--------------------------------------------------------------------------------
-- 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.                            --
--------------------------------------------------------------------------------

-- | Types to represent SAML2 assertions and functions to parse them from XML.
module Network.Wai.SAML2.Assertion (
    SubjectConfirmationMethod(..),
    SubjectConfirmation(..),
    Subject(..),
    NameID(..),
    Conditions(..),
    AudienceRestriction(..),
    AuthnStatement(..),
    AssertionAttribute(..),
    AttributeStatement,
    parseAttributeStatement,
    Assertion(..)
) where

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

import Control.Monad

import Data.Maybe (listToMaybe)
import qualified Data.Text as T
import Data.Time

import Text.XML.Cursor

import Network.Wai.SAML2.NameIDFormat
import Network.Wai.SAML2.XML

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

-- | Enumerates different subject confirmation methods.
-- See http://docs.oasis-open.org/security/saml/Post2.0/sstc-saml-tech-overview-2.0-cd-02.html#4.2.1.Subject%20Confirmation%20|outline
data SubjectConfirmationMethod
    = HolderOfKey -- ^ urn:oasis:names:tc:SAML:2.0:cm:holder-of-key
    | SenderVouches -- ^ urn:oasis:names:tc:SAML:2.0:cm:sender-vouches
    | Bearer -- ^ urn:oasis:names:tc:SAML:2.0:cm:bearer
    deriving (SubjectConfirmationMethod -> SubjectConfirmationMethod -> Bool
(SubjectConfirmationMethod -> SubjectConfirmationMethod -> Bool)
-> (SubjectConfirmationMethod -> SubjectConfirmationMethod -> Bool)
-> Eq SubjectConfirmationMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SubjectConfirmationMethod -> SubjectConfirmationMethod -> Bool
== :: SubjectConfirmationMethod -> SubjectConfirmationMethod -> Bool
$c/= :: SubjectConfirmationMethod -> SubjectConfirmationMethod -> Bool
/= :: SubjectConfirmationMethod -> SubjectConfirmationMethod -> Bool
Eq, Int -> SubjectConfirmationMethod -> ShowS
[SubjectConfirmationMethod] -> ShowS
SubjectConfirmationMethod -> String
(Int -> SubjectConfirmationMethod -> ShowS)
-> (SubjectConfirmationMethod -> String)
-> ([SubjectConfirmationMethod] -> ShowS)
-> Show SubjectConfirmationMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubjectConfirmationMethod -> ShowS
showsPrec :: Int -> SubjectConfirmationMethod -> ShowS
$cshow :: SubjectConfirmationMethod -> String
show :: SubjectConfirmationMethod -> String
$cshowList :: [SubjectConfirmationMethod] -> ShowS
showList :: [SubjectConfirmationMethod] -> ShowS
Show)

instance FromXML SubjectConfirmationMethod where
    parseXML :: forall (m :: * -> *).
