{-# 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