-------------------------------------------------------------------------------
-- 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.                           --
-------------------------------------------------------------------------------

-- | Defines types and functions for SP-initiated SSO. Use `issueAuthnRequest`
-- to initialise an `AuthnRequest` value which stores the parameters for the
-- authentication request you wish to issue to the IdP. You can update this
-- value as required.
--
-- Use `renderBase64` to render the request for use with a HTTP POST binding [1], or
-- `renderUrlEncodingDeflate` for HTTP redirect binding[2] respectively.
-- You may wish to read
-- the [SAML2 overview for this process](http://docs.oasis-open.org/security/saml/Post2.0/sstc-saml-tech-overview-2.0-cd-02.html#5.1.2.SP-Initiated%20SSO:%20%20Redirect/POST%20Bindings|outline).
--
-- * [1] https://docs.oasis-open.org/security/saml/v2.0/saml-bindings-2.0-os.pdf#page=21
--   Section 3.5 HTTP POST Binding
-- * [2] https://docs.oasis-open.org/security/saml/v2.0/saml-bindings-2.0-os.pdf#page=15
--   Section 3.4 HTTP Redirect Binding
--
-- @since 0.4
module Network.Wai.SAML2.Request (
    AuthnRequest(..),
    issueAuthnRequest,
    renderBase64,
    renderUrlEncodingDeflate,
    renderXML,
) where

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

import Crypto.Random

import Data.Time.Clock

import Network.Wai.SAML2.NameIDFormat
import Network.Wai.SAML2.XML

import Text.XML

import qualified Codec.Compression.Zlib.Raw as Deflate
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Types (urlEncode)

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

-- | Parameters for SP-initiated SSO
data AuthnRequest
    -- Reference [AuthnRequest]
    = AuthnRequest {
        -- | The time at which 'AuthnRequest' was created.
        AuthnRequest -> UTCTime
authnRequestTimestamp :: !UTCTime
        -- | Unique identifier for 'AuthnRequest' which should be preserved
        -- by the IdP in its response.
    ,   AuthnRequest -> Text
authnRequestID :: !T.Text
        -- | SP Entity ID
    ,   AuthnRequest -> Text
authnRequestIssuer :: !T.Text
        -- | The URI reference to which this request is to be sent. Required
        -- for signed requests
        --
        -- @since 0.5
    ,   AuthnRequest -> Maybe Text
authnRequestDestination :: !(Maybe T.Text)
        -- | Allow IdP to generate a new identifier
    ,   AuthnRequest -> Bool
authnRequestAllowCreate :: !Bool
        -- | The URI reference corresponding to a name identifier format
    ,   AuthnRequest -> NameIDFormat
authnRequestNameIDFormat :: !NameIDFormat
    }
    deriving (AuthnRequest -> AuthnRequest -> Bool
(AuthnRequest -> AuthnRequest -> Bool)
-> (AuthnRequest -> AuthnRequest -> Bool) -> Eq AuthnRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AuthnRequest -> AuthnRequest -> Bool
== :: AuthnRequest -> AuthnRequest -> Bool
$c/= :: AuthnRequest -> AuthnRequest -> Bool
/= :: AuthnRequest -> AuthnRequest -> Bool
Eq, Int -> AuthnRequest -> ShowS
[AuthnRequest] -> ShowS
AuthnRequest -> String
(Int -> AuthnRequest -> ShowS)
-> (AuthnRequest -> String)
-> ([AuthnRequest] -> ShowS)
-> Show AuthnRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AuthnRequest -> ShowS
showsPrec :: Int -> AuthnRequest -> ShowS
$cshow :: AuthnRequest -> String
show :: AuthnRequest -> String
$cshowList :: [AuthnRequest] -> ShowS
showList :: [AuthnRequest] -> ShowS
Show)

-- | Creates a default 'AuthnRequest' with the current timestamp and a
-- randomly-generated ID.
issueAuthnRequest
    :: T.Text -- ^ SP Entity ID
    -> IO AuthnRequest
issueAuthnRequest :: Text -> IO AuthnRequest
issueAuthnRequest Text
authnRequestIssuer = do
    UTCTime
authnRequestTimestamp <- IO UTCTime
getCurrentTime
    -- Digits are not allowed in initial position
    -- Reference [ID Values]
    Text
authnRequestID <- (Text
"id" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
forall byteArray. ByteArray byteArray => Int -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
16
    AuthnRequest -> IO AuthnRequest
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthnRequest{
        authnRequestAllowCreate :: Bool
authnRequestAllowCreate = Bool
True
    ,   authnRequestNameIDFormat :: NameIDFormat
authnRequestNameIDFormat = NameIDFormat
Transient
    ,   authnRequestDestination :: Maybe Text
authnRequestDestination = Maybe Text
forall a. Maybe a
Nothing
    ,   Text
UTCTime
authnRequestTimestamp :: UTCTime
authnRequestID :: Text
authnRequestIssuer :: Text
authnRequestIssuer :: Text
authnRequestTimestamp :: UTCTime
authnRequestID :: Text
..
    }

-- | Renders an `AuthnRequest` for SP initiated SSO according to
-- @urn:oasis:names:tc:SAML:2.0:bindings:URL-Encoding:DEFLATE@ and suitable for
-- use with HTTP Redirect binding
--
-- The value should be sent as a query parameter named @SAMLRequest@
renderUrlEncodingDeflate :: AuthnRequest -> B.ByteString
renderUrlEncodingDeflate :: AuthnRequest -> ByteString
renderUrlEncodingDeflate AuthnRequest
request =
    Bool -> ByteString -> ByteString
urlEncode Bool
True (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Deflate.compress (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthnRequest -> ByteString
renderXML AuthnRequest
request

-- | Renders and base64-encodes an `AuthnRequest` for SP initiated SSO suitable
-- for use with HTTP POST binding
--
-- If used in an HTTP POST binding, the value should be sent as an invisible
-- form control named @SAMLRequest@
renderBase64 :: AuthnRequest -> B.ByteString
renderBase64 :: AuthnRequest -> ByteString
renderBase64 AuthnRequest
request = ByteString -> ByteString
Base64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthnRequest -> ByteString
renderXML AuthnRequest
request

-- | Render an `AuthnRequest` as XML
renderXML :: AuthnRequest -> BL.ByteString
renderXML :: AuthnRequest -> ByteString
renderXML AuthnRequest{Bool
Maybe Text
Text
UTCTime
NameIDFormat
authnRequestTimestamp :: AuthnRequest -> UTCTime
authnRequestID :: AuthnRequest -> Text
authnRequestIssuer :: AuthnRequest -> Text
authnRequestDestination :: AuthnRequest -> Maybe Text
authnRequestAllowCreate :: AuthnRequest -> Bool
authnRequestNameIDFormat :: AuthnRequest -> NameIDFormat
authnRequestTimestamp :: UTCTime
authnRequestID :: Text
authnRequestIssuer :: Text
authnRequestDestination :: Maybe Text
authnRequestAllowCreate :: Bool
authnRequestNameIDFormat :: NameIDFormat
..} =
    RenderSettings -> Document -> ByteString
renderLBS RenderSettings
forall a. Default a => a
def (Document -> ByteString) -> Document -> ByteString
forall a b. (a -> b) -> a -> b
$
    -- Reference [HTTP redirect binding]
    Document{
        documentPrologue :: Prologue
documentPrologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
Prologue [] Maybe Doctype
forall a. Maybe a
Nothing []
    ,   documentRoot :: Element
documentRoot = Element
root
    ,   documentEpilogue :: [Miscellaneous]
documentEpilogue = []
    }
    where
        timestamp :: Text
timestamp = UTCTime -> Text
showUTCTime UTCTime
authnRequestTimestamp
        root :: Element
root = Name -> Map Name Text -> [Node] -> Element
Element
            (Text -> Name
saml2pName Text
"AuthnRequest")
            ([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
               ([ (Name
"xmlns:samlp", Text
"urn:oasis:names:tc:SAML:2.0:protocol")
                , (Name
"xmlns:saml", Text
"urn:oasis:names:tc:SAML:2.0:assertion")
                , (Name
"ID", Text
authnRequestID) -- Reference [RequestAbstractType] and see [ID Values]
                , (Name
"Version", Text
"2.0")  -- [RequestAbstractType]
                , (Name
"IssueInstant", Text
timestamp) -- [RequestAbstractType]
                , (Name
"AssertionConsumerServiceIndex", Text
"1") -- [AuthnRequest]
                ]
                -- [RequestAbstractType]
                [(Name, Text)] -> [(Name, Text)] -> [(Name, Text)]
forall a. [a] -> [a] -> [a]
++ [(Name
"Destination", Text
uri) | let Just Text
uri = Maybe Text
authnRequestDestination] ))
            [Element -> Node
NodeElement Element
issuer, Element -> Node
NodeElement Element
nameIdPolicy]
        -- Reference [RequestAbstractType]
        issuer :: Element
issuer = Name -> Map Name Text -> [Node] -> Element
Element
            (Text -> Name
saml2Name Text
"Issuer")
            Map Name Text
forall a. Monoid a => a
mempty
            [Text -> Node
NodeContent Text
authnRequestIssuer]
        -- Reference [AuthnRequest]
        nameIdPolicy :: Element
nameIdPolicy = Name -> Map Name Text -> [Node] -> Element
Element
            (Text -> Name
saml2pName Text
"NameIDPolicy")
            ([(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ (Name
"allowCreate"
                    , if Bool
authnRequestAllowCreate then Text
"true" else Text
"false")
                , (Name
"Format", NameIDFormat -> Text
showNameIDFormat NameIDFormat
authnRequestNameIDFormat)
                ])
            []

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

-- Reference [RequestAbstractType]
-- Source: https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf#page=36
-- Section: 3.2.1 Complex Type RequestAbstractType

-- Reference [AuthnRequest]
-- Source: https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf#page=48
-- Section: 3.4.1 Element <AuthnRequest>

-- Reference [HTTP redirect binding]
-- Source:
-- https://docs.oasis-open.org/security/saml/v2.0/saml-bindings-2.0-os.pdf#page=15
-- Section: 3.4 HTTP Redirect Binding

-- Reference [ID Values]
-- Source: https://docs.oasis-open.org/security/saml/v2.0/saml-core-2.0-os.pdf#page=9
-- Section: 1.3.4 ID and ID Reference Values
-- Note: ID Values must conform to "xs:ID", which in turn has a restriction of "xs:NCName" (non-colonized name).
-- In practice that means they are a string consisting of
-- first 1 of: Letter or '_'
-- then 0 or more of: Letter, Digit, '.', '-', '_',  CombiningChar, Extender
--
-- Definitions of character classes: https://www.w3.org/TR/2000/WD-xml-2e-20000814#CharClasses
-- Compare e.g. https://stackoverflow.com/questions/1631396/what-is-an-xsncname-type-and-when-should-it-be-used
--and https://www.w3.org/TR/xmlschema-2/#dt-ccesN (see \i and \c, bute not that colons are excluded)