{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- FUTUREWORK: consider using http://hackage.haskell.org/package/xml-conduit-parse

module SAML2.WebSSO.XML
  ( HasXML (..),
    HasXMLRoot (..),
    HasXMLImport (..),
    attributeIsCI,
    defNameSpaces,
    encode,
    decode,
    encodeElem,
    decodeElem,
    renderToDocument,
    parseFromDocument,
    parseFromXmlTree,
    unsafeReadTime,
    decodeTime,
    renderTime,
    explainDeniedReason,
    mkSPMetadata,
  )
where

import Control.Arrow ((>>>))
import Control.Category (Category (..))
import Control.Exception (SomeException)
import Control.Lens hiding (element)
import Control.Monad
import Control.Monad.Except
import Data.CaseInsensitive (CI)
import Data.CaseInsensitive qualified as CI
import Data.EitherR
import Data.Foldable (toList)
import Data.Kind (Type)
import Data.List qualified as List
import Data.List.NonEmpty as NL (NonEmpty ((:|)), nonEmpty)
import Data.List.NonEmpty qualified as NL
import Data.Map qualified as Map
import Data.Maybe
import Data.String.Conversions
import Data.Text (Text)
import Data.Text qualified as ST
import Data.Text.Lazy.Encoding
import Data.Time
import Data.Typeable (Proxy (Proxy), Typeable)
import Data.X509 qualified as X509
import GHC.Stack
import Network.URI qualified as URI
import SAML2.Bindings.Identifiers qualified as HX
import SAML2.Core qualified as HX
import SAML2.Metadata.Metadata qualified as HX
import SAML2.Profiles qualified as HX
import SAML2.Util
import SAML2.WebSSO.SP
import SAML2.WebSSO.Types
import SAML2.WebSSO.Types.Email qualified as Email
import SAML2.XML qualified as HX
import SAML2.XML.Schema.Datatypes qualified as HX (Boolean, Duration, UnsignedShort)
import SAML2.XML.Signature.Types qualified as HX (Signature)
import Text.Hamlet.XML (xml)
import Text.XML
import Text.XML.Cursor
import Text.XML.DSig (parseKeyInfo, renderKeyInfo)
import Text.XML.HXT.Arrow.Pickle.Xml qualified as HXT
import Text.XML.HXT.DOM.TypeDefs (XmlTree)
import URI.ByteString as U
import Prelude hiding (id, (.))

defNameSpaces :: [(ST, ST)]
defNameSpaces :: [(Text, Text)]
defNameSpaces =
  [ (Text
"samlp", Text
"urn:oasis:names:tc:SAML:2.0:protocol"),
    (Text
"samla", Text
"urn:oasis:names:tc:SAML:2.0:assertion"),
    (Text
"samlm", Text
"urn:oasis:names:tc:SAML:2.0:metadata"),
    (Text
"ds", Text
"http://www.w3.org/2000/09/xmldsig#")
  ]

----------------------------------------------------------------------
-- HasXML class

encode :: forall a. (HasXMLRoot a) => a -> LT
encode :: forall a. HasXMLRoot a => a -> LT
encode = RenderSettings -> Document -> LT
Text.XML.renderText RenderSettings
settings (Document -> LT) -> (a -> Document) -> a -> LT
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Document
forall a. HasXMLRoot a => a -> Document
renderToDocument
  where
    settings :: RenderSettings
settings = RenderSettings
forall a. Default a => a
def {rsNamespaces = nameSpaces (Proxy @a), rsXMLDeclaration = False}

decode :: forall m a. (HasXMLRoot a, MonadError String m) => LT -> m a
decode :: forall (m :: * -> *) a.
(HasXMLRoot a, MonadError String m) =>
LT -> m a
decode = (SomeException -> m a)
-> (Document -> m a) -> Either SomeException Document -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m a
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m a)
-> (SomeException -> String) -> SomeException -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show @SomeException) Document -> m a
forall a (m :: * -> *).
(HasXML a, MonadError String m) =>
Document -> m a
parseFromDocument (Either SomeException Document -> m a)
-> (LT -> Either SomeException Document) -> LT -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ParseSettings -> LT -> Either SomeException Document
parseText ParseSettings
forall a. Default a => a
def

encodeElem :: forall a. (HasXML a) => a -> LT
encodeElem :: forall a. HasXML a => a -> LT
encodeElem = RenderSettings -> Document -> LT
Text.XML.renderText RenderSettings
settings (Document -> LT) -> (a -> Document) -> a -> LT
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Node] -> Document
mkDocument' ([Node] -> Document) -> (a -> [Node]) -> a -> Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> [Node]
forall a. HasXML a => a -> [Node]
render
  where
    settings :: RenderSettings
settings = RenderSettings
forall a. Default a => a
def {rsNamespaces = nameSpaces (Proxy @a), rsXMLDeclaration = False}
    mkDocument' :: [Node] -> Document
mkDocument' [NodeElement Element
el] = Element -> Document
mkDocument Element
el
    mkDocument' [Node]
bad = String -> Document
forall a. HasCallStack => String -> a
error (String -> Document) -> String -> Document
forall a b. (a -> b) -> a -> b
$ String
"encodeElem: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Node] -> String
forall a. Show a => a -> String
show [Node]
bad

decodeElem :: forall a m. (HasXML a, MonadError String m) => LT -> m a
decodeElem :: forall a (m :: * -> *).
(HasXML a, MonadError String m) =>
LT -> m a
decodeElem = (SomeException -> m a)
-> (Document -> m a) -> Either SomeException Document -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m a
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m a)
-> (SomeException -> String) -> SomeException -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show @SomeException) Document -> m a
forall a (m :: * -> *).
(HasXML a, MonadError String m) =>
Document -> m a
parseFromDocument (Either SomeException Document -> m a)
-> (LT -> Either SomeException Document) -> LT -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ParseSettings -> LT -> Either SomeException Document
parseText ParseSettings
forall a. Default a => a
def

renderToDocument :: (HasXMLRoot a) => a -> Document
renderToDocument :: forall a. HasXMLRoot a => a -> Document
renderToDocument = Element -> Document
mkDocument (Element -> Document) -> (a -> Element) -> a -> Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Element
forall a. HasXMLRoot a => a -> Element
renderRoot

parseFromDocument :: (HasXML a, MonadError String m) => Document -> m a
parseFromDocument :: forall a (m :: * -> *).
(HasXML a, MonadError String m) =>
Document -> m a
parseFromDocument Document
doc = [Node] -> m a
forall a (m :: * -> *).
(HasXML a, MonadError String m) =>
[Node] -> m a
forall (m :: * -> *). MonadError String m => [Node] -> m a
parse [Element -> Node
NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Document -> Element
documentRoot Document
doc]

parseFromXmlTree :: (MonadError String m, HasXML a) => XmlTree -> m a
parseFromXmlTree :: forall (m :: * -> *) a.
(MonadError String m, HasXML a) =>
XmlTree -> m a
parseFromXmlTree XmlTree
raw = do
  Document
doc :: Document <- LT -> m Document
forall (m :: * -> *) a.
(HasXMLRoot a, MonadError String m) =>
LT -> m a
decode (LT -> m Document)
-> (ByteString -> LT) -> ByteString -> m Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> LT
decodeUtf8 (ByteString -> m Document) -> ByteString -> m Document
forall a b. (a -> b) -> a -> b
$ XmlTree -> ByteString
ourDocToXMLWithRoot XmlTree
raw
  Document -> m a
forall a (m :: * -> *).
(HasXML a, MonadError String m) =>
Document -> m a
parseFromDocument Document
doc

-- FUTUREWORK: perhaps we want to split this up: HasXML (for nameSpaces), and HasXMLParse, HasXMLRender,
-- and drop the assymetric, little used render function from HasXML?

class HasXML a where
  nameSpaces :: Proxy a -> [(ST, ST)]
  nameSpaces Proxy a
Proxy = [(Text, Text)]
defNameSpaces

  render :: a -> [Node]
  default render :: (HasXMLRoot a) => a -> [Node]
  render = (Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: []) (Node -> [Node]) -> (a -> Node) -> a -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Element -> Node
NodeElement (Element -> Node) -> (a -> Element) -> a -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Element
forall a. HasXMLRoot a => a -> Element
renderRoot

  parse :: (MonadError String m) => [Node] -> m a

class (HasXML a) => HasXMLRoot a where
  renderRoot :: a -> Element

instance HasXML Document where
  parse :: forall (m :: * -> *). MonadError String m => [Node] -> m Document
parse [NodeElement Element
el] = Document -> m Document
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Document -> m Document) -> Document -> m Document
forall a b. (a -> b) -> a -> b
$ Prologue -> Element -> [Miscellaneous] -> Document
Document Prologue
defPrologue Element
el [Miscellaneous]
defMiscellaneous
  parse [Node]
bad = Proxy Document -> [Node] -> m Document
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Document) [Node]
bad

instance HasXMLRoot Document where
  renderRoot :: Document -> Element
renderRoot (Document Prologue
_ Element
el [Miscellaneous]
_) = Element
el

----------------------------------------------------------------------
-- util

-- | Attribute either is not present or has a different value.  Oppositve of 'attributeIs'.
attributeIsNot :: Name -> ST.Text -> Axis
attributeIsNot :: Name -> Text -> Axis
attributeIsNot Name
key Text
val Cursor
cur = [Cursor
cur | [Cursor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Cursor] -> Bool) -> [Cursor] -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Text -> Axis
attributeIs Name
key Text
val Cursor
cur]

-- | Do not use this in production!  It works, but it's slow and failures are a bit violent.
unsafeReadTime :: (HasCallStack) => String -> Time
unsafeReadTime :: HasCallStack => String -> Time
unsafeReadTime String
s = (String -> Time) -> (Time -> Time) -> Either String Time -> Time
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> String -> Time
forall a. HasCallStack => String -> a
error (String
"decodeTime: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
s)) Time -> Time
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Either String Time -> Time) -> Either String Time -> Time
forall a b. (a -> b) -> a -> b
$ String -> Either String Time
forall (m :: * -> *) s.
(MonadError String m, ConvertibleStrings s String) =>
s -> m Time
decodeTime String
s

decodeTime :: (MonadError String m, ConvertibleStrings s String) => s -> m Time
decodeTime :: forall (m :: * -> *) s.
(MonadError String m, ConvertibleStrings s String) =>
s -> m Time
decodeTime (s -> String
forall a b. ConvertibleStrings a b => a -> b
cs -> String
s) = case Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
timeFormat String
s of
  Just UTCTime
t -> Time -> m Time
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> m Time) -> Time -> m Time
forall a b. (a -> b) -> a -> b
$ UTCTime -> Time
Time UTCTime
t
  Maybe UTCTime
Nothing -> Proxy Time -> (String, String) -> m Time
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Time) (String
s, String
timeFormat)

renderTime :: Time -> ST
renderTime :: Time -> Text
renderTime (Time UTCTime
utctime) =
  String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> String
accomodateMSAD (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
timeFormat UTCTime
utctime
  where
    -- more than 7 decimal points make Active Directory choke.
    accomodateMSAD :: String -> String
    accomodateMSAD :: String -> String
accomodateMSAD String
s = case Char -> String -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Char
'.' String
s of
      Maybe Int
Nothing -> String
s
      Just Int
i -> case Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
List.splitAt Int
i String
s of
        (String
t, String
u) -> case Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
List.splitAt Int
8 String
u of
          (String
_, String
"") -> String
t String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
u
          (String
v, String
_) -> String
t String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
v String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Z"

defAuthnRequest :: HX.ProtocolType -> HX.AuthnRequest
defAuthnRequest :: ProtocolType -> AuthnRequest
defAuthnRequest ProtocolType
proto =
  HX.AuthnRequest
    { authnRequest :: RequestAbstractType
HX.authnRequest = ProtocolType -> RequestAbstractType
HX.RequestAbstractType ProtocolType
proto,
      authnRequestForceAuthn :: Bool
HX.authnRequestForceAuthn = Bool
False,
      authnRequestIsPassive :: Bool
HX.authnRequestIsPassive = Bool
False,
      authnRequestAssertionConsumerService :: AssertionConsumerService
HX.authnRequestAssertionConsumerService = Maybe AnyURI
-> Maybe (IdentifiedURI Binding) -> AssertionConsumerService
HX.AssertionConsumerServiceURL Maybe AnyURI
forall a. Maybe a
Nothing Maybe (IdentifiedURI Binding)
forall a. Maybe a
Nothing,
      authnRequestAssertionConsumingServiceIndex :: Maybe UnsignedShort
HX.authnRequestAssertionConsumingServiceIndex = Maybe UnsignedShort
forall a. Maybe a
Nothing,
      authnRequestProviderName :: Maybe String
HX.authnRequestProviderName = Maybe String
forall a. Maybe a
Nothing,
      authnRequestSubject :: Maybe Subject
HX.authnRequestSubject = Maybe Subject
forall a. Maybe a
Nothing,
      authnRequestNameIDPolicy :: Maybe NameIDPolicy
HX.authnRequestNameIDPolicy = Maybe NameIDPolicy
forall a. Maybe a
Nothing,
      authnRequestConditions :: Maybe Conditions
HX.authnRequestConditions = Maybe Conditions
forall a. Maybe a
Nothing,
      authnRequestRequestedAuthnContext :: Maybe RequestedAuthnContext
HX.authnRequestRequestedAuthnContext = Maybe RequestedAuthnContext
forall a. Maybe a
Nothing,
      authnRequestScoping :: Maybe Scoping
HX.authnRequestScoping = Maybe Scoping
forall a. Maybe a
Nothing
    }

defProtocolType :: HX.ID -> HX.DateTime -> HX.ProtocolType
defProtocolType :: String -> UTCTime -> ProtocolType
defProtocolType String
pid UTCTime
iinst =
  HX.ProtocolType
    { protocolID :: String
HX.protocolID = String
pid,
      protocolVersion :: SAMLVersion
HX.protocolVersion = SAMLVersion
HX.SAML20,
      protocolIssueInstant :: UTCTime
HX.protocolIssueInstant = UTCTime
iinst,
      protocolDestination :: Maybe AnyURI
HX.protocolDestination = Maybe AnyURI
forall a. Maybe a
Nothing,
      protocolConsent :: IdentifiedURI Consent
HX.protocolConsent = Consent -> IdentifiedURI Consent
forall b a. a -> Identified b a
HX.Identified Consent
HX.ConsentUnspecified,
      protocolIssuer :: Maybe Issuer
HX.protocolIssuer = Maybe Issuer
forall a. Maybe a
Nothing,
      protocolSignature :: Maybe Signature
HX.protocolSignature = Maybe Signature
forall a. Maybe a
Nothing,
      protocolExtensions :: [XmlTree]
HX.protocolExtensions = [],
      relayState :: Maybe ByteString
HX.relayState = Maybe ByteString
forall a. Maybe a
Nothing
    }

explainDeniedReason :: DeniedReason -> ST
explainDeniedReason :: DeniedReason -> Text
explainDeniedReason = \case
  DeniedReason
DeniedStatusFailure -> Text
"status: failure"
  DeniedBadUserRefs String
msg -> Text
"bad user refs: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
msg
  DeniedBadInResponseTos String
msg -> Text
"bad InResponseTo attribute(s): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
msg
  DeniedReason
DeniedNoInResponseTo ->
    -- this can be turned into a redirect to simulate idp-initiated login.
    Text
"authentication response without authentication request ID"
  DeniedAssertionIssueInstantNotInPast Time
ts Time
now ->
    Text
"IssueInstant in Assertion must be older than "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
renderTime Time
now
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", but is "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
renderTime Time
ts
  DeniedAuthnStatementIssueInstantNotInPast Time
ts Time
now ->
    Text
"IssueInstant in AuthnStatement must be older than "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
renderTime Time
now
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", but is "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
renderTime Time
ts
  DeniedBadRecipient String
weare String
theywant -> String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"bad Recipient: we are " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
weare String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", they expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
theywant
  DeniedIssuerMismatch Maybe Issuer
inh Issuer
inass ->
    LT -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (LT -> Text) -> LT -> Text
forall a b. (a -> b) -> a -> b
$
      LT
"mismatching Issuers: in header: "
        LT -> LT -> LT
forall a. Semigroup a => a -> a -> a
<> LT -> (Issuer -> LT) -> Maybe Issuer -> LT
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LT
"Nothing" Issuer -> LT
forall a. HasXML a => a -> LT
encodeElem Maybe Issuer
inh
        LT -> LT -> LT
forall a. Semigroup a => a -> a -> a
<> LT
", in Assertion: "
        LT -> LT -> LT
forall a. Semigroup a => a -> a -> a
<> Issuer -> LT
forall a. HasXML a => a -> LT
encodeElem Issuer
inass
  DeniedReason
DeniedNoStatements -> Text
"no statements"
  DeniedReason
DeniedNoAuthnStatement -> Text
"no AuthnStatement"
  DeniedAuthnStatmentExpiredAt Time
eol -> Text
"AuthnStatement expired at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
renderTime Time
eol
  DeniedReason
DeniedNoBearerConfSubj -> Text
"No Bearer SubjectConfirmation"
  DeniedReason
DeniedBearerConfAssertionsWithoutAudienceRestriction -> Text
"AudienceRestriction required"
  DeniedNotOnOrAfterSubjectConfirmation Time
eol -> Text
"SubjectConfirmation expired at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
renderTime Time
eol
  DeniedNotBeforeSubjectConfirmation Time
bol -> Text
"SubjectConfirmation only valid starting " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
renderTime Time
bol
  DeniedNotOnOrAfterCondition Time
eol -> Text
"Condition expired at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
renderTime Time
eol
  DeniedNotBeforeCondition Time
bol -> Text
"Condition only valid starting " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
renderTime Time
bol
  DeniedAudienceMismatch URI
we NonEmpty URI
they ->
    Text
"Audience mismatch: we are "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> URI -> Text
renderURI URI
we
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", they expect one of ["
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
ST.intercalate Text
", " (URI -> Text
renderURI (URI -> Text) -> [URI] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty URI -> [URI]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty URI
they)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

----------------------------------------------------------------------
-- hack: use hsaml2 parsers and convert from SAMLProtocol instances

class HasXMLImport us them where
  importXml :: (MonadError String m) => them -> m us
  exportXml :: us -> them

wrapParse ::
  forall (m :: Type -> Type) them us.
  (HasCallStack, MonadError String m, HXT.XmlPickler them, HasXML us, Typeable us) =>
  (them -> m us) ->
  [Node] ->
  m us
wrapParse :: forall (m :: * -> *) them us.
(HasCallStack, MonadError String m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse them -> m us
imprt [NodeElement Element
el] =
  (String -> m us) -> (them -> m us) -> Either String them -> m us
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Proxy us -> String -> m us
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @us)) them -> m us
imprt (Either String them -> m us) -> Either String them -> m us
forall a b. (a -> b) -> a -> b
$
    ByteString -> Either String them
forall a. XmlPickler a => ByteString -> Either String a
HX.xmlToSAML (RenderSettings -> Document -> ByteString
renderLBS RenderSettings
forall a. Default a => a
def (Document -> ByteString) -> Document -> ByteString
forall a b. (a -> b) -> a -> b
$ Prologue -> Element -> [Miscellaneous] -> Document
Document Prologue
defPrologue Element
el [Miscellaneous]
defMiscellaneous)
wrapParse them -> m us
_ [Node]
badxml = String -> m us
forall a. HasCallStack => String -> a
error (String -> m us) -> String -> m us
forall a b. (a -> b) -> a -> b
$ String
"internal error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Node] -> String
forall a. Show a => a -> String
show [Node]
badxml

wrapRender ::
  forall them us.
  (HasCallStack, HXT.XmlPickler them, HasXML us) =>
  (us -> them) ->
  us ->
  [Node]
wrapRender :: forall them us.
(HasCallStack, XmlPickler them, HasXML us) =>
(us -> them) -> us -> [Node]
wrapRender us -> them
exprt = ByteString -> [Node]
parseElement (ByteString -> [Node]) -> (us -> ByteString) -> us -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. them -> ByteString
forall a. XmlPickler a => a -> ByteString
ourSamlToXML (them -> ByteString) -> (us -> them) -> us -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. us -> them
exprt
  where
    parseElement :: ByteString -> [Node]