MonadFail m =>
Cursor -> m SubjectConfirmationMethod
parseXML Cursor
cursor = case [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"Method" Cursor
cursor of
        Text
"urn:oasis:names:tc:SAML:2.0:cm:holder-of-key" -> SubjectConfirmationMethod -> m SubjectConfirmationMethod
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectConfirmationMethod
HolderOfKey
        Text
"urn:oasis:names:tc:SAML:2.0:cm:sender-vouches" -> SubjectConfirmationMethod -> m SubjectConfirmationMethod
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectConfirmationMethod
SenderVouches
        Text
"urn:oasis:names:tc:SAML:2.0:cm:bearer" -> SubjectConfirmationMethod -> m SubjectConfirmationMethod
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectConfirmationMethod
Bearer
        Text
_ -> String -> m SubjectConfirmationMethod
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not a valid SubjectConfirmationMethod."

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

-- | Represents a subject confirmation record.
data SubjectConfirmation = SubjectConfirmation {
    -- | The subject confirmation method used.
    SubjectConfirmation -> SubjectConfirmationMethod
subjectConfirmationMethod :: !SubjectConfirmationMethod,
    -- | The address of the subject.
    SubjectConfirmation -> Text
subjectConfirmationAddress :: !T.Text,
    -- | A timestamp.
    SubjectConfirmation -> UTCTime
subjectConfirmationNotOnOrAfter :: !UTCTime,
    -- | The recipient.
    SubjectConfirmation -> Text
subjectConfirmationRecipient :: !T.Text
} deriving (SubjectConfirmation -> SubjectConfirmation -> Bool
(SubjectConfirmation -> SubjectConfirmation -> Bool)
-> (SubjectConfirmation -> SubjectConfirmation -> Bool)
-> Eq SubjectConfirmation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SubjectConfirmation -> SubjectConfirmation -> Bool
== :: SubjectConfirmation -> SubjectConfirmation -> Bool
$c/= :: SubjectConfirmation -> SubjectConfirmation -> Bool
/= :: SubjectConfirmation -> SubjectConfirmation -> Bool
Eq, Int -> SubjectConfirmation -> ShowS
[SubjectConfirmation] -> ShowS
SubjectConfirmation -> String
(Int -> SubjectConfirmation -> ShowS)
-> (SubjectConfirmation -> String)
-> ([SubjectConfirmation] -> ShowS)
-> Show SubjectConfirmation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubjectConfirmation -> ShowS
showsPrec :: Int -> SubjectConfirmation -> ShowS
$cshow :: SubjectConfirmation -> String
show :: SubjectConfirmation -> String
$cshowList :: [SubjectConfirmation] -> ShowS
showList :: [SubjectConfirmation] -> ShowS
Show)

instance FromXML SubjectConfirmation where
    parseXML :: forall (m :: * -> *).
MonadFail m =>
Cursor -> m SubjectConfirmation
parseXML Cursor
cursor = do
        SubjectConfirmationMethod
method <- Cursor -> m SubjectConfirmationMethod
forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
forall (m :: * -> *).
MonadFail m =>
Cursor -> m SubjectConfirmationMethod
parseXML Cursor
cursor

        UTCTime
notOnOrAfter <- Text -> m UTCTime
forall (m :: * -> *). MonadFail m => Text -> m UTCTime
parseUTCTime (Text -> m UTCTime) -> Text -> m UTCTime
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
            Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"SubjectConfirmationData")
                  Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Text]
attribute Name
"NotOnOrAfter"

        SubjectConfirmation -> m SubjectConfirmation
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectConfirmation{
            subjectConfirmationMethod :: SubjectConfirmationMethod
subjectConfirmationMethod = SubjectConfirmationMethod
method,
            subjectConfirmationAddress :: Text
subjectConfirmationAddress = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"SubjectConfirmationData")
                      Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Text]
attribute Name
"Address",
            subjectConfirmationNotOnOrAfter :: UTCTime
subjectConfirmationNotOnOrAfter = UTCTime
notOnOrAfter,
            subjectConfirmationRecipient :: Text
subjectConfirmationRecipient = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"SubjectConfirmationData")
                      Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Text]
attribute Name
"Recipient"
        }


-- | The @<NameID>@ of a subject.
-- See http://docs.oasis-open.org/security/saml/Post2.0/sstc-saml-tech-overview-2.0-cd-02.html#4.4.2.Assertion,%20Subject,%20and%20Statement%20Structure|outline
-- and https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf#page=13
--
-- @since 0.4
data NameID = NameID {
    -- | The domain that qualifies the name. Allows names from different sources
    -- to used together without colliding
    NameID -> Maybe Text
nameIDQualifier :: !(Maybe T.Text),
    -- | Additionally qualifies the name with the name of the service provider
    NameID -> Maybe Text
nameIDSPNameQualifier :: !(Maybe T.Text),
    -- | Name provided by a service provider
    NameID -> Maybe Text
nameIDSPProvidedID :: !(Maybe T.Text),
    -- | A URI reference describing the format of the value. If not specified it
    -- defaults to @urn:oasis:names:tc:SAML:1.0:nameid-format:unspecified@
    NameID -> Maybe NameIDFormat
nameIDFormat :: !(Maybe NameIDFormat),
    -- | Some textual identifier for the subject, such as an email address.
    NameID -> Text
nameIDValue :: !T.Text
} deriving (NameID -> NameID -> Bool
(NameID -> NameID -> Bool)
-> (NameID -> NameID -> Bool) -> Eq NameID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NameID -> NameID -> Bool
== :: NameID -> NameID -> Bool
$c/= :: NameID -> NameID -> Bool
/= :: NameID -> NameID -> Bool
Eq, Int -> NameID -> ShowS
[NameID] -> ShowS
NameID -> String
(Int -> NameID -> ShowS)
-> (NameID -> String) -> ([NameID] -> ShowS) -> Show NameID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NameID -> ShowS
showsPrec :: Int -> NameID -> ShowS
$cshow :: NameID -> String
show :: NameID -> String
$cshowList :: [NameID] -> ShowS
showList :: [NameID] -> ShowS
Show)

