module Data.HttpSpec.XmlHelper -- == EXPORTS ================================================================= (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 -- == IMPORTS ================================================================= ---------------------------------------- -- STDLIB ---------------------------------------- import Control.Monad (liftM) import Data.Char (toLower) import Data.Maybe (fromMaybe) import Data.List (elemIndex) ---------------------------------------- -- SITE-PACKAGES ---------------------------------------- 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) ---------------------------------------- -- LOCAL ---------------------------------------- import Data.HttpSpec.MiscHelper (maybeToM) -- == TYPES =================================================================== 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 -- == ENCODING FUNCTIONS ====================================================== 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 -- == XML FUNCTIONS =========================================================== 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 -- >>> propagateNamespaces 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 }