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