module Network.Wai.SAML2.StatusCode (
StatusCode(..),
StatusCodeValue(..)
) where
import Control.Monad
import Data.Maybe
import qualified Data.Text as T
import Text.XML.Cursor
import Network.URI (URI, parseURI)
import Network.Wai.SAML2.XML
data StatusCode
= MkStatusCode {
StatusCode -> StatusCodeValue
statusCodeValue :: !StatusCodeValue,
StatusCode -> Maybe StatusCode
statusCodeSubordinate :: !(Maybe StatusCode)
}
deriving (StatusCode -> StatusCode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StatusCode -> StatusCode -> Bool
$c/= :: StatusCode -> StatusCode -> Bool
== :: StatusCode -> StatusCode -> Bool
$c== :: StatusCode -> StatusCode -> Bool
Eq, Int -> StatusCode -> ShowS
[StatusCode] -> ShowS
StatusCode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StatusCode] -> ShowS
$cshowList :: [StatusCode] -> ShowS
show :: StatusCode -> String
$cshow :: StatusCode -> String
showsPrec :: Int -> StatusCode -> ShowS
$cshowsPrec :: Int -> StatusCode -> ShowS
Show)
data StatusCodeValue
= Success
| Requester
| Responder
| VersionMismatch
| AuthnFailed
| InvalidAttrNameOrValue
| InvalidNameIDPolicy
| NoAuthnContext
| NoAvailableIDP
| NoPassive
| NoSupportedIDP
| PartialLogout
| ProxyCountExceeded
| RequestDenied
| RequestUnsupported
| RequestVersionDeprecated
| RequestVersionTooHigh
| RequestVersionTooLow
| ResourceNotRecognized
| TooManyResponses
| UnknownAttrProfile
| UnknownPrincipal
| UnsupportedBinding
| OtherStatus URI
deriving (StatusCodeValue -> StatusCodeValue -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StatusCodeValue -> StatusCodeValue -> Bool
$c/= :: StatusCodeValue -> StatusCodeValue -> Bool
== :: StatusCodeValue -> StatusCodeValue -> Bool
$c== :: StatusCodeValue -> StatusCodeValue -> Bool
Eq, Int -> StatusCodeValue -> ShowS
[StatusCodeValue] -> ShowS
StatusCodeValue -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StatusCodeValue] -> ShowS
$cshowList :: [StatusCodeValue] -> ShowS
show :: StatusCodeValue -> String
$cshow :: StatusCodeValue -> String
showsPrec :: Int -> StatusCodeValue -> ShowS
$cshowsPrec :: Int -> StatusCodeValue -> ShowS
Show)
instance FromXML StatusCode where
parseXML :: forall (m :: * -> *). MonadFail m => Cursor -> m StatusCode
parseXML = forall (m :: * -> *). MonadFail m => Bool -> Cursor -> m StatusCode
parseStatusCode Bool
True
parseStatusCode :: MonadFail m => Bool -> Cursor -> m StatusCode
parseStatusCode :: forall (m :: * -> *). MonadFail m => Bool -> Cursor -> m StatusCode
parseStatusCode Bool
isTopLevel Cursor
cursor = do
StatusCodeValue
statusCodeValue <- forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
"Value is a required attribute" forall a b. (a -> b) -> a -> b
$
Cursor
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/
Name -> Axis
element (Text -> Name
saml2pName Text
"Status") forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/
Name -> Axis
element (Text -> Name
saml2pName Text
"StatusCode") forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
forall (m :: * -> *).
MonadFail m =>
Bool -> Cursor -> m StatusCodeValue
parseStatusCodeValue Bool
isTopLevel
let statusCodeSubordinate :: Maybe StatusCode
statusCodeSubordinate = forall a. [a] -> Maybe a
listToMaybe (
Cursor
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/
Name -> Axis
element (Text -> Name
saml2pName Text
"Status") forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/
Name -> Axis
element (Text -> Name
saml2pName Text
"StatusCode")) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (m :: * -> *). MonadFail m => Bool -> Cursor -> m StatusCode
parseStatusCode Bool
False
forall (f :: * -> *) a. Applicative f => a -> f a
pure MkStatusCode{Maybe StatusCode
StatusCodeValue
statusCodeSubordinate :: Maybe StatusCode
statusCodeValue :: StatusCodeValue
statusCodeSubordinate :: Maybe StatusCode
statusCodeValue :: StatusCodeValue
..}
parseStatusCodeValue :: MonadFail m => Bool -> Cursor -> m StatusCodeValue
parseStatusCodeValue :: forall (m :: * -> *).
MonadFail m =>
Bool -> Cursor -> m StatusCodeValue
parseStatusCodeValue Bool
isTopLevel Cursor
cursor =
case [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"Value" Cursor
cursor of
Text
"urn:oasis:names:tc:SAML:2.0:status:Success" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
Success
Text
"urn:oasis:names:tc:SAML:2.0:status:Requester" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
Requester
Text
"urn:oasis:names:tc:SAML:2.0:status:Responder" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
Responder
Text
"urn:oasis:names:tc:SAML:2.0:status:VersionMismatch" ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
VersionMismatch
Text
"urn:oasis:names:tc:SAML:2.0:status:AuthnFailed" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
AuthnFailed
Text
"urn:oasis:names:tc:SAML:2.0:status:InvalidAttrNameOrValue" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
InvalidAttrNameOrValue
Text
"urn:oasis:names:tc:SAML:2.0:status:InvalidNameIDPolicy" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
InvalidNameIDPolicy
Text
"urn:oasis:names:tc:SAML:2.0:status:NoAuthnContext" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
NoAuthnContext
Text
"urn:oasis:names:tc:SAML:2.0:status:NoAvailableIDP" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
NoAvailableIDP
Text
"urn:oasis:names:tc:SAML:2.0:status:NoPassive" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
NoPassive
Text
"urn:oasis:names:tc:SAML:2.0:status:NoSupportedIDP" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
NoSupportedIDP
Text
"urn:oasis:names:tc:SAML:2.0:status:PartialLogout" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
PartialLogout
Text
"urn:oasis:names:tc:SAML:2.0:status:ProxyCountExceeded" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
ProxyCountExceeded
Text
"urn:oasis:names:tc:SAML:2.0:status:RequestDenied" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
RequestDenied
Text
"urn:oasis:names:tc:SAML:2.0:status:RequestUnsupported" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
RequestUnsupported
Text
"urn:oasis:names:tc:SAML:2.0:status:RequestVersionDeprecated" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
RequestVersionDeprecated
Text
"urn:oasis:names:tc:SAML:2.0:status:RequestVersionTooHigh" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
RequestVersionTooHigh
Text
"urn:oasis:names:tc:SAML:2.0:status:RequestVersionTooLow" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
RequestVersionTooLow
Text
"urn:oasis:names:tc:SAML:2.0:status:ResourceNotRecognized" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
ResourceNotRecognized
Text
"urn:oasis:names:tc:SAML:2.0:status:TooManyResponses" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
TooManyResponses
Text
"urn:oasis:names:tc:SAML:2.0:status:UnknownAttrProfile" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
UnknownAttrProfile
Text
"urn:oasis:names:tc:SAML:2.0:status:UnknownPrincipal" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
UnknownPrincipal
Text
"urn:oasis:names:tc:SAML:2.0:status:UnsupportedBinding" | Bool -> Bool
not Bool
isTopLevel ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
UnsupportedBinding
Text
uriString | Bool -> Bool
not Bool
isTopLevel -> case String -> Maybe URI
parseURI forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
uriString of
Maybe URI
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not a valid status code: " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
uriString
Just URI
uri -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ URI -> StatusCodeValue
OtherStatus URI
uri
Text
xs -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not a valid status code: " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
xs