{-# 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,
    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 qualified Data.CaseInsensitive as CI
import Data.EitherR
import Data.Foldable (toList)
import Data.Kind (Type)
import qualified Data.List as List
import Data.List.NonEmpty as NL (NonEmpty ((:|)), nonEmpty)
import qualified Data.List.NonEmpty as NL
import qualified Data.Map as Map
import Data.Maybe
import Data.String.Conversions
import qualified Data.Text as ST
import Data.Time
import Data.Typeable (Proxy (Proxy), Typeable)
import qualified Data.X509 as X509
import GHC.Stack
import qualified Network.URI as HS
import qualified SAML2.Bindings.Identifiers as HS
import qualified SAML2.Core as HS
import qualified SAML2.Metadata.Metadata as HS
import qualified SAML2.Profiles as HS
import SAML2.Util
import SAML2.WebSSO.SP
import SAML2.WebSSO.Types
import qualified SAML2.WebSSO.Types.Email as Email
import qualified SAML2.XML as HS
import qualified SAML2.XML as HX
import qualified SAML2.XML.Schema.Datatypes as HX (Boolean, Duration, UnsignedShort)
import qualified SAML2.XML.Signature.Types as HX (Signature)
import Text.Hamlet.XML
import Text.XML
import Text.XML.Cursor
import Text.XML.DSig (parseKeyInfo, renderKeyInfo)
import qualified Text.XML.HXT.Arrow.Pickle.Xml as HS
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 [Char] 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 ([Char] -> m a
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m a)
-> (SomeException -> [Char]) -> 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 -> [Char]
show @SomeException) Document -> m a
forall a (m :: * -> *).
(HasXML a, MonadError [Char] 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 = [Char] -> Document
forall a. HasCallStack => [Char] -> a
error ([Char] -> Document) -> [Char] -> Document
forall a b. (a -> b) -> a -> b
$ [Char]
"encodeElem: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Node] -> [Char]
forall a. Show a => a -> [Char]
show [Node]
bad

decodeElem :: forall a m. (HasXML a, MonadError String m) => LT -> m a
decodeElem :: forall a (m :: * -> *).
(HasXML a, MonadError [Char] 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 ([Char] -> m a
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m a)
-> (SomeException -> [Char]) -> 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 -> [Char]
show @SomeException) Document -> m a
forall a (m :: * -> *).
(HasXML a, MonadError [Char] 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 [Char] m) =>
Document -> m a
parseFromDocument Document
doc = [Node] -> m a
forall a (m :: * -> *).
(HasXML a, MonadError [Char] m) =>
[Node] -> m a
forall (m :: * -> *). MonadError [Char] m => [Node] -> m a
parse [Element -> Node
NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ Document -> Element
documentRoot 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 [Char] 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 :: * -> *).
(Typeable a, Show b, MonadError [Char] 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 => [Char] -> Time
unsafeReadTime [Char]
s = ([Char] -> Time) -> (Time -> Time) -> Either [Char] Time -> Time
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> [Char] -> Time
forall a. HasCallStack => [Char] -> a
error ([Char]
"decodeTime: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s)) Time -> Time
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Either [Char] Time -> Time) -> Either [Char] Time -> Time
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] Time
forall (m :: * -> *) s.
(MonadError [Char] m, ConvertibleStrings s [Char]) =>
s -> m Time
decodeTime [Char]
s

decodeTime :: (MonadError String m, ConvertibleStrings s String) => s -> m Time
decodeTime :: forall (m :: * -> *) s.
(MonadError [Char] m, ConvertibleStrings s [Char]) =>
s -> m Time
decodeTime (s -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs -> [Char]
s) = case Bool -> TimeLocale -> [Char] -> [Char] -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [Char] -> [Char] -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale [Char]
timeFormat [Char]
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 -> ([Char], [Char]) -> m Time
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Time) ([Char]
s, [Char]
timeFormat)

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

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

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

explainDeniedReason :: DeniedReason -> ST
explainDeniedReason :: DeniedReason -> Text
explainDeniedReason = \case
  DeniedReason
DeniedStatusFailure -> Text
"status: failure"
  DeniedBadUserRefs [Char]
msg -> Text
"bad user refs: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs [Char]
msg
  DeniedBadInResponseTos [Char]
msg -> Text
"bad InResponseTo attribute(s): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs [Char]
msg
  DeniedIssueInstantNotInPast Time
ts Time
now ->
    Text -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
      Text
"IssueInstant in Header 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
  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
  DeniedBadDestination [Char]
weare [Char]
theywant -> [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"bad Destination: we are " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
weare [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
", they expected " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
theywant
  DeniedBadRecipient [Char]
weare [Char]
theywant -> [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"bad Recipient: we are " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
weare [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
", they expected " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
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
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ 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, HS.XmlPickler them, HasXML us, Typeable us) =>
  (them -> m us) ->
  [Node] ->
  m us
wrapParse :: forall (m :: * -> *) them us.
(HasCallStack, MonadError [Char] m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse them -> m us
imprt [NodeElement Element
el] =
  ([Char] -> m us) -> (them -> m us) -> Either [Char] them -> m us
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Proxy us -> ([Char], Element) -> m us
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @us) (([Char], Element) -> m us)
-> ([Char] -> ([Char], Element)) -> [Char] -> m us
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
el)) them -> m us
imprt (Either [Char] them -> m us) -> Either [Char] them -> m us
forall a b. (a -> b) -> a -> b
$
    ByteString -> Either [Char] them
forall a. XmlPickler a => ByteString -> Either [Char] a
HS.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 = [Char] -> m us
forall a. HasCallStack => [Char] -> a
error ([Char] -> m us) -> [Char] -> m us
forall a b. (a -> b) -> a -> b
$ [Char]
"internal error: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Node] -> [Char]
forall a. Show a => a -> [Char]
show [Node]
badxml

wrapRender ::
  forall them us.
  (HasCallStack, HS.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
HS.samlToXML (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 -> [Char] -> [Node]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Node]) -> [Char] -> [Node]
forall a b. (a -> b) -> a -> b
$ (Proxy us, SomeException) -> [Char]
forall a. Show a => a -> [Char]
show (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @us, SomeException
msg)

wrapRenderRoot ::
  forall them us.
  (HasCallStack, HS.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
HS.samlToXML (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 -> [Char] -> Element
forall a. HasCallStack => [Char] -> a
error ([Char] -> Element) -> [Char] -> Element
forall a b. (a -> b) -> a -> b
$ (Proxy us, SomeException) -> [Char]
forall a. Show a => a -> [Char]
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 => HS.AuthnRequest -> m AuthnRequest
importAuthnRequest :: forall (m :: * -> *).
MonadError [Char] m =>
AuthnRequest -> m AuthnRequest
importAuthnRequest AuthnRequest
req = do
  let proto :: ProtocolType
proto = RequestAbstractType -> ProtocolType
HS.requestProtocol (RequestAbstractType -> ProtocolType)
-> RequestAbstractType -> ProtocolType
forall a b. (a -> b) -> a -> b
$ AuthnRequest -> RequestAbstractType
HS.authnRequest AuthnRequest
req
  () <- SAMLVersion -> m ()
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
SAMLVersion -> m ()
importVersion (SAMLVersion -> m ()) -> SAMLVersion -> m ()
forall a b. (a -> b) -> a -> b
$ ProtocolType -> SAMLVersion
HS.protocolVersion ProtocolType
proto
  ID AuthnRequest
_rqID <- [Char] -> m (ID AuthnRequest)
forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError [Char] m) =>
[Char] -> m (ID a)
importID ([Char] -> m (ID AuthnRequest)) -> [Char] -> m (ID AuthnRequest)
forall a b. (a -> b) -> a -> b
$ ProtocolType -> [Char]
HS.protocolID ProtocolType
proto
  Time
_rqIssueInstant <- UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
UTCTime -> m Time
importTime (UTCTime -> m Time) -> UTCTime -> m Time
forall a b. (a -> b) -> a -> b
$ ProtocolType -> UTCTime
HS.protocolIssueInstant ProtocolType
proto
  Issuer
_rqIssuer <- Maybe Issuer -> m Issuer
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
Maybe Issuer -> m Issuer
importRequiredIssuer (Maybe Issuer -> m Issuer) -> Maybe Issuer -> m Issuer
forall a b. (a -> b) -> a -> b
$ ProtocolType -> Maybe Issuer
HS.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 [Char] 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
HS.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 [Char] m) =>
AnyURI -> m URI
importURI (ProtocolType -> Maybe AnyURI
HS.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 -> [Char] -> m ()
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @AuthnRequest) ([Char]
"protocol destination not allowed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> URI -> [Char]
forall a. Show a => a -> [Char]
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
_rqID :: ID AuthnRequest
_rqIssueInstant :: Time
_rqIssuer :: Issuer
_rqNameIDPolicy :: Maybe NameIdPolicy
..}

exportAuthnRequest :: AuthnRequest -> HS.AuthnRequest
exportAuthnRequest :: AuthnRequest -> AuthnRequest
exportAuthnRequest AuthnRequest
req =
  (ProtocolType -> AuthnRequest
defAuthnRequest ProtocolType
proto)
    { HS.authnRequestNameIDPolicy = exportNameIDPolicy <$> req ^. rqNameIDPolicy
    }
  where
    proto :: ProtocolType
proto =
      ([Char] -> UTCTime -> ProtocolType
defProtocolType (ID AuthnRequest -> [Char]
forall {k} (a :: k). HasCallStack => ID a -> [Char]
exportID (ID AuthnRequest -> [Char]) -> ID AuthnRequest -> [Char]
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))
        { HS.protocolVersion = exportVersion,
          HS.protocolIssuer = exportRequiredIssuer $ req ^. rqIssuer,
          HS.protocolDestination = Nothing
        }

importNameIDPolicy :: (HasCallStack, MonadError String m) => HS.NameIDPolicy -> m NameIdPolicy
importNameIDPolicy :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
NameIDPolicy -> m NameIdPolicy
importNameIDPolicy NameIDPolicy
nip = do
  NameIDFormat
_nidFormat <- IdentifiedURI NameIDFormat -> m NameIDFormat
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
IdentifiedURI NameIDFormat -> m NameIDFormat
importNameIDFormat (IdentifiedURI NameIDFormat -> m NameIDFormat)
-> IdentifiedURI NameIDFormat -> m NameIDFormat
forall a b. (a -> b) -> a -> b
$ NameIDPolicy -> IdentifiedURI NameIDFormat
HS.nameIDPolicyFormat NameIDPolicy
nip
  let _nidSpNameQualifier :: Maybe XmlText
_nidSpNameQualifier = Text -> XmlText
mkXmlText (Text -> XmlText) -> ([Char] -> Text) -> [Char] -> XmlText
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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> XmlText) -> Maybe [Char] -> Maybe XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameIDPolicy -> Maybe [Char]
HS.nameIDPolicySPNameQualifier NameIDPolicy
nip
      _nidAllowCreate :: Bool
_nidAllowCreate = NameIDPolicy -> Bool
HS.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 XmlText -> Bool -> NameIdPolicy
NameIdPolicy NameIDFormat
_nidFormat Maybe XmlText
_nidSpNameQualifier Bool
_nidAllowCreate

exportNameIDPolicy :: HasCallStack => NameIdPolicy -> HS.NameIDPolicy
exportNameIDPolicy :: HasCallStack => NameIdPolicy -> NameIDPolicy
exportNameIDPolicy NameIdPolicy
nip =
  HS.NameIDPolicy
    { nameIDPolicyFormat :: IdentifiedURI NameIDFormat
HS.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 [Char]
HS.nameIDPolicySPNameQualifier = Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (XmlText -> Text) -> XmlText -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> [Char]) -> Maybe XmlText -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameIdPolicy
nip NameIdPolicy
-> Getting (Maybe XmlText) NameIdPolicy (Maybe XmlText)
-> Maybe XmlText
forall s a. s -> Getting a s a -> a
^. Getting (Maybe XmlText) NameIdPolicy (Maybe XmlText)
Lens' NameIdPolicy (Maybe XmlText)
nidSpNameQualifier,
      nameIDPolicyAllowCreate :: Bool
HS.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) => HS.IdentifiedURI HS.NameIDFormat -> m NameIDFormat
importNameIDFormat :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
IdentifiedURI NameIDFormat -> m NameIDFormat
importNameIDFormat = \case
  HS.Identified NameIDFormat
HS.NameIDFormatUnspecified -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFUnspecified
  HS.Identified NameIDFormat
HS.NameIDFormatEmail -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFEmail
  HS.Identified NameIDFormat
HS.NameIDFormatX509 -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFX509
  HS.Identified NameIDFormat
HS.NameIDFormatWindows -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFWindows
  HS.Identified NameIDFormat
HS.NameIDFormatKerberos -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFKerberos
  HS.Identified NameIDFormat
HS.NameIDFormatEntity -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFEntity
  HS.Identified NameIDFormat
HS.NameIDFormatPersistent -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFPersistent
  HS.Identified NameIDFormat
HS.NameIDFormatTransient -> NameIDFormat -> m NameIDFormat
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameIDFormat
NameIDFTransient
  bad :: IdentifiedURI NameIDFormat
bad@(HS.Identified NameIDFormat
HS.NameIDFormatEncrypted) -> [Char] -> m NameIDFormat
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m NameIDFormat) -> [Char] -> m NameIDFormat
forall a b. (a -> b) -> a -> b
$ [Char]
"unsupported: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> IdentifiedURI NameIDFormat -> [Char]
forall a. Show a => a -> [Char]
show IdentifiedURI NameIDFormat
bad
  bad :: IdentifiedURI NameIDFormat
bad@(HS.Unidentified AnyURI
_) -> [Char] -> m NameIDFormat
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m NameIDFormat) -> [Char] -> m NameIDFormat
forall a b. (a -> b) -> a -> b
$ [Char]
"unsupported: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> IdentifiedURI NameIDFormat -> [Char]
forall a. Show a => a -> [Char]
show IdentifiedURI NameIDFormat
bad

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

importAuthnResponse :: (HasCallStack, MonadError String m) => HS.Response -> m AuthnResponse
importAuthnResponse :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
Response -> m AuthnResponse
importAuthnResponse Response
rsp = do
  let StatusResponseType
rsptyp :: HS.StatusResponseType = Response -> StatusResponseType
HS.response Response
rsp
      ProtocolType
proto :: HS.ProtocolType = StatusResponseType -> ProtocolType
HS.statusProtocol StatusResponseType
rsptyp
  () <- SAMLVersion -> m ()
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
SAMLVersion -> m ()
importVersion (SAMLVersion -> m ()) -> SAMLVersion -> m ()
forall a b. (a -> b) -> a -> b
$ ProtocolType -> SAMLVersion
HS.protocolVersion ProtocolType
proto
  ID AuthnResponse
_rspID <- [Char] -> m (ID AuthnResponse)
forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError [Char] m) =>
[Char] -> m (ID a)
importID ([Char] -> m (ID AuthnResponse)) -> [Char] -> m (ID AuthnResponse)
forall a b. (a -> b) -> a -> b
$ ProtocolType -> [Char]
HS.protocolID ProtocolType
proto
  Maybe (ID AuthnRequest)
_rspInRespTo <- ([Char] -> m (ID AuthnRequest)
forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError [Char] m) =>
[Char] -> m (ID a)
importID ([Char] -> m (ID AuthnRequest))
-> ([Char] -> [Char]) -> [Char] -> 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
. [Char] -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs) ([Char] -> m (ID AuthnRequest))
-> Maybe [Char] -> 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 [Char]
HS.statusInResponseTo StatusResponseType
rsptyp
  Time
_rspIssueInstant <- UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
UTCTime -> m Time
importTime (UTCTime -> m Time) -> UTCTime -> m Time
forall a b. (a -> b) -> a -> b
$ ProtocolType -> UTCTime
HS.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 [Char] 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
HS.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 [Char] 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
HS.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
HS.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 ([Char] -> m (NonEmpty Assertion)
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Char]
"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 [Char] m) =>
PossiblyEncrypted Assertion -> m Assertion
importAssertion (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]
HS.responseAssertions Response
rsp)
  -- ignore: @HS.protocolSignature proto :: Maybe SAML2.XML.Signature.Types.Signature@
  -- ignore: @HS.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
_rspID :: ID AuthnResponse
_rspInRespTo :: Maybe (ID AuthnRequest)
_rspIssueInstant :: Time
_rspDestination :: Maybe URI
_rspIssuer :: Maybe Issuer
_rspStatus :: Status
_rspPayload :: NonEmpty Assertion
..}

exportAuthnResponse :: HasCallStack => AuthnResponse -> HS.Response
exportAuthnResponse :: HasCallStack => AuthnResponse -> Response
exportAuthnResponse AuthnResponse
rsp =
  HS.Response
    { response :: StatusResponseType
HS.response =
        HS.StatusResponseType
          { statusProtocol :: ProtocolType
HS.statusProtocol =
              HS.ProtocolType
                { protocolID :: [Char]
HS.protocolID = ID AuthnResponse -> [Char]
forall {k} (a :: k). HasCallStack => ID a -> [Char]
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
HS.protocolVersion = SAMLVersion
HasCallStack => SAMLVersion
exportVersion,
                  protocolIssueInstant :: UTCTime
HS.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
HS.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
HS.protocolConsent = Consent -> IdentifiedURI Consent
forall b a. a -> Identified b a
HS.Identified Consent
HS.ConsentUnspecified, -- [1/8.4.1] there are no rules how to process the consent value.
                  protocolIssuer :: Maybe Issuer
HS.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 HS.Issuer,
                  protocolSignature :: Maybe Signature
HS.protocolSignature = Maybe Signature
forall a. Maybe a
Nothing,
                  protocolExtensions :: [Node]
HS.protocolExtensions = [],
                  relayState :: Maybe ByteString
HS.relayState = Maybe ByteString
forall a. Maybe a
Nothing
                },
            statusInResponseTo :: Maybe [Char]
HS.statusInResponseTo = ID AuthnRequest -> [Char]
forall {k} (a :: k). HasCallStack => ID a -> [Char]
exportID (ID AuthnRequest -> [Char])
-> Maybe (ID AuthnRequest) -> Maybe [Char]
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
HS.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]
HS.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
exportAssertion (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)
    }

importAssertion :: (HasCallStack, MonadError String m) => HS.PossiblyEncrypted HS.Assertion -> m Assertion
importAssertion :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
PossiblyEncrypted Assertion -> m Assertion
importAssertion bad :: PossiblyEncrypted Assertion
bad@(HS.SoEncrypted EncryptedElement Assertion
_) = Proxy Assertion -> PossiblyEncrypted Assertion -> m Assertion
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Assertion) PossiblyEncrypted Assertion
bad
importAssertion (HS.NotEncrypted Assertion
ass) = do
  () <- SAMLVersion -> m ()
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
SAMLVersion -> m ()
importVersion (SAMLVersion -> m ()) -> SAMLVersion -> m ()
forall a b. (a -> b) -> a -> b
$ Assertion -> SAMLVersion
HS.assertionVersion Assertion
ass
  ID Assertion
_assID <- [Char] -> m (ID Assertion)
forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError [Char] m) =>
[Char] -> m (ID a)
importID ([Char] -> m (ID Assertion)) -> [Char] -> m (ID Assertion)
forall a b. (a -> b) -> a -> b
$ Assertion -> [Char]
HS.assertionID Assertion
ass
  Time
_assIssueInstant <- UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
UTCTime -> m Time
importTime (UTCTime -> m Time) -> UTCTime -> m Time
forall a b. (a -> b) -> a -> b
$ Assertion -> UTCTime
HS.assertionIssueInstant Assertion
ass
  Issuer
_assIssuer <- Issuer -> m Issuer
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
Issuer -> m Issuer
importIssuer (Issuer -> m Issuer) -> Issuer -> m Issuer
forall a b. (a -> b) -> a -> b
$ Assertion -> Issuer
HS.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 [Char] 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
HS.assertionConditions Assertion
ass
  SubjectAndStatements
_assContents <- do
    Subject
subj <- Subject -> m Subject
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
Subject -> m Subject
importSubject (Subject -> m Subject) -> Subject -> m Subject
forall a b. (a -> b) -> a -> b
$ Assertion -> Subject
HS.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]
HS.assertionStatement Assertion
ass) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      Proxy Assertion -> [Char] -> m ()
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Assertion) ([Char]
"no statements" :: String)
    [Maybe Statement]
mstmts <- Statement -> m (Maybe Statement)
forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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]
HS.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 -> [Char] -> m SubjectAndStatements
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Assertion) ([Char]
"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
HS.assertionAdvice Assertion
ass) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Proxy Assertion -> Maybe Advice -> m ()
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Assertion) (Assertion -> Maybe Advice
HS.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
_assID :: ID Assertion
_assIssueInstant :: Time
_assIssuer :: Issuer
_assConditions :: Maybe Conditions
_assContents :: SubjectAndStatements
..}

