--------------------------------------------------------------------------------
-- SAML2 Middleware for WAI                                                   --
--------------------------------------------------------------------------------
-- This source code is licensed under the MIT license found in the LICENSE    --
-- file in the root directory of this source tree.                            --
--------------------------------------------------------------------------------

-- | Functions to process and validate SAML2 respones.
module Network.Wai.SAML2.Validation (
    validateResponse,
    ansiX923
) where 

--------------------------------------------------------------------------------

import Control.Exception
import Control.Monad.Except

import Crypto.Error
import Crypto.Hash
import qualified Crypto.PubKey.RSA.OAEP as OAEP
import Crypto.PubKey.RSA.PKCS15 as PKCS15
import Crypto.Cipher.AES
import Crypto.Cipher.Types

import qualified Data.ByteString as BS 
import qualified Data.ByteString.Base64 as BS
import qualified Data.ByteString.Lazy as LBS 
import Data.Default.Class
import Data.Time

import Network.Wai.SAML2.XML.Encrypted
import Network.Wai.SAML2.Config
import Network.Wai.SAML2.Error
import Network.Wai.SAML2.XML
import Network.Wai.SAML2.C14N
import Network.Wai.SAML2.Response
import Network.Wai.SAML2.Assertion

import qualified Text.XML as XML
import qualified Text.XML.Cursor as XML

--------------------------------------------------------------------------------

-- | 'validateResponse' @cfg responseData@ validates a SAML2 response contained
-- in Base64-encoded @responseData@. 
validateResponse :: SAML2Config 
                 -> BS.ByteString 
                 -> IO (Either SAML2Error Assertion)
validateResponse :: SAML2Config -> ByteString -> IO (Either SAML2Error Assertion)
validateResponse SAML2Config
cfg ByteString
responseData = ExceptT SAML2Error IO Assertion -> IO (Either SAML2Error Assertion)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SAML2Error IO Assertion
 -> IO (Either SAML2Error Assertion))
-> ExceptT SAML2Error IO Assertion
-> IO (Either SAML2Error Assertion)
forall a b. (a -> b) -> a -> b
$ do 
    -- get the current time
    UTCTime
now <- IO UTCTime -> ExceptT SAML2Error IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> ExceptT SAML2Error IO UTCTime)
-> IO UTCTime -> ExceptT SAML2Error IO UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime 

    -- the response data is Base64-encoded; decode it
    let resXmlDocData :: ByteString
resXmlDocData = ByteString -> ByteString
BS.decodeLenient ByteString
responseData

    -- try to parse the XML document; throw an exception if it is not 
    -- a valid XML document
    Document
responseXmlDoc <- case ParseSettings -> ByteString -> Either SomeException Document
XML.parseLBS ParseSettings
forall a. Default a => a
def (ByteString -> ByteString
LBS.fromStrict ByteString
resXmlDocData) of 
        Left SomeException
err -> SAML2Error -> ExceptT SAML2Error IO Document
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SAML2Error -> ExceptT SAML2Error IO Document)
-> SAML2Error -> ExceptT SAML2Error IO Document
forall a b. (a -> b) -> a -> b
$ SomeException -> SAML2Error
InvalidResponseXml SomeException
err 
        Right Document
responseXmlDoc -> Document -> ExceptT SAML2Error IO Document
forall (f :: * -> *) a. Applicative f => a -> f a
pure Document
responseXmlDoc

    -- try to parse the XML document into a structured SAML2 response
    Either IOException Response
resParseResult <- IO (Either IOException Response)
-> ExceptT SAML2Error IO (Either IOException Response)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException Response)
 -> ExceptT SAML2Error IO (Either IOException Response))
-> IO (Either IOException Response)
-> ExceptT SAML2Error IO (Either IOException Response)
forall a b. (a -> b) -> a -> b
$ IO Response -> IO (Either IOException Response)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Response -> IO (Either IOException Response))
-> IO Response -> IO (Either IOException Response)
forall a b. (a -> b) -> a -> b
$ 
        Cursor -> IO Response
forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
parseXML (Document -> Cursor
XML.fromDocument Document
responseXmlDoc) 
        
    Response
samlResponse <- case Either IOException Response
resParseResult of 
        Left IOException
err -> SAML2Error -> ExceptT SAML2Error IO Response
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SAML2Error -> ExceptT SAML2Error IO Response)
-> SAML2Error -> ExceptT SAML2Error IO Response
forall a b. (a -> b) -> a -> b
$ IOException -> SAML2Error
InvalidResponse IOException
err
        Right Response
samlResponse -> Response -> ExceptT SAML2Error IO Response
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
samlResponse 

    -- check that the response indicates success
    case Response -> StatusCode
responseStatusCode Response
samlResponse of 
        StatusCode
Success -> () -> ExceptT SAML2Error IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        StatusCode
status -> SAML2Error -> ExceptT SAML2Error IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SAML2Error -> ExceptT SAML2Error IO ())
-> SAML2Error -> ExceptT SAML2Error IO ()
forall a b. (a -> b) -> a -> b
$ StatusCode -> SAML2Error
Unsuccessful StatusCode
status

    -- check that the destination is as expected, if the configuration
    -- expects us to validate this 
    let destination :: Text
destination = Response -> Text
responseDestination Response
samlResponse 

    case SAML2Config -> Maybe Text
saml2ExpectedDestination SAML2Config
cfg of 
        Just Text
expectedDestination 
            | Text
destination Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
expectedDestination -> 
                SAML2Error -> ExceptT SAML2Error IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SAML2Error -> ExceptT SAML2Error IO ())
-> SAML2Error -> ExceptT SAML2Error IO ()
forall a b. (a -> b) -> a -> b
$ Text -> SAML2Error
UnexpectedDestination Text
destination
        Maybe Text
_ -> () -> ExceptT SAML2Error IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- check that the issuer is as expected, if the configuration
    -- expects us to validate this 
    let issuer :: Text
issuer = Response -> Text
responseIssuer Response
samlResponse

    case SAML2Config -> Maybe Text
saml2ExpectedIssuer SAML2Config
cfg of
        Just Text
expectedIssuer
            | Text
issuer Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
expectedIssuer -> SAML2Error -> ExceptT SAML2Error IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SAML2Error -> ExceptT SAML2Error IO ())
-> SAML2Error -> ExceptT SAML2Error IO ()
forall a b. (a -> b) -> a -> b
$ Text -> SAML2Error
InvalidIssuer Text
issuer
        Maybe Text
_ -> () -> ExceptT SAML2Error IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    --  ***CORE VALIDATION***
    -- See https://www.w3.org/TR/xmldsig-core1/#sec-CoreValidation
    -- 
    --  *REFERENCE VALIDATION*
    -- 1. We extract the SignedInfo element from the SAML2 response's 
    -- Signature element. This element contains 
    Element
signedInfo <- Cursor -> ExceptT SAML2Error IO Element
forall (m :: * -> *). MonadFail m => Cursor -> m Element
extractSignedInfo (Document -> Cursor
XML.fromDocument Document
responseXmlDoc)

    -- construct a new XML document from the SignedInfo element and render
    -- it into a textual representation
    let doc :: Document
doc = Prologue -> Element -> [Miscellaneous] -> Document
XML.Document ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
XML.Prologue [] Maybe Doctype
forall a. Maybe a
Nothing []) Element
signedInfo []
    let signedInfoXml :: ByteString
signedInfoXml = RenderSettings -> Document -> ByteString
XML.renderLBS RenderSettings
forall a. Default a => a
def Document
doc

    -- canonicalise the textual representation of the SignedInfo element
    Either IOException ByteString
signedInfoCanonResult <- IO (Either IOException ByteString)
-> ExceptT SAML2Error IO (Either IOException ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException ByteString)
 -> ExceptT SAML2Error IO (Either IOException ByteString))
-> IO (Either IOException ByteString)
-> ExceptT SAML2Error IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either IOException ByteString))
-> IO ByteString -> IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ 
        ByteString -> IO ByteString
