aws-sdk-xml-unordered (empty) → 0.1.0.0
raw patch · 5 files changed
+597/−0 lines, 5 filesdep +aws-sdk-text-converterdep +aws-sdk-xml-unordereddep +basesetup-changed
Dependencies added: aws-sdk-text-converter, aws-sdk-xml-unordered, base, bytestring, conduit, hspec, mtl, text, unordered-containers, xml-conduit, xml-types
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- aws-sdk-xml-unordered.cabal +52/−0
- src/Cloud/AWS/Lib/Parser/Unordered.hs +166/−0
- test/test.hs +347/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, amutake++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of amutake nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aws-sdk-xml-unordered.cabal view
@@ -0,0 +1,52 @@+-- Initial xml-conduit-unordered.cabal generated by cabal init. For+-- further documentation, see http://haskell.org/cabal/users-guide/++name: aws-sdk-xml-unordered+version: 0.1.0.0+synopsis: XML parser for aws-sdk+description: This package provides a unordered xml parser for aws-sdk.+license: BSD3+license-file: LICENSE+author: Shohei Yasutake+maintainer: amutake.s@gmail.com+-- copyright:+category: XML+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ exposed-modules: Cloud.AWS.Lib.Parser.Unordered+ -- other-modules:+ -- other-extensions:+ build-depends: base >=4.6 && <4.7+ , unordered-containers+ , conduit+ , xml-conduit+ , xml-types+ , text+ , mtl+ , aws-sdk-text-converter+ hs-source-dirs: src+ ghc-options: -Wall -fno-warn-unused-do-bind+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: test.hs+ hs-source-dirs: test+ build-depends: base+ , bytestring+ , text+ , mtl+ , conduit+ , xml-conduit+ , xml-types+ , aws-sdk-text-converter+ , aws-sdk-xml-unordered+ , hspec+ ghc-options: -Wall -threaded -fno-warn-unused-do-bind++source-repository head+ type: git+ location: git://github.com/worksap-ate/aws-sdk-xml-unordered.git
+ src/Cloud/AWS/Lib/Parser/Unordered.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}++module Cloud.AWS.Lib.Parser.Unordered+ ( SimpleXML (..)+ , ParseError (..)+ , xmlParser+ , xmlParserM+ , xmlParserConduit+ , getT, (.<)+ , getElementM+ , getElement+ , getElements+ ) where++import Control.Applicative+import Control.Exception (Exception)+import Control.Monad+import Control.Monad.Trans+import Data.Char+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Maybe+import Data.Monoid+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Data.XML.Types+import Text.XML.Stream.Parse++import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HM++import Cloud.AWS.Lib.FromText++data SimpleXML = Map (HashMap Text [SimpleXML])+ | Content Text+ deriving (Show)++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 <- getXML+ 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 parse' = do+ ma <- xmlParserM parse'+ case ma of+ Just a -> yield a >> innerParser parse'+ Nothing -> return ()++getXML :: MonadThrow m+ => ConduitM Event o m (Maybe SimpleXML)+getXML = 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]+ 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'+ Just (EventContent (ContentText t)) -> CL.drop 1 >> return (Just $ Content t)+ _ -> return Nothing+ where+ getXMLList = do+ e <- dropWS+ case e of+ Just EventEndElement{} -> return []+ _ -> do+ xml <- getXML+ case xml of+ Just xml' -> (xml' :) <$> getXMLList+ Nothing -> return []+ toHMap (Map hmap) = hmap+ toHMap _ = error "toHMap: invalid structure"++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 []
+ test/test.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Applicative+import qualified Data.ByteString.Lazy as L+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Text (Text)+import Test.Hspec+import Text.XML.Stream.Parse++import Cloud.AWS.Lib.Parser.Unordered++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+ it "ignore unexpected tag" ignoreUnexpectedTag+ it "parse top data set" parseTopDataSet+ 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++data TestData = TestData+ { testDataId :: Int+ , testDataName :: Text+ , testDataDescription :: Maybe Text+ , testDataItemsSet :: [TestItem]+ } deriving (Eq, Show)++data TestItem = TestItem+ { testItemId :: Int+ , testItemName :: Text+ , testItemDescription :: Maybe Text+ , 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++parseTestItem :: (MonadThrow m, Applicative m) => SimpleXML -> m TestItem+parseTestItem xml = TestItem+ <$> xml .< "id"+ <*> xml .< "name"+ <*> xml .< "description"+ <*> getElementM xml "subItem" parseTestItem++parseNormal :: Expectation+parseNormal = do+ d <- runResourceT $ parseLBS def input $$+ xmlParser (\xml -> getElement xml "data" parseTestData)+ d `shouldBe` input'+ where+ input = L.concat+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"+ , "<data>"+ , " <id>1</id>"+ , " <name>test</name>"+ , " <description>this is test</description>"+ , " <itemSet>"+ , " <item>"+ , " <id>1</id>"+ , " <name>item1</name>"+ , " <description>this is item1</description>"+ , " <subItem>"+ , " <id>11</id>"+ , " <name>item1sub</name>"+ , " </subItem>"+ , " </item>"+ , " <item>"+ , " <id>2</id>"+ , " <name>item2</name>"+ , " </item>"+ , " </itemSet>"+ , "</data>"+ ]+ input' = TestData+ { testDataId = 1+ , testDataName = "test"+ , testDataDescription = Just "this is test"+ , testDataItemsSet =+ [ TestItem+ { testItemId = 1+ , testItemName = "item1"+ , testItemDescription = Just "this is item1"+ , testItemSubItem = Just TestItem+ { testItemId = 11+ , testItemName = "item1sub"+ , testItemDescription = Nothing+ , testItemSubItem = Nothing+ }+ }+ , TestItem+ { testItemId = 2+ , testItemName = "item2"+ , testItemDescription = Nothing+ , testItemSubItem = Nothing+ }+ ]+ }++parseUnordered :: Expectation+parseUnordered = do+ d <- runResourceT $ parseLBS def input $$+ xmlParser (\xml -> getElement xml "data" parseTestData)+ d `shouldBe` input'+ where+ input = L.concat+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"+ , "<data>"+ , " <name>test</name>"+ , " <itemSet>"+ , " <item>"+ , " <name>item1</name>"+ , " <id>1</id>"+ , " <subItem>"+ , " <name>item1sub</name>"+ , " <id>11</id>"+ , " </subItem>"+ , " <description>this is item1</description>"+ , " </item>"+ , " <item>"+ , " <name>item2</name>"+ , " <id>2</id>"+ , " </item>"+ , " </itemSet>"+ , " <description>this is test</description>"+ , " <id>1</id>"+ , "</data>"+ ]+ input' = TestData+ { testDataId = 1+ , testDataName = "test"+ , testDataDescription = Just "this is test"+ , testDataItemsSet =+ [ TestItem+ { testItemId = 1+ , testItemName = "item1"+ , testItemDescription = Just "this is item1"+ , testItemSubItem = Just TestItem+ { testItemId = 11+ , testItemName = "item1sub"+ , testItemDescription = Nothing+ , testItemSubItem = Nothing+ }+ }+ , TestItem+ { testItemId = 2+ , testItemName = "item2"+ , testItemDescription = Nothing+ , testItemSubItem = Nothing+ }+ ]+ }++parseEmpty :: Expectation+parseEmpty = do+ d <- runResourceT $ parseLBS def input $$+ xmlParserM (\xml -> getElement xml "data" parseTestData)+ d `shouldBe` input'+ 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'+ where+ input = L.concat+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"+ , "<data>"+ , " <id>1</id>"+ , " <name>test</name>"+ , " <description>this is test</description>"+ , " <itemSet>"+ , " </itemSet>"+ , "</data>"+ ]+ input' = TestData+ { testDataId = 1+ , testDataName = "test"+ , testDataDescription = Just "this is test"+ , testDataItemsSet = []+ }++parseNotAppearItemSet :: Expectation+parseNotAppearItemSet = do+ d <- runResourceT $ parseLBS def input $$+ xmlParser (\xml -> getElement xml "data" parseTestData)+ d `shouldBe` input'+ where+ input = L.concat+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"+ , "<data>"+ , " <id>1</id>"+ , " <name>test</name>"+ , "</data>"+ ]+ input' = 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"+ where+ input = L.concat+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"+ , "<data>"+ , " <id>1</id>"+ , " <name>"+ , " <first>foo</first>"+ , " <last>bar</last>"+ , " </name>"+ , "</data>"+ ]++ignoreUnexpectedTag :: Expectation+ignoreUnexpectedTag = do+ d <- runResourceT $ parseLBS def input $$+ xmlParser (\xml -> getElement xml "data" parseTestData)+ d `shouldBe` input'+ where+ input = L.concat+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"+ , "<data>"+ , " <id>1</id>"+ , " <unexpectedTag>tag</unexpectedTag>"+ , " <name>test</name>"+ , " <itemSet>"+ , " <unexpectedTag>tag</unexpectedTag>"+ , " <unexpectedTag>tag</unexpectedTag>"+ , " </itemSet>"+ , " <unexpectedTag>tag</unexpectedTag>"+ , "</data>"+ ]+ input' = TestData+ { testDataId = 1+ , testDataName = "test"+ , testDataDescription = Nothing+ , testDataItemsSet = []+ }++parseTopDataSet :: Expectation+parseTopDataSet = do+ d <- runResourceT $ parseLBS def input $$+ xmlParser (\xml -> getElements xml "dataSet" "data" parseTestData)+ d `shouldBe` input'+ where+ input = L.concat+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"+ , "<dataSet>"+ , " <data>"+ , " <id>1</id>"+ , " <name>test1</name>"+ , " <itemSet>"+ , " </itemSet>"+ , " <description>this is test 1</description>"+ , " </data>"+ , " <data>"+ , " <id>2</id>"+ , " <name>test2</name>"+ , " </data>"+ , "</dataSet>"+ ]+ input' =+ [ TestData+ { testDataId = 1+ , testDataName = "test1"+ , testDataDescription = Just "this is test 1"+ , testDataItemsSet = []+ }+ , TestData+ { testDataId = 2+ , testDataName = "test2"+ , testDataDescription = Nothing+ , testDataItemsSet = []+ }+ ]++parseTopDataSetConduit :: Expectation+parseTopDataSetConduit = do+ d <- runResourceT $ parseLBS def input $=+ xmlParserConduit "dataSet" (\xml -> getElement xml "data" parseTestData) $$+ CL.consume+ d `shouldBe` input'+ where+ input = L.concat+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"+ , "<dataSet>"+ , " <data>"+ , " <id>1</id>"+ , " <name>test1</name>"+ , " <itemSet>"+ , " </itemSet>"+ , " <description>this is test 1</description>"+ , " </data>"+ , " <data>"+ , " <id>2</id>"+ , " <name>test2</name>"+ , " </data>"+ , "</dataSet>"+ ]+ input' =+ [ TestData+ { testDataId = 1+ , testDataName = "test1"+ , testDataDescription = Just "this is test 1"+ , testDataItemsSet = []+ }+ , TestData+ { testDataId = 2+ , testDataName = "test2"+ , testDataDescription = Nothing+ , testDataItemsSet = []+ }+ ]++parseEmptyItemSetConduit :: Expectation+parseEmptyItemSetConduit = do+ d <- runResourceT $ parseLBS def input $=+ xmlParserConduit "dataSet" (\xml -> getElement xml "data" parseTestData) $$+ CL.consume+ d `shouldBe` input'+ where+ input = L.concat+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n"+ , "<dataSet>"+ , "</dataSet>"+ ]+ input' = []