introduce Aws.Xml for some common XML-related functions

Soostone · Jun 16, 2011 · a074da9 · a074da9
1 parent 2a7f182
commit a074da9
Show file tree

Hide file tree

Showing 7 changed files with 36 additions and 20 deletions.
diff --git a/Aws.hs b/Aws.hs
@@ -10,6 +10,7 @@ module Aws
 , module Aws.Signature
 , module Aws.Transaction
 , module Aws.Util
+, module Aws.Xml
 )
 where
 
@@ -23,3 +24,4 @@ import Aws.Response
 import Aws.Signature
 import Aws.Transaction
 import Aws.Util
+import Aws.Xml
diff --git a/Aws/S3/Commands/GetService.hs b/Aws/S3/Commands/GetService.hs
@@ -10,6 +10,7 @@ import           Aws.S3.Query
 import           Aws.S3.Response
 import           Aws.Signature
 import           Aws.Transaction
+import           Aws.Xml
 import           Control.Monad
 import           Data.Enumerator              ((=$))
 import           Data.Maybe
@@ -40,15 +41,15 @@ instance S3ResponseIteratee GetServiceResponse where
         where
           parse :: Cu.Cursor -> Either S3Error GetServiceResponse
           parse el = do
-            owner <- xmlForce "Missing Owner" <=< sequence $ el $/ Cu.laxElement "Owner" &| parseUserInfo
+            owner <- s3Force "Missing Owner" <=< sequence $ el $/ Cu.laxElement "Owner" &| parseUserInfo
             buckets <- sequence $ el $// Cu.laxElement "Bucket" &| parseBucket
             return GetServiceResponse { gsrOwner = owner, gsrBuckets = buckets }
 
           parseBucket :: Cu.Cursor -> Either S3Error BucketInfo
           parseBucket el = do
-            name <- xmlForce "Missing owner Name" $ el $/ Cu.laxElement "Name" &/ Cu.content &| T.unpack
-            creationDateString <- xmlForce "Missing owner CreationDate" $ el $/ Cu.laxElement "CreationDate" &/ Cu.content &| T.unpack
-            creationDate <- xmlForce "Invalid CreationDate" . maybeToList $ parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" creationDateString
+            name <- s3Force "Missing owner Name" $ el $/ elCont "Name"
+            creationDateString <- s3Force "Missing owner CreationDate" $ el $/ elCont "CreationDate"
+            creationDate <- s3Force "Invalid CreationDate" . maybeToList $ parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" creationDateString
             return BucketInfo { bucketName = name, bucketCreationDate = creationDate }
 
 instance SignQuery GetService where

diff --git a/Aws/S3/Error.hs b/Aws/S3/Error.hs
@@ -4,12 +4,11 @@ where
 
 import           Aws.Metadata
 import           Aws.S3.Metadata
-import           Control.Monad.Error.Class
+import           Aws.Xml
 import           Data.Typeable
-import           Text.XML.Monad
-import qualified Control.Exception         as C
-import qualified Data.ByteString           as B
-import qualified Network.HTTP.Types        as HTTP
+import qualified Control.Exception  as C
+import qualified Data.ByteString    as B
+import qualified Network.HTTP.Types as HTTP
 
 type ErrorCode = String
 
@@ -39,6 +38,5 @@ instance WithMetadata S3Error S3Metadata where
     setMetadata m a@S3Error{} = a { s3ErrorMetadata = Just m }
     setMetadata m a@S3XmlError{} = a { s3XmlErrorMetadata = Just m }
 
-xmlForce :: String -> [a] -> Either S3Error a
-xmlForce msg []    = Left (S3XmlError msg Nothing)
-xmlForce _   (x:_) = Right x
+s3Force :: String -> [a] -> Either S3Error a
+s3Force msg = force (S3XmlError msg Nothing)
diff --git a/Aws/S3/Model.hs b/Aws/S3/Model.hs
@@ -3,6 +3,7 @@ module Aws.S3.Model
 where
 
 import           Aws.S3.Error
+import           Aws.Xml
 import           Data.Maybe
 import           Data.Time
 import           Text.XML.Enumerator.Cursor (($/), (&/), (&|))
@@ -19,8 +20,8 @@ data UserInfo
     deriving (Show)
 
 parseUserInfo :: Cu.Cursor -> Either S3Error UserInfo
-parseUserInfo el = do id_ <- xmlForce "Missing user ID" $ el $/ Cu.laxElement "ID" &/ Cu.content &| T.unpack
-                      displayName <- xmlForce "Missing user DisplayName" $ el $/ Cu.laxElement "DisplayName" &/ Cu.content &| T.unpack
+parseUserInfo el = do id_ <- s3Force "Missing user ID" $ el $/ elCont "ID"
+                      displayName <- s3Force "Missing user DisplayName" $ el $/ elCont "DisplayName"
                       return UserInfo { userId = id_, userDisplayName = displayName }
 
 type Bucket = String

diff --git a/Aws/S3/Response.hs b/Aws/S3/Response.hs
@@ -7,6 +7,7 @@ import           Aws.Response
 import           Aws.S3.Error
 import           Aws.S3.Metadata
 import           Aws.Util
+import           Aws.Xml
 import           Control.Applicative
 import           Control.Monad.Compose.Class
 import           Data.Char
@@ -59,8 +60,8 @@ s3ErrorResponseIteratee status headers = do doc <- XML.parseBytes XML.decodeEnti
                                               Right err -> En.throwError err
     where
       parseError :: Cu.Cursor -> Either S3Error S3Error
-      parseError root = do code <- xmlForce "Missing error Code" $ root $/ elCont "Code"
-                           message <- xmlForce "Missing error Message" $ root $/ elCont "Message"
+      parseError root = do code <- s3Force "Missing error Code" $ root $/ elCont "Code"
+                           message <- s3Force "Missing error Message" $ root $/ elCont "Message"
                            let resource = listToMaybe $ root $/ elCont "Resource"
                                hostId = listToMaybe $ root $/ elCont "HostId"
                                accessKeyId = listToMaybe $ root $/ elCont "AWSAccessKeyId"
@@ -77,9 +78,7 @@ s3ErrorResponseIteratee status headers = do doc <- XML.parseBytes XML.decodeEnti
                                       , s3ErrorStringToSign = stringToSign
                                       , s3ErrorMetadata = Nothing
                                       }
-          where elCont el = Cu.laxElement el &/ Cu.content &| T.unpack
-
-                readHex2 :: [Char] -> Maybe Word8
+          where readHex2 :: [Char] -> Maybe Word8
                 readHex2 [c1,c2] = do n1 <- readHex1 c1
                                       n2 <- readHex1 c2
                                       return . fromIntegral $ n1 * 16 + n2

diff --git a/Aws/Xml.hs b/Aws/Xml.hs
@@ -0,0 +1,14 @@
+module Aws.Xml
+where
+
+import           Text.XML.Enumerator.Cursor
+import qualified Data.Text                    as T
+import qualified Text.XML.Enumerator.Parse    as XML
+import qualified Text.XML.Enumerator.Resolved as XML
+
+elCont :: T.Text -> Cursor -> [String]
+elCont name = laxElement name &/ content &| T.unpack
+
+force :: e -> [a] -> Either e a
+force e []    = Left e
+force _ (x:_) = Right x
diff --git a/aws.cabal b/aws.cabal
@@ -86,7 +86,8 @@ Library
                        Aws.SimpleDb.Query,
                        Aws.SimpleDb.Response,
                        Aws.Transaction,
-                       Aws.Util
+                       Aws.Util,
+                       Aws.Xml
 
   -- Packages needed in order to build this package.
   Build-depends: