{-# LANGUAGE OverloadedStrings #-}

-- | This is a partial implementation of Web SSO using the HTTP Post Binding [2/3.5].
--
-- The default API offers 3 end-points: one for retrieving the 'AuthnRequest' in a redirect to the
-- IdP; one for delivering the 'AuthnResponse' that will re-direct to some fixed landing page; and
-- one for retrieving the SP's metadata.
--
-- There are other scenarios, e.g. all resources on the page could be guarded with an authentication
-- check and redirect the client to the IdP, and make sure that the client lands on the initally
-- requested resource after successful authentication.  With the building blocks provided by this
-- module, it should be straight-forward to implemented all of these scenarios.
--
-- This module works best if imported qualified.
--
-- FUTUREWORK: servant-server is quite heavy.  we should have a cabal flag to exclude it.
module SAML2.WebSSO.API
  ( module SAML2.WebSSO.API,
    module SAML2.WebSSO.Servant,
  )
where

import Control.Lens hiding (element)
import Control.Monad hiding (ap)
import Control.Monad.Except
import Data.ByteString.Base64.Lazy qualified as EL (decodeLenient, encode)
import Data.ByteString.Lazy qualified as LBS
import Data.CaseInsensitive qualified as CI
import Data.EitherR
import Data.List qualified as L
import Data.List.NonEmpty
import Data.Map qualified as Map
import Data.Maybe (mapMaybe)
import Data.Proxy
import Data.String.Conversions
import Data.Text qualified as ST
import Data.Text.Lazy qualified as LT
import Data.Time
import GHC.Generics
import SAML2.Util
import SAML2.WebSSO.API.UnvalidatedSAMLStatus
import SAML2.WebSSO.Config
import SAML2.WebSSO.Cookie qualified as Cky
import SAML2.WebSSO.Error as SamlErr
import SAML2.WebSSO.SP
import SAML2.WebSSO.Servant
import SAML2.WebSSO.Types
import SAML2.WebSSO.XML
import Servant.API as Servant hiding (URI (..))
import Servant.Multipart
import Servant.Server
import System.Logger (Level (..))
import Text.Hamlet.XML
import Text.Show.Pretty (ppShow)
import Text.XML
import Text.XML.Cursor
import Text.XML.DSig
import Text.XML.HXT.Core (XmlTree)
import URI.ByteString

----------------------------------------------------------------------
-- saml web-sso api

type APIMeta = Get '[XML] SPMetadata

type APIAuthReq = Capture "idp" IdPId :> Get '[HTML] (FormRedirect AuthnRequest)

type APIAuthResp = MultipartForm Mem AuthnResponseBody :> PostRedir '[HTML] (WithCookieAndLocation ST)

type APIMeta' = "meta" :> APIMeta

type APIAuthReq' = "authreq" :> APIAuthReq

type APIAuthResp' = "authresp" :> APIAuthResp

-- | Consider rate-limiting these end-points to mitigate DOS attacks.  'APIAuthReq' uses database
-- space, and 'APIAuthResp' uses both database space and CPU.
type API =
  APIMeta'
    :<|> APIAuthReq'
    :<|> APIAuthResp'

-- | The 'Issuer' is an identifier of a SAML participant.  In this case, it's the SP, ie.,
-- ourselves.  For simplicity, we re-use the response URI here.
defSPIssuer :: (Functor m, HasConfig m) => m Issuer
defSPIssuer :: forall (m :: * -> *). (Functor m, HasConfig m) => m Issuer
defSPIssuer = URI -> Issuer
Issuer (URI -> Issuer) -> m URI -> m Issuer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m URI
forall (m :: * -> *). (Functor m, HasConfig m) => m URI
defResponseURI

-- | The URI that 'AuthnResponse' values are delivered to ('APIAuthResp').
defResponseURI :: (Functor m, HasConfig m) => m URI
defResponseURI :: forall (m :: * -> *). (Functor m, HasConfig m) => m URI
defResponseURI = Proxy API -> Proxy APIAuthResp' -> m URI
forall (m :: * -> *) endpoint api.
(HasCallStack, Functor m, HasConfig m, IsElem endpoint api,
 HasLink endpoint, ToHttpApiData (MkLink endpoint Link)) =>
Proxy api -> Proxy endpoint -> m URI
getSsoURINoMultiIngress (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @API) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @APIAuthResp')

defContactPersons :: (Functor m, HasConfig m) => m [ContactPerson]
defContactPersons :: forall (m :: * -> *). (Functor m, HasConfig m) => m [ContactPerson]
defContactPersons = MultiIngressDomainConfig -> [ContactPerson]
_cfgContacts (MultiIngressDomainConfig -> [ContactPerson])
-> m MultiIngressDomainConfig -> m [ContactPerson]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m MultiIngressDomainConfig
forall (m :: * -> *).
(HasConfig m, Functor m) =>
m MultiIngressDomainConfig
getMultiIngressDomainConfigNoMultiIngress

----------------------------------------------------------------------
-- authentication response body processing

-- | An 'AuthnResponseBody' contains a 'AuthnResponse', but you need to give it an SPId for
-- IdP lookup and trust base for signature verification first.  As a consequence, you will get
-- the signature validation error when looking at it, but the type still guarantees that the
-- signature verification cannot be circumvented.
data AuthnResponseBody = AuthnResponseBody
  { AuthnResponseBody
-> forall (m :: * -> *) err spid extra.
   (SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m,
    extra ~ IdPConfigExtra m) =>
   Maybe spid
   -> m (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus)
authnResponseBodyAction ::
      forall m err spid extra.
      (SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m, extra ~ IdPConfigExtra m) =>
      Maybe spid ->
      m (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus),
    AuthnResponseBody -> MultipartData Mem
authnResponseBodyRaw :: MultipartData Mem
    -- FUTUREWORK: this is only for dumping the error on the "something went wrong" page.  we
    -- should find a better solution there and remove it here.
  }

-- | Implies verification, hence the constraints and the optional service provider ID (needed for IdP lookup).
parseAuthnResponseBody ::
  forall m err spid extra.
  (SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m, extra ~ IdPConfigExtra m) =>
  Maybe spid ->
  ST ->
  m (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus)
parseAuthnResponseBody :: forall (m :: * -> *) err spid extra.
(SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m,
 extra ~ IdPConfigExtra m) =>
Maybe spid
-> ST
-> m (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus)
parseAuthnResponseBody Maybe spid
mbSPId ST
base64 = do
  -- https://www.ietf.org/rfc/rfc4648.txt states that all "noise" characters should be rejected
  -- unless another standard says they should be ignored.  'EL.decodeLenient' chooses the radical
  -- approach and ignores all "noise" characters.  since we have to deal with at least %0a, %0d%0a,
  -- '=', and probably other noise, this seems the safe thing to do.  It is no less secure than
  -- rejecting some noise characters and ignoring others.
  let LBS
xmltxt :: LBS = LBS -> LBS
EL.decodeLenient (ST -> LBS
forall a b. ConvertibleStrings a b => a -> b
cs ST
base64 :: LBS)
      mkErr :: String -> Error err
mkErr String
errmsg = LT -> Error err
forall err. LT -> Error err
BadSamlResponseXmlError (ST -> LT
forall a b. ConvertibleStrings a b => a -> b
cs (ST -> LT) -> ST -> LT
forall a b. (a -> b) -> a -> b
$ ST
"error message: " ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> String -> ST
forall a b. ConvertibleStrings a b => a -> b
cs String
errmsg ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> ST
"; base64-encoded saml authentication response: " ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> ST
base64)

  (signedAssertions, idp, status) <- do
    resp <-
      -- do not use `resp` as a result of `parseAuthnResponseBody`!  only use what comes back
      -- from `simpleVerifyAuthnResponse`!
      (String -> m AuthnResponse)
-> (AuthnResponse -> m AuthnResponse)
-> Either String AuthnResponse
-> m AuthnResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Error err -> m AuthnResponse
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error err -> m AuthnResponse)
-> (String -> Error err) -> String -> m AuthnResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Error err
mkErr) AuthnResponse -> m AuthnResponse
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String AuthnResponse -> m AuthnResponse)
-> Either String AuthnResponse -> m AuthnResponse
forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a.
(HasXMLRoot a, MonadError String m) =>
LT -> m a
decode @_ @AuthnResponse (LBS -> LT
forall a b. ConvertibleStrings a b => a -> b
cs LBS
xmltxt)
    issuer <- do
      respIssuer :: Issuer <-
        -- this issuer is not signed!!  but we'll check it anyway, just for good measure and
        -- because the standard says so.
        maybe (throwError BadSamlResponseIssuerMissing) pure (resp ^. rspIssuer)
      signedIssuers :: NonEmpty Issuer <-
        -- these are *possibly* signed, but we collect all of them, and if none of them are
        -- signed, signature validation will fail later.
        pure (view assIssuer <$> resp ^. rspPayload)
      case L.nub (respIssuer : toList signedIssuers) of
        [Issuer
i] -> Issuer -> m Issuer
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Issuer
i
        [Issuer]
