{-# LANGUAGE LambdaCase #-}
module Network.Wai.SAML2.EntityDescriptor (
IDPSSODescriptor(..),
Binding(..)
) where
import qualified Data.ByteString.Base64 as Base64
import qualified Data.X509 as X509
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.Wai.SAML2.XML
import Text.XML.Cursor
data IDPSSODescriptor
= IDPSSODescriptor {
IDPSSODescriptor -> Text
entityID :: Text
, IDPSSODescriptor -> SignedExact Certificate
x509Certificate :: X509.SignedExact X509.Certificate
, IDPSSODescriptor -> [Text]
nameIDFormats :: [Text]
, IDPSSODescriptor -> [(Binding, Text)]
singleSignOnServices :: [(Binding, Text)]
} deriving Int -> IDPSSODescriptor -> ShowS
[IDPSSODescriptor] -> ShowS
IDPSSODescriptor -> String
(Int -> IDPSSODescriptor -> ShowS)
-> (IDPSSODescriptor -> String)
-> ([IDPSSODescriptor] -> ShowS)
-> Show IDPSSODescriptor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IDPSSODescriptor -> ShowS
showsPrec :: Int -> IDPSSODescriptor -> ShowS
$cshow :: IDPSSODescriptor -> String
show :: IDPSSODescriptor -> String
$cshowList :: [IDPSSODescriptor] -> ShowS
showList :: [IDPSSODescriptor] -> ShowS
Show
data Binding
= HTTPPost
| HTTPRedirect
| HTTPArtifact
| PAOS
| SOAP
| URLEncodingDEFLATE
deriving (Int -> Binding -> ShowS
[Binding] -> ShowS
Binding -> String
(Int -> Binding -> ShowS)
-> (Binding -> String) -> ([Binding] -> ShowS) -> Show Binding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Binding -> ShowS
showsPrec :: Int -> Binding -> ShowS
$cshow :: Binding -> String
show :: Binding -> String
$cshowList :: [Binding] -> ShowS
showList :: [Binding] -> ShowS
Show, Binding -> Binding -> Bool
(Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool) -> Eq Binding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Binding -> Binding -> Bool
== :: Binding -> Binding -> Bool
$c/= :: Binding -> Binding -> Bool
/= :: Binding -> Binding -> Bool
Eq)
instance FromXML IDPSSODescriptor where
parseXML :: forall (m :: * -> *). MonadFail m => Cursor -> m IDPSSODescriptor
parseXML Cursor
cursor = do
let entityID :: Text
entityID = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"entityID" Cursor
cursor
Cursor
descriptor <- String -> [Cursor] -> m Cursor
forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
"IDPSSODescriptor is required"
([Cursor] -> m Cursor) -> [Cursor] -> m Cursor
forall a b. (a -> b) -> a -> b
$ Cursor
cursor Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Cursor -> [Cursor]
element (Text -> Name
mdName Text
"IDPSSODescriptor")
Text
rawCertificate <- String -> [Text] -> m Text
forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
"X509Certificate is required" ([Text] -> m Text) -> [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ Cursor
descriptor
Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Cursor -> [Cursor]
element (Text -> Name
mdName Text
"KeyDescriptor")
(Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Cursor -> [Cursor]
element (Text -> Name
dsName Text
"KeyInfo")
(Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Cursor -> [Cursor]
element (Text -> Name
dsName Text
"X509Data")
(Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Cursor -> [Cursor]
element (Text -> Name
dsName Text
"X509Certificate")
(Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
content
SignedExact Certificate
x509Certificate <- (String -> m (SignedExact Certificate))
-> (SignedExact Certificate -> m (SignedExact Certificate))
-> Either String (SignedExact Certificate)
-> m (SignedExact Certificate)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m (SignedExact Certificate)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail SignedExact Certificate -> m (SignedExact Certificate)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either String (SignedExact Certificate)
-> m (SignedExact Certificate))
-> Either String (SignedExact Certificate)
-> m (SignedExact Certificate)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String (SignedExact Certificate)
forall a.
(Show a, Eq a, ASN1Object a) =>
ByteString -> Either String (SignedExact a)
X509.decodeSignedObject
(ByteString -> Either String (SignedExact Certificate))
-> ByteString -> Either String (SignedExact Certificate)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base64.decodeLenient
(ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
rawCertificate
let nameIDFormats :: [Text]
nameIDFormats = Cursor
descriptor
Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Cursor -> [Cursor]
element (Text -> Name
mdName Text
"NameIDFormat")
(Cursor -> [Cursor]) -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
content
[(Binding, Text)]
singleSignOnServices <- (Cursor -> m (Binding, Text)) -> [Cursor] -> m [(Binding, Text)]
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) -> [a] -> f [b]
traverse Cursor -> m (Binding, Text)
forall (m :: * -> *). MonadFail m => Cursor -> m (Binding, Text)
parseService
([Cursor] -> m [(Binding, Text)])
-> [Cursor] -> m [(Binding, Text)]
forall a b. (a -> b) -> a -> b
$ Cursor
descriptor Cursor -> (Cursor -> [Cursor]) -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Cursor -> [Cursor]
element (Text -> Name
mdName Text
"SingleSignOnService")
IDPSSODescriptor -> m IDPSSODescriptor
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IDPSSODescriptor{[(Binding, Text)]
[Text]
Text
SignedExact Certificate
entityID :: Text
x509Certificate :: SignedExact Certificate
nameIDFormats :: [Text]
singleSignOnServices :: [(Binding, Text)]
entityID :: Text
x509Certificate :: SignedExact Certificate
nameIDFormats :: [Text]
singleSignOnServices :: [(Binding, Text)]
..}
parseService :: MonadFail m => Cursor -> m (Binding, Text)
parseService :: forall (m :: * -> *). MonadFail m => Cursor -> m (Binding, Text)
parseService Cursor
cursor = do
Binding
binding <- String -> [Text] -> m Text
forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
"Binding is required" (Name -> Cursor -> [Text]
attribute Name
"Binding" Cursor
cursor)
m Text -> (Text -> m Binding) -> m Binding
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> m Binding
forall (m :: * -> *). MonadFail m => Text -> m Binding
parseBinding
Text
location <- String -> [Text] -> m Text
forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
"Location is required" ([Text] -> m Text) -> [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"Location" Cursor
cursor
(Binding, Text) -> m (Binding, Text)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding
binding, Text
location)
parseBinding :: MonadFail m => Text -> m Binding
parseBinding :: forall (m :: * -> *). MonadFail m => Text -> m Binding
parseBinding = \case
Text
"urn:oasis:names:tc:SAML:2.0:bindings:HTTP-Artifact" -> Binding -> m Binding
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Binding
HTTPArtifact
Text
"urn:oasis:names:tc:SAML:2.0:bindings:HTTP-POST" -> Binding -> m Binding
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Binding
HTTPPost
Text
"urn:oasis:names:tc:SAML:2.0:bindings:HTTP-Redirect" -> Binding -> m Binding
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Binding
HTTPRedirect
Text
"urn:oasis:names:tc:SAML:2.0:bindings:PAOS" -> Binding -> m Binding
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Binding
PAOS
Text
"urn:oasis:names:tc:SAML:2.0:bindings:SOAP" -> Binding -> m Binding
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Binding
SOAP
Text
"urn:oasis:names:tc:SAML:2.0:bindings:URL-Encoding:DEFLATE"
-> Binding -> m Binding
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Binding
URLEncodingDEFLATE
Text
other -> String -> m Binding
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Binding) -> String -> m Binding
forall a b. (a -> b) -> a -> b
$ String
"Unknown Binding: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
other