exportAssertion :: HasCallStack => Assertion -> HS.PossiblyEncrypted HS.Assertion
exportAssertion :: HasCallStack => Assertion -> PossiblyEncrypted Assertion
exportAssertion Assertion
ass =
  Assertion -> PossiblyEncrypted Assertion
forall a. a -> PossiblyEncrypted a
HS.NotEncrypted
    HS.Assertion
      { assertionVersion :: SAMLVersion
HS.assertionVersion = SAMLVersion
HasCallStack => SAMLVersion
exportVersion,
        assertionID :: [Char]
HS.assertionID = ID Assertion -> [Char]
forall {k} (a :: k). HasCallStack => ID a -> [Char]
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
HS.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
HS.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
HS.assertionSignature = Maybe Signature
forall a. Maybe a
Nothing, -- signatures are handled before parsing.
        assertionSubject :: Subject
HS.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
HS.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
HS.assertionAdvice = Maybe Advice
forall a. Maybe a
Nothing,
        assertionStatement :: [Statement]
HS.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) => HS.Subject -> m Subject
importSubject :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
Subject -> m Subject
importSubject (HS.Subject Maybe (PossiblyEncrypted Identifier)
Nothing [SubjectConfirmation]
_) = Proxy Subject -> [Char] -> m Subject
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Subject) ([Char]
"Subject NameID is missing" :: String)
importSubject (HS.Subject (Just (HS.SoEncrypted EncryptedElement Identifier
_)) [SubjectConfirmation]
_) = Proxy Subject -> [Char] -> m Subject
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Subject) ([Char]
"encrypted subjects not supported" :: String)
importSubject (HS.Subject (Just (HS.NotEncrypted Identifier
sid)) [SubjectConfirmation]
scs) = case Identifier
sid of
  HS.IdentifierName NameID
nameid -> do
    NameID
nameid' <- NameID -> m NameID
forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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 [Char] 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@(HS.IdentifierBase BaseID [Node]
_baseid) -> do
    Proxy Subject -> [Char] -> m Subject
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Subject) ([Char]
"unsupported subject identifier: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Identifier -> [Char]
forall a. Show a => a -> [Char]
show Identifier
bad)

exportSubject :: (HasCallStack) => Subject -> HS.Subject
exportSubject :: HasCallStack => Subject -> Subject
exportSubject Subject
subj = Maybe (PossiblyEncrypted Identifier)
-> [SubjectConfirmation] -> Subject
HS.Subject (PossiblyEncrypted Identifier
-> Maybe (PossiblyEncrypted Identifier)
forall a. a -> Maybe a
Just (Identifier -> PossiblyEncrypted Identifier
forall a. a -> PossiblyEncrypted a
HS.NotEncrypted Identifier
sid)) [SubjectConfirmation]
scs
  where
    sid :: HS.Identifier
    sid :: Identifier
sid = NameID -> Identifier
HS.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 :: [HS.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 -> HS.SubjectConfirmation -> m SubjectConfirmation
importSubjectConfirmation :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
NameID -> SubjectConfirmation -> m SubjectConfirmation
importSubjectConfirmation = NameID -> SubjectConfirmation -> m SubjectConfirmation
forall {m :: * -> *}.
MonadError [Char] m =>
NameID -> SubjectConfirmation -> m SubjectConfirmation
go
  where
    go :: NameID -> SubjectConfirmation -> m SubjectConfirmation
go NameID
_ (HS.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
HS.Identified ConfirmationMethod
HS.ConfirmationMethodBearer =
        Proxy SubjectConfirmation -> [Char] -> m SubjectConfirmation
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SubjectConfirmation) ([Char]
"unsupported confirmation method: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> IdentifiedURI ConfirmationMethod -> [Char]
forall a. Show a => a -> [Char]
show IdentifiedURI ConfirmationMethod
meth)
    go NameID
uid (HS.SubjectConfirmation IdentifiedURI ConfirmationMethod
_ (Just (HS.NotEncrypted (HS.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
/= ([Char] -> ()) -> Either [Char] NameID -> Either () NameID
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL (() -> [Char] -> ()
forall a b. a -> b -> a
const ()) (NameID -> Either [Char] NameID
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
NameID -> m NameID
importNameID NameID
uid') =
        Proxy SubjectConfirmation -> [Char] -> m SubjectConfirmation
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SubjectConfirmation) ([Char]
"uid mismatch: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (NameID, NameID) -> [Char]
forall a. Show a => a -> [Char]
show (NameID
uid, NameID
uid'))
    go NameID
_ (HS.SubjectConfirmation IdentifiedURI ConfirmationMethod
_ (Just PossiblyEncrypted Identifier
bad) Maybe SubjectConfirmationData
_) =
      Proxy SubjectConfirmation -> [Char] -> m SubjectConfirmation
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @SubjectConfirmation) ([Char]
"unsupported identifier: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> PossiblyEncrypted Identifier -> [Char]
forall a. Show a => a -> [Char]
show PossiblyEncrypted Identifier
bad)
    go NameID
_ (HS.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 [Char] 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 -> HS.SubjectConfirmation
exportSubjectConfirmation :: HasCallStack => SubjectConfirmation -> SubjectConfirmation
exportSubjectConfirmation (SubjectConfirmation SubjectConfirmationMethod
SubjectConfirmationMethodBearer Maybe SubjectConfirmationData
scd) =
  IdentifiedURI ConfirmationMethod
-> Maybe (PossiblyEncrypted Identifier)
-> Maybe SubjectConfirmationData
-> SubjectConfirmation
HS.SubjectConfirmation (ConfirmationMethod -> IdentifiedURI ConfirmationMethod
forall b a. a -> Identified b a
HS.Identified ConfirmationMethod
HS.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) => HS.SubjectConfirmationData -> m SubjectConfirmationData
importSubjectConfirmationData :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
SubjectConfirmationData -> m SubjectConfirmationData
importSubjectConfirmationData (HS.SubjectConfirmationData Maybe UTCTime
notbefore (Just UTCTime
notonorafter) (Just AnyURI
recipient) Maybe [Char]
inresp Maybe [Char]
confaddr [KeyInfo]
_ [Node]
_) =
  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 [Char] 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 [Char] 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 [Char] 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
<*> [Char] -> m (ID AuthnRequest)
forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError [Char] m) =>
[Char] -> m (ID a)
importID ([Char] -> m (ID AuthnRequest))
-> Maybe [Char] -> 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 [Char]
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
<*> [Char] -> m IP
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
[Char] -> m IP
importIP ([Char] -> m IP) -> Maybe [Char] -> 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 [Char]
confaddr
-- ignore: 'HS.subjectConfirmationKeyInfo' (this is only required for holder of key subjects
-- [3/3.1], [1/2.4.1.2], [1/2.4.1.4])
-- ignore: 'HS.subjectConfirmationXML' (there is nothing we can assume about it's semantics)

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

exportSubjectConfirmationData :: (HasCallStack) => SubjectConfirmationData -> HS.SubjectConfirmationData
exportSubjectConfirmationData :: HasCallStack => SubjectConfirmationData -> SubjectConfirmationData
exportSubjectConfirmationData SubjectConfirmationData
scd =
  HS.SubjectConfirmationData
    { subjectConfirmationNotBefore :: Maybe UTCTime
HS.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
HS.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
HS.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 [Char]
HS.subjectConfirmationInResponseTo = Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char])
-> (ID AuthnRequest -> Text) -> ID AuthnRequest -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> Text)
-> (ID AuthnRequest -> XmlText) -> ID AuthnRequest -> 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
. ID AuthnRequest -> XmlText
forall {k} (m :: k). ID m -> XmlText
fromID (ID AuthnRequest -> [Char])
-> Maybe (ID AuthnRequest) -> Maybe [Char]
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 [Char]
HS.subjectConfirmationAddress = HasCallStack => IP -> [Char]
IP -> [Char]
exportIP (IP -> [Char]) -> Maybe IP -> Maybe [Char]
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]
HS.subjectConfirmationKeyInfo = [KeyInfo]
forall a. Monoid a => a
mempty,
      subjectConfirmationXML :: [Node]
HS.subjectConfirmationXML = [Node]
forall a. Monoid a => a
mempty
    }

importIP :: (HasCallStack, MonadError String m) => HS.IP -> m IP
importIP :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
[Char] -> m IP
importIP = Text -> m IP
forall (m :: * -> *). MonadError [Char] m => Text -> m IP
mkIP (Text -> m IP) -> ([Char] -> Text) -> [Char] -> 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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs

exportIP :: (HasCallStack) => IP -> HS.IP
exportIP :: HasCallStack => IP -> [Char]
exportIP = Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (IP -> Text) -> IP -> [Char]
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) => HS.Conditions -> m Conditions
importConditions :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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 [Char] 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
HS.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 [Char] 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
HS.conditionsNotOnOrAfter Conditions
conds
  let _condOneTimeUse :: Bool
_condOneTimeUse = Bool
False
      _condAudienceRestriction :: [a]
_condAudienceRestriction = []
      go :: Conditions -> HS.Condition -> m Conditions
      go :: Conditions -> Condition -> m Conditions
go Conditions
conds' Condition
HS.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' (HS.AudienceRestriction List1 Audience
hsrs) = do
        NonEmpty URI
rs :: NonEmpty URI <- (AnyURI -> m URI
forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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
HS.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 NonEmpty URI -> [NonEmpty URI] -> [NonEmpty URI]
forall a. a -> [a] -> [a]
:)
      go Conditions
_ Condition
badcond = Proxy Conditions -> ([Char], Condition) -> m Conditions
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Conditions) ([Char]
"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]
_condNotBefore :: Maybe Time
_condNotOnOrAfter :: Maybe Time
_condOneTimeUse :: Bool
_condAudienceRestriction :: [NonEmpty URI]
..}) (Conditions -> [Condition]
HS.conditions Conditions
conds)

