aws-sdk-xml-unordered 0.1.1 → 0.2
raw patch · 3 files changed
+80/−23 lines, 3 files
Files
- aws-sdk-xml-unordered.cabal +1/−1
- src/Cloud/AWS/Lib/Parser/Unordered.hs +44/−22
- test/test.hs +35/−0
aws-sdk-xml-unordered.cabal view
@@ -1,5 +1,5 @@ name: aws-sdk-xml-unordered-version: 0.1.1+version: 0.2 synopsis: The xml parser for aws-sdk description: This package provides the unordered xml parser for aws-sdk. license: BSD3
src/Cloud/AWS/Lib/Parser/Unordered.hs view
@@ -33,7 +33,7 @@ data SimpleXML = Map (HashMap Text [SimpleXML]) | Content Text- deriving (Show)+ deriving (Show, Eq) data ParseError = ParseError { parseErrorMessage :: Text@@ -50,7 +50,7 @@ => (SimpleXML -> m a) -> ConduitM Event o m (Maybe a) xmlParserM parse = do- xmlm <- getXML+ xmlm <- getMultiXML case xmlm of Just xml -> lift $ liftM Just $ parse xml Nothing -> return Nothing@@ -67,42 +67,64 @@ innerParser parse _ -> monadThrow $ ParseError $ "xmlParserConduit: no element '" <> set <> "'" where+ innerParser :: MonadThrow m => (SimpleXML -> m a) -> Conduit Event m a innerParser parse' = do- ma <- xmlParserM parse'- case ma of- Just a -> yield a >> innerParser parse'+ xmlm <- getSingleXML+ case xmlm of+ Just xml -> do+ a <- lift $ parse' xml+ yield a+ innerParser parse' Nothing -> return () -getXML :: MonadThrow m- => ConduitM Event o m (Maybe SimpleXML)-getXML = do+getSingleXML :: MonadThrow m+ => ConduitM Event o m (Maybe SimpleXML)+getSingleXML = do e <- dropWS case e of Just (EventBeginElement name _) -> do CL.drop 1 xmls <- getXMLList- let xml = Map $ HM.singleton (nameLocalName name) $ case xmls of- [Content _] -> xmls- _ -> [Map $ foldr (HM.unionWith (++) . toHMap) HM.empty xmls]+ let xml = Map $ HM.singleton (nameLocalName name) $ foldXML xmls e' <- dropWS case e' of Just (EventEndElement name') | name == name' -> CL.drop 1 >> return (Just xml)- _ -> lift $ monadThrow $ XmlException ("Expected end tag: " ++ show name) e'+ _ -> lift $ monadThrow $ XmlException ("getSingleXML: Expected end tag for: " ++ show name) e' Just (EventContent (ContentText t)) -> CL.drop 1 >> return (Just $ Content t) _ -> return Nothing++foldXML :: [SimpleXML] -> [SimpleXML]+foldXML [] = []+foldXML xmls@(Content _ : _) = [Content $ T.concat . map toContent $ xmls] where- getXMLList = do- e <- dropWS- case e of- Just EventEndElement{} -> return []- _ -> do- xml <- getXML- case xml of- Just xml' -> (xml' :) <$> getXMLList- Nothing -> return []+ toContent (Map _) = error $ "getSingleXML: Unexpected structure. Please report. " ++ show xmls+ toContent (Content t) = t+foldXML xmls@(Map _ : _) = case [Map $ foldr (HM.unionWith (++) . toHMap) HM.empty xmls] of+ [Map hmap] | hmap == HM.fromList [] -> []+ xmls' -> xmls'+ where toHMap (Map hmap) = hmap- toHMap _ = error "toHMap: invalid structure"+ toHMap _ = error $ "getSingleXML: Unexpected structure. Please report. " ++ show xmls++getMultiXML :: MonadThrow m+ => ConduitM Event o m (Maybe SimpleXML)+getMultiXML = do+ xmls <- getXMLList+ return $ listToMaybe $ foldXML xmls++getXMLList :: MonadThrow m+ => ConduitM Event o m [SimpleXML]+getXMLList = do+ e <- dropWS+ case e of+ Just EventEndElement{} -> return []+ Nothing -> return []+ _ -> do+ xml <- getSingleXML+ case xml of+ Just xml' -> (xml' :) <$> getXMLList+ Nothing -> return [] dropWS :: Monad m => ConduitM Event o m (Maybe Event) dropWS = do -- drop white space
test/test.hs view
@@ -22,6 +22,8 @@ it "parse top data set" parseTopDataSet it "parse list of text" parseList it "cannot parse list of text" parseListFailure+ it "parse top level elements" parseTopElements+ it "parse escaped content" parseEscaped describe "xml parser of maybe version" $ it "parse empty xml" parseEmpty describe "xml parser of conduit version" $ do@@ -376,3 +378,36 @@ , "<data><dummy/></data>" , "</dataSet>" ]++parseTopElements :: Expectation+parseTopElements = do+ d <- runResourceT $ parseLBS def input $$+ xmlParser (\xml -> (,,)+ <$> xml .< "itemA"+ <*> xml .< "itemB"+ <*> getElements xml "itemSet" "item" (\xml' ->+ getElements xml' "itemSet" "item" content+ )+ )+ d `shouldBe` input'+ where+ input = L.concat+ [ "<itemA>item-a</itemA>"+ , "<itemB>item-b</itemB>"+ , "<itemSet>"+ , " <item>"+ , " <itemSet>"+ , " <item>a</item>"+ , " </itemSet>"+ , " </item>"+ , "</itemSet>"+ ]+ input' = ("item-a", "item-b", [["a"]]) :: (Text, Text, [[Text]])++parseEscaped :: Expectation+parseEscaped = do+ d <- runResourceT $ parseLBS def input $$ xmlParser (.< "escaped")+ d `shouldBe` input'+ where+ input = "<escaped>{"version":"1.0","queryDate":"2013-05-08T21:09:40.443+0000","startDate":"2013-05-08T20:09:00.000+0000","statistic":"Maximum","period":3600,"recentDatapoints":[6.89],"threshold":90.5}</escaped>"+ input' = "{\"version\":\"1.0\",\"queryDate\":\"2013-05-08T21:09:40.443+0000\",\"startDate\":\"2013-05-08T20:09:00.000+0000\",\"statistic\":\"Maximum\",\"period\":3600,\"recentDatapoints\":[6.89],\"threshold\":90.5}" :: Text