aws-sdk-xml-unordered 0.2 → 0.3
raw patch · 7 files changed
+524/−292 lines, 7 filesdep +containersdep +lifted-basedep ~mtl
Dependencies added: containers, lifted-base
Dependency ranges changed: mtl
Files
- aws-sdk-xml-unordered.cabal +10/−3
- src/Cloud/AWS/Lib/Parser/Unordered.hs +23/−185
- src/Cloud/AWS/Lib/Parser/Unordered/Conduit.hs +147/−0
- src/Cloud/AWS/Lib/Parser/Unordered/Convert.hs +85/−0
- src/Cloud/AWS/Lib/Parser/Unordered/Path.hs +70/−0
- src/Cloud/AWS/Lib/Parser/Unordered/Types.hs +18/−0
- test/test.hs +171/−104
aws-sdk-xml-unordered.cabal view
@@ -1,7 +1,7 @@ name: aws-sdk-xml-unordered-version: 0.2-synopsis: The xml parser for aws-sdk-description: This package provides the unordered xml parser for aws-sdk.+version: 0.3+synopsis: The xml parser for aws-sdk package+description: This package provides the unordered xml parser for aws-sdk package. license: BSD3 license-file: LICENSE author: Shohei Yasutake <amutake.s@gmail.com>@@ -15,13 +15,19 @@ library exposed-modules: Cloud.AWS.Lib.Parser.Unordered+ other-modules: Cloud.AWS.Lib.Parser.Unordered.Types+ Cloud.AWS.Lib.Parser.Unordered.Convert+ Cloud.AWS.Lib.Parser.Unordered.Conduit+ Cloud.AWS.Lib.Parser.Unordered.Path build-depends: base ==4.*+ , containers >=0.5 , unordered-containers >=0.2 , conduit >=1.0.1 , xml-conduit >=0.5 , xml-types ==0.3.* , text >=0.1 , mtl >=1.0+ , lifted-base >=0.2 , aws-sdk-text-converter >=0.1 hs-source-dirs: src ghc-options: -Wall -fno-warn-unused-do-bind@@ -38,6 +44,7 @@ , xml-conduit , aws-sdk-xml-unordered , hspec+ , mtl ghc-options: -Wall -threaded -fno-warn-unused-do-bind default-language: Haskell2010
src/Cloud/AWS/Lib/Parser/Unordered.hs view
@@ -1,192 +1,30 @@ {-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} module Cloud.AWS.Lib.Parser.Unordered- ( SimpleXML+ ( XmlElement+ , ElementPath+ , (.=)+ , (.-)+ , tag+ , end+ , anytag+ -- , mergePath , ParseError (..)- , xmlParser- , xmlParserM- , xmlParserConduit- , getT, (.<)- , getElementM- , getElement- , getElements+ , elementConsumer+ , elementConduit+ , convert+ , tryConvert+ , convertMany+ , convertConduit , content+ , (.<)+ , element+ , elementM+ , elements+ -- , lookupTag ) where -import Cloud.AWS.Lib.FromText (FromText (..))-import Control.Applicative ((<$>))-import Control.Exception (Exception)-import Control.Monad (liftM)-import Control.Monad.Trans (lift)-import Data.Char (isSpace)-import Data.Conduit (ConduitM, Conduit, yield, MonadThrow (..))-import qualified Data.Conduit.List as CL-import Data.HashMap.Lazy (HashMap)-import qualified Data.HashMap.Lazy as HM-import Data.Maybe (listToMaybe)-import Data.Monoid ((<>))-import Data.Text (Text)-import qualified Data.Text as T-import Data.Typeable (Typeable)-import Data.XML.Types (Event (..), Name (..), Content (..))-import Text.XML.Stream.Parse (XmlException (..))--data SimpleXML = Map (HashMap Text [SimpleXML])- | Content Text- deriving (Show, Eq)--data ParseError = ParseError- { parseErrorMessage :: Text- } deriving (Show, Typeable)-instance Exception ParseError--xmlParser :: MonadThrow m- => (SimpleXML -> m a)- -> ConduitM Event o m a-xmlParser parse = xmlParserM parse >>=- maybe (lift $ monadThrow $ ParseError "xmlParser: invalid xml") return--xmlParserM :: MonadThrow m- => (SimpleXML -> m a)- -> ConduitM Event o m (Maybe a)-xmlParserM parse = do- xmlm <- getMultiXML- case xmlm of- Just xml -> lift $ liftM Just $ parse xml- Nothing -> return Nothing--xmlParserConduit :: MonadThrow m- => Text -- ^ name of item set- -> (SimpleXML -> m a) -- ^ item parser- -> Conduit Event m a-xmlParserConduit set parse = do- e <- dropWS- case e of- Just (EventBeginElement name _) | nameLocalName name == set -> do- CL.drop 1- innerParser parse- _ -> monadThrow $ ParseError $ "xmlParserConduit: no element '" <> set <> "'"- where- innerParser :: MonadThrow m => (SimpleXML -> m a) -> Conduit Event m a- innerParser parse' = do- xmlm <- getSingleXML- case xmlm of- Just xml -> do- a <- lift $ parse' xml- yield a- innerParser parse'- Nothing -> return ()--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) $ foldXML xmls- e' <- dropWS- case e' of- Just (EventEndElement name')- | name == name' -> CL.drop 1 >> return (Just xml)- _ -> 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- 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 $ "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- e <- CL.peek- if isWS e then CL.drop 1 >> dropWS else return e- where- isWS e = case e of -- is white space- Just EventBeginDocument -> True- Just EventEndDocument -> True- Just EventBeginDoctype{} -> True- Just EventEndDoctype -> True- Just EventInstruction{} -> True- Just EventBeginElement{} -> False- Just EventEndElement{} -> False- Just (EventContent (ContentText t))- | T.all isSpace t -> True- | otherwise -> False- Just (EventContent ContentEntity{}) -> False- Just EventComment{} -> True- Just EventCDATA{} -> False- Nothing -> False--fromMaybeM :: Monad m => m a -> Maybe a -> m a-fromMaybeM a Nothing = a-fromMaybeM _ (Just a) = return a--getContentText :: SimpleXML -> Maybe Text-getContentText (Map _) = Nothing-getContentText (Content c) = return c--getSubXMLs :: SimpleXML -> Text -> [SimpleXML]-getSubXMLs (Map hmap) name = cat $ HM.lookup name hmap- where- cat (Just xs) = xs- cat Nothing = []-getSubXMLs (Content _) _ = []--getSubXMLM :: SimpleXML -> Text -> Maybe SimpleXML-getSubXMLM xml name = listToMaybe $ getSubXMLs xml name--getT :: (MonadThrow m, FromText a) => SimpleXML -> Text -> m a-getT xml name = fromNamedText name $- getSubXMLM xml name >>= getContentText---- | infix version of getT. like aeson's (.:).-(.<) :: (MonadThrow m, FromText a) => SimpleXML -> Text -> m a-(.<) = getT--getElementM :: MonadThrow m => SimpleXML -> Text -> (SimpleXML -> m a) -> m (Maybe a)-getElementM xml name parse = case getSubXMLM xml name of- Just xml' -> liftM Just $ parse xml'- Nothing -> return Nothing--getElement :: MonadThrow m => SimpleXML -> Text -> (SimpleXML -> m a) -> m a-getElement xml name parse = getElementM xml name parse >>=- fromMaybeM (monadThrow $ ParseError $ "getElement: element '" <> name <> "' not found")--getElements :: MonadThrow m => SimpleXML -> Text -> Text -> (SimpleXML -> m a) -> m [a]-getElements xml set item parse = case getSubXMLM xml set of- Just xml' -> mapM parse $ getSubXMLs xml' item- Nothing -> return []--content :: MonadThrow m => SimpleXML -> m Text-content (Content t) = return t-content _ = fail "This is not a content."+import Cloud.AWS.Lib.Parser.Unordered.Types+import Cloud.AWS.Lib.Parser.Unordered.Conduit+import Cloud.AWS.Lib.Parser.Unordered.Convert+import Cloud.AWS.Lib.Parser.Unordered.Path
+ src/Cloud/AWS/Lib/Parser/Unordered/Conduit.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, ScopedTypeVariables #-}++module Cloud.AWS.Lib.Parser.Unordered.Conduit where++import Control.Applicative+import Control.Exception (SomeException)+import Control.Exception.Lifted (try)+import Control.Monad.Trans (lift)+import Data.Char (isSpace)+import Data.Conduit+import qualified Data.Conduit.List as CL+import qualified Data.HashMap.Strict as HM+import Data.Maybe (maybeToList)+import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Tree+import Data.XML.Types++import Cloud.AWS.Lib.Parser.Unordered.Path+import Cloud.AWS.Lib.Parser.Unordered.Types++-- | top-level xml element consumer.+-- e.g.,+elementConsumer :: MonadThrow m+ => Consumer Event m XmlElement+elementConsumer = getElement >>=+ maybe (monadThrow $ ParseError "elementConsumer: the top element is not found") return++-- | map from 'Event' to 'XmlElement'.+elementConduit :: MonadThrow m+ => ElementPath+ -> Conduit Event m XmlElement+elementConduit tree = go []+ where+ snoc l x = l ++ [x]++ treeElem [path] (Node (TagName root) []) = root == path+ treeElem (_ : paths) (Node AnyTag forest) = any (treeElem paths) forest+ treeElem (path : paths) (Node (TagName root) forest)+ | root == path = any (treeElem paths) forest+ | otherwise = False+ treeElem _ _ = False++ isTarget name now = treeElem (snoc now $ nameLocalName name) tree++ go now = do+ drops+ e <- CL.peek+ case e of+ Just (EventBeginElement name _) | isTarget name now -> do+ el <- getElement+ maybe (return ()) yield el+ go now+ Just (EventBeginElement name _) -> do+ CL.drop 1+ go $ snoc now $ nameLocalName name+ Just (EventEndElement name) -> do+ CL.drop 1+ if last now == nameLocalName name+ then go $ init now+ else monadThrow $ ParseError "elementConduit: invalid XML"+ Nothing -> return ()+ _ -> CL.drop 1 >> go now++-- | Drop unnecessary events.+drops :: Monad m => ConduitM Event o m ()+drops = do+ e <- CL.peek+ case e of+ Just e' | unnecessary e' -> CL.drop 1 >> drops+ _ -> return ()+ where+ unnecessary EventBeginElement{} = False+ unnecessary EventEndElement{} = False+ unnecessary (EventContent (ContentText t))+ | T.all isSpace t = True+ | otherwise = False+ unnecessary (EventContent ContentEntity{}) = False+ unnecessary _ = True++getElement :: MonadThrow m+ => ConduitM Event o m (Maybe XmlElement)+getElement = do+ drops+ e <- CL.peek+ case e of+ Just (EventBeginElement name _) -> do+ CL.drop 1+ els <- getElements+ let el = HM $ HM.singleton (nameLocalName name) $ maybeToList $ foldElements els+ drops+ e' <- CL.peek+ case e' of+ Just (EventEndElement name')+ | name == name' -> CL.drop 1 >> return (Just el)+ _ -> lift $ monadThrow $ ParseError ("getElement: expected end tag: " <> T.pack (show name)) -- arienai+ Just (EventContent (ContentText t)) -> CL.drop 1 >> return (Just $ T t)+ _ -> return Nothing++getElements :: MonadThrow m+ => ConduitM Event o m [XmlElement]+getElements = do+ drops+ e <- CL.peek+ case e of+ Just EventEndElement{} -> return []+ Nothing -> return []+ _ -> getElement >>= maybe (return []) (\el -> (el :) <$> getElements)++foldElements :: [XmlElement] -> Maybe XmlElement+foldElements [] = Nothing+foldElements els@(T _ : _) = Just . T . T.concat . map extract $ els+ where+ extract (T t) = t+ extract _ = error $ "foldElements: Unexpected structure. Please report. " ++ show els+foldElements els@(HM _ : _)+ | hm == HM.empty = Nothing+ | otherwise = Just $ HM hm+ where+ hm = foldr (HM.unionWith (++) . extract) HM.empty els+ extract (HM hmap) = hmap+ extract _ = error $ "foldelements: Unexpected structure. Please report. " ++ show els++convert :: MonadThrow m => (XmlElement -> m a) -> ConduitM XmlElement o m a+convert conv = await >>= maybe (lift . monadThrow $ ParseError "convert: no element") (lift . conv)++convertConduit :: MonadBaseControl IO m => (XmlElement -> m a) -> Conduit XmlElement m a+convertConduit conv = tryConvert conv >>= maybe (return ()) (\a -> yield a >> convertConduit conv)++-- | if conversion is success, it consume an element. otherwise, it does not consume any elements.+tryConvert :: MonadBaseControl IO m+ => (XmlElement -> m a)+ -> ConduitM XmlElement o m (Maybe a)+tryConvert conv = await >>= maybe none (\el ->+ lift (tryMaybe $ conv el) >>= maybe (leftover el >> none) (return . Just))+ where+ none = return Nothing+ tryMaybe m = do+ ei <- try m+ case ei of+ Left (_ :: SomeException) -> return Nothing+ Right a -> return $ Just a++convertMany :: MonadBaseControl IO m+ => (XmlElement -> m a)+ -> ConduitM XmlElement o m [a]+convertMany conv = tryConvert conv >>= maybe (return []) (\a -> (a :) <$> convertMany conv)
+ src/Cloud/AWS/Lib/Parser/Unordered/Convert.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}++module Cloud.AWS.Lib.Parser.Unordered.Convert+ ( (.<)+ , content+ , element+ , elementM+ , elements+ , lookupTag+ ) where++import Control.Monad+import Data.Conduit+import qualified Data.HashMap.Strict as HM+import Data.Maybe+import Data.Monoid+import Data.Text (Text)++import Cloud.AWS.Lib.FromText (FromText (..))+import Cloud.AWS.Lib.Parser.Unordered.Types++getContentText :: XmlElement -> Maybe Text+getContentText (HM _) = Nothing+getContentText (T c) = return c++getSubElements :: XmlElement -> Text -> [XmlElement]+getSubElements (HM hm) name = cat $ HM.lookup name hm+ where+ cat (Just xs) = xs+ cat Nothing = []+getSubElements (T _) _ = []++getSubElement :: XmlElement -> Text -> Maybe XmlElement+getSubElement el = listToMaybe . getSubElements el++-- | the operator like aeson's (.:).+(.<) :: (MonadThrow m, FromText a) => XmlElement -> Text -> m a+(.<) xml name = fromNamedText name $+ getSubElement xml name >>= getContentText++-- | content "<tag>tag-content</tag>" === "tag-content"+content :: (MonadThrow m, FromText t) => XmlElement -> m t+content (T t) = fromText t+content _ = monadThrow $ ParseError "This is not a content."++-- | 'elementM conv name el' return Nothing if 'el' doesn't have any elements named "name". otherwise, return 'Just a'.+elementM :: MonadThrow m+ => Text -- ^ tag name+ -> (XmlElement -> m a) -- ^ Conversion function+ -> XmlElement -- ^ element+ -> m (Maybe a)+elementM name conv el = maybe+ (return Nothing)+ (liftM Just . conv)+ (getSubElement el name)++-- | This function throws error if the result of 'elementM' is Nothing.+element :: MonadThrow m+ => Text -- ^ tag name+ -> (XmlElement -> m a) -- ^ conversion function+ -> XmlElement -- ^ element+ -> m a+element name conv el = elementM name conv el >>= maybe+ (monadThrow $ ParseError $ "element: element '" <> name <> "' not found")+ return++elements :: MonadThrow m+ => Text -- ^ name of sets+ -> Text -- ^ name of item+ -> (XmlElement -> m a) -- ^ convert function+ -> XmlElement -- ^ element+ -> m [a]+elements setname itemname conv el = maybe+ (return [])+ (mapM conv . flip getSubElements itemname)+ (getSubElement el setname)++lookupTag :: MonadThrow m+ => Text+ -> XmlElement+ -> m XmlElement+lookupTag name el = case getSubElements el name of+ [e] -> return e+ [] -> monadThrow $ ParseError $ "lookupTag: tag '" <> name <> "' not found"+ _ -> monadThrow $ ParseError $ "lookupTag: tag '" <> name <> "' is list. please use lookupTags."
+ src/Cloud/AWS/Lib/Parser/Unordered/Path.hs view
@@ -0,0 +1,70 @@+module Cloud.AWS.Lib.Parser.Unordered.Path+ ( ElementName (..)+ , ElementPath+ , (.=)+ , (.-)+ , tag+ , end+ , anytag+ -- , mergePath+ ) where++import Data.String (IsString (..))+import Data.Text (Text)+import Data.Tree (Tree (..))++import Cloud.AWS.Lib.ToText (ToText (..))++data ElementName = TagName Text | AnyTag deriving (Eq)++instance Show ElementName where+ show (TagName t) = show t+ show AnyTag = "<any>"++instance IsString ElementName where+ fromString = TagName . fromString++type ElementPath = Tree ElementName++infixr 1 .=+-- | infix version of 'Node'+(.=) :: ElementName -> [ElementPath] -> ElementPath+name .= paths = Node name paths+{-# INLINE (.=) #-}++infixr 1 .-+(.-) :: ElementName -> ElementPath -> ElementPath+name .- path = Node name [path]+{-# INLINE (.-) #-}++tag :: ToText a => a -> ElementName+tag a = TagName $ toText a+{-# INLINE tag #-}++end :: ElementName -> ElementPath+end name = Node name []+{-# INLINE end #-}++anytag :: ElementName+anytag = AnyTag+{-# INLINE anytag #-}++-- normalize :: ElementPath -> ElementPath+-- normalize (Node root forest) = Node root $ normalize' forest+-- where+-- normalize' [] = []+-- normalize' fs = if elem AnyTag fs+-- then [AnyTag]+-- else normalize'' fs+-- normalize'' [] = []+-- normalize'' (p:ps) = if elem p ps+-- then normalize'' ps+-- else p : normalize'' ps++-- mergePath :: ElementPath -> ElementPath -> ElementPath+-- mergePath (Node AnyTag f1) (Node AnyTag f2) = AnyTag .- mergePaths f1 f2++-- mergePaths :: [ElementPath] -> [ElementPath] -> [ElementPath]+-- margePaths [] ps = ps+-- mergePaths ps [] = ps+-- mergePaths (AnyTag:p1s) p2s = [AnyTag]
+ src/Cloud/AWS/Lib/Parser/Unordered/Types.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Cloud.AWS.Lib.Parser.Unordered.Types where++import Control.Exception (Exception)+import Data.HashMap.Strict (HashMap)+import Data.Text (Text)+import Data.Typeable (Typeable)++data XmlElement = HM (HashMap Text [XmlElement])+ | T Text+ deriving (Show, Eq)++data ParseError = ParseError+ { parseErrorMessage :: Text+ } deriving (Show, Typeable)++instance Exception ParseError
test/test.hs view
@@ -12,24 +12,27 @@ main :: IO () main = hspec $ do- describe "xml parser" $ do- it "parse normal xml" parseNormal- it "parse xml which contains unordered elements" parseUnordered- it "parse xml which contains empty list" parseEmptyList- it "parse xml which does not contain itemSet tag" parseNotAppearItemSet- it "cannot parse unexpected xml structure" notParseUnexpectedDataStructure+ describe "unordered parser" $ do+ it "can parse normal xml" parseNormal+ it "can parse xml which contains unordered elements" parseUnordered+ it "cannot parse empty xml" cannotParseEmpty+ it "can parse xml which contains empty list" parseEmptyList+ it "can parse xml which does not contain itemSet tag" parseNotAppearItemSet+ it "cannot parse unexpected xml structure" cannotParseUnexpectedDataStructure it "ignore unexpected tag" ignoreUnexpectedTag- it "parse top data set" parseTopDataSet- it "parse list of text" parseList+ it "can parse top data set" parseTopDataSet+ it "can 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- it "parse normal xml" parseTopDataSetConduit- it "parse empty itemSet" parseEmptyItemSetConduit+ it "can parse escaped content" parseEscaped+ it "can parse ec2response-like xml" parseEC2Response+ describe "unordered parser using conduit" $ do+ it "can parse normal xml" parseTopDataSetConduit+ it "can parse empty itemSet" parseEmptyItemSetConduit+ it "can parse ec2response-like xml" parseEC2ResponseConduit +parseError :: Selector ParseError+parseError = const True+ data TestData = TestData { testDataId :: Int , testDataName :: Text@@ -44,25 +47,27 @@ , testItemSubItem :: Maybe TestItem } deriving (Eq, Show) -parseTestData :: (MonadThrow m, Applicative m) => SimpleXML -> m TestData-parseTestData xml = TestData- <$> xml .< "id"- <*> xml .< "name"- <*> xml .< "description"- <*> getElements xml "itemSet" "item" parseTestItem+dataConv :: (MonadThrow m, Applicative m) => XmlElement -> m TestData+dataConv e = TestData+ <$> e .< "id"+ <*> e .< "name"+ <*> e .< "description"+ <*> elements "itemSet" "item" itemConv e -parseTestItem :: (MonadThrow m, Applicative m) => SimpleXML -> m TestItem-parseTestItem xml = TestItem- <$> xml .< "id"- <*> xml .< "name"- <*> xml .< "description"- <*> getElementM xml "subItem" parseTestItem+itemConv :: (MonadThrow m, Applicative m) => XmlElement -> m TestItem+itemConv e = TestItem+ <$> e .< "id"+ <*> e .< "name"+ <*> e .< "description"+ <*> elementM "subItem" itemConv e +getElement :: MonadThrow m => L.ByteString -> m XmlElement+getElement input = parseLBS def input $$ elementConsumer+ parseNormal :: Expectation parseNormal = do- d <- runResourceT $ parseLBS def input $$- xmlParser (\xml -> getElement xml "data" parseTestData)- d `shouldBe` input'+ result <- getElement input >>= element "data" dataConv+ result `shouldBe` expectedData where input = L.concat [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"@@ -87,7 +92,7 @@ , " </itemSet>" , "</data>" ]- input' = TestData+ expectedData = TestData { testDataId = 1 , testDataName = "test" , testDataDescription = Just "this is test"@@ -114,9 +119,8 @@ parseUnordered :: Expectation parseUnordered = do- d <- runResourceT $ parseLBS def input $$- xmlParser (\xml -> getElement xml "data" parseTestData)- d `shouldBe` input'+ result <- getElement input >>= element "data" dataConv+ result `shouldBe` expectedData where input = L.concat [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"@@ -141,7 +145,7 @@ , " <id>1</id>" , "</data>" ]- input' = TestData+ expectedData = TestData { testDataId = 1 , testDataName = "test" , testDataDescription = Just "this is test"@@ -166,20 +170,17 @@ ] } -parseEmpty :: Expectation-parseEmpty = do- d <- runResourceT $ parseLBS def input $$- xmlParserM (\xml -> getElement xml "data" parseTestData)- d `shouldBe` input'+cannotParseEmpty :: Expectation+cannotParseEmpty =+ (getElement input >>= element "data" dataConv)+ `shouldThrow` parseError where input = "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"- input' = Nothing parseEmptyList :: Expectation parseEmptyList = do- d <- runResourceT $ parseLBS def input $$- xmlParser (\xml -> getElement xml "data" parseTestData)- d `shouldBe` input'+ result <- getElement input >>= element "data" dataConv+ result `shouldBe` expectedData where input = L.concat [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"@@ -191,7 +192,7 @@ , " </itemSet>" , "</data>" ]- input' = TestData+ expectedData = TestData { testDataId = 1 , testDataName = "test" , testDataDescription = Just "this is test"@@ -200,9 +201,8 @@ parseNotAppearItemSet :: Expectation parseNotAppearItemSet = do- d <- runResourceT $ parseLBS def input $$- xmlParser (\xml -> getElement xml "data" parseTestData)- d `shouldBe` input'+ result <- getElement input >>= element "data" dataConv+ result `shouldBe` expectedData where input = L.concat [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"@@ -211,18 +211,17 @@ , " <name>test</name>" , "</data>" ]- input' = TestData+ expectedData = TestData { testDataId = 1 , testDataName = "test" , testDataDescription = Nothing , testDataItemsSet = [] } -notParseUnexpectedDataStructure :: Expectation-notParseUnexpectedDataStructure =- runResourceT (parseLBS def input $$- xmlParser (\xml -> getElement xml "data" parseTestData))- `shouldThrow` errorCall "FromText error: no text name=name"+cannotParseUnexpectedDataStructure :: Expectation+cannotParseUnexpectedDataStructure =+ (getElement input >>= element "data" dataConv)+ `shouldThrow` anyException -- errorCall "FromText error: no text name=name" where input = L.concat [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"@@ -237,9 +236,8 @@ ignoreUnexpectedTag :: Expectation ignoreUnexpectedTag = do- d <- runResourceT $ parseLBS def input $$- xmlParser (\xml -> getElement xml "data" parseTestData)- d `shouldBe` input'+ result <- getElement input >>= element "data" dataConv+ result `shouldBe` expectedData where input = L.concat [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"@@ -254,7 +252,7 @@ , " <unexpectedTag>tag</unexpectedTag>" , "</data>" ]- input' = TestData+ expectedData = TestData { testDataId = 1 , testDataName = "test" , testDataDescription = Nothing@@ -263,9 +261,8 @@ parseTopDataSet :: Expectation parseTopDataSet = do- d <- runResourceT $ parseLBS def input $$- xmlParser (\xml -> getElements xml "dataSet" "data" parseTestData)- d `shouldBe` input'+ result <- getElement input >>= elements "dataSet" "data" dataConv+ result `shouldBe` expectedData where input = L.concat [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"@@ -283,7 +280,7 @@ , " </data>" , "</dataSet>" ]- input' =+ expectedData = [ TestData { testDataId = 1 , testDataName = "test1"@@ -300,11 +297,12 @@ parseTopDataSetConduit :: Expectation parseTopDataSetConduit = do- d <- runResourceT $ parseLBS def input $=- xmlParserConduit "dataSet" (\xml -> getElement xml "data" parseTestData) $$+ result <- runResourceT $ parseLBS def input $= mapElem $=+ convertConduit (element "data" dataConv) $$ CL.consume- d `shouldBe` input'+ result `shouldBe` expectedData where+ mapElem = elementConduit $ "dataSet" .- end "data" input = L.concat [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" , "<dataSet>"@@ -321,7 +319,7 @@ , " </data>" , "</dataSet>" ]- input' =+ expectedData = [ TestData { testDataId = 1 , testDataName = "test1"@@ -338,23 +336,23 @@ parseEmptyItemSetConduit :: Expectation parseEmptyItemSetConduit = do- d <- runResourceT $ parseLBS def input $=- xmlParserConduit "dataSet" (\xml -> getElement xml "data" parseTestData) $$+ result <- runResourceT $ parseLBS def input $= mapElem $=+ convertConduit (element "data" dataConv) $$ CL.consume- d `shouldBe` input'+ result `shouldBe` expectedData where+ mapElem = elementConduit $ "dataSet" .- end "data" input = L.concat [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" , "<dataSet>" , "</dataSet>" ]- input' = []+ expectedData = [] parseList :: Expectation parseList = do- d <- runResourceT $ parseLBS def input $$- xmlParser (\xml -> getElements xml "dataSet" "data" content)- d `shouldBe` input'+ result <- getElement input >>= elements "dataSet" "data" content+ result `shouldBe` expectedData where input = L.concat [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"@@ -364,14 +362,15 @@ , "<data>item</data>" , "</dataSet>" ]- input' = ["item", "item", "item"]+ expectedData = ["item", "item", "item"] :: [Text] parseListFailure :: Expectation-parseListFailure = do- runResourceT $ parseLBS def input $$- xmlParser (\xml -> getElements xml "dataSet" "data" content)- `shouldThrow` errorCall "This is not a content."+parseListFailure =+ (getElement input >>= elements "dataSet" "data" c)+ `shouldThrow` parseError where+ c :: XmlElement -> IO Text+ c = content input = L.concat [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" , "<dataSet>"@@ -379,35 +378,103 @@ , "</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'+parseEscaped :: Expectation+parseEscaped = do+ result <- getElement input >>= (.< "escaped")+ result `shouldBe` expectedData where- input = L.concat- [ "<itemA>item-a</itemA>"- , "<itemB>item-b</itemB>"- , "<itemSet>"- , " <item>"+ 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>"+ expectedData = "{\"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++parseEC2Response :: Expectation+parseEC2Response = do+ (rid, d, nt) <- getElement (input True False) >>= element "response" conv+ rid `shouldBe` Just "req-id"+ d `shouldBe` expectedData+ nt `shouldBe` Nothing+ (rid', d', nt') <- getElement (input False True) >>= element "response" conv+ rid' `shouldBe` Nothing+ d' `shouldBe` expectedData+ nt' `shouldBe` Just "next-token"+ where+ conv :: (MonadThrow m, Applicative m) => XmlElement -> m (Maybe Text, TestData, Maybe Text)+ conv e = (,,)+ <$> e .< "requestId"+ <*> element "data" dataConv e+ <*> e .< "nextToken"+ input hasReqId hasNextToken = L.concat+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"+ , "<response>"+ , if hasReqId then " <requestId>req-id</requestId>" else ""+ , " <data>"+ , " <id>1</id>"+ , " <name>test1</name>" , " <itemSet>"- , " <item>a</item>" , " </itemSet>"- , " </item>"- , "</itemSet>"+ , " <description>this is test</description>"+ , " </data>"+ , if hasNextToken then " <nextToken>next-token</nextToken>" else ""+ , "</response>" ]- input' = ("item-a", "item-b", [["a"]]) :: (Text, Text, [[Text]])+ expectedData = TestData+ { testDataId = 1+ , testDataName = "test1"+ , testDataDescription = Just "this is test"+ , testDataItemsSet = []+ } -parseEscaped :: Expectation-parseEscaped = do- d <- runResourceT $ parseLBS def input $$ xmlParser (.< "escaped")- d `shouldBe` input'+parseEC2ResponseConduit :: Expectation+parseEC2ResponseConduit = do+ (rid, d, nt) <- runResourceT $ parseLBS def (input True False) $= mapElem $$ sink+ rid `shouldBe` Just ("req-id" :: Text)+ d `shouldBe` expectedData+ nt `shouldBe` (Nothing :: Maybe Text)+ (rid', d', nt') <- runResourceT $ parseLBS def (input False True) $= mapElem $$ sink+ rid' `shouldBe` Nothing+ d' `shouldBe` expectedData+ nt' `shouldBe` Just "next-token" 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+ mapElem = elementConduit $ "response" .=+ [ end "requestId"+ , "dataSet" .- end "data"+ , end "nextToken"+ ]+ sink = do+ rid <- tryConvert (.< "requestId")+ d <- convertMany $ element "data" dataConv+ nt <- tryConvert (.< "nextToken")+ return (rid, d, nt)+ input hasReqId hasNextToken = L.concat+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"+ , "<response>"+ , if hasReqId then " <requestId>req-id</requestId>" else ""+ , " <dataSet>"+ , " <data>"+ , " <id>1</id>"+ , " <name>test1</name>"+ , " <itemSet>"+ , " </itemSet>"+ , " <description>this is test</description>"+ , " </data>"+ , " <data>"+ , " <id>2</id>"+ , " <name>test2</name>"+ , " </data>"+ , " </dataSet>"+ , if hasNextToken then " <nextToken>next-token</nextToken>" else ""+ , "</response>"+ ]+ expectedData =+ [ TestData+ { testDataId = 1+ , testDataName = "test1"+ , testDataDescription = Just "this is test"+ , testDataItemsSet = []+ }+ , TestData+ { testDataId = 2+ , testDataName = "test2"+ , testDataDescription = Nothing+ , testDataItemsSet = []+ }+ ]