{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeOperators #-}
module SAML2.XML
  ( module SAML2.XML.Types
  , module SAML2.Core.Datatypes
  , URI
  , xpTrimAnyElem
  , xpTrimElemNS
  , xpXmlLang
  , IP, xpIP
  , Identified(..)
  , Identifiable(..)
  , unidentify
  , xpIdentified
  , xpIdentifier
  , IdentifiedURI
  , samlToDoc
  , samlToDocFirstChild
  , samlToXML
  , docToSAML
  , docToXMLWithoutRoot
  , docToXMLWithRoot
  , xmlToSAML
  , xmlToDoc
  , xmlToDocE
  ) where

import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.UTF8 as BSLU
import Data.Default (Default(..))
import qualified Data.Invertible as Inv
import Data.Maybe (listToMaybe)
import Network.URI (URI)
import qualified Text.XML.HXT.Core as HXT
import qualified Text.XML.HXT.DOM.ShowXml
import Text.XML.HXT.DOM.XmlNode (getChildren)
import qualified Data.Tree.NTree.TypeDefs as HXT

import SAML2.XML.Types
import SAML2.Core.Datatypes
import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP
import qualified SAML2.XML.Schema as XS

xpTrimAnyElem :: XP.PU HXT.XmlTree
xpTrimAnyElem :: PU XmlTree
xpTrimAnyElem = PU XmlTree -> PU XmlTree
forall a. PU a -> PU a
XP.xpTrim PU XmlTree
XP.xpAnyElem

xpTrimElemNS :: Namespace -> String -> XP.PU a -> XP.PU a
xpTrimElemNS :: forall a. Namespace -> String -> PU a -> PU a
xpTrimElemNS Namespace
ns String
n PU a
c = PU a -> PU a
forall a. PU a -> PU a
XP.xpTrim (PU a -> PU a) -> PU a -> PU a
forall a b. (a -> b) -> a -> b
$ QName -> PU a -> PU a
forall a. QName -> PU a -> PU a
XP.xpElemQN (Namespace -> String -> QName
mkNName Namespace
ns String
n) (PU a
c PU a -> PU () -> PU a
forall (f :: * -> *) a. Monoidal f => f a -> f () -> f a
XP.>* PU ()
XP.xpWhitespace)

xpXmlLang :: XP.PU XS.Language
xpXmlLang :: PU String
xpXmlLang = QName -> PU String -> PU String
forall a. QName -> PU a -> PU a
XP.xpAttrQN (Namespace -> String -> QName
mkNName Namespace
xmlNS String
"lang") PU String
XS.xpLanguage

type IP = XS.String

xpIP :: XP.PU IP
xpIP :: PU String
xpIP = PU String
XS.xpString

data Identified b a
  = Identified !a
  | Unidentified !b
  deriving (Identified b a -> Identified b a -> Bool
(Identified b a -> Identified b a -> Bool)
-> (Identified b a -> Identified b a -> Bool)
-> Eq (Identified b a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall b a.
(Eq a, Eq b) =>
Identified b a -> Identified b a -> Bool
$c== :: forall b a.
(Eq a, Eq b) =>
Identified b a -> Identified b a -> Bool
== :: Identified b a -> Identified b a -> Bool
$c/= :: forall b a.
(Eq a, Eq b) =>
Identified b a -> Identified b a -> Bool
/= :: Identified b a -> Identified b a -> Bool
Eq, Int -> Identified b a -> ShowS
[Identified b a] -> ShowS
Identified b a -> String
(Int -> Identified b a -> ShowS)
-> (Identified b a -> String)
-> ([Identified b a] -> ShowS)
-> Show (Identified b a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall b a. (Show a, Show b) => Int -> Identified b a -> ShowS
forall b a. (Show a, Show b) => [Identified b a] -> ShowS
forall b a. (Show a, Show b) => Identified b a -> String
$cshowsPrec :: forall b a. (Show a, Show b) => Int -> Identified b a -> ShowS
showsPrec :: Int -> Identified b a -> ShowS
$cshow :: forall b a. (Show a, Show b) => Identified b a -> String
show :: Identified b a -> String
$cshowList :: forall b a. (Show a, Show b) => [Identified b a] -> ShowS
showList :: [Identified b a] -> ShowS
Show)

instance Default a => Default (Identified b a) where
  def :: Identified b a
def = a -> Identified b a
forall b a. a -> Identified b a
Identified a
forall a. Default a => a
def

class Eq b => Identifiable b a | a -> b where
  identifier :: a -> b
  identifiedValues :: [a]
  default identifiedValues :: (Bounded a, Enum a) => [a]
  identifiedValues = [a
forall a. Bounded a => a
minBound..a
forall a. Bounded a => a
maxBound]
  reidentify :: b -> Identified b a
  reidentify b
u = Identified b a
-> (a -> Identified b a) -> Maybe a -> Identified b a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (b -> Identified b a
forall b a. b -> Identified b a
Unidentified b
u) a -> Identified b a
forall b a. a -> Identified b a
Identified (Maybe a -> Identified b a) -> Maybe a -> Identified b a
forall a b. (a -> b) -> a -> b
$ b -> [(b, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup b
u [(b, a)]
l where
    l :: [(b, a)]
l = [ (a -> b
forall b a. Identifiable b a => a -> b
identifier a
a, a
a) | a
a <- [a]
forall b a. Identifiable b a => [a]
identifiedValues ]

unidentify :: Identifiable b a => Identified b a -> b
unidentify :: forall b a. Identifiable b a => Identified b a -> b
unidentify (Identified a
a) = a -> b
forall b a. Identifiable b a => a -> b
identifier a
a
unidentify (Unidentified b
b) = b
b

identify :: Identifiable b a => b Inv.<-> Identified b a
identify :: forall b a. Identifiable b a => b <-> Identified b a
identify = b -> Identified b a
forall b a. Identifiable b a => b -> Identified b a
reidentify (b -> Identified b a)
-> (Identified b a -> b) -> Bijection (->) b (Identified b a)
forall (a :: * -> * -> *) b c. a b c -> a c b -> Bijection a b c
Inv.:<->: Identified b a -> b
forall b a. Identifiable b a => Identified b a -> b
unidentify

xpIdentified :: Identifiable b a => XP.PU b -> XP.PU (Identified b a)
xpIdentified :: forall b a. Identifiable b a => PU b -> PU (Identified b a)
xpIdentified = (b <-> Identified b a) -> PU b -> PU (Identified b a)
forall a b. (a <-> b) -> PU a -> PU b
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
Inv.fmap b <-> Identified b a
forall b a. Identifiable b a => b <-> Identified b a
identify

xpIdentifier :: Identifiable b a => XP.PU b -> String -> XP.PU a
xpIdentifier :: forall b a. Identifiable b a => PU b -> String -> PU a
xpIdentifier PU b
b String
t = (b -> Either String a, a -> b) -> PU b -> PU a
forall a b. (a -> Either String b, b -> a) -> PU a -> PU b
XP.xpWrapEither
  ( \b
u -> case b -> Identified b a
forall b a. Identifiable b a => b -> Identified b a
reidentify b
u of
      Identified a
a -> a -> Either String a
forall a b. b -> Either a b
Right a
a
      Unidentified b
_ -> String -> Either String a
forall a b. a -> Either a b
Left (String
"invalid " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t)
  , a -> b
forall b a. Identifiable b a => a -> b
identifier
  ) PU b
b

type IdentifiedURI = Identified URI

instance Identifiable URI a => XP.XmlPickler (Identified URI a) where
  xpickle :: PU (Identified URI a)
xpickle = PU URI -> PU (Identified URI a)
forall b a. Identifiable b a => PU b -> PU (Identified b a)
xpIdentified PU URI
XS.xpAnyURI

samlToDoc :: XP.XmlPickler a => a -> HXT.XmlTree
samlToDoc :: forall a. XmlPickler a => a -> XmlTree
samlToDoc = [XmlTree] -> XmlTree
forall a. HasCallStack => [a] -> a
head
  ([XmlTree] -> XmlTree) -> (a -> [XmlTree]) -> a -> XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
HXT.runLA (LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b) -> LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
HXT.processChildren (LA XmlTree XmlTree -> LA XmlTree XmlTree)
-> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$ LA XmlTree (String, String) -> LA XmlTree XmlTree
HXT.cleanupNamespaces LA XmlTree (String, String)
HXT.collectPrefixUriPairs)
  (XmlTree -> [XmlTree]) -> (a -> XmlTree) -> a -> [XmlTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PU a -> a -> XmlTree
forall a. PU a -> a -> XmlTree
XP.pickleDoc PU a
forall a. XmlPickler a => PU a
XP.xpickle

-- | From the input xml forest, take the first child of the first tree.
samlToDocFirstChild :: XP.XmlPickler a => a -> HXT.XmlTree
samlToDocFirstChild :: forall a. XmlPickler a => a -> XmlTree
samlToDocFirstChild = [XmlTree] -> XmlTree
forall a. HasCallStack => [a] -> a
head ([XmlTree] -> XmlTree) -> (a -> [XmlTree]) -> a -> XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> [XmlTree]
forall a. NTree a -> [NTree a]
forall (t :: * -> *) a. Tree t => t a -> [t a]
getChildren (XmlTree -> [XmlTree]) -> (a -> XmlTree) -> a -> [XmlTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XmlTree] -> XmlTree
forall a. HasCallStack => [a] -> a
head
  ([XmlTree] -> XmlTree) -> (a -> [XmlTree]) -> a -> XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
HXT.runLA (LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b) -> LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
HXT.processChildren (LA XmlTree XmlTree -> LA XmlTree XmlTree)
-> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall a b. (a -> b) -> a -> b
$ LA XmlTree (String, String) -> LA XmlTree XmlTree
HXT.cleanupNamespaces LA XmlTree (String, String)
HXT.collectPrefixUriPairs)
  (XmlTree -> [XmlTree]) -> (a -> XmlTree) -> a -> [XmlTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PU a -> a -> XmlTree
forall a. PU a -> a -> XmlTree
XP.pickleDoc PU a
forall a. XmlPickler a => PU a
XP.xpickle

-- | see also 'docToXMLWithRoot'
docToXMLWithoutRoot :: HXT.XmlTree -> BSL.ByteString
docToXMLWithoutRoot :: XmlTree -> ByteString
docToXMLWithoutRoot =  [ByteString] -> ByteString
BSL.concat ([ByteString] -> ByteString)
-> (XmlTree -> [ByteString]) -> XmlTree -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LA XmlTree ByteString -> XmlTree -> [ByteString]
forall a b. LA a b -> a -> [b]
HXT.runLA (LA XmlTree XmlTree -> LA XmlTree ByteString
forall n. LA n XmlTree -> LA n ByteString
forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n ByteString
HXT.xshowBlob LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
HXT.getChildren)

-- | 'docToXML' chops off the root element from the tree.  'docToXMLWithRoot' does not do
-- this.  it may make sense to remove 'docToXMLWithoutRoot', but since i don't understand this
-- code enough to be confident not to break anything, i'll just leave this extra function for
-- reference.
docToXMLWithRoot :: HXT.XmlTree -> BSL.ByteString
docToXMLWithRoot :: XmlTree -> ByteString
docToXMLWithRoot = [XmlTree] -> ByteString
Text.XML.HXT.DOM.ShowXml.xshowBlob ([XmlTree] -> ByteString)
-> (XmlTree -> [XmlTree]) -> XmlTree -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XmlTree -> [XmlTree] -> [XmlTree]
forall a. a -> [a] -> [a]
:[])

samlToXML :: XP.XmlPickler a => a -> BSL.ByteString
samlToXML :: forall a. XmlPickler a => a -> ByteString
samlToXML = XmlTree -> ByteString
docToXMLWithoutRoot (XmlTree -> ByteString) -> (a -> XmlTree) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> XmlTree
forall a. XmlPickler a => a -> XmlTree
samlToDoc

xmlToDoc :: BSL.ByteString -> Maybe HXT.XmlTree
xmlToDoc :: ByteString -> Maybe XmlTree
xmlToDoc = (String -> Maybe XmlTree)
-> (XmlTree -> Maybe XmlTree)
-> Either String XmlTree
-> Maybe XmlTree
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe XmlTree -> String -> Maybe XmlTree
forall a b. a -> b -> a
const Maybe XmlTree
forall a. Maybe a
Nothing) XmlTree -> Maybe XmlTree
forall a. a -> Maybe a
Just (Either String XmlTree -> Maybe XmlTree)
-> (ByteString -> Either String XmlTree)
-> ByteString
-> Maybe XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String XmlTree
xmlToDocE

xmlToDocE :: BSL.ByteString -> Either String HXT.XmlTree
xmlToDocE :: ByteString -> Either String XmlTree
xmlToDocE = Maybe XmlTree -> Either String XmlTree
fix (Maybe XmlTree -> Either String XmlTree)
-> (ByteString -> Maybe XmlTree)
-> ByteString
-> Either String XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe XmlTree
xmlToDocUnsafe
  where
    fix :: Maybe XmlTree -> Either String XmlTree
fix Maybe XmlTree
Nothing =
      String -> Either String XmlTree
forall a b. a -> Either a b
Left String
"Nothing"
    fix (Just (HXT.NTree (HXT.XError Int
num String
msg) [XmlTree]
shouldBeEmpty)) =
      String -> Either String XmlTree
forall a b. a -> Either a b
Left (String -> Either String XmlTree)
-> String -> Either String XmlTree
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
num String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if [XmlTree] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [XmlTree]
shouldBeEmpty then String
"" else [XmlTree] -> String
forall a. Show a => a -> String
show [XmlTree]
shouldBeEmpty)
    fix (Just XmlTree
good) =
      XmlTree -> Either String XmlTree
forall a b. b -> Either a b
Right XmlTree
good

-- | Take a UTF-8 encoded bytestring and return an xml tree.  This is unsafe and returns xml
-- trees containing parse errors on occasion; call 'xmlToDocE' instead.
xmlToDocUnsafe :: BSL.ByteString -> Maybe HXT.XmlTree
xmlToDocUnsafe :: ByteString -> Maybe XmlTree
xmlToDocUnsafe = [XmlTree] -> Maybe XmlTree
forall a. [a] -> Maybe a
listToMaybe ([XmlTree] -> Maybe XmlTree)
-> (ByteString -> [XmlTree]) -> ByteString -> Maybe XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LA String XmlTree -> String -> [XmlTree]
forall a b. LA a b -> a -> [b]
HXT.runLA
  (LA String XmlTree
forall (a :: * -> * -> *). ArrowXml a => a String XmlTree
HXT.xreadDoc
  LA String XmlTree -> LA XmlTree XmlTree -> LA String XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
HXT.>>> LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
HXT.removeWhiteSpace
  LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
HXT.>>> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall b c. LA b c -> LA b b
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b b
HXT.neg LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
HXT.isXmlPi
  LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
HXT.>>> LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
HXT.propagateNamespaces)
  (String -> [XmlTree])
-> (ByteString -> String) -> ByteString -> [XmlTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSLU.toString

docToSAML :: XP.XmlPickler a => HXT.XmlTree -> Either String a
docToSAML :: forall a. XmlPickler a => XmlTree -> Either String a
docToSAML = PU a -> XmlTree -> Either String a
forall a. PU a -> XmlTree -> Either String a
XP.unpickleDoc' PU a
forall a. XmlPickler a => PU a
XP.xpickle
  (XmlTree -> Either String a)
-> (XmlTree -> XmlTree) -> XmlTree -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XmlTree] -> XmlTree
forall a. HasCallStack => [a] -> a
head
  ([XmlTree] -> XmlTree)
-> (XmlTree -> [XmlTree]) -> XmlTree -> XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LA XmlTree XmlTree -> XmlTree -> [XmlTree]
forall a b. LA a b -> a -> [b]
HXT.runLA (LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b) -> LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
HXT.processBottomUp (LA XmlTree XmlTree -> LA XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
HXT.processAttrl (LA XmlTree XmlTree -> LA XmlTree XmlTree
forall b c. LA b c -> LA b b
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b b
HXT.neg LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
HXT.isNamespaceDeclAttr)))

xmlToSAML :: XP.XmlPickler a => BSL.ByteString -> Either String a
xmlToSAML :: forall a. XmlPickler a => ByteString -> Either String a
xmlToSAML = Either String a
-> (XmlTree -> Either String a) -> Maybe XmlTree -> Either String a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String a
forall a b. a -> Either a b
Left String
"invalid XML") XmlTree -> Either String a
forall a. XmlPickler a => XmlTree -> Either String a
docToSAML (Maybe XmlTree -> Either String a)
-> (ByteString -> Maybe XmlTree) -> ByteString -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe XmlTree
xmlToDoc