parseElement ByteString
lbs = case ParseSettings -> ByteString -> Either SomeException Document
parseLBS ParseSettings
forall a. Default a => a
def ByteString
lbs of
      Right (Document Prologue
_ Element
el [Miscellaneous]
_) -> [Element -> Node
NodeElement Element
el]
      Left SomeException
msg -> String -> [Node]
forall a. HasCallStack => String -> a
error (String -> [Node]) -> String -> [Node]
forall a b. (a -> b) -> a -> b
$ (Proxy us, SomeException) -> String
forall a. Show a => a -> String
show (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @us, SomeException
msg)

wrapRenderRoot ::
  forall them us.
  (HasCallStack, HXT.XmlPickler them, HasXMLRoot us) =>
  (us -> them) ->
  us ->
  Element
wrapRenderRoot :: forall them us.
(HasCallStack, XmlPickler them, HasXMLRoot us) =>
(us -> them) -> us -> Element
wrapRenderRoot us -> them
exprt = ByteString -> Element
parseElement (ByteString -> Element) -> (us -> ByteString) -> us -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. them -> ByteString
forall a. XmlPickler a => a -> ByteString
ourSamlToXML (them -> ByteString) -> (us -> them) -> us -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. us -> them
exprt
  where
    parseElement :: ByteString -> Element
parseElement ByteString
lbs = case ParseSettings -> ByteString -> Either SomeException Document
parseLBS ParseSettings
forall a. Default a => a
def ByteString
lbs of
      Right (Document Prologue
_ Element
el [Miscellaneous]
_) -> Element
el
      Left SomeException
msg -> String -> Element
forall a. HasCallStack => String -> a
error (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ (Proxy us, SomeException) -> String
forall a. Show a => a -> String
show (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @us, SomeException
msg)

----------------------------------------------------------------------
-- map individual types from hsaml2 to saml2-web-sso

importAuthnRequest :: (MonadError String m) => HX.AuthnRequest -> m AuthnRequest
importAuthnRequest :: forall (m :: * -> *).
MonadError String m =>
AuthnRequest -> m AuthnRequest
importAuthnRequest AuthnRequest
req = do
  let proto :: ProtocolType
proto = RequestAbstractType -> ProtocolType
HX.requestProtocol (RequestAbstractType -> ProtocolType)
-> RequestAbstractType -> ProtocolType
forall a b. (a -> b) -> a -> b
$ AuthnRequest -> RequestAbstractType
HX.authnRequest AuthnRequest
req
  () <- SAMLVersion -> m ()
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SAMLVersion -> m ()
importVersion (SAMLVersion -> m ()) -> SAMLVersion -> m ()
forall a b. (a -> b) -> a -> b
$ ProtocolType -> SAMLVersion
HX.protocolVersion ProtocolType
proto
  ID AuthnRequest
_rqID <- String -> m (ID AuthnRequest)
forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError String m) =>
String -> m (ID a)
importID (String -> m (ID AuthnRequest)) -> String -> m (ID AuthnRequest)
forall a b. (a -> b) -> a -> b
$ ProtocolType -> String
HX.protocolID ProtocolType
proto
  Time
_rqIssueInstant <- UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
UTCTime -> m Time
importTime (UTCTime -> m Time) -> UTCTime -> m Time
forall a b. (a -> b) -> a -> b
$ ProtocolType -> UTCTime
HX.protocolIssueInstant ProtocolType
proto
  Issuer
_rqIssuer <- Maybe Issuer -> m Issuer
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Maybe Issuer -> m Issuer
importRequiredIssuer (Maybe Issuer -> m Issuer) -> Maybe Issuer -> m Issuer
forall a b. (a -> b) -> a -> b
$ ProtocolType -> Maybe Issuer
HX.protocolIssuer ProtocolType
proto
  Maybe NameIdPolicy
_rqNameIDPolicy <- (NameIDPolicy -> m NameIdPolicy)
-> Maybe NameIDPolicy -> m (Maybe NameIdPolicy)
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 NameIDPolicy -> m NameIdPolicy
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
NameIDPolicy -> m NameIdPolicy
importNameIDPolicy (Maybe NameIDPolicy -> m (Maybe NameIdPolicy))
-> Maybe NameIDPolicy -> m (Maybe NameIdPolicy)
forall a b. (a -> b) -> a -> b
$ AuthnRequest -> Maybe NameIDPolicy
HX.authnRequestNameIDPolicy AuthnRequest
req
  (AnyURI -> m URI) -> Maybe AnyURI -> m (Maybe URI)
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 AnyURI -> m URI
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
AnyURI -> m URI
importURI (ProtocolType -> Maybe AnyURI
HX.protocolDestination ProtocolType
proto) m (Maybe URI) -> (Maybe URI -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe URI
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just URI
dest -> Proxy AuthnRequest -> String -> m ()
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @AuthnRequest) (String
"protocol destination not allowed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> URI -> String
forall a. Show a => a -> String
show URI
dest)
  AuthnRequest -> m AuthnRequest
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthnRequest {Maybe NameIdPolicy
ID AuthnRequest
Time
Issuer
_rqID :: ID AuthnRequest
_rqIssueInstant :: Time
_rqIssuer :: Issuer
_rqNameIDPolicy :: Maybe NameIdPolicy
_rqNameIDPolicy :: Maybe NameIdPolicy
_rqIssuer :: Issuer
_rqIssueInstant :: Time
_rqID :: ID AuthnRequest
..}

exportAuthnRequest :: AuthnRequest -> HX.AuthnRequest
exportAuthnRequest :: AuthnRequest -> AuthnRequest
exportAuthnRequest AuthnRequest
req =
  (ProtocolType -> AuthnRequest
defAuthnRequest ProtocolType
proto)
    { HX.authnRequestNameIDPolicy = exportNameIDPolicy <$> req ^. rqNameIDPolicy
    }
  where
    proto :: ProtocolType
proto =
      (String -> UTCTime -> ProtocolType
defProtocolType (ID AuthnRequest -> String
forall {k} (a :: k). HasCallStack => ID a -> String
exportID (ID AuthnRequest -> String) -> ID AuthnRequest -> String
forall a b. (a -> b) -> a -> b
$ AuthnRequest
req AuthnRequest
-> Getting (ID AuthnRequest) AuthnRequest (ID AuthnRequest)
-> ID AuthnRequest
forall s a. s -> Getting a s a -> a
^. Getting (ID AuthnRequest) AuthnRequest (ID AuthnRequest)
Lens' AuthnRequest (ID AuthnRequest)
rqID) (HasCallStack => Time -> UTCTime
Time -> UTCTime
exportTime (Time -> UTCTime) -> Time -> UTCTime
forall a b. (a -> b) -> a -> b
$ AuthnRequest
req AuthnRequest -> Getting Time AuthnRequest Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time AuthnRequest Time
Lens' AuthnRequest Time
rqIssueInstant))
        { HX.protocolVersion = exportVersion,
          HX.protocolIssuer = exportRequiredIssuer $ req ^. rqIssuer,
          HX.protocolDestination = Nothing
        }

importNameIDPolicy :: (HasCallStack, MonadError String m) => HX.NameIDPolicy -> m NameIdPolicy
importNameIDPolicy :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
NameIDPolicy -> m NameIdPolicy
importNameIDPolicy NameIDPolicy
nip = do
  NameIDFormat
_nidFormat <- IdentifiedURI NameIDFormat -> m NameIDFormat
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
IdentifiedURI NameIDFormat -> m NameIDFormat
importNameIDFormat (IdentifiedURI NameIDFormat -> m NameIDFormat)
-> IdentifiedURI NameIDFormat -> m NameIDFormat
forall a b. (a -> b) -> a -> b
$ NameIDPolicy -> IdentifiedURI NameIDFormat
HX.nameIDPolicyFormat NameIDPolicy
nip
  let _nidSpNameQualifier :: Maybe Text
_nidSpNameQualifier = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameIDPolicy -> Maybe String
HX.nameIDPolicySPNameQualifier NameIDPolicy
nip
      _nidAllowCreate :: Bool
_nidAllowCreate = NameIDPolicy -> Bool
HX.nameIDPolicyAllowCreate NameIDPolicy
nip
  NameIdPolicy -> m NameIdPolicy
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NameIdPolicy -> m NameIdPolicy) -> NameIdPolicy -> m NameIdPolicy
forall a b. (a -> b) -> a -> b
$ NameIDFormat -> Maybe Text -> Bool -> NameIdPolicy
NameIdPolicy NameIDFormat
_nidFormat Maybe Text
_nidSpNameQualifier Bool
_nidAllowCreate

exportNameIDPolicy :: (HasCallStack) => NameIdPolicy -> HX.NameIDPolicy
exportNameIDPolicy :: HasCallStack => NameIdPolicy -> NameIDPolicy
exportNameIDPolicy NameIdPolicy
nip =
  HX.NameIDPolicy
    { nameIDPolicyFormat :: IdentifiedURI NameIDFormat
HX.nameIDPolicyFormat = NameIDFormat -> IdentifiedURI NameIDFormat
exportNameIDFormat (NameIDFormat -> IdentifiedURI NameIDFormat)
-> NameIDFormat -> IdentifiedURI NameIDFormat
forall a b. (a -> b) -> a -> b
$ NameIdPolicy
nip NameIdPolicy
-> Getting NameIDFormat NameIdPolicy NameIDFormat -> NameIDFormat
forall s a. s -> Getting a s a -> a
^. Getting NameIDFormat NameIdPolicy NameIDFormat
Lens' NameIdPolicy NameIDFormat
nidFormat,
      nameIDPolicySPNameQualifier :: Maybe String
HX.nameIDPolicySPNameQualifier = Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameIdPolicy
nip NameIdPolicy
-> Getting (Maybe Text) NameIdPolicy (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) NameIdPolicy (Maybe Text)
Lens' NameIdPolicy (Maybe Text)
nidSpNameQualifier,
      nameIDPolicyAllowCreate :: Bool
HX.nameIDPolicyAllowCreate = NameIdPolicy
nip NameIdPolicy -> Getting Bool NameIdPolicy Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool NameIdPolicy Bool
Lens' NameIdPolicy Bool
nidAllowCreate
    }

importNameIDFormat :: (HasCallStack, MonadError String m) => HX.IdentifiedURI HX.NameIDFormat -> m NameIDFormat
importNameIDFormat :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
IdentifiedURI NameIDFormat -> m NameIDFormat
importNameIDFormat = \case
  HX.Identified NameIDFormat
HX.NameIDFormatUnspecified -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFUnspecified
  HX.Identified NameIDFormat
HX.NameIDFormatEmail -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFEmail
  HX.Identified NameIDFormat
HX.NameIDFormatX509 -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFX509
  HX.Identified NameIDFormat
HX.NameIDFormatWindows -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFWindows
  HX.Identified NameIDFormat
HX.NameIDFormatKerberos -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFKerberos
  HX.Identified NameIDFormat
HX.NameIDFormatEntity -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFEntity
  HX.Identified NameIDFormat
HX.NameIDFormatPersistent -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFPersistent
  HX.Identified NameIDFormat
HX.NameIDFormatTransient -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFTransient
  bad :: IdentifiedURI NameIDFormat
bad@(HX.Identified NameIDFormat
HX.NameIDFormatEncrypted) -> String -> m NameIDFormat
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m NameIDFormat) -> String -> m NameIDFormat
forall a b. (a -> b) -> a -> b
$ String
"unsupported: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> IdentifiedURI NameIDFormat -> String
forall a. Show a => a -> String
show IdentifiedURI NameIDFormat
bad
  bad :: IdentifiedURI NameIDFormat
bad@(HX.Unidentified AnyURI
_) -> String -> m NameIDFormat
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m NameIDFormat) -> String -> m NameIDFormat
forall a b. (a -> b) -> a -> b
$ String
"unsupported: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> IdentifiedURI NameIDFormat -> String
forall a. Show a => a -> String
show IdentifiedURI NameIDFormat
bad

exportNameIDFormat :: NameIDFormat -> HX.IdentifiedURI HX.NameIDFormat
exportNameIDFormat :: NameIDFormat -> IdentifiedURI NameIDFormat
exportNameIDFormat = \case
  NameIDFormat
NameIDFUnspecified -> NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatUnspecified
  NameIDFormat
NameIDFEmail -> NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatEmail
  NameIDFormat
NameIDFX509 -> NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatX509
  NameIDFormat
NameIDFWindows -> NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatWindows
  NameIDFormat
NameIDFKerberos -> NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatKerberos
  NameIDFormat
NameIDFEntity -> NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatEntity
  NameIDFormat
NameIDFPersistent -> NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatPersistent
  NameIDFormat
NameIDFTransient -> NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatTransient

importAuthnResponse :: (HasCallStack, MonadError String m) => HX.Response -> m AuthnResponse
importAuthnResponse :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Response -> m AuthnResponse
importAuthnResponse Response
rsp = do
  let StatusResponseType
rsptyp :: HX.StatusResponseType = Response -> StatusResponseType
HX.response Response
rsp
      ProtocolType
proto :: HX.ProtocolType = StatusResponseType -> ProtocolType
HX.statusProtocol StatusResponseType
rsptyp
  () <- SAMLVersion -> m ()
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SAMLVersion -> m ()
importVersion (SAMLVersion -> m ()) -> SAMLVersion -> m ()
forall a b. (a -> b) -> a -> b
$ ProtocolType -> SAMLVersion
HX.protocolVersion ProtocolType
proto
  ID AuthnResponse
_rspID <- String -> m (ID AuthnResponse)
forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError String m) =>
String -> m (ID a)
importID (String -> m (ID AuthnResponse)) -> String -> m (ID AuthnResponse)
forall a b. (a -> b) -> a -> b
$ ProtocolType -> String
HX.protocolID ProtocolType
proto
  Maybe (ID AuthnRequest)
_rspInRespTo <- (String -> m (ID AuthnRequest)
forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError String m) =>
String -> m (ID a)
importID (String -> m (ID AuthnRequest))
-> (String -> String) -> String -> m (ID AuthnRequest)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> String
forall a b. ConvertibleStrings a b => a -> b
cs) (String -> m (ID AuthnRequest))
-> Maybe String -> m (Maybe (ID AuthnRequest))
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` StatusResponseType -> Maybe String
HX.statusInResponseTo StatusResponseType
rsptyp
  Time
_rspIssueInstant <- UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
UTCTime -> m Time
importTime (UTCTime -> m Time) -> UTCTime -> m Time
forall a b. (a -> b) -> a -> b
$ ProtocolType -> UTCTime
HX.protocolIssueInstant ProtocolType
proto
  Maybe URI
_rspDestination <- (AnyURI -> m URI) -> Maybe AnyURI -> m (Maybe URI)
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 AnyURI -> m URI
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
AnyURI -> m URI
importURI (Maybe AnyURI -> m (Maybe URI)) -> Maybe AnyURI -> m (Maybe URI)
forall a b. (a -> b) -> a -> b
$ ProtocolType -> Maybe AnyURI
HX.protocolDestination ProtocolType
proto
  Maybe Issuer
_rspIssuer <- (Issuer -> m Issuer) -> Maybe Issuer -> m (Maybe Issuer)
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 Issuer -> m Issuer
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Issuer -> m Issuer
importIssuer (Maybe Issuer -> m (Maybe Issuer))
-> Maybe Issuer -> m (Maybe Issuer)
forall a b. (a -> b) -> a -> b
$ ProtocolType -> Maybe Issuer
HX.protocolIssuer ProtocolType
proto
  Status
_rspStatus <- Status -> m Status
forall (m :: * -> *). (HasCallStack, Monad m) => Status -> m Status
importStatus (Status -> m Status) -> Status -> m Status
forall a b. (a -> b) -> a -> b
$ StatusResponseType -> Status
HX.status StatusResponseType
rsptyp
  NonEmpty Assertion
_rspPayload <- m (NonEmpty Assertion)
-> (NonEmpty Assertion -> m (NonEmpty Assertion))
-> Maybe (NonEmpty Assertion)
-> m (NonEmpty Assertion)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m (NonEmpty Assertion)
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"no assertions") NonEmpty Assertion -> m (NonEmpty Assertion)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (NonEmpty Assertion) -> m (NonEmpty Assertion))
-> ([Assertion] -> Maybe (NonEmpty Assertion))
-> [Assertion]
-> m (NonEmpty Assertion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Assertion] -> Maybe (NonEmpty Assertion)
forall a. [a] -> Maybe (NonEmpty a)
NL.nonEmpty ([Assertion] -> m (NonEmpty Assertion))
-> m [Assertion] -> m (NonEmpty Assertion)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (PossiblyEncrypted Assertion -> m Assertion
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
PossiblyEncrypted Assertion -> m Assertion
importPossiblyEncryptedAssertion (PossiblyEncrypted Assertion -> m Assertion)
-> [PossiblyEncrypted Assertion] -> m [Assertion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` Response -> [PossiblyEncrypted Assertion]
HX.responseAssertions Response
rsp)
  -- ignore: @HX.protocolSignature proto :: Maybe SAML2.XML.Signature.Types.Signature@
  -- ignore: @HX.relayState proto :: Maybe SAML2.Bindings.General.RelayState@

  AuthnResponse -> m AuthnResponse
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response {Maybe URI
Maybe (ID AuthnRequest)
Maybe Issuer
NonEmpty Assertion
Status
ID AuthnResponse
Time
_rspID :: ID AuthnResponse
_rspInRespTo :: Maybe (ID AuthnRequest)
_rspIssueInstant :: Time
_rspDestination :: Maybe URI
_rspIssuer :: Maybe Issuer
_rspStatus :: Status
_rspPayload :: NonEmpty Assertion
_rspPayload :: NonEmpty Assertion
_rspStatus :: Status
_rspIssuer :: Maybe Issuer
_rspDestination :: Maybe URI
_rspIssueInstant :: Time
_rspInRespTo :: Maybe (ID AuthnRequest)
_rspID :: ID AuthnResponse
..}

exportAuthnResponse :: (HasCallStack) => AuthnResponse -> HX.Response
exportAuthnResponse :: HasCallStack => AuthnResponse -> Response
exportAuthnResponse AuthnResponse
rsp =
  HX.Response
    { response :: StatusResponseType
HX.response =
        HX.StatusResponseType
          { statusProtocol :: ProtocolType
HX.statusProtocol =
              HX.ProtocolType
                { protocolID :: String
HX.protocolID = ID AuthnResponse -> String
forall {k} (a :: k). HasCallStack => ID a -> String
exportID (AuthnResponse
rsp AuthnResponse
-> Getting (ID AuthnResponse) AuthnResponse (ID AuthnResponse)
-> ID AuthnResponse
forall s a. s -> Getting a s a -> a
^. Getting (ID AuthnResponse) AuthnResponse (ID AuthnResponse)
forall payload (f :: * -> *).
Functor f =>
(ID (Response payload) -> f (ID (Response payload)))
-> Response payload -> f (Response payload)
rspID),
                  protocolVersion :: SAMLVersion
HX.protocolVersion = SAMLVersion
HasCallStack => SAMLVersion
exportVersion,
                  protocolIssueInstant :: UTCTime
HX.protocolIssueInstant = HasCallStack => Time -> UTCTime
Time -> UTCTime
exportTime (AuthnResponse
rsp AuthnResponse -> Getting Time AuthnResponse Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time AuthnResponse Time
forall payload (f :: * -> *).
Functor f =>
(Time -> f Time) -> Response payload -> f (Response payload)
rspIssueInstant),
                  protocolDestination :: Maybe AnyURI
HX.protocolDestination = HasCallStack => URI -> AnyURI
URI -> AnyURI
exportURI (URI -> AnyURI) -> Maybe URI -> Maybe AnyURI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AuthnResponse
rsp AuthnResponse
-> Getting (Maybe URI) AuthnResponse (Maybe URI) -> Maybe URI
forall s a. s -> Getting a s a -> a
^. Getting (Maybe URI) AuthnResponse (Maybe URI)
forall payload (f :: * -> *).
Functor f =>
(Maybe URI -> f (Maybe URI))
-> Response payload -> f (Response payload)
rspDestination),
                  protocolConsent :: IdentifiedURI Consent
HX.protocolConsent = Consent -> IdentifiedURI Consent
forall b a. a -> Identified b a
HX.Identified Consent
HX.ConsentUnspecified, -- [1/8.4.1] there are no rules how to process the consent value.
                  protocolIssuer :: Maybe Issuer
HX.protocolIssuer = HasCallStack => Issuer -> Issuer
Issuer -> Issuer
exportIssuer (Issuer -> Issuer) -> Maybe Issuer -> Maybe Issuer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AuthnResponse
rsp AuthnResponse
-> Getting (Maybe Issuer) AuthnResponse (Maybe Issuer)
-> Maybe Issuer
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Issuer) AuthnResponse (Maybe Issuer)
forall payload (f :: * -> *).
Functor f =>
(Maybe Issuer -> f (Maybe Issuer))
-> Response payload -> f (Response payload)
rspIssuer) :: Maybe HX.Issuer,
                  protocolSignature :: Maybe Signature
