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

-- | Utility functions related to XML parsing.
module Network.Wai.SAML2.XML (
    -- * Namespaces
    saml2Name,
    saml2pName,
    xencName,
    dsName,
    mdName,
    ecName,

    -- * Utility functions
    toMaybeText,
    showUTCTime,
    parseUTCTime,

    -- * XML parsing
    FromXML(..),
    oneOrFail,
    parseSettings
) where

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

import qualified Data.Text as T
import Data.Time
import Data.Time.Format.ISO8601 (iso8601ParseM)

import Text.XML
import Text.XML.Cursor

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

-- | 'saml2Name' @name@ constructs a 'Name' for @name@ in the
-- urn:oasis:names:tc:SAML:2.0:assertion namespace.
saml2Name :: T.Text -> Name
saml2Name :: Text -> Name
saml2Name Text
name =
    Text -> Maybe Text -> Maybe Text -> Name
Name Text
name (forall a. a -> Maybe a
Just Text
"urn:oasis:names:tc:SAML:2.0:assertion") (forall a. a -> Maybe a
Just Text
"saml2")

-- | 'saml2pName' @name@ constructs a 'Name' for @name@ in the
-- urn:oasis:names:tc:SAML:2.0:protocol namespace.
saml2pName :: T.Text -> Name
saml2pName :: Text -> Name
saml2pName Text
name =
    Text -> Maybe Text -> Maybe Text -> Name
Name Text
name (forall a. a -> Maybe a
Just Text
"urn:oasis:names:tc:SAML:2.0:protocol") (forall a. a -> Maybe a
Just Text
"saml2p")

-- | 'xencName' @name@ constructs a 'Name' for @name@ in the
-- http://www.w3.org/2001/04/xmlenc# namespace.
xencName :: T.Text -> Name
xencName :: Text -> Name
xencName Text
name =
    Text -> Maybe Text -> Maybe Text -> Name
Name Text
name (forall a. a -> Maybe a
Just Text
"http://www.w3.org/2001/04/xmlenc#") (forall a. a -> Maybe a
Just Text
"xenc")

-- | 'dsName' @name@ constructs a 'Name' for @name@ in the
-- http://www.w3.org/2000/09/xmldsig# namespace.
dsName :: T.Text -> Name
dsName :: Text -> Name
dsName Text
name =
    Text -> Maybe Text -> Maybe Text -> Name
Name Text
name (forall a. a -> Maybe a
Just Text
"http://www.w3.org/2000/09/xmldsig#") (forall a. a -> Maybe a
Just Text
"ds")

-- | `mdName` @name@ constructs a `Name` for @name@ in the
-- @urn:oasis:names:tc:SAML:2.0:metadata@ namespace.
mdName :: T.Text -> Name
mdName :: Text -> Name
mdName Text
name =
    Text -> Maybe Text -> Maybe Text -> Name
Name Text
name (forall a. a -> Maybe a
Just Text
"urn:oasis:names:tc:SAML:2.0:metadata") (forall a. a -> Maybe a
Just Text
"md")


-- | 'ecName' @name@ constructs a 'Name' for @name@ in the
-- http://www.w3.org/2001/10/xml-exc-c14n# namespace.
--
-- @since 0.5
ecName :: T.Text -> Name
ecName :: Text -> Name
ecName Text
name =
    Text -> Maybe Text -> Maybe Text -> Name
Name Text
name (forall a. a -> Maybe a
Just Text
"http://www.w3.org/2001/10/xml-exc-c14n#") (forall a. a -> Maybe a
Just Text
"ec")

-- | 'toMaybeText' @xs@ returns 'Nothing' if @xs@ is the empty list, or
-- the result of concatenating @xs@ wrapped in 'Just' otherwise.
toMaybeText :: [T.Text] -> Maybe T.Text
toMaybeText :: [Text] -> Maybe Text
toMaybeText [] = forall a. Maybe a
Nothing
toMaybeText [Text]
xs = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text]
xs

-- | The time format used by SAML2.
timeFormat :: String
timeFormat :: String
timeFormat = String
"%Y-%m-%dT%H:%M:%S%6QZ"

-- | Display a 'UTCTime' as an ISO8601 timestamp including up to
-- 6 digits for the microseconds.
--
-- @since 0.4.0.0
--
showUTCTime :: UTCTime -> T.Text
showUTCTime :: UTCTime -> Text
showUTCTime = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
timeFormat

-- | 'parseUTCTime' @text@ parses @text@ into a 'UTCTime' value.
parseUTCTime :: MonadFail m => T.Text -> m UTCTime
parseUTCTime :: forall (m :: * -> *). MonadFail m => Text -> m UTCTime
parseUTCTime = forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
iso8601ParseM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

-- | A class of types which can be parsed from XML.
class FromXML a where
    parseXML :: MonadFail m => Cursor -> m a

-- | 'oneOrFail' @message xs@ throws an 'XMLException' with @message@ if
-- @xs@ is the empty list. If @xs@ has at least one element, the first is
-- returned and all others are discarded.
oneOrFail :: MonadFail m => String -> [a] -> m a
oneOrFail :: forall (m :: * -> *) a. MonadFail m => String -> [a] -> m a
oneOrFail String
err [] = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
oneOrFail String
_ (a
x:[a]
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

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

-- | It is important to retain namespaces in order to calculate the hash of the canonicalised XML correctly.
-- see: https://stackoverflow.com/questions/69252831/saml-2-0-digest-value-calculation-in-saml-assertion
--
-- @since 0.5
parseSettings :: ParseSettings
parseSettings :: ParseSettings
parseSettings = forall a. Default a => a
def { psRetainNamespaces :: Bool
psRetainNamespaces = Bool
True }