exportConditions :: (HasCallStack) => Conditions -> HS.Conditions
exportConditions :: HasCallStack => Conditions -> Conditions
exportConditions Conditions
conds =
  HS.Conditions
    { conditionsNotBefore :: Maybe UTCTime
HS.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
HS.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]
HS.conditions =
        [Condition
HS.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
HS.AudienceRestriction (AnyURI -> Audience
HS.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) =>
  HS.Statement ->
  m (Maybe Statement)
importStatement :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
Statement -> m (Maybe Statement)
importStatement (HS.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 (HS.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 [Char] m) =>
UTCTime -> m Time
importTime (UTCTime -> m Time) -> UTCTime -> m Time
forall a b. (a -> b) -> a -> b
$ AuthnStatement -> UTCTime
HS.authnStatementInstant AuthnStatement
st
    let _astSessionIndex :: Maybe XmlText
_astSessionIndex = Text -> XmlText
mkXmlText (Text -> XmlText) -> ([Char] -> Text) -> [Char] -> XmlText
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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> XmlText) -> Maybe [Char] -> Maybe XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AuthnStatement -> Maybe [Char]
HS.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 [Char] 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
HS.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 [Char] 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
HS.authnStatementSubjectLocality AuthnStatement
st
    -- NB: @HS.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 XmlText -> Maybe Time -> Maybe Locality -> Statement
AuthnStatement Time
_astAuthnInstant Maybe XmlText
_astSessionIndex Maybe Time
_astSessionNotOnOrAfter Maybe Locality
_astSubjectLocality
importStatement Statement
bad = Proxy Statement -> Statement -> m (Maybe Statement)
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Statement) Statement
bad

exportStatement :: (HasCallStack) => Statement -> HS.Statement
exportStatement :: HasCallStack => Statement -> Statement
exportStatement Statement
stm =
  AuthnStatement -> Statement
HS.StatementAuthn
    HS.AuthnStatement
      { authnStatementInstant :: UTCTime
HS.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 [Char]
HS.authnStatementSessionIndex = Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (XmlText -> Text) -> XmlText -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> [Char]) -> Maybe XmlText -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Statement
stm Statement
-> Getting (Maybe XmlText) Statement (Maybe XmlText)
-> Maybe XmlText
forall s a. s -> Getting a s a -> a
^. Getting (Maybe XmlText) Statement (Maybe XmlText)
Lens' Statement (Maybe XmlText)
astSessionIndex),
        authnStatementSessionNotOnOrAfter :: Maybe UTCTime
HS.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
HS.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
HS.authnStatementContext = Maybe AnyURI -> Maybe AuthnContextDecl -> [AnyURI] -> AuthnContext
HS.AuthnContext Maybe AnyURI
forall a. Maybe a
Nothing Maybe AuthnContextDecl
forall a. Maybe a
Nothing []
      }

importLocality :: (HasCallStack, MonadError String m) => HS.SubjectLocality -> m Locality
importLocality :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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
<$> (([Char] -> m IP) -> Maybe [Char] -> 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 [Char] -> m IP
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
[Char] -> m IP
importIP (Maybe [Char] -> m (Maybe IP)) -> Maybe [Char] -> m (Maybe IP)
forall a b. (a -> b) -> a -> b
$ SubjectLocality -> Maybe [Char]
HS.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 (Maybe DNSName -> m (Maybe DNSName))
-> Maybe DNSName -> m (Maybe DNSName)
forall a b. (a -> b) -> a -> b
$ (Text -> DNSName
mkDNSName (Text -> DNSName) -> ([Char] -> Text) -> [Char] -> 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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs) ([Char] -> DNSName) -> Maybe [Char] -> Maybe DNSName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubjectLocality -> Maybe [Char]
HS.subjectLocalityDNSName SubjectLocality
loc)

exportLocality :: HasCallStack => Locality -> HS.SubjectLocality
exportLocality :: HasCallStack => Locality -> SubjectLocality
exportLocality Locality
loc =
  HS.SubjectLocality
    { subjectLocalityAddress :: Maybe [Char]
HS.subjectLocalityAddress = HasCallStack => IP -> [Char]
IP -> [Char]
exportIP (IP -> [Char]) -> Maybe IP -> Maybe [Char]
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 [Char]
HS.subjectLocalityDNSName = Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (DNSName -> Text) -> DNSName -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> Text) -> (DNSName -> XmlText) -> DNSName -> 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
. DNSName -> XmlText
fromDNSName (DNSName -> [Char]) -> Maybe DNSName -> Maybe [Char]
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) => HS.ID -> m (ID a)
importID :: forall {k} (m :: * -> *) (a :: k).
(HasCallStack, MonadError [Char] m) =>
[Char] -> 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)) -> ([Char] -> ID a) -> [Char] -> 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
mkID (Text -> ID a) -> ([Char] -> Text) -> [Char] -> 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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs

exportID :: HasCallStack => ID a -> HS.ID
exportID :: forall {k} (a :: k). HasCallStack => ID a -> [Char]
exportID = Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (ID a -> Text) -> ID a -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> Text) -> (ID a -> XmlText) -> ID a -> 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
. ID a -> XmlText
forall {k} (m :: k). ID m -> XmlText
fromID

importNameID :: (HasCallStack, MonadError String m) => HS.NameID -> m NameID
importNameID :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
NameID -> m NameID
importNameID bad :: NameID
bad@(HS.NameID (HS.BaseID Maybe [Char]
_ Maybe [Char]
_ [Char]
_) (HS.Unidentified AnyURI
_) Maybe [Char]
_) =
  Proxy NameID -> [Char] -> m NameID
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @NameID) (NameID -> [Char]
forall a. Show a => a -> [Char]
show NameID
bad)
importNameID (HS.NameID (HS.BaseID Maybe [Char]
m1 Maybe [Char]
m2 [Char]
nid) (HS.Identified NameIDFormat
hsNameIDFormat) Maybe [Char]
m3) =
  ([Char] -> m NameID)
-> (NameID -> m NameID) -> Either [Char] NameID -> m NameID
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Proxy NameID -> [Char] -> m NameID
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] 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 [Char] NameID -> m NameID)
-> Either [Char] NameID -> m NameID
forall a b. (a -> b) -> a -> b
$
    NameIDFormat -> Text -> Either [Char] UnqualifiedNameID
forall (m :: * -> *).
MonadError [Char] m =>
NameIDFormat -> Text -> m UnqualifiedNameID
form NameIDFormat
hsNameIDFormat ([Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs [Char]
nid) Either [Char] UnqualifiedNameID
-> (UnqualifiedNameID -> Either [Char] NameID)
-> Either [Char] NameID
forall a b.
Either [Char] a -> (a -> Either [Char] b) -> Either [Char] b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \UnqualifiedNameID
nid' -> UnqualifiedNameID
-> Maybe Text -> Maybe Text -> Maybe Text -> Either [Char] NameID
forall (m :: * -> *).
MonadError [Char] m =>
UnqualifiedNameID
-> Maybe Text -> Maybe Text -> Maybe Text -> m NameID
mkNameID UnqualifiedNameID
nid' ([Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> Maybe [Char] -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
m1) ([Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> Maybe [Char] -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
m2) ([Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> Maybe [Char] -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
m3)
  where
    form :: MonadError String m => HS.NameIDFormat -> ST -> m UnqualifiedNameID
    form :: forall (m :: * -> *).
MonadError [Char] m =>
NameIDFormat -> Text -> m UnqualifiedNameID
form NameIDFormat
HS.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
. XmlText -> UnqualifiedNameID
UNameIDUnspecified (XmlText -> UnqualifiedNameID)
-> (Text -> XmlText) -> Text -> 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 -> XmlText
mkXmlText
    form NameIDFormat
HS.NameIDFormatEmail = Text -> m UnqualifiedNameID
forall (m :: * -> *).
MonadError [Char] m =>
Text -> m UnqualifiedNameID
mkUNameIDEmail
    form NameIDFormat
HS.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
. XmlText -> UnqualifiedNameID
UNameIDX509 (XmlText -> UnqualifiedNameID)
-> (Text -> XmlText) -> Text -> 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 -> XmlText
mkXmlText
    form NameIDFormat
HS.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
. XmlText -> UnqualifiedNameID
UNameIDWindows (XmlText -> UnqualifiedNameID)
-> (Text -> XmlText) -> Text -> 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 -> XmlText
mkXmlText
    form NameIDFormat
HS.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
. XmlText -> UnqualifiedNameID
UNameIDKerberos (XmlText -> UnqualifiedNameID)
-> (Text -> XmlText) -> Text -> 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 -> XmlText
mkXmlText
    form NameIDFormat
HS.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 [Char] m => Text -> m URI
parseURI'
    form NameIDFormat
HS.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
. XmlText -> UnqualifiedNameID
UNameIDPersistent (XmlText -> UnqualifiedNameID)
-> (Text -> XmlText) -> Text -> 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 -> XmlText
mkXmlText
    form NameIDFormat
HS.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
. XmlText -> UnqualifiedNameID
UNameIDTransient (XmlText -> UnqualifiedNameID)
-> (Text -> XmlText) -> Text -> 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 -> XmlText
mkXmlText
    form b :: NameIDFormat
b@NameIDFormat
HS.NameIDFormatEncrypted = \Text
_ -> Proxy NameID -> [Char] -> m UnqualifiedNameID
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @NameID) (NameIDFormat -> [Char]
forall a. Show a => a -> [Char]
show NameIDFormat
b)

exportNameID :: NameID -> HS.NameID
exportNameID :: NameID -> NameID
exportNameID NameID
name =
  HS.NameID
    { nameBaseID :: BaseID [Char]
HS.nameBaseID =
        Maybe [Char] -> Maybe [Char] -> [Char] -> BaseID [Char]
forall id. Maybe [Char] -> Maybe [Char] -> id -> BaseID id
HS.BaseID
          (Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (XmlText -> Text) -> XmlText -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> [Char]) -> Maybe XmlText -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameID
name NameID
-> Getting (Maybe XmlText) NameID (Maybe XmlText) -> Maybe XmlText
forall s a. s -> Getting a s a -> a
^. Getting (Maybe XmlText) NameID (Maybe XmlText)
Lens' NameID (Maybe XmlText)
nameIDNameQ)
          (Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (XmlText -> Text) -> XmlText -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> [Char]) -> Maybe XmlText -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameID
name NameID
-> Getting (Maybe XmlText) NameID (Maybe XmlText) -> Maybe XmlText
forall s a. s -> Getting a s a -> a
^. Getting (Maybe XmlText) NameID (Maybe XmlText)
Lens' NameID (Maybe XmlText)
nameIDSPNameQ)
          (Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs Text
nid),
      nameIDFormat :: IdentifiedURI NameIDFormat
HS.nameIDFormat = IdentifiedURI NameIDFormat
fmt,
      nameSPProvidedID :: Maybe [Char]
HS.nameSPProvidedID = Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (XmlText -> Text) -> XmlText -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> [Char]) -> Maybe XmlText -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameID
name NameID
-> Getting (Maybe XmlText) NameID (Maybe XmlText) -> Maybe XmlText
forall s a. s -> Getting a s a -> a
^. Getting (Maybe XmlText) NameID (Maybe XmlText)
Lens' NameID (Maybe XmlText)
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 -> (HS.IdentifiedURI HS.NameIDFormat, ST)
    unform :: UnqualifiedNameID -> (IdentifiedURI NameIDFormat, Text)
