{-# 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)

  (NonEmpty Assertion
signedAssertions, IdPConfig extra
idp, UnvalidatedSAMLStatus
status) <- do
    AuthnResponse
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
issuer <- do
      Issuer
respIssuer :: Issuer <-
        -- this issuer is not signed!!  but we'll check it anyway, just for good measure and
        -- because the standard says so.
        m Issuer -> (Issuer -> m Issuer) -> Maybe Issuer -> m Issuer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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
BadSamlResponseIssuerMissing) Issuer -> m Issuer
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthnResponse
resp AuthnResponse
-> Getting (Maybe Issuer) AuthnResponse (Maybe Issuer)
-> Maybe Issuer
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Issuer) AuthnResponse (Maybe Issuer)
forall payload (f :: * -> *).
Functor f =>
(Maybe Issuer -> f (Maybe Issuer))
-> Response payload -> f (Response payload)
rspIssuer)
      NonEmpty Issuer
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.
        NonEmpty Issuer -> m (NonEmpty Issuer)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Getting Issuer Assertion Issuer -> Assertion -> Issuer
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Issuer Assertion Issuer
Lens' Assertion Issuer
assIssuer (Assertion -> Issuer) -> NonEmpty Assertion -> NonEmpty Issuer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AuthnResponse
resp AuthnResponse
-> Getting (NonEmpty Assertion) AuthnResponse (NonEmpty Assertion)
-> NonEmpty Assertion
forall s a. s -> Getting a s a -> a
^. Getting (NonEmpty Assertion) AuthnResponse (NonEmpty Assertion)
forall payload (f :: * -> *).
Functor f =>
(payload -> f payload) -> Response payload -> f (Response payload)
rspPayload)
      case [Issuer] -> [Issuer]