HX.protocolSignature = Maybe Signature
forall a. Maybe a
Nothing,
                  protocolExtensions :: [XmlTree]
HX.protocolExtensions = [],
                  relayState :: Maybe ByteString
HX.relayState = Maybe ByteString
forall a. Maybe a
Nothing
                },
            statusInResponseTo :: Maybe String
HX.statusInResponseTo = ID AuthnRequest -> String
forall {k} (a :: k). HasCallStack => ID a -> String
exportID (ID AuthnRequest -> String)
-> Maybe (ID AuthnRequest) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AuthnResponse
rsp AuthnResponse
-> Getting
     (Maybe (ID AuthnRequest)) AuthnResponse (Maybe (ID AuthnRequest))
-> Maybe (ID AuthnRequest)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (ID AuthnRequest)) AuthnResponse (Maybe (ID AuthnRequest))
forall payload (f :: * -> *).
Functor f =>
(Maybe (ID AuthnRequest) -> f (Maybe (ID AuthnRequest)))
-> Response payload -> f (Response payload)
rspInRespTo),
            status :: Status
HX.status = HasCallStack => Status -> Status
Status -> Status
exportStatus (AuthnResponse
rsp AuthnResponse -> Getting Status AuthnResponse Status -> Status
forall s a. s -> Getting a s a -> a
^. Getting Status AuthnResponse Status
forall payload (f :: * -> *).
Functor f =>
(Status -> f Status) -> Response payload -> f (Response payload)
rspStatus)
          },
      responseAssertions :: [PossiblyEncrypted Assertion]
HX.responseAssertions = NonEmpty (PossiblyEncrypted Assertion)
-> [PossiblyEncrypted Assertion]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty (PossiblyEncrypted Assertion)
 -> [PossiblyEncrypted Assertion])
-> NonEmpty (PossiblyEncrypted Assertion)
-> [PossiblyEncrypted Assertion]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Assertion -> PossiblyEncrypted Assertion
Assertion -> PossiblyEncrypted Assertion
exportPossiblyEncryptedAssertion (Assertion -> PossiblyEncrypted Assertion)
-> NonEmpty Assertion -> NonEmpty (PossiblyEncrypted Assertion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AuthnResponse
rsp AuthnResponse
-> Getting (NonEmpty Assertion) AuthnResponse (NonEmpty Assertion)
-> NonEmpty Assertion
forall s a. s -> Getting a s a -> a
^. Getting (NonEmpty Assertion) AuthnResponse (NonEmpty Assertion)
forall payload (f :: * -> *).
Functor f =>
(payload -> f payload) -> Response payload -> f (Response payload)
rspPayload)
    }

importPossiblyEncryptedAssertion :: (HasCallStack, MonadError String m) => HX.PossiblyEncrypted HX.Assertion -> m Assertion
importPossiblyEncryptedAssertion :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
PossiblyEncrypted Assertion -> m Assertion
importPossiblyEncryptedAssertion bad :: PossiblyEncrypted Assertion
bad@(HX.SoEncrypted EncryptedElement Assertion
_) = Proxy Assertion -> PossiblyEncrypted Assertion -> m Assertion
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Assertion) PossiblyEncrypted Assertion
bad
importPossiblyEncryptedAssertion (HX.NotEncrypted Assertion
ass) = Assertion -> m Assertion
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Assertion -> m Assertion
importAssertion Assertion
ass

importAssertion :: (HasCallStack, MonadError String m) => HX.Assertion -> m Assertion
importAssertion :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Assertion -> m Assertion
importAssertion Assertion
ass = do
  () <- SAMLVersion -> m ()
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SAMLVersion -> m ()
importVersion (SAMLVersion -> m ()) -> SAMLVersion -> m ()
forall a b. (a -> b) -> a -> b
$ Assertion -> SAMLVersion
HX.assertionVersion Assertion
ass
  ID Assertion
_assID <- String -> m (ID Assertion)
forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError String m) =>
String -> m (ID a)
importID (String -> m (ID Assertion)) -> String -> m (ID Assertion)
forall a b. (a -> b) -> a -> b
$ Assertion -> String
HX.assertionID Assertion
ass
  Time
_assIssueInstant <- UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
UTCTime -> m Time
importTime (UTCTime -> m Time) -> UTCTime -> m Time
forall a b. (a -> b) -> a -> b
$ Assertion -> UTCTime
HX.assertionIssueInstant Assertion
ass
  Issuer
_assIssuer <- Issuer -> m Issuer
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Issuer -> m Issuer
importIssuer (Issuer -> m Issuer) -> Issuer -> m Issuer
forall a b. (a -> b) -> a -> b
$ Assertion -> Issuer
HX.assertionIssuer Assertion
ass
  Maybe Conditions
_assConditions <- (Conditions -> m Conditions)
-> Maybe Conditions -> m (Maybe Conditions)
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 Conditions -> m Conditions
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Conditions -> m Conditions
importConditions (Maybe Conditions -> m (Maybe Conditions))
-> Maybe Conditions -> m (Maybe Conditions)
forall a b. (a -> b) -> a -> b
$ Assertion -> Maybe Conditions
HX.assertionConditions Assertion
ass
  SubjectAndStatements
_assContents <- do
    Subject
subj <- Subject -> m Subject
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Subject -> m Subject
importSubject (Subject -> m Subject) -> Subject -> m Subject
forall a b. (a -> b) -> a -> b
$ Assertion -> Subject
HX.assertionSubject Assertion
ass
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Statement] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Statement] -> Bool) -> [Statement] -> Bool
forall a b. (a -> b) -> a -> b
$ Assertion -> [Statement]
HX.assertionStatement Assertion
ass) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      Proxy Assertion -> String -> m ()
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Assertion) (String
"no statements" :: String)
    [Maybe Statement]
mstmts <- Statement -> m (Maybe Statement)
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Statement -> m (Maybe Statement)
importStatement (Statement -> m (Maybe Statement))
-> [Statement] -> m [Maybe Statement]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` Assertion -> [Statement]
HX.assertionStatement Assertion
ass
    case [Maybe Statement] -> [Statement]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Statement]
mstmts of
      Statement
stmt : [Statement]
stmts -> SubjectAndStatements -> m SubjectAndStatements
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SubjectAndStatements -> m SubjectAndStatements)
-> SubjectAndStatements -> m SubjectAndStatements
forall a b. (a -> b) -> a -> b
$ Subject -> NonEmpty Statement -> SubjectAndStatements
SubjectAndStatements Subject
subj (Statement
stmt Statement -> [Statement] -> NonEmpty Statement
forall a. a -> [a] -> NonEmpty a
:| [Statement]
stmts)
      [] -> Proxy Assertion -> String -> m SubjectAndStatements
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Assertion) (String
"no statements" :: String)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Advice -> Bool
forall a. Maybe a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Maybe Advice -> Bool) -> Maybe Advice -> Bool
forall a b. (a -> b) -> a -> b
$ Assertion -> Maybe Advice
HX.assertionAdvice Assertion
ass) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Proxy Assertion -> Maybe Advice -> m ()
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Assertion) (Assertion -> Maybe Advice
HX.assertionAdvice Assertion
ass)
  Assertion -> m Assertion
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Assertion {Maybe Conditions
SubjectAndStatements
ID Assertion
Time
Issuer
_assID :: ID Assertion
_assIssueInstant :: Time
_assIssuer :: Issuer
_assConditions :: Maybe Conditions
_assContents :: SubjectAndStatements
_assContents :: SubjectAndStatements
_assConditions :: Maybe Conditions
_assIssuer :: Issuer
_assIssueInstant :: Time
_assID :: ID Assertion
..}

exportPossiblyEncryptedAssertion :: (HasCallStack) => Assertion -> HX.PossiblyEncrypted HX.Assertion
exportPossiblyEncryptedAssertion :: HasCallStack => Assertion -> PossiblyEncrypted Assertion
exportPossiblyEncryptedAssertion = Assertion -> PossiblyEncrypted Assertion
forall a. a -> PossiblyEncrypted a
HX.NotEncrypted (Assertion -> PossiblyEncrypted Assertion)
-> (Assertion -> Assertion)
-> Assertion
-> PossiblyEncrypted Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => Assertion -> Assertion
Assertion -> Assertion
exportAssertion

exportAssertion :: (HasCallStack) => Assertion -> HX.Assertion
exportAssertion :: HasCallStack => Assertion -> Assertion
exportAssertion Assertion
ass =
  HX.Assertion
    { assertionVersion :: SAMLVersion
HX.assertionVersion = SAMLVersion
HasCallStack => SAMLVersion
exportVersion,
      assertionID :: String
HX.assertionID = ID Assertion -> String
forall {k} (a :: k). HasCallStack => ID a -> String
exportID (Assertion
ass Assertion
-> Getting (ID Assertion) Assertion (ID Assertion) -> ID Assertion
forall s a. s -> Getting a s a -> a
^. Getting (ID Assertion) Assertion (ID Assertion)
Lens' Assertion (ID Assertion)
assID),
      assertionIssueInstant :: UTCTime
HX.assertionIssueInstant = HasCallStack => Time -> UTCTime
Time -> UTCTime
exportTime (Assertion
ass Assertion -> Getting Time Assertion Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time Assertion Time
Lens' Assertion Time
assIssueInstant),
      assertionIssuer :: Issuer
HX.assertionIssuer = HasCallStack => Issuer -> Issuer
Issuer -> Issuer
exportIssuer (Assertion
ass Assertion -> Getting Issuer Assertion Issuer -> Issuer
forall s a. s -> Getting a s a -> a
^. Getting Issuer Assertion Issuer
Lens' Assertion Issuer
assIssuer),
      assertionSignature :: Maybe Signature
HX.assertionSignature = Maybe Signature
forall a. Maybe a
Nothing, -- signatures are handled before parsing.
      assertionSubject :: Subject
HX.assertionSubject = HasCallStack => Subject -> Subject
Subject -> Subject
exportSubject (Subject -> Subject) -> Subject -> Subject
forall a b. (a -> b) -> a -> b
$ Assertion
ass Assertion -> Getting Subject Assertion Subject -> Subject
forall s a. s -> Getting a s a -> a
^. (SubjectAndStatements -> Const Subject SubjectAndStatements)
-> Assertion -> Const Subject Assertion
Lens' Assertion SubjectAndStatements
assContents ((SubjectAndStatements -> Const Subject SubjectAndStatements)
 -> Assertion -> Const Subject Assertion)
-> ((Subject -> Const Subject Subject)
    -> SubjectAndStatements -> Const Subject SubjectAndStatements)
-> Getting Subject Assertion Subject
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Subject -> Const Subject Subject)
-> SubjectAndStatements -> Const Subject SubjectAndStatements
Lens' SubjectAndStatements Subject
sasSubject,
      assertionConditions :: Maybe Conditions
HX.assertionConditions = HasCallStack => Conditions -> Conditions
Conditions -> Conditions
exportConditions (Conditions -> Conditions) -> Maybe Conditions -> Maybe Conditions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Assertion
ass Assertion
-> Getting (Maybe Conditions) Assertion (Maybe Conditions)
-> Maybe Conditions
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Conditions) Assertion (Maybe Conditions)
Lens' Assertion (Maybe Conditions)
assConditions),
      assertionAdvice :: Maybe Advice
HX.assertionAdvice = Maybe Advice
forall a. Maybe a
Nothing,
      assertionStatement :: [Statement]
HX.assertionStatement = HasCallStack => Statement -> Statement
Statement -> Statement
exportStatement (Statement -> Statement) -> [Statement] -> [Statement]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Assertion
ass Assertion
-> Getting [Statement] Assertion [Statement] -> [Statement]
forall s a. s -> Getting a s a -> a
^. (SubjectAndStatements -> Const [Statement] SubjectAndStatements)
-> Assertion -> Const [Statement] Assertion
Lens' Assertion SubjectAndStatements
assContents ((SubjectAndStatements -> Const [Statement] SubjectAndStatements)
 -> Assertion -> Const [Statement] Assertion)
-> (([Statement] -> Const [Statement] [Statement])
    -> SubjectAndStatements -> Const [Statement] SubjectAndStatements)
-> Getting [Statement] Assertion [Statement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (NonEmpty Statement -> Const [Statement] (NonEmpty Statement))
-> SubjectAndStatements -> Const [Statement] SubjectAndStatements
Lens' SubjectAndStatements (NonEmpty Statement)
sasStatements ((NonEmpty Statement -> Const [Statement] (NonEmpty Statement))
 -> SubjectAndStatements -> Const [Statement] SubjectAndStatements)
-> (([Statement] -> Const [Statement] [Statement])
    -> NonEmpty Statement -> Const [Statement] (NonEmpty Statement))
-> ([Statement] -> Const [Statement] [Statement])
-> SubjectAndStatements
-> Const [Statement] SubjectAndStatements
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (NonEmpty Statement -> [Statement])
-> ([Statement] -> Const [Statement] [Statement])
-> NonEmpty Statement
-> Const [Statement] (NonEmpty Statement)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to NonEmpty Statement -> [Statement]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)
    }

importSubject :: (HasCallStack, MonadError String m) => HX.Subject -> m Subject
importSubject :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Subject -> m Subject
importSubject (HX.Subject Maybe (PossiblyEncrypted Identifier)
Nothing [SubjectConfirmation]
_) = Proxy Subject -> String -> m Subject
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Subject) (String
"Subject NameID is missing" :: String)
importSubject (HX.Subject (Just (HX.SoEncrypted EncryptedElement Identifier
_)) [SubjectConfirmation]
_) = Proxy Subject -> String -> m Subject
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Subject) (String
"encrypted subjects not supported" :: String)
importSubject (HX.Subject (Just (HX.NotEncrypted Identifier
sid)) [SubjectConfirmation]
scs) = case Identifier
sid of
  HX.IdentifierName NameID
nameid -> do
    NameID
nameid' <- NameID -> m NameID
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
NameID -> m NameID
importNameID NameID
nameid
    NameID -> [SubjectConfirmation] -> Subject
Subject NameID
nameid' ([SubjectConfirmation] -> Subject)
-> m [SubjectConfirmation] -> m Subject
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameID -> SubjectConfirmation -> m SubjectConfirmation
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
NameID -> SubjectConfirmation -> m SubjectConfirmation
importSubjectConfirmation NameID
nameid' (SubjectConfirmation -> m SubjectConfirmation)
-> [SubjectConfirmation] -> m [SubjectConfirmation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [SubjectConfirmation]
scs
  bad :: Identifier
bad@(HX.IdentifierBase BaseID [XmlTree]
_baseid) -> do
    Proxy Subject -> String -> m Subject
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Subject) (String
"unsupported subject identifier: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Identifier -> String
forall a. Show a => a -> String
show Identifier
bad)

exportSubject :: (HasCallStack) => Subject -> HX.Subject
exportSubject :: HasCallStack => Subject -> Subject
exportSubject Subject
subj = Maybe (PossiblyEncrypted Identifier)
-> [SubjectConfirmation] -> Subject
HX.Subject (PossiblyEncrypted Identifier
-> Maybe (PossiblyEncrypted Identifier)
forall a. a -> Maybe a
Just (Identifier -> PossiblyEncrypted Identifier
forall a. a -> PossiblyEncrypted a
HX.NotEncrypted Identifier
sid)) [SubjectConfirmation]
scs
  where
    sid :: HX.Identifier
    sid :: Identifier
sid = NameID -> Identifier
HX.IdentifierName (NameID -> Identifier) -> NameID -> Identifier
forall a b. (a -> b) -> a -> b
$ NameID -> NameID
exportNameID (Subject
subj Subject -> Getting NameID Subject NameID -> NameID
forall s a. s -> Getting a s a -> a
^. Getting NameID Subject NameID
Lens' Subject NameID
subjectID)
    scs :: [HX.SubjectConfirmation]
    scs :: [SubjectConfirmation]
scs = HasCallStack => SubjectConfirmation -> SubjectConfirmation
SubjectConfirmation -> SubjectConfirmation
exportSubjectConfirmation (SubjectConfirmation -> SubjectConfirmation)
-> [SubjectConfirmation] -> [SubjectConfirmation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Subject
subj Subject
-> Getting [SubjectConfirmation] Subject [SubjectConfirmation]
-> [SubjectConfirmation]
forall s a. s -> Getting a s a -> a
^. Getting [SubjectConfirmation] Subject [SubjectConfirmation]
Lens' Subject [SubjectConfirmation]
subjectConfirmations

importSubjectConfirmation :: (HasCallStack, MonadError String m) => NameID -> HX.SubjectConfirmation -> m SubjectConfirmation
importSubjectConfirmation :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
NameID -> SubjectConfirmation -> m SubjectConfirmation
importSubjectConfirmation = NameID -> SubjectConfirmation -> m SubjectConfirmation
forall {m :: * -> *}.
MonadError String m =>
NameID -> SubjectConfirmation -> m SubjectConfirmation
go
  where
    go :: NameID -> SubjectConfirmation -> m SubjectConfirmation
go NameID
_ (HX.SubjectConfirmation IdentifiedURI ConfirmationMethod
meth Maybe (PossiblyEncrypted Identifier)
_ Maybe SubjectConfirmationData
_)
      | IdentifiedURI ConfirmationMethod
meth IdentifiedURI ConfirmationMethod
-> IdentifiedURI ConfirmationMethod -> Bool
forall a. Eq a => a -> a -> Bool
/= ConfirmationMethod -> IdentifiedURI ConfirmationMethod
forall b a. a -> Identified b a
HX.Identified ConfirmationMethod
HX.ConfirmationMethodBearer =
          Proxy SubjectConfirmation -> String -> m SubjectConfirmation
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SubjectConfirmation) (String
"unsupported confirmation method: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> IdentifiedURI ConfirmationMethod -> String
forall a. Show a => a -> String
show IdentifiedURI ConfirmationMethod
meth)
    go NameID
uid (HX.SubjectConfirmation IdentifiedURI ConfirmationMethod
_ (Just (HX.NotEncrypted (HX.IdentifierName NameID
uid'))) Maybe SubjectConfirmationData
_)
      | NameID -> Either () NameID
forall a b. b -> Either a b
Right NameID
uid Either () NameID -> Either () NameID -> Bool
forall a. Eq a => a -> a -> Bool
/= (String -> ()) -> Either String NameID -> Either () NameID
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL (() -> String -> ()
forall a b. a -> b -> a
const ()) (NameID -> Either String NameID
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
NameID -> m NameID
importNameID NameID
uid') =
          Proxy SubjectConfirmation -> String -> m SubjectConfirmation
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SubjectConfirmation) (String
"uid mismatch: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (NameID, NameID) -> String
forall a. Show a => a -> String
show (NameID
uid, NameID
uid'))
    go NameID
_ (HX.SubjectConfirmation IdentifiedURI ConfirmationMethod
_ (Just PossiblyEncrypted Identifier
bad) Maybe SubjectConfirmationData
_) =
      Proxy SubjectConfirmation -> String -> m SubjectConfirmation
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SubjectConfirmation) (String
"unsupported identifier: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PossiblyEncrypted Identifier -> String
forall a. Show a => a -> String
show PossiblyEncrypted Identifier
bad)
    go NameID
_ (HX.SubjectConfirmation IdentifiedURI ConfirmationMethod
_ Maybe (PossiblyEncrypted Identifier)
_ Maybe SubjectConfirmationData
confdata) =
      SubjectConfirmationMethod
-> Maybe SubjectConfirmationData -> SubjectConfirmation
SubjectConfirmation SubjectConfirmationMethod
SubjectConfirmationMethodBearer (Maybe SubjectConfirmationData -> SubjectConfirmation)
-> m (Maybe SubjectConfirmationData) -> m SubjectConfirmation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubjectConfirmationData -> m SubjectConfirmationData
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SubjectConfirmationData -> m SubjectConfirmationData
importSubjectConfirmationData (SubjectConfirmationData -> m SubjectConfirmationData)
-> Maybe SubjectConfirmationData
-> m (Maybe SubjectConfirmationData)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
`mapM` Maybe SubjectConfirmationData
confdata

exportSubjectConfirmation :: (HasCallStack) => SubjectConfirmation -> HX.SubjectConfirmation
exportSubjectConfirmation :: HasCallStack => SubjectConfirmation -> SubjectConfirmation
exportSubjectConfirmation (SubjectConfirmation SubjectConfirmationMethod
SubjectConfirmationMethodBearer Maybe SubjectConfirmationData
scd) =
  IdentifiedURI ConfirmationMethod
-> Maybe (PossiblyEncrypted Identifier)
-> Maybe SubjectConfirmationData
-> SubjectConfirmation
HX.SubjectConfirmation (ConfirmationMethod -> IdentifiedURI ConfirmationMethod
forall b a. a -> Identified b a
HX.Identified ConfirmationMethod
HX.ConfirmationMethodBearer) Maybe (PossiblyEncrypted Identifier)
forall a. Maybe a
Nothing (Maybe SubjectConfirmationData -> SubjectConfirmation)
-> Maybe SubjectConfirmationData -> SubjectConfirmation
forall a b. (a -> b) -> a -> b
$ HasCallStack => SubjectConfirmationData -> SubjectConfirmationData
SubjectConfirmationData -> SubjectConfirmationData
exportSubjectConfirmationData (SubjectConfirmationData -> SubjectConfirmationData)
-> Maybe SubjectConfirmationData -> Maybe SubjectConfirmationData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SubjectConfirmationData
scd

importSubjectConfirmationData :: (HasCallStack, MonadError String m) => HX.SubjectConfirmationData -> m SubjectConfirmationData
importSubjectConfirmationData :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SubjectConfirmationData -> m SubjectConfirmationData
importSubjectConfirmationData (HX.SubjectConfirmationData Maybe UTCTime
notbefore (Just UTCTime
notonorafter) (Just AnyURI
recipient) Maybe String
inresp Maybe String
confaddr [KeyInfo]
_ [XmlTree]
_) =
  Maybe Time
-> Time
-> URI
-> Maybe (ID AuthnRequest)
-> Maybe IP
-> SubjectConfirmationData
SubjectConfirmationData
    (Maybe Time
 -> Time
 -> URI
 -> Maybe (ID AuthnRequest)
 -> Maybe IP
 -> SubjectConfirmationData)
-> m (Maybe Time)
-> m (Time
      -> URI
      -> Maybe (ID AuthnRequest)
      -> Maybe IP
      -> SubjectConfirmationData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
UTCTime -> m Time
importTime (UTCTime -> m Time) -> Maybe UTCTime -> m (Maybe Time)
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` Maybe UTCTime
notbefore
    m (Time
   -> URI
   -> Maybe (ID AuthnRequest)
   -> Maybe IP
   -> SubjectConfirmationData)
