{-# 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 qualified Data.ByteString.Base64.Lazy as EL (decodeLenient, encode)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.CaseInsensitive as CI
import Data.Either (isRight)
import Data.EitherR
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import Data.Proxy
import Data.String.Conversions
import qualified Data.Text as ST
import Data.Time
import GHC.Generics
import SAML2.Util
import SAML2.WebSSO.Config
import qualified SAML2.WebSSO.Cookie 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 Text.Hamlet.XML
import Text.Show.Pretty (ppShow)
import Text.XML
import Text.XML.Cursor
import Text.XML.DSig
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'

api :: forall err m. SPHandler (Error err) m => ST -> HandleVerdict m -> ServerT API m
api :: forall err (m :: * -> *).
SPHandler (Error err) m =>
ST -> HandleVerdict m -> ServerT API m
api ST
appName HandleVerdict m
handleVerdict =
  ST -> m Issuer -> m URI -> m SPMetadata
forall (m :: * -> *) err.
(SPStore m, MonadError err m, HasConfig m) =>
ST -> m Issuer -> m URI -> m SPMetadata
meta ST
appName m Issuer
forall (m :: * -> *). (Functor m, HasConfig m) => m Issuer
defSPIssuer m URI
forall (m :: * -> *). (Functor m, HasConfig m) => m URI
defResponseURI
    m SPMetadata
-> ((IdPId -> m (FormRedirect AuthnRequest))
    :<|> (AuthnResponseBody -> m (WithCookieAndLocation ST)))
-> m SPMetadata
   :<|> ((IdPId -> m (FormRedirect AuthnRequest))
         :<|> (AuthnResponseBody -> m (WithCookieAndLocation ST)))
forall a b. a -> b -> a :<|> b
:<|> m Issuer -> IdPId -> m (FormRedirect AuthnRequest)
forall (m :: * -> *) err.
(SPStore m, SPStoreIdP err m, MonadError err m) =>
m Issuer -> IdPId -> m (FormRedirect AuthnRequest)
authreq' m Issuer
forall (m :: * -> *). (Functor m, HasConfig m) => m Issuer
defSPIssuer
    (IdPId -> m (FormRedirect AuthnRequest))
-> (AuthnResponseBody -> m (WithCookieAndLocation ST))
-> (IdPId -> m (FormRedirect AuthnRequest))
   :<|> (AuthnResponseBody -> m (WithCookieAndLocation ST))
forall a b. a -> b -> a :<|> b
:<|> Maybe (IdPConfigSPId m)
-> m Issuer
-> m URI
-> HandleVerdict m
-> AuthnResponseBody
-> m (WithCookieAndLocation ST)
forall (m :: * -> *) err.
(SP m, SPStoreIdP (Error err) m, SPStoreID Assertion m,
 SPStoreID AuthnRequest m) =>
Maybe (IdPConfigSPId m)
-> m Issuer
-> m URI
-> HandleVerdict m
-> AuthnResponseBody
-> m (WithCookieAndLocation ST)
authresp' Maybe (IdPConfigSPId m)
forall a. Maybe a
Nothing {- this is a lazy short-cut: no SPIds expected in this API -} m Issuer
forall (m :: * -> *). (Functor m, HasConfig m) => m Issuer
defSPIssuer m URI
forall (m :: * -> *). (Functor m, HasConfig m) => m URI
defResponseURI HandleVerdict m
handleVerdict

-- | 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)) =>
Proxy api -> Proxy endpoint -> m URI
getSsoURI (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @API) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @APIAuthResp')

----------------------------------------------------------------------
-- 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, plus you may get an error when
-- you're looking at it.
data AuthnResponseBody = AuthnResponseBody
  { AuthnResponseBody
-> forall (m :: * -> *) err spid extra.
   (SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m,
    extra ~ IdPConfigExtra m) =>
   Maybe spid -> m (AuthnResponse, IdPConfig extra)
authnResponseBodyAction ::
      forall m err spid extra.
      (SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m, extra ~ IdPConfigExtra m) =>
      Maybe spid ->
      m (AuthnResponse, IdPConfig extra),
    AuthnResponseBody -> MultipartData Mem
authnResponseBodyRaw :: MultipartData Mem
  }