instance FromXML NameID where
    parseXML :: forall (m :: * -> *). MonadFail m => Cursor -> m NameID
parseXML Cursor
cursor = do
        Maybe NameIDFormat
nameIDFormat <- (Text -> m NameIDFormat) -> Maybe Text -> m (Maybe NameIDFormat)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Text -> m NameIDFormat
forall (m :: * -> *). MonadFail m => Text -> m NameIDFormat
parseNameIDFormat
            (Maybe Text -> m (Maybe NameIDFormat))
-> Maybe Text -> m (Maybe NameIDFormat)
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe (Name -> Cursor -> [Text]
attribute Name
"Format" Cursor
cursor)
        NameID -> m NameID
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameID {
            nameIDQualifier :: Maybe Text
nameIDQualifier = [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"NameQualifier" Cursor
cursor,
            nameIDSPNameQualifier :: Maybe Text
nameIDSPNameQualifier =
                [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"SPNameQualifier" Cursor
cursor,
            nameIDSPProvidedID :: Maybe Text
nameIDSPProvidedID = [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"SPProvidedID" Cursor
cursor,
            nameIDFormat :: Maybe NameIDFormat
nameIDFormat = Maybe NameIDFormat
nameIDFormat,
            nameIDValue :: Text
nameIDValue = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Cursor -> [Text]
content
        }

-- | The subject of the assertion.
data Subject = Subject {
    -- | The list of subject confirmation elements, if any.
    Subject -> [SubjectConfirmation]
subjectConfirmations :: ![SubjectConfirmation],
    -- | An identifier for the subject of the assertion.
    Subject -> NameID
subjectNameID :: !NameID
} deriving (Subject -> Subject -> Bool
(Subject -> Subject -> Bool)
-> (Subject -> Subject -> Bool) -> Eq Subject
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Subject -> Subject -> Bool
== :: Subject -> Subject -> Bool
$c/= :: Subject -> Subject -> Bool
/= :: Subject -> Subject -> Bool
Eq, Int -> Subject -> ShowS
[Subject] -> ShowS
Subject -> String
(Int -> Subject -> ShowS)
-> (Subject -> String) -> ([Subject] -> ShowS) -> Show Subject
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Subject -> ShowS
showsPrec :: Int -> Subject -> ShowS
$cshow :: Subject -> String
show :: Subject -> String
$cshowList :: [Subject] -> ShowS
showList :: [Subject] -> ShowS
Show)

instance FromXML Subject where
    parseXML :: forall (m :: * -> *). MonadFail m => Cursor -> m Subject
parseXML Cursor
cursor = do
        [SubjectConfirmation]
confirmations <- [m SubjectConfirmation] -> m [SubjectConfirmation]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([m SubjectConfirmation] -> m [SubjectConfirmation])
-> [m SubjectConfirmation] -> m [SubjectConfirmation]
forall a b. (a -> b) -> a -> b
$
            Cursor
cursor Cursor
-> (Cursor -> [m SubjectConfirmation]) -> [m SubjectConfirmation]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"SubjectConfirmation") Axis
-> (Cursor -> m SubjectConfirmation)
-> Cursor
-> [m SubjectConfirmation]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Cursor -> m SubjectConfirmation
forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
forall (m :: * -> *).
MonadFail m =>
Cursor -> m SubjectConfirmation
parseXML
        NameID
nameID <- String -> [NameID] -> m NameID
forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
"SubjectNameID is required" ([NameID] -> m NameID) -> [NameID] -> m NameID
forall a b. (a -> b) -> a -> b
$
            Cursor
cursor Cursor -> (Cursor -> [NameID]) -> [NameID]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"NameID") Axis -> (Cursor -> [NameID]) -> Cursor -> [NameID]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> [NameID]
forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
forall (m :: * -> *). MonadFail m => Cursor -> m NameID
parseXML

        Subject -> m Subject
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Subject{
            subjectConfirmations :: [SubjectConfirmation]
subjectConfirmations = [SubjectConfirmation]
confirmations,
            subjectNameID :: NameID
subjectNameID        = NameID
nameID
        }

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

-- | An audience restriction.
--
-- @since 0.4

-- Reference [AudienceRestriction]
data AudienceRestriction = AudienceRestriction {
    -- | A URI reference that identifies an intended audience. For the
    -- corresponding assertion to be valid, the client has to be a member of one
    -- or more of these audiences
    AudienceRestriction -> [Text]
audienceRestrictionAudience :: ![T.Text]
} deriving (AudienceRestriction -> AudienceRestriction -> Bool
(AudienceRestriction -> AudienceRestriction -> Bool)
-> (AudienceRestriction -> AudienceRestriction -> Bool)
-> Eq AudienceRestriction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AudienceRestriction -> AudienceRestriction -> Bool
== :: AudienceRestriction -> AudienceRestriction -> Bool
$c/= :: AudienceRestriction -> AudienceRestriction -> Bool
/= :: AudienceRestriction -> AudienceRestriction -> Bool
Eq, Int -> AudienceRestriction -> ShowS
[AudienceRestriction] -> ShowS
AudienceRestriction -> String
(Int -> AudienceRestriction -> ShowS)
-> (AudienceRestriction -> String)
-> ([AudienceRestriction] -> ShowS)
-> Show AudienceRestriction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AudienceRestriction -> ShowS
showsPrec :: Int -> AudienceRestriction -> ShowS
$cshow :: AudienceRestriction -> String
show :: AudienceRestriction -> String
$cshowList :: [AudienceRestriction] -> ShowS
showList :: [AudienceRestriction] -> ShowS
Show)

-- Reference [AudienceRestriction]
instance FromXML AudienceRestriction where
    parseXML :: forall (m :: * -> *).
MonadFail m =>
Cursor -> m AudienceRestriction
parseXML Cursor
cursor =
        AudienceRestriction -> m AudienceRestriction
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AudienceRestriction{
            audienceRestrictionAudience :: [Text]
audienceRestrictionAudience =
                let elements :: [Cursor]
elements = Cursor
cursor Cursor -> Axis -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"Audience")
                in [ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Cursor
element Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Cursor -> [Text]
content
                   | Cursor
element <- [Cursor]
elements
                   ]
        }