canonicalise (ByteString -> ByteString
LBS.toStrict ByteString
signedInfoXml)

    ByteString
normalisedSignedInfo <- case Either IOException ByteString
signedInfoCanonResult of 
        Left IOException
err -> SAML2Error -> ExceptT SAML2Error IO ByteString
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SAML2Error -> ExceptT SAML2Error IO ByteString)
-> SAML2Error -> ExceptT SAML2Error IO ByteString
forall a b. (a -> b) -> a -> b
$ IOException -> SAML2Error
CanonicalisationFailure IOException
err
        Right ByteString
result -> ByteString -> ExceptT SAML2Error IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
result 

    -- 2. At this point we should dereference all elements identified by
    -- Reference elements inside the SignedInfo element. However, we do
    -- not currently do that and instead just assume that there is only
    -- one Reference element which targets the overall Response. 
    -- We sanity check this, just in case we are wrong since we do not
    -- want an attacker to be able to exploit this.
    let documentId :: Text
documentId = Response -> Text
responseId Response
samlResponse
    let referenceId :: Text
referenceId = Reference -> Text
referenceURI
                    (Reference -> Text) -> Reference -> Text
forall a b. (a -> b) -> a -> b
$ SignedInfo -> Reference
signedInfoReference
                    (SignedInfo -> Reference) -> SignedInfo -> Reference
forall a b. (a -> b) -> a -> b
$ Signature -> SignedInfo
signatureInfo
                    (Signature -> SignedInfo) -> Signature -> SignedInfo
forall a b. (a -> b) -> a -> b
$ Response -> Signature
responseSignature Response
samlResponse

    if Text
documentId Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
referenceId 
    then SAML2Error -> ExceptT SAML2Error IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SAML2Error -> ExceptT SAML2Error IO ())
-> SAML2Error -> ExceptT SAML2Error IO ()
forall a b. (a -> b) -> a -> b
$ Text -> SAML2Error
UnexpectedReference Text
referenceId
    else () -> ExceptT SAML2Error IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- Now that we have sanity checked that we should indeed validate
    -- the entire Response, we need to remove the Signature element
    -- from it (since the Response cannot possibly have been hashed with 
    -- the Signature element present). First remove the Signature element:
    let docMinusSignature :: Document
docMinusSignature = Document -> Document
removeSignature Document
responseXmlDoc

    -- then render the resulting document and canonicalise it
    let renderedXml :: ByteString
renderedXml = RenderSettings -> Document -> ByteString
XML.renderLBS RenderSettings
forall a. Default a => a
def Document
docMinusSignature
    Either IOException ByteString
refCanonResult <- IO (Either IOException ByteString)
-> ExceptT SAML2Error IO (Either IOException ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException ByteString)
 -> ExceptT SAML2Error IO (Either IOException ByteString))
-> IO (Either IOException ByteString)
-> ExceptT SAML2Error IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either IOException ByteString))
-> IO ByteString -> IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ByteString
canonicalise (ByteString -> ByteString
LBS.toStrict ByteString
renderedXml)

    ByteString
normalised <- case Either IOException ByteString
refCanonResult of 
        Left IOException
err -> SAML2Error -> ExceptT SAML2Error IO ByteString
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SAML2Error -> ExceptT SAML2Error IO ByteString)
-> SAML2Error -> ExceptT SAML2Error IO ByteString
forall a b. (a -> b) -> a -> b
$ IOException -> SAML2Error
CanonicalisationFailure IOException
err
        Right ByteString
result -> ByteString -> ExceptT SAML2Error IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
result 

    -- next, compute the hash for the normalised document and extract the
    -- existing hash from the response; both hash values must be the same
    -- or the response has been tampered with; if both hashes are the same,
    -- then the response has not been tampered with, assuming that the
    -- Signature has not been tampered with, which we validate next
    let documentHash :: Digest SHA256
documentHash = SHA256 -> ByteString -> Digest SHA256
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA256
SHA256 ByteString
normalised
    let referenceHash :: Maybe (Digest SHA256)