forall a. Eq a => [a] -> [a]
L.nub (Issuer
respIssuer Issuer -> [Issuer] -> [Issuer]
forall a. a -> [a] -> [a]
: NonEmpty Issuer -> [Issuer]
forall a. NonEmpty a -> [a]
toList NonEmpty Issuer
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

    IdPConfig extra
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'
      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 spid
Maybe (IdPConfigSPId m)
mbSPId
    NonEmpty SignCreds
creds <- Issuer -> IdPConfig extra -> m (NonEmpty SignCreds)
forall (m :: * -> *) err extra.
(SPStoreIdP (Error err) m, extra ~ IdPConfigExtra m) =>
Issuer -> IdPConfig extra -> m (NonEmpty SignCreds)
idpToCreds Issuer
issuer IdPConfig extra
idp
    (,IdPConfig extra
idp,Status -> UnvalidatedSAMLStatus
mkUnvalidatedSAMLStatus (AuthnResponse
resp AuthnResponse -> Getting Status AuthnResponse Status -> Status
forall s a. s -> Getting a s a -> a
^. Getting Status AuthnResponse Status
forall payload (f :: * -> *).
Functor f =>
(Status -> f Status) -> Response payload -> f (Response payload)
rspStatus)) (NonEmpty Assertion
 -> (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus))
-> m (NonEmpty Assertion)
-> m (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty SignCreds -> LBS -> m (NonEmpty Assertion)
forall (m :: * -> *) err.
MonadError (Error err) m =>
NonEmpty SignCreds -> LBS -> m (NonEmpty Assertion)
simpleVerifyAuthnResponse NonEmpty SignCreds
creds LBS
xmltxt
  (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus)
-> m (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty Assertion
signedAssertions, IdPConfig extra
idp, UnvalidatedSAMLStatus
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
        ST
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
        Maybe spid
-> ST
-> m (NonEmpty Assertion, IdPConfig extra, UnvalidatedSAMLStatus)
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

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) -> (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
  Cursor
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)
  NonEmpty Element
assertions :: NonEmpty Element <- do
    let elemOnly :: Node -> Maybe Element
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 (Cursor -> Maybe Element) -> [Cursor] -> [Element]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Node -> Maybe Element
elemOnly (Node -> Maybe Element)
-> (Cursor -> Node) -> Cursor -> Maybe Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> Node
forall node. Cursor node -> node
node) (Cursor
doc Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Cursor -> [Cursor]
element Name
"{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)
  NonEmpty String
nodeids :: NonEmpty String <- do
    let assertionID :: Element -> m String
        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
    Element -> m String
assertionID (Element -> m String) -> NonEmpty Element -> m (NonEmpty String)
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 Element
assertions
  NonEmpty SignCreds
-> LBS -> NonEmpty String -> m (NonEmpty Assertion)
forall (m :: * -> *) err.
MonadError (Error err) m =>
NonEmpty SignCreds
-> LBS -> NonEmpty String -> m (NonEmpty Assertion)
allVerifies NonEmpty SignCreds
creds LBS
raw NonEmpty String
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 Any) (NonEmpty XmlTree)
workArounds = NonEmpty SignCreds
-> LBS -> NonEmpty String -> Either (Error Any) (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
  NonEmpty XmlTree
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 Any) (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 Any
_ -> 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
  (Either String Assertion -> m Assertion
forall (m' :: * -> *) err' a.
MonadError (Error err') m' =>
Either String a -> m' a
renderVerifyErrorHack (Either String Assertion -> m Assertion)
-> (XmlTree -> Either String Assertion) -> XmlTree -> m Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Either String Assertion
forall (m :: * -> *) a.
(MonadError String m, HasXML a) =>
XmlTree -> m a
parseFromXmlTree) (XmlTree -> m Assertion)
-> NonEmpty XmlTree -> m (NonEmpty Assertion)
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 XmlTree
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
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 [ST]
formAction :: [ST] = Cursor
cursor Cursor -> (Cursor -> [ST]) -> [ST]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Name -> Cursor -> [Cursor]
element Name
"{http://www.w3.org/1999/xhtml}form" (Cursor -> [Cursor]) -> (Cursor -> [ST]) -> Cursor -> [ST]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [ST]
attribute Name
"action"
        [ST]
formBody :: [ST] = Cursor
cursor Cursor -> (Cursor -> [ST]) -> [ST]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Name -> Cursor -> [Cursor]
element Name
"{http://www.w3.org/1999/xhtml}input" (Cursor -> [Cursor]) -> (Cursor -> [ST]) -> Cursor -> [ST]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> ST -> Cursor -> [Cursor]
attributeIs Name
"name" ST
"SAMLRequest" (Cursor -> [Cursor]) -> (Cursor -> [ST]) -> Cursor -> [ST]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [ST]
attribute Name
"value"
    URI
uri <- ShowS -> Either String URI -> Either String URI
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [ST] -> String
forall a. Show a => a -> String
show [ST]
formAction)) (Either String URI -> Either String URI)
-> (ST -> Either String URI) -> ST -> Either String URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> Either String URI
forall (m :: * -> *). MonadError String m => ST -> m URI
parseURI' (ST -> Either String URI) -> ST -> Either String URI
forall a b. (a -> b) -> a -> b
$ [ST] -> ST
forall a. Monoid a => [a] -> a
mconcat [ST]
formAction
    xml
resp <- ShowS -> Either String xml -> Either String xml
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [ST] -> String
forall a. Show a => a -> String
show [ST]
formBody)) (Either String xml -> Either String xml)
-> (ST -> Either String xml) -> ST -> Either String xml
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LT -> Either String xml
forall (m :: * -> *) a.
(HasXMLRoot a, MonadError String m) =>
LT -> m a
decode (LT -> Either String xml) -> (ST -> LT) -> ST -> Either String xml
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LBS -> LT
forall a b. ConvertibleStrings a b => a -> b
cs (LBS -> LT) -> (ST -> LBS) -> ST -> LT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LBS -> LBS
EL.decodeLenient (LBS -> LBS) -> (ST -> LBS) -> ST -> LBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> LBS
forall a b. ConvertibleStrings a b => a -> b
cs (ST -> Either String xml) -> ST -> Either String xml
forall a b. (a -> b) -> a -> b
$ [ST] -> ST
forall a. Monoid a => [a] -> a
mconcat [ST]
formBody
    FormRedirect xml -> Either String (FormRedirect xml)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormRedirect xml -> Either String (FormRedirect xml))
-> FormRedirect xml -> Either String (FormRedirect xml)
forall a b. (a -> b) -> a -> b
$ URI -> xml -> FormRedirect xml
forall xml. URI -> xml -> FormRedirect xml
FormRedirect URI
uri xml
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 URI
org <- m Issuer
getRequestIssuer
  URI
resp <- m URI
getResponseURI
  [ContactPerson]
contacts <- m [ContactPerson]
getContactPersons
  ST -> URI -> URI -> [ContactPerson] -> m SPMetadata
forall (m :: * -> *).
(Monad m, SP m) =>
ST -> URI -> URI -> [ContactPerson] -> m SPMetadata
mkSPMetadata ST
appName URI
org URI
resp [ContactPerson]
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"
  IdPConfig (IdPConfigExtra m)
