--------------------------------------------------------------------------------
-- 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubjectConfirmationMethod -> SubjectConfirmationMethod -> Bool
$c/= :: SubjectConfirmationMethod -> SubjectConfirmationMethod -> Bool
== :: SubjectConfirmationMethod -> SubjectConfirmationMethod -> Bool
$c== :: SubjectConfirmationMethod -> SubjectConfirmationMethod -> Bool
Eq, Int -> SubjectConfirmationMethod -> ShowS
[SubjectConfirmationMethod] -> ShowS
SubjectConfirmationMethod -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SubjectConfirmationMethod] -> ShowS
$cshowList :: [SubjectConfirmationMethod] -> ShowS
show :: SubjectConfirmationMethod -> String
$cshow :: SubjectConfirmationMethod -> String
showsPrec :: Int -> SubjectConfirmationMethod -> ShowS
$cshowsPrec :: Int -> SubjectConfirmationMethod -> ShowS
Show)

instance FromXML SubjectConfirmationMethod where
    parseXML :: forall (m :: * -> *).
MonadFail m =>
Cursor -> m SubjectConfirmationMethod
parseXML Cursor
cursor = case [Text] -> Text
T.concat 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" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectConfirmationMethod
HolderOfKey
        Text
"urn:oasis:names:tc:SAML:2.0:cm:sender-vouches" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectConfirmationMethod
SenderVouches
        Text
"urn:oasis:names:tc:SAML:2.0:cm:bearer" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectConfirmationMethod
Bearer
        Text
_ -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubjectConfirmation -> SubjectConfirmation -> Bool
$c/= :: SubjectConfirmation -> SubjectConfirmation -> Bool
== :: SubjectConfirmation -> SubjectConfirmation -> Bool
$c== :: SubjectConfirmation -> SubjectConfirmation -> Bool
Eq, Int -> SubjectConfirmation -> ShowS
[SubjectConfirmation] -> ShowS
SubjectConfirmation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SubjectConfirmation] -> ShowS
$cshowList :: [SubjectConfirmation] -> ShowS
show :: SubjectConfirmation -> String
$cshow :: SubjectConfirmation -> String
showsPrec :: Int -> SubjectConfirmation -> ShowS
$cshowsPrec :: Int -> SubjectConfirmation -> ShowS
Show)

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

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

        forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectConfirmation{
            subjectConfirmationMethod :: SubjectConfirmationMethod
subjectConfirmationMethod = SubjectConfirmationMethod
method,
            subjectConfirmationAddress :: Text
subjectConfirmationAddress = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$
                Cursor
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"SubjectConfirmationData")
                      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 forall a b. (a -> b) -> a -> b
$
                Cursor
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"SubjectConfirmationData")
                      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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NameID -> NameID -> Bool
$c/= :: NameID -> NameID -> Bool
== :: NameID -> NameID -> Bool
$c== :: NameID -> NameID -> Bool
Eq, Int -> NameID -> ShowS
[NameID] -> ShowS
NameID -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NameID] -> ShowS
$cshowList :: [NameID] -> ShowS
show :: NameID -> String
$cshow :: NameID -> String
showsPrec :: Int -> NameID -> ShowS
$cshowsPrec :: Int -> NameID -> ShowS
Show)

instance FromXML NameID where
    parseXML :: forall (m :: * -> *). MonadFail m => Cursor -> m NameID
parseXML Cursor
cursor = do
        Maybe NameIDFormat
nameIDFormat <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *). MonadFail m => Text -> m NameIDFormat
parseNameIDFormat
            forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe (Name -> Cursor -> [Text]
attribute Name
"Format" Cursor
cursor)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure NameID {
            nameIDQualifier :: Maybe Text
nameIDQualifier = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"NameQualifier" Cursor
cursor,
            nameIDSPNameQualifier :: Maybe Text
nameIDSPNameQualifier =
                forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"SPNameQualifier" Cursor
cursor,
            nameIDSPProvidedID :: Maybe Text
nameIDSPProvidedID = forall a. [a] -> Maybe a
listToMaybe 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 forall a b. (a -> b) -> a -> b
$ Cursor
cursor 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Subject -> Subject -> Bool
$c/= :: Subject -> Subject -> Bool
== :: Subject -> Subject -> Bool
$c== :: Subject -> Subject -> Bool
Eq, Int -> Subject -> ShowS
[Subject] -> ShowS
Subject -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Subject] -> ShowS
$cshowList :: [Subject] -> ShowS
show :: Subject -> String
$cshow :: Subject -> String
showsPrec :: Int -> Subject -> ShowS
$cshowsPrec :: Int -> Subject -> ShowS
Show)

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

        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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AudienceRestriction -> AudienceRestriction -> Bool
