{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module SAML2.Core.Protocols where
import Control.Lens (Lens', lens, (.~), (^.), view)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy, asProxyTypeOf)
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 SAML2.Core.Namespaces
import SAML2.Core.Versioning
import qualified SAML2.Core.Assertions as SAML
import SAML2.Core.Identifiers
import SAML2.Bindings.General (RelayState)
import SAML2.Bindings.Identifiers
ns :: Namespace
ns = mkNamespace "samlp" $ samlURN SAML20 ["protocol"]
xpElem :: String -> XP.PU a -> XP.PU a
xpElem = xpTrimElemNS ns
data ProtocolType = ProtocolType
{ protocolID :: XS.ID
, protocolVersion :: SAMLVersion
, protocolIssueInstant :: DateTime
, protocolDestination :: Maybe AnyURI
, protocolConsent :: IdentifiedURI Consent
, protocolIssuer :: Maybe SAML.Issuer
, protocolSignature :: Maybe DS.Signature
, protocolExtensions :: [Node]
, relayState :: Maybe RelayState
} deriving (Eq, Show)
instance XP.XmlPickler ProtocolType where
xpickle = XP.xpWrap (pt, tp)
$ (XP.xpAttr "ID" XS.xpID
XP.>*< XP.xpAttr "Version" XP.xpickle
XP.>*< XP.xpAttr "IssueInstant" XS.xpDateTime
XP.>*< XP.xpAttrImplied "Destination" XS.xpAnyURI
XP.>*< XP.xpDefault (Identified ConsentUnspecified) (XP.xpAttr "Consent" XP.xpickle)
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpOption (xpElem "Extensions" $ XP.xpList1 xpTrimAnyElem))
where
pt (((((((i, v), t), d), c), u), g), x) = ProtocolType i v t d c u g (fromMaybe [] x) Nothing
tp (ProtocolType i v t d c u g [] _) = (((((((i, v), t), d), c), u), g), Nothing)
tp (ProtocolType i v t d c u g x _) = (((((((i, v), t), d), c), u), g), Just x)
instance DS.Signable ProtocolType where
signature' = $(fieldLens 'protocolSignature)
signedID = protocolID
class (XP.XmlPickler a, DS.Signable a, Show a) => SAMLProtocol a where
samlProtocol' :: Lens' a ProtocolType
isSAMLResponse :: a -> Bool
isSAMLResponse_ :: Proxy a -> Maybe Bool
isSAMLResponse_ = Just . isSAMLResponse . asProxyTypeOf undefined
newtype RequestAbstractType = RequestAbstractType
{ requestProtocol :: ProtocolType
} deriving (Eq, Show)
instance XP.XmlPickler RequestAbstractType where
xpickle = [XP.biCase|p <-> RequestAbstractType p|]
XP.>$< XP.xpickle
class SAMLProtocol a => SAMLRequest a where
samlRequest' :: Lens' a RequestAbstractType
requestProtocol' :: Lens' RequestAbstractType ProtocolType
requestProtocol' = $(fieldLens 'requestProtocol)
data StatusResponseType = StatusResponseType
{ statusProtocol :: !ProtocolType
, statusInResponseTo :: Maybe XS.NCName
, status :: Status
} deriving (Eq, Show)
instance XP.XmlPickler StatusResponseType where
xpickle = [XP.biCase|((p, r), s) <-> StatusResponseType p r s|]
XP.>$< (XP.xpickle
XP.>*< XP.xpAttrImplied "InResponseTo" XS.xpNCName
XP.>*< XP.xpickle)
class SAMLProtocol a => SAMLResponse a where
samlResponse' :: Lens' a StatusResponseType
statusProtocol' :: Lens' StatusResponseType ProtocolType
statusProtocol' = $(fieldLens 'statusProtocol)
data Status = Status
{ statusCode :: StatusCode
, statusMessage :: Maybe XString
, statusDetail :: Maybe Nodes
} deriving (Eq, Show)
instance XP.XmlPickler Status where
xpickle = xpElem "Status" $ [XP.biCase|
((c, m), d) <-> Status c m d|]
XP.>$< (XP.xpickle
XP.>*< XP.xpOption (xpElem "StatusMessage" XP.xpText0)
XP.>*< XP.xpOption (xpElem "StatusDetail" XP.xpAnyCont))
data StatusCode = StatusCode
{ statusCode1 :: StatusCode1
, statusCodes :: [IdentifiedURI StatusCode2]
} deriving (Eq, Show)
instance XP.XmlPickler StatusCode where
xpickle = xpElem "StatusCode" $ [XP.biCase|
(v, c) <-> StatusCode v c|]
XP.>$< (XP.xpAttr "Value" XP.xpickle
XP.>*< xpStatusCodes) where
xpStatusCodes = [XP.biCase|
Nothing <-> []
Just (v, c) <-> v : c|]
XP.>$< XP.xpOption (xpElem "StatusCode" $
XP.xpAttr "Value" XP.xpickle
XP.>*< xpStatusCodes)
data StatusCode1
= StatusSuccess
| StatusRequester
| StatusResponder
| StatusVersionMismatch
deriving (Eq, Bounded, Enum, Show)
instance Identifiable URI StatusCode1 where
identifier = samlURNIdentifier "status" . f where
f StatusSuccess = (SAML20, "Success")
f StatusRequester = (SAML20, "Requester")
f StatusResponder = (SAML20, "Responder")
f StatusVersionMismatch = (SAML20, "VersionMismatch")
instance XP.XmlPickler StatusCode1 where
xpickle = xpIdentifier XS.xpAnyURI "status"
data StatusCode2
= StatusAuthnFailed
| StatusInvalidAttrNameOrValue
| StatusInvalidNameIDPolicy
| StatusNoAuthnContext
| StatusNoAvailableIDP
| StatusNoPassive
| StatusNoSupportedIDP
| StatusPartialLogout
| StatusProxyCountExceeded
| StatusRequestDenied
| StatusRequestUnsupported
| StatusRequestVersionDeprecated
| StatusRequestVersionTooHigh
| StatusRequestVersionTooLow
| StatusResourceNotRecognized
| StatusTooManyResponses
| StatusUnknownAttrProfile
| StatusUnknownPrincipal
| StatusUnsupportedBinding
deriving (Eq, Bounded, Enum, Show)
instance Identifiable URI StatusCode2 where
identifier = samlURNIdentifier "status" . f where
f StatusAuthnFailed = (SAML20, "AuthnFailed")
f StatusInvalidAttrNameOrValue = (SAML20, "InvalidAttrNameOrValue")
f StatusInvalidNameIDPolicy = (SAML20, "InvalidNameIDPolicy")
f StatusNoAuthnContext = (SAML20, "NoAuthnContext")
f StatusNoAvailableIDP = (SAML20, "NoAvailableIDP")
f StatusNoPassive = (SAML20, "NoPassive")
f StatusNoSupportedIDP = (SAML20, "NoSupportedIDP")
f StatusPartialLogout = (SAML20, "PartialLogout")
f StatusProxyCountExceeded = (SAML20, "ProxyCountExceeded")
f StatusRequestDenied = (SAML20, "RequestDenied")
f StatusRequestUnsupported = (SAML20, "RequestUnsupported")
f StatusRequestVersionDeprecated = (SAML20, "RequestVersionDeprecated")
f StatusRequestVersionTooHigh = (SAML20, "RequestVersionTooHigh")
f StatusRequestVersionTooLow = (SAML20, "RequestVersionTooLow")
f StatusResourceNotRecognized = (SAML20, "ResourceNotRecognized")
f StatusTooManyResponses = (SAML20, "TooManyResponses")
f StatusUnknownAttrProfile = (SAML20, "UnknownAttrProfile")
f StatusUnknownPrincipal = (SAML20, "UnknownPrincipal")
f StatusUnsupportedBinding = (SAML20, "UnsupportedBinding")
successStatus :: Status
successStatus = Status (StatusCode StatusSuccess []) Nothing Nothing
data AssertionIDRequest = AssertionIDRequest
{ assertionIDRequest :: !RequestAbstractType
, assertionIDRequestRef :: List1 (SAML.AssertionIDRef)
} deriving (Eq, Show)
instance XP.XmlPickler AssertionIDRequest where
xpickle = xpElem "AssertionIDRequest" $ [XP.biCase|
(q, r) <-> AssertionIDRequest q r|]
XP.>$< (XP.xpickle
XP.>*< xpList1 XP.xpickle)
instance DS.Signable AssertionIDRequest where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol AssertionIDRequest where
samlProtocol' = samlRequest' . requestProtocol'
isSAMLResponse _ = False
instance SAMLRequest AssertionIDRequest where
samlRequest' = $(fieldLens 'assertionIDRequest)
data SubjectQueryAbstractType = SubjectQueryAbstractType
{ subjectQuery :: !RequestAbstractType
, subjectQuerySubject :: SAML.Subject
} deriving (Eq, Show)
instance XP.XmlPickler SubjectQueryAbstractType where
xpickle = [XP.biCase|
(q, r) <-> SubjectQueryAbstractType q r|]
XP.>$< (XP.xpickle
XP.>*< XP.xpickle)
subjectQuery' :: Lens' SubjectQueryAbstractType RequestAbstractType
subjectQuery' = $(fieldLens 'subjectQuery)
data AuthnQuery = AuthnQuery
{ authnQuery :: !SubjectQueryAbstractType
, authnQuerySessionIndex :: Maybe XString
, authnQueryRequestedAuthnContext :: Maybe RequestedAuthnContext
} deriving (Eq, Show)
instance XP.XmlPickler AuthnQuery where
xpickle = xpElem "AuthnQuery" $ [XP.biCase|
((q, i), c) <-> AuthnQuery q i c|]
XP.>$< (XP.xpickle
XP.>*< XP.xpAttrImplied "SessionIndex" XS.xpString
XP.>*< XP.xpOption XP.xpickle)
instance DS.Signable AuthnQuery where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol AuthnQuery where
samlProtocol' = samlRequest' . requestProtocol'
isSAMLResponse _ = False
instance SAMLRequest AuthnQuery where
samlRequest' = authnQuery' . subjectQuery' where
authnQuery' = $(fieldLens 'authnQuery)
data RequestedAuthnContext = RequestedAuthnContext
{ requestedAuthnContextComparison :: Maybe AuthnContextComparisonType
, requestedAuthnContextRefs :: AuthnContextRefs
} deriving (Eq, Show)
instance XP.XmlPickler RequestedAuthnContext where
xpickle = xpElem "RequestedAuthnContext" $ [XP.biCase|
(c, r) <-> RequestedAuthnContext c r|]
XP.>$< (XP.xpAttrImplied "Comparison" XP.xpickle
XP.>*< XP.xpickle)
data AuthnContextRefs
= AuthnContextClassRefs (List1 AnyURI)
| AuthnContextDeclRefs (List1 AnyURI)
deriving (Eq, Show)
instance XP.XmlPickler AuthnContextRefs where
xpickle = [XP.biCase|
Left l <-> AuthnContextClassRefs l
Right l <-> AuthnContextDeclRefs l|]
XP.>$< (xpList1 (SAML.xpElem "AuthnContextClassRef" XS.xpAnyURI)
XP.>|< xpList1 (SAML.xpElem "AuthnContextDeclRef" XS.xpAnyURI))
data AuthnContextComparisonType
= ComparisonExact
| ComparisonMinimum
| ComparisonMaximum
| ComparisonBetter
deriving (Eq, Enum, Bounded, Show)
instance Identifiable XString AuthnContextComparisonType where
identifier ComparisonExact = "exact"
identifier ComparisonMinimum = "minimum"
identifier ComparisonMaximum = "maximum"
identifier ComparisonBetter = "better"
instance XP.XmlPickler AuthnContextComparisonType where
xpickle = xpIdentifier (XP.xpTextDT (XPS.scDT (namespaceURIString ns) "AuthnContextComparisonType" [])) "AuthnContextComparisonType"
data AttributeQuery = AttributeQuery
{ attributeQuery :: !SubjectQueryAbstractType
, attributeQueryAttributes :: [SAML.Attribute]
} deriving (Eq, Show)
instance XP.XmlPickler AttributeQuery where
xpickle = xpElem "AttributeQuery" $ [XP.biCase|
(q, a) <-> AttributeQuery q a|]
XP.>$< (XP.xpickle
XP.>*< XP.xpList XP.xpickle)
instance DS.Signable AttributeQuery where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol AttributeQuery where
samlProtocol' = samlRequest' . requestProtocol'
isSAMLResponse _ = False
instance SAMLRequest AttributeQuery where
samlRequest' = attributeQuery' . subjectQuery' where
attributeQuery' = $(fieldLens 'attributeQuery)
data AuthzDecisionQuery = AuthzDecisionQuery
{ authzDecisionQuery :: !SubjectQueryAbstractType
, authzDecisionQueryResource :: AnyURI
, authzDecisionQueryActions :: [SAML.Action]
, authzDecisionQueryEvidence :: SAML.Evidence
} deriving (Eq, Show)
instance XP.XmlPickler AuthzDecisionQuery where
xpickle = xpElem "AuthzDecisionQuery" $ [XP.biCase|
(((q, r), a), e) <-> AuthzDecisionQuery q r a e|]
XP.>$< (XP.xpickle
XP.>*< XP.xpAttr "Resource" XS.xpAnyURI
XP.>*< XP.xpList XP.xpickle
XP.>*< XP.xpickle)
instance DS.Signable AuthzDecisionQuery where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol AuthzDecisionQuery where
samlProtocol' = samlRequest' . requestProtocol'
isSAMLResponse _ = False
instance SAMLRequest AuthzDecisionQuery where
samlRequest' = authzDecisionQuery' . subjectQuery' where
authzDecisionQuery' = $(fieldLens 'authzDecisionQuery)
data Response = Response
{ response :: !StatusResponseType
, responseAssertions :: [SAML.PossiblyEncrypted SAML.Assertion]
} deriving (Eq, Show)
instance XP.XmlPickler Response where
xpickle = xpElem "Response" $ [XP.biCase|
(r, a) <-> Response r a|]
XP.>$< (XP.xpickle
XP.>*< XP.xpList SAML.xpPossiblyEncrypted)
instance DS.Signable Response where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol Response where
samlProtocol' = samlResponse' . statusProtocol'
isSAMLResponse _ = True
instance SAMLResponse Response where
samlResponse' = $(fieldLens 'response)
data AuthnRequest = AuthnRequest
{ authnRequest :: !RequestAbstractType
, authnRequestForceAuthn :: XS.Boolean
, authnRequestIsPassive :: XS.Boolean
, authnRequestAssertionConsumerService :: AssertionConsumerService
, authnRequestAssertionConsumingServiceIndex :: Maybe XS.UnsignedShort
, authnRequestProviderName :: Maybe XString
, authnRequestSubject :: Maybe SAML.Subject
, authnRequestNameIDPolicy :: Maybe NameIDPolicy
, authnRequestConditions :: Maybe SAML.Conditions
, authnRequestRequestedAuthnContext :: Maybe RequestedAuthnContext
, authnRequestScoping :: Maybe Scoping
} deriving (Eq, Show)
data AssertionConsumerService
= AssertionConsumerServiceIndex XS.UnsignedShort
| AssertionConsumerServiceURL
{ authnRequestAssertionConsumerServiceURL :: Maybe AnyURI
, authnRequestProtocolBinding :: Maybe (IdentifiedURI Binding)
}
deriving (Eq, Show)
instance XP.XmlPickler AuthnRequest where
xpickle = xpElem "AuthnRequest" $ [XP.biCase|
((((((((((q, f), p), Left i), g), n), s), np), c), r), sc) <-> AuthnRequest q f p (AssertionConsumerServiceIndex i) g n s np c r sc
((((((((((q, f), p), Right (u, b)), g), n), s), np), c), r), sc) <-> AuthnRequest q f p (AssertionConsumerServiceURL u b) g n s np c r sc|]
XP.>$< (XP.xpickle
XP.>*< XP.xpDefault False (XP.xpAttr "ForceAuthn" XS.xpBoolean)
XP.>*< XP.xpDefault False (XP.xpAttr "IsPassive" XS.xpBoolean)
XP.>*< (XP.xpAttr "AssertionConsumerServiceIndex" XS.xpUnsignedShort
XP.>|< (XP.xpAttrImplied "AssertionConsumerServiceURL" XS.xpAnyURI
XP.>*< XP.xpAttrImplied "ProtocolBinding" XP.xpickle))
XP.>*< XP.xpAttrImplied "AttributeConsumingServiceIndex" XS.xpUnsignedShort
XP.>*< XP.xpAttrImplied "ProviderName" XS.xpString
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpOption XP.xpickle)
instance DS.Signable AuthnRequest where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol AuthnRequest where
samlProtocol' = samlRequest' . requestProtocol'
isSAMLResponse _ = False
instance SAMLRequest AuthnRequest where
samlRequest' = $(fieldLens 'authnRequest)
data NameIDPolicy = NameIDPolicy
{ nameIDPolicyFormat :: IdentifiedURI NameIDFormat
, nameIDPolicySPNameQualifier :: Maybe XString
, nameIDPolicyAllowCreate :: Bool
} deriving (Eq, Show)
instance XP.XmlPickler NameIDPolicy where
xpickle = xpElem "NameIDPolicy" $ [XP.biCase|
((f, q), c) <-> NameIDPolicy f q c|]
XP.>$< (XP.xpDefault (Identified NameIDFormatUnspecified) (XP.xpAttr "Format" XP.xpickle)
XP.>*< XP.xpAttrImplied "SPNameQualifier" XS.xpString
XP.>*< XP.xpDefault False (XP.xpAttr "AllowCreate" XS.xpBoolean))
data Scoping = Scoping
{ scopingProxyCount :: Maybe XS.NonNegativeInteger
, scopingIDPList :: Maybe IDPList
, scopingRequesterID :: [AnyURI]
} deriving (Eq, Show)
instance XP.XmlPickler Scoping where
xpickle = xpElem "Scoping" $ [XP.biCase|
((c, i), r) <-> Scoping c i r|]
XP.>$< (XP.xpAttrImplied "ProxyCount" XS.xpNonNegativeInteger
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpList (xpElem "RequesterID" XS.xpAnyURI))
data IDPList = IDPList
{ idpList :: List1 IDPEntry
, idpGetComplete :: Maybe AnyURI
} deriving (Eq, Show)
instance XP.XmlPickler IDPList where
xpickle = xpElem "IDPList" $ [XP.biCase|
(l, c) <-> IDPList l c|]
XP.>$< (xpList1 XP.xpickle
XP.>*< XP.xpOption (xpElem "GetComplete" XS.xpAnyURI))
data IDPEntry = IDPEntry
{ idpEntryProviderID :: AnyURI
, idpEntryName :: Maybe XString
, idpEntryLoc :: Maybe AnyURI
} deriving (Eq, Show)
instance XP.XmlPickler IDPEntry where
xpickle = xpElem "IDPEntry" $ [XP.biCase|
((p, n), l) <-> IDPEntry p n l|]
XP.>$< (XP.xpAttr "ProviderID" XS.xpAnyURI
XP.>*< XP.xpAttrImplied "Name" XS.xpString
XP.>*< XP.xpAttrImplied "Loc" XS.xpAnyURI)
data ArtifactResolve = ArtifactResolve
{ artifactResolve :: !RequestAbstractType
, artifactResolveArtifact :: XString
} deriving (Eq, Show)
instance XP.XmlPickler ArtifactResolve where
xpickle = xpElem "ArtifactResolve" $ [XP.biCase|
(r, a) <-> ArtifactResolve r a|]
XP.>$< (XP.xpickle
XP.>*< xpElem "Artifact" XS.xpString)
instance DS.Signable ArtifactResolve where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol ArtifactResolve where
samlProtocol' = samlRequest' . requestProtocol'
isSAMLResponse _ = False
instance SAMLRequest ArtifactResolve where
samlRequest' = $(fieldLens 'artifactResolve)
data ArtifactResponse = ArtifactResponse
{ artifactResponse :: !StatusResponseType
, artifactResponseMessage :: Maybe Node
} deriving (Eq, Show)
instance XP.XmlPickler ArtifactResponse where
xpickle = xpElem "ArtifactResponse" $ [XP.biCase|
(r, a) <-> ArtifactResponse r a|]
XP.>$< (XP.xpickle
XP.>*< XP.xpOption xpTrimAnyElem)
instance DS.Signable ArtifactResponse where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol ArtifactResponse where
samlProtocol' = samlResponse' . statusProtocol'
isSAMLResponse _ = True
instance SAMLResponse ArtifactResponse where
samlResponse' = $(fieldLens 'artifactResponse)
data ManageNameIDRequest = ManageNameIDRequest
{ manageNameIDRequest :: !RequestAbstractType
, manageNameIDRequestNameID :: SAML.PossiblyEncrypted SAML.NameID
, manageNameIDRequestNewID :: Maybe (SAML.PossiblyEncrypted NewID)
} deriving (Eq, Show)
instance XP.XmlPickler ManageNameIDRequest where
xpickle = xpElem "ManageNameIDRequest" $ [XP.biCase|
((r, o), Left n) <-> ManageNameIDRequest r o (Just n)
((r, o), Right ()) <-> ManageNameIDRequest r o Nothing|]
XP.>$< (XP.xpickle
XP.>*< SAML.xpPossiblyEncrypted
XP.>*< (SAML.xpPossiblyEncrypted
XP.>|< xpElem "Terminate" XP.xpUnit))
instance DS.Signable ManageNameIDRequest where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol ManageNameIDRequest where
samlProtocol' = samlRequest' . requestProtocol'
isSAMLResponse _ = False
instance SAMLRequest ManageNameIDRequest where
samlRequest' = $(fieldLens 'manageNameIDRequest)
newtype NewID = NewID{ newID :: XString }
deriving (Eq, Show)
instance XP.XmlPickler NewID where
xpickle = xpElem "NewID" $ [XP.biCase|
n <-> NewID n|]
XP.>$< XS.xpString
type NewEncryptedID = SAML.EncryptedElement NewID
instance XP.XmlPickler NewEncryptedID where
xpickle = xpElem "NewEncryptedID" SAML.xpEncryptedElement
newtype ManageNameIDResponse = ManageNameIDResponse
{ manageNameIDResponse :: StatusResponseType }
deriving (Eq, Show)
instance XP.XmlPickler ManageNameIDResponse where
xpickle = xpElem "ManageNameIDResponse" $ [XP.biCase|
r <-> ManageNameIDResponse r|]
XP.>$< XP.xpickle
instance DS.Signable ManageNameIDResponse where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol ManageNameIDResponse where
samlProtocol' = samlResponse' . statusProtocol'
isSAMLResponse _ = True
instance SAMLResponse ManageNameIDResponse where
samlResponse' = $(fieldLens 'manageNameIDResponse)
data LogoutRequest = LogoutRequest
{ logoutRequest :: !RequestAbstractType
, logoutRequestReason :: Maybe (Identified XString LogoutReason)
, logoutRequestNotOnOrAfter :: Maybe XS.DateTime
, logoutRequestIdentifier :: SAML.PossiblyEncrypted SAML.Identifier
, logoutRequestSessionIndex :: Maybe XString
} deriving (Eq, Show)
instance XP.XmlPickler LogoutRequest where
xpickle = xpElem "LogoutRequest" $ [XP.biCase|
((((q, r), t), i), s) <-> LogoutRequest q r t i s|]
XP.>$< (XP.xpickle
XP.>*< XP.xpAttrImplied "Reason" XP.xpickle
XP.>*< XP.xpAttrImplied "NotOnOrAfter" XS.xpDateTime
XP.>*< SAML.xpPossiblyEncrypted
XP.>*< XP.xpOption (xpElem "SessionIndex" XS.xpString))
instance DS.Signable LogoutRequest where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol LogoutRequest where
samlProtocol' = samlRequest' . requestProtocol'
isSAMLResponse _ = False
instance SAMLRequest LogoutRequest where
samlRequest' = $(fieldLens 'logoutRequest)
newtype LogoutResponse = LogoutResponse
{ logoutResponse :: StatusResponseType }
deriving (Eq, Show)
instance XP.XmlPickler LogoutResponse where
xpickle = xpElem "LogoutResponse" $ [XP.biCase|
r <-> LogoutResponse r|]
XP.>$< XP.xpickle
instance DS.Signable LogoutResponse where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol LogoutResponse where
samlProtocol' = samlResponse' . statusProtocol'
isSAMLResponse _ = True
instance SAMLResponse LogoutResponse where
samlResponse' = $(fieldLens 'logoutResponse)
data LogoutReason
= LogoutReasonUser
| LogoutReasonAdmin
deriving (Eq, Enum, Bounded, Show)
instance Identifiable XString LogoutReason where
identifier = show . samlURNIdentifier "logout" . f where
f LogoutReasonUser = (SAML20, "user")
f LogoutReasonAdmin = (SAML20, "admin")
instance XP.XmlPickler (Identified XString LogoutReason) where
xpickle = xpIdentified XS.xpString
data NameIDMappingRequest = NameIDMappingRequest
{ nameIDMappingRequest :: !RequestAbstractType
, nameIDMappingRequestIdentifier :: SAML.PossiblyEncrypted SAML.Identifier
, nameIDMappingRequestPolicy :: NameIDPolicy
} deriving (Eq, Show)
instance XP.XmlPickler NameIDMappingRequest where
xpickle = xpElem "NameIDMappingRequest" $ [XP.biCase|
((r, i), p) <-> NameIDMappingRequest r i p|]
XP.>$< (XP.xpickle
XP.>*< SAML.xpPossiblyEncrypted
XP.>*< XP.xpickle)
instance DS.Signable NameIDMappingRequest where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol NameIDMappingRequest where
samlProtocol' = samlRequest' . requestProtocol'
isSAMLResponse _ = False
instance SAMLRequest NameIDMappingRequest where
samlRequest' = $(fieldLens 'nameIDMappingRequest)
data NameIDMappingResponse = NameIDMappingResponse
{ nameIDMappingResponse :: !StatusResponseType
, nameIDMappingResponseNameID :: SAML.PossiblyEncrypted SAML.NameID
} deriving (Eq, Show)
instance XP.XmlPickler NameIDMappingResponse where
xpickle = xpElem "NameIDMappingResponse" $ [XP.biCase|
(r, a) <-> NameIDMappingResponse r a|]
XP.>$< (XP.xpickle
XP.>*< SAML.xpPossiblyEncrypted)
instance DS.Signable NameIDMappingResponse where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol NameIDMappingResponse where
samlProtocol' = samlResponse' . statusProtocol'
isSAMLResponse _ = True
instance SAMLResponse NameIDMappingResponse where
samlResponse' = $(fieldLens 'nameIDMappingResponse)
data AnyRequest
= RequestAssertionIDRequest !AssertionIDRequest
| RequestAuthnQuery !AuthnQuery
| RequestAttributeQuery !AttributeQuery
| RequestAuthzDecisionQuery !AuthzDecisionQuery
| RequestAuthnRequest !AuthnRequest
| RequestArtifactResolve !ArtifactResolve
| RequestManageNameIDRequest !ManageNameIDRequest
| RequestLogoutRequest !LogoutRequest
| RequestNameIDMappingRequest !NameIDMappingRequest
deriving (Eq, Show)
instance XP.XmlPickler AnyRequest where
xpickle = [XP.biCase|
Left (Left (Left (Left (Left (Left (Left (Left r))))))) <-> RequestAssertionIDRequest r
Left (Left (Left (Left (Left (Left (Left (Right r))))))) <-> RequestAuthnQuery r
Left (Left (Left (Left (Left (Left (Right r)))))) <-> RequestAttributeQuery r
Left (Left (Left (Left (Left (Right r))))) <-> RequestAuthzDecisionQuery r
Left (Left (Left (Left (Right r)))) <-> RequestAuthnRequest r
Left (Left (Left (Right r))) <-> RequestArtifactResolve r
Left (Left (Right r)) <-> RequestManageNameIDRequest r
Left (Right r) <-> RequestLogoutRequest r
Right r <-> RequestNameIDMappingRequest r|]
XP.>$< (XP.xpickle
XP.>|< XP.xpickle
XP.>|< XP.xpickle
XP.>|< XP.xpickle
XP.>|< XP.xpickle
XP.>|< XP.xpickle
XP.>|< XP.xpickle
XP.>|< XP.xpickle
XP.>|< XP.xpickle)
instance DS.Signable AnyRequest where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol AnyRequest where
samlProtocol' = samlRequest' . requestProtocol'
isSAMLResponse _ = False
instance SAMLRequest AnyRequest where
samlRequest' = lens g s where
g (RequestAssertionIDRequest r) = r ^. samlRequest'
g (RequestAuthnQuery r) = r ^. samlRequest'
g (RequestAttributeQuery r) = r ^. samlRequest'
g (RequestAuthzDecisionQuery r) = r ^. samlRequest'
g (RequestAuthnRequest r) = r ^. samlRequest'
g (RequestArtifactResolve r) = r ^. samlRequest'
g (RequestManageNameIDRequest r) = r ^. samlRequest'
g (RequestLogoutRequest r) = r ^. samlRequest'
g (RequestNameIDMappingRequest r) = r ^. samlRequest'
s (RequestAssertionIDRequest r) q = RequestAssertionIDRequest $ samlRequest' .~ q $ r
s (RequestAuthnQuery r) q = RequestAuthnQuery $ samlRequest' .~ q $ r
s (RequestAttributeQuery r) q = RequestAttributeQuery $ samlRequest' .~ q $ r
s (RequestAuthzDecisionQuery r) q = RequestAuthzDecisionQuery $ samlRequest' .~ q $ r
s (RequestAuthnRequest r) q = RequestAuthnRequest $ samlRequest' .~ q $ r
s (RequestArtifactResolve r) q = RequestArtifactResolve $ samlRequest' .~ q $ r
s (RequestManageNameIDRequest r) q = RequestManageNameIDRequest $ samlRequest' .~ q $ r
s (RequestLogoutRequest r) q = RequestLogoutRequest $ samlRequest' .~ q $ r
s (RequestNameIDMappingRequest r) q = RequestNameIDMappingRequest $ samlRequest' .~ q $ r
data AnyResponse
= ResponseResponse !Response
| ResponseArtifactResponse !ArtifactResponse
deriving (Eq, Show)
instance XP.XmlPickler AnyResponse where
xpickle = [XP.biCase|
Left r <-> ResponseResponse r
Right r <-> ResponseArtifactResponse r|]
XP.>$< (XP.xpickle
XP.>|< XP.xpickle)
instance DS.Signable AnyResponse where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol AnyResponse where
samlProtocol' = samlResponse' . statusProtocol'
isSAMLResponse _ = True
instance SAMLResponse AnyResponse where
samlResponse' = lens g s where
g (ResponseResponse r) = r ^. samlResponse'
g (ResponseArtifactResponse r) = r ^. samlResponse'
s (ResponseResponse r) q = ResponseResponse $ samlResponse' .~ q $ r
s (ResponseArtifactResponse r) q = ResponseArtifactResponse $ samlResponse' .~ q $ r
data AnyProtocol
= ProtocolRequest !AnyRequest
| ProtocolResponse !AnyResponse
deriving (Eq, Show)
instance XP.XmlPickler AnyProtocol where
xpickle = [XP.biCase|
Left r <-> ProtocolRequest r
Right r <-> ProtocolResponse r|]
XP.>$< (XP.xpickle
XP.>|< XP.xpickle)
instance DS.Signable AnyProtocol where
signature' = samlProtocol' . DS.signature'
signedID = protocolID . view samlProtocol'
instance SAMLProtocol AnyProtocol where
samlProtocol' = lens g s where
g (ProtocolRequest r) = r ^. samlProtocol'
g (ProtocolResponse r) = r ^. samlProtocol'
s (ProtocolRequest r) q = ProtocolRequest $ samlProtocol' .~ q $ r
s (ProtocolResponse r) q = ProtocolResponse $ samlProtocol' .~ q $ r
isSAMLResponse (ProtocolRequest _) = False
isSAMLResponse (ProtocolResponse _) = True
isSAMLResponse_ _ = Nothing