-> m Time
-> m (URI
      -> Maybe (ID AuthnRequest) -> Maybe IP -> SubjectConfirmationData)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
UTCTime -> m Time
importTime UTCTime
notonorafter
    m (URI
   -> Maybe (ID AuthnRequest) -> Maybe IP -> SubjectConfirmationData)
-> m URI
-> m (Maybe (ID AuthnRequest)
      -> Maybe IP -> SubjectConfirmationData)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AnyURI -> m URI
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
AnyURI -> m URI
importURI AnyURI
recipient
    m (Maybe (ID AuthnRequest) -> Maybe IP -> SubjectConfirmationData)
-> m (Maybe (ID AuthnRequest))
-> m (Maybe IP -> SubjectConfirmationData)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> m (ID AuthnRequest)
forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError String m) =>
String -> m (ID a)
importID (String -> m (ID AuthnRequest))
-> Maybe String -> m (Maybe (ID AuthnRequest))
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` Maybe String
inresp
    m (Maybe IP -> SubjectConfirmationData)
-> m (Maybe IP) -> m SubjectConfirmationData
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> m IP
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
String -> m IP
importIP (String -> m IP) -> Maybe String -> m (Maybe IP)
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` Maybe String
confaddr
-- ignore: 'HX.subjectConfirmationKeyInfo' (this is only required for holder of key subjects
-- [3/3.1], [1/2.4.1.2], [1/2.4.1.4])
-- ignore: 'HX.subjectConfirmationXML' (there is nothing we can assume about it's semantics)

importSubjectConfirmationData bad :: SubjectConfirmationData
bad@(HX.SubjectConfirmationData Maybe UTCTime
_ Maybe UTCTime
Nothing Maybe AnyURI
_ Maybe String
_ Maybe String
_ [KeyInfo]
_ [XmlTree]
_) =
  Proxy SubjectConfirmationData
-> String -> m SubjectConfirmationData
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SubjectConfirmationData) (String
"missing NotOnOrAfter: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SubjectConfirmationData -> String
forall a. Show a => a -> String
show SubjectConfirmationData
bad)
importSubjectConfirmationData bad :: SubjectConfirmationData
bad@(HX.SubjectConfirmationData Maybe UTCTime
_ Maybe UTCTime
_ Maybe AnyURI
Nothing Maybe String
_ Maybe String
_ [KeyInfo]
_ [XmlTree]
_) =
  Proxy SubjectConfirmationData
-> String -> m SubjectConfirmationData
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SubjectConfirmationData) (String
"missing Recipient: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SubjectConfirmationData -> String
forall a. Show a => a -> String
show SubjectConfirmationData
bad)

exportSubjectConfirmationData :: (HasCallStack) => SubjectConfirmationData -> HX.SubjectConfirmationData
exportSubjectConfirmationData :: HasCallStack => SubjectConfirmationData -> SubjectConfirmationData
exportSubjectConfirmationData SubjectConfirmationData
scd =
  HX.SubjectConfirmationData
    { subjectConfirmationNotBefore :: Maybe UTCTime
HX.subjectConfirmationNotBefore = HasCallStack => Time -> UTCTime
Time -> UTCTime
exportTime (Time -> UTCTime) -> Maybe Time -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubjectConfirmationData
scd SubjectConfirmationData
-> Getting (Maybe Time) SubjectConfirmationData (Maybe Time)
-> Maybe Time
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Time) SubjectConfirmationData (Maybe Time)
Lens' SubjectConfirmationData (Maybe Time)
scdNotBefore,
      subjectConfirmationNotOnOrAfter :: Maybe UTCTime
HX.subjectConfirmationNotOnOrAfter = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime)
-> (Time -> UTCTime) -> Time -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => Time -> UTCTime
Time -> UTCTime
exportTime (Time -> Maybe UTCTime) -> Time -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ SubjectConfirmationData
scd SubjectConfirmationData
-> Getting Time SubjectConfirmationData Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time SubjectConfirmationData Time
Lens' SubjectConfirmationData Time
scdNotOnOrAfter,
      subjectConfirmationRecipient :: Maybe AnyURI
HX.subjectConfirmationRecipient = AnyURI -> Maybe AnyURI
forall a. a -> Maybe a
Just (AnyURI -> Maybe AnyURI) -> (URI -> AnyURI) -> URI -> Maybe AnyURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => URI -> AnyURI
URI -> AnyURI
exportURI (URI -> Maybe AnyURI) -> URI -> Maybe AnyURI
forall a b. (a -> b) -> a -> b
$ SubjectConfirmationData
scd SubjectConfirmationData
-> Getting URI SubjectConfirmationData URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI SubjectConfirmationData URI
Lens' SubjectConfirmationData URI
scdRecipient,
      subjectConfirmationInResponseTo :: Maybe String
HX.subjectConfirmationInResponseTo = Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String)
-> (ID AuthnRequest -> Text) -> ID AuthnRequest -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ID AuthnRequest -> Text
forall {k} (m :: k). ID m -> Text
fromID (ID AuthnRequest -> String)
-> Maybe (ID AuthnRequest) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubjectConfirmationData
scd SubjectConfirmationData
-> Getting
     (Maybe (ID AuthnRequest))
     SubjectConfirmationData
     (Maybe (ID AuthnRequest))
-> Maybe (ID AuthnRequest)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (ID AuthnRequest))
  SubjectConfirmationData
  (Maybe (ID AuthnRequest))
Lens' SubjectConfirmationData (Maybe (ID AuthnRequest))
scdInResponseTo,
      subjectConfirmationAddress :: Maybe String
HX.subjectConfirmationAddress = HasCallStack => IP -> String
IP -> String
exportIP (IP -> String) -> Maybe IP -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubjectConfirmationData
scd SubjectConfirmationData
-> Getting (Maybe IP) SubjectConfirmationData (Maybe IP)
-> Maybe IP
forall s a. s -> Getting a s a -> a
^. Getting (Maybe IP) SubjectConfirmationData (Maybe IP)
Lens' SubjectConfirmationData (Maybe IP)
scdAddress,
      subjectConfirmationKeyInfo :: [KeyInfo]
HX.subjectConfirmationKeyInfo = [KeyInfo]
forall a. Monoid a => a
mempty,
      subjectConfirmationXML :: [XmlTree]
HX.subjectConfirmationXML = [XmlTree]
forall a. Monoid a => a
mempty
    }

importIP :: (HasCallStack, MonadError String m) => HX.IP -> m IP
importIP :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
String -> m IP
importIP = Text -> m IP
forall (m :: * -> *). MonadError String m => Text -> m IP
mkIP (Text -> m IP) -> (String -> Text) -> String -> m IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs

exportIP :: (HasCallStack) => IP -> HX.IP
exportIP :: HasCallStack => IP -> String
exportIP = Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> (IP -> Text) -> IP -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IP -> Text
ipToST

importConditions :: forall m. (HasCallStack, MonadError String m) => HX.Conditions -> m Conditions
importConditions :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Conditions -> m Conditions
importConditions Conditions
conds = do
  Maybe Time
_condNotBefore <- (UTCTime -> m Time) -> Maybe UTCTime -> m (Maybe Time)
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 UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
UTCTime -> m Time
importTime (Maybe UTCTime -> m (Maybe Time))
-> Maybe UTCTime -> m (Maybe Time)
forall a b. (a -> b) -> a -> b
$ Conditions -> Maybe UTCTime
HX.conditionsNotBefore Conditions
conds
  Maybe Time
_condNotOnOrAfter <- (UTCTime -> m Time) -> Maybe UTCTime -> m (Maybe Time)
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 UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
UTCTime -> m Time
importTime (Maybe UTCTime -> m (Maybe Time))
-> Maybe UTCTime -> m (Maybe Time)
forall a b. (a -> b) -> a -> b
$ Conditions -> Maybe UTCTime
HX.conditionsNotOnOrAfter Conditions
conds
  let _condOneTimeUse :: Bool
_condOneTimeUse = Bool
False
      _condAudienceRestriction :: [a]
_condAudienceRestriction = []
      go :: Conditions -> HX.Condition -> m Conditions
      go :: Conditions -> Condition -> m Conditions
go Conditions
conds' Condition
HX.OneTimeUse =
        Conditions -> m Conditions
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Conditions -> m Conditions) -> Conditions -> m Conditions
forall a b. (a -> b) -> a -> b
$ Conditions
conds' Conditions -> (Conditions -> Conditions) -> Conditions
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> Conditions -> Identity Conditions
Lens' Conditions Bool
condOneTimeUse ((Bool -> Identity Bool) -> Conditions -> Identity Conditions)
-> Bool -> Conditions -> Conditions
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
      go Conditions
conds' (HX.AudienceRestriction List1 Audience
hsrs) = do
        NonEmpty URI
rs :: NonEmpty URI <- (AnyURI -> m URI
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
AnyURI -> m URI
importURI (AnyURI -> m URI) -> (Audience -> AnyURI) -> Audience -> m URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Audience -> AnyURI
HX.audience) (Audience -> m URI) -> List1 Audience -> m (NonEmpty URI)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
`mapM` List1 Audience
hsrs
        Conditions -> m Conditions
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Conditions -> m Conditions) -> Conditions -> m Conditions
forall a b. (a -> b) -> a -> b
$ Conditions
conds' Conditions -> (Conditions -> Conditions) -> Conditions
forall a b. a -> (a -> b) -> b
& ([NonEmpty URI] -> Identity [NonEmpty URI])
-> Conditions -> Identity Conditions
Lens' Conditions [NonEmpty URI]
condAudienceRestriction (([NonEmpty URI] -> Identity [NonEmpty URI])
 -> Conditions -> Identity Conditions)
-> ([NonEmpty URI] -> [NonEmpty URI]) -> Conditions -> Conditions
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (NonEmpty URI
rs :)
      go Conditions
_ Condition
badcond = Proxy Conditions -> (String, Condition) -> m Conditions
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Conditions) (String
"unsupported condition" :: String, Condition
badcond)
  (Conditions -> Condition -> m Conditions)
-> Conditions -> [Condition] -> m Conditions
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Conditions -> Condition -> m Conditions
go (Conditions {Bool
[NonEmpty URI]
Maybe Time
forall a. [a]
_condNotBefore :: Maybe Time
_condNotOnOrAfter :: Maybe Time
_condOneTimeUse :: Bool
_condAudienceRestriction :: forall a. [a]
_condAudienceRestriction :: [NonEmpty URI]
_condOneTimeUse :: Bool
_condNotOnOrAfter :: Maybe Time
_condNotBefore :: Maybe Time
..}) (Conditions -> [Condition]
HX.conditions Conditions
conds)

exportConditions :: (HasCallStack) => Conditions -> HX.Conditions
exportConditions :: HasCallStack => Conditions -> Conditions
exportConditions Conditions
conds =
  HX.Conditions
    { conditionsNotBefore :: Maybe UTCTime
HX.conditionsNotBefore = HasCallStack => Time -> UTCTime
Time -> UTCTime
exportTime (Time -> UTCTime) -> Maybe Time -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conditions
conds Conditions
-> Getting (Maybe Time) Conditions (Maybe Time) -> Maybe Time
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Time) Conditions (Maybe Time)
Lens' Conditions (Maybe Time)
condNotBefore,
      conditionsNotOnOrAfter :: Maybe UTCTime
HX.conditionsNotOnOrAfter = HasCallStack => Time -> UTCTime
Time -> UTCTime
exportTime (Time -> UTCTime) -> Maybe Time -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Conditions
conds Conditions
-> Getting (Maybe Time) Conditions (Maybe Time) -> Maybe Time
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Time) Conditions (Maybe Time)
Lens' Conditions (Maybe Time)
condNotOnOrAfter,
      conditions :: [Condition]
HX.conditions =
        [Condition
HX.OneTimeUse | Conditions
conds Conditions -> Getting Bool Conditions Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Conditions Bool
Lens' Conditions Bool
condOneTimeUse]
          [Condition] -> [Condition] -> [Condition]
forall a. Semigroup a => a -> a -> a
<> [ List1 Audience -> Condition
HX.AudienceRestriction (AnyURI -> Audience
HX.Audience (AnyURI -> Audience) -> (URI -> AnyURI) -> URI -> Audience
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => URI -> AnyURI
URI -> AnyURI
exportURI (URI -> Audience) -> NonEmpty URI -> List1 Audience
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty URI
hsrs)
               | NonEmpty URI
hsrs <- Conditions
conds Conditions
-> Getting [NonEmpty URI] Conditions [NonEmpty URI]
-> [NonEmpty URI]
forall s a. s -> Getting a s a -> a
^. Getting [NonEmpty URI] Conditions [NonEmpty URI]
Lens' Conditions [NonEmpty URI]
condAudienceRestriction
             ]
    }

-- | Attribute statements are silently ignored.
importStatement ::
  (HasCallStack, MonadError String m) =>
  HX.Statement ->
  m (Maybe Statement)
importStatement :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Statement -> m (Maybe Statement)
importStatement (HX.StatementAttribute AttributeStatement
_) = Maybe Statement -> m (Maybe Statement)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Statement
forall a. Maybe a
Nothing
importStatement (HX.StatementAuthn AuthnStatement
st) =
  Statement -> Maybe Statement
forall a. a -> Maybe a
Just (Statement -> Maybe Statement)
-> m Statement -> m (Maybe Statement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    Time
_astAuthnInstant <- UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
UTCTime -> m Time
importTime (UTCTime -> m Time) -> UTCTime -> m Time
forall a b. (a -> b) -> a -> b
$ AuthnStatement -> UTCTime
HX.authnStatementInstant AuthnStatement
st
    let _astSessionIndex :: Maybe Text
_astSessionIndex = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AuthnStatement -> Maybe String
HX.authnStatementSessionIndex AuthnStatement
st
    Maybe Time
_astSessionNotOnOrAfter <- (UTCTime -> m Time) -> Maybe UTCTime -> m (Maybe Time)
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 UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
UTCTime -> m Time
importTime (Maybe UTCTime -> m (Maybe Time))
-> Maybe UTCTime -> m (Maybe Time)
forall a b. (a -> b) -> a -> b
$ AuthnStatement -> Maybe UTCTime
HX.authnStatementSessionNotOnOrAfter AuthnStatement
st
    Maybe Locality
_astSubjectLocality <- (SubjectLocality -> m Locality)
-> Maybe SubjectLocality -> m (Maybe Locality)
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 SubjectLocality -> m Locality
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SubjectLocality -> m Locality
importLocality (Maybe SubjectLocality -> m (Maybe Locality))
-> Maybe SubjectLocality -> m (Maybe Locality)
forall a b. (a -> b) -> a -> b
$ AuthnStatement -> Maybe SubjectLocality
HX.authnStatementSubjectLocality AuthnStatement
st
    -- NB: @HX.authnStatementContext st@ is ignored [1/2.7.2.2].
    Statement -> m Statement
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Statement -> m Statement) -> Statement -> m Statement
forall a b. (a -> b) -> a -> b
$ Time -> Maybe Text -> Maybe Time -> Maybe Locality -> Statement
AuthnStatement Time
_astAuthnInstant Maybe Text
_astSessionIndex Maybe Time
_astSessionNotOnOrAfter Maybe Locality
_astSubjectLocality
importStatement Statement
bad = Proxy Statement -> Statement -> m (Maybe Statement)
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Statement) Statement
bad

exportStatement :: (HasCallStack) => Statement -> HX.Statement
exportStatement :: HasCallStack => Statement -> Statement
exportStatement Statement
stm =
  AuthnStatement -> Statement
HX.StatementAuthn
    HX.AuthnStatement
      { authnStatementInstant :: UTCTime
HX.authnStatementInstant = HasCallStack => Time -> UTCTime
Time -> UTCTime
exportTime (Time -> UTCTime) -> Time -> UTCTime
forall a b. (a -> b) -> a -> b
$ Statement
stm Statement -> Getting Time Statement Time -> Time
forall s a. s -> Getting a s a -> a
^. Getting Time Statement Time
Lens' Statement Time
astAuthnInstant,
        authnStatementSessionIndex :: Maybe String
HX.authnStatementSessionIndex = Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Statement
stm Statement
-> Getting (Maybe Text) Statement (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) Statement (Maybe Text)
Lens' Statement (Maybe Text)
astSessionIndex),
        authnStatementSessionNotOnOrAfter :: Maybe UTCTime