-- | Conditions under which a SAML assertion is issued.

-- Reference [Conditions]
data Conditions = Conditions {
    -- | The time when the assertion is valid from (inclusive).
    Conditions -> UTCTime
conditionsNotBefore :: !UTCTime,
    -- | The time the assertion is valid to (not inclusive).
    Conditions -> UTCTime
conditionsNotOnOrAfter :: !UTCTime,
    -- | The intended audience of the assertion.
    --
    -- @since 0.4
    Conditions -> [AudienceRestriction]
conditionsAudienceRestrictions :: ![AudienceRestriction]
} deriving (Conditions -> Conditions -> Bool
(Conditions -> Conditions -> Bool)
-> (Conditions -> Conditions -> Bool) -> Eq Conditions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Conditions -> Conditions -> Bool
== :: Conditions -> Conditions -> Bool
$c/= :: Conditions -> Conditions -> Bool
/= :: Conditions -> Conditions -> Bool
Eq, Int -> Conditions -> ShowS
[Conditions] -> ShowS
Conditions -> String
(Int -> Conditions -> ShowS)
-> (Conditions -> String)
-> ([Conditions] -> ShowS)
-> Show Conditions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Conditions -> ShowS
showsPrec :: Int -> Conditions -> ShowS
$cshow :: Conditions -> String
show :: Conditions -> String
$cshowList :: [Conditions] -> ShowS
showList :: [Conditions] -> ShowS
Show)

-- Reference [Conditions]
instance FromXML Conditions where
    parseXML :: forall (m :: * -> *). MonadFail m => Cursor -> m Conditions
parseXML Cursor
cursor = do
        UTCTime
