{-# LANGUAGE OverloadedStrings #-}
module Text.XML.Util where
import Control.Monad.Except
import qualified Data.ByteString.Lazy as BSL
import Data.Char (isSpace)
import qualified Data.Generics.Uniplate.Data as Uniplate
import Data.Kind (Type)
import Data.Map as Map
import Data.Proxy
import Data.String.Conversions
import qualified Data.Text as ST
import qualified Data.Tree.NTree.TypeDefs as HXT
import Data.Typeable
import GHC.Stack
import qualified SAML2.XML as HS
import Text.XML
import qualified Text.XML.HXT.Core as HXT
import qualified Text.XML.HXT.DOM.ShowXml
die :: forall (a :: Type) b c m. (Typeable a, Show b, MonadError String m) => Proxy a -> b -> m c
die :: forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError String m) =>
Proxy a -> b -> m c
die = Maybe String -> Proxy a -> b -> m c
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError String m) =>
Maybe String -> Proxy a -> b -> m c
die' Maybe String
forall a. Maybe a
Nothing
die' :: forall (a :: Type) b c m. (Typeable a, Show b, MonadError String m) => Maybe String -> Proxy a -> b -> m c
die' :: forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError String m) =>
Maybe String -> Proxy a -> b -> m c
die' Maybe String
mextra Proxy a
Proxy b
msg =
String -> m c
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m c) -> String -> m c
forall a b. (a -> b) -> a -> b
$
String
"HasXML: could not parse " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show (forall a. Typeable a => a -> TypeRep
typeOf @a a
forall a. HasCallStack => a
undefined) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> b -> String
forall a. Show a => a -> String
show b
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
"; " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) Maybe String
mextra
type Attrs = Map.Map Name ST
elemToNodes :: HasCallStack => Element -> [Node]
elemToNodes :: HasCallStack => Element -> [Node]
elemToNodes = (Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: []) (Node -> [Node]) -> (Element -> Node) -> Element -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Node
NodeElement
nodesToElem :: HasCallStack => [Node] -> Element
nodesToElem :: HasCallStack => [Node] -> Element
nodesToElem [NodeElement Element
el] = Element
el
nodesToElem [Node]
bad = String -> Element
forall a. HasCallStack => String -> a
error (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ [Node] -> String
forall a. Show a => a -> String
show [Node]
bad
docToNodes :: HasCallStack => Document -> [Node]
docToNodes :: HasCallStack => Document -> [Node]
docToNodes (Document Prologue
_ Element
el [Miscellaneous]
_) = HasCallStack => Element -> [Node]
Element -> [Node]
elemToNodes Element
el
nodesToDoc :: HasCallStack => [Node] -> Document
nodesToDoc :: HasCallStack => [Node] -> Document
nodesToDoc = Element -> Document
mkDocument (Element -> Document) -> ([Node] -> Element) -> [Node] -> Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => [Node] -> Element
[Node] -> Element
nodesToElem
mkDocument :: Element -> Document
mkDocument :: Element -> Document
mkDocument Element
el = Prologue -> Element -> [Miscellaneous] -> Document
Document Prologue
defPrologue Element
el [Miscellaneous]
defMiscellaneous
defPrologue :: Prologue
defPrologue :: Prologue
defPrologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
Prologue [] Maybe Doctype
forall a. Maybe a
Nothing []
defMiscellaneous :: [Miscellaneous]
defMiscellaneous :: [Miscellaneous]
defMiscellaneous = []
hxtToConduit :: MonadError String m => HXT.XmlTree -> m Document
hxtToConduit :: forall (m :: * -> *). MonadError String m => XmlTree -> m Document
hxtToConduit = (SomeException -> m Document)
-> (Document -> m Document)
-> Either SomeException Document
-> m Document
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m Document
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m Document)
-> (SomeException -> String) -> SomeException -> m Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"hxtToConduit: parseLBS failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> (SomeException -> String) -> SomeException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) Document -> m Document
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException Document -> m Document)
-> (XmlTree -> Either SomeException Document)
-> XmlTree
-> m Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseSettings -> ByteString -> Either SomeException Document
parseLBS ParseSettings
forall a. Default a => a
def (ByteString -> Either SomeException Document)
-> (XmlTree -> ByteString)
-> XmlTree
-> Either SomeException Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> ByteString
docToXML'
conduitToHxt :: MonadError String m => Document -> m HXT.XmlTree
conduitToHxt :: forall (m :: * -> *). MonadError String m => Document -> m XmlTree
conduitToHxt = (String -> m XmlTree)
-> (XmlTree -> m XmlTree) -> Either String XmlTree -> m XmlTree
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m XmlTree
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m XmlTree) -> (String -> String) -> String -> m XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"conduitToHxt: xmlToDoc' failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)) XmlTree -> m XmlTree
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String XmlTree -> m XmlTree)
-> (Document -> Either String XmlTree) -> Document -> m XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String XmlTree
forall (m :: * -> *).
MonadError String m =>
ByteString -> m XmlTree
xmlToDoc' (ByteString -> Either String XmlTree)
-> (Document -> ByteString) -> Document -> Either String XmlTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderSettings -> Document -> ByteString
renderLBS RenderSettings
forall a. Default a => a
def {rsXMLDeclaration = False}
samlToConduit :: (MonadError String m, HXT.XmlPickler a) => a -> m Document
samlToConduit :: forall (m :: * -> *) a.
(MonadError String m, XmlPickler a) =>
a -> m Document
samlToConduit = (SomeException -> m Document)
-> (Document -> m Document)
-> Either SomeException Document
-> m Document
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m Document
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m Document)
-> (SomeException -> String) -> SomeException -> m Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"samlToConduit: parseLBS failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> (SomeException -> String) -> SomeException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) Document -> m Document
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException Document -> m Document)
-> (a -> Either SomeException Document) -> a -> m Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseSettings -> ByteString -> Either SomeException Document
parseLBS ParseSettings
forall a. Default a => a
def (ByteString -> Either SomeException Document)
-> (a -> ByteString) -> a -> Either SomeException Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. XmlPickler a => a -> ByteString
HS.samlToXML
docToXML' :: HXT.XmlTree -> BSL.ByteString
docToXML' :: XmlTree -> ByteString
docToXML' = XmlTrees -> ByteString
Text.XML.HXT.DOM.ShowXml.xshowBlob (XmlTrees -> ByteString)
-> (XmlTree -> XmlTrees) -> XmlTree -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XmlTree -> XmlTrees -> XmlTrees
forall a. a -> [a] -> [a]
: [])
xmlToDoc' :: MonadError String m => BSL.ByteString -> m HXT.XmlTree
xmlToDoc' :: forall (m :: * -> *).
MonadError String m =>
ByteString -> m XmlTree
xmlToDoc' ByteString
xml = case LA String XmlTree -> String -> XmlTrees
forall a b. LA a b -> a -> [b]
HXT.runLA LA String XmlTree
forall (a :: * -> * -> *). ArrowXml a => a String XmlTree
HXT.xread (ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
xml) of
[HXT.NTree (HXT.XError Int
_errcode String
errmsg) XmlTrees
_] -> String -> m XmlTree
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
errmsg
[XmlTree
t] -> XmlTree -> m XmlTree
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XmlTree
t
[] -> String -> m XmlTree
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"no root elements"
bad :: XmlTrees
bad@(XmlTree
_ : XmlTree
_ : XmlTrees
_) -> String -> m XmlTree
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m XmlTree) -> String -> m XmlTree
forall a b. (a -> b) -> a -> b
$ String
"more than one root element: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (XmlTrees -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length XmlTrees
bad)
stripWhitespace :: Document -> Document
stripWhitespace :: Document -> Document
stripWhitespace =
[[Transformer]] -> Document -> Document
forall a. Data a => [[Transformer]] -> a -> a
Uniplate.transformBis
[ [ (Node -> Node) -> Transformer
forall a. Data a => (a -> a) -> Transformer
Uniplate.transformer ((Node -> Node) -> Transformer) -> (Node -> Node) -> Transformer
forall a b. (a -> b) -> a -> b
$ \case
(NodeContent Text
txt) -> Text -> Node
NodeContent (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
ST.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
txt
Node
other -> Node
other
],
[ (Element -> Element) -> Transformer
forall a. Data a => (a -> a) -> Transformer
Uniplate.transformer ((Element -> Element) -> Transformer)
-> (Element -> Element) -> Transformer
forall a b. (a -> b) -> a -> b
$ \case
(Element Name
nm Map Name Text
attrs [Node]
nodes) -> Name -> Map Name Text -> [Node] -> Element
Element Name
nm Map Name Text
attrs ((Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (Node -> Node -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Node
NodeContent Text
"") ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ [Node]
nodes)
]
]
mergeContentSiblings :: Document -> Document
mergeContentSiblings :: Document -> Document
mergeContentSiblings =
[[Transformer]] -> Document -> Document
forall a. Data a => [[Transformer]] -> a -> a
Uniplate.transformBis
[ [ (Element -> Element) -> Transformer
forall a. Data a => (a -> a) -> Transformer
Uniplate.transformer ((Element -> Element) -> Transformer)
-> (Element -> Element) -> Transformer
forall a b. (a -> b) -> a -> b
$ \case
(Element Name
nm Map Name Text
attrs [Node]
nodes) -> Name -> Map Name Text -> [Node] -> Element
Element Name
nm Map Name Text
attrs ([Node] -> [Node]
go [Node]
nodes)
]
]
where
go :: [Node] -> [Node]
go [] = []
go (NodeContent Text
s : NodeContent Text
t : [Node]
xs) = [Node] -> [Node]
go ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ Text -> Node
NodeContent (Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t) Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node]
xs
go (Node
x : [Node]
xs) = Node
x Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node] -> [Node]
go [Node]
xs
normalizeDoc :: Document -> Document
normalizeDoc :: Document -> Document
normalizeDoc = Document -> Document
stripWhitespace (Document -> Document)
-> (Document -> Document) -> Document -> Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document -> Document
mergeContentSiblings
repairNamespaces :: HasCallStack => [Node] -> [Node]
repairNamespaces :: HasCallStack => [Node] -> [Node]
repairNamespaces = (Node -> Node) -> [Node] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Node -> Node) -> [Node] -> [Node])
-> (Node -> Node) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ \case
NodeElement Element
el -> Element -> Node
NodeElement (Element -> Node) -> Element -> Node
forall a b. (a -> b) -> a -> b
$ HasCallStack => Element -> Element
Element -> Element
repairNamespacesEl Element
el
Node
other -> Node
other
repairNamespacesEl :: HasCallStack => Element -> Element
repairNamespacesEl :: HasCallStack => Element -> Element
repairNamespacesEl Element
el = Either SomeException Document -> Element
forall {a}. Show a => Either a Document -> Element
unwrap (Either SomeException Document -> Element)
-> (Element -> Either SomeException Document) -> Element -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseSettings -> Text -> Either SomeException Document
parseText ParseSettings
forall a. Default a => a
def (Text -> Either SomeException Document)
-> (Element -> Text) -> Element -> Either SomeException Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderSettings -> Document -> Text
renderText RenderSettings
forall a. Default a => a
def (Document -> Text) -> (Element -> Document) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Document
mkDocument (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Element
el
where
unwrap :: Either a Document -> Element
unwrap (Right (Document Prologue
_ Element
el' [Miscellaneous]
_)) = Element
el'
unwrap (Left a
msg) = String -> Element
forall a. HasCallStack => String -> a
error (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
msg