{-# 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
  , samlToXML
  , docToSAML
  , docToXML
  , xmlToSAML
  , xmlToDoc
  ) 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 Text.XML.HXT.Arrow.Edit (escapeXmlRefs)
import Text.XML.HXT.DOM.ShowXml (xshow')
import Text.XML.HXT.DOM.XmlNode (getChildren)

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 :: 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 -> PU String) -> PU String -> PU String
forall a b. (a -> b) -> a -> b
$ 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
/= :: 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
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
showList :: [Identified b a] -> ShowS
$cshowList :: forall b a. (Show a, Show b) => [Identified b a] -> ShowS
show :: Identified b a -> String
$cshow :: forall b a. (Show a, Show b) => Identified b a -> String
showsPrec :: Int -> Identified b a -> ShowS
$cshowsPrec :: forall b a. (Show a, Show b) => Int -> 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 :: 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 :: 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) -> 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 :: PU b -> PU (Identified b a)
xpIdentified = (b <-> Identified b a) -> PU b -> PU (Identified b a)
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 :: 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 :: a -> XmlTree
samlToDoc = [XmlTree] -> XmlTree
forall a. [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 (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

docToXML :: HXT.XmlTree -> BSL.ByteString
docToXML :: XmlTree -> ByteString
docToXML = (Char -> ShowS)
-> (Char -> ShowS) -> (Char -> ShowS) -> [XmlTree] -> ByteString
xshow' Char -> ShowS
cquot Char -> ShowS
aquot (:) ([XmlTree] -> ByteString)
-> (XmlTree -> [XmlTree]) -> XmlTree -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> [XmlTree]
forall (t :: * -> *) a. Tree t => t a -> [t a]
getChildren where (Char -> ShowS
cquot, Char -> ShowS
aquot) = (Char -> ShowS, Char -> ShowS)
escapeXmlRefs

samlToXML :: XP.XmlPickler a => a -> BSL.ByteString
samlToXML :: a -> ByteString
samlToXML = XmlTree -> ByteString
docToXML (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 = [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 (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 :: 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. [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 (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 (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 :: 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