module Data.HttpSpec.XmlHelper
(XmlEncoding, xmlEncodingFromString, xmlEncodingToString
,serializeXml, parseXml
,pickle, pickleWithEnc, pickleStr, unpickle, unpickleStr, unpickleDocM
,fromPair,fromTriple,fromQuadruple,fromQuintuple
,PUCase, xpOne, xpMany, xpTagSwitch, xpCase, xpCaseConst, xpSwitch
,xpTextFixed
,_ISO8859_1_, _ISO8859_2_, _ISO8859_3_, _ISO8859_4_, _ISO8859_5_
,_ISO8859_6_, _ISO8859_7_, _ISO8859_8_, _ISO8859_9_, _ISO8859_10_
,_ISO8859_11_, _ISO8859_13_, _ISO8859_14_, _ISO8859_15_, _ISO8859_16_
,_USASCII_, _UCS2_, _UTF8_, _UTF16_, _UTF16BE_, _UTF16LE_, _ISOLATIN1_
,_UNICODE_)
where
import Control.Monad (liftM)
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Data.List (elemIndex)
import Control.Arrow.ArrowIf (when)
import Control.Arrow.ArrowList (this,none)
import Control.Arrow.ArrowTree (processChildren, processTopDown)
import qualified Data.ByteString.Lazy.Char8 as BSLChar
import Data.Tree.NTree.TypeDefs (NTrees, NTree(..))
import Text.XML.HXT.Arrow
( XmlTree, XmlPickler(..)
,runLA, constA, (>>>), arr
,addXmlPi,addXmlPiEncoding,replaceChildren,xshow,mkText,escapeXmlDoc
,getChildren, xread)
import Text.XML.HXT.Arrow.Pickle (PU(..), Schema, unpickleDoc,
pickleDoc ,xpElem, xpList, xpAlt, xpWrap,
xpWrapMaybe, xpLift, xpText)
import Text.XML.HXT.Arrow.Pickle.Schema (scFixed)
import Text.XML.HXT.Arrow.ParserInterface (parseXmlDoc,substXmlEntityRefs)
import Text.XML.HXT.Arrow.Edit (canonicalizeContents, removeDocWhiteSpace
,transfAllCharRef, indentDoc)
import Text.XML.HXT.Arrow.GeneralEntitySubstitution (processGeneralEntities)
import Text.XML.HXT.Arrow.XmlArrow (root, isPi, hasName)
import Text.XML.HXT.Arrow.DocumentOutput (encodeDocument')
import Text.XML.HXT.DOM.TypeDefs (XNode(..))
import Text.XML.HXT.DOM.XmlKeywords
(t_xml
,iso8859_1, iso8859_2, iso8859_3, iso8859_4, iso8859_5, iso8859_6
,iso8859_7, iso8859_8, iso8859_9, iso8859_10, iso8859_11, iso8859_13
,iso8859_14, iso8859_15, iso8859_16, usAscii, ucs2, utf8, utf16, utf16be
,utf16le, unicodeString, isoLatin1)
import Text.XML.HXT.Arrow.Namespace (propagateNamespaces, validateNamespaces)
import Data.HttpSpec.MiscHelper (maybeToM)
newtype XmlEncoding = XmlEncoding { xmlEncodingName :: String } deriving (Eq)
instance Show XmlEncoding where
show (XmlEncoding name) = name
_UNICODE_ = XmlEncoding unicodeString
_ISO8859_1_ = XmlEncoding iso8859_1
_ISO8859_2_ = XmlEncoding iso8859_2
_ISO8859_3_ = XmlEncoding iso8859_3
_ISO8859_4_ = XmlEncoding iso8859_4
_ISO8859_5_ = XmlEncoding iso8859_5
_ISO8859_6_ = XmlEncoding iso8859_6
_ISO8859_7_ = XmlEncoding iso8859_7
_ISO8859_8_ = XmlEncoding iso8859_8
_ISO8859_9_ = XmlEncoding iso8859_9
_ISO8859_10_ = XmlEncoding iso8859_10
_ISO8859_11_ = XmlEncoding iso8859_11
_ISO8859_13_ = XmlEncoding iso8859_13
_ISO8859_14_ = XmlEncoding iso8859_14
_ISO8859_15_ = XmlEncoding iso8859_15
_ISO8859_16_ = XmlEncoding iso8859_16
_USASCII_ = XmlEncoding usAscii
_UCS2_ = XmlEncoding ucs2
_UTF8_ = XmlEncoding utf8
_UTF16_ = XmlEncoding utf16
_UTF16BE_ = XmlEncoding utf16be
_UTF16LE_ = XmlEncoding utf16le
_ISOLATIN1_ = XmlEncoding isoLatin1
xmlEncodingFromString :: String -> Either String XmlEncoding
xmlEncodingFromString name =
case map toLower name of
"latin1" -> return _ISOLATIN1_
"latin9" -> return _ISO8859_15_
"iso-8859-1" -> return _ISO8859_1_
"iso-8859-2" -> return _ISO8859_2_
"iso-8859-3" -> return _ISO8859_3_
"iso-8859-4" -> return _ISO8859_4_
"iso-8859-5" -> return _ISO8859_5_
"iso-8859-6" -> return _ISO8859_6_
"iso-8859-7" -> return _ISO8859_7_
"iso-8859-8" -> return _ISO8859_8_
"iso-8859-9" -> return _ISO8859_9_
"iso-8859-10" -> return _ISO8859_10_
"iso-8859-11" -> return _ISO8859_11_
"iso-8859-13" -> return _ISO8859_13_
"iso-8859-14" -> return _ISO8859_14_
"iso-8859-15" -> return _ISO8859_15_
"utf8" -> return _UTF8_
"utf-8" -> return _UTF8_
"utf16" -> return _UTF16_
"utf-16" -> return _UTF16_
"ascii" -> return _USASCII_
"us-ascii" -> return _USASCII_
"unicode" -> return _UNICODE_
_ -> fail $ "Can't parse unsupported XmlEncoding name `" ++ name ++ "'."
xmlEncodingToString :: XmlEncoding -> String
xmlEncodingToString = show
xpOne :: PU a -> PU a
xpOne = id
xpMany :: String -> PU a -> PU [a]
xpMany root pu = xpElem root (xpList pu)
pickle :: PU a -> a -> BSLChar.ByteString
pickle pu = serializeXml _UTF8_ . pickleDoc pu
pickleWithEnc :: XmlEncoding -> PU a -> a -> BSLChar.ByteString
pickleWithEnc enc pu = serializeXml' noProlog enc . pickleDoc pu
where noProlog = enc == _UNICODE_
unpickle :: Monad m => PU a -> BSLChar.ByteString -> m a
unpickle pu bsl = parseXml True True bsl >>= unpickleDocM pu
pickleStr :: PU a -> a -> String
pickleStr pu = BSLChar.unpack . pickleWithEnc _UNICODE_ pu
unpickleDocM :: Monad m => PU a -> XmlTree -> m a
unpickleDocM pu = maybeToM "Unpickling failed." . unpickleDoc pu
unpickleStr pu = unpickle pu . BSLChar.pack
serializeXml :: XmlEncoding -> XmlTree -> BSLChar.ByteString
serializeXml enc xml = serializeXml' False enc xml
serializeXml' :: Bool -> XmlEncoding -> XmlTree -> BSLChar.ByteString
serializeXml' indent enc xml =
let [str] = runLA (constA xml >>> encodeA) undefined
in (BSLChar.pack (strip str))
where rmpi = enc == _UNICODE_
encodeA =
(if indent then processChildren indentDoc else this)
>>>
escapeXmlDoc
>>>
encodeDocument' rmpi (xmlEncodingName enc)
>>>
replaceChildren (xshow getChildren >>> arr encode >>> mkText)
>>>
xshow getChildren
encode = id
strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace
isSpace = (`elem` " \n\t")
parseXml :: Monad m => Bool -> Bool -> BSLChar.ByteString -> m XmlTree
parseXml rmpi rmspace bstr =
let trees = runLA pipe undefined
in case trees of
[] -> fail "empty result"
(NTree _ ((NTree (XError _ msg) _) : _) : _) -> fail msg
trees -> return (last trees)
where str = BSLChar.unpack bstr
pipe = root [] []
>>> replaceChildren parse
>>> (if rmpi then removeXmlPi else this)
>>> (if rmspace then removeDocWhiteSpace else this)
parse = constA ("urn:Data.ByteString", str)
>>> parseXmlDoc
>>> substXmlEntityRefs
>>> canonicalizeContents
removeXmlPi = processTopDown (none `when` (isPi >>> hasName t_xml))
fromPair :: (a -> b -> c) -> (a, b) -> c
fromPair f ~(a, b) = f a b
fromTriple :: (a -> b -> c -> d) -> (a, b, c) -> d
fromTriple f ~(a, b, c) = f a b c
fromQuadruple :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
fromQuadruple f ~(a, b, c, d) = f a b c d
fromQuintuple :: (a -> b -> c -> d -> e -> f) -> (a, b, c, d, e) -> f
fromQuintuple f ~(a, b, c, d, e) = f a b c d e
data PUCase a = PUCase { case_value :: a
, case_spec :: PU a }
xpCase :: (a -> b, b -> a) -> PU a -> PUCase b
xpCase wrapfuns@(aToB,_bToA) specA = PUCase value spec
where value = aToB (error "xpCase: tagging function requires evaluation")
spec = xpWrap wrapfuns specA
xpCaseConst :: a -> PU () -> PUCase a
xpCaseConst a pu = xpCase (const a, const undefined) pu
where undef = error "xpCaseConst: this value should have been ignored"
xpSwitch :: Show a => [PUCase a] -> PU a
xpSwitch = xpTagSwitch (takeWhile (/= ' ') . show)
xpTagSwitch :: Eq t => (a -> t) -> [PUCase a] -> PU a
xpTagSwitch tag cases = xpAlt idx (map case_spec cases)
where idx = fromMaybe err . flip elemIndex tags . tag
err = error $ "xpTagSwitch: no case matched"
tags = map (tag . case_value) cases
xpTextFixed :: String -> PU ()
xpTextFixed text =
(xpWrapMaybe (\t -> if t == text then Just () else Nothing, const text)
xpText) { theSchema = scFixed text }