referenceHash = ByteString -> Maybe (Digest SHA256)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString 
                      (ByteString -> Maybe (Digest SHA256))
-> ByteString -> Maybe (Digest SHA256)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.decodeLenient 
                      (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Reference -> ByteString
referenceDigestValue 
                      (Reference -> ByteString) -> Reference -> ByteString
forall a b. (a -> b) -> a -> b
$ SignedInfo -> Reference
signedInfoReference 
                      (SignedInfo -> Reference) -> SignedInfo -> Reference
forall a b. (a -> b) -> a -> b
$ Signature -> SignedInfo
signatureInfo 
                      (Signature -> SignedInfo) -> Signature -> SignedInfo
forall a b. (a -> b) -> a -> b
$ Response -> Signature
responseSignature Response
samlResponse

    if Digest SHA256 -> Maybe (Digest SHA256)
forall a. a -> Maybe a
Just Digest SHA256
documentHash Maybe (Digest SHA256) -> Maybe (Digest SHA256) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (Digest SHA256)
referenceHash 
    then SAML2Error -> ExceptT SAML2Error IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SAML2Error
InvalidDigest
    else () -> ExceptT SAML2Error IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    --  *SIGNATURE VALIDATION*
    -- We need to check that the SignedInfo element has not been tampered 
    -- with, which we do by checking the signature contained in the response;
    -- first: extract the signature data from the response
    let sig :: ByteString
sig = ByteString -> ByteString
BS.decodeLenient (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Signature -> ByteString
signatureValue (Signature -> ByteString) -> Signature -> ByteString
forall a b. (a -> b) -> a -> b
$ Response -> Signature
responseSignature Response
samlResponse

    -- using the IdP's public key and the canonicalised SignedInfo element,
    -- check that the signature is correct
    let pubKey :: PublicKey
pubKey = SAML2Config -> PublicKey
saml2PublicKey SAML2Config
cfg

    if Maybe SHA256 -> PublicKey -> ByteString -> ByteString -> Bool
forall hashAlg.
HashAlgorithmASN1 hashAlg =>
Maybe hashAlg -> PublicKey -> ByteString -> ByteString -> Bool
PKCS15.verify (SHA256 -> Maybe SHA256
forall a. a -> Maybe a
Just SHA256
SHA256) PublicKey
pubKey ByteString
normalisedSignedInfo ByteString
sig 
    then () -> ExceptT SAML2Error IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else SAML2Error -> ExceptT SAML2Error IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SAML2Error
InvalidSignature  

    --  ***ASSERTION DECRYPTION***
    -- the SAML assertion is AES-encrypted and we need to acquire the key
    -- to decrypt it; the key itself is RSA-encrypted:
    -- get the private key from the configuration and use it to decrypt
    -- the key used to decrypt the assertion
    let pk :: PrivateKey
pk = SAML2Config -> PrivateKey
saml2PrivateKey SAML2Config
cfg
    let encryptedAssertion :: EncryptedAssertion
encryptedAssertion = Response -> EncryptedAssertion
responseEncryptedAssertion Response
samlResponse
    
    Either Error ByteString
oaepResult <- IO (Either Error ByteString)
-> ExceptT SAML2Error IO (Either Error ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Error ByteString)
 -> ExceptT SAML2Error IO (Either Error ByteString))
-> IO (Either Error ByteString)
-> ExceptT SAML2Error IO (Either Error ByteString)
forall a b. (a -> b) -> a -> b
$ OAEPParams SHA1 ByteString ByteString
-> PrivateKey -> ByteString -> IO (Either Error ByteString)
forall hash (m :: * -> *).
(HashAlgorithm hash, MonadRandom m) =>
OAEPParams hash ByteString ByteString
-> PrivateKey -> ByteString -> m (Either Error ByteString)
OAEP.decryptSafer (SHA1 -> OAEPParams SHA1 ByteString ByteString
forall seed output hash.
(ByteArrayAccess seed, ByteArray output, HashAlgorithm hash) =>
hash -> OAEPParams hash seed output
OAEP.defaultOAEPParams SHA1
SHA1) PrivateKey
pk 
        (ByteString -> IO (Either Error ByteString))
-> ByteString -> IO (Either Error ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.decodeLenient 
        (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CipherData -> ByteString
cipherValue 
        (CipherData -> ByteString) -> CipherData -> ByteString
forall a b. (a -> b) -> a -> b
$ EncryptedKey -> CipherData
encryptedKeyCipher 
        (EncryptedKey -> CipherData) -> EncryptedKey -> CipherData
forall a b. (a -> b) -> a -> b
$ EncryptedAssertion -> EncryptedKey
encryptedAssertionKey 
        (EncryptedAssertion -> EncryptedKey)
-> EncryptedAssertion -> EncryptedKey
forall a b. (a -> b) -> a -> b
$ EncryptedAssertion
encryptedAssertion

    ByteString
aesKey <- case Either Error ByteString
oaepResult of 
        Left Error
err -> SAML2Error -> ExceptT SAML2Error IO ByteString
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SAML2Error -> ExceptT SAML2Error IO ByteString)
-> SAML2Error -> ExceptT SAML2Error IO ByteString
forall a b. (a -> b) -> a -> b
$ Error -> SAML2Error
DecryptionFailure Error
err
        Right ByteString
cipherData -> ByteString -> ExceptT SAML2Error IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
cipherData

    -- next we can decrypt the assertion; initialise AES128 with 
    -- the key we have just decrypted
    ByteString
xmlData <- case ByteString -> CryptoFailable AES128
forall cipher key.
(Cipher cipher, ByteArray key) =>
key -> CryptoFailable cipher
cipherInit ByteString
aesKey of 
        CryptoFailed CryptoError
err -> SAML2Error -> ExceptT SAML2Error IO ByteString
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SAML2Error -> ExceptT SAML2Error IO ByteString)
-> SAML2Error -> ExceptT SAML2Error IO ByteString
forall a b. (a -> b) -> a -> b
$ CryptoError -> SAML2Error
CryptoError CryptoError
err 
        CryptoPassed AES128
aes128 -> do
            -- get the AES ciphertext
            let cipherText :: ByteString
cipherText = ByteString -> ByteString
BS.decodeLenient 
                           (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CipherData -> ByteString
cipherValue 
                           (CipherData -> ByteString) -> CipherData -> ByteString
forall a b. (a -> b) -> a -> b
$ EncryptedAssertion -> CipherData
encryptedAssertionCipher 
                           (EncryptedAssertion -> CipherData)
-> EncryptedAssertion -> CipherData
forall a b. (a -> b) -> a -> b
$ EncryptedAssertion
encryptedAssertion

            -- the IV used for AES is 128bits (16 bytes) prepended
            -- to the ciphertext
            let (ByteString
ivBytes, ByteString
xmlBytes) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
16 ByteString
cipherText

            -- convert the bytes into the IV
            case ByteString -> Maybe (IV AES128)
forall b c. (ByteArrayAccess b, BlockCipher c) => b -> Maybe (IV c)
makeIV ByteString
ivBytes of 
                Maybe (IV AES128)
Nothing -> SAML2Error -> ExceptT SAML2Error IO ByteString
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SAML2Error
InvalidIV
                Just IV AES128
iv -> do
                    -- run AES to decrypt the assertion
                    let plaintext :: ByteString
plaintext = AES128 -> IV AES128 -> ByteString -> ByteString
forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> IV cipher -> ba -> ba
cbcDecrypt (AES128
aes128 :: AES128) IV AES128
iv ByteString
xmlBytes

                    -- remove padding from the plaintext
                    case ByteString -> Maybe ByteString
ansiX923 ByteString
plaintext of 
                        Maybe ByteString
Nothing -> SAML2Error -> ExceptT SAML2Error IO ByteString
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SAML2Error
InvalidPadding
                        Just ByteString
xmlData -> ByteString -> ExceptT SAML2Error IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
xmlData

    -- try to parse the assertion that we decrypted earlier
    Assertion
assertion <- case ParseSettings -> ByteString -> Either SomeException Document
XML.parseLBS ParseSettings
forall a. Default a => a
def (ByteString -> ByteString
LBS.fromStrict ByteString
xmlData) of 
        Left SomeException
err -> SAML2Error -> ExceptT SAML2Error IO Assertion
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SAML2Error -> ExceptT SAML2Error IO Assertion)
-> SAML2Error -> ExceptT SAML2Error IO Assertion
forall a b. (a -> b) -> a -> b
$ SomeException -> SAML2Error
InvalidAssertionXml SomeException
err 
        Right Document
assertDoc -> do
            -- try to convert the assertion document into a more
            -- structured representation
            Either IOException Assertion
assertParseResult <- IO (Either IOException Assertion)
-> ExceptT SAML2Error IO (Either IOException Assertion)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException Assertion)
 -> ExceptT SAML2Error IO (Either IOException Assertion))