notBefore <- Text -> m UTCTime
forall (m :: * -> *). MonadFail m => Text -> m UTCTime
parseUTCTime (Text -> m UTCTime) -> Text -> m UTCTime
forall a b. (a -> b) -> a -> b
$
            [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"NotBefore" Cursor
cursor
        UTCTime
notOnOrAfter <- Text -> m UTCTime
forall (m :: * -> *). MonadFail m => Text -> m UTCTime
parseUTCTime (Text -> m UTCTime) -> Text -> m UTCTime
forall a b. (a -> b) -> a -> b
$
            [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"NotOnOrAfter" Cursor
cursor

        Conditions -> m Conditions
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Conditions{
            conditionsNotBefore :: UTCTime
conditionsNotBefore = UTCTime
notBefore,
            conditionsNotOnOrAfter :: UTCTime
conditionsNotOnOrAfter = UTCTime
notOnOrAfter,
            conditionsAudienceRestrictions :: [AudienceRestriction]
conditionsAudienceRestrictions =
                Cursor
cursor Cursor
-> (Cursor -> [AudienceRestriction]) -> [AudienceRestriction]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"AudienceRestriction")
                    Axis
-> (Cursor -> [AudienceRestriction])
-> Cursor
-> [AudienceRestriction]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> [AudienceRestriction]
forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
forall (m :: * -> *).
MonadFail m =>
Cursor -> m AudienceRestriction
parseXML
        }

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

-- | SAML2 authentication statements.

-- Reference [AuthnStatement]
data AuthnStatement = AuthnStatement {
    -- | The timestamp when the assertion was issued.
    AuthnStatement -> UTCTime
authnStatementInstant :: !UTCTime,
    -- | The session index.
    AuthnStatement -> Text
authnStatementSessionIndex :: !T.Text,
    -- | The statement locality.
    AuthnStatement -> Text
authnStatementLocality :: !T.Text
} deriving (AuthnStatement -> AuthnStatement -> Bool
(AuthnStatement -> AuthnStatement -> Bool)
-> (AuthnStatement -> AuthnStatement -> Bool) -> Eq AuthnStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AuthnStatement -> AuthnStatement -> Bool
== :: AuthnStatement -> AuthnStatement -> Bool
$c/= :: AuthnStatement -> AuthnStatement -> Bool
/= :: AuthnStatement -> AuthnStatement -> Bool
Eq, Int -> AuthnStatement -> ShowS
[AuthnStatement] -> ShowS
AuthnStatement -> String
(Int -> AuthnStatement -> ShowS)
-> (AuthnStatement -> String)
-> ([AuthnStatement] -> ShowS)
-> Show AuthnStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AuthnStatement -> ShowS
showsPrec :: Int -> AuthnStatement -> ShowS
$cshow :: AuthnStatement -> String
show :: AuthnStatement -> String
$cshowList :: [AuthnStatement] -> ShowS
showList :: [AuthnStatement] -> ShowS
Show)

instance FromXML AuthnStatement where
    parseXML :: forall (m :: * -> *). MonadFail m => Cursor -> m AuthnStatement
parseXML Cursor
cursor = do
        UTCTime
issueInstant <- Text -> m UTCTime
forall (m :: * -> *). MonadFail m => Text -> m UTCTime
parseUTCTime (Text -> m UTCTime) -> Text -> m UTCTime
forall a b. (a -> b) -> a -> b
$
            [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"AuthnInstant" Cursor
cursor

        AuthnStatement -> m AuthnStatement
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthnStatement{
            authnStatementInstant :: UTCTime
authnStatementInstant = UTCTime
issueInstant,
            authnStatementSessionIndex :: Text
authnStatementSessionIndex = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                Name -> Cursor -> [Text]
attribute Name
"SessionIndex" Cursor
cursor,
            authnStatementLocality :: Text
authnStatementLocality = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"SubjectLocality")
                    Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Text]
attribute Name
"Address"
        }

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