unform (UNameIDUnspecified XmlText
n) = (NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HS.Identified NameIDFormat
HS.NameIDFormatUnspecified, XmlText -> Text
escapeXmlText XmlText
n)
    unform (UNameIDEmail CI Email
n) =
      ( NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HS.Identified NameIDFormat
HS.NameIDFormatEmail,
        XmlText -> Text
escapeXmlText (XmlText -> Text) -> (CI Email -> XmlText) -> 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
. Text -> XmlText
mkXmlText (Text -> XmlText) -> (CI Email -> Text) -> CI Email -> XmlText
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
. 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 XmlText
n) = (NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HS.Identified NameIDFormat
HS.NameIDFormatX509, XmlText -> Text
escapeXmlText XmlText
n)
    unform (UNameIDWindows XmlText
n) = (NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HS.Identified NameIDFormat
HS.NameIDFormatWindows, XmlText -> Text
escapeXmlText XmlText
n)
    unform (UNameIDKerberos XmlText
n) = (NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HS.Identified NameIDFormat
HS.NameIDFormatKerberos, XmlText -> Text
escapeXmlText XmlText
n)
    unform (UNameIDEntity URI
n) =
      ( NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HS.Identified NameIDFormat
HS.NameIDFormatEntity,
        XmlText -> Text
escapeXmlText (XmlText -> Text) -> (Text -> XmlText) -> Text -> 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
. Text -> XmlText
mkXmlText (Text -> XmlText) -> (Text -> Text) -> Text -> XmlText
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 -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ URI -> Text
renderURI URI
n
      )
    unform (UNameIDPersistent XmlText
n) = (NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HS.Identified NameIDFormat
HS.NameIDFormatPersistent, XmlText -> Text
escapeXmlText XmlText
n)
    unform (UNameIDTransient XmlText
n) = (NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HS.Identified NameIDFormat
HS.NameIDFormatTransient, XmlText -> Text
escapeXmlText XmlText
n)

importVersion :: (HasCallStack, MonadError String m) => HS.SAMLVersion -> m ()
importVersion :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
SAMLVersion -> m ()
importVersion SAMLVersion
HS.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 :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @HS.SAMLVersion) SAMLVersion
bad

exportVersion :: HasCallStack => HS.SAMLVersion
exportVersion :: HasCallStack => SAMLVersion
exportVersion = SAMLVersion
HS.SAML20

importTime :: (HasCallStack, MonadError String m) => HS.DateTime -> m Time
importTime :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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 -> HS.DateTime
exportTime :: HasCallStack => Time -> UTCTime
exportTime = Time -> UTCTime
fromTime

importURI :: (HasCallStack, MonadError String m) => HS.URI -> m URI
importURI :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
AnyURI -> m URI
importURI AnyURI
uri = Text -> m URI
forall (m :: * -> *). MonadError [Char] m => Text -> m URI
parseURI' (Text -> m URI) -> ([Char] -> Text) -> [Char] -> 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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> m URI) -> [Char] -> m URI
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> AnyURI -> [Char] -> [Char]
HS.uriToString [Char] -> [Char]
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id AnyURI
uri [Char]
forall a. Monoid a => a
mempty

exportURI :: HasCallStack => URI -> HS.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
. [Char] -> Maybe AnyURI
HS.parseURIReference ([Char] -> Maybe AnyURI) -> (URI -> [Char]) -> 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 -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (URI -> Text) -> URI -> [Char]
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 = [Char] -> AnyURI
forall a. HasCallStack => [Char] -> a
error ([Char] -> AnyURI) -> [Char] -> AnyURI
forall a b. (a -> b) -> a -> b
$ [Char]
"internal error: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> URI -> [Char]
forall a. Show a => a -> [Char]
show URI
uri

-- | [1/3.2.2.1;3.2.2.2]
importStatus :: (HasCallStack, Monad m) => HS.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
    HS.Status (HS.StatusCode StatusCode1
HS.StatusSuccess [IdentifiedURI StatusCode2]
_) Maybe [Char]
_ Maybe [Node]
_ -> Status
StatusSuccess
    Status
_ -> Status
StatusFailure

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

importIssuer :: (HasCallStack, MonadError String m) => HS.Issuer -> m Issuer
importIssuer :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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 [Char] 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 [Char] 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
HS.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 XmlText -> Bool
forall a. Maybe a -> Bool
isNothing (NameID
nameid NameID
-> Getting (Maybe XmlText) NameID (Maybe XmlText) -> Maybe XmlText
forall s a. s -> Getting a s a -> a
^. Getting (Maybe XmlText) NameID (Maybe XmlText)
Lens' NameID (Maybe XmlText)
nameIDNameQ)
            Bool -> Bool -> Bool
&& Maybe XmlText -> Bool
forall a. Maybe a -> Bool
isNothing (NameID
nameid NameID
-> Getting (Maybe XmlText) NameID (Maybe XmlText) -> Maybe XmlText
forall s a. s -> Getting a s a -> a
^. Getting (Maybe XmlText) NameID (Maybe XmlText)
Lens' NameID (Maybe XmlText)
nameIDSPNameQ)
            Bool -> Bool -> Bool
&& Maybe XmlText -> Bool
forall a. Maybe a -> Bool
isNothing (NameID
nameid NameID
-> Getting (Maybe XmlText) NameID (Maybe XmlText) -> Maybe XmlText
forall s a. s -> Getting a s a -> a
^. Getting (Maybe XmlText) NameID (Maybe XmlText)
Lens' NameID (Maybe XmlText)
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 :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Issuer) NameID
bad

exportIssuer :: HasCallStack => Issuer -> HS.Issuer
exportIssuer :: HasCallStack => Issuer -> Issuer
exportIssuer = NameID -> Issuer
HS.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 HS.Issuer -> m Issuer
importRequiredIssuer :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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 -> [Char] -> m Issuer
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Proxy a -> b -> m c
die (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @AuthnRequest) ([Char]
"no issuer id" :: String)) Issuer -> m Issuer
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
Issuer -> m Issuer
importIssuer

exportRequiredIssuer :: HasCallStack => Issuer -> Maybe HS.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 -> XmlText
mkXmlText -> XmlText
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 :: XmlText
_spOrgName = XmlText
nick
      _spOrgDisplayName :: XmlText
_spOrgDisplayName = XmlText
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]
UTCTime
NominalDiffTime
URI
ID SPMetadata
XmlText
forall {a}. Num a => a
_spID :: ID SPMetadata
_spCacheDuration :: forall {a}. Num a => a
_spOrgName :: XmlText
_spOrgDisplayName :: XmlText
_spOrgURL :: URI
_spResponseURL :: URI
_spContacts :: [ContactPerson]
_spValidUntil :: UTCTime
_spID :: ID SPMetadata
_spValidUntil :: UTCTime
_spCacheDuration :: NominalDiffTime
_spOrgName :: XmlText
_spOrgDisplayName :: XmlText
_spOrgURL :: URI
_spResponseURL :: URI
_spContacts :: [ContactPerson]
..}

-- | NB: this works best under the assumption that the input has been constructed by
-- 'exportSPMetadata'.
importSPMetadata :: (HasCallStack, MonadError String m) => HS.Metadata -> m SPMetadata
importSPMetadata :: forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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
HS.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
HS.entityDescriptors -> Descriptor
desc) = do
  case Descriptor
desc of
    HS.SPSSODescriptor {} -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Descriptor
bad -> [Char] -> m ()
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"malformed HS.Descriptor: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Descriptor -> [Char]
forall a. Show a => a -> [Char]
show Descriptor
bad
  ID SPMetadata
_spID <-
    let raw :: Maybe [Char]
raw = RoleDescriptor -> Maybe [Char]
HS.roleDescriptorID (RoleDescriptor -> Maybe [Char])
-> (Descriptor -> RoleDescriptor) -> Descriptor -> Maybe [Char]
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
HS.descriptorRole (Descriptor -> Maybe [Char]) -> Descriptor -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ Descriptor
desc
     in m (ID SPMetadata)
-> ([Char] -> m (ID SPMetadata))
-> Maybe [Char]
-> m (ID SPMetadata)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> m (ID SPMetadata)
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char]
"malformed descriptorID: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe [Char] -> [Char]
forall a. Show a => a -> [Char]
show Maybe [Char]
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))
-> ([Char] -> ID SPMetadata) -> [Char] -> 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
mkID (Text -> ID SPMetadata)
-> ([Char] -> Text) -> [Char] -> 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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs) Maybe [Char]
raw
  UTCTime
_spValidUntil <-
    let raw :: Maybe UTCTime
raw = RoleDescriptor -> Maybe UTCTime
HS.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
HS.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 ([Char] -> m UTCTime
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m UTCTime) -> [Char] -> m UTCTime
forall a b. (a -> b) -> a -> b
$ [Char]
"bad validUntil: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe UTCTime -> [Char]
forall a. Show a => a -> [Char]
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 [Char] m) =>
them -> m us
forall (m :: * -> *). MonadError [Char] m => UTCTime -> m Time
importXml) Maybe UTCTime
raw
  NominalDiffTime
_spCacheDuration <-
    let raw :: Maybe NominalDiffTime
raw = RoleDescriptor -> Maybe NominalDiffTime
HS.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
HS.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 ([Char] -> m NominalDiffTime
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m NominalDiffTime) -> [Char] -> m NominalDiffTime
forall a b. (a -> b) -> a -> b
$ [Char]
"bad cacheDuration: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe NominalDiffTime -> [Char]
forall a. Show a => a -> [Char]
show Maybe NominalDiffTime
raw) NominalDiffTime -> m NominalDiffTime
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NominalDiffTime
raw
  XmlText
_spOrgName :: XmlText <-
    let raw :: Maybe [Char]
raw = case (Organization -> NonEmpty (Localized [Char]))
-> Maybe Organization -> Maybe (NonEmpty (Localized [Char]))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Organization -> NonEmpty (Localized [Char])
HS.organizationName (Maybe Organization -> Maybe (NonEmpty (Localized [Char])))
-> (Descriptor -> Maybe Organization)
-> Descriptor
-> Maybe (NonEmpty (Localized [Char]))
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
HS.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
HS.descriptorRole (Descriptor -> Maybe (NonEmpty (Localized [Char])))
-> Descriptor -> Maybe (NonEmpty (Localized [Char]))
forall a b. (a -> b) -> a -> b
$ Descriptor
desc of
          Just (HS.Localized [Char]
"EN" [Char]
x :| []) -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
x
          Maybe (NonEmpty (Localized [Char]))