idp <- IdPId -> m (IdPConfig (IdPConfigExtra m))
forall err (m :: * -> *).
SPStoreIdP err m =>
IdPId -> m (IdPConfig (IdPConfigExtra m))
getIdPConfig IdPId
idpid
  let uri :: URI
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 :: Issuer
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
  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
"authreq uri: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ST -> String
forall a b. ConvertibleStrings a b => a -> b
cs (URI -> ST
renderURI URI
uri)
  AuthnRequest
req <- do
    Issuer
spiss <- m Issuer
getSPIssuer
    NominalDiffTime -> Issuer -> Issuer -> m AuthnRequest
forall (m :: * -> *).
(Monad m, SP m, SPStore m) =>
NominalDiffTime -> Issuer -> Issuer -> m AuthnRequest
createAuthnRequest NominalDiffTime
lifeExpectancySecs Issuer
spiss Issuer
idpiss
  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
"authreq req: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> LT -> String
forall a b. ConvertibleStrings a b => a -> b
cs (AuthnRequest -> LT
forall a. HasXMLRoot a => a -> LT
encode AuthnRequest
req)
  FormRedirect AuthnRequest -> m (FormRedirect AuthnRequest)
forall (m :: * -> *) a. (Monad m, Show a, SP m) => a -> m a
leaveH (FormRedirect AuthnRequest -> m (FormRedirect AuthnRequest))
-> FormRedirect AuthnRequest -> m (FormRedirect AuthnRequest)
forall a b. (a -> b) -> a -> b
$ URI -> AuthnRequest -> FormRedirect AuthnRequest
forall xml. URI -> xml -> FormRedirect xml
FormRedirect URI
uri AuthnRequest
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"
  JudgeCtx
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
  (NonEmpty Assertion
assertions :: NonEmpty Assertion, IdPConfig extra
idp :: IdPConfig extra, UnvalidatedSAMLStatus
status :: UnvalidatedSAMLStatus) <- 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 AuthnResponseBody
body Maybe (IdPConfigSPId m)
mbSPId
  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
"authresp: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (JudgeCtx, NonEmpty Assertion, IdPConfig extra,
 UnvalidatedSAMLStatus)
-> String
forall a. Show a => a -> String
ppShow (JudgeCtx
jctx, NonEmpty Assertion
assertions, IdPConfig extra
idp, UnvalidatedSAMLStatus
status)
  AccessVerdict
verdict <- NonEmpty Assertion
-> UnvalidatedSAMLStatus -> JudgeCtx -> m AccessVerdict
forall (m :: * -> *).
(Monad m, SP m, SPStore m) =>
NonEmpty Assertion
-> UnvalidatedSAMLStatus -> JudgeCtx -> m AccessVerdict
judge NonEmpty Assertion
assertions UnvalidatedSAMLStatus
status JudgeCtx
jctx
  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
"authresp: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> AccessVerdict -> String
forall a. Show a => a -> String
show AccessVerdict
verdict
  NonEmpty Assertion -> IdPConfig extra -> AccessVerdict -> m resp
handleVerdictAction NonEmpty Assertion
assertions IdPConfig extra
idp AccessVerdict
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
cky <- ByteString -> Maybe (ST, NominalDiffTime) -> m Cky
forall (name :: Symbol) (m :: * -> *).
(Applicative m, SP m, KnownSymbol name) =>
ByteString
-> Maybe (ST, NominalDiffTime) -> m (SimpleSetCookie name)
Cky.toggleCookie ByteString
"/" (Maybe (ST, NominalDiffTime) -> m Cky)
-> Maybe (ST, NominalDiffTime) -> m Cky
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)
  URI
appuri <- (MultiIngressDomainConfig
-> Getting URI MultiIngressDomainConfig URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI MultiIngressDomainConfig URI
Lens' MultiIngressDomainConfig URI
cfgSPAppURI) (MultiIngressDomainConfig -> URI)
-> m MultiIngressDomainConfig -> m URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m MultiIngressDomainConfig
forall (m :: * -> *).
(HasConfig m, Functor m) =>
m MultiIngressDomainConfig
getMultiIngressDomainConfigNoMultiIngress
  (Cky, URI) -> m (Cky, URI)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cky
cky, URI
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 (Cky, URI)
-> ((Cky, URI) -> WithCookieAndLocation ST)
-> m (WithCookieAndLocation ST)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Cky
setcookie, URI
uri) ->
      Cky
-> 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 Cky
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