HX.authnStatementSessionNotOnOrAfter = HasCallStack => Time -> UTCTime
Time -> UTCTime
exportTime (Time -> UTCTime) -> Maybe Time -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Statement
stm Statement
-> Getting (Maybe Time) Statement (Maybe Time) -> Maybe Time
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Time) Statement (Maybe Time)
Lens' Statement (Maybe Time)
astSessionNotOnOrAfter),
        authnStatementSubjectLocality :: Maybe SubjectLocality
HX.authnStatementSubjectLocality = HasCallStack => Locality -> SubjectLocality
Locality -> SubjectLocality
exportLocality (Locality -> SubjectLocality)
-> Maybe Locality -> Maybe SubjectLocality
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Statement
stm Statement
-> Getting (Maybe Locality) Statement (Maybe Locality)
-> Maybe Locality
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Locality) Statement (Maybe Locality)
Lens' Statement (Maybe Locality)
astSubjectLocality),
        authnStatementContext :: AuthnContext
HX.authnStatementContext = Maybe AnyURI -> Maybe AuthnContextDecl -> [AnyURI] -> AuthnContext
HX.AuthnContext Maybe AnyURI
forall a. Maybe a
Nothing Maybe AuthnContextDecl
forall a. Maybe a
Nothing []
      }

importLocality :: (HasCallStack, MonadError String m) => HX.SubjectLocality -> m Locality
importLocality :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SubjectLocality -> m Locality
importLocality SubjectLocality
loc =
  Maybe IP -> Maybe DNSName -> Locality
Locality
    (Maybe IP -> Maybe DNSName -> Locality)
-> m (Maybe IP) -> m (Maybe DNSName -> Locality)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> m IP) -> Maybe String -> m (Maybe IP)
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 String -> m IP
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
String -> m IP
importIP (SubjectLocality -> Maybe String
HX.subjectLocalityAddress SubjectLocality
loc)
    m (Maybe DNSName -> Locality) -> m (Maybe DNSName) -> m Locality
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe DNSName -> m (Maybe DNSName)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text -> DNSName
mkDNSName (Text -> DNSName) -> (String -> Text) -> String -> DNSName
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs) (String -> DNSName) -> Maybe String -> Maybe DNSName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubjectLocality -> Maybe String
HX.subjectLocalityDNSName SubjectLocality
loc)

exportLocality :: (HasCallStack) => Locality -> HX.SubjectLocality
exportLocality :: HasCallStack => Locality -> SubjectLocality
exportLocality Locality
loc =
  HX.SubjectLocality
    { subjectLocalityAddress :: Maybe String
HX.subjectLocalityAddress = HasCallStack => IP -> String
IP -> String
exportIP (IP -> String) -> Maybe IP -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Locality
loc Locality -> Getting (Maybe IP) Locality (Maybe IP) -> Maybe IP
forall s a. s -> Getting a s a -> a
^. Getting (Maybe IP) Locality (Maybe IP)
Lens' Locality (Maybe IP)
localityAddress,
      subjectLocalityDNSName :: Maybe String
HX.subjectLocalityDNSName = Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> (DNSName -> Text) -> DNSName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. DNSName -> Text
fromDNSName (DNSName -> String) -> Maybe DNSName -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Locality
loc Locality
-> Getting (Maybe DNSName) Locality (Maybe DNSName)
-> Maybe DNSName
forall s a. s -> Getting a s a -> a
^. Getting (Maybe DNSName) Locality (Maybe DNSName)
Lens' Locality (Maybe DNSName)
localityDNSName
    }

importID :: (HasCallStack, MonadError String m) => HX.ID -> m (ID a)
importID :: forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError String m) =>
String -> m (ID a)
importID = ID a -> m (ID a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID a -> m (ID a)) -> (String -> ID a) -> String -> m (ID a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ID a
forall {k} (m :: k). Text -> ID m
ID (Text -> ID a) -> (String -> Text) -> String -> ID a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs

exportID :: (HasCallStack) => ID a -> HX.ID
exportID :: forall {k} (a :: k). HasCallStack => ID a -> String
exportID = Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> (ID a -> Text) -> ID a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ID a -> Text
forall {k} (m :: k). ID m -> Text
fromID

importNameID :: (HasCallStack, MonadError String m) => HX.NameID -> m NameID
importNameID :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
NameID -> m NameID
importNameID bad :: NameID
bad@(HX.NameID (HX.BaseID {}) (HX.Unidentified AnyURI
_) Maybe String
_) =
  Proxy NameID -> String -> m NameID
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @NameID) (NameID -> String
forall a. Show a => a -> String
show NameID
bad)
importNameID (HX.NameID (HX.BaseID Maybe String
m1 Maybe String
m2 String
nid) (HX.Identified NameIDFormat
hsNameIDFormat) Maybe String
m3) =
  (String -> m NameID)
-> (NameID -> m NameID) -> Either String NameID -> m NameID
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Proxy NameID -> String -> m NameID
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @NameID)) NameID -> m NameID
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String NameID -> m NameID)
-> Either String NameID -> m NameID
forall a b. (a -> b) -> a -> b
$
    NameIDFormat -> Text -> Either String UnqualifiedNameID
forall (m :: * -> *).
MonadError String m =>
NameIDFormat -> Text -> m UnqualifiedNameID
form NameIDFormat
hsNameIDFormat (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
nid) Either String UnqualifiedNameID
-> (UnqualifiedNameID -> Either String NameID)
-> Either String NameID
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \UnqualifiedNameID
nid' -> UnqualifiedNameID
-> Maybe Text -> Maybe Text -> Maybe Text -> Either String NameID
forall (m :: * -> *).
MonadError String m =>
UnqualifiedNameID
-> Maybe Text -> Maybe Text -> Maybe Text -> m NameID
mkNameID UnqualifiedNameID
nid' (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
m1) (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
m2) (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
m3)
  where
    form :: (MonadError String m) => HX.NameIDFormat -> ST -> m UnqualifiedNameID
    form :: forall (m :: * -> *).
MonadError String m =>
NameIDFormat -> Text -> m UnqualifiedNameID
form NameIDFormat
HX.NameIDFormatUnspecified = UnqualifiedNameID -> m UnqualifiedNameID
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnqualifiedNameID -> m UnqualifiedNameID)
-> (Text -> UnqualifiedNameID) -> Text -> m UnqualifiedNameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> UnqualifiedNameID
UNameIDUnspecified
    form NameIDFormat
HX.NameIDFormatEmail = Text -> m UnqualifiedNameID
forall (m :: * -> *).
MonadError String m =>
Text -> m UnqualifiedNameID
mkUNameIDEmail
    form NameIDFormat
HX.NameIDFormatX509 = UnqualifiedNameID -> m UnqualifiedNameID
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnqualifiedNameID -> m UnqualifiedNameID)
-> (Text -> UnqualifiedNameID) -> Text -> m UnqualifiedNameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> UnqualifiedNameID
UNameIDX509
    form NameIDFormat
HX.NameIDFormatWindows = UnqualifiedNameID -> m UnqualifiedNameID
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnqualifiedNameID -> m UnqualifiedNameID)
-> (Text -> UnqualifiedNameID) -> Text -> m UnqualifiedNameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> UnqualifiedNameID
UNameIDWindows
    form NameIDFormat
HX.NameIDFormatKerberos = UnqualifiedNameID -> m UnqualifiedNameID
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnqualifiedNameID -> m UnqualifiedNameID)
-> (Text -> UnqualifiedNameID) -> Text -> m UnqualifiedNameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> UnqualifiedNameID
UNameIDKerberos
    form NameIDFormat
HX.NameIDFormatEntity = (URI -> UnqualifiedNameID) -> m URI -> m UnqualifiedNameID
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap URI -> UnqualifiedNameID
UNameIDEntity (m URI -> m UnqualifiedNameID)
-> (Text -> m URI) -> Text -> m UnqualifiedNameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> m URI
forall (m :: * -> *). MonadError String m => Text -> m URI
parseURI'
    form NameIDFormat
HX.NameIDFormatPersistent = UnqualifiedNameID -> m UnqualifiedNameID
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnqualifiedNameID -> m UnqualifiedNameID)
-> (Text -> UnqualifiedNameID) -> Text -> m UnqualifiedNameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> UnqualifiedNameID
UNameIDPersistent
    form NameIDFormat
HX.NameIDFormatTransient = UnqualifiedNameID -> m UnqualifiedNameID
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnqualifiedNameID -> m UnqualifiedNameID)
-> (Text -> UnqualifiedNameID) -> Text -> m UnqualifiedNameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> UnqualifiedNameID
UNameIDTransient
    form b :: NameIDFormat
b@NameIDFormat
HX.NameIDFormatEncrypted = \Text
_ -> Proxy NameID -> String -> m UnqualifiedNameID
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @NameID) (NameIDFormat -> String
forall a. Show a => a -> String
show NameIDFormat
b)

exportNameID :: NameID -> HX.NameID
exportNameID :: NameID -> NameID
exportNameID NameID
name =
  HX.NameID
    { nameBaseID :: BaseID String
HX.nameBaseID =
        Maybe String -> Maybe String -> String -> BaseID String
forall id. Maybe String -> Maybe String -> id -> BaseID id
HX.BaseID
          (Text -> String
ST.unpack (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameID
name NameID -> Getting (Maybe Text) NameID (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) NameID (Maybe Text)
Lens' NameID (Maybe Text)
nameIDNameQ)
          (Text -> String
ST.unpack (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameID
name NameID -> Getting (Maybe Text) NameID (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) NameID (Maybe Text)
Lens' NameID (Maybe Text)
nameIDSPNameQ)
          (Text -> String
ST.unpack Text
nid),
      nameIDFormat :: IdentifiedURI NameIDFormat
HX.nameIDFormat = IdentifiedURI NameIDFormat
fmt,
      nameSPProvidedID :: Maybe String
HX.nameSPProvidedID = Text -> String
ST.unpack (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameID
name NameID -> Getting (Maybe Text) NameID (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) NameID (Maybe Text)
Lens' NameID (Maybe Text)
nameIDSPProvidedID
    }
  where
    (IdentifiedURI NameIDFormat
fmt, Text
nid) = UnqualifiedNameID -> (IdentifiedURI NameIDFormat, Text)
unform (NameID
name NameID
-> Getting UnqualifiedNameID NameID UnqualifiedNameID
-> UnqualifiedNameID
forall s a. s -> Getting a s a -> a
^. Getting UnqualifiedNameID NameID UnqualifiedNameID
Lens' NameID UnqualifiedNameID
nameID)
    unform :: UnqualifiedNameID -> (HX.IdentifiedURI HX.NameIDFormat, ST)
    unform :: UnqualifiedNameID -> (IdentifiedURI NameIDFormat, Text)
unform (UNameIDUnspecified Text
n) = (NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatUnspecified, Text
n)
    unform (UNameIDEmail CI Email
n) =
      ( NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatEmail,
        Email -> Text
forall s.
(FoldCase s, ConvertibleStrings ByteString s) =>
Email -> s
Email.render (Email -> Text) -> (CI Email -> Email) -> CI Email -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. CI Email -> Email
forall s. CI s -> s
CI.original (CI Email -> Text) -> CI Email -> Text
forall a b. (a -> b) -> a -> b
$ CI Email
n
      )
    unform (UNameIDX509 Text
n) = (NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatX509, Text
n)
    unform (UNameIDWindows Text
n) = (NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatWindows, Text
n)
    unform (UNameIDKerberos Text
n) = (NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatKerberos, Text
n)
    unform (UNameIDEntity URI
n) =
      ( NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatEntity,
        URI -> Text
renderURI URI
n
      )
    unform (UNameIDPersistent Text
n) = (NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatPersistent, Text
n)
    unform (UNameIDTransient Text
n) = (NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatTransient, Text
n)

importVersion :: (HasCallStack, MonadError String m) => HX.SAMLVersion -> m ()
importVersion :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SAMLVersion -> m ()
importVersion SAMLVersion
HX.SAML20 = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
importVersion SAMLVersion
bad = Proxy SAMLVersion -> SAMLVersion -> m ()
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @HX.SAMLVersion) SAMLVersion
bad

exportVersion :: (HasCallStack) => HX.SAMLVersion
exportVersion :: HasCallStack => SAMLVersion
exportVersion = SAMLVersion
HX.SAML20

importTime :: (HasCallStack, MonadError String m) => HX.DateTime -> m Time
importTime :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
UTCTime -> m Time
importTime = Time -> m Time
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> m Time) -> (UTCTime -> Time) -> UTCTime -> m Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTCTime -> Time
Time

exportTime :: (HasCallStack) => Time -> HX.DateTime
exportTime :: HasCallStack => Time -> UTCTime
exportTime = Time -> UTCTime
fromTime

importURI :: (HasCallStack, MonadError String m) => HX.URI -> m URI
importURI :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
AnyURI -> m URI
importURI AnyURI
uri = Text -> m URI
forall (m :: * -> *). MonadError String m => Text -> m URI
parseURI' (Text -> m URI) -> (String -> Text) -> String -> m URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> m URI) -> String -> m URI
forall a b. (a -> b) -> a -> b
$ (String -> String) -> AnyURI -> String -> String
URI.uriToString String -> String
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id AnyURI
uri String
forall a. Monoid a => a
mempty

exportURI :: (HasCallStack) => URI -> HX.URI
exportURI :: HasCallStack => URI -> AnyURI
exportURI URI
uri = AnyURI -> Maybe AnyURI -> AnyURI
forall a. a -> Maybe a -> a
fromMaybe AnyURI
err (Maybe AnyURI -> AnyURI) -> (URI -> Maybe AnyURI) -> URI -> AnyURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Maybe AnyURI
URI.parseURIReference (String -> Maybe AnyURI) -> (URI -> String) -> URI -> Maybe AnyURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> (URI -> Text) -> URI -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. URI -> Text
renderURI (URI -> AnyURI) -> URI -> AnyURI
forall a b. (a -> b) -> a -> b
$ URI
uri
  where
    err :: AnyURI
err = String -> AnyURI
forall a. HasCallStack => String -> a
error (String -> AnyURI) -> String -> AnyURI
forall a b. (a -> b) -> a -> b
$ String
"internal error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> URI -> String
forall a. Show a => a -> String
show URI
uri

-- | [1/3.2.2.1;3.2.2.2]
importStatus :: (HasCallStack, Monad m) => HX.Status -> m Status
importStatus :: forall (m :: * -> *). (HasCallStack, Monad m) => Status -> m Status
importStatus =
  Status -> m Status
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status -> m Status) -> (Status -> Status) -> Status -> m Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. \case
    HX.Status (HX.StatusCode StatusCode1
HX.StatusSuccess [IdentifiedURI StatusCode2]
_) Maybe String
_ Maybe [XmlTree]
_ -> Status
StatusSuccess
    Status
_ -> Status
StatusFailure

exportStatus :: (HasCallStack) => Status -> HX.Status
exportStatus :: HasCallStack => Status -> Status
exportStatus = \case
  Status
StatusSuccess -> StatusCode -> Maybe String -> Maybe [XmlTree] -> Status
HX.Status (StatusCode1 -> [IdentifiedURI StatusCode2] -> StatusCode
HX.StatusCode StatusCode1
HX.StatusSuccess []) Maybe String
forall a. Maybe a
Nothing Maybe [XmlTree]
forall a. Maybe a
Nothing
  Status
StatusFailure -> StatusCode -> Maybe String -> Maybe [XmlTree] -> Status
HX.Status (StatusCode1 -> [IdentifiedURI StatusCode2] -> StatusCode
HX.StatusCode StatusCode1
HX.StatusRequester []) Maybe String
forall a. Maybe a
Nothing Maybe [XmlTree]
forall a. Maybe a
Nothing

importIssuer :: (HasCallStack, MonadError String m) => HX.Issuer -> m Issuer
importIssuer :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Issuer -> m Issuer
importIssuer = (URI -> Issuer) -> m URI -> m Issuer
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap URI -> Issuer
Issuer (m URI -> m Issuer) -> (Issuer -> m URI) -> Issuer -> m Issuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (NameID -> m URI
forall {f :: * -> *}. MonadError String f => NameID -> f URI
nameIDToURI (NameID -> m URI) -> (NameID -> m NameID) -> NameID -> m URI
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< NameID -> m NameID
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
NameID -> m NameID
importNameID) (NameID -> m URI) -> (Issuer -> NameID) -> Issuer -> m URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Issuer -> NameID
HX.issuer
  where
    nameIDToURI :: NameID -> f URI
nameIDToURI nameid :: NameID
nameid@(Getting UnqualifiedNameID NameID UnqualifiedNameID
-> NameID -> UnqualifiedNameID
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UnqualifiedNameID NameID UnqualifiedNameID
Lens' NameID UnqualifiedNameID
nameID -> UNameIDEntity URI
uri)
      | ( Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (NameID
nameid NameID -> Getting (Maybe Text) NameID (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) NameID (Maybe Text)
Lens' NameID (Maybe Text)
nameIDNameQ)
            Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (NameID
nameid NameID -> Getting (Maybe Text) NameID (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) NameID (Maybe Text)
Lens' NameID (Maybe Text)
nameIDSPNameQ)
            Bool -> Bool -> Bool
&& Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (NameID
nameid NameID -> Getting (Maybe Text) NameID (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) NameID (Maybe Text)
Lens' NameID (Maybe Text)
nameIDSPProvidedID)
        ) =
          URI -> f URI
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
uri
    nameIDToURI NameID
bad = Proxy Issuer -> NameID -> f URI
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Issuer) NameID
bad

exportIssuer :: (HasCallStack) => Issuer -> HX.Issuer
exportIssuer :: HasCallStack => Issuer -> Issuer
exportIssuer = NameID -> Issuer
HX.Issuer (NameID -> Issuer) -> (Issuer -> NameID) -> Issuer -> Issuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NameID -> NameID
exportNameID (NameID -> NameID) -> (Issuer -> NameID) -> Issuer -> NameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. URI -> NameID
entityNameID (URI -> NameID) -> (Issuer -> URI) -> Issuer -> NameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Issuer -> URI
_fromIssuer

importRequiredIssuer :: (HasCallStack, MonadError String m) => Maybe HX.Issuer -> m Issuer
importRequiredIssuer :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Maybe Issuer -> m Issuer
importRequiredIssuer = m Issuer -> (Issuer -> m Issuer) -> Maybe Issuer -> m Issuer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Proxy AuthnRequest -> String -> m Issuer
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @AuthnRequest) (String
"no issuer id" :: String)) Issuer -> m Issuer
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Issuer -> m Issuer
importIssuer

exportRequiredIssuer :: (HasCallStack) => Issuer -> Maybe HX.Issuer
exportRequiredIssuer :: HasCallStack => Issuer -> Maybe Issuer
exportRequiredIssuer = Issuer -> Maybe Issuer
forall a. a -> Maybe a
Just (Issuer -> Maybe Issuer)
-> (Issuer -> Issuer) -> Issuer -> Maybe Issuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => Issuer -> Issuer
Issuer -> Issuer
exportIssuer

----------------------------------------------------------------------
-- metadata

-- | Construct SP metadata with a new UUID and current time stamp.
--
-- The @resp@ argument here must match the @finalize-login@ end-point (as can be constructed by
-- 'getSsoURL').
mkSPMetadata :: (Monad m, SP m) => ST -> URI -> URI -> [ContactPerson] -> m SPMetadata
mkSPMetadata :: forall (m :: * -> *).
(Monad m, SP m) =>
Text -> URI -> URI -> [ContactPerson] -> m SPMetadata
mkSPMetadata Text
nick URI
org URI
resp [ContactPerson]
contacts = do
  ID SPMetadata
mid <- m (ID SPMetadata)
forall {k} (m :: * -> *) (a :: k). (Functor m, SP m) => m (ID a)
createID
  Time
now <- m Time
forall (m :: * -> *). HasNow m => m Time
getNow
  SPMetadata -> m SPMetadata
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SPMetadata -> m SPMetadata) -> SPMetadata -> m SPMetadata
forall a b. (a -> b) -> a -> b
$ ID SPMetadata
-> Time -> Text -> URI -> URI -> [ContactPerson] -> SPMetadata
mkSPMetadata' ID SPMetadata
mid Time
now Text
nick URI
org URI
resp [ContactPerson]
contacts