_ -> Error err -> m Issuer
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error err
forall err. Error err
BadSamlResponseInconsistentIdPIssuerInfo

    idp :: IdPConfig extra <-
      -- this is convoluted, but secure against signatures from rogue idps: this idp config
      -- contains a public key Pub associated with private key Priv, and issuer Iss; it is
      -- provided by the team admin and thus works as a trust root.  On the other hand, the
      -- authentication response contains a mention of isuser Iss signed by Priv.
      -- See also: 'verdictHandlerResultCore'
      getIdPConfigByIssuerOptionalSPId issuer mbSPId
    creds <- idpToCreds issuer idp
    (,idp,mkUnvalidatedSAMLStatus (resp ^. rspStatus)) <$> simpleVerifyAuthnResponse creds xmltxt
  pure (signedAssertions, idp, status)

instance FromMultipart Mem AuthnResponseBody where
  fromMultipart :: MultipartData Mem -> Either String AuthnResponseBody
fromMultipart MultipartData Mem
resp = AuthnResponseBody -> Either String AuthnResponseBody
forall a b. b -> Either a b
Right ((forall (m :: * -> *) err spid extra.
 (SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m,
  extra ~ IdPConfigExtra m) =>
 Maybe spid
 -> m (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus))
-> MultipartData Mem -> AuthnResponseBody
AuthnResponseBody Maybe spid
-> m (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus)
forall (m :: * -> *) err spid extra.
(SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m,
 extra ~ IdPConfigExtra m) =>
Maybe spid
-> m (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus)
eval MultipartData Mem
resp)
    where
      eval ::
        forall m err spid extra.
        (SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m, extra ~ IdPConfigExtra m) =>
        Maybe spid ->
        m (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus)
      eval :: forall (m :: * -> *) err spid extra.
(SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m,
 extra ~ IdPConfigExtra m) =>
Maybe spid
-> m (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus)
eval Maybe spid
mbSPId = do
        base64 <-
          (String -> m ST) -> (ST -> m ST) -> Either String ST -> m ST
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m ST -> String -> m ST
forall a b. a -> b -> a
const (m ST -> String -> m ST) -> m ST -> String -> m ST
forall a b. (a -> b) -> a -> b
$ Error err -> m ST
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error err
forall err. Error err
BadSamlResponseFormFieldMissing) ST -> m ST
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ST -> m ST) -> Either String ST -> m ST
forall a b. (a -> b) -> a -> b
$
            ST -> MultipartData Mem -> Either String ST
forall tag. ST -> MultipartData tag -> Either String ST
lookupInput ST
"SAMLResponse" MultipartData Mem
resp
        parseAuthnResponseBody mbSPId base64

issuerToCreds :: forall m err. (SPStoreIdP (Error err) m) => Maybe Issuer -> Maybe (IdPConfigSPId m) -> m (NonEmpty SignCreds)
issuerToCreds :: forall (m :: * -> *) err.
SPStoreIdP (Error err) m =>
Maybe Issuer -> Maybe (IdPConfigSPId m) -> m (NonEmpty SignCreds)
issuerToCreds Maybe Issuer
Nothing Maybe (IdPConfigSPId m)
_ = Error err -> m (NonEmpty SignCreds)
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error err
forall err. Error err
BadSamlResponseIssuerMissing
issuerToCreds (Just Issuer
issuer) Maybe (IdPConfigSPId m)
mbSPId = Issuer -> IdPConfig (IdPConfigExtra m) -> m (NonEmpty SignCreds)
forall (m :: * -> *) err extra.
(SPStoreIdP (Error err) m, extra ~ IdPConfigExtra m) =>
Issuer -> IdPConfig extra -> m (NonEmpty SignCreds)
idpToCreds Issuer
issuer (IdPConfig (IdPConfigExtra m) -> m (NonEmpty SignCreds))
-> m (IdPConfig (IdPConfigExtra m)) -> m (NonEmpty SignCreds)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Issuer
-> Maybe (IdPConfigSPId m) -> m (IdPConfig (IdPConfigExtra m))
forall err (m :: * -> *).
SPStoreIdP err m =>
Issuer
-> Maybe (IdPConfigSPId m) -> m (IdPConfig (IdPConfigExtra m))
getIdPConfigByIssuerOptionalSPId Issuer
issuer Maybe (IdPConfigSPId m)
mbSPId