-- | SAML2 assertion attributes.
data AssertionAttribute = AssertionAttribute {
    -- | The name of the attribute.
    AssertionAttribute -> Text
attributeName :: !T.Text,
    -- | A friendly attribute name, if it exists.
    AssertionAttribute -> Maybe Text
attributeFriendlyName :: !(Maybe T.Text),
    -- | The name format.
    AssertionAttribute -> Text
attributeNameFormat :: !T.Text,
    -- | The value of the attribute.
    AssertionAttribute -> Text
attributeValue :: !T.Text
} deriving (AssertionAttribute -> AssertionAttribute -> Bool
(AssertionAttribute -> AssertionAttribute -> Bool)
-> (AssertionAttribute -> AssertionAttribute -> Bool)
-> Eq AssertionAttribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AssertionAttribute -> AssertionAttribute -> Bool
== :: AssertionAttribute -> AssertionAttribute -> Bool
$c/= :: AssertionAttribute -> AssertionAttribute -> Bool
/= :: AssertionAttribute -> AssertionAttribute -> Bool
Eq, Int -> AssertionAttribute -> ShowS
[AssertionAttribute] -> ShowS
AssertionAttribute -> String
(Int -> AssertionAttribute -> ShowS)
-> (AssertionAttribute -> String)
-> ([AssertionAttribute] -> ShowS)
-> Show AssertionAttribute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AssertionAttribute -> ShowS
showsPrec :: Int -> AssertionAttribute -> ShowS
$cshow :: AssertionAttribute -> String
show :: AssertionAttribute -> String
$cshowList :: [AssertionAttribute] -> ShowS
showList :: [AssertionAttribute] -> ShowS
Show)

instance FromXML AssertionAttribute where
    parseXML :: forall (m :: * -> *). MonadFail m => Cursor -> m AssertionAttribute
parseXML Cursor
cursor = do
        AssertionAttribute -> m AssertionAttribute
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AssertionAttribute{
            attributeName :: Text
attributeName = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"Name" Cursor
cursor,
            attributeFriendlyName :: Maybe Text
attributeFriendlyName =
                [Text] -> Maybe Text
toMaybeText ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"FriendlyName" Cursor
cursor,
            attributeNameFormat :: Text
attributeNameFormat = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"NameFormat" Cursor
cursor,
            attributeValue :: Text
attributeValue = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"AttributeValue") Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
content
        }

-- | SAML2 assertion statements (collections of assertion attributes).
type AttributeStatement = [AssertionAttribute]

-- | 'parseAttributeStatement' @cursor@ parses an 'AttributeStatement'.
parseAttributeStatement :: Cursor -> AttributeStatement
parseAttributeStatement :: Cursor -> [AssertionAttribute]
parseAttributeStatement Cursor
cursor =
    Cursor
cursor Cursor -> (Cursor -> [AssertionAttribute]) -> [AssertionAttribute]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"Attribute") Axis
-> (Cursor -> [AssertionAttribute])
-> Cursor
-> [AssertionAttribute]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> [AssertionAttribute]
forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
forall (m :: * -> *). MonadFail m => Cursor -> m AssertionAttribute
parseXML

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

-- | Represents a SAML2 assertion.

-- Reference [Assertion]
data Assertion = Assertion {
    -- | The unique ID of this assertion. It is important to keep track of
    -- these in order to avoid replay attacks.
    Assertion -> Text
assertionId :: !T.Text,
    -- | The date and time when the assertion was issued.
    Assertion -> UTCTime
assertionIssued :: !UTCTime,
    -- | The name of the entity that issued this assertion.
    Assertion -> Text
assertionIssuer :: !T.Text,
    -- | The subject of the assertion.
    Assertion -> Subject
assertionSubject :: !Subject,
    -- | The conditions under which the assertion is issued.
    Assertion -> Conditions
assertionConditions :: !Conditions,
    -- | The authentication statement included in the assertion.
    Assertion -> AuthnStatement
assertionAuthnStatement :: !AuthnStatement,
    -- | The assertion's attribute statement.
    Assertion -> [AssertionAttribute]
assertionAttributeStatement :: !AttributeStatement
} deriving (Assertion -> Assertion -> Bool
(Assertion -> Assertion -> Bool)
-> (Assertion -> Assertion -> Bool) -> Eq Assertion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Assertion -> Assertion -> Bool
== :: Assertion -> Assertion -> Bool
$c/= :: Assertion -> Assertion -> Bool
/= :: Assertion -> Assertion -> Bool
Eq, Int -> Assertion -> ShowS
[Assertion] -> ShowS
Assertion -> String
(Int -> Assertion -> ShowS)
-> (Assertion -> String)
-> ([Assertion] -> ShowS)
-> Show Assertion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Assertion -> ShowS
showsPrec :: Int -> Assertion -> ShowS
$cshow :: Assertion -> String
show :: Assertion -> String
$cshowList :: [Assertion] -> ShowS
showList :: [Assertion] -> ShowS
Show)