mkSPMetadata' :: ID SPMetadata -> Time -> ST -> URI -> URI -> [ContactPerson] -> SPMetadata
mkSPMetadata' :: ID SPMetadata
-> Time -> Text -> URI -> URI -> [ContactPerson] -> SPMetadata
mkSPMetadata' ID SPMetadata
mid Time
now Text
nick URI
org URI
resp [ContactPerson]
contacts =
  let _spID :: ID SPMetadata
_spID = ID SPMetadata
mid
      _spCacheDuration :: a
_spCacheDuration = a -> a
forall {a}. Num a => a -> a
months a
1
      _spOrgName :: Text
_spOrgName = Text
nick
      _spOrgDisplayName :: Text
_spOrgDisplayName = Text
nick
      _spOrgURL :: URI
_spOrgURL = URI
org
      _spResponseURL :: URI
_spResponseURL = URI
resp
      _spContacts :: [ContactPerson]
_spContacts = [ContactPerson]
contacts
      years :: a -> a
years a
n = a -> a
forall {a}. Num a => a -> a
days a
n a -> a -> a
forall a. Num a => a -> a -> a
* a
365
      months :: a -> a
months a
n = a -> a
forall {a}. Num a => a -> a
days a
n a -> a -> a
forall a. Num a => a -> a -> a
* a
30
      days :: a -> a
days a
n = a
n a -> a -> a
forall a. Num a => a -> a -> a
* a
60 a -> a -> a
forall a. Num a => a -> a -> a
* a
60 a -> a -> a
forall a. Num a => a -> a -> a
* a
24
      Time UTCTime
_spValidUntil = NominalDiffTime -> Time -> Time
addTime (NominalDiffTime -> NominalDiffTime
forall {a}. Num a => a -> a
years NominalDiffTime
1) Time
now
   in SPMetadata {[ContactPerson]
Text
UTCTime
NominalDiffTime
URI
ID SPMetadata
forall {a}. Num a => a
_spID :: ID SPMetadata
_spCacheDuration :: forall {a}. Num a => a
_spOrgName :: Text
_spOrgDisplayName :: Text
_spOrgURL :: URI
_spResponseURL :: URI
_spContacts :: [ContactPerson]
_spValidUntil :: UTCTime
_spContacts :: [ContactPerson]
_spResponseURL :: URI
_spOrgURL :: URI
_spOrgDisplayName :: Text
_spOrgName :: Text
_spCacheDuration :: NominalDiffTime
_spValidUntil :: UTCTime
_spID :: ID SPMetadata
..}

-- | NB: this works best under the assumption that the input has been constructed by
-- 'exportSPMetadata'.
importSPMetadata :: (HasCallStack, MonadError String m) => HX.Metadata -> m SPMetadata
importSPMetadata :: forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Metadata -> m SPMetadata
importSPMetadata (NonEmpty Descriptor -> Descriptor
forall a. NonEmpty a -> a
NL.head (NonEmpty Descriptor -> Descriptor)
-> (Metadata -> NonEmpty Descriptor) -> Metadata -> Descriptor
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Descriptors -> NonEmpty Descriptor
HX.descriptors (Descriptors -> NonEmpty Descriptor)
-> (Metadata -> Descriptors) -> Metadata -> NonEmpty Descriptor
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Metadata -> Descriptors
HX.entityDescriptors -> Descriptor
desc) = do
  case Descriptor
desc of
    HX.SPSSODescriptor {} -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Descriptor
bad -> String -> m ()
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"malformed HX.Descriptor: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Descriptor -> String
forall a. Show a => a -> String
show Descriptor
bad
  ID SPMetadata
_spID <-
    let raw :: Maybe String
raw = RoleDescriptor -> Maybe String
HX.roleDescriptorID (RoleDescriptor -> Maybe String)
-> (Descriptor -> RoleDescriptor) -> Descriptor -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Descriptor -> RoleDescriptor
HX.descriptorRole (Descriptor -> Maybe String) -> Descriptor -> Maybe String
forall a b. (a -> b) -> a -> b
$ Descriptor
desc
     in m (ID SPMetadata)
-> (String -> m (ID SPMetadata))
-> Maybe String
-> m (ID SPMetadata)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m (ID SPMetadata)
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String
"malformed descriptorID: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe String -> String
forall a. Show a => a -> String
show Maybe String
raw)) (ID SPMetadata -> m (ID SPMetadata)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ID SPMetadata -> m (ID SPMetadata))
-> (String -> ID SPMetadata) -> String -> m (ID SPMetadata)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ID SPMetadata
forall {k} (m :: k). Text -> ID m
ID (Text -> ID SPMetadata)
-> (String -> Text) -> String -> ID SPMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs) Maybe String
raw
  UTCTime
_spValidUntil <-
    let raw :: Maybe UTCTime
raw = RoleDescriptor -> Maybe UTCTime
HX.roleDescriptorValidUntil (RoleDescriptor -> Maybe UTCTime)
-> (Descriptor -> RoleDescriptor) -> Descriptor -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Descriptor -> RoleDescriptor
HX.descriptorRole (Descriptor -> Maybe UTCTime) -> Descriptor -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ Descriptor
desc
     in m UTCTime -> (UTCTime -> m UTCTime) -> Maybe UTCTime -> m UTCTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m UTCTime
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m UTCTime) -> String -> m UTCTime
forall a b. (a -> b) -> a -> b
$ String
"bad validUntil: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe UTCTime -> String
forall a. Show a => a -> String
show Maybe UTCTime
raw) ((Time -> UTCTime) -> m Time -> m UTCTime
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Time -> UTCTime
fromTime (m Time -> m UTCTime)
-> (UTCTime -> m Time) -> UTCTime -> m UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTCTime -> m Time
forall us them (m :: * -> *).
(HasXMLImport us them, MonadError String m) =>
them -> m us
forall (m :: * -> *). MonadError String m => UTCTime -> m Time
importXml) Maybe UTCTime
raw
  NominalDiffTime
_spCacheDuration <-
    let raw :: Maybe NominalDiffTime
raw = RoleDescriptor -> Maybe NominalDiffTime
HX.roleDescriptorCacheDuration (RoleDescriptor -> Maybe NominalDiffTime)
-> (Descriptor -> RoleDescriptor)
-> Descriptor
-> Maybe NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Descriptor -> RoleDescriptor
HX.descriptorRole (Descriptor -> Maybe NominalDiffTime)
-> Descriptor -> Maybe NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Descriptor
desc
     in m NominalDiffTime
-> (NominalDiffTime -> m NominalDiffTime)
-> Maybe NominalDiffTime
-> m NominalDiffTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m NominalDiffTime
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m NominalDiffTime) -> String -> m NominalDiffTime
forall a b. (a -> b) -> a -> b
$ String
"bad cacheDuration: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe NominalDiffTime -> String
forall a. Show a => a -> String
show Maybe NominalDiffTime
raw) NominalDiffTime -> m NominalDiffTime
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NominalDiffTime
raw
  Text
_spOrgName :: Text <-
    let raw :: Maybe String
raw = case (Organization -> NonEmpty LocalizedName)
-> Maybe Organization -> Maybe (NonEmpty LocalizedName)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Organization -> NonEmpty LocalizedName
HX.organizationName (Maybe Organization -> Maybe (NonEmpty LocalizedName))
-> (Descriptor -> Maybe Organization)
-> Descriptor
-> Maybe (NonEmpty LocalizedName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RoleDescriptor -> Maybe Organization
HX.roleDescriptorOrganization (RoleDescriptor -> Maybe Organization)
-> (Descriptor -> RoleDescriptor)
-> Descriptor
-> Maybe Organization
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Descriptor -> RoleDescriptor
HX.descriptorRole (Descriptor -> Maybe (NonEmpty LocalizedName))
-> Descriptor -> Maybe (NonEmpty LocalizedName)
forall a b. (a -> b) -> a -> b
$ Descriptor
desc of
          Just (HX.Localized String
"EN" String
x :| []) -> String -> Maybe String
forall a. a -> Maybe a
Just String
x
          Maybe (NonEmpty LocalizedName)
_ -> Maybe String
forall a. Maybe a
Nothing
     in m Text -> (String -> m Text) -> Maybe String -> m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m Text
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m Text) -> String -> m Text
forall a b. (a -> b) -> a -> b
$ String
"bad orgName: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe String -> String
forall a. Show a => a -> String
show Maybe String
raw) (Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> (String -> Text) -> String -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs) Maybe String
raw
  Text
_spOrgDisplayName <-
    let raw :: Maybe String
raw = case (Organization -> NonEmpty LocalizedName)
-> Maybe Organization -> Maybe (NonEmpty LocalizedName)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Organization -> NonEmpty LocalizedName
HX.organizationDisplayName (Maybe Organization -> Maybe (NonEmpty LocalizedName))
-> (Descriptor -> Maybe Organization)
-> Descriptor
-> Maybe (NonEmpty LocalizedName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RoleDescriptor -> Maybe Organization
HX.roleDescriptorOrganization (RoleDescriptor -> Maybe Organization)
-> (Descriptor -> RoleDescriptor)
-> Descriptor
-> Maybe Organization
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Descriptor -> RoleDescriptor
HX.descriptorRole (Descriptor -> Maybe (NonEmpty LocalizedName))
-> Descriptor -> Maybe (NonEmpty LocalizedName)
forall a b. (a -> b) -> a -> b
$ Descriptor
desc of
          Just (HX.Localized String
"EN" String
x :| []) -> String -> Maybe String
forall a. a -> Maybe a
Just String
x
          Maybe (NonEmpty LocalizedName)
_ -> Maybe String
forall a. Maybe a
Nothing
     in m Text -> (String -> m Text) -> Maybe String -> m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m Text
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m Text) -> String -> m Text
forall a b. (a -> b) -> a -> b
$ String
"bad orgDisplayName: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe String -> String
forall a. Show a => a -> String
show Maybe String
raw) (Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> (String -> Text) -> String -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs) Maybe String
raw
  URI
_spOrgURL <-
    let raw :: Maybe (List1 LocalizedURI)
raw = (Organization -> List1 LocalizedURI)
-> Maybe Organization -> Maybe (List1 LocalizedURI)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Organization -> List1 LocalizedURI
HX.organizationURL (Maybe Organization -> Maybe (List1 LocalizedURI))
-> (Descriptor -> Maybe Organization)
-> Descriptor
-> Maybe (List1 LocalizedURI)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RoleDescriptor -> Maybe Organization
HX.roleDescriptorOrganization (RoleDescriptor -> Maybe Organization)
-> (Descriptor -> RoleDescriptor)
-> Descriptor
-> Maybe Organization
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Descriptor -> RoleDescriptor
HX.descriptorRole (Descriptor -> Maybe (List1 LocalizedURI))
-> Descriptor -> Maybe (List1 LocalizedURI)
forall a b. (a -> b) -> a -> b
$ Descriptor
desc
     in case Maybe (List1 LocalizedURI)
raw of
          Just (HX.Localized String
"EN" AnyURI
u :| []) -> AnyURI -> m URI
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
AnyURI -> m URI
importURI AnyURI
u
          Maybe (List1 LocalizedURI)
bad -> String -> m URI
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m URI) -> String -> m URI
forall a b. (a -> b) -> a -> b
$ String
"bad or no organizationURL" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe (List1 LocalizedURI) -> String
forall a. Show a => a -> String
show Maybe (List1 LocalizedURI)
bad
  URI
_spResponseURL <-
    AnyURI -> m URI
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
AnyURI -> m URI
importURI
      (AnyURI -> m URI) -> (Descriptor -> AnyURI) -> Descriptor -> m URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Endpoint -> AnyURI
HX.endpointLocation
      (Endpoint -> AnyURI)
-> (Descriptor -> Endpoint) -> Descriptor -> AnyURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IndexedEndpoint -> Endpoint
HX.indexedEndpoint
      (IndexedEndpoint -> Endpoint)
-> (Descriptor -> IndexedEndpoint) -> Descriptor -> Endpoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NonEmpty IndexedEndpoint -> IndexedEndpoint
forall a. NonEmpty a -> a
NL.head
      (NonEmpty IndexedEndpoint -> IndexedEndpoint)
-> (Descriptor -> NonEmpty IndexedEndpoint)
-> Descriptor
-> IndexedEndpoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Descriptor -> NonEmpty IndexedEndpoint
HX.descriptorAssertionConsumerService
      (Descriptor -> m URI) -> Descriptor -> m URI
forall a b. (a -> b) -> a -> b
$ Descriptor
desc
  [ContactPerson]
_spContacts <- (Contact -> m ContactPerson) -> [Contact] -> m [ContactPerson]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Contact -> m ContactPerson
forall (m :: * -> *).
MonadError String m =>
Contact -> m ContactPerson
importContactPerson ([Contact] -> m [ContactPerson])
-> (Descriptor -> [Contact]) -> Descriptor -> m [ContactPerson]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RoleDescriptor -> [Contact]
HX.roleDescriptorContactPerson (RoleDescriptor -> [Contact])
-> (Descriptor -> RoleDescriptor) -> Descriptor -> [Contact]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Descriptor -> RoleDescriptor
HX.descriptorRole (Descriptor -> m [ContactPerson])
-> Descriptor -> m [ContactPerson]
forall a b. (a -> b) -> a -> b
$ Descriptor
desc
  SPMetadata -> m SPMetadata
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SPMetadata {[ContactPerson]
Text
UTCTime
NominalDiffTime
URI
ID SPMetadata
_spContacts :: [ContactPerson]
_spResponseURL :: URI
_spOrgURL :: URI
_spOrgDisplayName :: Text
_spOrgName :: Text
_spCacheDuration :: NominalDiffTime
_spValidUntil :: UTCTime
_spID :: ID SPMetadata
_spID :: ID SPMetadata
_spValidUntil :: UTCTime
_spCacheDuration :: NominalDiffTime
_spOrgName :: Text
_spOrgDisplayName :: Text
_spOrgURL :: URI
_spResponseURL :: URI
_spContacts :: [ContactPerson]
..}

exportSPMetadata :: (HasCallStack) => SPMetadata -> HX.Metadata
exportSPMetadata :: HasCallStack => SPMetadata -> Metadata
exportSPMetadata SPMetadata
spdesc =
  HX.EntityDescriptor
    { entityID :: AnyURI
HX.entityID = HasCallStack => URI -> AnyURI
URI -> AnyURI
exportURI (SPMetadata
spdesc SPMetadata -> Getting URI SPMetadata URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI SPMetadata URI
Lens' SPMetadata URI
spOrgURL) :: HX.EntityID,
      metadataID :: Maybe String
HX.metadataID = Maybe String
forall a. Maybe a
Nothing :: Maybe HX.ID,
      metadataValidUntil :: Maybe UTCTime
HX.metadataValidUntil = Maybe UTCTime
forall a. Maybe a
Nothing :: Maybe HX.DateTime,
      metadataCacheDuration :: Maybe NominalDiffTime
HX.metadataCacheDuration = Maybe NominalDiffTime
forall a. Maybe a
Nothing :: Maybe HX.Duration,
      entityAttrs :: [XmlTree]
HX.entityAttrs = [XmlTree]
forall a. Monoid a => a
mempty :: HX.Nodes,
      metadataSignature :: Maybe Signature
HX.metadataSignature = Maybe Signature
forall a. Maybe a
Nothing :: Maybe HX.Signature,
      metadataExtensions :: Extensions
HX.metadataExtensions = Extensions
forall a. Monoid a => a
mempty :: HX.Extensions,
      entityDescriptors :: Descriptors
HX.entityDescriptors = NonEmpty Descriptor -> Descriptors
HX.Descriptors (HasCallStack => SPMetadata -> Descriptor
SPMetadata -> Descriptor
exportSPMetadata' SPMetadata
spdesc Descriptor -> [Descriptor] -> NonEmpty Descriptor
forall a. a -> [a] -> NonEmpty a
:| []),
      entityOrganization :: Maybe Organization
HX.entityOrganization = Maybe Organization
forall a. Maybe a
Nothing :: Maybe HX.Organization,
      entityContactPerson :: [Contact]
HX.entityContactPerson = [Contact]
forall a. Monoid a => a
mempty :: [HX.Contact],
      entityAditionalMetadataLocation :: [AdditionalMetadataLocation]
HX.entityAditionalMetadataLocation = [AdditionalMetadataLocation]
forall a. Monoid a => a
mempty :: [HX.AdditionalMetadataLocation]
    }

-- | [4/2.6], [4/2]
exportSPMetadata' :: (HasCallStack) => SPMetadata -> HX.Descriptor
exportSPMetadata' :: HasCallStack => SPMetadata -> Descriptor
exportSPMetadata' SPMetadata
spdesc =
  HX.SPSSODescriptor
    { descriptorRole :: RoleDescriptor
HX.descriptorRole =
        HX.RoleDescriptor
          { roleDescriptorID :: Maybe String
HX.roleDescriptorID = String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String)
-> (ID SPMetadata -> Text) -> ID SPMetadata -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ID SPMetadata -> Text
forall {k} (m :: k). ID m -> Text
fromID (ID SPMetadata -> String) -> ID SPMetadata -> String
forall a b. (a -> b) -> a -> b
$ SPMetadata
spdesc SPMetadata
-> Getting (ID SPMetadata) SPMetadata (ID SPMetadata)
-> ID SPMetadata
forall s a. s -> Getting a s a -> a
^. Getting (ID SPMetadata) SPMetadata (ID SPMetadata)
Lens' SPMetadata (ID SPMetadata)
spID) :: Maybe HX.ID,
            roleDescriptorValidUntil :: Maybe UTCTime
HX.roleDescriptorValidUntil = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (SPMetadata
spdesc SPMetadata -> Getting UTCTime SPMetadata UTCTime -> UTCTime
forall s a. s -> Getting a s a -> a
^. Getting UTCTime SPMetadata UTCTime
Lens' SPMetadata UTCTime
spValidUntil) :: Maybe HX.DateTime,
            roleDescriptorCacheDuration :: Maybe NominalDiffTime
HX.roleDescriptorCacheDuration = NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just (SPMetadata
spdesc SPMetadata
-> Getting NominalDiffTime SPMetadata NominalDiffTime
-> NominalDiffTime
forall s a. s -> Getting a s a -> a
^. Getting NominalDiffTime SPMetadata NominalDiffTime
Lens' SPMetadata NominalDiffTime
spCacheDuration) :: Maybe HX.Duration,
            roleDescriptorProtocolSupportEnumeration :: [AnyURI]
HX.roleDescriptorProtocolSupportEnumeration = [SAMLVersion -> [String] -> AnyURI
HX.samlURN SAMLVersion
HX.SAML20 [String
"protocol"]] :: [HX.AnyURI],
            roleDescriptorErrorURL :: Maybe AnyURI
HX.roleDescriptorErrorURL = Maybe AnyURI
forall a. Maybe a
Nothing :: Maybe HX.AnyURI,
            roleDescriptorAttrs :: [XmlTree]
HX.roleDescriptorAttrs = [] :: HX.Nodes,
            roleDescriptorSignature :: Maybe Signature
HX.roleDescriptorSignature = Maybe Signature
forall a. Maybe a
Nothing :: Maybe HX.Signature,
            roleDescriptorExtensions :: Extensions
HX.roleDescriptorExtensions = [XmlTree] -> Extensions
HX.Extensions [],
            roleDescriptorKeyDescriptor :: [KeyDescriptor]
HX.roleDescriptorKeyDescriptor = [] :: [HX.KeyDescriptor],
            roleDescriptorOrganization :: Maybe Organization
HX.roleDescriptorOrganization =
              Organization -> Maybe Organization