idpToCreds ::
  forall m err extra.
  (SPStoreIdP (Error err) m, extra ~ IdPConfigExtra m) =>
  Issuer ->
  IdPConfig extra ->
  m (NonEmpty SignCreds)
idpToCreds :: forall (m :: * -> *) err extra.
(SPStoreIdP (Error err) m, extra ~ IdPConfigExtra m) =>
Issuer -> IdPConfig extra -> m (NonEmpty SignCreds)
idpToCreds Issuer
issuer IdPConfig extra
idp = do
  let certs :: NonEmpty SignedCertificate
certs = IdPConfig extra
idp IdPConfig extra
-> Getting
     (NonEmpty SignedCertificate)
     (IdPConfig extra)
     (NonEmpty SignedCertificate)
-> NonEmpty SignedCertificate
forall s a. s -> Getting a s a -> a
^. (IdPMetadata -> Const (NonEmpty SignedCertificate) IdPMetadata)
-> IdPConfig extra
-> Const (NonEmpty SignedCertificate) (IdPConfig extra)
forall extra (f :: * -> *).
Functor f =>
(IdPMetadata -> f IdPMetadata)
-> IdPConfig extra -> f (IdPConfig extra)
idpMetadata ((IdPMetadata -> Const (NonEmpty SignedCertificate) IdPMetadata)
 -> IdPConfig extra
 -> Const (NonEmpty SignedCertificate) (IdPConfig extra))
-> ((NonEmpty SignedCertificate
     -> Const (NonEmpty SignedCertificate) (NonEmpty SignedCertificate))
    -> IdPMetadata -> Const (NonEmpty SignedCertificate) IdPMetadata)
-> Getting
     (NonEmpty SignedCertificate)
     (IdPConfig extra)
     (NonEmpty SignedCertificate)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty SignedCertificate
 -> Const (NonEmpty SignedCertificate) (NonEmpty SignedCertificate))
-> IdPMetadata -> Const (NonEmpty SignedCertificate) IdPMetadata
Lens' IdPMetadata (NonEmpty SignedCertificate)
edCertAuthnResponse
  let err :: String -> m SignCreds
err = Error err -> m SignCreds
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error err -> m SignCreds)
-> (String -> Error err) -> String -> m SignCreds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LT -> Error err
forall err. LT -> Error err
InvalidCert (LT -> Error err) -> (String -> LT) -> String -> Error err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Issuer -> LT
forall a. HasXML a => a -> LT
encodeElem Issuer
issuer LT -> LT -> LT
forall a. Semigroup a => a -> a -> a
<> LT
": ") LT -> LT -> LT
forall a. Semigroup a => a -> a -> a
<>) (LT -> LT) -> (String -> LT) -> String -> LT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LT
forall a b. ConvertibleStrings a b => a -> b
cs
  NonEmpty SignedCertificate
-> (SignedCertificate -> m SignCreds) -> m (NonEmpty SignCreds)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty SignedCertificate
certs ((SignedCertificate -> m SignCreds) -> m (NonEmpty SignCreds))
-> (SignedCertificate -> m SignCreds) -> m (NonEmpty SignCreds)
forall a b. (a -> b) -> a -> b
$ (String -> m SignCreds)
-> (SignCreds -> m SignCreds)
-> Either String SignCreds
-> m SignCreds
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m SignCreds
err SignCreds -> m SignCreds
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String SignCreds -> m SignCreds)
-> (SignedCertificate -> Either String SignCreds)
-> SignedCertificate
-> m SignCreds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignedCertificate -> Either String SignCreds
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SignedCertificate -> m SignCreds
certToCreds

-- | Pull assertions sub-forest and pass unparsed xml input to 'verify' with a reference to
-- each assertion individually.  The input must be a valid 'AuthnResponse'.  All assertions
-- need to be signed by the issuer given in the arguments using the same key.
--
-- The assertions are returned.
--
-- NEVER PROCESS AN ASSERTION NOT RETURNED BY A SIGNATURE VERifICATION FUNCTION.
--
-- `simpleVerifyAuthnResponse` ensures that the assertion list is non-empty, and (more
-- importantly) that the IDs are unique accross the entire document we pass to the signature
-- validation function.  REASON: since we use xml-conduit as a parser here, and signature
-- validation uses a different one, we can't guarantee that the assertions we return here are
-- the ones of which we validated the signatures.  this problem can get very real very
-- quickly:
-- https://github.blog/security/sign-in-as-anyone-bypassing-saml-sso-authentication-with-parser-differentials
simpleVerifyAuthnResponse :: forall m err. (MonadError (Error err) m) => NonEmpty SignCreds -> LBS -> m (NonEmpty Assertion)
simpleVerifyAuthnResponse :: forall (m :: * -> *) err.
MonadError (Error err) m =>
NonEmpty SignCreds -> LBS -> m (NonEmpty Assertion)
simpleVerifyAuthnResponse NonEmpty SignCreds
creds LBS
raw = do
  let err :: a -> m a
err = Error err -> m a
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error err -> m a) -> (a -> Error err) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LT -> Error err
forall err. LT -> Error err
BadSamlResponseSamlError (LT -> Error err) -> (a -> LT) -> a -> Error err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LT
forall a b. ConvertibleStrings a b => a -> b
cs (String -> LT) -> (a -> String) -> a -> LT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
  doc :: Cursor <- do
    (SomeException -> m Cursor)
-> (Document -> m Cursor)
-> Either SomeException Document
-> m Cursor
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> m Cursor
forall {err} {m :: * -> *} {a} {a}.
(MonadError (Error err) m, Show a) =>
a -> m a
err (Cursor -> m Cursor
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cursor -> m Cursor)
-> (Document -> Cursor) -> Document -> m Cursor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Cursor
fromDocument) (ParseSettings -> LBS -> Either SomeException Document
parseLBS ParseSettings
forall a. Default a => a
def LBS
raw)
  assertions :: NonEmpty Element <- do
    let elemOnly (NodeElement Element
el) = Element -> Maybe Element
forall a. a -> Maybe a
Just Element
el
        elemOnly Node