renderAuthnResponseBody :: AuthnResponse -> LBS
renderAuthnResponseBody :: AuthnResponse -> ByteString
renderAuthnResponseBody = ByteString -> ByteString
EL.encode (ByteString -> ByteString)
-> (AuthnResponse -> ByteString) -> AuthnResponse -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LT -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (LT -> ByteString)
-> (AuthnResponse -> LT) -> AuthnResponse -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthnResponse -> LT
forall a. HasXMLRoot a => a -> LT
encode

-- | Implies verification, hence the constraints.
parseAuthnResponseBody ::
  forall m err spid extra.
  (SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m, extra ~ IdPConfigExtra m) =>
  Maybe spid ->
  ST ->
  m (AuthnResponse, IdPConfig extra)
parseAuthnResponseBody :: forall (m :: * -> *) err spid extra.
(SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m,
 extra ~ IdPConfigExtra m) =>
Maybe spid -> ST -> m (AuthnResponse, IdPConfig extra)
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 ByteString
xmltxt :: LBS = ByteString -> ByteString
EL.decodeLenient (ST -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs ST
base64 :: LBS)
  AuthnResponse
resp <-
    (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
. 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
forall a b. ConvertibleStrings a b => a -> b
cs) 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
$
      LT -> Either String AuthnResponse
forall (m :: * -> *) a.
(HasXMLRoot a, MonadError String m) =>
LT -> m a
decode (ByteString -> LT
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
xmltxt)
  Issuer
issuer <- 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)
  IdPConfig extra
idp :: IdPConfig extra <- 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
  NonEmpty SignCreds -> ByteString -> m ()
forall (m :: * -> *) err.
MonadError (Error err) m =>
NonEmpty SignCreds -> ByteString -> m ()
simpleVerifyAuthnResponse NonEmpty SignCreds
creds ByteString
xmltxt
  (AuthnResponse, IdPConfig extra)
-> m (AuthnResponse, IdPConfig extra)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthnResponse
resp, IdPConfig extra
idp)

authnResponseBodyToMultipart :: AuthnResponse -> MultipartData tag
authnResponseBodyToMultipart :: forall tag. AuthnResponse -> MultipartData tag
authnResponseBodyToMultipart AuthnResponse
resp = [Input] -> [FileData tag] -> MultipartData tag
forall tag. [Input] -> [FileData tag] -> MultipartData tag
MultipartData [ST -> ST -> Input
Input ST
"SAMLResponse" (ByteString -> ST
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> ST) -> ByteString -> ST
forall a b. (a -> b) -> a -> b
$ AuthnResponse -> ByteString
renderAuthnResponseBody AuthnResponse
resp)] []

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 (AuthnResponse, IdPConfig extra))
-> MultipartData Mem -> AuthnResponseBody
AuthnResponseBody Maybe spid -> m (AuthnResponse, IdPConfig extra)
forall (m :: * -> *) err spid extra.
(SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m,
 extra ~ IdPConfigExtra m) =>
Maybe spid -> m (AuthnResponse, IdPConfig extra)
eval MultipartData Mem
resp)
    where
      eval ::
        forall m err spid extra.
        (SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m, extra ~ IdPConfigExtra m) =>
        Maybe spid ->
        m (AuthnResponse, IdPConfig extra)
      eval :: forall (m :: * -> *) err spid extra.
(SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m,
 extra ~ IdPConfigExtra m) =>
Maybe spid -> m (AuthnResponse, IdPConfig extra)
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 (AuthnResponse, IdPConfig extra)
forall (m :: * -> *) err spid extra.
(SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m,
 extra ~ IdPConfigExtra m) =>
