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

    -- * Utility functions
    toMaybeText,
    parseUTCTime,

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

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

import qualified Data.Text as T
import Data.Time

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 (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"urn:oasis:names:tc:SAML:2.0:assertion") (Text -> Maybe Text
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 (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"urn:oasis:names:tc:SAML:2.0:protocol") (Text -> Maybe Text
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 (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"http://www.w3.org/2001/04/xmlenc#") (Text -> Maybe Text
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 (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"http://www.w3.org/2000/09/xmldsig#") (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"ds")

-- | '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 [] = Maybe Text
forall a. Maybe a
Nothing 
toMaybeText [Text]
xs = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
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%QZ"

-- | 'parseUTCTime' @text@ parses @text@ into a 'UTCTime' value.
parseUTCTime :: MonadFail m => T.Text -> m UTCTime
parseUTCTime :: Text -> m UTCTime
parseUTCTime Text
value = 
    Bool -> TimeLocale -> String -> String -> m UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
False TimeLocale
defaultTimeLocale String
timeFormat (Text -> String
T.unpack Text
value) 

-- | 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 :: String -> [a] -> m a
oneOrFail String
err [] = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
oneOrFail String
_ (a
x:[a]
_) = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

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