_ = Maybe Element
forall a. Maybe a
Nothing
    case mapMaybe (elemOnly . node) (doc $/ element "{urn:oasis:names:tc:SAML:2.0:assertion}Assertion") of
      [] -> Error err -> m (NonEmpty Element)
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error err
forall err. Error err
BadSamlResponseNoAssertions
      Element
hd : [Element]
tl -> NonEmpty Element -> m (NonEmpty Element)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element
hd Element -> [Element] -> NonEmpty Element
forall a. a -> [a] -> NonEmpty a
:| [Element]
tl)
  nodeids :: NonEmpty String <- do
    let assertionID :: Element -> m String
        assertionID (Element Name
_ Map Name ST
attrs [Node]
_) =
          m String -> (ST -> m String) -> Maybe ST -> m String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Error err -> m String
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error err
forall err. Error err
BadSamlResponseAssertionWithoutID) (String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> (ST -> String) -> ST -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> String
forall a b. ConvertibleStrings a b => a -> b
cs) (Maybe ST -> m String) -> Maybe ST -> m String
forall a b. (a -> b) -> a -> b
$
            Name -> Map Name ST -> Maybe ST
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
"ID" Map Name ST
attrs
    assertionID `mapM` assertions
  allVerifies creds raw nodeids

-- | Call verify and, if that fails, any work-arounds we have.  Discard all errors from
-- work-arounds, and throw the error from the regular verification.
allVerifies :: forall m err. (MonadError (Error err) m) => NonEmpty SignCreds -> LBS -> NonEmpty String -> m (NonEmpty Assertion)
allVerifies :: forall (m :: * -> *) err.
MonadError (Error err) m =>
NonEmpty SignCreds
-> LBS -> NonEmpty String -> m (NonEmpty Assertion)
allVerifies NonEmpty SignCreds
creds LBS
raw NonEmpty String
nodeids = do
  let workArounds :: Either (Error (ZonkAny 0)) (NonEmpty XmlTree)
workArounds = NonEmpty SignCreds
-> LBS
-> NonEmpty String
-> Either (Error (ZonkAny 0)) (NonEmpty XmlTree)
forall err (m :: * -> *).
MonadError (Error err) m =>
NonEmpty SignCreds
-> LBS -> NonEmpty String -> m (NonEmpty XmlTree)
verifyADFS NonEmpty SignCreds
creds LBS
raw NonEmpty String
nodeids
  xmls :: NonEmpty XmlTree <- case NonEmpty SignCreds -> LBS -> String -> Either String XmlTree
forall (m :: * -> *).
MonadError String m =>
NonEmpty SignCreds -> LBS -> String -> m XmlTree
verify NonEmpty SignCreds
creds LBS
raw (String -> Either String XmlTree)
-> NonEmpty String -> Either String (NonEmpty XmlTree)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
`mapM` NonEmpty String
nodeids of
    Right NonEmpty XmlTree
assertions -> NonEmpty XmlTree -> m (NonEmpty XmlTree)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty XmlTree
assertions
    Left String
err -> case Either (Error (ZonkAny 0)) (NonEmpty XmlTree)
workArounds of
      Right NonEmpty XmlTree
ws -> NonEmpty XmlTree -> m (NonEmpty XmlTree)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty XmlTree
ws
      Left Error (ZonkAny 0)