Maybe spid -> ST -> m (AuthnResponse, IdPConfig extra)
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 -> 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.
simpleVerifyAuthnResponse :: forall m err. MonadError (Error err) m => NonEmpty SignCreds -> LBS -> m ()
simpleVerifyAuthnResponse :: forall (m :: * -> *) err.
MonadError (Error err) m =>
NonEmpty SignCreds -> ByteString -> m ()
simpleVerifyAuthnResponse NonEmpty SignCreds
creds ByteString
raw = do
  Cursor
doc :: Cursor <- 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
    (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 -> ByteString -> Either SomeException Document
parseLBS ParseSettings
forall a. Default a => a
def ByteString
raw)
  [Element]
assertions :: [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 [Maybe Element] -> [Element]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Element] -> [Element]) -> [Maybe Element] -> [Element]
forall a b. (a -> b) -> a -> b
$
      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 -> Maybe Element) -> [Cursor] -> [Maybe Element]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 [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
      some :: [Element]
some@(Element
_ : [Element]
_) -> [Element] -> m [Element]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Element]
some
  [String]
nodeids :: [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) -> [Element] -> m [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) -> [a] -> m [b]
`mapM` [Element]
assertions
  NonEmpty SignCreds -> ByteString -> [String] -> m ()
forall (m :: * -> *) err.
MonadError (Error err) m =>
NonEmpty SignCreds -> ByteString -> [String] -> m ()
allVerifies NonEmpty SignCreds
creds ByteString
raw [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 -> [String] -> m ()
allVerifies :: forall (m :: * -> *) err.
MonadError (Error err) m =>
NonEmpty SignCreds -> ByteString -> [String] -> m ()
allVerifies NonEmpty SignCreds
creds ByteString
raw [String]
nodeids = do
  let workArounds :: [Either String ()]
      workArounds :: [Either String ()]
workArounds =
        [ NonEmpty SignCreds -> ByteString -> [String] -> Either String ()
forall (m :: * -> *).
MonadError String m =>
NonEmpty SignCreds -> ByteString -> [String] -> m ()
verifyADFS NonEmpty SignCreds
creds ByteString
raw [String]
nodeids
        ]
  case NonEmpty SignCreds -> ByteString -> String -> Either String ()
forall (m :: * -> *).
MonadError String m =>
NonEmpty SignCreds -> ByteString -> String -> m ()
verify NonEmpty SignCreds
creds ByteString
raw (String -> Either String ()) -> [String] -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` [String]
nodeids of
    Right () -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Left String
err -> do
      if (Either String () -> Bool) -> [Either String ()] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either String () -> Bool
forall a b. Either a b -> Bool
isRight [Either String ()]
workArounds
        then () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        else Error err -> m ()
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error err -> m ()) -> (LT -> Error err) -> LT -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LT -> Error err
forall err. LT -> Error err
BadSamlResponseInvalidSignature (LT -> m ()) -> LT -> m ()
forall a b. (a -> b) -> a -> b
$ String -> LT
forall a b. ConvertibleStrings a b => a -> b
cs String
err

-- | 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 String m => NonEmpty SignCreds -> LBS -> [String] -> m ()
verifyADFS :: forall (m :: * -> *).
MonadError String m =>
NonEmpty SignCreds -> ByteString -> [String] -> m ()
verifyADFS NonEmpty SignCreds
creds ByteString
raw [String]
nodeids = NonEmpty SignCreds -> ByteString -> String -> m ()
forall (m :: * -> *).
MonadError String m =>
NonEmpty SignCreds -> ByteString -> String -> m ()
verify NonEmpty SignCreds
creds ByteString
raw' (String -> m ()) -> [String] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` [String]
nodeids
  where
    raw' :: ByteString
raw' = ByteString -> ByteString
go ByteString
raw
      where
        go :: LBS -> LBS
        go :: ByteString -> ByteString
go ByteString
"" = ByteString
""
        go ByteString
rw = case (Int64 -> ByteString -> (ByteString, ByteString)
LBS.splitAt Int64
3 ByteString
rw, Int64 -> ByteString -> (ByteString, ByteString)
LBS.splitAt Int64
1 ByteString
rw) of
          ((ByteString
"> <", ByteString
tl), (ByteString, ByteString)
_) -> ByteString
"><" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
go ByteString
tl
          ((ByteString, ByteString)
_, (ByteString
hd, ByteString
tl)) -> ByteString
hd ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
go ByteString
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 -> ByteString
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) (ByteString -> ST
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> ST) -> (xml -> ByteString) -> xml -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
EL.encode (ByteString -> ByteString)
-> (xml -> ByteString) -> xml -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LT -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (LT -> ByteString) -> (xml -> LT) -> xml -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. xml -> LT
forall a. HasXMLRoot a => a -> LT
encode -> ST
value)) =
      [Node] -> ByteString
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 -> ByteString -> Either String (FormRedirect xml)
mimeUnrender Proxy HTML
Proxy ByteString
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 -> ByteString -> Either SomeException Document
parseLBS ParseSettings
forall a. Default a => a
def ByteString
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
. ByteString -> LT
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> LT) -> (ST -> ByteString) -> ST -> LT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
EL.decodeLenient (ByteString -> ByteString)
-> (ST -> ByteString) -> ST -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> ByteString
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 SPMetadata
meta :: forall (m :: * -> *) err.
(SPStore m, MonadError err m, HasConfig m) =>
ST -> m Issuer -> m URI -> m SPMetadata
meta ST
appName m Issuer
getRequestIssuer m URI
getResponseURI = 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 <- (Config
-> Getting [ContactPerson] Config [ContactPerson]
-> [ContactPerson]
forall s a. s -> Getting a s a -> a
^. Getting [ContactPerson] Config [ContactPerson]
Lens' Config [ContactPerson]
cfgContacts) (Config -> [ContactPerson]) -> m Config -> m [ContactPerson]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Config
forall (m :: * -> *). HasConfig m => m Config
getConfig
  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