_ -> Maybe [Char]
forall a. Maybe a
Nothing
     in m XmlText -> ([Char] -> m XmlText) -> Maybe [Char] -> m XmlText
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> m XmlText
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m XmlText) -> [Char] -> m XmlText
forall a b. (a -> b) -> a -> b
$ [Char]
"bad orgName: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe [Char] -> [Char]
forall a. Show a => a -> [Char]
show Maybe [Char]
raw) (XmlText -> m XmlText
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XmlText -> m XmlText)
-> ([Char] -> XmlText) -> [Char] -> m XmlText
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 -> XmlText
mkXmlText (Text -> XmlText) -> ([Char] -> Text) -> [Char] -> XmlText
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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs) Maybe [Char]
raw
  XmlText
_spOrgDisplayName :: XmlText <-
    let raw :: Maybe [Char]
raw = case (Organization -> NonEmpty (Localized [Char]))
-> Maybe Organization -> Maybe (NonEmpty (Localized [Char]))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Organization -> NonEmpty (Localized [Char])
HS.organizationDisplayName (Maybe Organization -> Maybe (NonEmpty (Localized [Char])))
-> (Descriptor -> Maybe Organization)
-> Descriptor
-> Maybe (NonEmpty (Localized [Char]))
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
HS.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
HS.descriptorRole (Descriptor -> Maybe (NonEmpty (Localized [Char])))
-> Descriptor -> Maybe (NonEmpty (Localized [Char]))
forall a b. (a -> b) -> a -> b
$ Descriptor
desc of
          Just (HS.Localized [Char]
"EN" [Char]
x :| []) -> [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
x
          Maybe (NonEmpty (Localized [Char]))
_ -> Maybe [Char]
forall a. Maybe a
Nothing
     in m XmlText -> ([Char] -> m XmlText) -> Maybe [Char] -> m XmlText
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> m XmlText
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m XmlText) -> [Char] -> m XmlText
forall a b. (a -> b) -> a -> b
$ [Char]
"bad orgDisplayName: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe [Char] -> [Char]
forall a. Show a => a -> [Char]
show Maybe [Char]
raw) (XmlText -> m XmlText
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XmlText -> m XmlText)
-> ([Char] -> XmlText) -> [Char] -> m XmlText
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 -> XmlText
mkXmlText (Text -> XmlText) -> ([Char] -> Text) -> [Char] -> XmlText
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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs) Maybe [Char]
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
HS.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
HS.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
HS.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 (HS.Localized [Char]
"EN" AnyURI
u :| []) -> AnyURI -> m URI
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
AnyURI -> m URI
importURI AnyURI
u
          Maybe (List1 LocalizedURI)
bad -> [Char] -> m URI
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m URI) -> [Char] -> m URI
forall a b. (a -> b) -> a -> b
$ [Char]
"bad or no organizationURL" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe (List1 LocalizedURI) -> [Char]
forall a. Show a => a -> [Char]
show Maybe (List1 LocalizedURI)
bad
  URI
_spResponseURL <-
    AnyURI -> m URI
forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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
HS.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
HS.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
HS.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 [Char] 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]
HS.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
HS.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]
UTCTime
NominalDiffTime
URI
ID SPMetadata
XmlText
_spID :: ID SPMetadata
_spValidUntil :: UTCTime
_spCacheDuration :: NominalDiffTime
_spOrgName :: XmlText
_spOrgDisplayName :: XmlText
_spOrgURL :: URI
_spResponseURL :: URI
_spContacts :: [ContactPerson]
_spID :: ID SPMetadata
_spValidUntil :: UTCTime
_spCacheDuration :: NominalDiffTime
_spOrgName :: XmlText
_spOrgDisplayName :: XmlText
_spOrgURL :: URI
_spResponseURL :: URI
_spContacts :: [ContactPerson]
..}

exportSPMetadata :: HasCallStack => SPMetadata -> HS.Metadata
exportSPMetadata :: HasCallStack => SPMetadata -> Metadata
exportSPMetadata SPMetadata
spdesc =
  HS.EntityDescriptor
    { entityID :: AnyURI
HS.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) :: HS.EntityID,
      metadataID :: Maybe [Char]
HS.metadataID = Maybe [Char]
forall a. Maybe a
Nothing :: Maybe HX.ID,
      metadataValidUntil :: Maybe UTCTime
HS.metadataValidUntil = Maybe UTCTime
forall a. Maybe a
Nothing :: Maybe HX.DateTime,
      metadataCacheDuration :: Maybe NominalDiffTime
HS.metadataCacheDuration = Maybe NominalDiffTime
forall a. Maybe a
Nothing :: Maybe HX.Duration,
      entityAttrs :: [Node]
HS.entityAttrs = [Node]
forall a. Monoid a => a
mempty :: HX.Nodes,
      metadataSignature :: Maybe Signature
HS.metadataSignature = Maybe Signature
forall a. Maybe a
Nothing :: Maybe HX.Signature,
      metadataExtensions :: Extensions
HS.metadataExtensions = Extensions
forall a. Monoid a => a
mempty :: HS.Extensions,
      entityDescriptors :: Descriptors
HS.entityDescriptors = NonEmpty Descriptor -> Descriptors
HS.Descriptors (HasCallStack => SPMetadata -> Descriptor
SPMetadata -> Descriptor
exportSPMetadata' SPMetadata
spdesc Descriptor -> [Descriptor] -> NonEmpty Descriptor
forall a. a -> [a] -> NonEmpty a
:| []),
      entityOrganization :: Maybe Organization
HS.entityOrganization = Maybe Organization
forall a. Maybe a
Nothing :: Maybe HS.Organization,
      entityContactPerson :: [Contact]
HS.entityContactPerson = [Contact]
forall a. Monoid a => a
mempty :: [HS.Contact],
      entityAditionalMetadataLocation :: [AdditionalMetadataLocation]
HS.entityAditionalMetadataLocation = [AdditionalMetadataLocation]
forall a. Monoid a => a
mempty :: [HS.AdditionalMetadataLocation]
    }

-- | [4/2.6], [4/2]
exportSPMetadata' :: HasCallStack => SPMetadata -> HS.Descriptor
exportSPMetadata' :: HasCallStack => SPMetadata -> Descriptor
exportSPMetadata' SPMetadata
spdesc =
  HS.SPSSODescriptor
    { descriptorRole :: RoleDescriptor
HS.descriptorRole =
        HS.RoleDescriptor
          { roleDescriptorID :: Maybe [Char]
HS.roleDescriptorID = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char])
-> (ID SPMetadata -> Text) -> ID SPMetadata -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> Text)
-> (ID SPMetadata -> XmlText) -> ID SPMetadata -> 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
. ID SPMetadata -> XmlText
forall {k} (m :: k). ID m -> XmlText
fromID (ID SPMetadata -> [Char]) -> ID SPMetadata -> [Char]
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
HS.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
HS.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]
HS.roleDescriptorProtocolSupportEnumeration = [SAMLVersion -> [[Char]] -> AnyURI
HS.samlURN SAMLVersion
HS.SAML20 [[Char]
"protocol"]] :: [HX.AnyURI],
            roleDescriptorErrorURL :: Maybe AnyURI
HS.roleDescriptorErrorURL = Maybe AnyURI
forall a. Maybe a
Nothing :: Maybe HX.AnyURI,
            roleDescriptorAttrs :: [Node]
HS.roleDescriptorAttrs = [] :: HX.Nodes,
            roleDescriptorSignature :: Maybe Signature
HS.roleDescriptorSignature = Maybe Signature
forall a. Maybe a
Nothing :: Maybe HX.Signature,
            roleDescriptorExtensions :: Extensions
HS.roleDescriptorExtensions = [Node] -> Extensions
HS.Extensions [],
            roleDescriptorKeyDescriptor :: [KeyDescriptor]
HS.roleDescriptorKeyDescriptor = [] :: [HS.KeyDescriptor],
            roleDescriptorOrganization :: Maybe Organization
HS.roleDescriptorOrganization =
              Organization -> Maybe Organization
forall a. a -> Maybe a
Just
                HS.Organization
                  { organizationAttrs :: [Node]
HS.organizationAttrs = [],
                    organizationExtensions :: Extensions
HS.organizationExtensions = [Node] -> Extensions
HS.Extensions [],
                    organizationName :: NonEmpty (Localized [Char])
HS.organizationName = [Char] -> [Char] -> Localized [Char]
forall a. [Char] -> a -> Localized a
HS.Localized [Char]
"EN" (Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (XmlText -> Text) -> XmlText -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> [Char]) -> XmlText -> [Char]
forall a b. (a -> b) -> a -> b
$ SPMetadata
spdesc SPMetadata -> Getting XmlText SPMetadata XmlText -> XmlText
forall s a. s -> Getting a s a -> a
^. Getting XmlText SPMetadata XmlText
Lens' SPMetadata XmlText
spOrgName) Localized [Char]
-> [Localized [Char]] -> NonEmpty (Localized [Char])
forall a. a -> [a] -> NonEmpty a
:| [],
                    organizationDisplayName :: NonEmpty (Localized [Char])
HS.organizationDisplayName = [Char] -> [Char] -> Localized [Char]
forall a. [Char] -> a -> Localized a
HS.Localized [Char]
"EN" (Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (XmlText -> Text) -> XmlText -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> [Char]) -> XmlText -> [Char]
forall a b. (a -> b) -> a -> b
$ SPMetadata
spdesc SPMetadata -> Getting XmlText SPMetadata XmlText -> XmlText
forall s a. s -> Getting a s a -> a
^. Getting XmlText SPMetadata XmlText
Lens' SPMetadata XmlText
spOrgDisplayName) Localized [Char]
-> [Localized [Char]] -> NonEmpty (Localized [Char])
forall a. a -> [a] -> NonEmpty a
:| [],
                    organizationURL :: List1 LocalizedURI
HS.organizationURL = [Char] -> AnyURI -> LocalizedURI
forall a. [Char] -> a -> Localized a
HS.Localized [Char]
"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 HS.LocalizedURI
                  },
            roleDescriptorContactPerson :: [Contact]