forall a. a -> Maybe a
Just
                HX.Organization
                  { organizationAttrs :: [XmlTree]
HX.organizationAttrs = [],
                    organizationExtensions :: Extensions
HX.organizationExtensions = [XmlTree] -> Extensions
HX.Extensions [],
                    organizationName :: NonEmpty LocalizedName
HX.organizationName = String -> String -> LocalizedName
forall a. String -> a -> Localized a
HX.Localized String
"EN" (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ SPMetadata
spdesc SPMetadata -> Getting Text SPMetadata Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text SPMetadata Text
Lens' SPMetadata Text
spOrgName) LocalizedName -> [LocalizedName] -> NonEmpty LocalizedName
forall a. a -> [a] -> NonEmpty a
:| [],
                    organizationDisplayName :: NonEmpty LocalizedName
HX.organizationDisplayName = String -> String -> LocalizedName
forall a. String -> a -> Localized a
HX.Localized String
"EN" (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ SPMetadata
spdesc SPMetadata -> Getting Text SPMetadata Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text SPMetadata Text
Lens' SPMetadata Text
spOrgDisplayName) LocalizedName -> [LocalizedName] -> NonEmpty LocalizedName
forall a. a -> [a] -> NonEmpty a
:| [],
                    organizationURL :: List1 LocalizedURI
HX.organizationURL = String -> AnyURI -> LocalizedURI
forall a. String -> a -> Localized a
HX.Localized String
"EN" (HasCallStack => URI -> AnyURI
URI -> AnyURI
exportURI (URI -> AnyURI) -> URI -> AnyURI
forall a b. (a -> b) -> a -> b
$ SPMetadata
spdesc SPMetadata -> Getting URI SPMetadata URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI SPMetadata URI
Lens' SPMetadata URI
spOrgURL) LocalizedURI -> [LocalizedURI] -> List1 LocalizedURI
forall a. a -> [a] -> NonEmpty a
:| [] :: HX.List1 HX.LocalizedURI
                  },
            roleDescriptorContactPerson :: [Contact]
HX.roleDescriptorContactPerson = ContactPerson -> Contact
exportContactPerson (ContactPerson -> Contact) -> [ContactPerson] -> [Contact]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SPMetadata
spdesc SPMetadata
-> Getting [ContactPerson] SPMetadata [ContactPerson]
-> [ContactPerson]
forall s a. s -> Getting a s a -> a
^. Getting [ContactPerson] SPMetadata [ContactPerson]
Lens' SPMetadata [ContactPerson]
spContacts)
          },
      descriptorSSO :: SSODescriptor
HX.descriptorSSO =
        HX.SSODescriptor
          { ssoDescriptorArtifactResolutionService :: [IndexedEndpoint]
HX.ssoDescriptorArtifactResolutionService = [] :: [HX.IndexedEndpoint],
            ssoDescriptorSingleLogoutService :: [Endpoint]
HX.ssoDescriptorSingleLogoutService = [] :: [HX.Endpoint],
            ssoDescriptorManageNameIDService :: [Endpoint]
HX.ssoDescriptorManageNameIDService = [] :: [HX.Endpoint],
            ssoDescriptorNameIDFormat :: [IdentifiedURI NameIDFormat]
HX.ssoDescriptorNameIDFormat = [NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatUnspecified, NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HX.NameIDFormatEntity] -- [1/8.3]
          },
      descriptorAuthnRequestsSigned :: Bool
HX.descriptorAuthnRequestsSigned = Bool
False,
      descriptorWantAssertionsSigned :: Bool
HX.descriptorWantAssertionsSigned = Bool
True,
      descriptorAssertionConsumerService :: NonEmpty IndexedEndpoint
HX.descriptorAssertionConsumerService =
        HX.IndexedEndpoint
          { indexedEndpoint :: Endpoint
HX.indexedEndpoint =
              HX.Endpoint
                { endpointBinding :: IdentifiedURI Binding
HX.endpointBinding = Binding -> IdentifiedURI Binding
forall b a. a -> Identified b a
HX.Identified Binding
HX.BindingHTTPPOST :: HX.IdentifiedURI HX.Binding,
                  endpointLocation :: AnyURI
HX.endpointLocation = HasCallStack => URI -> AnyURI
URI -> AnyURI
exportURI (URI -> AnyURI) -> URI -> AnyURI
forall a b. (a -> b) -> a -> b
$ SPMetadata
spdesc SPMetadata -> Getting URI SPMetadata URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI SPMetadata URI
Lens' SPMetadata URI
spResponseURL :: HX.AnyURI,
                  endpointResponseLocation :: Maybe AnyURI
HX.endpointResponseLocation = Maybe AnyURI
forall a. Maybe a
Nothing :: Maybe HX.AnyURI,
                  endpointAttrs :: [XmlTree]
HX.endpointAttrs = [] :: HX.Nodes,
                  endpointXML :: [XmlTree]
HX.endpointXML = [] :: HX.Nodes
                },
            indexedEndpointIndex :: UnsignedShort
HX.indexedEndpointIndex = UnsignedShort
0 :: HX.UnsignedShort,
            indexedEndpointIsDefault :: Bool
HX.indexedEndpointIsDefault = Bool
True :: HX.Boolean
          }
          IndexedEndpoint -> [IndexedEndpoint] -> NonEmpty IndexedEndpoint
forall a. a -> [a] -> NonEmpty a
:| [] ::
          HX.List1 HX.IndexedEndpoint,
      descriptorAttributeConsumingService :: [AttributeConsumingService]
HX.descriptorAttributeConsumingService = [] :: [HX.AttributeConsumingService]
      -- (for identification we do not need any attributes, but can use the 'SubjectID' that is
      -- always included in the response.)
    }

exportContactPerson :: ContactPerson -> HX.Contact
exportContactPerson :: ContactPerson -> Contact
exportContactPerson ContactPerson
contact =
  HX.ContactPerson
    { contactType :: ContactType
HX.contactType = ContactType -> ContactType
exportContactType (ContactType -> ContactType) -> ContactType -> ContactType
forall a b. (a -> b) -> a -> b
$ ContactPerson
contact ContactPerson
-> Getting ContactType ContactPerson ContactType -> ContactType
forall s a. s -> Getting a s a -> a
^. Getting ContactType ContactPerson ContactType
Lens' ContactPerson ContactType
cntType,
      contactAttrs :: [XmlTree]
HX.contactAttrs = [],
      contactExtensions :: Extensions
HX.contactExtensions = [XmlTree] -> Extensions
HX.Extensions [],
      contactCompany :: Maybe String
HX.contactCompany = Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContactPerson
contact ContactPerson
-> Getting (Maybe Text) ContactPerson (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) ContactPerson (Maybe Text)
Lens' ContactPerson (Maybe Text)
cntCompany,
      contactGivenName :: Maybe String
HX.contactGivenName = Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContactPerson
contact ContactPerson
-> Getting (Maybe Text) ContactPerson (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) ContactPerson (Maybe Text)
Lens' ContactPerson (Maybe Text)
cntGivenName,
      contactSurName :: Maybe String
HX.contactSurName = Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContactPerson
contact ContactPerson
-> Getting (Maybe Text) ContactPerson (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) ContactPerson (Maybe Text)
Lens' ContactPerson (Maybe Text)
cntSurname,
      contactEmailAddress :: [AnyURI]
HX.contactEmailAddress = Maybe AnyURI -> [AnyURI]
forall a. Maybe a -> [a]
maybeToList (Maybe AnyURI -> [AnyURI]) -> Maybe AnyURI -> [AnyURI]
forall a b. (a -> b) -> a -> b
$ HasCallStack => URI -> AnyURI
URI -> AnyURI
exportURI (URI -> AnyURI) -> Maybe URI -> Maybe AnyURI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContactPerson
contact ContactPerson
-> Getting (Maybe URI) ContactPerson (Maybe URI) -> Maybe URI
forall s a. s -> Getting a s a -> a
^. Getting (Maybe URI) ContactPerson (Maybe URI)
Lens' ContactPerson (Maybe URI)
cntEmail :: [HX.AnyURI],
      contactTelephoneNumber :: [String]
HX.contactTelephoneNumber = Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContactPerson
contact ContactPerson
-> Getting (Maybe Text) ContactPerson (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) ContactPerson (Maybe Text)
Lens' ContactPerson (Maybe Text)
cntPhone
    }

importContactPerson :: (MonadError String m) => HX.Contact -> m ContactPerson
importContactPerson :: forall (m :: * -> *).
MonadError String m =>
Contact -> m ContactPerson
importContactPerson Contact
contact = do
  let _cntType :: ContactType
_cntType = ContactType -> ContactType
importContactType (ContactType -> ContactType) -> ContactType -> ContactType
forall a b. (a -> b) -> a -> b
$ Contact -> ContactType
HX.contactType Contact
contact
      _cntCompany :: Maybe Text
_cntCompany = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contact -> Maybe String
HX.contactCompany Contact
contact
      _cntGivenName :: Maybe Text
_cntGivenName = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contact -> Maybe String
HX.contactGivenName Contact
contact
      _cntSurname :: Maybe Text
_cntSurname = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contact -> Maybe String
HX.contactSurName Contact
contact
      _cntPhone :: Maybe Text
_cntPhone = [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contact -> [String]
HX.contactTelephoneNumber Contact
contact
  Maybe URI
_cntEmail <- (AnyURI -> m URI) -> Maybe AnyURI -> m (Maybe URI)
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 AnyURI -> m URI
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
AnyURI -> m URI
importURI (Maybe AnyURI -> m (Maybe URI)) -> Maybe AnyURI -> m (Maybe URI)
forall a b. (a -> b) -> a -> b
$ [AnyURI] -> Maybe AnyURI
forall a. [a] -> Maybe a
listToMaybe (Contact -> [AnyURI]
HX.contactEmailAddress Contact
contact)
  ContactPerson -> m ContactPerson
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ContactPerson {Maybe Text
Maybe URI
ContactType
_cntType :: ContactType
_cntCompany :: Maybe Text
_cntGivenName :: Maybe Text
_cntSurname :: Maybe Text
_cntPhone :: Maybe Text
_cntEmail :: Maybe URI
_cntPhone :: Maybe Text
_cntEmail :: Maybe URI
_cntSurname :: Maybe Text
_cntGivenName :: Maybe Text
_cntCompany :: Maybe Text
_cntType :: ContactType
..}

exportContactType :: ContactType -> HX.ContactType
exportContactType :: ContactType -> ContactType
exportContactType = \case
  ContactType
ContactTechnical -> ContactType
HX.ContactTypeTechnical
  ContactType
ContactSupport -> ContactType
HX.ContactTypeSupport
  ContactType
ContactAdministrative -> ContactType
HX.ContactTypeAdministrative
  ContactType
ContactBilling -> ContactType
HX.ContactTypeBilling
  ContactType
ContactOther -> ContactType
HX.ContactTypeOther

importContactType :: HX.ContactType -> ContactType
importContactType :: ContactType -> ContactType
importContactType = \case
  ContactType
HX.ContactTypeTechnical -> ContactType
ContactTechnical
  ContactType
HX.ContactTypeSupport -> ContactType
ContactSupport
  ContactType
HX.ContactTypeAdministrative -> ContactType
ContactAdministrative
  ContactType
HX.ContactTypeBilling -> ContactType
ContactBilling
  ContactType
HX.ContactTypeOther -> ContactType
ContactOther

parseIdPMetadata :: (MonadError String m) => Element -> m IdPMetadata
parseIdPMetadata :: forall (m :: * -> *).
MonadError String m =>
Element -> m IdPMetadata
parseIdPMetadata el :: Element
el@(Element Name
tag Map Name Text
_ [Node]
_) = case Name
tag of
  Name
"{urn:oasis:names:tc:SAML:2.0:metadata}EntitiesDescriptor" ->
    (Element -> m Element
forall (m :: * -> *). MonadError String m => Element -> m Element
parseIdPMetadataList (Element -> m Element)
-> (Element -> m IdPMetadata) -> Element -> m IdPMetadata
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Element -> m IdPMetadata
forall (m :: * -> *).
MonadError String m =>
Element -> m IdPMetadata
parseIdPMetadataHead) Element
el
  Name
"{urn:oasis:names:tc:SAML:2.0:metadata}EntityDescriptor" ->
    Element -> m IdPMetadata
forall (m :: * -> *).
MonadError String m =>
Element -> m IdPMetadata
parseIdPMetadataHead Element
el
  Name
bad ->
    String -> m IdPMetadata
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m IdPMetadata) -> String -> m IdPMetadata
forall a b. (a -> b) -> a -> b
$ String
"expected <EntitiesDescriptor> or <EntityDescriptor>: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
bad

-- | Some IdPs send a list with one element in it.  In that case, we return the child so we
-- can call 'parseIdPMetadataHead' on it.
parseIdPMetadataList :: (MonadError String m) => Element -> m Element
parseIdPMetadataList :: forall (m :: * -> *). MonadError String m => Element -> m Element
parseIdPMetadataList (Element Name
tag Map Name Text
_ [Node]
chs) = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
tag Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"{urn:oasis:names:tc:SAML:2.0:metadata}EntitiesDescriptor") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    String -> m ()
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"expected <EntitiesDescriptor>"
  let isElem :: Node -> Bool
isElem = \case
        (NodeElement Element
_) -> Bool
True
        Node
_ -> Bool
False
  case (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter Node -> Bool
isElem [Node]
chs of
    [NodeElement Element
ch] -> Element -> m Element
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
ch
    [Node]
bad ->
      let msg :: a
msg = a
"expected <EntitiesDescriptor> with exactly one child element"
       in String -> m Element
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m Element) -> String -> m Element
forall a b. (a -> b) -> a -> b
$ String
forall {a}. IsString a => a
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; found " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Node] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node]
bad)

findSome :: (MonadError String m) => String -> (Cursor -> [a]) -> [Cursor] -> m [a]
findSome :: forall (m :: * -> *) a.
MonadError String m =>
String -> (Cursor -> [a]) -> [Cursor] -> m [a]
findSome String
descr Cursor -> [a]
axis [Cursor]
cursors =
  case (Cursor -> [a]) -> [Cursor] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cursor -> [a]
axis [Cursor]
cursors of
    [] -> String -> m [a]
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String
"Couldnt find any matches for: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
descr)
    [a]
xs -> [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
xs

getSingleton :: (MonadError String m) => String -> [a] -> m a
getSingleton :: forall (m :: * -> *) a. MonadError String m => String -> [a] -> m a
getSingleton String
_ [a
x] = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
getSingleton String
descr [] = String -> m a
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String
"Couldnt find any matches for: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
descr)
getSingleton String
descr [a]
_ = String -> m a
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String
"Expected only one but found multiple matches for: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
descr)

-- | Case insensitive version fo 'attributeIs'.  NB: this is generally violating the standard
-- (see below), but in many cases there is clearly no harm in doing so (it's hard to base an
-- attack on being able to say `HTTP-Post` instead of `HTTP-POST`).
--
-- Details:
-- * According to https://docs.oasis-open.org/security/saml/v2.0/saml-bindings-2.0-os.pdf,
--   Section 3.5.1, the binding should be "urn:oasis:names:tc:SAML:2.0:bindings:HTTP-POST",
--   but what you sent is "urn:oasis:names:tc:SAML:2.0:bindings:HTTP-Post".
-- * According to https://tools.ietf.org/html/rfc8141, page 17, URNs are case sensitive in the
--   position of "HTTP-Post".  All SAML IdPs that wire supports, including microsoft azure,
--   okta, and centrify are following this line of reasoning.
attributeIsCI :: Name -> CI ST -> (Cursor -> [Cursor])
attributeIsCI :: Name -> CI Text -> Axis
attributeIsCI Name
name CI Text
attValue = (Node -> Bool) -> Axis
forall b. Boolean b => (Node -> b) -> Axis
checkNode ((Node -> Bool) -> Axis) -> (Node -> Bool) -> Axis
forall a b. (a -> b) -> a -> b
$ \case
  NodeElement (Element Name
_ Map Name Text
as [Node]
_) ->
    case Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name Text
as of
      Maybe Text
Nothing -> Bool
False
      Just (Text -> CI Text
forall s. FoldCase s => s -> CI s
CI.mk -> CI Text
elAttValue) ->
        CI Text
elAttValue CI Text -> CI Text -> Bool
forall a. Eq a => a -> a -> Bool
== CI Text
attValue
  Node
_ -> Bool
False

-- | This is the sane case: since we only want one element, just send that.
parseIdPMetadataHead :: (MonadError String m) => Element -> m IdPMetadata
parseIdPMetadataHead :: forall (m :: * -> *).
MonadError String m =>
Element -> m IdPMetadata
parseIdPMetadataHead el :: Element
el@(Element Name
tag Map Name Text
attrs [Node]
_) = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
tag Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"{urn:oasis:names:tc:SAML:2.0:metadata}EntityDescriptor") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    String -> m ()
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"expected <EntityDescriptor>"
  Issuer
_edIssuer :: Issuer <- do
    Text
issueruri :: ST <- m Text -> (Text -> m Text) -> Maybe Text -> m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m Text
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"no issuer") Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
"entityID" Map Name Text
attrs)
    URI -> Issuer
Issuer (URI -> Issuer) -> m URI -> m Issuer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m URI
forall (m :: * -> *). MonadError String m => Text -> m URI
parseURI' Text
issueruri
  URI
_edRequestURI :: URI <- do
    Text
target :: ST <-
      let bindingDescr :: a
bindingDescr = a
"\"Binding\" attribute with value \"urn:oasis:names:tc:SAML:2.0:bindings:HTTP-POST\""
       in [Node -> Cursor
fromNode (Element -> Node
NodeElement Element
el)]
            [Cursor] -> ([Cursor] -> m Text) -> m Text
forall a b. a -> (a -> b) -> b
& ( String -> Axis -> [Cursor] -> m [Cursor]
forall (m :: * -> *) a.
MonadError String m =>
String -> (Cursor -> [a]) -> [Cursor] -> m [a]
findSome String
"IDPSSODescriptor element" (Axis
forall node. Axis node
descendant Axis -> Axis -> Axis
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Axis
element Name
"{urn:oasis:names:tc:SAML:2.0:metadata}IDPSSODescriptor")
                  ([Cursor] -> m [Cursor])
-> ([Cursor] -> m Text) -> [Cursor] -> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> Axis -> [Cursor] -> m [Cursor]
forall (m :: * -> *) a.
MonadError String m =>
String -> (Cursor -> [a]) -> [Cursor] -> m [a]
findSome String
"SingleSignOnService element" (Axis
forall node. Axis node
child Axis -> Axis -> Axis
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Axis
element Name
"{urn:oasis:names:tc:SAML:2.0:metadata}SingleSignOnService")
                  ([Cursor] -> m [Cursor])
-> ([Cursor] -> m Text) -> [Cursor] -> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> Axis -> [Cursor] -> m [Cursor]
forall (m :: * -> *) a.
MonadError String m =>
String -> (Cursor -> [a]) -> [Cursor] -> m [a]
findSome String
forall {a}. IsString a => a
bindingDescr (Name -> CI Text -> Axis
attributeIsCI Name
"Binding" CI Text
"urn:oasis:names:tc:SAML:2.0:bindings:HTTP-POST")
                  ([Cursor] -> m [Cursor])
-> ([Cursor] -> m Text) -> [Cursor] -> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> [Cursor] -> m Cursor
forall (m :: * -> *) a. MonadError String m => String -> [a] -> m a
getSingleton String
forall {a}. IsString a => a
bindingDescr
                  ([Cursor] -> m Cursor) -> (Cursor -> m Text) -> [Cursor] -> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Cursor -> [Text]
attribute Name
"Location"
                  (Cursor -> [Text]) -> ([Text] -> m Text) -> Cursor -> m Text
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> String -> [Text] -> m Text
forall (m :: * -> *) a. MonadError String m => String -> [a] -> m a
getSingleton String
"\"Location\""
              )
    case Text -> Either String URI
forall (m :: * -> *). MonadError String m => Text -> m URI
parseURI' Text
target of
      Right URI
uri -> URI -> m URI
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
uri
      Left String
msg -> String -> m URI
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m URI) -> String -> m URI
forall a b. (a -> b) -> a -> b
$ String
"bad request uri: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg

  let cursorToKeyInfo :: (MonadError String m) => Cursor -> m X509.SignedCertificate
      cursorToKeyInfo :: forall (m :: * -> *).
