--------------------------------------------------------------------------------
-- SAML2 Middleware for WAI                                                   --
--------------------------------------------------------------------------------
-- This source code is licensed under the MIT license found in the LICENSE    --
-- file in the root directory of this source tree.                            --
--------------------------------------------------------------------------------

-- | The SAML2 specification distinguishes between the topmost status code,
-- which is required and must contain a status value from a specific list of
-- status codes, and subordinate status codes, which are optional and may
-- contain arbitrary URIs.
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

--------------------------------------------------------------------------------

-- | Represents SAML2 status codes, which are comprised of a status value
-- and an optional, subordinate status.
data StatusCode
    = MkStatusCode {
        -- | The status code value.
        StatusCode -> StatusCodeValue
statusCodeValue :: !StatusCodeValue,
        -- | An optional, subordinate status code.
        StatusCode -> Maybe StatusCode
statusCodeSubordinate :: !(Maybe StatusCode)
    }
    deriving (StatusCode -> StatusCode -> Bool
(StatusCode -> StatusCode -> Bool)
-> (StatusCode -> StatusCode -> Bool) -> Eq StatusCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StatusCode -> StatusCode -> Bool
== :: StatusCode -> StatusCode -> Bool
$c/= :: StatusCode -> StatusCode -> Bool
/= :: StatusCode -> StatusCode -> Bool
Eq, Int -> StatusCode -> ShowS
[StatusCode] -> ShowS
StatusCode -> String
(Int -> StatusCode -> ShowS)
-> (StatusCode -> String)
-> ([StatusCode] -> ShowS)
-> Show StatusCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StatusCode -> ShowS
showsPrec :: Int -> StatusCode -> ShowS
$cshow :: StatusCode -> String
show :: StatusCode -> String
$cshowList :: [StatusCode] -> ShowS
showList :: [StatusCode] -> ShowS
Show)

-- | Enumerates SAML2 status code values.
--
-- @since 0.4
data StatusCodeValue
    -- | The response indicates success!
    = Success
    -- | The request could not be performed due to an error on the part of the
    -- requester.
    | Requester
    -- | The request could not be performed due to an error on the part of the
    -- SAML responder or SAML authority.
    | Responder
    -- | The SAML responder could not process the request because the version
    -- of the request message was incorrect.
    | VersionMismatch
    -- | The responding provider was unable to successfully authenticate the
    -- principal.
    | AuthnFailed
    -- | Unexpected or invalid content was encountered within a
    -- @\<saml:Attribute\>@ or @\<saml:AttributeValue\>@ element.
    | InvalidAttrNameOrValue
    -- | The responding provider cannot or will not support the requested name
    -- identifier policy.
    | InvalidNameIDPolicy
    -- | The specified authentication context requirements cannot be met by the
    -- responder.
    | NoAuthnContext
    -- | Used by an intermediary to indicate that none of the supported
    -- identity provider @\<Loc\>@ elements in an @\<IDPList\>@ can be resolved
    -- or that none of the supported identity providers are available.
    | NoAvailableIDP
    -- | Indicates the responding provider cannot authenticate the principal
    -- passively, as has been requested.
    | NoPassive
    -- | Used by an intermediary to indicate that none of the identity
    -- providers in an @\<IDPList\>@ are supported by the intermediary.
    | NoSupportedIDP
    -- | Used by a session authority to indicate to a session participant that
    -- it was not able to propagate logout to all other session participants.
    | PartialLogout
    -- | Indicates that a responding provider cannot authenticate the principal
    -- directly and is not permitted to proxy the request further.
    | ProxyCountExceeded
    -- | The SAML responder or SAML authority is able to process the request
    -- but has chosen not to respond. This status code MAY be used when there
    -- is concern about the security context of the request message or the
    -- sequence of request messages received from a particular requester.
    | RequestDenied
    -- | The SAML responder or SAML authority does not support the request.
    | RequestUnsupported
    -- | The SAML responder cannot process any requests with the protocol
    --  version specified in the request.
    | RequestVersionDeprecated
    -- | The SAML responder cannot process the request because the protocol
    -- version specified in the request message is a major upgrade from the
    -- highest protocol version supported by the responder.
    | RequestVersionTooHigh
    -- | The SAML responder cannot process the request because the protocol
    -- version specified in the request message is too low.
    | RequestVersionTooLow
    -- | The resource value provided in the request message is invalid or
    -- unrecognized.
    | ResourceNotRecognized
    -- | The response message would contain more elements than the SAML
    -- responder is able to return.
    | TooManyResponses
    -- | An entity that has no knowledge of a particular attribute profile
    -- has been presented with an attribute drawn from that profile.
    | UnknownAttrProfile
    -- | The responding provider does not recognize the principal specified
    -- or implied by the request.
    | UnknownPrincipal
    -- | The SAML responder cannot properly fulfil the request using the
    -- protocol binding specified in the request.
    | UnsupportedBinding
    -- | The SAML2 specification notes that a status code value can be any
    -- valid URI and that additional subordinate status codes may be
    -- introduced in the future.
    | OtherStatus URI
    deriving (StatusCodeValue -> StatusCodeValue -> Bool
(StatusCodeValue -> StatusCodeValue -> Bool)
-> (StatusCodeValue -> StatusCodeValue -> Bool)
-> Eq StatusCodeValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StatusCodeValue -> StatusCodeValue -> Bool
== :: StatusCodeValue -> StatusCodeValue -> Bool
$c/= :: StatusCodeValue -> StatusCodeValue -> Bool
/= :: StatusCodeValue -> StatusCodeValue -> Bool
Eq, Int -> StatusCodeValue -> ShowS
[StatusCodeValue] -> ShowS
StatusCodeValue -> String
(Int -> StatusCodeValue -> ShowS)
-> (StatusCodeValue -> String)
-> ([StatusCodeValue] -> ShowS)
-> Show StatusCodeValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StatusCodeValue -> ShowS
showsPrec :: Int -> StatusCodeValue -> ShowS
$cshow :: StatusCodeValue -> String
show :: StatusCodeValue -> String
$cshowList :: [StatusCodeValue] -> ShowS
showList :: [StatusCodeValue] -> ShowS
Show)