HS.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
HS.descriptorSSO =
        HS.SSODescriptor
          { ssoDescriptorArtifactResolutionService :: [IndexedEndpoint]
HS.ssoDescriptorArtifactResolutionService = [] :: [HS.IndexedEndpoint],
            ssoDescriptorSingleLogoutService :: [Endpoint]
HS.ssoDescriptorSingleLogoutService = [] :: [HS.Endpoint],
            ssoDescriptorManageNameIDService :: [Endpoint]
HS.ssoDescriptorManageNameIDService = [] :: [HS.Endpoint],
            ssoDescriptorNameIDFormat :: [IdentifiedURI NameIDFormat]
HS.ssoDescriptorNameIDFormat = [NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HS.NameIDFormatUnspecified, NameIDFormat -> IdentifiedURI NameIDFormat
forall b a. a -> Identified b a
HX.Identified NameIDFormat
HS.NameIDFormatEntity] -- [1/8.3]
          },
      descriptorAuthnRequestsSigned :: Bool
HS.descriptorAuthnRequestsSigned = Bool
False,
      descriptorWantAssertionsSigned :: Bool
HS.descriptorWantAssertionsSigned = Bool
True,
      descriptorAssertionConsumerService :: NonEmpty IndexedEndpoint
HS.descriptorAssertionConsumerService =
        HS.IndexedEndpoint
          { indexedEndpoint :: Endpoint
HS.indexedEndpoint =
              HS.Endpoint
                { endpointBinding :: IdentifiedURI Binding
HS.endpointBinding = Binding -> IdentifiedURI Binding
forall b a. a -> Identified b a
HX.Identified Binding
HS.BindingHTTPPOST :: HX.IdentifiedURI HS.Binding,
                  endpointLocation :: AnyURI
HS.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
HS.endpointResponseLocation = Maybe AnyURI
forall a. Maybe a
Nothing :: Maybe HX.AnyURI,
                  endpointAttrs :: [Node]
HS.endpointAttrs = [] :: HX.Nodes,
                  endpointXML :: [Node]
HS.endpointXML = [] :: HX.Nodes
                },
            indexedEndpointIndex :: UnsignedShort
HS.indexedEndpointIndex = UnsignedShort
0 :: HX.UnsignedShort,
            indexedEndpointIsDefault :: Bool
HS.indexedEndpointIsDefault = Bool
True :: HX.Boolean
          }
          IndexedEndpoint -> [IndexedEndpoint] -> NonEmpty IndexedEndpoint
forall a. a -> [a] -> NonEmpty a
:| [] ::
          HX.List1 HS.IndexedEndpoint,
      descriptorAttributeConsumingService :: [AttributeConsumingService]
HS.descriptorAttributeConsumingService = [] :: [HS.AttributeConsumingService]
      -- (for identification we do not need any attributes, but can use the 'SubjectID' that is
      -- always included in the response.)
    }

exportContactPerson :: ContactPerson -> HS.Contact
exportContactPerson :: ContactPerson -> Contact
exportContactPerson ContactPerson
contact =
  HS.ContactPerson
    { contactType :: ContactType
HS.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 :: [Node]
HS.contactAttrs = [],
      contactExtensions :: Extensions
HS.contactExtensions = [Node] -> Extensions
HS.Extensions [],
      contactCompany :: Maybe [Char]
HS.contactCompany = Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (XmlText -> Text) -> XmlText -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> [Char]) -> Maybe XmlText -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContactPerson
contact ContactPerson
-> Getting (Maybe XmlText) ContactPerson (Maybe XmlText)
-> Maybe XmlText
forall s a. s -> Getting a s a -> a
^. Getting (Maybe XmlText) ContactPerson (Maybe XmlText)
Lens' ContactPerson (Maybe XmlText)
cntCompany,
      contactGivenName :: Maybe [Char]
HS.contactGivenName = Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (XmlText -> Text) -> XmlText -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> [Char]) -> Maybe XmlText -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContactPerson
contact ContactPerson
-> Getting (Maybe XmlText) ContactPerson (Maybe XmlText)
-> Maybe XmlText
forall s a. s -> Getting a s a -> a
^. Getting (Maybe XmlText) ContactPerson (Maybe XmlText)
Lens' ContactPerson (Maybe XmlText)
cntGivenName,
      contactSurName :: Maybe [Char]
HS.contactSurName = Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (XmlText -> Text) -> XmlText -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> [Char]) -> Maybe XmlText -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContactPerson
contact ContactPerson
-> Getting (Maybe XmlText) ContactPerson (Maybe XmlText)
-> Maybe XmlText
forall s a. s -> Getting a s a -> a
^. Getting (Maybe XmlText) ContactPerson (Maybe XmlText)
Lens' ContactPerson (Maybe XmlText)
cntSurname,
      contactEmailAddress :: [AnyURI]
HS.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 :: [[Char]]
HS.contactTelephoneNumber = Maybe [Char] -> [[Char]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> [Char]) -> (XmlText -> Text) -> XmlText -> [Char]
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
. XmlText -> Text
escapeXmlText (XmlText -> [Char]) -> Maybe XmlText -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContactPerson
contact ContactPerson
-> Getting (Maybe XmlText) ContactPerson (Maybe XmlText)
-> Maybe XmlText
forall s a. s -> Getting a s a -> a
^. Getting (Maybe XmlText) ContactPerson (Maybe XmlText)
Lens' ContactPerson (Maybe XmlText)
cntPhone
    }

importContactPerson :: MonadError String m => HS.Contact -> m ContactPerson
importContactPerson :: forall (m :: * -> *).
MonadError [Char] 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
HS.contactType Contact
contact
      _cntCompany :: Maybe XmlText
_cntCompany = Text -> XmlText
mkXmlText (Text -> XmlText) -> ([Char] -> Text) -> [Char] -> XmlText
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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> XmlText) -> Maybe [Char] -> Maybe XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contact -> Maybe [Char]
HS.contactCompany Contact
contact
      _cntGivenName :: Maybe XmlText
_cntGivenName = Text -> XmlText
mkXmlText (Text -> XmlText) -> ([Char] -> Text) -> [Char] -> XmlText
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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> XmlText) -> Maybe [Char] -> Maybe XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contact -> Maybe [Char]
HS.contactGivenName Contact
contact
      _cntSurname :: Maybe XmlText
_cntSurname = Text -> XmlText
mkXmlText (Text -> XmlText) -> ([Char] -> Text) -> [Char] -> XmlText
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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> XmlText) -> Maybe [Char] -> Maybe XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contact -> Maybe [Char]
HS.contactSurName Contact
contact
      _cntPhone :: Maybe XmlText
_cntPhone = [XmlText] -> Maybe XmlText
forall a. [a] -> Maybe a
listToMaybe ([XmlText] -> Maybe XmlText) -> [XmlText] -> Maybe XmlText
forall a b. (a -> b) -> a -> b
$ Text -> XmlText
mkXmlText (Text -> XmlText) -> ([Char] -> Text) -> [Char] -> XmlText
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
. [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> XmlText) -> [[Char]] -> [XmlText]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contact -> [[Char]]
HS.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 [Char] 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]
HS.contactEmailAddress Contact
contact)
  ContactPerson -> m ContactPerson
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ContactPerson {Maybe URI
Maybe XmlText
ContactType
_cntType :: ContactType
_cntCompany :: Maybe XmlText
_cntGivenName :: Maybe XmlText
_cntSurname :: Maybe XmlText
_cntPhone :: Maybe XmlText
_cntEmail :: Maybe URI
_cntType :: ContactType
_cntCompany :: Maybe XmlText
_cntGivenName :: Maybe XmlText
_cntSurname :: Maybe XmlText
_cntEmail :: Maybe URI
_cntPhone :: Maybe XmlText
..}

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

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

parseIdPMetadata :: (MonadError String m) => Element -> m IdPMetadata
parseIdPMetadata :: forall (m :: * -> *).
MonadError [Char] 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 [Char] 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 [Char] m =>
Element -> m IdPMetadata
parseIdPMetadataHead) Element
el
  Name
"{urn:oasis:names:tc:SAML:2.0:metadata}EntityDescriptor" ->
    Element -> m IdPMetadata
forall (m :: * -> *).
MonadError [Char] m =>
Element -> m IdPMetadata
parseIdPMetadataHead Element
el
  Name
bad ->
    [Char] -> m IdPMetadata
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m IdPMetadata) -> [Char] -> m IdPMetadata
forall a b. (a -> b) -> a -> b
$ [Char]
"expected <EntitiesDescriptor> or <EntityDescriptor>: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Name -> [Char]
forall a. Show a => a -> [Char]
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 [Char] 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
$
    [Char] -> m ()
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Char]
"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 [Char] -> m Element
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m Element) -> [Char] -> m Element
forall a b. (a -> b) -> a -> b
$ [Char]
forall {a}. IsString a => a
msg [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"; found " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
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 [Char] m =>
[Char] -> (Cursor -> [a]) -> [Cursor] -> m [a]
findSome [Char]
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
    [] -> [Char] -> m [a]
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char]
"Couldnt find any matches for: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
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 [Char] m => [Char] -> [a] -> m a
getSingleton [Char]
_ [a
x] = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
getSingleton [Char]
descr [] = [Char] -> m a
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char]
"Couldnt find any matches for: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
descr)
getSingleton [Char]
descr [a]
_ = [Char] -> m a
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char]
"Expected only one but found multiple matches for: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
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 [Char] 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
$
    [Char] -> m ()
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Char]
"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 ([Char] -> m Text
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Char]
"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 [Char] 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
& ( [Char] -> Axis -> [Cursor] -> m [Cursor]
forall (m :: * -> *) a.
MonadError [Char] m =>
[Char] -> (Cursor -> [a]) -> [Cursor] -> m [a]
findSome [Char]
"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
>=> [Char] -> Axis -> [Cursor] -> m [Cursor]
forall (m :: * -> *) a.
MonadError [Char] m =>
[Char] -> (Cursor -> [a]) -> [Cursor] -> m [a]
findSome [Char]
"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
>=> [Char] -> Axis -> [Cursor] -> m [Cursor]
forall (m :: * -> *) a.
MonadError [Char] m =>
[Char] -> (Cursor -> [a]) -> [Cursor] -> m [a]
findSome [Char]
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
>=> [Char] -> [Cursor] -> m Cursor
forall (m :: * -> *) a. MonadError [Char] m => [Char] -> [a] -> m a
getSingleton [Char]
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
>>> [Char] -> [Text] -> m Text
forall (m :: * -> *) a. MonadError [Char] m => [Char] -> [a] -> m a
getSingleton [Char]
"\"Location\""
              )
    case Text -> Either [Char] URI
forall (m :: * -> *). MonadError [Char] 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 [Char]
msg -> [Char] -> m URI
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m URI) -> [Char] -> m URI
forall a b. (a -> b) -> a -> b
$ [Char]
"bad request uri: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
msg

  let cursorToKeyInfo :: MonadError String m => Cursor -> m X509.SignedCertificate
      cursorToKeyInfo :: forall (m :: * -> *).
