{-# LANGUAGE QuasiQuotes #-}
module SAML2.XML.Types where

import Data.List.NonEmpty (NonEmpty(..))
import Network.URI (URI(..), URIAuth(..), uriToString)
import qualified Text.XML.HXT.DOM.TypeDefs as HXT

import qualified Text.XML.HXT.Arrow.Pickle.Xml.Invertible as XP

type Node = HXT.XmlTree
-- instance XP.XmlPickler XML.Node where xpickle = XP.xpTree
type Nodes = HXT.XmlTrees
-- instance XP.XmlPickler XML.Nodes where xpickle = XP.xpTrees
type List1 a = NonEmpty a

xpList1 :: XP.PU a -> XP.PU (List1 a)
xpList1 :: PU a -> PU (List1 a)
xpList1 PU a
f = [XP.biCase|a:l <-> a:|l|] Bijection (->) [a] (List1 a) -> PU [a] -> PU (List1 a)
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
XP.>$< PU a -> PU [a]
forall a. PU a -> PU [a]
XP.xpList1 PU a
f

type QName = HXT.QName

data Namespace = Namespace
  { Namespace -> String
namespacePrefix :: !String
  , Namespace -> URI
namespaceURI :: !URI
  , Namespace -> String
namespaceURIString :: !String
  }

mkNamespace :: String -> URI -> Namespace
mkNamespace :: String -> URI -> Namespace
mkNamespace String
p URI
u = String -> URI -> String -> Namespace
Namespace String
p URI
u (String -> Namespace) -> String -> Namespace
forall a b. (a -> b) -> a -> b
$ (String -> String) -> URI -> String -> String
uriToString String -> String
forall a. a -> a
id URI
u String
""

mkNName :: Namespace -> String -> QName
mkNName :: Namespace -> String -> QName
mkNName Namespace
ns String
n = String -> String -> String -> QName
HXT.mkQName (Namespace -> String
namespacePrefix Namespace
ns) String
n (Namespace -> String
namespaceURIString Namespace
ns)

httpURI :: String -> String -> String -> String -> URI
httpURI :: String -> String -> String -> String -> URI
httpURI String
host = String -> Maybe URIAuth -> String -> String -> String -> URI
URI String
"http:" (Maybe URIAuth -> String -> String -> String -> URI)
-> Maybe URIAuth -> String -> String -> String -> URI
forall a b. (a -> b) -> a -> b
$ URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just (URIAuth -> Maybe URIAuth) -> URIAuth -> Maybe URIAuth
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> URIAuth
URIAuth String
"" String
host String
""

xmlNS, xmlnsNS :: Namespace
xmlNS :: Namespace
xmlNS = String -> URI -> Namespace
mkNamespace String
"xml" (URI -> Namespace) -> URI -> Namespace
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> URI
httpURI String
"www.w3.org" String
"/XML/1998/namespace" String
"" String
""
xmlnsNS :: Namespace
xmlnsNS = String -> URI -> Namespace
mkNamespace String
"xmlns" (URI -> Namespace) -> URI -> Namespace
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> URI
httpURI String
"www.w3.org" String
"/2000/xmlns/" String
"" String
""