diff --git a/aws-sdk-xml-unordered.cabal b/aws-sdk-xml-unordered.cabal --- a/aws-sdk-xml-unordered.cabal +++ b/aws-sdk-xml-unordered.cabal @@ -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 @@ -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 diff --git a/src/Cloud/AWS/Lib/Parser/Unordered.hs b/src/Cloud/AWS/Lib/Parser/Unordered.hs --- a/src/Cloud/AWS/Lib/Parser/Unordered.hs +++ b/src/Cloud/AWS/Lib/Parser/Unordered.hs @@ -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 diff --git a/src/Cloud/AWS/Lib/Parser/Unordered/Conduit.hs b/src/Cloud/AWS/Lib/Parser/Unordered/Conduit.hs new file mode 100644 --- /dev/null +++ b/src/Cloud/AWS/Lib/Parser/Unordered/Conduit.hs @@ -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) diff --git a/src/Cloud/AWS/Lib/Parser/Unordered/Convert.hs b/src/Cloud/AWS/Lib/Parser/Unordered/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Cloud/AWS/Lib/Parser/Unordered/Convert.hs @@ -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-content" === "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." diff --git a/src/Cloud/AWS/Lib/Parser/Unordered/Path.hs b/src/Cloud/AWS/Lib/Parser/Unordered/Path.hs new file mode 100644 --- /dev/null +++ b/src/Cloud/AWS/Lib/Parser/Unordered/Path.hs @@ -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 = "" + +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] diff --git a/src/Cloud/AWS/Lib/Parser/Unordered/Types.hs b/src/Cloud/AWS/Lib/Parser/Unordered/Types.hs new file mode 100644 --- /dev/null +++ b/src/Cloud/AWS/Lib/Parser/Unordered/Types.hs @@ -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 diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -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 [ "\n" @@ -87,7 +92,7 @@ , " " , "" ] - 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 [ "\n" @@ -141,7 +145,7 @@ , " 1" , "" ] - 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 = "\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 [ "\n" @@ -191,7 +192,7 @@ , " " , "" ] - 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 [ "\n" @@ -211,18 +211,17 @@ , " test" , "" ] - 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 [ "\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 [ "\n" @@ -254,7 +252,7 @@ , " tag" , "" ] - 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 [ "\n" @@ -283,7 +280,7 @@ , " " , "" ] - 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 [ "\n" , "" @@ -321,7 +319,7 @@ , " " , "" ] - 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 [ "\n" , "" , "" ] - 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 [ "\n" @@ -364,14 +362,15 @@ , "item" , "" ] - 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 [ "\n" , "" @@ -379,35 +378,103 @@ , "" ] -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 - [ "item-a" - , "item-b" - , "" - , " " + 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}" + 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 + [ "\n" + , "" + , if hasReqId then " req-id" else "" + , " " + , " 1" + , " test1" , " " - , " a" , " " - , " " - , "" + , " this is test" + , " " + , if hasNextToken then " next-token" else "" + , "" ] - 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 = "{"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}" - 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 + [ "\n" + , "" + , if hasReqId then " req-id" else "" + , " " + , " " + , " 1" + , " test1" + , " " + , " " + , " this is test" + , " " + , " " + , " 2" + , " test2" + , " " + , " " + , if hasNextToken then " next-token" else "" + , "" + ] + expectedData = + [ TestData + { testDataId = 1 + , testDataName = "test1" + , testDataDescription = Just "this is test" + , testDataItemsSet = [] + } + , TestData + { testDataId = 2 + , testDataName = "test2" + , testDataDescription = Nothing + , testDataItemsSet = [] + } + ]