{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module SAML2.Core.Assertions where
import qualified Text.XML.HXT.Arrow.Pickle.Schema as XPS
import SAML2.Lens
import SAML2.XML
import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP
import qualified SAML2.XML.Schema as XS
import qualified SAML2.XML.Signature.Types as DS
import qualified SAML2.XML.Encryption as XEnc
import SAML2.Core.Namespaces
import SAML2.Core.Versioning
import SAML2.Core.Identifiers
import SAML2.Profiles.ConfirmationMethod
ns :: Namespace
ns = mkNamespace "" $ samlURN SAML20 ["assertion"]
xpElem :: String -> XP.PU a -> XP.PU a
xpElem = xpTrimElemNS ns
data BaseID id = BaseID
{ baseNameQualifier :: Maybe XString
, baseSPNameQualifier :: Maybe XString
, baseID :: !id
} deriving (Eq, Show)
xpBaseID :: XP.PU id -> XP.PU (BaseID id)
xpBaseID idp = [XP.biCase|((n, s), i) <-> BaseID n s i|]
XP.>$< (XP.xpAttrImplied "NameQualifier" XS.xpString
XP.>*< XP.xpAttrImplied "SPNameQualifier" XS.xpString
XP.>*< idp)
data NameID = NameID
{ nameBaseID :: BaseID XString
, nameIDFormat :: IdentifiedURI NameIDFormat
, nameSPProvidedID :: Maybe XString
} deriving (Eq, Show)
simpleNameID :: NameIDFormat -> XString -> NameID
simpleNameID f s = NameID (BaseID Nothing Nothing s) (Identified f) Nothing
xpNameIDDefaulting :: IdentifiedURI NameIDFormat -> XP.PU NameID
xpNameIDDefaulting fmt = [XP.biCase|((f, p), b) <-> NameID b f p|]
XP.>$< (XP.xpDefault fmt (XP.xpAttr "Format" XP.xpickle)
XP.>*< XP.xpAttrImplied "SPProvidedID" XS.xpString
XP.>*< xpBaseID XS.xpString)
xpNameID :: XP.PU NameID
xpNameID = xpNameIDDefaulting $ Identified NameIDFormatUnspecified
instance XP.XmlPickler NameID where
xpickle = xpElem "NameID" xpNameID
type EncryptedNameID = EncryptedElement NameID
instance XP.XmlPickler EncryptedNameID where
xpickle = xpElem "EncryptedID" xpEncryptedElement
data Identifier
= IdentifierName NameID
| IdentifierBase (BaseID Nodes)
deriving (Eq, Show)
instance XP.XmlPickler Identifier where
xpickle = [XP.biCase|
Left n <-> IdentifierName n
Right b <-> IdentifierBase b |]
XP.>$< (XP.xpickle XP.>|< xpElem "BaseID" (xpBaseID XP.xpTrees))
type EncryptedID = EncryptedElement Identifier
instance XP.XmlPickler EncryptedID where
xpickle = xpElem "EncryptedID" xpEncryptedElement
data EncryptedElement a = EncryptedElement
{ encryptedData :: XEnc.EncryptedData
, encryptedKey :: [XEnc.EncryptedKey]
} deriving (Eq, Show)
xpEncryptedElement :: XP.PU (EncryptedElement a)
xpEncryptedElement = [XP.biCase|(d, k) <-> EncryptedElement d k|]
XP.>$< (XP.xpickle
XP.>*< XP.xpList XP.xpickle)
data PossiblyEncrypted a
= NotEncrypted !a
| SoEncrypted (EncryptedElement a)
deriving (Eq, Show)
xpPossiblyEncrypted :: (XP.XmlPickler a, XP.XmlPickler (EncryptedElement a)) => XP.PU (PossiblyEncrypted a)
xpPossiblyEncrypted = [XP.biCase|
Left a <-> NotEncrypted a
Right a <-> SoEncrypted a |]
XP.>$< (XP.xpickle XP.>|< XP.xpickle)
data AssertionRef
= AssertionRefID AssertionIDRef
| AssertionURIRef AnyURI
| AssertionRef (PossiblyEncrypted Assertion)
deriving (Eq, Show)
instance XP.XmlPickler AssertionRef where
xpickle = [XP.biCase|
Left (Left i) <-> AssertionRefID i
Left (Right u) <-> AssertionURIRef u
Right a <-> AssertionRef a|]
XP.>$< (XP.xpickle
XP.>|< xpElem "AssertionURIRef" XS.xpAnyURI
XP.>|< xpPossiblyEncrypted)
newtype Issuer = Issuer{ issuer :: NameID }
deriving (Eq, Show)
instance XP.XmlPickler Issuer where
xpickle = xpElem "Issuer" $ [XP.biCase|
n <-> Issuer n|]
XP.>$< xpNameIDDefaulting (Identified NameIDFormatEntity)
newtype AssertionIDRef = AssertionIDRef{ assertionIDRef :: ID }
deriving (Eq, Show)
instance XP.XmlPickler AssertionIDRef where
xpickle = xpElem "AssertionIDRef" $ [XP.biCase|
i <-> AssertionIDRef i|]
XP.>$< XS.xpID
data Assertion = Assertion
{ assertionVersion :: SAMLVersion
, assertionID :: ID
, assertionIssueInstant :: DateTime
, assertionIssuer :: Issuer
, assertionSignature :: Maybe DS.Signature
, assertionSubject :: Subject
, assertionConditions :: Maybe Conditions
, assertionAdvice :: Maybe Advice
, assertionStatement :: [Statement]
} deriving (Eq, Show)
instance XP.XmlPickler Assertion where
xpickle = xpElem "Assertion" $
[XP.biCase|
((((((((v, i), t), n), s), Nothing), c), a), l) <-> Assertion v i t n s (Subject Nothing []) c a l
((((((((v, i), t), n), s), Just r), c), a), l) <-> Assertion v i t n s r c a l|]
XP.>$< (XP.xpAttr "Version" XP.xpickle
XP.>*< XP.xpAttr "ID" XS.xpID
XP.>*< XP.xpAttr "IssueInstant" XS.xpDateTime
XP.>*< XP.xpickle
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpOption (xpElem "Advice" $ XP.xpList XP.xpickle)
XP.>*< XP.xpList XP.xpickle)
instance DS.Signable Assertion where
signature' = $(fieldLens 'assertionSignature)
signedID = assertionID
type EncryptedAssertion = EncryptedElement Assertion
instance XP.XmlPickler EncryptedAssertion where
xpickle = xpElem "EncryptedAssertion" xpEncryptedElement
data Subject = Subject
{ subjectIdentifier :: Maybe (PossiblyEncrypted Identifier)
, subjectConfirmation :: [SubjectConfirmation]
} deriving (Eq, Show)
instance XP.XmlPickler Subject where
xpickle = xpElem "Subject" $ [XP.biCase|
(i, c) <-> Subject i c|]
XP.>$< (XP.xpOption xpPossiblyEncrypted
XP.>*< XP.xpList XP.xpickle)
noSubject :: Subject
noSubject = Subject Nothing []
data SubjectConfirmation = SubjectConfirmation
{ subjectConfirmationMethod :: IdentifiedURI ConfirmationMethod
, subjectConfirmationIdentifier :: Maybe (PossiblyEncrypted Identifier)
, subjectConfirmationData :: Maybe SubjectConfirmationData
} deriving (Eq, Show)
instance XP.XmlPickler SubjectConfirmation where
xpickle = xpElem "SubjectConfirmation" $ [XP.biCase|
((m, i), d) <-> SubjectConfirmation m i d|]
XP.>$< (XP.xpAttr "Method" XP.xpickle
XP.>*< XP.xpOption xpPossiblyEncrypted
XP.>*< XP.xpOption XP.xpickle)
data SubjectConfirmationData = SubjectConfirmationData
{ subjectConfirmationNotBefore
, subjectConfirmationNotOnOrAfter :: Maybe DateTime
, subjectConfirmationRecipient :: Maybe AnyURI
, subjectConfirmationInResponseTo :: Maybe ID
, subjectConfirmationAddress :: Maybe IP
, subjectConfirmationKeyInfo :: [DS.KeyInfo]
, subjectConfirmationXML :: Nodes
} deriving (Eq, Show)
instance XP.XmlPickler SubjectConfirmationData where
xpickle = xpElem "SubjectConfirmationData" $ [XP.biCase|
((((((s, e), r), i), a), k), x) <-> SubjectConfirmationData s e r i a k x|]
XP.>$< (XP.xpAttrImplied "NotBefore" XS.xpDateTime
XP.>*< XP.xpAttrImplied "NotOnOrAfter" XS.xpDateTime
XP.>*< XP.xpAttrImplied "Recipient" XS.xpAnyURI
XP.>*< XP.xpAttrImplied "InResponseTo" XS.xpNCName
XP.>*< XP.xpAttrImplied "Address" xpIP
XP.>*< XP.xpList XP.xpickle
XP.>*< XP.xpAny)
data Conditions = Conditions
{ conditionsNotBefore
, conditionsNotOnOrAfter :: Maybe DateTime
, conditions :: [Condition]
} deriving (Eq, Show)
instance XP.XmlPickler Conditions where
xpickle = xpElem "Conditions" $ [XP.biCase|
((s, e), c) <-> Conditions s e c|]
XP.>$< (XP.xpAttrImplied "NotBefore" XS.xpDateTime
XP.>*< XP.xpAttrImplied "NotOnOrAfter" XS.xpDateTime
XP.>*< XP.xpList XP.xpickle)
data Condition
= Condition Node
| AudienceRestriction (List1 Audience)
| OneTimeUse
| ProxyRestriction
{ proxyRestrictionCount :: Maybe XS.NonNegativeInteger
, proxyRestrictionAudience :: [Audience]
}
deriving (Eq, Show)
instance XP.XmlPickler Condition where
xpickle = [XP.biCase|
Left (Left (Left a)) <-> AudienceRestriction a
Left (Left (Right ())) <-> OneTimeUse
Left (Right (c, a)) <-> ProxyRestriction c a
Right x <-> Condition x|]
XP.>$< (xpElem "AudienceRestriction" (xpList1 XP.xpickle)
XP.>|< xpElem "OneTimeUse" XP.xpUnit
XP.>|< xpElem "ProxyRestriction"
(XP.xpAttrImplied "Count" XS.xpNonNegativeInteger
XP.>*< XP.xpList XP.xpickle)
XP.>|< xpTrimAnyElem)
newtype Audience = Audience{ audience :: AnyURI }
deriving (Eq, Show)
instance XP.XmlPickler Audience where
xpickle = xpElem "Audience" $ [XP.biCase|
u <-> Audience u|]
XP.>$< XS.xpAnyURI
type Advice = [AdviceElement]
data AdviceElement
= AdviceAssertion AssertionRef
| Advice Node
deriving (Eq, Show)
instance XP.XmlPickler AdviceElement where
xpickle = [XP.biCase|
Left a <-> AdviceAssertion a
Right x <-> Advice x|]
XP.>$< (XP.xpickle
XP.>|< xpTrimAnyElem)
data Statement
= StatementAuthn AuthnStatement
| StatementAttribute AttributeStatement
| StatementAuthzDecision AuthzDecisionStatement
| Statement Node
deriving (Eq, Show)
instance XP.XmlPickler Statement where
xpickle = [XP.biCase|
Left (Left (Left s)) <-> StatementAuthn s
Left (Left (Right s)) <-> StatementAttribute s
Left (Right s) <-> StatementAuthzDecision s
Right x <-> Statement x|]
XP.>$< (XP.xpickle
XP.>|< XP.xpickle
XP.>|< XP.xpickle
XP.>|< xpTrimAnyElem)
data AuthnStatement = AuthnStatement
{ authnStatementInstant :: DateTime
, authnStatementSessionIndex :: Maybe XString
, authnStatementSessionNotOnOrAfter :: Maybe DateTime
, authnStatementSubjectLocality :: Maybe SubjectLocality
, authnStatementContext :: AuthnContext
} deriving (Eq, Show)
instance XP.XmlPickler AuthnStatement where
xpickle = xpElem "AuthnStatement" $ [XP.biCase|
((((t, i), e), l), c) <-> AuthnStatement t i e l c|]
XP.>$< (XP.xpAttr "AuthnInstant" XS.xpDateTime
XP.>*< XP.xpAttrImplied "SessionIndex" XS.xpString
XP.>*< XP.xpAttrImplied "SessionNotOnOrAfter" XS.xpDateTime
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpickle)
data SubjectLocality = SubjectLocality
{ subjectLocalityAddress :: Maybe IP
, subjectLocalityDNSName :: Maybe XString
} deriving (Eq, Show)
instance XP.XmlPickler SubjectLocality where
xpickle = xpElem "SubjectLocality" $ [XP.biCase|
(a, d) <-> SubjectLocality a d|]
XP.>$< (XP.xpAttrImplied "Address" xpIP
XP.>*< XP.xpAttrImplied "DNSName" XS.xpString)
data AuthnContext = AuthnContext
{ authnContextClassRef :: Maybe AnyURI
, authnContextDecl :: Maybe AuthnContextDecl
, authnContextAuthenticatingAuthority :: [AnyURI]
} deriving (Eq, Show)
instance XP.XmlPickler AuthnContext where
xpickle = xpElem "AuthnContext" $ [XP.biCase|
((c, d), a) <-> AuthnContext c d a|]
XP.>$< (XP.xpOption (xpElem "AuthnContextClassRef" XS.xpAnyURI)
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpList (xpElem "AuthenticatingAuthority" XS.xpAnyURI))
data AuthnContextDecl
= AuthnContextDecl Nodes
| AuthnContextDeclRef AnyURI
deriving (Eq, Show)
instance XP.XmlPickler AuthnContextDecl where
xpickle = [XP.biCase|
Left d <-> AuthnContextDecl d
Right r <-> AuthnContextDeclRef r|]
XP.>$< (xpElem "AuthnContextDecl" XP.xpAny
XP.>|< xpElem "AuthnContextDeclRef" XS.xpAnyURI)
newtype AttributeStatement = AttributeStatement{ attributeStatement :: List1 (PossiblyEncrypted Attribute) }
deriving (Eq, Show)
instance XP.XmlPickler AttributeStatement where
xpickle = xpElem "AttributeStatement" $ [XP.biCase|
l <-> AttributeStatement l|]
XP.>$< xpList1 xpPossiblyEncrypted
data Attribute = Attribute
{ attributeName :: XString
, attributeNameFormat :: IdentifiedURI AttributeNameFormat
, attributeFriendlyName :: Maybe XString
, attributeAttrs :: Nodes
, attributeValues :: [Nodes]
} deriving (Eq, Show)
xpAttributeType :: XP.PU Attribute
xpAttributeType = [XP.biCase|
((((n, f), u), x), v) <-> Attribute n f u x v|]
XP.>$< (XP.xpAttr "Name" XS.xpString
XP.>*< XP.xpDefault (Identified AttributeNameFormatUnspecified) (XP.xpAttr "NameFormat" XP.xpickle)
XP.>*< XP.xpAttrImplied "FriendlyName" XS.xpString
XP.>*< XP.xpAnyAttrs
XP.>*< XP.xpList (xpElem "AttributeValue" XP.xpAny))
instance XP.XmlPickler Attribute where
xpickle = xpElem "Attribute" xpAttributeType
type EncryptedAttribute = EncryptedElement Attribute
instance XP.XmlPickler EncryptedAttribute where
xpickle = xpElem "EncryptedAttribute" xpEncryptedElement
data AuthzDecisionStatement = AuthzDecisionStatement
{ authzDecisionStatementResource :: AnyURI
, authzDecisionStatementDecision :: DecisionType
, authzDecisionStatementAction :: List1 Action
, authzDecisionStatementEvidence :: Evidence
} deriving (Eq, Show)
instance XP.XmlPickler AuthzDecisionStatement where
xpickle = xpElem "AuthzDecisionStatement" $ [XP.biCase|
(((r, d), a), e) <-> AuthzDecisionStatement r d a e|]
XP.>$< (XP.xpAttr "Resource" XS.xpAnyURI
XP.>*< XP.xpAttr "Decision" XP.xpickle
XP.>*< xpList1 XP.xpickle
XP.>*< XP.xpickle)
data DecisionType
= DecisionTypePermit
| DecisionTypeDeny
| DecisionTypeIndeterminate
deriving (Eq, Enum, Bounded, Show)
instance Identifiable XString DecisionType where
identifier DecisionTypePermit = "Permit"
identifier DecisionTypeDeny = "Deny"
identifier DecisionTypeIndeterminate = "Indeterminate"
instance XP.XmlPickler DecisionType where
xpickle = xpIdentifier (XP.xpTextDT (XPS.scDT (namespaceURIString ns) "DecisionType" [])) "DecisionType"
data Action = Action
{ actionNamespace :: IdentifiedURI ActionNamespace
, action :: XString
} deriving (Eq, Show)
instance XP.XmlPickler Action where
xpickle = xpElem "Action" $ [XP.biCase|
(n, a) <-> Action n a|]
XP.>$< (XP.xpAttr "Namespace" XP.xpickle
XP.>*< XP.xpText0)
newtype Evidence = Evidence{ evidence :: [AssertionRef] }
deriving (Eq, Show, Monoid)
instance XP.XmlPickler Evidence where
xpickle = [XP.biCase|
Nothing <-> Evidence []
Just l <-> Evidence l|]
XP.>$< XP.xpOption (xpElem "Evidence" $ XP.xpList1 XP.xpickle)