instance FromXML StatusCode where
    parseXML :: forall (m :: * -> *). MonadFail m => Cursor -> m StatusCode
parseXML = Bool -> Cursor -> m StatusCode
forall (m :: * -> *). MonadFail m => Bool -> Cursor -> m StatusCode
parseStatusCode Bool
True

-- | `parseStatusCode` @isTopLevel cursor@ attempts to parse a @<StatusCode>@
-- element from the XML @cursor@. The SAML2 specification distinguishes
-- between the topmost status code, which is required and must contain a
-- status value from a specific list of status codes, and subordinate status
-- codes. The @isTopLevel@ value indicates whether we are parsing a top-level
-- @<StatusCode>@ element or not and therefore controls which status codes
-- values we accept as valid.
--
-- @since 0.4
parseStatusCode :: MonadFail m => Bool -> Cursor -> m StatusCode
parseStatusCode :: forall (m :: * -> *). MonadFail m => Bool -> Cursor -> m StatusCode
parseStatusCode Bool
isTopLevel Cursor
cursor = do
    StatusCodeValue
statusCodeValue <- String -> [StatusCodeValue] -> m StatusCodeValue
forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
"Value is a required attribute" ([StatusCodeValue] -> m StatusCodeValue)
-> [StatusCodeValue] -> m StatusCodeValue
forall a b. (a -> b) -> a -> b
$
        Cursor
cursor Cursor -> (Cursor -> [StatusCodeValue]) -> [StatusCodeValue]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/
            Name -> Axis
element (Text -> Name
saml2pName Text
"Status") Axis
-> (Cursor -> [StatusCodeValue]) -> Cursor -> [StatusCodeValue]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/
            Name -> Axis
element (Text -> Name
saml2pName Text
"StatusCode") Axis
-> (Cursor -> [StatusCodeValue]) -> Cursor -> [StatusCodeValue]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
            Bool -> Cursor -> [StatusCodeValue]
forall (m :: * -> *).
MonadFail m =>
Bool -> Cursor -> m StatusCodeValue
parseStatusCodeValue Bool
isTopLevel
    let statusCodeSubordinate :: Maybe StatusCode
statusCodeSubordinate = [Cursor] -> Maybe Cursor
forall a. [a] -> Maybe a
listToMaybe (
            Cursor
cursor Cursor -> Axis -> [Cursor]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/
                Name -> Axis
element (Text -> Name
saml2pName Text
"Status") Axis -> Axis -> Axis
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/
                Name -> Axis
element (Text -> Name
saml2pName Text
"StatusCode")) Maybe Cursor -> (Cursor -> Maybe StatusCode) -> Maybe StatusCode
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                Bool -> Cursor -> Maybe StatusCode
forall (m :: * -> *). MonadFail m => Bool -> Cursor -> m StatusCode
parseStatusCode Bool
False

    StatusCode -> m StatusCode
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MkStatusCode{Maybe StatusCode
StatusCodeValue
statusCodeValue :: StatusCodeValue
statusCodeSubordinate :: Maybe StatusCode
statusCodeValue :: StatusCodeValue
statusCodeSubordinate :: Maybe StatusCode
..}

-- | `parseStatusCodeValue` @isTopLevel cursor@ attempts to parse a status code
-- value from the XML @cursor@. The @isTopLevel@ value determines which values
-- we permit as valid status code values. See the note for `parseStatusCode`.
--
-- @since 0.4
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 ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Cursor -> [Text]
attribute Name
"Value" Cursor
cursor of
        -- the following status codes are always permitted
        Text
"urn:oasis:names:tc:SAML:2.0:status:Success" -> StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
Success
        Text
"urn:oasis:names:tc:SAML:2.0:status:Requester" -> StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
Requester
        Text
"urn:oasis:names:tc:SAML:2.0:status:Responder" -> StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
Responder
        Text
"urn:oasis:names:tc:SAML:2.0:status:VersionMismatch" ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
VersionMismatch
        -- the following are only permitted for subordinate elements
        Text
"urn:oasis:names:tc:SAML:2.0:status:AuthnFailed" | Bool -> Bool
not Bool
isTopLevel ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
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 ->
            StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StatusCodeValue
UnsupportedBinding
        Text
uriString | Bool -> Bool
not Bool
isTopLevel -> case String -> Maybe URI
parseURI (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
uriString of
            Maybe URI
Nothing -> String -> m StatusCodeValue
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m StatusCodeValue) -> String -> m StatusCodeValue
forall a b. (a -> b) -> a -> b
$ String
"Not a valid status code: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
uriString
            Just URI
uri -> StatusCodeValue -> m StatusCodeValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StatusCodeValue -> m StatusCodeValue)
-> StatusCodeValue -> m StatusCodeValue
forall a b. (a -> b) -> a -> b
$ URI -> StatusCodeValue
OtherStatus URI
uri
        -- not a valid URI or a status code that's not supported at the
        -- top-level
        Text
xs -> String -> m StatusCodeValue
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m StatusCodeValue) -> String -> m StatusCodeValue
forall a b. (a -> b) -> a -> b
$ String
"Not a valid status code: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
xs

--------------------------------------------------------------------------------