First of all, Happy New Year! I look forward to IHP’s continue growth in 2024!
I am looking at the feasibility of adopting IHP for our high performance computing center at the university, which uses Shibboleth as our SSO solution. How can IHP be integrated with a SAML2-based SSO? Ideally, I want to continue to use ensureIsUser and ensureIsAdmin to handle authorization.
Happy new year! Great to hear you plan to use IHP for this 
I’ve implemented SAML based auth once in one of our projects. You need to install the saml2-web-sso package from hackage and then use it as follows:
module Web.Controller.Sessions where
import Web.Controller.Prelude
import Web.View.Sessions.New
import Web.View.Sessions.NewWithEmail
import Web.View.Sessions.NewWithSAML
import qualified IHP.AuthSupport.Controller.Sessions as Sessions
import qualified IHP.AuthSupport.Lockable as Lockable
import qualified Network.Wreq as Wreq
import qualified Jose.Jwk as Jwk
import qualified Jose.Jwt as Jwt
import Control.Lens hiding ((|>), set)
import qualified Data.Aeson as Aeson
import qualified Config
import Web.Controller.Users (fillUtm, cleanupGuestUser, trackReferral)
import Web.Mail.Users.Welcome
instance Controller SessionsController where
action NewSessionAction = Sessions.newSessionAction @User
action NewSessionWithEmailAction = do
let user = newRecord @User
render NewWithEmailView { .. }
action NewSessionWithSAMLAction = do
let user = newRecord @User
render NewWithSAMLView { .. }
action CreateSessionAction = Sessions.createSessionAction @User
action DeleteSessionAction = Sessions.deleteSessionAction @User
action CreateSessionWithSAMLAction = do
maybeCompany <- findCompanyByDomain (userEmailDomain' (paramText "email"))
case maybeCompany of
Just company -> do
identityProvider <- company
|> get #identityProviders
|> fetchOneOrNothing
case identityProvider of
Just identityProvider -> redirectTo SAMLAuthRequestAction { identityProviderId = get #id identityProvider }
Nothing -> do
setErrorMessage "We could find a company account, but SAML has not been enabled for your account. Try to sign in via email"
redirectTo NewSessionAction
Nothing -> do
setErrorMessage "There's no identity provider connected to your email address. Contact support@digitallyinduced.com to get help"
redirectTo NewSessionAction
module Web.Controller.SAML where
import Web.Controller.Prelude
import qualified SAML2.WebSSO.API as WebSSO
import qualified SAML2.WebSSO.API.Example as WebSSO
import qualified SAML2.WebSSO.Config as WebSSO
import qualified SAML2.WebSSO.Types as WebSSO
import qualified SAML2.WebSSO.XML as XML
import qualified SAML2.WebSSO.SP as WebSSO
import qualified SAML2.WebSSO.Error as WebSSO
import URI.ByteString.QQ
import URI.ByteString
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.X509 as X509
import qualified Data.PEM as PEM
import qualified Data.Either as Either
import qualified Servant.API.ContentTypes as Servant
import qualified Text.Blaze.Html as Blaze
import qualified Prelude
import qualified Data.Text as Text
import Control.Monad.Except
import qualified Data.TMap as TMap
import Control.Concurrent.MVar
import qualified Data.ByteString.Builder as ByteString
import qualified Data.CaseInsensitive as CI
import qualified IHP.AuthSupport.Lockable as Lockable
import qualified Web.Controller.Sessions
import qualified IHP.AuthSupport.Controller.Sessions as Sessions
import Web.Mail.Users.Welcome
import qualified Data.ByteString.Base64 as Base64
import qualified SAML2.Core
import qualified Text.XML
import qualified SAML2.XML
import qualified Text.XML.HXT.Core as HXT
import qualified Data.Tree.NTree.TypeDefs as HXT
import qualified Control.Monad.Error as Error
instance Controller SAMLController where
action SAMLMetaAction = do
context <- makeWebSSOContext
meta <- WebSSO.runSimpleSP context do
WebSSO.meta "virtualoffice.team" WebSSO.defSPIssuer WebSSO.defResponseURI
case meta of
Left someError -> someError
|> tshow
|> error
Right meta -> meta
|> XML.encode
|> cs
|> renderXml
action SAMLAuthRequestAction { identityProviderId } = do
let idpId = WebSSO.IdPId (unpack identityProviderId)
context <- makeWebSSOContext
formRedirect <- WebSSO.runSimpleSP context do
WebSSO.authreq' WebSSO.defSPIssuer idpId
case formRedirect of
Left someError -> someError
|> tshow
|> error
Right formRedirect -> do
let html = Servant.mimeRender (Proxy :: Proxy WebSSO.HTML) formRedirect
respondHtml (Blaze.unsafeLazyByteString html)
action SAMLAuthResponseAction = do
let samlResponse = paramText "SAMLResponse"
let authnResponseBody = WebSSO.AuthnResponseBody (WebSSO.parseAuthnResponseBody samlResponse) (error "AuthnResponseBody: not fully initialized")
context <- makeWebSSOContext
result <- WebSSO.runSimpleSP context do
WebSSO.authresp WebSSO.defSPIssuer WebSSO.defResponseURI handleVerdict authnResponseBody
case result of
Left e -> do
setErrorMessage (tshow e)
redirectTo NewSessionAction
Right _ -> renderPlain "ok"
makeWebSSOContext :: _ => _
makeWebSSOContext = do
idps <- fetchIdpConfigs
pure $ WebSSO.SimpleSPCtx ssoConfig idps requestStore assertionStore
handleVerdict :: _ => WebSSO.AuthnResponse -> WebSSO.AccessVerdict -> WebSSO.SimpleSP ()
handleVerdict authnResponse accessVerdict = do
case accessVerdict of
WebSSO.AccessDenied reasons -> do
WebSSO.logger WebSSO.Debug (Prelude.show reasons)
(throwError . WebSSO.Forbidden . cs $ Text.intercalate "; " (XML.explainDeniedReason <$> reasons))
WebSSO.AccessGranted uid -> liftIO $ handleAccessGranted authnResponse uid
handleAccessGranted :: _ => WebSSO.AuthnResponse -> WebSSO.UserRef -> IO ()
handleAccessGranted authnResponse uid = do
setSuccessMessage "logged in"
let issuer :: Text = uid
|> get #_uidTenant
|> get #_fromIssuer
|> serializeURIRef
|> ByteString.toLazyByteString
|> cs
idp <- query @IdentityProvider
|> filterWhere (#issuer, issuer)
|> fetchOne
company <- fetch (get #companyId idp)
let nameId = CI.foldedCase (WebSSO.nameIDToST (get #_uidSubject uid)) -- The saml user name
let statements = authnResponse
|> get #_rspPayload
|> NonEmpty.head
|> get #_assContents
|> get #_sasStatements
let
findAttributeStatementValue' :: Text -> Maybe Text
findAttributeStatementValue' name =
statements
|> NonEmpty.toList
|> mapMaybe (\case
(WebSSO.AttributeStatement (SAML2.Core.AttributeStatement attributes)) -> Just (attributes |> NonEmpty.toList)
_ -> Nothing
)
|> join
|> mapMaybe (\case
SAML2.Core.NotEncrypted (SAML2.Core.Attribute { attributeName, attributeValues }) | attributeName == (cs name) -> Just attributeValues
_ -> Nothing
)
|> \case
[[[HXT.NTree (HXT.XText value) _]]] -> Just (cs value)
_ -> Nothing
findAttributeStatementValue :: Text -> Text
findAttributeStatementValue name = findAttributeStatementValue' name |> fromMaybe ""
existingUser <- query @User
|> filterWhere (#companyId, get #id company)
|> filterWhere (#samlNameId, Just nameId)
|> fetchOneOrNothing
case existingUser of
Just user -> do
isLocked <- Lockable.isLocked user
when isLocked do
setErrorMessage "User is locked"
redirectTo NewSessionAction
Sessions.beforeLogin user
login user
user <- user
|> set #failedLoginAttempts 0
|> updateRecord
redirectUrl <- getSessionAndClear "IHP.LoginSupport.redirectAfterLogin"
redirectToPath (fromMaybe (Sessions.afterLoginRedirectPath @User) redirectUrl)
Nothing -> do
randomPassword <- generateAuthenticationToken
hashed <- hashPassword randomPassword
let firstname = findAttributeStatementValue "http://schemas.xmlsoap.org/ws/2005/05/identity/claims/givenname"
let lastname = findAttributeStatementValue "http://schemas.xmlsoap.org/ws/2005/05/identity/claims/surname"
let email = findAttributeStatementValue "http://schemas.xmlsoap.org/ws/2005/05/identity/claims/emailaddress"
user <- newRecord @User
|> set #firstname firstname
|> set #lastname lastname
|> set #passwordHash hashed
|> set #companyId (get #id company)
|> set #isConfirmed True
|> set #email email
|> setJust #samlNameId nameId
|> createRecord
sendToSlackAsync ("New User joined via invite to existing team: " <> get #firstname user <> " " <> get #lastname user <> " with email " <> get #email user)
updateCompanySubscriptionSeats (get #companyId user)
sendMail WelcomeMail { .. }
login user
redirectTo OnboardingFinishedAction
ssoConfig :: (?context :: ControllerContext) => WebSSO.Config
ssoConfig = WebSSO.Config
{ _cfgLogLevel = WebSSO.Debug
, _cfgSPHost = "localhost" -- Not used
, _cfgSPPort = 8000 -- Not used
, _cfgSPAppURI = urlTo ShowDefaultFloorAction
|> cs
|> parseURI laxURIParserOptions
|> Either.fromRight (error "Invalid url")
, _cfgSPSsoURI = ?context
|> getFrameworkConfig
|> get #baseUrl
|> (\url -> url <> "/sso/")
|> cs
|> parseURI laxURIParserOptions
|> Either.fromRight (error "Invalid url")
, _cfgContacts = [
WebSSO.ContactPerson
{ _cntType = WebSSO.ContactSupport
, _cntCompany = Just $ WebSSO.mkXmlText "digitally induced GmbH"
, _cntGivenName = Just $ WebSSO.mkXmlText ""
, _cntSurname = Just $ WebSSO.mkXmlText ""
, _cntEmail = Just [uri|email:support@digitallyinduced.com|]
, _cntPhone = Nothing
}
]
}
fetchIdpConfigs :: (?modelContext :: ModelContext) => IO [WebSSO.IdPConfig_]
fetchIdpConfigs = do
idps <- query @IdentityProvider |> fetch
pure (map identityProviderToIdPConfig idps)
identityProviderToIdPConfig :: IdentityProvider -> WebSSO.IdPConfig_
identityProviderToIdPConfig idp = WebSSO.IdPConfig
{ _idpId = WebSSO.IdPId (unpack (get #id idp))
, _idpMetadata = WebSSO.IdPMetadata
{ _edIssuer = WebSSO.Issuer (unsafeParseUrl (get #issuer idp)) -- [uri|https://sts.windows.net/09f7a635-7dab-4621-bade-9c23d46403cb/|]
, _edRequestURI = (unsafeParseUrl (get #requestUrl idp)) -- [uri|https://login.microsoftonline.com/09f7a635-7dab-4621-bade-9c23d46403cb/saml2|]
, _edCertAuthnResponse = certs
}
, _idpExtraInfo = ()
}
where
unsafeParseUrl text =
text
|> cs
|> parseURI laxURIParserOptions
|> Either.fromRight (error "Invalid url")
certs =
idp
|> get #certAuthnResponse
|> cs
|> PEM.pemParseLBS
|> \case
Left message -> error (tshow message)
Right [pem] -> pem
|> get #pemContent
|> X509.decodeSignedCertificate
|> \case
Left message -> error ("failed to decode cert saved into db:" <> tshow message)
Right cert -> cert
|> \a -> NonEmpty.fromList [a]
requestStore :: (?context :: ControllerContext) => MVar WebSSO.RequestStore
requestStore = ?context
|> getFrameworkConfig
|> get #appConfig
|> TMap.lookup @(MVar WebSSO.RequestStore)
|> fromMaybe (error "Could not find RequestStore in config")
assertionStore :: (?context :: ControllerContext) => MVar WebSSO.AssertionStore
assertionStore = ?context
|> getFrameworkConfig
|> get #appConfig
|> TMap.lookup @(MVar WebSSO.AssertionStore)
|> fromMaybe (error "Could not find AssertionStore in config")
module Web.Types where
import IHP.Prelude
import IHP.ModelSupport
import Generated.Types
import qualified Data.Aeson as Aeson
import IHP.LoginSupport.Types
import qualified Network.WebSockets.Connection as WS
data WebApplication = WebApplication deriving (Eq, Show)
instance HasNewSessionUrl User where
newSessionUrl _ = "/NewSession"
type instance CurrentUserRecord = User
data SessionsController
= NewSessionAction
| NewSessionWithEmailAction
| NewSessionWithSAMLAction
| CreateSessionWithGoogleAction
| CreateSessionWithSAMLAction
| CreateSessionAction
| DeleteSessionAction
deriving (Eq, Show, Data)
data SAMLController
= SAMLMetaAction
| SAMLAuthRequestAction { identityProviderId :: !(Id IdentityProvider) }
| SAMLAuthResponseAction
deriving (Eq, Show, Data)
Here’s our nix package definition for the SSO package:
{ mkDerivation, aeson, asn1-encoding, asn1-parse, asn1-types, base
, base64-bytestring, binary, bytestring, case-insensitive
, containers, cookie, cryptonite, data-default, directory, dns
, email-validate, errors, exceptions, extra, filepath, foundation
, ghc-prim, hedgehog, hedgehog-quickcheck, hourglass, hpack, hsaml2
, hspec, hspec-core, hspec-discover, hspec-wai, http-media
, http-types, hxt, lens, lens-datetime, memory, mtl, network-uri
, pretty-show, process, QuickCheck, quickcheck-instances, random
, servant, servant-multipart, servant-server, shelly, silently
, stdenv, string-conversions, temporary, text, time, transformers
, uniplate, uri-bytestring, uuid, wai, wai-extra, warp, word8, x509
, xml-conduit, xml-conduit-writer, xml-hamlet, xml-types, yaml
, fetchFromGitHub
}:
mkDerivation {
pname = "saml2-web-sso";
version = "0.18";
src = fetchFromGitHub {
owner = "digitallyinduced";
repo = "saml2-web-sso";
rev = "21a00e88fef9e0e0dd1ff4c6f1d8b8bd41c29e89";
sha256 = "0azbm7g70ch8883l8f2c149p38i983kf8g4prflp2rmd9zq4ip0i";
};
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
aeson asn1-encoding asn1-parse asn1-types base base64-bytestring
binary bytestring case-insensitive containers cookie cryptonite
data-default directory dns email-validate errors exceptions extra
filepath foundation ghc-prim hedgehog hedgehog-quickcheck hourglass
hsaml2 hspec hspec-wai http-media http-types hxt lens lens-datetime
memory mtl network-uri pretty-show process QuickCheck
quickcheck-instances random servant servant-multipart
servant-server shelly silently string-conversions temporary text
time transformers uniplate uri-bytestring uuid wai wai-extra warp
word8 x509 xml-conduit xml-conduit-writer xml-hamlet xml-types yaml
];
libraryToolDepends = [ hpack ];
executableHaskellDepends = [
aeson asn1-encoding asn1-parse asn1-types base base64-bytestring
binary bytestring case-insensitive containers cookie cryptonite
data-default directory dns email-validate errors exceptions extra
filepath foundation ghc-prim hedgehog hedgehog-quickcheck hourglass
hsaml2 hspec hspec-wai http-media http-types hxt lens lens-datetime
memory mtl network-uri pretty-show process QuickCheck
quickcheck-instances random servant servant-multipart
servant-server shelly silently string-conversions temporary text
time transformers uniplate uri-bytestring uuid wai wai-extra warp
word8 x509 xml-conduit xml-conduit-writer xml-hamlet xml-types yaml
];
testHaskellDepends = [
aeson asn1-encoding asn1-parse asn1-types base base64-bytestring
binary bytestring case-insensitive containers cookie cryptonite
data-default directory dns email-validate errors exceptions extra
filepath foundation ghc-prim hedgehog hedgehog-quickcheck hourglass
hsaml2 hspec hspec-core hspec-discover hspec-wai http-media
http-types hxt lens lens-datetime memory mtl network-uri
pretty-show process QuickCheck quickcheck-instances random servant
servant-multipart servant-server shelly silently string-conversions
temporary text time transformers uniplate uri-bytestring uuid wai
wai-extra warp word8 x509 xml-conduit xml-conduit-writer xml-hamlet
xml-types yaml
];
testToolDepends = [ hspec-discover ];
prePatch = "hpack";
description = "Library and example web app for the SAML Web-based SSO profile";
license = stdenv.lib.licenses.agpl3;
}
It looks like we forked the package for some reason: GitHub - digitallyinduced/saml2-web-sso: Library and example web app for the SAML Web-based SSO profile.
module Config where
import IHP.Prelude
import IHP.Environment
import IHP.FrameworkConfig
import IHP.Mail.Types
import IHP.FileStorage.Config
import Application.Initializer
import qualified SAML2.WebSSO.API.Example as WebSSO
config :: ConfigBuilder
config = do
-- ...
initWebSSO
initWebSSO :: State.StateT TMap.TMap IO ()
initWebSSO = do
requestStore :: MVar WebSSO.RequestStore <- liftIO $ newMVar mempty
assertionStore :: MVar WebSSO.AssertionStore <- liftIO $ newMVar mempty
option requestStore
option assertionStore
@marc It’s great to have this! I think it could be even more accessible if we had a demo repo showcasing it in action. But I think that for that we’d need also some server to authenticate against. Do you have a recommendation to that?
Here’s our nix package definition for the SSO package:
Where is this one going?
But I think that for that we’d need also some server to authenticate against
Back then I’ve tested it by creating a microsoft Azure account and starting a trial for the SSO server product. Then I had to add test users to my azure organisation and then could log in with them. So it’s complicated.
Where is this one going?
Config/nix/haskell-packages/saml2-web-sso.nix
I think it could be even more accessible if we had a demo repo
We used it back then for getting a large enterprise client into our old virtualoffice.team product. Potentially we could open source that repo. But we need to check that it contains no hard coded secrets etc.
Thanks @marc! This might be simpler than I first thought.
Talking to our admins, we use an Apache HTTP module for Shibboleth SP to handle the SAML dance, so essentially, the Apache server will handle the redirects to IdP and login page. Then once logged in, the Shibboleth module will forward the user attributes as request headers to the target application (so in IHP’s case, we can setup Apache as a reverse proxy, but still have it handle the Shibboleth authentication).
So essentially, I just need IHP to initiate a user Session only when this header (which should contain the university ID for the user) exists. And in case it doesn’t exist, redirect to some error page.
From the code you provided, it looks like I just need to use getHeader to get the user ID, if Nothing, redirect to login/error page, if Just, query DB for user. If user doesn’t exist create the user, if user exists, load the user, and use it to login. Does that sound about right?
But I think that for that we’d need also some server to authenticate against. Do you have a recommendation to that?
@amitaibu, would this help?
I think it’s better to have something one can execute locally, rather than a service. Maybe something like this
@billksun would you up for spinning an example IHP repo dealing only with the SAML2 stuff?
Sounds great, much simpler this way.
Yes exactly
I haven’t responded to this challenge, mainly because I’ve been facing headwinds from my manager, so this project may not happen at all.
Being in the research university setting in the U.S., Python is strongly preferred, and I am against an application written on top of Django. This application is considered “mission critical” for my organization, which I think is much better suited to a statically typed language than Python. And it makes sense to bring in-house mission critical systems, especially when we have plans to expand and scale the capabilities of that system.
I saw an opportunity to move to Haskell here because I have to migrate our customizations of the said application to the newest upstream (0.02 → 1.1.5!). So not only do I have to re-implement our customizations, I also have to rework them to work with the newest upstream base. And preliminary investigation has shown that this will be very painful, to say the least. And even more so when you take into consideration that in order to keep up with upstream changes and security updates, we will have to migrate our ever increasing number of customizations frequently.
My manager isn’t technical, so it’s a little hard for me to convey the technical and operational advantages of rebuilding that application with a more robust language and having full control over the direction of the software.
His arguments are:
If anyone has any experience convincing managers or customers on adopting Haskell, I will be grateful to hear any advice or suggestions from you!
I have written this Haskell IHP Framework, from a Technical and Business Perspective
But, tbh, if your boss is against it, I’m not sure I’d recommend it; sounds too risky.