{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
-- |
-- XML Canonicalization
--
-- For <http://www.w3.org/TR/2008/REC-xmldsig-core-20080610/> §6.5
module SAML2.XML.Canonical where

import Control.Monad ((<=<))
import qualified Data.ByteString as BS
import Data.Tree.Class (getChildren)
import qualified Text.XML.HXT.Core as HXT

import SAML2.XML
import qualified SAML2.XML.LibXML2 as LibXML2
import qualified SAML2.XML.Schema as XS
import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP

-- |§6.5
data CanonicalizationAlgorithm
  = CanonicalXML10
    { CanonicalizationAlgorithm -> Bool
canonicalWithComments :: Bool
    } -- ^§6.5.1 <http://www.w3.org/TR/xml-c14n/ xml-c14n>
  | CanonicalXML11
    { canonicalWithComments :: Bool
    } -- ^§6.5.2 <http://www.w3.org/TR/xml-c14n11/ xml-c14n11>
  | CanonicalXMLExcl10
    { canonicalWithComments :: Bool
    } -- ^<http://www.w3.org/TR/xml-exc-c14n/ xml-exc-c14n>
  deriving (CanonicalizationAlgorithm -> CanonicalizationAlgorithm -> Bool
(CanonicalizationAlgorithm -> CanonicalizationAlgorithm -> Bool)
-> (CanonicalizationAlgorithm -> CanonicalizationAlgorithm -> Bool)
-> Eq CanonicalizationAlgorithm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CanonicalizationAlgorithm -> CanonicalizationAlgorithm -> Bool
== :: CanonicalizationAlgorithm -> CanonicalizationAlgorithm -> Bool
$c/= :: CanonicalizationAlgorithm -> CanonicalizationAlgorithm -> Bool
/= :: CanonicalizationAlgorithm -> CanonicalizationAlgorithm -> Bool
Eq, Int -> CanonicalizationAlgorithm -> ShowS
[CanonicalizationAlgorithm] -> ShowS
CanonicalizationAlgorithm -> String
(Int -> CanonicalizationAlgorithm -> ShowS)
-> (CanonicalizationAlgorithm -> String)
-> ([CanonicalizationAlgorithm] -> ShowS)
-> Show CanonicalizationAlgorithm
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CanonicalizationAlgorithm -> ShowS
showsPrec :: Int -> CanonicalizationAlgorithm -> ShowS
$cshow :: CanonicalizationAlgorithm -> String
show :: CanonicalizationAlgorithm -> String
$cshowList :: [CanonicalizationAlgorithm] -> ShowS
showList :: [CanonicalizationAlgorithm] -> ShowS
Show)

instance Identifiable URI CanonicalizationAlgorithm where
  identifier :: CanonicalizationAlgorithm -> URI
identifier (CanonicalXML10 Bool
False)     = String -> String -> String -> String -> URI
httpURI String
"www.w3.org" String
"/TR/2001/REC-xml-c14n-20010315" String
"" String
""
  identifier (CanonicalXML10 Bool
True)      = String -> String -> String -> String -> URI
httpURI String
"www.w3.org" String
"/TR/2001/REC-xml-c14n-20010315" String
"" String
"#WithComments"
  identifier (CanonicalXML11 Bool
False)     = String -> String -> String -> String -> URI
httpURI String
"www.w3.org" String
"/2006/12/xml-c14n11" String
"" String
""
  identifier (CanonicalXML11 Bool
True)      = String -> String -> String -> String -> URI
httpURI String
"www.w3.org" String
"/2006/12/xml-c14n11" String
"" String
"#WithComments"
  identifier (CanonicalXMLExcl10 Bool
False) = String -> String -> String -> String -> URI
httpURI String
"www.w3.org" String
"/2001/10/xml-exc-c14n" String
"" String
"#"
  identifier (CanonicalXMLExcl10 Bool
True)  = String -> String -> String -> String -> URI
httpURI String
"www.w3.org" String
"/2001/10/xml-exc-c14n" String
"" String
"#WithComments"
  identifiedValues :: [CanonicalizationAlgorithm]
identifiedValues =
    [ Bool -> CanonicalizationAlgorithm
CanonicalXML10 Bool
False
    , Bool -> CanonicalizationAlgorithm
CanonicalXML10 Bool
True
    , Bool -> CanonicalizationAlgorithm
CanonicalXML11 Bool
False
    , Bool -> CanonicalizationAlgorithm
CanonicalXML11 Bool
True
    , Bool -> CanonicalizationAlgorithm
CanonicalXMLExcl10 Bool
False
    , Bool -> CanonicalizationAlgorithm
CanonicalXMLExcl10 Bool
True
    ]

newtype InclusiveNamespaces = InclusiveNamespaces
  { InclusiveNamespaces -> NMTOKENS
inclusiveNamespacesPrefixList :: XS.NMTOKENS
  } deriving (InclusiveNamespaces -> InclusiveNamespaces -> Bool
(InclusiveNamespaces -> InclusiveNamespaces -> Bool)
-> (InclusiveNamespaces -> InclusiveNamespaces -> Bool)
-> Eq InclusiveNamespaces
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InclusiveNamespaces -> InclusiveNamespaces -> Bool
== :: InclusiveNamespaces -> InclusiveNamespaces -> Bool
$c/= :: InclusiveNamespaces -> InclusiveNamespaces -> Bool
/= :: InclusiveNamespaces -> InclusiveNamespaces -> Bool
Eq, Int -> InclusiveNamespaces -> ShowS
[InclusiveNamespaces] -> ShowS
InclusiveNamespaces -> String
(Int -> InclusiveNamespaces -> ShowS)
-> (InclusiveNamespaces -> String)
-> ([InclusiveNamespaces] -> ShowS)
-> Show InclusiveNamespaces
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InclusiveNamespaces -> ShowS
showsPrec :: Int -> InclusiveNamespaces -> ShowS
$cshow :: InclusiveNamespaces -> String
show :: InclusiveNamespaces -> String
$cshowList :: [InclusiveNamespaces] -> ShowS
showList :: [InclusiveNamespaces] -> ShowS
Show)

instance XP.XmlPickler InclusiveNamespaces where
  xpickle :: PU InclusiveNamespaces
xpickle = Namespace
-> String -> PU InclusiveNamespaces -> PU InclusiveNamespaces
forall a. Namespace -> String -> PU a -> PU a
xpTrimElemNS (String -> URI -> Namespace
mkNamespace String
"ec" (String -> String -> String -> String -> URI
httpURI String
"www.w3.org" String
"/2001/10/xml-exc-c14n" String
"" String
"#")) String
"InclusiveNamespaces" (PU InclusiveNamespaces -> PU InclusiveNamespaces)
-> PU InclusiveNamespaces -> PU InclusiveNamespaces
forall a b. (a -> b) -> a -> b
$
    [XP.biCase|n <-> InclusiveNamespaces n|]
    Bijection (->) NMTOKENS InclusiveNamespaces
-> PU NMTOKENS -> PU InclusiveNamespaces
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
XP.>$< String -> PU NMTOKENS -> PU NMTOKENS
forall a. String -> PU a -> PU a
XP.xpAttr String
"PrefixList" PU NMTOKENS
XS.xpNMTOKENS

-- |Canonicalize and serialize an XML document
canonicalize :: CanonicalizationAlgorithm -> Maybe InclusiveNamespaces -> Maybe String -> HXT.XmlTree -> IO BS.ByteString
canonicalize :: CanonicalizationAlgorithm
-> Maybe InclusiveNamespaces
-> Maybe String
-> XmlTree
-> IO ByteString
canonicalize CanonicalizationAlgorithm
a Maybe InclusiveNamespaces
i Maybe String
s = CanonicalizationAlgorithm
-> Maybe InclusiveNamespaces
-> Maybe String
-> XmlTrees
-> IO ByteString
canonicalizeWithRoot CanonicalizationAlgorithm
a Maybe InclusiveNamespaces
i Maybe String
s (XmlTrees -> IO ByteString)
-> (XmlTree -> XmlTrees) -> XmlTree -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> XmlTrees
forall a. NTree a -> [NTree a]
forall (t :: * -> *) a. Tree t => t a -> [t a]
getChildren

canonicalizeWithRoot :: CanonicalizationAlgorithm -> Maybe InclusiveNamespaces -> Maybe String -> HXT.XmlTrees -> IO BS.ByteString
canonicalizeWithRoot :: CanonicalizationAlgorithm
-> Maybe InclusiveNamespaces
-> Maybe String
-> XmlTrees
-> IO ByteString
canonicalizeWithRoot CanonicalizationAlgorithm
a Maybe InclusiveNamespaces
i Maybe String
s =
  C14NMode
-> Maybe NMTOKENS -> Bool -> Maybe String -> Doc -> IO ByteString
LibXML2.c14n (CanonicalizationAlgorithm -> C14NMode
cm CanonicalizationAlgorithm
a) (InclusiveNamespaces -> NMTOKENS
inclusiveNamespacesPrefixList (InclusiveNamespaces -> NMTOKENS)
-> Maybe InclusiveNamespaces -> Maybe NMTOKENS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe InclusiveNamespaces
i) (CanonicalizationAlgorithm -> Bool
canonicalWithComments CanonicalizationAlgorithm
a) Maybe String
s
    (Doc -> IO ByteString)
-> (XmlTrees -> IO Doc) -> XmlTrees -> IO ByteString
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< XmlTrees -> IO Doc
LibXML2.fromXmlTrees where
  cm :: CanonicalizationAlgorithm -> C14NMode
cm CanonicalXML10{} = C14NMode
LibXML2.C14N_1_0
  cm CanonicalXML11{} = C14NMode
LibXML2.C14N_1_1
  cm CanonicalXMLExcl10{} = C14NMode
LibXML2.C14N_EXCLUSIVE_1_0