-- Reference [Assertion]
instance FromXML Assertion where
    parseXML :: forall (m :: * -> *). MonadFail m => Cursor -> m Assertion
parseXML Cursor
cursor = do
        UTCTime
issueInstant <- Text -> m UTCTime
forall (m :: * -> *). MonadFail m => Text -> m UTCTime
parseUTCTime (Text -> m UTCTime) -> Text -> m UTCTime
forall a b. (a -> b) -> a -> b
$
            [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"IssueInstant" Cursor
cursor

        Subject
subject <- String -> [Subject] -> m Subject
forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
"Subject is required" ([Subject] -> m Subject) -> [Subject] -> m Subject
forall a b. (a -> b) -> a -> b
$
            Cursor
cursor Cursor -> (Cursor -> [Subject]) -> [Subject]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"Subject") Axis -> (Cursor -> [Subject]) -> Cursor -> [Subject]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> [Subject]
forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
forall (m :: * -> *). MonadFail m => Cursor -> m Subject
parseXML

        Conditions
conditions <- String -> [Conditions] -> m Conditions
forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
"Conditions are required" ([Conditions] -> m Conditions) -> [Conditions] -> m Conditions
forall a b. (a -> b) -> a -> b
$
            Cursor
cursor Cursor -> (Cursor -> [Conditions]) -> [Conditions]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"Conditions") Axis -> (Cursor -> [Conditions]) -> Cursor -> [Conditions]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> [Conditions]
forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
forall (m :: * -> *). MonadFail m => Cursor -> m Conditions
parseXML

        AuthnStatement
authnStatement <- String -> [AuthnStatement] -> m AuthnStatement
forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
"AuthnStatement is required" ([AuthnStatement] -> m AuthnStatement)
-> [AuthnStatement] -> m AuthnStatement
forall a b. (a -> b) -> a -> b
$
            Cursor
cursor Cursor -> (Cursor -> [AuthnStatement]) -> [AuthnStatement]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"AuthnStatement") Axis -> (Cursor -> [AuthnStatement]) -> Cursor -> [AuthnStatement]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> [AuthnStatement]
forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
forall (m :: * -> *). MonadFail m => Cursor -> m AuthnStatement
parseXML

        Assertion -> m Assertion
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Assertion{
            assertionId :: Text
assertionId = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"ID" Cursor
cursor,
            assertionIssued :: UTCTime
assertionIssued = UTCTime
issueInstant,
            assertionIssuer :: Text
assertionIssuer = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                Cursor
cursor Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"Issuer") Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
content,
            assertionSubject :: Subject
assertionSubject = Subject
subject,
            assertionConditions :: Conditions
assertionConditions = Conditions
conditions,
            assertionAuthnStatement :: AuthnStatement
assertionAuthnStatement = AuthnStatement
authnStatement,
            assertionAttributeStatement :: [AssertionAttribute]
assertionAttributeStatement =
                Cursor
cursor Cursor -> (Cursor -> [AssertionAttribute]) -> [AssertionAttribute]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"AttributeStatement")
                    Axis
-> (Cursor -> [AssertionAttribute])
-> Cursor
-> [AssertionAttribute]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> [AssertionAttribute]
parseAttributeStatement
        }

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

-- Reference [AuthnStatement]
--   Source: https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf#page=26
--   Section: 2.7.2 Element <AuthnStatement>

-- Reference [Assertion]
-- Source: https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf#page=15
-- Section 2.3.3 Element <Assertion>

-- Reference [Conditions]
-- Source: https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf#page=21
-- 2.5.1 Element <Conditions>

-- Reference [AudienceRestriction]
-- Source: https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf#page=23
-- Section: 2.5.1.4 Elements <AudienceRestriction> and <Audience>