_ -> Error err -> m (NonEmpty XmlTree)
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error err -> m (NonEmpty XmlTree))
-> (LT -> Error err) -> LT -> m (NonEmpty XmlTree)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LT -> Error err
forall err. LT -> Error err
BadSamlResponseInvalidSignature (LT -> m (NonEmpty XmlTree)) -> LT -> m (NonEmpty XmlTree)
forall a b. (a -> b) -> a -> b
$ String -> LT
forall a b. ConvertibleStrings a b => a -> b
cs String
err
  (renderVerifyErrorHack . parseFromXmlTree) `mapM` xmls
  where
    -- (there must be a better way for this, but where?)
    renderVerifyErrorHack :: forall m' err' a. (MonadError (Error err') m') => Either String a -> m' a
    renderVerifyErrorHack :: forall (m' :: * -> *) err' a.
MonadError (Error err') m' =>
Either String a -> m' a
renderVerifyErrorHack = (Error err' -> m' a)
-> (a -> m' a) -> Either (Error err') a -> m' a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error err' -> m' a
forall a. Error err' -> m' a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> m' a
forall a. a -> m' a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Error err') a -> m' a)
-> (Either String a -> Either (Error err') a)
-> Either String a
-> m' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Error err') -> Either String a -> Either (Error err') a
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL (LT -> Error err'
forall err. LT -> Error err
BadSamlResponseSamlError (LT -> Error err') -> (String -> LT) -> String -> Error err'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LT
LT.pack)

-- | ADFS illegally breaks whitespace after signing documents; here we try to fix that.
-- https://github.com/wireapp/wire-server/issues/656
-- (This may also have been a copy&paste issue in customer support, but let's just leave it in just in case.)
verifyADFS :: (MonadError (Error err) m) => NonEmpty SignCreds -> LBS -> NonEmpty String -> m (NonEmpty XmlTree)
verifyADFS :: forall err (m :: * -> *).
MonadError (Error err) m =>
NonEmpty SignCreds
-> LBS -> NonEmpty String -> m (NonEmpty XmlTree)
verifyADFS NonEmpty SignCreds
creds LBS
raw NonEmpty String
nodeids = do
  (Error err -> m (NonEmpty XmlTree))
-> (NonEmpty XmlTree -> m (NonEmpty XmlTree))
-> Either (Error err) (NonEmpty XmlTree)
-> m (NonEmpty XmlTree)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Error err -> m (NonEmpty XmlTree)
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError NonEmpty XmlTree -> m (NonEmpty XmlTree)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Error err) (NonEmpty XmlTree) -> m (NonEmpty XmlTree))
-> (Either String (NonEmpty XmlTree)
    -> Either (Error err) (NonEmpty XmlTree))
-> Either String (NonEmpty XmlTree)
-> m (NonEmpty XmlTree)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Error err)
-> Either String (NonEmpty XmlTree)
-> Either (Error err) (NonEmpty XmlTree)
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL (LT -> Error err
forall err. LT -> Error err
BadSamlResponseXmlError (LT -> Error err) -> (String -> LT) -> String -> Error err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LT
LT.pack) (Either String (NonEmpty XmlTree) -> m (NonEmpty XmlTree))
-> Either String (NonEmpty XmlTree) -> m (NonEmpty XmlTree)
forall a b. (a -> b) -> a -> b
$
    NonEmpty SignCreds -> LBS -> String -> Either String XmlTree
forall (m :: * -> *).
MonadError String m =>
NonEmpty SignCreds -> LBS -> String -> m XmlTree
verify NonEmpty SignCreds
creds (LBS -> LBS
tweak LBS
raw) (String -> Either String XmlTree)
-> NonEmpty String -> Either String (NonEmpty XmlTree)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
`mapM` NonEmpty String
nodeids
  where
    tweak :: LBS -> LBS
    tweak :: LBS -> LBS
tweak LBS
"" = LBS
""
    tweak LBS
rw = case (Int64 -> LBS -> (LBS, LBS)
LBS.splitAt Int64
3 LBS
rw, Int64 -> LBS -> (LBS, LBS)
LBS.splitAt Int64
1 LBS
rw) of
      ((LBS
"> <", LBS
tl), (LBS, LBS)
_) -> LBS
"><" LBS -> LBS -> LBS
forall a. Semigroup a => a -> a -> a
<> LBS -> LBS
tweak LBS
tl
      ((LBS, LBS)
_, (LBS
hd, LBS
tl)) -> LBS
hd LBS -> LBS -> LBS
forall a. Semigroup a => a -> a -> a
<> LBS -> LBS
tweak LBS
tl

----------------------------------------------------------------------
-- form redirect

-- | [2/3.5.4]
data FormRedirect xml = FormRedirect URI xml
  deriving (FormRedirect xml -> FormRedirect xml -> Bool
(FormRedirect xml -> FormRedirect xml -> Bool)
-> (FormRedirect xml -> FormRedirect xml -> Bool)
-> Eq (FormRedirect xml)
forall xml. Eq xml => FormRedirect xml -> FormRedirect xml -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall xml. Eq xml => FormRedirect xml -> FormRedirect xml -> Bool
== :: FormRedirect xml -> FormRedirect xml -> Bool
$c/= :: forall xml. Eq xml => FormRedirect xml -> FormRedirect xml -> Bool
/= :: FormRedirect xml -> FormRedirect xml -> Bool
Eq, Int -> FormRedirect xml -> ShowS
[FormRedirect xml] -> ShowS
FormRedirect xml -> String
(Int -> FormRedirect xml -> ShowS)
-> (FormRedirect xml -> String)
-> ([FormRedirect xml] -> ShowS)
-> Show (FormRedirect xml)
forall xml. Show xml => Int -> FormRedirect xml -> ShowS
forall xml. Show xml => [FormRedirect xml] -> ShowS
forall xml. Show xml => FormRedirect xml -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall xml. Show xml => Int -> FormRedirect xml -> ShowS
showsPrec :: Int -> FormRedirect xml -> ShowS
$cshow :: forall xml. Show xml => FormRedirect xml -> String
show :: FormRedirect xml -> String
$cshowList :: forall xml. Show xml => [FormRedirect xml] -> ShowS
showList :: [FormRedirect xml] -> ShowS
Show, (forall x. FormRedirect xml -> Rep (FormRedirect xml) x)
-> (forall x. Rep (FormRedirect xml) x -> FormRedirect xml)
-> Generic (FormRedirect xml)
forall x. Rep (FormRedirect xml) x -> FormRedirect xml
forall x. FormRedirect xml -> Rep (FormRedirect xml) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall xml x. Rep (FormRedirect xml) x -> FormRedirect xml
forall xml x. FormRedirect xml -> Rep (FormRedirect xml) x
$cfrom :: forall xml x. FormRedirect xml -> Rep (FormRedirect xml) x
from :: forall x. FormRedirect xml -> Rep (FormRedirect xml) x
$cto :: forall xml x. Rep (FormRedirect xml) x -> FormRedirect xml
to :: forall x. Rep (FormRedirect xml) x -> FormRedirect xml
Generic)

class (HasXML xml) => HasFormRedirect xml where
  formRedirectFieldName :: xml -> ST

instance HasFormRedirect AuthnRequest where
  formRedirectFieldName :: AuthnRequest -> ST
formRedirectFieldName AuthnRequest
_ = ST
"SAMLRequest"

instance (HasXMLRoot xml) => MimeRender HTML (FormRedirect xml) where
  mimeRender :: Proxy HTML -> FormRedirect xml -> LBS
mimeRender
    (Proxy HTML
Proxy :: Proxy HTML)
    (FormRedirect (ByteString -> ST
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> ST) -> (URI -> ByteString) -> URI -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' -> ST
uri) (LBS -> ST
forall a b. ConvertibleStrings a b => a -> b
cs (LBS -> ST) -> (xml -> LBS) -> xml -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LBS -> LBS
EL.encode (LBS -> LBS) -> (xml -> LBS) -> xml -> LBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LT -> LBS
forall a b. ConvertibleStrings a b => a -> b
cs (LT -> LBS) -> (xml -> LT) -> xml -> LBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. xml -> LT
forall a. HasXMLRoot a => a -> LT
encode -> ST
value)) =
      [Node] -> LBS
mkHtml
        [xml|
                 <body onload="document.forms[0].submit()">
                   <noscript>
                     <p>
                       <strong>
                         Note:
                       Since your browser does not support JavaScript, you must press the Continue button once to proceed.
                   <form action=#{uri} method="post" accept-charset="utf-8">
                     <input type="hidden" name="SAMLRequest" value=#{value}>
                     <noscript>
                       <input type="submit" value="Continue">
             |]

instance (HasXMLRoot xml) => Servant.MimeUnrender HTML (FormRedirect xml) where
  mimeUnrender :: Proxy HTML -> LBS -> Either String (FormRedirect xml)
mimeUnrender Proxy HTML
Proxy LBS
lbs = do
    cursor <- (SomeException -> String)
-> Either SomeException Cursor -> Either String Cursor
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL SomeException -> String
forall a. Show a => a -> String
show (Either SomeException Cursor -> Either String Cursor)
-> Either SomeException Cursor -> Either String Cursor
forall a b. (a -> b) -> a -> b
$ Document -> Cursor
fromDocument (Document -> Cursor)
-> Either SomeException Document -> Either SomeException Cursor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseSettings -> LBS -> Either SomeException Document
parseLBS ParseSettings
forall a. Default a => a
def LBS
lbs
    let formAction :: [ST] = cursor $// element "{http://www.w3.org/1999/xhtml}form" >=> attribute "action"
        formBody :: [ST] = cursor $// element "{http://www.w3.org/1999/xhtml}input" >=> attributeIs "name" "SAMLRequest" >=> attribute "value"
    uri <- fmapL (<> (": " <> show formAction)) . parseURI' $ mconcat formAction
    resp <- fmapL (<> (": " <> show formBody)) . decode . cs . EL.decodeLenient . cs $ mconcat formBody
    pure $ FormRedirect uri resp

----------------------------------------------------------------------
-- handlers

meta ::
  forall m err.
  (SPStore m, MonadError err m, HasConfig m) =>
  ST ->
  m Issuer ->
  m URI ->
  m [ContactPerson] ->
  m SPMetadata
meta :: forall (m :: * -> *) err.
(SPStore m, MonadError err m, HasConfig m) =>
ST -> m Issuer -> m URI -> m [ContactPerson] -> m SPMetadata
meta ST
appName m Issuer
getRequestIssuer m URI
getResponseURI m [ContactPerson]
getContactPersons = do
  String -> m ()
forall (m :: * -> *). SP m => String -> m ()
enterH String
"meta"
  Issuer org <- m Issuer
getRequestIssuer
  resp <- getResponseURI
  contacts <- getContactPersons
  mkSPMetadata appName org resp contacts

-- | Create authnreq, store it for comparison against assertions later, and return it in an HTTP
-- redirect together with the IdP's URI.
authreq ::
  (SPStore m, SPStoreIdP err m, MonadError err m) =>
  NominalDiffTime ->
  m Issuer ->
  IdPId ->
  m (FormRedirect AuthnRequest)
authreq :: forall (m :: * -> *) err.
(SPStore m, SPStoreIdP err m, MonadError err m) =>
NominalDiffTime
-> m Issuer -> IdPId -> m (FormRedirect AuthnRequest)
authreq NominalDiffTime
lifeExpectancySecs m Issuer
getSPIssuer IdPId
idpid = do
  String -> m ()
forall (m :: * -> *). SP m => String -> m ()
enterH String
"authreq"
  idp <- IdPId -> m (IdPConfig (IdPConfigExtra m))
forall err (m :: * -> *).
SPStoreIdP err m =>
IdPId -> m (IdPConfig (IdPConfigExtra m))
getIdPConfig IdPId
idpid
  let uri = IdPConfig (IdPConfigExtra m)
idp IdPConfig (IdPConfigExtra m)
-> Getting URI (IdPConfig (IdPConfigExtra m)) URI -> URI
forall s a. s -> Getting a s a -> a
^. (IdPMetadata -> Const URI IdPMetadata)
-> IdPConfig (IdPConfigExtra m)
-> Const URI (IdPConfig (IdPConfigExtra m))
forall extra (f :: * -> *).
Functor f =>
(IdPMetadata -> f IdPMetadata)
-> IdPConfig extra -> f (IdPConfig extra)
idpMetadata ((IdPMetadata -> Const URI IdPMetadata)
 -> IdPConfig (IdPConfigExtra m)
 -> Const URI (IdPConfig (IdPConfigExtra m)))
-> ((URI -> Const URI URI) -> IdPMetadata -> Const URI IdPMetadata)
-> Getting URI (IdPConfig (IdPConfigExtra m)) URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (URI -> Const URI URI) -> IdPMetadata -> Const URI IdPMetadata
Lens' IdPMetadata URI
edRequestURI
      idpiss = IdPConfig (IdPConfigExtra m)
idp IdPConfig (IdPConfigExtra m)
-> Getting Issuer (IdPConfig (IdPConfigExtra m)) Issuer -> Issuer
forall s a. s -> Getting a s a -> a
^. (IdPMetadata -> Const Issuer IdPMetadata)
-> IdPConfig (IdPConfigExtra m)
-> Const Issuer (IdPConfig (IdPConfigExtra m))
forall extra (f :: * -> *).
Functor f =>
(IdPMetadata -> f IdPMetadata)
-> IdPConfig extra -> f (IdPConfig extra)
idpMetadata ((IdPMetadata -> Const Issuer IdPMetadata)
 -> IdPConfig (IdPConfigExtra m)
 -> Const Issuer (IdPConfig (IdPConfigExtra m)))
-> ((Issuer -> Const Issuer Issuer)
    -> IdPMetadata -> Const Issuer IdPMetadata)
-> Getting Issuer (IdPConfig (IdPConfigExtra m)) Issuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Issuer -> Const Issuer Issuer)
-> IdPMetadata -> Const Issuer IdPMetadata
Lens' IdPMetadata Issuer
edIssuer
  logger Debug $ "authreq uri: " <> cs (renderURI uri)
  req <- do
    spiss <- getSPIssuer
    createAuthnRequest lifeExpectancySecs spiss idpiss
  logger Debug $ "authreq req: " <> cs (encode req)
  leaveH $ FormRedirect uri req

-- | 'authreq' with request life expectancy defaulting to 8 hours.
authreq' ::
  (SPStore m, SPStoreIdP err m, MonadError err m) =>
  m Issuer ->
  IdPId ->
  m (FormRedirect AuthnRequest)
authreq' :: forall (m :: * -> *) err.
(SPStore m, SPStoreIdP err m, MonadError err m) =>
m Issuer -> IdPId -> m (FormRedirect AuthnRequest)
authreq' = NominalDiffTime
-> m Issuer -> IdPId -> m (FormRedirect AuthnRequest)
forall (m :: * -> *) err.
(SPStore m, SPStoreIdP err m, MonadError err m) =>
NominalDiffTime
-> m Issuer -> IdPId -> m (FormRedirect AuthnRequest)
authreq NominalDiffTime
defReqTTL

defReqTTL :: NominalDiffTime
defReqTTL :: NominalDiffTime
defReqTTL = NominalDiffTime
15 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60 -- seconds

-- | parse and validate response, and pass the verdict to a user-provided verdict handler.  the
-- handler takes a response and a verdict (provided by this package), and can cause any effects in
-- 'm' and return anything it likes.
authresp ::
  (SPStoreIdP (Error err) m, SPStoreRequest AuthnRequest m, extra ~ IdPConfigExtra m, SPStore m) =>
  Maybe (IdPConfigSPId m) ->
  m Issuer ->
  m URI ->
  (NonEmpty Assertion -> IdPConfig extra -> AccessVerdict -> m resp) ->
  AuthnResponseBody ->
  m resp
authresp :: forall err (m :: * -> *) extra resp.
(SPStoreIdP (Error err) m, SPStoreRequest AuthnRequest m,
 extra ~ IdPConfigExtra m, SPStore m) =>
Maybe (IdPConfigSPId m)
-> m Issuer
-> m URI
-> (NonEmpty Assertion
    -> IdPConfig extra -> AccessVerdict -> m resp)
-> AuthnResponseBody
-> m resp
authresp Maybe (IdPConfigSPId m)
mbSPId m Issuer
getSPIssuer m URI
getResponseURI NonEmpty Assertion -> IdPConfig extra -> AccessVerdict -> m resp
handleVerdictAction AuthnResponseBody
body = do
  String -> m ()
forall (m :: * -> *). SP m => String -> m ()
enterH String
"authresp: entering"
  jctx :: JudgeCtx <- Issuer -> URI -> JudgeCtx
JudgeCtx (Issuer -> URI -> JudgeCtx) -> m Issuer -> m (URI -> JudgeCtx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Issuer
getSPIssuer m (URI -> JudgeCtx) -> m URI -> m JudgeCtx
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m URI
getResponseURI
  (assertions :: NonEmpty Assertion, idp :: IdPConfig extra, status :: UnvalidatedSAMLStatus) <- authnResponseBodyAction body mbSPId
  logger Debug $ "authresp: " <> ppShow (jctx, assertions, idp, status)
  verdict <- judge assertions status jctx
  logger Debug $ "authresp: " <> show verdict
  handleVerdictAction assertions idp verdict

-- | a variant of 'authresp' with a less general verdict handler.
authresp' ::
  forall m err extra.
  (SPStoreIdP (Error err) m, SP m, MonadError (Error err) m, SPStore m, extra ~ IdPConfigExtra m) =>
  Maybe (IdPConfigSPId m) ->
  m Issuer ->
  m URI ->
  HandleVerdict m ->
  AuthnResponseBody ->
  m (WithCookieAndLocation ST)
authresp' :: forall (m :: * -> *) err extra.
(SPStoreIdP (Error err) m, SP m, MonadError (Error err) m,
 SPStore m, extra ~ IdPConfigExtra m) =>
Maybe (IdPConfigSPId m)
-> m Issuer
-> m URI
-> HandleVerdict m
-> AuthnResponseBody
-> m (WithCookieAndLocation ST)
authresp' Maybe (IdPConfigSPId m)
mbSPId m Issuer
getRequestIssuerURI m URI
getResponseURI HandleVerdict m
handleVerdict AuthnResponseBody
body = do
  let handleVerdictAction :: NonEmpty Assertion -> IdPConfig extra -> AccessVerdict -> m (WithCookieAndLocation ST)
      handleVerdictAction :: NonEmpty Assertion
-> IdPConfig extra -> AccessVerdict -> m (WithCookieAndLocation ST)
handleVerdictAction NonEmpty Assertion
resp IdPConfig extra
_idp AccessVerdict
verdict = case HandleVerdict m
handleVerdict of
        HandleVerdictRedirect OnSuccessRedirect m
onsuccess -> OnSuccessRedirect m
-> AccessVerdict -> m (WithCookieAndLocation ST)
forall (m :: * -> *) err.
(SP m, MonadError (Error err) m) =>
OnSuccessRedirect m
-> AccessVerdict -> m (WithCookieAndLocation ST)
simpleHandleVerdict OnSuccessRedirect m
onsuccess AccessVerdict
verdict
        HandleVerdictRaw NonEmpty Assertion -> AccessVerdict -> m ResponseVerdict
action -> Error err -> m (WithCookieAndLocation ST)
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error err -> m (WithCookieAndLocation ST))
-> (ResponseVerdict -> Error err)
-> ResponseVerdict
-> m (WithCookieAndLocation ST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerError -> Error err
forall err. ServerError -> Error err
CustomServant (ServerError -> Error err)
-> (ResponseVerdict -> ServerError) -> ResponseVerdict -> Error err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResponseVerdict -> ServerError
unResponseVerdict (ResponseVerdict -> m (WithCookieAndLocation ST))
-> m ResponseVerdict -> m (WithCookieAndLocation ST)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NonEmpty Assertion -> AccessVerdict -> m ResponseVerdict
action NonEmpty Assertion
resp AccessVerdict
verdict
  Maybe (IdPConfigSPId m)
-> m Issuer
-> m URI
-> (NonEmpty Assertion
    -> IdPConfig extra
    -> AccessVerdict
    -> m (WithCookieAndLocation ST))
-> AuthnResponseBody
-> m (WithCookieAndLocation ST)
forall err (m :: * -> *) extra resp.
(SPStoreIdP (Error err) m, SPStoreRequest AuthnRequest m,
 extra ~ IdPConfigExtra m, SPStore m) =>
Maybe (IdPConfigSPId m)
-> m Issuer
-> m URI
-> (NonEmpty Assertion
    -> IdPConfig extra -> AccessVerdict -> m resp)
-> AuthnResponseBody
-> m resp
authresp Maybe (IdPConfigSPId m)
mbSPId m Issuer
getRequestIssuerURI m URI
getResponseURI NonEmpty Assertion
-> IdPConfig extra -> AccessVerdict -> m (WithCookieAndLocation ST)
handleVerdictAction AuthnResponseBody
body

type OnSuccessRedirect m = UserRef -> m (Cky, URI)

type WithCookieAndLocation = Headers '[Servant.Header "Set-Cookie" Cky, Servant.Header "Location" URI]

type Cky = Cky.SimpleSetCookie CookieName

type CookieName = "saml2-web-sso"

data SubjectFoldCase
  = SubjectFoldCase
  | SubjectDontFoldCase

simpleOnSuccess ::
  (Monad m, SP m) =>
  SubjectFoldCase ->
  OnSuccessRedirect m
simpleOnSuccess :: forall (m :: * -> *).
(Monad m, SP m) =>
SubjectFoldCase -> OnSuccessRedirect m
simpleOnSuccess SubjectFoldCase
foldCase UserRef
uid = do
  cky <- ByteString
-> Maybe (ST, NominalDiffTime) -> m (SimpleSetCookie CookieName)
forall (name :: Symbol) (m :: * -> *).
(Applicative m, SP m, KnownSymbol name) =>
ByteString
-> Maybe (ST, NominalDiffTime) -> m (SimpleSetCookie name)
Cky.toggleCookie ByteString
"/" (Maybe (ST, NominalDiffTime) -> m (SimpleSetCookie CookieName))
-> Maybe (ST, NominalDiffTime) -> m (SimpleSetCookie CookieName)
forall a b. (a -> b) -> a -> b
$ (ST, NominalDiffTime) -> Maybe (ST, NominalDiffTime)
forall a. a -> Maybe a
Just (UserRef -> ST
userRefToST UserRef
uid, NominalDiffTime
defReqTTL)
  appuri <- (^. cfgSPAppURI) <$> getMultiIngressDomainConfigNoMultiIngress
  pure (cky, appuri)
  where
    userRefToST :: UserRef -> ST
    userRefToST :: UserRef -> ST
userRefToST (UserRef (Issuer URI
tenant) NameID
subject) = ST
"{" ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> URI -> ST
renderURI URI
tenant ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> ST
"}" ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> NameID -> ST
renderSubject NameID
subject
    renderSubject :: NameID -> ST
renderSubject NameID
subject =
      case SubjectFoldCase
foldCase of
        SubjectFoldCase
SubjectFoldCase -> CI ST -> ST
forall s. CI s -> s
CI.foldedCase (NameID -> CI ST
nameIDToST NameID
subject)
        SubjectFoldCase
SubjectDontFoldCase -> CI ST -> ST
forall s. CI s -> s
CI.original (NameID -> CI ST
nameIDToST NameID
subject)

-- | We support two cases: redirect with a cookie, and a generic response with arbitrary status,
-- headers, and body.  The latter case fits the 'ServerError' type well, but we give it a more
-- suitable name here.
data HandleVerdict m
  = HandleVerdictRedirect (OnSuccessRedirect m)
  | HandleVerdictRaw (NonEmpty Assertion -> AccessVerdict -> m ResponseVerdict)

newtype ResponseVerdict = ResponseVerdict {ResponseVerdict -> ServerError
unResponseVerdict :: ServerError}
  deriving (ResponseVerdict -> ResponseVerdict -> Bool
(ResponseVerdict -> ResponseVerdict -> Bool)
-> (ResponseVerdict -> ResponseVerdict -> Bool)
-> Eq ResponseVerdict
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResponseVerdict -> ResponseVerdict -> Bool
== :: ResponseVerdict -> ResponseVerdict -> Bool
$c/= :: ResponseVerdict -> ResponseVerdict -> Bool
/= :: ResponseVerdict -> ResponseVerdict -> Bool
Eq, Int -> ResponseVerdict -> ShowS
[ResponseVerdict] -> ShowS
ResponseVerdict -> String
(Int -> ResponseVerdict -> ShowS)
-> (ResponseVerdict -> String)
-> ([ResponseVerdict] -> ShowS)
-> Show ResponseVerdict
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResponseVerdict -> ShowS
showsPrec :: Int -> ResponseVerdict -> ShowS
$cshow :: ResponseVerdict -> String
show :: ResponseVerdict -> String
$cshowList :: [ResponseVerdict] -> ShowS
showList :: [ResponseVerdict] -> ShowS
Show)

simpleHandleVerdict ::
  (SP m, MonadError (Error err) m) =>
  OnSuccessRedirect m ->
  AccessVerdict ->
  m (WithCookieAndLocation ST)
simpleHandleVerdict :: forall (m :: * -> *) err.
(SP m, MonadError (Error err) m) =>
OnSuccessRedirect m
-> AccessVerdict -> m (WithCookieAndLocation ST)
simpleHandleVerdict OnSuccessRedirect m
onsuccess = \case
  AccessDenied [DeniedReason]
reasons ->
    Level -> String -> m ()
forall (m :: * -> *). HasLogger m => Level -> String -> m ()
logger Level
Debug ([DeniedReason] -> String
forall a. Show a => a -> String
show [DeniedReason]
reasons) m ()
-> m (WithCookieAndLocation ST) -> m (WithCookieAndLocation ST)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Error err -> m (WithCookieAndLocation ST)
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error err -> m (WithCookieAndLocation ST))
-> (ST -> Error err) -> ST -> m (WithCookieAndLocation ST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LT -> Error err
forall err. LT -> Error err
Forbidden (LT -> Error err) -> (ST -> LT) -> ST -> Error err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> LT
forall a b. ConvertibleStrings a b => a -> b
cs (ST -> m (WithCookieAndLocation ST))
-> ST -> m (WithCookieAndLocation ST)
forall a b. (a -> b) -> a -> b
$ ST -> [ST] -> ST
ST.intercalate ST
"; " (DeniedReason -> ST
explainDeniedReason (DeniedReason -> ST) -> [DeniedReason] -> [ST]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DeniedReason]
reasons))
  AccessGranted UserRef