getIssuer IdPId
idpid = do
  String -> m ()
forall (m :: * -> *). SP m => String -> m ()
enterH String
"authreq"
  URI
uri <- (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) (IdPConfig (IdPConfigExtra m) -> URI)
-> m (IdPConfig (IdPConfigExtra m)) -> m URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IdPId -> m (IdPConfig (IdPConfigExtra m))
forall err (m :: * -> *).
SPStoreIdP err m =>
IdPId -> m (IdPConfig (IdPConfigExtra m))
getIdPConfig IdPId
idpid
  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 <- NominalDiffTime -> m Issuer -> m AuthnRequest
forall (m :: * -> *).
(Monad m, SP m, SPStore m) =>
NominalDiffTime -> m Issuer -> m AuthnRequest
createAuthnRequest NominalDiffTime
lifeExpectancySecs m Issuer
getIssuer
  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 ::
  (SP m, SPStoreIdP (Error err) m, extra ~ IdPConfigExtra m, SPStoreID Assertion m, SPStoreID AuthnRequest m) =>
  Maybe (IdPConfigSPId m) ->
  m Issuer ->
  m URI ->
  (AuthnResponse -> IdPConfig extra -> AccessVerdict -> m resp) ->
  AuthnResponseBody ->
  m resp
authresp :: forall (m :: * -> *) err extra resp.
(SP m, SPStoreIdP (Error err) m, extra ~ IdPConfigExtra m,
 SPStoreID Assertion m, SPStoreID AuthnRequest m) =>
