xml2json 0.1.0.1 → 0.2.0.0
raw patch · 5 files changed
+239/−58 lines, 5 filesdep +hspecdep +resourcetdep +xml2jsondep ~aesondep ~bytestringdep ~text
Dependencies added: hspec, resourcet, xml2json
Dependency ranges changed: aeson, bytestring, text, transformers
Files
- Main.hs +2/−2
- Text/XML/ToJSON.hs +86/−31
- Text/XML/ToJSON/Builder.hs +62/−24
- tests/Test.hs +74/−0
- xml2json.cabal +15/−1
Main.hs view
@@ -4,10 +4,10 @@ import qualified Data.Conduit.Binary as C import qualified Data.ByteString.Lazy.Char8 as L import Data.Aeson (encode)-import Text.XML.ToJSON (xmlToJSON)+import Text.XML.ToJSON (bsSourceToJSON) main :: IO () main = do [name] <- getArgs- json <- runResourceT $ xmlToJSON (C.sourceFile name)+ json <- runResourceT $ bsSourceToJSON (C.sourceFile name) L.putStrLn $ encode json
Text/XML/ToJSON.hs view
@@ -1,21 +1,39 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}+ module Text.XML.ToJSON- ( elementToJSON- , tokensToJSON+ (++{-| This library provide a way to convert xml to json.+ + Further more, by combining with aeson's parsing facility, it provide a way to parse xml to haskell data type.+ -}+ parseXML , xmlToJSON+ , JSONParseError+ -- * streamlined api+ , bsSourceToJSON+ , bsRSourceToJSON+ -- * utils+ , tokenToBuilder+ , elementToJSON+ , tokensToJSON ) where -import Control.Monad (when)+import Control.Monad (when, liftM) import Control.Arrow (second)-import Control.Applicative ( (<$>), (*>) )+import Control.Exception (Exception)+import Control.Applicative ( (*>), (<|>) ) +import Data.Typeable (Typeable) import Data.Maybe (fromMaybe) import qualified Data.CaseInsensitive as CI import qualified Data.Text as T+import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) import qualified Blaze.ByteString.Builder as B-import Data.Attoparsec.ByteString.Char8 (char)-import Data.Conduit+import qualified Data.Attoparsec as A+import Data.Attoparsec.ByteString.Char8 (char, skipSpace)+import Data.Conduit (Source, yield, (=$), ($$++), ($$+-), MonadThrow(monadThrow)) import Data.Conduit.Internal (ResumableSource(ResumableSource)) import qualified Data.Conduit.List as C import qualified Data.Conduit.Attoparsec as C@@ -27,8 +45,9 @@ import qualified Text.HTML.TagStream.Text as T import qualified Text.HTML.TagStream.ByteString as S import Text.XML.ToJSON.Builder-import Data.Aeson (Value(..), Object)+import Data.Aeson (Value(..), Object, FromJSON, fromJSON, Result(Error, Success)) +-- | Convert tagstream-conduit `Token' to xml element `Builder' tokenToBuilder :: T.Token -> Builder tokenToBuilder (TagOpen s as selfClose) = do beginElement s@@ -38,13 +57,9 @@ tokenToBuilder (Text s) = addValue s tokenToBuilder _ = return () -attrsToObject :: [(Str, Str)] -> Object-attrsToObject = HM.fromList . map (second String)--mergeObject :: Value -> Value -> Value-mergeObject (Array arr) v = Array (V.cons v arr)-mergeObject v1 v2 = Array (V.fromList [v1, v2])-+-- |Convert xml `Element' to aeson `Value' .+--+-- xml attributes and text values are converted to special object attribute @__attributes@ and @__values@. elementToJSON :: Element -> Value elementToJSON (Element as vs cs) = if null as && null cs@@ -63,14 +78,31 @@ then [] else [("__values", Array (V.fromList (map String vs)))] + attrsToObject :: [(T.Text, T.Text)] -> Object+ attrsToObject = HM.fromList . map (second String)++ mergeObject :: Value -> Value -> Value+ mergeObject v (Array arr) = Array (V.cons v arr)+ mergeObject v1 v2 = Array (V.fromList [v1, v2])++-- |Convert list of tagstream-conduit `Token` to aeson `Value' tokensToJSON :: [T.Token] -> Value tokensToJSON tokens = elementToJSON $ runBuilder (mapM_ tokenToBuilder tokens) -xmlToJSON :: (Functor m, Monad m, MonadThrow m) => Source m ByteString -> m Value-xmlToJSON src = do+-- | Consume a source and convert the content to aeson `Value', it try to inspect xml encoding from first tag.+--+-- e.g. @bsSourceToJSON (C.sourceFile path_to_xml_file)@+bsSourceToJSON :: MonadThrow m => Source m ByteString -> m Value+bsSourceToJSON src = bsRSourceToJSON (ResumableSource src (return ()))++-- | Consume a source and convert the content to aeson `Value', it try to inspect xml encoding from first tag.+--+-- e.g. @xmlStreamToJSONResumable (requestBody req)@+bsRSourceToJSON :: MonadThrow m => ResumableSource m ByteString -> m Value+bsRSourceToJSON src = do -- try to peek the first tag to find the xml encoding.- (src', token) <- src $$+ C.sinkParser (char '<' *> S.tag)+ (src', token) <- src $$++ C.sinkParser (skipBOM *> skipSpace *> char '<' *> S.tag) let (mencoding, src'') = case token of@@ -85,19 +117,42 @@ codec = fromMaybe C.utf8 (mencoding >>= getCodec . CI.mk) - tokensToJSON <$> (src'' $$+- (C.decode codec =$ T.tokenStream =$ C.consume))+ liftM tokensToJSON (src'' $$+- (C.decode codec =$ T.tokenStream =$ C.consume))+ where+ skipBOM :: A.Parser ()+ skipBOM =+ ( A.string "\xff\xfe"+ <|> A.string "\xef\xbb\xbf"+ ) *> return ()+ <|> return () -prependRSrc :: Monad m- => Source m a- -> ResumableSource m a- -> ResumableSource m a-prependRSrc src (ResumableSource src' close) = ResumableSource (src >> src') close+ prependRSrc :: Monad m+ => Source m a+ -> ResumableSource m a+ -> ResumableSource m a+ prependRSrc src (ResumableSource src' close) = ResumableSource (src >> src') close -getCodec :: CI.CI ByteString -> Maybe C.Codec-getCodec c =- case c of- "utf-8" -> Just C.utf8- "utf8" -> Just C.utf8- "iso8859" -> Just C.iso8859_1- _ -> Nothing+ getCodec :: CI.CI ByteString -> Maybe C.Codec+ getCodec c =+ case c of+ "utf-8" -> Just C.utf8+ "utf8" -> Just C.utf8+ "iso8859" -> Just C.iso8859_1+ _ -> Nothing +newtype JSONParseError = JSONParseError String+ deriving (Typeable, Show)+instance Exception JSONParseError++-- | parse xml to haskell data type by using aeson's `FromJSON'.+parseXML :: (MonadThrow m, FromJSON a) => L.ByteString -> m a+parseXML s = xmlToJSON s >>= convert+ where+ convert v =+ case fromJSON v of+ Error err -> monadThrow (JSONParseError err)+ Success a -> return a++-- | convert lazy xml `ByteString' to aeson `Value'.+xmlToJSON :: MonadThrow m => L.ByteString -> m Value+xmlToJSON s = bsSourceToJSON (C.sourceList (L.toChunks s))
Text/XML/ToJSON/Builder.hs view
@@ -1,55 +1,89 @@ {-# LANGUAGE OverloadedStrings #-}-module Text.XML.ToJSON.Builder where+module Text.XML.ToJSON.Builder+ ( -- * Element type and operations+ Element(..)+ , emptyElement+ , addChild'+ , addValue'+ , addAttr'+ , addAttrs'+ -- * Stack type and operations+ , Stack+ , popStack+ , closeStack+ -- * Builder type and operations+ , Builder+ , runBuilder+ , beginElement+ , endElement+ , modifyTopElement+ , addChild+ , addValue+ , addAttr+ , addAttrs+ ) where import Data.Text (Text) import Control.Monad.Trans.State -type Str = Text-+-- | represent a XML element. data Element = Element- { elAttrs :: [(Str, Str)]- , elValues :: [Str]- , elChildren :: [(Str, Element)]+ { elAttrs :: [(Text, Text)] -- ^ tag attributes.+ , elValues :: [Text] -- ^ text values.+ , elChildren :: [(Text, Element)] -- ^ child elements. } deriving (Show) emptyElement :: Element emptyElement = Element [] [] [] -addChild' :: (Str, Element) -> Element -> Element+-- | add a child element to an element+addChild' :: (Text, Element) -> Element -> Element addChild' item o = o { elChildren = item : elChildren o } -addValue' :: Str -> Element -> Element+-- | add a text value to an element+addValue' :: Text -> Element -> Element addValue' v o = o { elValues = v : elValues o } -addAttr' :: (Str, Str) -> Element -> Element+-- | add an attribute to an element+addAttr' :: (Text, Text) -> Element -> Element addAttr' attr o = o { elAttrs = attr : elAttrs o } -addAttrs' :: [(Str, Str)] -> Element -> Element+-- | add multiple attributes to an element+addAttrs' :: [(Text, Text)] -> Element -> Element addAttrs' as o = o { elAttrs = as ++ elAttrs o } -type Stack = [(Str, Element)]-type Builder = State Stack ()--runBuilder :: Builder -> Element-runBuilder b = finishStack $ execState b [("", emptyElement)]+-- | xml element stack with recent opened element at the top.+type Stack = [(Text, Element)] +-- | close current tag. popStack :: Stack -> Stack popStack ((k,v) : (name,elm) : tl) = (name, addChild' (k,v) elm) : tl popStack _ = error "popStack: can't pop root elmect." -finishStack :: Stack -> Element-finishStack [] = error "finishStack: empty stack."-finishStack [(_, elm)] = elm-finishStack st = finishStack (popStack st)+-- | close all unclosed tags and return the root element.+closeStack :: Stack -> Element+closeStack [] = error "closeStack: empty stack."+closeStack [(_, elm)] = elm+closeStack st = closeStack (popStack st) -beginElement :: Str -> Builder+-- | `Builder' is a `State' monad to transform a `Stack'.+type Builder = State Stack ()++-- | exec the state monad and close the result stack.+runBuilder :: Builder -> Element+runBuilder b = closeStack $ execState b [("", emptyElement)]++-- | open element+beginElement :: Text -> Builder beginElement name = modify ( (name, emptyElement) : ) +-- | close element endElement :: Builder endElement = modify popStack +-- | util to modify top element. modifyTopElement :: (Element -> Element) -> Builder modifyTopElement f = modify $ \st ->@@ -57,14 +91,18 @@ ((k, v) : tl) -> (k, f v) : tl _ -> fail "modifyTopElement: impossible: empty stack." -addValue :: Str -> Builder+-- | add value to top element.+addValue :: Text -> Builder addValue = modifyTopElement . addValue' -addAttr :: (Str, Str) -> Builder+-- | add attribute to top element.+addAttr :: (Text, Text) -> Builder addAttr = modifyTopElement . addAttr' -addAttrs :: [(Str, Str)] -> Builder+-- | add multiple attributes to top element.+addAttrs :: [(Text, Text)] -> Builder addAttrs = modifyTopElement . addAttrs' -addChild :: (Str, Element) -> Builder+-- | add child element to top element.+addChild :: (Text, Element) -> Builder addChild = modifyTopElement . addChild'
+ tests/Test.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}+import Debug.Trace++import Control.Monad (liftM)+import Control.Monad.Trans.Resource (runExceptionT)+import Control.Exception (throw)+import Data.Functor.Identity (runIdentity)+import qualified Data.ByteString.Lazy as L+import qualified Data.Text.Encoding as T+import Data.Aeson (encode)+import Text.XML.ToJSON (xmlToJSON)+import Test.Hspec++toLazy s = L.fromChunks [s]++cases :: [(String, L.ByteString, L.ByteString)]+cases =+ [ ( "basic"+ , toLazy $ T.encodeUtf8 $+ "<user>\+ \<name>foo</name>\+ \<addr>bar road</addr>\+ \</user>"+ , toLazy $ T.encodeUtf8 $+ "{\"user\":{\"name\":\"foo\",\"addr\":\"bar road\"}}"+ )+ , ( "unicode"+ , toLazy $ T.encodeUtf8 $+ "<?xml encoding=\"utf-8\"?>\n\+ \<user>\+ \<name>测试</name>\+ \<addr>bar road</addr>\+ \</user>"+ , toLazy $ T.encodeUtf8 $+ "{\"user\":{\"name\":\"测试\",\"addr\":\"bar road\"}}"+ )+ , ( "array"+ , toLazy $ T.encodeUtf8 $+ "<users>\+ \<user>\+ \<name>foo</name>\+ \<addr>foo road</addr>\+ \</user>\+ \<user>\+ \<name>bar</name>\+ \<addr>bar road</addr>\+ \</user>\+ \<user>\+ \<name>test</name>\+ \<addr>test road</addr>\+ \</user>\+ \</users>"+ , toLazy $ T.encodeUtf8 $+ "{\"users\":\+ \{\"user\":\+ \[{\"name\":\"foo\",\"addr\":\"foo road\"}\+ \,{\"name\":\"bar\",\"addr\":\"bar road\"}\+ \,{\"name\":\"test\",\"addr\":\"test road\"}\+ \]\+ \}\+ \}"+ )+ ]++one (desc, xml, json) =+ it desc $+ let m = liftM encode (xmlToJSON xml)+ in either throw+ (==json)+ (runIdentity (runExceptionT m))++main :: IO ()+main = hspec $ do+ describe "basic cases" $ mapM_ one cases
xml2json.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.1+version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: translate xml to json@@ -90,3 +90,17 @@ , blaze-builder-conduit ==0.5.* , attoparsec-conduit ==0.5.* , tagstream-conduit ==0.5.*++test-suite test+ hs-source-dirs: tests+ main-is: Test.hs+ type: exitcode-stdio-1.0+ build-depends: base >= 4 && < 5+ , transformers >= 0.3+ , resourcet >= 0.3+ , hspec >= 1.3+ , bytestring+ , text+ , aeson+ , xml2json >= 0.2+ ghc-options: -Wall