-> IO (Either IOException Assertion)
-> ExceptT SAML2Error IO (Either IOException Assertion)
forall a b. (a -> b) -> a -> b
$ IO Assertion -> IO (Either IOException Assertion)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Assertion -> IO (Either IOException Assertion))
-> IO Assertion -> IO (Either IOException Assertion)
forall a b. (a -> b) -> a -> b
$ 
                Cursor -> IO Assertion
forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
parseXML (Document -> Cursor
XML.fromDocument Document
assertDoc)

            case Either IOException Assertion
assertParseResult of 
                Left IOException
err -> SAML2Error -> ExceptT SAML2Error IO Assertion
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SAML2Error -> ExceptT SAML2Error IO Assertion)
-> SAML2Error -> ExceptT SAML2Error IO Assertion
forall a b. (a -> b) -> a -> b
$ IOException -> SAML2Error
InvalidAssertion IOException
err
                Right Assertion
assertion -> Assertion -> ExceptT SAML2Error IO Assertion
forall (f :: * -> *) a. Applicative f => a -> f a
pure Assertion
assertion 

    -- validate that the assertion is valid at this point in time
    let Conditions{Text
UTCTime
conditionsAudience :: Conditions -> Text
conditionsNotOnOrAfter :: Conditions -> UTCTime
conditionsNotBefore :: Conditions -> UTCTime
conditionsAudience :: Text
conditionsNotOnOrAfter :: UTCTime
conditionsNotBefore :: UTCTime
..} = Assertion -> Conditions
assertionConditions Assertion
assertion

    if (UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
conditionsNotBefore Bool -> Bool -> Bool
|| UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
conditionsNotOnOrAfter) Bool -> Bool -> Bool
&&
        Bool -> Bool