Maybe (IdPConfigSPId m)
-> m Issuer
-> m URI
-> (AuthnResponse -> IdPConfig extra -> AccessVerdict -> m resp)
-> AuthnResponseBody
-> m resp
authresp Maybe (IdPConfigSPId m)
mbSPId m Issuer
getSPIssuer m URI
getResponseURI AuthnResponse -> 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
  (AuthnResponse
resp :: AuthnResponse, IdPConfig extra
idp :: IdPConfig extra) <- AuthnResponseBody
-> forall (m :: * -> *) err spid extra.
   (SPStoreIdP (Error err) m, spid ~ IdPConfigSPId m,
    extra ~ IdPConfigExtra m) =>
   Maybe spid -> m (AuthnResponse, IdPConfig extra)
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, AuthnResponse) -> String
forall a. Show a => a -> String
ppShow (JudgeCtx
jctx, AuthnResponse
resp)
  AccessVerdict
verdict <- AuthnResponse -> JudgeCtx -> m AccessVerdict
forall (m :: * -> *).
(Monad m, SP m, SPStore m) =>
AuthnResponse -> JudgeCtx -> m AccessVerdict
judge AuthnResponse
resp 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
  AuthnResponse -> IdPConfig extra -> AccessVerdict -> m resp
handleVerdictAction AuthnResponse
resp IdPConfig extra
idp AccessVerdict
verdict

-- | a variant of 'authresp' with a less general verdict handler.
authresp' ::
  (SP m, SPStoreIdP (Error err) m, SPStoreID Assertion m, SPStoreID AuthnRequest m) =>
  Maybe (IdPConfigSPId m) ->
  m Issuer ->
  m URI ->
  HandleVerdict m ->
  AuthnResponseBody ->
  m (WithCookieAndLocation ST)
authresp' :: forall (m :: * -> *) err.
(SP m, SPStoreIdP (Error err) m, SPStoreID Assertion m,
 SPStoreID AuthnRequest 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 :: AuthnResponse
-> IdPConfig (IdPConfigExtra m)
-> AccessVerdict
-> m (WithCookieAndLocation ST)
handleVerdictAction AuthnResponse
resp IdPConfig (IdPConfigExtra m)
_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 AuthnResponse -> 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
. ResponseVerdict -> Error err
forall err. ResponseVerdict -> Error err
CustomServant (ResponseVerdict -> m (WithCookieAndLocation ST))
-> m ResponseVerdict -> m (WithCookieAndLocation ST)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AuthnResponse -> AccessVerdict -> m ResponseVerdict
action AuthnResponse
resp AccessVerdict
verdict
  Maybe (IdPConfigSPId m)
-> m Issuer
-> m URI
-> (AuthnResponse
    -> IdPConfig (IdPConfigExtra m)
    -> AccessVerdict
    -> m (WithCookieAndLocation ST))
-> AuthnResponseBody
-> m (WithCookieAndLocation ST)
forall (m :: * -> *) err extra resp.
(SP m, SPStoreIdP (Error err) m, extra ~ IdPConfigExtra m,
 SPStoreID Assertion m, SPStoreID AuthnRequest m) =>
Maybe (IdPConfigSPId m)
-> m Issuer
-> m URI
-> (AuthnResponse -> IdPConfig extra -> AccessVerdict -> m resp)
-> AuthnResponseBody
-> m resp
authresp Maybe (IdPConfigSPId m)
mbSPId m Issuer
getRequestIssuerURI m URI
getResponseURI AuthnResponse
-> IdPConfig (IdPConfigExtra m)
-> 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 <- (Config -> Getting URI Config URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI Config URI
Lens' Config URI
cfgSPAppURI) (Config -> URI) -> m Config -> m URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Config
forall (m :: * -> *). HasConfig m => m Config
getConfig
  (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 (AuthnResponse -> AccessVerdict -> m ResponseVerdict)

type ResponseVerdict = ServerError

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

-- | Write error info to log, and apologise to client.
crash :: (SP m, MonadError (Error err) m) => String -> m a
crash :: forall (m :: * -> *) err a.
(SP m, MonadError (Error err) m) =>
String -> m a
crash String
msg = Level -> String -> m ()
forall (m :: * -> *). HasLogger m => Level -> String -> m ()
logger Level
Fatal String
msg m () -> m a -> m a
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Error err -> m a
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error err
forall err. Error err
UnknownError

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