MonadError String m =>
Cursor -> m SignedCertificate
cursorToKeyInfo = \case
        (Cursor -> Node
forall node. Cursor node -> node
node -> NodeElement Element
key) -> Bool -> LT -> m SignedCertificate
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Bool -> LT -> m SignedCertificate
parseKeyInfo Bool
False (LT -> m SignedCertificate)
-> (Element -> LT) -> Element -> m SignedCertificate
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RenderSettings -> Document -> LT
renderText RenderSettings
forall a. Default a => a
def (Document -> LT) -> (Element -> Document) -> Element -> LT
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Element -> Document
mkDocument (Element -> m SignedCertificate) -> Element -> m SignedCertificate
forall a b. (a -> b) -> a -> b
$ Element
key
        Cursor
bad -> String -> m SignedCertificate
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m SignedCertificate) -> String -> m SignedCertificate
forall a b. (a -> b) -> a -> b
$ String
"unexpected: could not parse x509 cert: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Cursor -> String
forall a. Show a => a -> String
show Cursor
bad
  -- some metadata documents really have more than one of these.  since there is no way of knowing
  -- which one is correct, we accept all of them.
  NonEmpty SignedCertificate
_edCertAuthnResponse :: NonEmpty X509.SignedCertificate <- do
    let cur :: Cursor
cur = Node -> Cursor
fromNode (Node -> Cursor) -> Node -> Cursor
forall a b. (a -> b) -> a -> b
$ Element -> Node
NodeElement Element
el
        target :: [Cursor]
        target :: [Cursor]
target =
          Cursor
cur
            Cursor -> Axis -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Name -> Axis
element Name
"{urn:oasis:names:tc:SAML:2.0:metadata}IDPSSODescriptor"
            Axis -> Axis -> Axis
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Axis
element Name
"{urn:oasis:names:tc:SAML:2.0:metadata}KeyDescriptor"
            Axis -> Axis -> Axis
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Name -> Text -> Axis
attributeIsNot Name
"use" Text
"encryption" -- [4/2.4.1.1]
            Axis -> Axis -> Axis
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Axis
element Name
"{http://www.w3.org/2000/09/xmldsig#}KeyInfo"
    (Cursor -> m SignedCertificate
forall (m :: * -> *).
MonadError String m =>
Cursor -> m SignedCertificate
cursorToKeyInfo (Cursor -> m SignedCertificate)
-> [Cursor] -> m [SignedCertificate]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [Cursor]
target) m [SignedCertificate]
-> ([SignedCertificate] -> m (NonEmpty SignedCertificate))
-> m (NonEmpty SignedCertificate)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      [] -> String -> m (NonEmpty SignedCertificate)
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m (NonEmpty SignedCertificate))
-> String -> m (NonEmpty SignedCertificate)
forall a b. (a -> b) -> a -> b
$ String
"could not find any AuthnResponse signature certificates."
      (SignedCertificate
x : [SignedCertificate]
xs) -> NonEmpty SignedCertificate -> m (NonEmpty SignedCertificate)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty SignedCertificate -> m (NonEmpty SignedCertificate))
-> NonEmpty SignedCertificate -> m (NonEmpty SignedCertificate)
forall a b. (a -> b) -> a -> b
$ SignedCertificate
x SignedCertificate
-> [SignedCertificate] -> NonEmpty SignedCertificate
forall a. a -> [a] -> NonEmpty a
:| [SignedCertificate]
xs
  IdPMetadata -> m IdPMetadata
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IdPMetadata {NonEmpty SignedCertificate
URI
Issuer
_edIssuer :: Issuer
_edRequestURI :: URI
_edCertAuthnResponse :: NonEmpty SignedCertificate
_edCertAuthnResponse :: NonEmpty SignedCertificate
_edRequestURI :: URI
_edIssuer :: Issuer
..}

renderIdPMetadata :: (HasCallStack) => IdPMetadata -> Element
renderIdPMetadata :: HasCallStack => IdPMetadata -> Element
renderIdPMetadata (IdPMetadata Issuer
issuer URI
requri (NonEmpty SignedCertificate -> [SignedCertificate]
forall a. NonEmpty a -> [a]
NL.toList -> [SignedCertificate]
certs)) = HasCallStack => [Node] -> Element
[Node] -> Element
nodesToElem ([Node] -> Element) -> [Node] -> Element
forall a b. (a -> b) -> a -> b
$ HasCallStack => [Node] -> [Node]
[Node] -> [Node]
repairNamespaces [Node]
nodes
  where
    nodes :: [Node]
nodes =
      [xml|
      <EntityDescriptor
        ID="#{descID}"
        entityID="#{entityID}"
        xmlns="urn:oasis:names:tc:SAML:2.0:metadata">
          <IDPSSODescriptor protocolSupportEnumeration="urn:oasis:names:tc:SAML:2.0:protocol">
              <KeyDescriptor use="signing">
                  ^{certNodes}
              <SingleSignOnService Binding="urn:oasis:names:tc:SAML:2.0:bindings:HTTP-POST" Location="#{authnUrl}">
      |]
    descID :: a
descID = a
"_0c29ba62-a541-11e8-8042-873ef87bdcba"
    entityID :: Text
entityID = URI -> Text
renderURI (URI -> Text) -> URI -> Text
forall a b. (a -> b) -> a -> b
$ Issuer
issuer Issuer -> Getting URI Issuer URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI Issuer URI
Iso' Issuer URI
fromIssuer
    authnUrl :: Text
authnUrl = URI -> Text
renderURI (URI -> Text) -> URI -> Text
forall a b. (a -> b) -> a -> b
$ URI
requri
    certNodes :: [Node]
certNodes = [[Node]] -> [Node]
forall a. Monoid a => [a] -> a
mconcat ([[Node]] -> [Node]) -> [[Node]] -> [Node]
forall a b. (a -> b) -> a -> b
$ SignedCertificate -> [Node]
mkCertNode (SignedCertificate -> [Node]) -> [SignedCertificate] -> [[Node]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SignedCertificate]
certs
    mkCertNode :: SignedCertificate -> [Node]
mkCertNode =
      (SomeException -> [Node])
-> (Document -> [Node]) -> Either SomeException Document -> [Node]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> [Node]
forall a. HasCallStack => String -> a
error (String -> [Node])
-> (SomeException -> String) -> SomeException -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SomeException -> String
forall a. Show a => a -> String
show) (HasCallStack => Document -> [Node]
Document -> [Node]
docToNodes)
        (Either SomeException Document -> [Node])
-> (SignedCertificate -> Either SomeException Document)
-> SignedCertificate
-> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ParseSettings -> ByteString -> Either SomeException Document
parseLBS ParseSettings
forall a. Default a => a
def
        (ByteString -> Either SomeException Document)
-> (SignedCertificate -> ByteString)
-> SignedCertificate
-> Either SomeException Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LT -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs
        (LT -> ByteString)
-> (SignedCertificate -> LT) -> SignedCertificate -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => SignedCertificate -> LT
SignedCertificate -> LT
renderKeyInfo

----------------------------------------------------------------------
-- instances

instance HasXMLImport AuthnRequest HX.AuthnRequest where
  importXml :: forall (m :: * -> *).
MonadError String m =>
AuthnRequest -> m AuthnRequest
importXml = AuthnRequest -> m AuthnRequest
forall (m :: * -> *).
MonadError String m =>
AuthnRequest -> m AuthnRequest
importAuthnRequest
  exportXml :: AuthnRequest -> AuthnRequest
exportXml = AuthnRequest -> AuthnRequest
exportAuthnRequest

instance HasXML AuthnRequest where
  parse :: forall (m :: * -> *).
MonadError String m =>
[Node] -> m AuthnRequest
parse = (AuthnRequest -> m AuthnRequest) -> [Node] -> m AuthnRequest
forall (m :: * -> *) them us.
(HasCallStack, MonadError String m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse AuthnRequest -> m AuthnRequest
forall (m :: * -> *).
MonadError String m =>
AuthnRequest -> m AuthnRequest
importAuthnRequest

instance HasXMLRoot AuthnRequest where
  renderRoot :: AuthnRequest -> Element
renderRoot = (AuthnRequest -> AuthnRequest) -> AuthnRequest -> Element
forall them us.
(HasCallStack, XmlPickler them, HasXMLRoot us) =>
(us -> them) -> us -> Element
wrapRenderRoot AuthnRequest -> AuthnRequest
exportAuthnRequest

instance HasXMLImport NameIdPolicy HX.NameIDPolicy where
  importXml :: forall (m :: * -> *).
MonadError String m =>
NameIDPolicy -> m NameIdPolicy
importXml = NameIDPolicy -> m NameIdPolicy
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
NameIDPolicy -> m NameIdPolicy
importNameIDPolicy
  exportXml :: NameIdPolicy -> NameIDPolicy
exportXml = HasCallStack => NameIdPolicy -> NameIDPolicy
NameIdPolicy -> NameIDPolicy
exportNameIDPolicy

instance HasXMLImport AuthnResponse HX.Response where
  importXml :: forall (m :: * -> *).
MonadError String m =>
Response -> m AuthnResponse
importXml = Response -> m AuthnResponse
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Response -> m AuthnResponse
importAuthnResponse
  exportXml :: AuthnResponse -> Response
exportXml = HasCallStack => AuthnResponse -> Response
AuthnResponse -> Response
exportAuthnResponse

instance HasXML AuthnResponse where
  parse :: forall (m :: * -> *).
MonadError String m =>
[Node] -> m AuthnResponse
parse = (Response -> m AuthnResponse) -> [Node] -> m AuthnResponse
forall (m :: * -> *) them us.
(HasCallStack, MonadError String m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse Response -> m AuthnResponse
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Response -> m AuthnResponse
importAuthnResponse

instance HasXMLRoot AuthnResponse where
  renderRoot :: AuthnResponse -> Element
renderRoot = (AuthnResponse -> Response) -> AuthnResponse -> Element
forall them us.
(HasCallStack, XmlPickler them, HasXMLRoot us) =>
(us -> them) -> us -> Element
wrapRenderRoot HasCallStack => AuthnResponse -> Response
AuthnResponse -> Response
exportAuthnResponse

instance HasXMLImport Assertion (HX.PossiblyEncrypted HX.Assertion) where
  importXml :: forall (m :: * -> *).
MonadError String m =>
PossiblyEncrypted Assertion -> m Assertion
importXml = PossiblyEncrypted Assertion -> m Assertion
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
PossiblyEncrypted Assertion -> m Assertion
importPossiblyEncryptedAssertion
  exportXml :: Assertion -> PossiblyEncrypted Assertion
exportXml = HasCallStack => Assertion -> PossiblyEncrypted Assertion
Assertion -> PossiblyEncrypted Assertion
exportPossiblyEncryptedAssertion

instance HasXML Assertion where
  parse :: forall (m :: * -> *). MonadError String m => [Node] -> m Assertion
parse = (Assertion -> m Assertion) -> [Node] -> m Assertion
forall (m :: * -> *) them us.
(HasCallStack, MonadError String m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse Assertion -> m Assertion
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Assertion -> m Assertion
importAssertion

instance HasXMLRoot Assertion where
  renderRoot :: Assertion -> Element
renderRoot = (Assertion -> Assertion) -> Assertion -> Element
forall them us.
(HasCallStack, XmlPickler them, HasXMLRoot us) =>
(us -> them) -> us -> Element
wrapRenderRoot HasCallStack => Assertion -> Assertion
Assertion -> Assertion
exportAssertion

instance HasXML Subject where
  parse :: forall (m :: * -> *). MonadError String m => [Node] -> m Subject
parse = (Subject -> m Subject) -> [Node] -> m Subject
forall (m :: * -> *) them us.
(HasCallStack, MonadError String m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse Subject -> m Subject
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Subject -> m Subject
importSubject
  render :: Subject -> [Node]
render = (Subject -> Subject) -> Subject -> [Node]
forall them us.
(HasCallStack, XmlPickler them, HasXML us) =>
(us -> them) -> us -> [Node]
wrapRender HasCallStack => Subject -> Subject
Subject -> Subject
exportSubject

instance HasXMLImport Subject HX.Subject where
  importXml :: forall (m :: * -> *). MonadError String m => Subject -> m Subject
importXml = Subject -> m Subject
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Subject -> m Subject
importSubject
  exportXml :: Subject -> Subject
exportXml = HasCallStack => Subject -> Subject
Subject -> Subject
exportSubject

instance HasXMLImport SubjectConfirmationData HX.SubjectConfirmationData where
  importXml :: forall (m :: * -> *).
MonadError String m =>
SubjectConfirmationData -> m SubjectConfirmationData
importXml = SubjectConfirmationData -> m SubjectConfirmationData
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SubjectConfirmationData -> m SubjectConfirmationData
importSubjectConfirmationData
  exportXml :: SubjectConfirmationData -> SubjectConfirmationData
exportXml = HasCallStack => SubjectConfirmationData -> SubjectConfirmationData
SubjectConfirmationData -> SubjectConfirmationData
exportSubjectConfirmationData

instance HasXMLImport IP HX.IP where
  importXml :: forall (m :: * -> *). MonadError String m => String -> m IP
importXml = String -> m IP
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
String -> m IP
importIP
  exportXml :: IP -> String
exportXml = HasCallStack => IP -> String
IP -> String
exportIP

instance HasXMLImport Conditions HX.Conditions where
  importXml :: forall (m :: * -> *).
MonadError String m =>
Conditions -> m Conditions
importXml = Conditions -> m Conditions
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Conditions -> m Conditions
importConditions
  exportXml :: Conditions -> Conditions
exportXml = HasCallStack => Conditions -> Conditions
Conditions -> Conditions
exportConditions

instance HasXML Conditions where
  parse :: forall (m :: * -> *). MonadError String m => [Node] -> m Conditions
parse = (Conditions -> m Conditions) -> [Node] -> m Conditions
forall (m :: * -> *) them us.
(HasCallStack, MonadError String m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse Conditions -> m Conditions
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Conditions -> m Conditions
importConditions
  render :: Conditions -> [Node]
render = (Conditions -> Conditions) -> Conditions -> [Node]
forall them us.
(HasCallStack, XmlPickler them, HasXML us) =>
(us -> them) -> us -> [Node]
wrapRender HasCallStack => Conditions -> Conditions
Conditions -> Conditions
exportConditions

instance HasXMLImport (Maybe Statement) HX.Statement where
  importXml :: forall (m :: * -> *).
MonadError String m =>
Statement -> m (Maybe Statement)
importXml = Statement -> m (Maybe Statement)
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Statement -> m (Maybe Statement)
importStatement
  exportXml :: Maybe Statement -> Statement
exportXml = HasCallStack => Statement -> Statement
Statement -> Statement
exportStatement (Statement -> Statement)
-> (Maybe Statement -> Statement) -> Maybe Statement -> Statement
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Maybe Statement -> Statement
forall a. HasCallStack => a
undefined :: Maybe Statement -> Statement)

instance HasXMLImport Locality HX.SubjectLocality where
  importXml :: forall (m :: * -> *).
MonadError String m =>
SubjectLocality -> m Locality
importXml = SubjectLocality -> m Locality
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SubjectLocality -> m Locality
importLocality
  exportXml :: Locality -> SubjectLocality
exportXml = HasCallStack => Locality -> SubjectLocality
Locality -> SubjectLocality
exportLocality

instance HasXMLImport (ID a) HX.ID where
  importXml :: forall (m :: * -> *). MonadError String m => String -> m (ID a)
importXml = String -> m (ID a)
forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError String m) =>
String -> m (ID a)
importID
  exportXml :: ID a -> String
exportXml = ID a -> String
forall {k} (a :: k). HasCallStack => ID a -> String
exportID

instance HasXMLImport NameID HX.NameID where
  importXml :: forall (m :: * -> *). MonadError String m => NameID -> m NameID
importXml = NameID -> m NameID
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
NameID -> m NameID
importNameID
  exportXml :: NameID -> NameID
exportXml = NameID -> NameID
exportNameID

instance HasXML NameID where
  parse :: forall (m :: * -> *). MonadError String m => [Node] -> m NameID
parse = (NameID -> m NameID) -> [Node] -> m NameID
forall (m :: * -> *) them us.
(HasCallStack, MonadError String m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse NameID -> m NameID
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
NameID -> m NameID
importNameID
  render :: NameID -> [Node]
render = (NameID -> NameID) -> NameID -> [Node]
forall them us.
(HasCallStack, XmlPickler them, HasXML us) =>
(us -> them) -> us -> [Node]
wrapRender NameID -> NameID
exportNameID

instance HasXMLImport () HX.SAMLVersion where
  importXml :: forall (m :: * -> *). MonadError String m => SAMLVersion -> m ()
importXml = SAMLVersion -> m ()
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
SAMLVersion -> m ()
importVersion
  exportXml :: () -> SAMLVersion
exportXml () = SAMLVersion
HasCallStack => SAMLVersion
exportVersion

instance HasXMLImport Time HX.DateTime where
  importXml :: forall (m :: * -> *). MonadError String m => UTCTime -> m Time
importXml = UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
UTCTime -> m Time
importTime
  exportXml :: Time -> UTCTime
exportXml = HasCallStack => Time -> UTCTime
Time -> UTCTime
exportTime

instance HasXMLImport URI HX.URI where
  importXml :: forall (m :: * -> *). MonadError String m => AnyURI -> m URI
importXml = AnyURI -> m URI
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
AnyURI -> m URI
importURI
  exportXml :: URI -> AnyURI
exportXml = HasCallStack => URI -> AnyURI
URI -> AnyURI
exportURI

instance HasXMLImport Status HX.Status where
  importXml :: forall (m :: * -> *). MonadError String m => Status -> m Status
importXml = Status -> m Status
forall (m :: * -> *). (HasCallStack, Monad m) => Status -> m Status
importStatus
  exportXml :: Status -> Status
exportXml = HasCallStack => Status -> Status
Status -> Status
exportStatus

instance HasXMLImport Issuer HX.Issuer where
  importXml :: forall (m :: * -> *). MonadError String m => Issuer -> m Issuer
importXml = Issuer -> m Issuer
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Issuer -> m Issuer
importIssuer
  exportXml :: Issuer -> Issuer
exportXml = HasCallStack => Issuer -> Issuer
Issuer -> Issuer
exportIssuer

instance HasXML Issuer where
  parse :: forall (m :: * -> *). MonadError String m => [Node] -> m Issuer
parse = (Issuer -> m Issuer) -> [Node] -> m Issuer
forall (m :: * -> *) them us.
(HasCallStack, MonadError String m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse Issuer -> m Issuer
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Issuer -> m Issuer
importIssuer
  render :: Issuer -> [Node]
render = (Issuer -> Issuer) -> Issuer -> [Node]
forall them us.
(HasCallStack, XmlPickler them, HasXML us) =>
(us -> them) -> us -> [Node]
wrapRender HasCallStack => Issuer -> Issuer
Issuer -> Issuer
exportIssuer

instance HasXML SPMetadata where
  parse :: forall (m :: * -> *). MonadError String m => [Node] -> m SPMetadata
parse = (Metadata -> m SPMetadata) -> [Node] -> m SPMetadata
forall (m :: * -> *) them us.
(HasCallStack, MonadError String m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse Metadata -> m SPMetadata
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Metadata -> m SPMetadata
importSPMetadata

instance HasXMLRoot SPMetadata where
  renderRoot :: SPMetadata -> Element
renderRoot = (SPMetadata -> Metadata) -> SPMetadata -> Element
forall them us.
(HasCallStack, XmlPickler them, HasXMLRoot us) =>
(us -> them) -> us -> Element
wrapRenderRoot HasCallStack => SPMetadata -> Metadata
SPMetadata -> Metadata
exportSPMetadata

instance HasXML IdPMetadata where
  parse :: forall (m :: * -> *).
MonadError String m =>
[Node] -> m IdPMetadata
parse [NodeElement Element
el] = Element -> m IdPMetadata
forall (m :: * -> *).
MonadError String m =>
Element -> m IdPMetadata
parseIdPMetadata Element
el
  parse [Node]
bad = Proxy IdPMetadata -> [Node] -> m IdPMetadata
forall a b c (m :: * -> *).
(HasCallStack, Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @IdPMetadata) [Node]
bad

instance HasXMLRoot IdPMetadata where
  renderRoot :: IdPMetadata -> Element
renderRoot = HasCallStack => IdPMetadata -> Element
IdPMetadata -> Element
renderIdPMetadata