MonadError [Char] 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 [Char] 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 -> [Char] -> m SignedCertificate
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m SignedCertificate) -> [Char] -> m SignedCertificate
forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected: could not parse x509 cert: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Cursor -> [Char]
forall a. Show a => a -> [Char]
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 [Char] 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
      [] -> [Char] -> m (NonEmpty SignedCertificate)
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m (NonEmpty SignedCertificate))
-> [Char] -> m (NonEmpty SignedCertificate)
forall a b. (a -> b) -> a -> b
$ [Char]
"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
_edIssuer :: Issuer
_edRequestURI :: URI
_edCertAuthnResponse :: NonEmpty SignedCertificate
..}

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])
-> ([Node] -> [Node]) -> Either SomeException [Node] -> [Node]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> [Node]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [Node])
-> (SomeException -> [Char]) -> 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 -> [Char]
forall a. Show a => a -> [Char]
show) [Node] -> [Node]
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
        (Either SomeException [Node] -> [Node])
-> (SignedCertificate -> Either SomeException [Node])
-> 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
. (Document -> [Node])
-> Either SomeException Document -> Either SomeException [Node]
forall a b.
(a -> b) -> Either SomeException a -> Either SomeException b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HasCallStack => Document -> [Node]
Document -> [Node]
docToNodes
        (Either SomeException Document -> Either SomeException [Node])
-> (SignedCertificate -> Either SomeException Document)
-> SignedCertificate
-> Either 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
. 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 HS.AuthnRequest where
  importXml :: forall (m :: * -> *).
MonadError [Char] m =>
AuthnRequest -> m AuthnRequest
importXml = AuthnRequest -> m AuthnRequest
forall (m :: * -> *).
MonadError [Char] m =>
AuthnRequest -> m AuthnRequest
importAuthnRequest
  exportXml :: AuthnRequest -> AuthnRequest
exportXml = AuthnRequest -> AuthnRequest
exportAuthnRequest

instance HasXML AuthnRequest where
  parse :: forall (m :: * -> *).
MonadError [Char] m =>
[Node] -> m AuthnRequest
parse = (AuthnRequest -> m AuthnRequest) -> [Node] -> m AuthnRequest
forall (m :: * -> *) them us.
(HasCallStack, MonadError [Char] m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse AuthnRequest -> m AuthnRequest
forall (m :: * -> *).
MonadError [Char] 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 HS.NameIDPolicy where
  importXml :: forall (m :: * -> *).
MonadError [Char] m =>
NameIDPolicy -> m NameIdPolicy
importXml = NameIDPolicy -> m NameIdPolicy
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
NameIDPolicy -> m NameIdPolicy
importNameIDPolicy
  exportXml :: NameIdPolicy -> NameIDPolicy
exportXml = HasCallStack => NameIdPolicy -> NameIDPolicy
NameIdPolicy -> NameIDPolicy
exportNameIDPolicy

instance HasXMLImport AuthnResponse HS.Response where
  importXml :: forall (m :: * -> *).
MonadError [Char] m =>
Response -> m AuthnResponse
importXml = Response -> m AuthnResponse
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
Response -> m AuthnResponse
importAuthnResponse
  exportXml :: AuthnResponse -> Response
exportXml = HasCallStack => AuthnResponse -> Response
AuthnResponse -> Response
exportAuthnResponse

instance HasXML AuthnResponse where
  parse :: forall (m :: * -> *).
MonadError [Char] m =>
[Node] -> m AuthnResponse
parse = (Response -> m AuthnResponse) -> [Node] -> m AuthnResponse
forall (m :: * -> *) them us.
(HasCallStack, MonadError [Char] m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse Response -> m AuthnResponse
forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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 (HS.PossiblyEncrypted HS.Assertion) where
  importXml :: forall (m :: * -> *).
MonadError [Char] m =>
PossiblyEncrypted Assertion -> m Assertion
importXml = PossiblyEncrypted Assertion -> m Assertion
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
PossiblyEncrypted Assertion -> m Assertion
importAssertion
  exportXml :: Assertion -> PossiblyEncrypted Assertion
exportXml = HasCallStack => Assertion -> PossiblyEncrypted Assertion
Assertion -> PossiblyEncrypted Assertion
exportAssertion

instance HasXML Subject where
  parse :: forall (m :: * -> *). MonadError [Char] m => [Node] -> m Subject
parse = (Subject -> m Subject) -> [Node] -> m Subject
forall (m :: * -> *) them us.
(HasCallStack, MonadError [Char] m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse Subject -> m Subject
forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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 HS.Subject where
  importXml :: forall (m :: * -> *). MonadError [Char] m => Subject -> m Subject
importXml = Subject -> m Subject
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
Subject -> m Subject
importSubject
  exportXml :: Subject -> Subject
exportXml = HasCallStack => Subject -> Subject
Subject -> Subject
exportSubject

instance HasXMLImport SubjectConfirmationData HS.SubjectConfirmationData where
  importXml :: forall (m :: * -> *).
MonadError [Char] m =>
SubjectConfirmationData -> m SubjectConfirmationData
importXml = SubjectConfirmationData -> m SubjectConfirmationData
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
SubjectConfirmationData -> m SubjectConfirmationData
importSubjectConfirmationData
  exportXml :: SubjectConfirmationData -> SubjectConfirmationData
exportXml = HasCallStack => SubjectConfirmationData -> SubjectConfirmationData
SubjectConfirmationData -> SubjectConfirmationData
exportSubjectConfirmationData

instance HasXMLImport IP HS.IP where
  importXml :: forall (m :: * -> *). MonadError [Char] m => [Char] -> m IP
importXml = [Char] -> m IP
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
[Char] -> m IP
importIP
  exportXml :: IP -> [Char]
exportXml = HasCallStack => IP -> [Char]
IP -> [Char]
exportIP

instance HasXMLImport Conditions HS.Conditions where
  importXml :: forall (m :: * -> *).
MonadError [Char] m =>
Conditions -> m Conditions
importXml = Conditions -> m Conditions
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
Conditions -> m Conditions
importConditions
  exportXml :: Conditions -> Conditions
exportXml = HasCallStack => Conditions -> Conditions
Conditions -> Conditions
exportConditions

instance HasXML Conditions where
  parse :: forall (m :: * -> *). MonadError [Char] m => [Node] -> m Conditions
parse = (Conditions -> m Conditions) -> [Node] -> m Conditions
forall (m :: * -> *) them us.
(HasCallStack, MonadError [Char] m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse Conditions -> m Conditions
forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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) HS.Statement where
  importXml :: forall (m :: * -> *).
MonadError [Char] m =>
Statement -> m (Maybe Statement)
importXml = Statement -> m (Maybe Statement)
forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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 HS.SubjectLocality where
  importXml :: forall (m :: * -> *).
MonadError [Char] m =>
SubjectLocality -> m Locality
importXml = SubjectLocality -> m Locality
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
SubjectLocality -> m Locality
importLocality
  exportXml :: Locality -> SubjectLocality
exportXml = HasCallStack => Locality -> SubjectLocality
Locality -> SubjectLocality
exportLocality

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

instance HasXMLImport NameID HS.NameID where
  importXml :: forall (m :: * -> *). MonadError [Char] m => NameID -> m NameID
importXml = NameID -> m NameID
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
NameID -> m NameID
importNameID
  exportXml :: NameID -> NameID
exportXml = NameID -> NameID
exportNameID

instance HasXML NameID where
  parse :: forall (m :: * -> *). MonadError [Char] m => [Node] -> m NameID
parse = (NameID -> m NameID) -> [Node] -> m NameID
forall (m :: * -> *) them us.
(HasCallStack, MonadError [Char] m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse NameID -> m NameID
forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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 () HS.SAMLVersion where
  importXml :: forall (m :: * -> *). MonadError [Char] m => SAMLVersion -> m ()
importXml = SAMLVersion -> m ()
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
SAMLVersion -> m ()
importVersion
  exportXml :: () -> SAMLVersion
exportXml = \() -> SAMLVersion
HasCallStack => SAMLVersion
exportVersion

instance HasXMLImport Time HS.DateTime where
  importXml :: forall (m :: * -> *). MonadError [Char] m => UTCTime -> m Time
importXml = UTCTime -> m Time
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
UTCTime -> m Time
importTime
  exportXml :: Time -> UTCTime
exportXml = HasCallStack => Time -> UTCTime
Time -> UTCTime
exportTime

instance HasXMLImport URI HS.URI where
  importXml :: forall (m :: * -> *). MonadError [Char] m => AnyURI -> m URI
importXml = AnyURI -> m URI
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
AnyURI -> m URI
importURI
  exportXml :: URI -> AnyURI
exportXml = HasCallStack => URI -> AnyURI
URI -> AnyURI
exportURI

instance HasXMLImport Status HS.Status where
  importXml :: forall (m :: * -> *). MonadError [Char] 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 HS.Issuer where
  importXml :: forall (m :: * -> *). MonadError [Char] m => Issuer -> m Issuer
importXml = Issuer -> m Issuer
forall (m :: * -> *).
(HasCallStack, MonadError [Char] m) =>
Issuer -> m Issuer
importIssuer
  exportXml :: Issuer -> Issuer
exportXml = HasCallStack => Issuer -> Issuer
Issuer -> Issuer
exportIssuer

instance HasXML Issuer where
  parse :: forall (m :: * -> *). MonadError [Char] m => [Node] -> m Issuer
parse = (Issuer -> m Issuer) -> [Node] -> m Issuer
forall (m :: * -> *) them us.
(HasCallStack, MonadError [Char] m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse Issuer -> m Issuer
forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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 [Char] m => [Node] -> m SPMetadata
parse = (Metadata -> m SPMetadata) -> [Node] -> m SPMetadata
forall (m :: * -> *) them us.
(HasCallStack, MonadError [Char] m, XmlPickler them, HasXML us,
 Typeable us) =>
(them -> m us) -> [Node] -> m us
wrapParse Metadata -> m SPMetadata
forall (m :: * -> *).
(HasCallStack, MonadError [Char] 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 [Char] m =>
[Node] -> m IdPMetadata
parse [NodeElement Element
el] = Element -> m IdPMetadata
forall (m :: * -> *).
MonadError [Char] m =>
Element -> m IdPMetadata
parseIdPMetadata Element
el
  parse [Node]
bad = Proxy IdPMetadata -> [Node] -> m IdPMetadata
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] 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