uid ->
    OnSuccessRedirect m
onsuccess UserRef
uid m (SimpleSetCookie CookieName, URI)
-> ((SimpleSetCookie CookieName, URI) -> WithCookieAndLocation ST)
-> m (WithCookieAndLocation ST)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(SimpleSetCookie CookieName
setcookie, URI
uri) ->
      SimpleSetCookie CookieName
-> Headers '[Header' '[Optional, Strict] "Location" URI] ST
-> WithCookieAndLocation ST
forall (h :: Symbol) v orig new.
AddHeader '[Optional, Strict] h v orig new =>
v -> orig -> new
addHeader SimpleSetCookie CookieName
setcookie (Headers '[Header' '[Optional, Strict] "Location" URI] ST
 -> WithCookieAndLocation ST)
-> Headers '[Header' '[Optional, Strict] "Location" URI] ST
-> WithCookieAndLocation ST
forall a b. (a -> b) -> a -> b
$ URI
-> ST -> Headers '[Header' '[Optional, Strict] "Location" URI] ST
forall (h :: Symbol) v orig new.
AddHeader '[Optional, Strict] h v orig new =>
v -> orig -> new
addHeader URI
uri (ST
"SSO successful, redirecting to " ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> URI -> ST
renderURI URI
uri)

----------------------------------------------------------------------
-- handler combinators

enterH :: (SP m) => String -> m ()
enterH :: forall (m :: * -> *). SP m => String -> m ()
enterH String
msg =
  Level -> String -> m ()
forall (m :: * -> *). HasLogger m => Level -> String -> m ()
logger Level
Debug (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"entering handler: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg

leaveH :: (Monad m, Show a, SP m) => a -> m a
leaveH :: forall (m :: * -> *) a. (Monad m, Show a, SP m) => a -> m a
leaveH a
x = do
  Level -> String -> m ()
forall (m :: * -> *). HasLogger m => Level -> String -> m ()
logger Level
Debug (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"leaving handler: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x
  a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x