module Network.Wai.SAML2.Response (
Response(..),
removeSignature,
extractSignedInfo,
extractPrefixList,
module Network.Wai.SAML2.StatusCode,
module Network.Wai.SAML2.Signature
) where
import Data.Maybe (listToMaybe)
import qualified Data.Text as T
import Data.Time
import Text.XML
import Text.XML.Cursor
import Network.Wai.SAML2.Assertion
import Network.Wai.SAML2.XML
import Network.Wai.SAML2.XML.Encrypted
import Network.Wai.SAML2.StatusCode
import Network.Wai.SAML2.Signature
data Response = Response {
Response -> Text
responseDestination :: !T.Text,
Response -> Maybe Text
responseInResponseTo :: !(Maybe T.Text),
Response -> Text
responseId :: !T.Text,
Response -> UTCTime
responseIssueInstant :: !UTCTime,
Response -> Text
responseVersion :: !T.Text,
Response -> Text
responseIssuer :: !T.Text,
Response -> StatusCode
responseStatusCode :: !StatusCode,
Response -> Signature
responseSignature :: !Signature,
Response -> Maybe Assertion
responseAssertion :: !(Maybe Assertion),
Response -> Maybe EncryptedAssertion
responseEncryptedAssertion :: !(Maybe EncryptedAssertion)
} deriving (Response -> Response -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Response -> Response -> Bool
$c/= :: Response -> Response -> Bool
== :: Response -> Response -> Bool
$c== :: Response -> Response -> Bool
Eq, Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> String
$cshow :: Response -> String
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show)
instance FromXML Response where
parseXML :: forall (m :: * -> *). MonadFail m => Cursor -> m Response
parseXML Cursor
cursor = do
UTCTime
issueInstant <- forall (m :: * -> *). MonadFail m => Text -> m UTCTime
parseUTCTime
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"IssueInstant" Cursor
cursor
StatusCode
statusCode <- case forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
parseXML Cursor
cursor of
Maybe StatusCode
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid status code"
Just StatusCode
sc -> forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCode
sc
let assertion :: Maybe Assertion
assertion = forall a. [a] -> Maybe a
listToMaybe
forall a b. (a -> b) -> a -> b
$ ( Cursor
cursor
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"Assertion")
) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
parseXML
let encAssertion :: Maybe EncryptedAssertion
encAssertion = forall a. [a] -> Maybe a
listToMaybe
forall a b. (a -> b) -> a -> b
$ ( Cursor
cursor
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"EncryptedAssertion")
) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
parseXML
Signature
signature <- forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
"Signature is required" (
Cursor
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
dsName Text
"Signature") ) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *). (FromXML a, MonadFail m) => Cursor -> m a
parseXML
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response{
responseDestination :: Text
responseDestination = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"Destination" Cursor
cursor,
responseId :: Text
responseId = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"ID" Cursor
cursor,
responseInResponseTo :: Maybe Text
responseInResponseTo = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"InResponseTo" Cursor
cursor,
responseIssueInstant :: UTCTime
responseIssueInstant = UTCTime
issueInstant,
responseVersion :: Text
responseVersion = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"Version" Cursor
cursor,
responseIssuer :: Text
responseIssuer = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$
Cursor
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
saml2Name Text
"Issuer") forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
content,
responseStatusCode :: StatusCode
responseStatusCode = StatusCode
statusCode,
responseSignature :: Signature
responseSignature = Signature
signature,
responseAssertion :: Maybe Assertion
responseAssertion = Maybe Assertion
assertion,
responseEncryptedAssertion :: Maybe EncryptedAssertion
responseEncryptedAssertion = Maybe EncryptedAssertion
encAssertion
}
isNotSignature :: Node -> Bool
isNotSignature :: Node -> Bool
isNotSignature (NodeElement Element
e) = Element -> Name
elementName Element
e forall a. Eq a => a -> a -> Bool
/= Text -> Name
dsName Text
"Signature"
isNotSignature Node
_ = Bool
True
removeSignature :: Document -> Document
removeSignature :: Document -> Document
removeSignature (Document Prologue
prologue Element
root [Miscellaneous]
misc) =
let Element Name
n Map Name Text
attr [Node]
ns = Element
root
in Prologue -> Element -> [Miscellaneous] -> Document
Document Prologue
prologue (Name -> Map Name Text -> [Node] -> Element
Element Name
n Map Name Text
attr (forall a. (a -> Bool) -> [a] -> [a]
filter Node -> Bool
isNotSignature [Node]
ns)) [Miscellaneous]
misc
nodes :: MonadFail m => Cursor -> m Node
nodes :: forall (m :: * -> *). MonadFail m => Cursor -> m Node
nodes = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall node. Cursor node -> node
node
extractSignedInfo :: MonadFail m => Cursor -> m Element
Cursor
cursor = do
NodeElement Element
signedInfo <- forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
"SignedInfo is required"
( Cursor
cursor
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
dsName Text
"Signature")
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Axis
element (Text -> Name
dsName Text
"SignedInfo")
) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadFail m => Cursor -> m Node
nodes
forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
signedInfo
extractPrefixList :: Cursor -> [T.Text]
Cursor
cursor = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
T.words
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Cursor -> [Text]
attribute Name
"PrefixList")
forall a b. (a -> b) -> a -> b
$ Cursor
cursor
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
dsName Text
"Reference")
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Axis
element (Text -> Name
dsName Text
"Transforms")
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Axis
element (Text -> Name
dsName Text
"Transform")
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Name -> Axis
element (Text -> Name
ecName Text
"InclusiveNamespaces")