$c/= :: AudienceRestriction -> AudienceRestriction -> Bool
== :: AudienceRestriction -> AudienceRestriction -> Bool
$c== :: AudienceRestriction -> AudienceRestriction -> Bool
Eq, Int -> AudienceRestriction -> ShowS
[AudienceRestriction] -> ShowS
AudienceRestriction -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AudienceRestriction] -> ShowS
$cshowList :: [AudienceRestriction] -> ShowS
show :: AudienceRestriction -> String
$cshow :: AudienceRestriction -> String
showsPrec :: Int -> AudienceRestriction -> ShowS
$cshowsPrec :: Int -> AudienceRestriction -> ShowS
Show)

-- Reference [AudienceRestriction]
instance FromXML AudienceRestriction where
    parseXML :: forall (m :: * -> *).
MonadFail m =>
Cursor -> m AudienceRestriction
parseXML Cursor
cursor =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure AudienceRestriction{
            audienceRestrictionAudience :: [Text]
audienceRestrictionAudience =
                let elements :: [Cursor]
elements = Cursor
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"Audience")
                in [ [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ Cursor
element 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Conditions -> Conditions -> Bool
$c/= :: Conditions -> Conditions -> Bool
== :: Conditions -> Conditions -> Bool
$c== :: Conditions -> Conditions -> Bool
Eq, Int -> Conditions -> ShowS
[Conditions] -> ShowS
Conditions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Conditions] -> ShowS
$cshowList :: [Conditions] -> ShowS
show :: Conditions -> String
$cshow :: Conditions -> String
showsPrec :: Int -> Conditions -> ShowS
$cshowsPrec :: Int -> Conditions -> ShowS
Show)

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

        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 forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"AudienceRestriction")
                    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthnStatement -> AuthnStatement -> Bool
$c/= :: AuthnStatement -> AuthnStatement -> Bool
== :: AuthnStatement -> AuthnStatement -> Bool
$c== :: AuthnStatement -> AuthnStatement -> Bool
Eq, Int -> AuthnStatement -> ShowS
[AuthnStatement] -> ShowS
AuthnStatement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthnStatement] -> ShowS
$cshowList :: [AuthnStatement] -> ShowS
show :: AuthnStatement -> String
$cshow :: AuthnStatement -> String
showsPrec :: Int -> AuthnStatement -> ShowS
$cshowsPrec :: Int -> AuthnStatement -> ShowS
Show)

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

        forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthnStatement{
            authnStatementInstant :: UTCTime
authnStatementInstant = UTCTime
issueInstant,
            authnStatementSessionIndex :: Text
authnStatementSessionIndex = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$
                Name -> Cursor -> [Text]
attribute Name
"SessionIndex" Cursor
cursor,
            authnStatementLocality :: Text
authnStatementLocality = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$
                Cursor
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"SubjectLocality")
                    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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AssertionAttribute -> AssertionAttribute -> Bool
$c/= :: AssertionAttribute -> AssertionAttribute -> Bool
== :: AssertionAttribute -> AssertionAttribute -> Bool
$c== :: AssertionAttribute -> AssertionAttribute -> Bool
Eq, Int -> AssertionAttribute -> ShowS
[AssertionAttribute] -> ShowS
AssertionAttribute -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AssertionAttribute] -> ShowS
$cshowList :: [AssertionAttribute] -> ShowS
show :: AssertionAttribute -> String
$cshow :: AssertionAttribute -> String
showsPrec :: Int -> AssertionAttribute -> ShowS
$cshowsPrec :: Int -> AssertionAttribute -> ShowS
Show)

instance FromXML AssertionAttribute where
    parseXML :: forall (m :: * -> *). MonadFail m => Cursor -> m AssertionAttribute
parseXML Cursor
cursor = do
        forall (f :: * -> *) a. Applicative f => a -> f a
pure AssertionAttribute{
            attributeName :: Text
attributeName = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"Name" Cursor
cursor,
            attributeFriendlyName :: Maybe Text
attributeFriendlyName =
                [Text] -> Maybe Text
toMaybeText forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"FriendlyName" Cursor
cursor,
            attributeNameFormat :: Text
attributeNameFormat = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"NameFormat" Cursor
cursor,
            attributeValue :: Text
attributeValue = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$
                Cursor
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"AttributeValue") 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 forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"Attribute") forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Assertion -> Assertion -> Bool
$c/= :: Assertion -> Assertion -> Bool
== :: Assertion -> Assertion -> Bool
$c== :: Assertion -> Assertion -> Bool
Eq, Int -> Assertion -> ShowS
[Assertion] -> ShowS
Assertion -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Assertion] -> ShowS
$cshowList :: [Assertion] -> ShowS
show :: Assertion -> String
$cshow :: Assertion -> String
showsPrec :: Int -> Assertion -> ShowS
$cshowsPrec :: Int -> Assertion -> ShowS
Show)

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

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

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

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

        forall (f :: * -> *) a. Applicative f => a -> f a
pure Assertion{
            assertionId :: Text
assertionId = [Text] -> Text
T.concat 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 forall a b. (a -> b) -> a -> b
$
                Cursor
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"Issuer") 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 forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"AttributeStatement")
                    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>