{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module SAML2.Metadata.Metadata where
import Data.Foldable (fold)
import qualified Network.URI as URI
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 qualified SAML2.Core.Assertions as SAML
import SAML2.Bindings.Identifiers
ns :: Namespace
ns = mkNamespace "md" $ samlURN SAML20 ["metadata"]
xpElem :: String -> XP.PU a -> XP.PU a
xpElem = xpTrimElemNS ns
type EntityID = AnyURI
xpEntityID :: XP.PU EntityID
xpEntityID = XS.xpAnyURI
data Endpoint = Endpoint
{ endpointBinding :: IdentifiedURI Binding
, endpointLocation :: AnyURI
, endpointResponseLocation :: Maybe AnyURI
, endpointAttrs :: Nodes
, endpointXML :: Nodes
} deriving (Eq, Show)
instance XP.XmlPickler Endpoint where
xpickle = [XP.biCase|
((((b, l), r), a), x) <-> Endpoint b l r a x|]
XP.>$< (XP.xpAttr "Binding" XP.xpickle
XP.>*< XP.xpAttr "Location" XS.xpAnyURI
XP.>*< XP.xpAttrImplied "ResponseLocation" XS.xpAnyURI
XP.>*< XP.xpAnyAttrs
XP.>*< XP.xpList xpTrimAnyElem)
data IndexedEndpoint = IndexedEndpoint
{ indexedEndpoint :: Endpoint
, indexedEndpointIndex :: XS.UnsignedShort
, indexedEndpointIsDefault :: XS.Boolean
} deriving (Eq, Show)
instance XP.XmlPickler IndexedEndpoint where
xpickle = [XP.biCase|
((i, d), e) <-> IndexedEndpoint e i d|]
XP.>$< (XP.xpAttr "index" XS.xpUnsignedShort
XP.>*< XP.xpDefault False (XP.xpAttr "isDefault" XS.xpBoolean)
XP.>*< XP.xpickle)
data Localized a = Localized
{ localizedLang :: XS.Language
, localized :: a
} deriving (Eq, Show)
xpLocalized :: XP.PU a -> XP.PU (Localized a)
xpLocalized p = [XP.biCase|
(l, x) <-> Localized l x|]
XP.>$< (xpXmlLang
XP.>*< p)
type LocalizedName = Localized XS.String
instance XP.XmlPickler LocalizedName where
xpickle = xpLocalized XS.xpString
type LocalizedURI = Localized XS.AnyURI
instance XP.XmlPickler LocalizedURI where
xpickle = xpLocalized XS.xpAnyURI
data Metadata
= EntityDescriptor
{ entityID :: EntityID
, metadataID :: Maybe XS.ID
, metadataValidUntil :: Maybe XS.DateTime
, metadataCacheDuration :: Maybe XS.Duration
, entityAttrs :: Nodes
, metadataSignature :: Maybe DS.Signature
, metadataExtensions :: Extensions
, entityDescriptors :: Descriptors
, entityOrganization :: Maybe Organization
, entityContactPerson :: [Contact]
, entityAditionalMetadataLocation :: [AdditionalMetadataLocation]
}
| EntitiesDescriptor
{ metadataID :: Maybe XS.ID
, metadataValidUntil :: Maybe XS.DateTime
, metadataCacheDuration :: Maybe XS.Duration
, entitiesName :: Maybe XS.String
, metadataSignature :: Maybe DS.Signature
, metadataExtensions :: Extensions
, entities :: List1 Metadata
}
deriving (Eq, Show)
instance XP.XmlPickler Metadata where
xpickle = [XP.biCase|
Left ((((((((((e, i), vu), cd), xa), sig), ext), desc), org), cp), aml) <-> EntityDescriptor e i vu cd xa sig ext desc org cp aml
Right ((((((i, vu), cd), n), sig), ext), l) <-> EntitiesDescriptor i vu cd n sig ext l|]
XP.>$< (xpElem "EntityDescriptor"
(XP.xpAttr "entityID" xpEntityID
XP.>*< XP.xpAttrImplied "ID" XS.xpID
XP.>*< XP.xpAttrImplied "validUntil" XS.xpDateTime
XP.>*< XP.xpAttrImplied "cacheDuration" XS.xpDuration
XP.>*< XP.xpAnyAttrs
XP.>*< XP.xpickle
XP.>*< XP.xpickle
XP.>*< XP.xpickle
XP.>*< XP.xpickle
XP.>*< XP.xpList XP.xpickle
XP.>*< XP.xpList XP.xpickle)
XP.>|< xpElem "EntitiesDescriptor"
(XP.xpAttrImplied "ID" XS.xpID
XP.>*< XP.xpAttrImplied "validUntil" XS.xpDateTime
XP.>*< XP.xpAttrImplied "cacheDuration" XS.xpDuration
XP.>*< XP.xpAttrImplied "Name" XS.xpString
XP.>*< XP.xpickle
XP.>*< XP.xpickle
XP.>*< xpList1 XP.xpickle))
instance DS.Signable Metadata where
signature' = $(fieldLens 'metadataSignature)
signedID = fold . metadataID
newtype Extensions = Extensions{ extensions :: Nodes }
deriving (Eq, Show, Monoid)
instance XP.XmlPickler Extensions where
xpickle = XP.xpDefault (Extensions []) $
xpElem "Extensions" $ [XP.biCase|
x <-> Extensions x|]
XP.>$< (XP.xpList1 xpTrimAnyElem)
data Descriptors
= Descriptors{ descriptors :: List1 Descriptor }
| AffiliationDescriptor
{ affiliationDescriptorAffiliationOwnerID :: EntityID
, affiliationDescriptorID :: Maybe XS.ID
, affiliationDescriptorValidUntil :: Maybe XS.DateTime
, affiliationDescriptorCacheDuration :: Maybe XS.Duration
, affiliationDescriptorAttrs :: Nodes
, affiliationDescriptorSignature :: Maybe DS.Signature
, affiliationDescriptorExtensions :: Extensions
, affiliationDescriptorAffiliateMember :: List1 EntityID
, affiliationDescriptorKeyDescriptor :: [KeyDescriptor]
}
deriving (Eq, Show)
instance XP.XmlPickler Descriptors where
xpickle = [XP.biCase|
Left l <-> Descriptors l
Right ((((((((o, i), vu), cd), a), sig), ext), am), kd) <-> AffiliationDescriptor o i vu cd a sig ext am kd|]
XP.>$< (xpList1 XP.xpickle
XP.>|< xpElem "AffiliationDescriptor"
(XP.xpAttr "affiliationOwnerID" xpEntityID
XP.>*< XP.xpAttrImplied "ID" XS.xpID
XP.>*< XP.xpAttrImplied "validUntil" XS.xpDateTime
XP.>*< XP.xpAttrImplied "cacheDuration" XS.xpDuration
XP.>*< XP.xpAnyAttrs
XP.>*< XP.xpickle
XP.>*< XP.xpickle
XP.>*< xpList1 (xpElem "AffiliateMember" xpEntityID)
XP.>*< XP.xpList XP.xpickle))
data Descriptor
= Descriptor
{ descriptorRole :: !RoleDescriptor
}
| IDPSSODescriptor
{ descriptorRole :: !RoleDescriptor
, descriptorSSO :: !SSODescriptor
, descriptorWantAuthnRequestsSigned :: XS.Boolean
, descriptorSingleSignOnService :: List1 Endpoint
, descriptorNameIDMappingService :: [Endpoint]
, descriptorAssertionIDRequestService :: [Endpoint]
, descriptorAttributeProfile :: [XS.AnyURI]
, descriptorAttribute :: [SAML.Attribute]
}
| SPSSODescriptor
{ descriptorRole :: !RoleDescriptor
, descriptorSSO :: !SSODescriptor
, descriptorAuthnRequestsSigned :: XS.Boolean
, descriptorWantAssertionsSigned :: XS.Boolean
, descriptorAssertionConsumerService :: List1 IndexedEndpoint
, descriptorAttributeConsumingService :: [AttributeConsumingService]
}
| AuthnAuthorityDescriptor
{ descriptorRole :: !RoleDescriptor
, descriptorAuthnQueryService :: List1 Endpoint
, descriptorAssertionIDRequestService :: [Endpoint]
, descriptorNameIDFormat :: [IdentifiedURI NameIDFormat]
}
| AttributeAuthorityDescriptor
{ descriptorRole :: !RoleDescriptor
, descriptorAttributeService :: List1 Endpoint
, descriptorAssertionIDRequestService :: [Endpoint]
, descriptorNameIDFormat :: [IdentifiedURI NameIDFormat]
, descriptorAttributeProfile :: [XS.AnyURI]
, descriptorAttribute :: [SAML.Attribute]
}
| PDPDescriptor
{ descriptorRole :: !RoleDescriptor
, descriptorAuthzService :: List1 Endpoint
, descriptorAssertionIDRequestService :: [Endpoint]
, descriptorNameIDFormat :: [IdentifiedURI NameIDFormat]
}
deriving (Eq, Show)
instance XP.XmlPickler Descriptor where
xpickle = [XP.biCase|
Left (Left (Left (Left (Left r)))) <-> Descriptor r
Left (Left (Left (Left (Right (((((((ws, r), s), sso), nim), air), ap), a))))) <-> IDPSSODescriptor r s ws sso nim air ap a
Left (Left (Left (Right (((((a, w), r), s), e), t)))) <-> SPSSODescriptor r s a w e t
Left (Left (Right (((r, a), s), n))) <-> AuthnAuthorityDescriptor r a s n
Left (Right (((((r, a), s), n), tp), t)) <-> AttributeAuthorityDescriptor r a s n tp t
Right (((r, a), s), n) <-> PDPDescriptor r a s n|]
XP.>$< (xpElem "RoleDescriptor" XP.xpickle
XP.>|< xpElem "IDPSSODescriptor"
(XP.xpDefault False (XP.xpAttr "WantAuthnRequestsSigned" XS.xpBoolean)
XP.>*< XP.xpickle
XP.>*< XP.xpickle
XP.>*< xpList1 (xpElem "SingleSignOnService" XP.xpickle)
XP.>*< XP.xpList (xpElem "NameIDMappingService" XP.xpickle)
XP.>*< XP.xpList (xpElem "AssertionIDRequestService" XP.xpickle)
XP.>*< XP.xpList (xpElem "AttributeProfile" XS.xpAnyURI)
XP.>*< XP.xpList XP.xpickle)
XP.>|< xpElem "SPSSODescriptor"
(XP.xpDefault False (XP.xpAttr "AuthnRequestsSigned" XS.xpBoolean)
XP.>*< XP.xpDefault False (XP.xpAttr "WantAssertionsSigned" XS.xpBoolean)
XP.>*< XP.xpickle
XP.>*< XP.xpickle
XP.>*< xpList1 (xpElem "AssertionConsumerService" XP.xpickle)
XP.>*< XP.xpList XP.xpickle)
XP.>|< xpElem "AuthnAuthorityDescriptor"
(XP.xpickle
XP.>*< xpList1 (xpElem "AuthnQueryService" XP.xpickle)
XP.>*< XP.xpList (xpElem "AssertionIDRequestService" XP.xpickle)
XP.>*< XP.xpList (xpElem "NameIDFormat" XP.xpickle))
XP.>|< xpElem "AttributeAuthorityDescriptor"
(XP.xpickle
XP.>*< xpList1 (xpElem "AttributeService" XP.xpickle)
XP.>*< XP.xpList (xpElem "AssertionIDRequestService" XP.xpickle)
XP.>*< XP.xpList (xpElem "NameIDFormat" XP.xpickle)
XP.>*< XP.xpList (xpElem "AttributeProfile" XS.xpAnyURI)
XP.>*< XP.xpList XP.xpickle)
XP.>|< xpElem "PDPDescriptor"
(XP.xpickle
XP.>*< xpList1 (xpElem "AuthzService" XP.xpickle)
XP.>*< XP.xpList (xpElem "AssertionIDRequestService" XP.xpickle)
XP.>*< XP.xpList (xpElem "NameIDFormat" XP.xpickle)))
data Organization = Organization
{ organizationAttrs :: Nodes
, organizationExtensions :: Extensions
, organizationName :: List1 LocalizedName
, organizationDisplayName :: List1 LocalizedName
, organizationURL :: List1 LocalizedURI
} deriving (Eq, Show)
instance XP.XmlPickler Organization where
xpickle = xpElem "Organization" $
[XP.biCase|
((((a, e), n), d), u) <-> Organization a e n d u|]
XP.>$< (XP.xpAnyAttrs
XP.>*< XP.xpickle
XP.>*< xpList1 (xpElem "OrganizationName" XP.xpickle)
XP.>*< xpList1 (xpElem "OrganizationDisplayName" XP.xpickle)
XP.>*< xpList1 (xpElem "OrganizationURL" XP.xpickle))
data Contact = ContactPerson
{ contactType :: ContactType
, contactAttrs :: Nodes
, contactExtensions :: Extensions
, contactCompany :: Maybe XS.String
, contactGivenName :: Maybe XS.String
, contactSurName :: Maybe XS.String
, contactEmailAddress :: [XS.AnyURI]
, contactTelephoneNumber :: [XS.String]
} deriving (Eq, Show)
instance XP.XmlPickler Contact where
xpickle = xpElem "ContactPerson" $
[XP.biCase|
(((((((t, a), ext), c), g), s), e), tn) <-> ContactPerson t a ext c g s e tn|]
XP.>$< (XP.xpAttr "contactType" XP.xpickle
XP.>*< XP.xpAnyAttrs
XP.>*< XP.xpickle
XP.>*< XP.xpOption (xpElem "Company" XS.xpString)
XP.>*< XP.xpOption (xpElem "GivenName" XS.xpString)
XP.>*< XP.xpOption (xpElem "SurName" XS.xpString)
XP.>*< XP.xpList (xpElem "EmailAddress" XS.xpAnyURI)
XP.>*< XP.xpList (xpElem "TelephoneNumber" XS.xpString))
data ContactType
= ContactTypeTechnical
| ContactTypeSupport
| ContactTypeAdministrative
| ContactTypeBilling
| ContactTypeOther
deriving (Eq, Enum, Bounded, Show)
instance Identifiable XString ContactType where
identifier ContactTypeTechnical = "technical"
identifier ContactTypeSupport = "support"
identifier ContactTypeAdministrative = "administrative"
identifier ContactTypeBilling = "billing"
identifier ContactTypeOther = "other"
instance XP.XmlPickler ContactType where
xpickle = xpIdentifier (XP.xpTextDT (XPS.scDT (namespaceURIString ns) "ContactTypeType" [])) "ContactTypeType"
data AdditionalMetadataLocation = AdditionalMetadataLocation
{ additionalMetadataLocationNamespace :: XS.AnyURI
, additionalMetadataLocation :: XS.AnyURI
} deriving (Eq, Show)
instance XP.XmlPickler AdditionalMetadataLocation where
xpickle = xpElem "AdditionalMetadataLocation" $
[XP.biCase|
(n, l) <-> AdditionalMetadataLocation n l|]
XP.>$< (XP.xpAttr "namespace" XS.xpAnyURI
XP.>*< XS.xpAnyURI)
data RoleDescriptor = RoleDescriptor
{ roleDescriptorID :: Maybe XS.ID
, roleDescriptorValidUntil :: Maybe XS.DateTime
, roleDescriptorCacheDuration :: Maybe XS.Duration
, roleDescriptorProtocolSupportEnumeration :: [XS.AnyURI]
, roleDescriptorErrorURL :: Maybe XS.AnyURI
, roleDescriptorAttrs :: Nodes
, roleDescriptorSignature :: Maybe DS.Signature
, roleDescriptorExtensions :: Extensions
, roleDescriptorKeyDescriptor :: [KeyDescriptor]
, roleDescriptorOrganization :: Maybe Organization
, roleDescriptorContactPerson :: [Contact]
} deriving (Eq, Show)
instance XP.XmlPickler RoleDescriptor where
xpickle = [XP.biCase|
((((((((((i, vu), cd), ps), eu), a), sig), ext), key), org), cp) <-> RoleDescriptor i vu cd ps eu a sig ext key org cp|]
XP.>$< (XP.xpAttrImplied "ID" XS.xpID
XP.>*< XP.xpAttrImplied "validUntil" XS.xpDateTime
XP.>*< XP.xpAttrImplied "cacheDuration" XS.xpDuration
XP.>*< XP.xpAttr "protocolSupportEnumeration" xpAnyURIList
XP.>*< XP.xpAttrImplied "errorURL" XS.xpAnyURI
XP.>*< XP.xpAnyAttrs
XP.>*< XP.xpickle
XP.>*< XP.xpickle
XP.>*< XP.xpList XP.xpickle
XP.>*< XP.xpOption XP.xpickle
XP.>*< XP.xpList XP.xpickle)
where
xpAnyURIList = XP.xpWrapEither
( mapM (maybe (Left "invalid anyURI") Right . URI.parseURIReference) . words
, tail . foldr ((.) (' ':) . URI.uriToString id) ""
) $ XP.xpTextDT $ XPS.scDT (namespaceURIString ns) "anyURIListType" []
instance DS.Signable RoleDescriptor where
signature' = $(fieldLens 'roleDescriptorSignature)
signedID = fold . roleDescriptorID
data KeyDescriptor = KeyDescriptor
{ keyDescriptorUse :: KeyTypes
, keyDescriptorKeyInfo :: DS.KeyInfo
, keyDescriptorEncryptionMethod :: [XEnc.EncryptionMethod]
} deriving (Eq, Show)
instance XP.XmlPickler KeyDescriptor where
xpickle = xpElem "KeyDescriptor" $
[XP.biCase|
((t, i), m) <-> KeyDescriptor t i m|]
XP.>$< (XP.xpDefault KeyTypeBoth (XP.xpAttr "use" XP.xpickle)
XP.>*< XP.xpickle
XP.>*< XP.xpList (xpElem "EncryptionMethod" XEnc.xpEncryptionMethodType))
data KeyTypes
= KeyTypeSigning
| KeyTypeEncryption
| KeyTypeBoth
deriving (Eq, Enum, Bounded, Show)
keyType :: KeyTypes -> KeyTypes -> Bool
keyType _ KeyTypeBoth = True
keyType k t = k == t
instance Identifiable XString KeyTypes where
identifier KeyTypeSigning = "signing"
identifier KeyTypeEncryption = "encryption"
identifier KeyTypeBoth = ""
identifiedValues = [KeyTypeEncryption, KeyTypeSigning]
instance XP.XmlPickler KeyTypes where
xpickle = xpIdentifier (XP.xpTextDT (XPS.scDT (namespaceURIString ns) "KeyTypes" [])) "KeyTypes"
data SSODescriptor = SSODescriptor
{ ssoDescriptorArtifactResolutionService :: [IndexedEndpoint]
, ssoDescriptorSingleLogoutService :: [Endpoint]
, ssoDescriptorManageNameIDService :: [Endpoint]
, ssoDescriptorNameIDFormat :: [IdentifiedURI NameIDFormat]
} deriving (Eq, Show)
instance XP.XmlPickler SSODescriptor where
xpickle = [XP.biCase|
(((a, s), m), n) <-> SSODescriptor a s m n|]
XP.>$< (XP.xpList (xpElem "ArtifactResolutionService" XP.xpickle)
XP.>*< XP.xpList (xpElem "SingleLogoutService" XP.xpickle)
XP.>*< XP.xpList (xpElem "ManageNameIDService" XP.xpickle)
XP.>*< XP.xpList (xpElem "NameIDFormat" XP.xpickle))
data AttributeConsumingService = AttributeConsumingService
{ attributeConsumingServiceIndex :: XS.UnsignedShort
, attributeConsumingServiceIsDefault :: Bool
, attributeConsumingServiceServiceName :: List1 LocalizedName
, attributeConsumingServiceServiceDescription :: [LocalizedName]
, attributeConsumingServiceRequestedAttribute :: List1 RequestedAttribute
} deriving (Eq, Show)
instance XP.XmlPickler AttributeConsumingService where
xpickle = xpElem "AttributeConsumingService" $
[XP.biCase|
((((i, d), sn), sd), ra) <-> AttributeConsumingService i d sn sd ra|]
XP.>$< (XP.xpAttr "index" XS.xpUnsignedShort
XP.>*< XP.xpDefault False (XP.xpAttr "isDefault" XS.xpBoolean)
XP.>*< xpList1 (xpElem "ServiceName" XP.xpickle)
XP.>*< XP.xpList (xpElem "ServiceDescription" XP.xpickle)
XP.>*< xpList1 XP.xpickle)
data RequestedAttribute = RequestedAttribute
{ requestedAttribute :: !SAML.Attribute
, requestedAttributeIsRequired :: Bool
} deriving (Eq, Show)
instance XP.XmlPickler RequestedAttribute where
xpickle = xpElem "RequestedAttribute" $
[XP.biCase|
(r, a) <-> RequestedAttribute a r|]
XP.>$< (XP.xpDefault False (XP.xpAttr "isRequired" XS.xpBoolean)
XP.>*< SAML.xpAttributeType)