not (SAML2Config -> Bool
saml2DisableTimeValidation SAML2Config
cfg)
    then SAML2Error -> ExceptT SAML2Error IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SAML2Error
NotValid
    else () -> ExceptT SAML2Error IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- all checks out, return the assertion
    Assertion -> ExceptT SAML2Error IO Assertion
forall (f :: * -> *) a. Applicative f => a -> f a
pure Assertion
assertion

-- | 'ansiX923' @plaintext@ removes ANSI X9.23 padding from @plaintext@. 
-- See https://en.wikipedia.org/wiki/Padding_(cryptography)#ANSI_X9.23
ansiX923 :: BS.ByteString -> Maybe BS.ByteString 
ansiX923 :: ByteString -> Maybe ByteString
ansiX923 ByteString
d
    | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Maybe ByteString
forall a. Maybe a
Nothing 
    | Int
padLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
padLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
len = Maybe ByteString
forall a. Maybe a
Nothing
    | Bool
otherwise = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
content
    where len :: Int
len = ByteString -> Int
BS.length ByteString
d 
          padBytes :: Word8
padBytes = ByteString -> Int -> Word8
BS.index ByteString
d (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
          padLen :: Int
padLen = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
padBytes
          (ByteString
content,ByteString
_) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
padLen) ByteString
d

--------------------------------------------------------------------------------