aws 0.0.3 → 0.0.4
raw patch · 31 files changed
+516/−427 lines, 31 filesdep +attemptdep +failuredep +textdep −transformers-composedep −xmldep −xml-monaddep ~crypto-apidep ~cryptohashdep ~http-enumerator
Dependencies added: attempt, failure, text, xml-enumerator
Dependencies removed: transformers-compose, xml, xml-monad
Dependency ranges changed: crypto-api, cryptohash, http-enumerator
Files
- Aws.hs +2/−2
- Aws/Aws.hs +19/−9
- Aws/Metadata.hs +0/−7
- Aws/Query.hs +2/−0
- Aws/Response.hs +32/−24
- Aws/S3/Commands/GetBucket.hs +40/−7
- Aws/S3/Commands/GetService.hs +18/−18
- Aws/S3/Error.hs +4/−27
- Aws/S3/Info.hs +24/−54
- Aws/S3/Metadata.hs +12/−3
- Aws/S3/Model.hs +30/−13
- Aws/S3/Query.hs +8/−4
- Aws/S3/Response.hs +65/−77
- Aws/SimpleDb/Commands/BatchDeleteAttributes.hs +6/−5
- Aws/SimpleDb/Commands/BatchPutAttributes.hs +6/−5
- Aws/SimpleDb/Commands/CreateDomain.hs +6/−5
- Aws/SimpleDb/Commands/DeleteAttributes.hs +6/−5
- Aws/SimpleDb/Commands/DeleteDomain.hs +6/−5
- Aws/SimpleDb/Commands/DomainMetadata.hs +20/−16
- Aws/SimpleDb/Commands/GetAttributes.hs +13/−9
- Aws/SimpleDb/Commands/ListDomains.hs +14/−10
- Aws/SimpleDb/Commands/PutAttributes.hs +6/−5
- Aws/SimpleDb/Commands/Select.hs +16/−10
- Aws/SimpleDb/Error.hs +1/−24
- Aws/SimpleDb/Metadata.hs +11/−2
- Aws/SimpleDb/Model.hs +16/−15
- Aws/SimpleDb/Response.hs +44/−52
- Aws/Transaction.hs +3/−2
- Aws/Util.hs +8/−2
- Aws/Xml.hs +56/−0
- aws.cabal +22/−10
Aws.hs view
@@ -4,12 +4,12 @@ , module Aws.Credentials , module Aws.Debug , module Aws.Http-, module Aws.Metadata , module Aws.Query , module Aws.Response , module Aws.Signature , module Aws.Transaction , module Aws.Util+, module Aws.Xml ) where @@ -17,9 +17,9 @@ import Aws.Credentials import Aws.Debug import Aws.Http-import Aws.Metadata import Aws.Query import Aws.Response import Aws.Signature import Aws.Transaction import Aws.Util+import Aws.Xml
Aws/Aws.hs view
@@ -13,6 +13,10 @@ import Aws.Transaction import Control.Applicative import Control.Monad.Reader+import Data.Attempt (attemptIO)+import Data.IORef+import Data.Monoid+import qualified Control.Exception as E import qualified Data.ByteString as B import qualified Data.Enumerator as En import qualified Network.HTTP.Enumerator as HTTP@@ -87,18 +91,19 @@ instance MonadIO m => MonadAws (AwsT m) where configuration = AwsT ask -aws :: (Transaction request response- , ConfigurationFetch (Info request)+aws :: (Transaction r a+ , ConfigurationFetch (Info r) , MonadAws aws) - => request -> aws response+ => r -> aws (Response (ResponseMetadata a) a) aws = unsafeAws unsafeAws- :: (MonadAws m,- ResponseIteratee response,- SignQuery request,- ConfigurationFetch (Info request)) =>- request -> m response+ :: (MonadAws aws,+ ResponseIteratee a,+ Monoid (ResponseMetadata a),+ SignQuery r,+ ConfigurationFetch (Info r)) =>+ r -> aws (Response (ResponseMetadata a) a) unsafeAws request = do cfg <- configuration sd <- liftIO $ signatureData <$> timeInfo <*> credentials $ cfg@@ -106,7 +111,12 @@ let q = signQuery request info sd debugPrint "String to sign" $ sqStringToSign q let httpRequest = queryToHttpRequest q- liftIO $ HTTP.withManager $ En.run_ . HTTP.httpRedirect httpRequest responseIteratee+ liftIO $ do+ metadataRef <- newIORef mempty+ resp <- attemptIO (id :: E.SomeException -> E.SomeException) $+ HTTP.withManager $ En.run_ . HTTP.httpRedirect httpRequest (responseIteratee metadataRef)+ metadata <- readIORef metadataRef+ return $ Response metadata resp awsUri :: (SignQuery request , ConfigurationFetch (Info request)
− Aws/Metadata.hs
@@ -1,7 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}-module Aws.Metadata-where- -class WithMetadata a m | a -> m where- getMetadata :: a -> Maybe m- setMetadata :: m -> a -> a
Aws/Query.hs view
@@ -49,6 +49,8 @@ , HTTP.requestBody = HTTP.RequestBodyLBS $ case sqMethod of Get -> L.empty PostQuery -> Blaze.toLazyByteString $ HTTP.renderQueryBuilder False sqQuery+ , HTTP.proxy = Nothing+ , HTTP.rawBody = False } where contentType = case sqMethod of PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8"
Aws/Response.hs view
@@ -1,32 +1,40 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable, DeriveFunctor, TypeFamilies #-} module Aws.Response where -import Control.Monad.Compose.Class-import Control.Monad.Error.Class-import Control.Monad.Reader.Class-import Text.XML.Monad-import qualified Control.Exception as C-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy.UTF8 as BLU-import qualified Data.Enumerator as En-import qualified Network.HTTP.Enumerator as HTTP-import qualified Network.HTTP.Types as HTTP-import qualified Text.XML.Light as XL+import Data.IORef+import Data.Monoid+import Data.Attempt (Attempt(..))+import qualified Control.Exception as E+import qualified Control.Failure as F+import qualified Data.ByteString as B+import qualified Data.Enumerator as En+import qualified Network.HTTP.Enumerator as HTTP+import qualified Network.HTTP.Types as HTTP+ +data Response m a = Response m (Attempt a)+ deriving (Show, Functor) +tellMetadata :: m -> Response m ()+tellMetadata m = Response m (return ())++instance Monoid m => Monad (Response m) where+ return x = Response mempty (Success x)+ Response m1 (Failure e) >>= _ = Response m1 (Failure e)+ Response m1 (Success x) >>= f = let Response m2 y = f x+ in Response (m1 `mappend` m2) y -- currently using First-semantics, Last SHOULD work too++instance (Monoid m, E.Exception e) => F.Failure e (Response m) where+ failure e = Response mempty (F.failure e)++tellMetadataRef :: Monoid m => IORef m -> m -> IO ()+tellMetadataRef r m = modifyIORef r (`mappend` m)+ class ResponseIteratee a where- responseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a+ type ResponseMetadata a+ responseIteratee :: IORef (ResponseMetadata a) -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a instance ResponseIteratee HTTP.Response where- responseIteratee = HTTP.lbsIter--xmlResponseIteratee :: C.Exception e => Xml e HTTP.Response a -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a-xmlResponseIteratee xml status headers = do- body <- HTTP.lbsIter status headers- case runXml xml body of- Left e -> En.throwError e- Right a -> return a--parseXmlResponse :: (FromXmlError e, Error e) => Xml e HTTP.Response XL.Element-parseXmlResponse = parseXMLDoc <<< asks (BLU.toString . HTTP.responseBody)+ type ResponseMetadata HTTP.Response = ()+ responseIteratee _ = HTTP.lbsIter
Aws/S3/Commands/GetBucket.hs view
@@ -1,17 +1,26 @@-{-# LANGUAGE TypeFamilies, RecordWildCards, TupleSections, OverloadedStrings #-}+{-# LANGUAGE TypeFamilies, RecordWildCards, TupleSections, OverloadedStrings, MultiParamTypeClasses, FlexibleInstances #-} module Aws.S3.Commands.GetBucket where +import Aws.Response import Aws.S3.Info+import Aws.S3.Metadata import Aws.S3.Model import Aws.S3.Query+import Aws.S3.Response import Aws.Signature+import Aws.Transaction+import Aws.Xml import Control.Applicative-import Control.Arrow (second)-import Data.ByteString.Char8 ({- IsString -})+import Control.Arrow (second)+import Data.ByteString.Char8 ({- IsString -}) import Data.Maybe-import qualified Data.ByteString.UTF8 as BU-import qualified Network.HTTP.Types as HTTP+import Text.XML.Enumerator.Cursor (($/), (&|), (&//))+import qualified Data.ByteString.UTF8 as BU+import qualified Data.Text as T+import qualified Data.Traversable+import qualified Network.HTTP.Types as HTTP+import qualified Text.XML.Enumerator.Cursor as Cu data GetBucket = GetBucket {@@ -33,8 +42,8 @@ , gbPrefix = Nothing } -data GetBucketResult- = GetBucketResult {+data GetBucketResponse+ = GetBucketResponse { gbrName :: Bucket , gbrDelimiter :: Maybe String , gbrMarker :: Maybe String@@ -57,3 +66,27 @@ , ("prefix",) <$> gbPrefix ] }++instance ResponseIteratee GetBucketResponse where+ type ResponseMetadata GetBucketResponse = S3Metadata++ responseIteratee = s3XmlResponseIteratee parse+ where parse cursor+ = do name <- force "Missing Name" $ cursor $/ elCont "Name"+ let delimiter = listToMaybe $ cursor $/ elCont "Delimiter"+ let marker = listToMaybe $ cursor $/ elCont "Marker"+ maxKeys <- Data.Traversable.sequence . listToMaybe $ cursor $/ elCont "MaxKeys" &| readInt+ let prefix = listToMaybe $ cursor $/ elCont "Prefix"+ contents <- sequence $ cursor $/ Cu.laxElement "Contents" &| parseObjectInfo+ let commonPrefixes = cursor $/ Cu.laxElement "CommonPrefixes" &// Cu.content &| T.unpack+ return GetBucketResponse{+ gbrName = name+ , gbrDelimiter = delimiter+ , gbrMarker = marker+ , gbrMaxKeys = maxKeys+ , gbrPrefix = prefix+ , gbrContents = contents+ , gbrCommonPrefixes = commonPrefixes+ }++instance Transaction GetBucket GetBucketResponse
Aws/S3/Commands/GetService.hs view
@@ -1,20 +1,21 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, OverloadedStrings #-} module Aws.S3.Commands.GetService where import Aws.Response-import Aws.S3.Error import Aws.S3.Info+import Aws.S3.Metadata import Aws.S3.Model import Aws.S3.Query import Aws.S3.Response import Aws.Signature import Aws.Transaction-import Control.Monad.Compose.Class+import Aws.Xml+import Data.Maybe import Data.Time.Format import System.Locale-import Text.XML.Monad-import qualified Text.XML.Light as XL+import Text.XML.Enumerator.Cursor (($/), ($//), (&|))+import qualified Text.XML.Enumerator.Cursor as Cu data GetService = GetService @@ -25,25 +26,24 @@ } deriving (Show) -instance S3ResponseIteratee GetServiceResponse where- s3ResponseIteratee = xmlResponseIteratee $ parse <<< parseXmlResponse+instance ResponseIteratee GetServiceResponse where+ type ResponseMetadata GetServiceResponse = S3Metadata++ responseIteratee = s3XmlResponseIteratee parse where- parse :: Xml S3Error XL.Element GetServiceResponse- parse = do- owner <- parseUserInfo <<< findElementNameUI "Owner"- buckets <- inList parseBucket <<< findElementsNameUI "Bucket"- + parse el = do+ owner <- forceM "Missing Owner" $ el $/ Cu.laxElement "Owner" &| parseUserInfo+ buckets <- sequence $ el $// Cu.laxElement "Bucket" &| parseBucket return GetServiceResponse { gsrOwner = owner, gsrBuckets = buckets } - parseBucket = do- name <- strContent <<< findElementNameUI "Name"- creationDateString <- strContent <<< findElementNameUI "CreationDate"- creationDate <- maybeRaiseXml (EncodingError "Invalid date encoding") $- parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" creationDateString+ parseBucket el = do+ name <- force "Missing owner Name" $ el $/ elCont "Name"+ creationDateString <- force "Missing owner CreationDate" $ el $/ elCont "CreationDate"+ creationDate <- force "Invalid CreationDate" . maybeToList $ parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" creationDateString return BucketInfo { bucketName = name, bucketCreationDate = creationDate } instance SignQuery GetService where type Info GetService = S3Info signQuery GetService = s3SignQuery S3Query { s3QBucket = Nothing, s3QSubresources = [], s3QQuery = [] } -instance Transaction GetService (S3Response GetServiceResponse)+instance Transaction GetService GetServiceResponse
Aws/S3/Error.hs view
@@ -1,15 +1,11 @@-{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, RecordWildCards #-} module Aws.S3.Error where -import Aws.Metadata-import Aws.S3.Metadata-import Control.Monad.Error.Class 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 @@ -22,26 +18,7 @@ , s3ErrorHostId :: Maybe String -- Error/HostId , s3ErrorAccessKeyId :: Maybe String -- Error/AWSAccessKeyId , s3ErrorStringToSign :: Maybe B.ByteString -- Error/StringToSignBytes (hexadecimal encoding)- , s3ErrorMetadata :: Maybe S3Metadata }- | S3XmlError { - fromS3XmlError :: XmlError- , s3XmlErrorMetadata :: Maybe S3Metadata- } deriving (Show, Typeable) instance C.Exception S3Error--instance FromXmlError S3Error where- fromXmlError = flip S3XmlError Nothing--instance Error S3Error where- noMsg = fromXmlError noMsg- strMsg = fromXmlError . strMsg--instance WithMetadata S3Error S3Metadata where- getMetadata S3Error { s3ErrorMetadata = m } = m- getMetadata S3XmlError { s3XmlErrorMetadata = m } = m-- setMetadata m a@S3Error{} = a { s3ErrorMetadata = Just m }- setMetadata m a@S3XmlError{} = a { s3XmlErrorMetadata = Just m }
Aws/S3/Info.hs view
@@ -3,7 +3,6 @@ where import Aws.Http-import Aws.S3.Model import Data.Time import qualified Data.ByteString as B @@ -12,74 +11,45 @@ | S3AuthorizationQuery deriving (Show) -data Endpoint- = Endpoint {- endpointHost :: B.ByteString- , endpointDefaultLocationConstraint :: LocationConstraint- , endpointAllowedLocationConstraints :: [LocationConstraint]- }+data RequestStyle+ = PathStyle+ | BucketStyle+ | VHostStyle deriving (Show) data S3Info = S3Info { s3Protocol :: Protocol- , s3Endpoint :: Endpoint+ , s3Endpoint :: B.ByteString+ , s3RequestStyle :: RequestStyle , s3Port :: Int , s3UseUri :: Bool , s3DefaultExpiry :: NominalDiffTime } deriving (Show) -s3EndpointUsClassic :: Endpoint-s3EndpointUsClassic - = Endpoint { - endpointHost = "s3.amazonaws.com"- , endpointDefaultLocationConstraint = locationUsClassic- , endpointAllowedLocationConstraints = [locationUsClassic- , locationUsWest- , locationEu- , locationApSouthEast- , locationApNorthEast]- }+s3EndpointUsClassic :: B.ByteString+s3EndpointUsClassic = "s3.amazonaws.com" -s3EndpointUsWest :: Endpoint-s3EndpointUsWest- = Endpoint {- endpointHost = "s3-us-west-1.amazonaws.com"- , endpointDefaultLocationConstraint = locationUsWest- , endpointAllowedLocationConstraints = [locationUsWest]- }+s3EndpointUsWest :: B.ByteString+s3EndpointUsWest = "s3-us-west-1.amazonaws.com" -s3EndpointEu :: Endpoint-s3EndpointEu- = Endpoint {- endpointHost = "s3-eu-west-1.amazonaws.com"- , endpointDefaultLocationConstraint = locationEu- , endpointAllowedLocationConstraints = [locationEu]- }+s3EndpointEu :: B.ByteString+s3EndpointEu = "s3-eu-west-1.amazonaws.com" -s3EndpointApSouthEast :: Endpoint-s3EndpointApSouthEast- = Endpoint {- endpointHost = "s3-ap-southeast-1.amazonaws.com"- , endpointDefaultLocationConstraint = locationApSouthEast- , endpointAllowedLocationConstraints = [locationApSouthEast]- }+s3EndpointApSouthEast :: B.ByteString+s3EndpointApSouthEast = "s3-ap-southeast-1.amazonaws.com" -s3EndpointApNorthEast :: Endpoint-s3EndpointApNorthEast- = Endpoint {- endpointHost = "s3-ap-northeast-1.amazonaws.com"- , endpointDefaultLocationConstraint = locationApNorthEast- , endpointAllowedLocationConstraints = [locationApNorthEast]- }+s3EndpointApNorthEast :: B.ByteString+s3EndpointApNorthEast = "s3-ap-northeast-1.amazonaws.com" -s3 :: Protocol -> Endpoint -> Bool -> S3Info+s3 :: Protocol -> B.ByteString -> Bool -> S3Info s3 protocol endpoint uri = S3Info { - s3Protocol = protocol- , s3Endpoint = endpoint- , s3Port = defaultPort protocol- , s3UseUri = uri- , s3DefaultExpiry = 15*60- }+ s3Protocol = protocol+ , s3Endpoint = endpoint+ , s3RequestStyle = BucketStyle+ , s3Port = defaultPort protocol+ , s3UseUri = uri+ , s3DefaultExpiry = 15*60+ }
Aws/S3/Metadata.hs view
@@ -1,9 +1,18 @@+{-# LANGUAGE DeriveDataTypeable #-} module Aws.S3.Metadata where+ +import Control.Monad+import Data.Monoid+import Data.Typeable data S3Metadata = S3Metadata {- s3MAmzId2 :: String- , s3MRequestId :: String+ s3MAmzId2 :: Maybe String+ , s3MRequestId :: Maybe String }- deriving (Show)+ deriving (Show, Typeable)++instance Monoid S3Metadata where+ mempty = S3Metadata Nothing Nothing+ S3Metadata a1 r1 `mappend` S3Metadata a2 r2 = S3Metadata (a1 `mplus` a2) (r1 `mplus` r2)
Aws/S3/Model.hs view
@@ -1,11 +1,13 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Aws.S3.Model where -import Aws.S3.Error-import Control.Monad.Compose.Class+import Aws.Xml import Data.Time-import Text.XML.Monad-import qualified Text.XML.Light as XL+import System.Locale+import Text.XML.Enumerator.Cursor (($/), (&|))+import qualified Control.Failure as F+import qualified Text.XML.Enumerator.Cursor as Cu type CanonicalUserId = String @@ -16,11 +18,10 @@ } deriving (Show) -parseUserInfo :: Xml S3Error XL.Element UserInfo-parseUserInfo = do- id_ <- strContent <<< findElementNameUI "ID"- displayName <- strContent <<< findElementNameUI "DisplayName"- return UserInfo { userId = id_, userDisplayName = displayName }+parseUserInfo :: F.Failure XmlException m => Cu.Cursor -> m UserInfo+parseUserInfo el = do id_ <- force "Missing user ID" $ el $/ elCont "ID"+ displayName <- force "Missing user DisplayName" $ el $/ elCont "DisplayName"+ return UserInfo { userId = id_, userDisplayName = displayName } type Bucket = String @@ -37,14 +38,30 @@ , objectLastModified :: UTCTime , objectETag :: String , objectSize :: Integer- , objectStorageClass :: StorageClass+ , objectStorageClass :: String , objectOwner :: UserInfo } deriving (Show) -data StorageClass - = StorageClassStandard- deriving (Show)+parseObjectInfo :: F.Failure XmlException m => Cu.Cursor -> m ObjectInfo+parseObjectInfo el + = do key <- force "Missing object Key" $ el $/ elCont "Key"+ let time s = case parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" s of+ Nothing -> F.failure $ XmlException "Invalid time"+ Just v -> return v+ lastModified <- forceM "Missing object LastModified" $ el $/ elCont "LastModified" &| time+ eTag <- force "Missing object ETag" $ el $/ elCont "ETag"+ size <- forceM "Missing object Size" $ el $/ elCont "Size" &| readInt+ storageClass <- force "Missing object StorageClass" $ el $/ elCont "StorageClass"+ owner <- forceM "Missing object Owner" $ el $/ Cu.laxElement "Owner" &| parseUserInfo+ return ObjectInfo{+ objectKey = key+ , objectLastModified = lastModified+ , objectETag = eTag+ , objectSize = size+ , objectStorageClass = storageClass+ , objectOwner = owner+ } type LocationConstraint = String
Aws/S3/Query.hs view
@@ -32,9 +32,9 @@ = SignedQuery { sqMethod = method , sqProtocol = s3Protocol- , sqHost = endpointHost s3Endpoint+ , sqHost = B.intercalate "." $ catMaybes host , sqPort = s3Port- , sqPath = path+ , sqPath = mconcat $ catMaybes path , sqQuery = sortedSubresources ++ s3QQuery ++ authQuery , sqDate = Just signatureTime , sqAuthorization = authorization@@ -47,11 +47,15 @@ method = Get contentMd5 = Nothing contentType = Nothing- path = mconcat . catMaybes $ [Just "/", s3QBucket]+ (host, path) = case s3RequestStyle of + PathStyle -> ([Just s3Endpoint], [Just "/", s3QBucket, Just "/"])+ BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just "/"])+ VHostStyle -> ([Just $ fromMaybe s3Endpoint s3QBucket], [Just "/"]) sortedSubresources = sort s3QSubresources canonicalizedResource = Blaze.copyByteString "/" `mappend` maybe mempty Blaze.copyByteString s3QBucket `mappend`- HTTP.renderQueryBuilder True sortedSubresources+ HTTP.renderQueryBuilder True sortedSubresources `mappend`+ Blaze.copyByteString "/" ti = case (s3UseUri, signatureTimeInfo) of (False, ti') -> ti' (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time
Aws/S3/Response.hs view
@@ -1,94 +1,82 @@-{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, RecordWildCards, TypeFamilies #-} module Aws.S3.Response where -import Aws.Metadata import Aws.Response import Aws.S3.Error import Aws.S3.Metadata-import Aws.Util-import Control.Applicative-import Control.Monad.Compose.Class+import Aws.Xml+import Control.Monad.IO.Class+import Data.Attempt (Attempt(..)) import Data.Char+import Data.Enumerator ((=$))+import Data.IORef import Data.Maybe import Data.Word-import Text.XML.Monad-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.Enumerator as En-import qualified Network.HTTP.Enumerator as HTTPE-import qualified Network.HTTP.Types as HTTP-import qualified Text.XML.Light as XL--data S3Response a- = S3Response {- fromS3Response :: a- , s3AmzId2 :: String- , s3RequestId :: String- }- deriving (Show)+import Text.XML.Enumerator.Cursor (($/))+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.Enumerator as En+import qualified Network.HTTP.Types as HTTP+import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Text.XML.Enumerator.Parse as XML+import qualified Text.XML.Enumerator.Resolved as XML -instance (S3ResponseIteratee a) => ResponseIteratee (S3Response a) where- responseIteratee status headers = do- let headerString = fromMaybe "" . fmap B8.unpack . flip lookup headers+s3ResponseIteratee ::+ (HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a)+ -> IORef S3Metadata+ -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a+s3ResponseIteratee inner metadata status headers = do+ let headerString = fmap B8.unpack . flip lookup headers let amzId2 = headerString "x-amz-id-2" let requestId = headerString "x-amz-request-id" - specific <- tryError $ if status >= HTTP.status400- then s3ErrorResponseIteratee status headers- else s3ResponseIteratee status headers+ let m = S3Metadata { s3MAmzId2 = amzId2, s3MRequestId = requestId }+ liftIO $ tellMetadataRef metadata m - case specific of- Left (err :: S3Error) -> En.throwError (setMetadata m err)- where m = S3Metadata { s3MAmzId2 = amzId2, s3MRequestId = requestId }- Right resp -> return S3Response {- fromS3Response = resp- , s3AmzId2 = amzId2- , s3RequestId = requestId- }+ if status >= HTTP.status400+ then s3ErrorResponseIteratee status headers+ else inner status headers -s3ErrorResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a-s3ErrorResponseIteratee status headers = xmlResponseIteratee (e <<< parseXmlResponse) status headers- where - e :: Xml S3Error XL.Element a- e = do- err <- e' <<< findElementNameUI "Error"- raise err- - e' = do- code <- strContent <<< findElementNameUI "Code"- message <- strContent <<< findElementNameUI "Message"- resource <- tryMaybe $ strContent <<< findElementNameUI "Resource"- hostId <- tryMaybe $ strContent <<< findElementNameUI "HostId"- accessKeyId <- tryMaybe $ strContent <<< findElementNameUI "AWSAccessKeyId"- stringToSignUnprocessed <- tryMaybe $ strContent <<< findElementNameUI "StringToSignBytes"- let stringToSign = B.pack <$> (sequence . map readHex2 . words =<< stringToSignUnprocessed)- - return S3Error { - s3StatusCode = status- , s3ErrorCode = code- , s3ErrorMessage = message- , s3ErrorResource = resource- , s3ErrorHostId = hostId- , s3ErrorAccessKeyId = accessKeyId- , s3ErrorStringToSign = stringToSign- , s3ErrorMetadata = Nothing- }+s3XmlResponseIteratee :: + (Cu.Cursor -> Response S3Metadata a)+ -> IORef S3Metadata+ -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a+s3XmlResponseIteratee parse metadataRef = s3ResponseIteratee (xmlCursorIteratee parse metadataRef) metadataRef - readHex2 :: [Char] -> Maybe Word8- readHex2 [c1,c2] = do- n1 <- readHex1 c1- n2 <- readHex1 c2- return . fromIntegral $ n1 * 16 + n2- readHex2 _ = Nothing+s3ErrorResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a+s3ErrorResponseIteratee status _headers + = do doc <- XML.parseBytes XML.decodeEntities =$ XML.fromEvents+ let cursor = Cu.fromDocument doc+ case parseError cursor of+ Success err -> En.throwError err+ Failure otherErr -> En.throwError otherErr+ where+ parseError :: Cu.Cursor -> Attempt S3Error+ parseError root = do code <- force "Missing error Code" $ root $/ elCont "Code"+ message <- force "Missing error Message" $ root $/ elCont "Message"+ let resource = listToMaybe $ root $/ elCont "Resource"+ hostId = listToMaybe $ root $/ elCont "HostId"+ accessKeyId = listToMaybe $ root $/ elCont "AWSAccessKeyId"+ stringToSign = do unprocessed <- listToMaybe $ root $/ elCont "StringToSignBytes"+ bytes <- mapM readHex2 $ words unprocessed+ return $ B.pack bytes+ return S3Error {+ s3StatusCode = status+ , s3ErrorCode = code+ , s3ErrorMessage = message+ , s3ErrorResource = resource+ , s3ErrorHostId = hostId+ , s3ErrorAccessKeyId = accessKeyId+ , s3ErrorStringToSign = stringToSign+ }+ where readHex2 :: [Char] -> Maybe Word8+ readHex2 [c1,c2] = do n1 <- readHex1 c1+ n2 <- readHex1 c2+ return . fromIntegral $ n1 * 16 + n2+ readHex2 _ = Nothing - readHex1 c | c >= '0' && c <= '9' = Just $ ord c - ord '0'- | c >= 'A' && c <= 'F' = Just $ ord c - ord 'A' + 10- | c >= 'a' && c <= 'f' = Just $ ord c - ord 'a' + 10- readHex1 _ = Nothing--class S3ResponseIteratee a where- s3ResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a--instance S3ResponseIteratee HTTPE.Response where- s3ResponseIteratee = HTTPE.lbsIter+ readHex1 c | c >= '0' && c <= '9' = Just $ ord c - ord '0'+ | c >= 'A' && c <= 'F' = Just $ ord c - ord 'A' + 10+ | c >= 'a' && c <= 'f' = Just $ ord c - ord 'a' + 10+ readHex1 _ = Nothing
Aws/SimpleDb/Commands/BatchDeleteAttributes.hs view
@@ -2,15 +2,15 @@ module Aws.SimpleDb.Commands.BatchDeleteAttributes where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info+import Aws.SimpleDb.Metadata import Aws.SimpleDb.Model import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util-import Control.Applicative-import Text.XML.Monad import qualified Data.ByteString.UTF8 as BU data BatchDeleteAttributes@@ -35,7 +35,8 @@ , ("DomainName", BU.fromString bdaDomainName)] ++ queryList (itemQuery $ queryList (attributeQuery deleteAttributeQuery) "Attribute") "Item" bdaItems -instance SdbFromResponse BatchDeleteAttributesResponse where- sdbFromResponse = BatchDeleteAttributesResponse <$ testElementNameUI "BatchDeleteAttributesResponse"+instance ResponseIteratee BatchDeleteAttributesResponse where+ type ResponseMetadata BatchDeleteAttributesResponse = SdbMetadata+ responseIteratee = sdbResponseIteratee $ sdbCheckResponseType BatchDeleteAttributesResponse "BatchDeleteAttributesResponse" -instance Transaction BatchDeleteAttributes (SdbResponse BatchDeleteAttributesResponse)+instance Transaction BatchDeleteAttributes BatchDeleteAttributesResponse
Aws/SimpleDb/Commands/BatchPutAttributes.hs view
@@ -2,15 +2,15 @@ module Aws.SimpleDb.Commands.BatchPutAttributes where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info+import Aws.SimpleDb.Metadata import Aws.SimpleDb.Model import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util-import Control.Applicative-import Text.XML.Monad import qualified Data.ByteString.UTF8 as BU data BatchPutAttributes@@ -35,7 +35,8 @@ , ("DomainName", BU.fromString bpaDomainName)] ++ queryList (itemQuery $ queryList (attributeQuery setAttributeQuery) "Attribute") "Item" bpaItems -instance SdbFromResponse BatchPutAttributesResponse where- sdbFromResponse = BatchPutAttributesResponse <$ testElementNameUI "BatchPutAttributesResponse"+instance ResponseIteratee BatchPutAttributesResponse where+ type ResponseMetadata BatchPutAttributesResponse = SdbMetadata+ responseIteratee = sdbResponseIteratee $ sdbCheckResponseType BatchPutAttributesResponse "BatchPutAttributesResponse" -instance Transaction BatchPutAttributes (SdbResponse BatchPutAttributesResponse)+instance Transaction BatchPutAttributes BatchPutAttributesResponse
Aws/SimpleDb/Commands/CreateDomain.hs view
@@ -2,13 +2,13 @@ module Aws.SimpleDb.Commands.CreateDomain where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info+import Aws.SimpleDb.Metadata import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction-import Control.Applicative-import Text.XML.Monad import qualified Data.ByteString.UTF8 as BU data CreateDomain@@ -28,7 +28,8 @@ type Info CreateDomain = SdbInfo signQuery CreateDomain{..} = sdbSignQuery [("Action", "CreateDomain"), ("DomainName", BU.fromString cdDomainName)] -instance SdbFromResponse CreateDomainResponse where- sdbFromResponse = CreateDomainResponse <$ testElementNameUI "CreateDomainResponse"+instance ResponseIteratee CreateDomainResponse where+ type ResponseMetadata CreateDomainResponse = SdbMetadata+ responseIteratee = sdbResponseIteratee $ sdbCheckResponseType CreateDomainResponse "CreateDomainResponse" -instance Transaction CreateDomain (SdbResponse CreateDomainResponse)+instance Transaction CreateDomain CreateDomainResponse
Aws/SimpleDb/Commands/DeleteAttributes.hs view
@@ -2,15 +2,15 @@ module Aws.SimpleDb.Commands.DeleteAttributes where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info+import Aws.SimpleDb.Metadata import Aws.SimpleDb.Model import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util-import Control.Applicative-import Text.XML.Monad import qualified Data.ByteString.UTF8 as BU data DeleteAttributes@@ -42,7 +42,8 @@ queryList (attributeQuery deleteAttributeQuery) "Attribute" daAttributes ++ queryList (attributeQuery expectedAttributeQuery) "Expected" daExpected -instance SdbFromResponse DeleteAttributesResponse where- sdbFromResponse = DeleteAttributesResponse <$ testElementNameUI "DeleteAttributesResponse"+instance ResponseIteratee DeleteAttributesResponse where+ type ResponseMetadata DeleteAttributesResponse = SdbMetadata+ responseIteratee = sdbResponseIteratee $ sdbCheckResponseType DeleteAttributesResponse "DeleteAttributesResponse" -instance Transaction DeleteAttributes (SdbResponse DeleteAttributesResponse)+instance Transaction DeleteAttributes DeleteAttributesResponse
Aws/SimpleDb/Commands/DeleteDomain.hs view
@@ -2,13 +2,13 @@ module Aws.SimpleDb.Commands.DeleteDomain where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info+import Aws.SimpleDb.Metadata import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction-import Control.Applicative-import Text.XML.Monad import qualified Data.ByteString.UTF8 as BU data DeleteDomain@@ -28,7 +28,8 @@ type Info DeleteDomain = SdbInfo signQuery DeleteDomain{..} = sdbSignQuery [("Action", "DeleteDomain"), ("DomainName", BU.fromString ddDomainName)] -instance SdbFromResponse DeleteDomainResponse where- sdbFromResponse = DeleteDomainResponse <$ testElementNameUI "DeleteDomainResponse"+instance ResponseIteratee DeleteDomainResponse where+ type ResponseMetadata DeleteDomainResponse = SdbMetadata+ responseIteratee = sdbResponseIteratee $ sdbCheckResponseType DeleteDomainResponse "DeleteDomainResponse" -instance Transaction DeleteDomain (SdbResponse DeleteDomainResponse)+instance Transaction DeleteDomain DeleteDomainResponse
Aws/SimpleDb/Commands/DomainMetadata.hs view
@@ -2,17 +2,18 @@ module Aws.SimpleDb.Commands.DomainMetadata where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info+import Aws.SimpleDb.Metadata import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction-import Control.Applicative-import Control.Monad.Compose.Class+import Aws.Xml import Data.Time import Data.Time.Clock.POSIX-import Text.XML.Monad-import qualified Data.ByteString.UTF8 as BU+import Text.XML.Enumerator.Cursor (($//), (&|))+import qualified Data.ByteString.UTF8 as BU data DomainMetadata = DomainMetadata {@@ -39,16 +40,19 @@ type Info DomainMetadata = SdbInfo signQuery DomainMetadata{..} = sdbSignQuery [("Action", "DomainMetadata"), ("DomainName", BU.fromString dmDomainName)] -instance SdbFromResponse DomainMetadataResponse where- sdbFromResponse = do- testElementNameUI "DomainMetadataResponse"- dmrTimestamp <- posixSecondsToUTCTime . fromInteger <$> readContent <<< findElementNameUI "Timestamp"- dmrItemCount <- readContent <<< findElementNameUI "ItemCount"- dmrAttributeValueCount <- readContent <<< findElementNameUI "AttributeValueCount"- dmrAttributeNameCount <- readContent <<< findElementNameUI "AttributeNameCount"- dmrItemNamesSizeBytes <- readContent <<< findElementNameUI "ItemNamesSizeBytes"- dmrAttributeValuesSizeBytes <- readContent <<< findElementNameUI "AttributeValuesSizeBytes"- dmrAttributeNamesSizeBytes <- readContent <<< findElementNameUI "AttributeNamesSizeBytes"- return DomainMetadataResponse{..}+instance ResponseIteratee DomainMetadataResponse where+ type ResponseMetadata DomainMetadataResponse = SdbMetadata -instance Transaction DomainMetadata (SdbResponse DomainMetadataResponse)+ responseIteratee = sdbResponseIteratee parse+ where parse cursor = do+ sdbCheckResponseType () "DomainMetadataResponse" cursor+ dmrTimestamp <- forceM "Timestamp expected" $ cursor $// elCont "Timestamp" &| (fmap posixSecondsToUTCTime . readInt)+ dmrItemCount <- forceM "ItemCount expected" $ cursor $// elCont "ItemCount" &| readInt+ dmrAttributeValueCount <- forceM "AttributeValueCount expected" $ cursor $// elCont "AttributeValueCount" &| readInt+ dmrAttributeNameCount <- forceM "AttributeNameCount expected" $ cursor $// elCont "AttributeNameCount" &| readInt+ dmrItemNamesSizeBytes <- forceM "ItemNamesSizeBytes expected" $ cursor $// elCont "ItemNamesSizeBytes" &| readInt+ dmrAttributeValuesSizeBytes <- forceM "AttributeValuesSizeBytes expected" $ cursor $// elCont "AttributeValuesSizeBytes" &| readInt+ dmrAttributeNamesSizeBytes <- forceM "AttributeNamesSizeBytes expected" $ cursor $// elCont "AttributeNamesSizeBytes" &| readInt+ return DomainMetadataResponse{..}++instance Transaction DomainMetadata DomainMetadataResponse
Aws/SimpleDb/Commands/GetAttributes.hs view
@@ -2,8 +2,10 @@ module Aws.SimpleDb.Commands.GetAttributes where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info+import Aws.SimpleDb.Metadata import Aws.SimpleDb.Model import Aws.SimpleDb.Query import Aws.SimpleDb.Response@@ -11,10 +13,10 @@ import Aws.Util import Control.Applicative import Control.Monad-import Control.Monad.Compose.Class import Data.Maybe-import Text.XML.Monad-import qualified Data.ByteString.UTF8 as BU+import Text.XML.Enumerator.Cursor (($//), (&|))+import qualified Data.ByteString.UTF8 as BU+import qualified Text.XML.Enumerator.Cursor as Cu data GetAttributes = GetAttributes {@@ -42,10 +44,12 @@ maybeToList (("AttributeName",) <$> BU.fromString <$> gaAttributeName) ++ (guard gaConsistentRead >> [("ConsistentRead", awsTrue)]) -instance SdbFromResponse GetAttributesResponse where- sdbFromResponse = do- testElementNameUI "GetAttributesResponse"- attributes <- inList readAttribute <<< findElementsNameUI "Attribute"- return $ GetAttributesResponse attributes+instance ResponseIteratee GetAttributesResponse where+ type ResponseMetadata GetAttributesResponse = SdbMetadata+ responseIteratee = sdbResponseIteratee parse+ where parse cursor = do+ sdbCheckResponseType () "GetAttributesResponse" cursor+ attributes <- sequence $ cursor $// Cu.laxElement "Attribute" &| readAttribute+ return $ GetAttributesResponse attributes -instance Transaction GetAttributes (SdbResponse GetAttributesResponse)+instance Transaction GetAttributes GetAttributesResponse
Aws/SimpleDb/Commands/ListDomains.hs view
@@ -2,16 +2,18 @@ module Aws.SimpleDb.Commands.ListDomains where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info+import Aws.SimpleDb.Metadata import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction+import Aws.Xml import Control.Applicative-import Control.Monad.Compose.Class import Data.Maybe-import Text.XML.Monad-import qualified Data.ByteString.UTF8 as BU+import Text.XML.Enumerator.Cursor (($//))+import qualified Data.ByteString.UTF8 as BU data ListDomains = ListDomains {@@ -38,11 +40,13 @@ , ("NextToken",) <$> BU.fromString <$> ldNextToken ] -instance SdbFromResponse ListDomainsResponse where- sdbFromResponse = do- testElementNameUI "ListDomainsResponse"- names <- inList strContent <<< findElementsNameUI "DomainName"- nextToken <- tryMaybe $ strContent <<< findElementNameUI "NextToken"- return $ ListDomainsResponse names nextToken+instance ResponseIteratee ListDomainsResponse where+ type ResponseMetadata ListDomainsResponse = SdbMetadata+ responseIteratee = sdbResponseIteratee parse + where parse cursor = do+ sdbCheckResponseType () "ListDomainsResponse" cursor+ let names = cursor $// elCont "DomainName"+ let nextToken = listToMaybe $ cursor $// elCont "NextToken"+ return $ ListDomainsResponse names nextToken -instance Transaction ListDomains (SdbResponse ListDomainsResponse)+instance Transaction ListDomains ListDomainsResponse
Aws/SimpleDb/Commands/PutAttributes.hs view
@@ -2,15 +2,15 @@ module Aws.SimpleDb.Commands.PutAttributes where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info+import Aws.SimpleDb.Metadata import Aws.SimpleDb.Model import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util-import Control.Applicative-import Text.XML.Monad import qualified Data.ByteString.UTF8 as BU data PutAttributes@@ -42,7 +42,8 @@ queryList (attributeQuery setAttributeQuery) "Attribute" paAttributes ++ queryList (attributeQuery expectedAttributeQuery) "Expected" paExpected -instance SdbFromResponse PutAttributesResponse where- sdbFromResponse = PutAttributesResponse <$ testElementNameUI "PutAttributesResponse"+instance ResponseIteratee PutAttributesResponse where+ type ResponseMetadata PutAttributesResponse = SdbMetadata+ responseIteratee = sdbResponseIteratee $ sdbCheckResponseType PutAttributesResponse "PutAttributesResponse" -instance Transaction PutAttributes (SdbResponse PutAttributesResponse)+instance Transaction PutAttributes PutAttributesResponse
Aws/SimpleDb/Commands/Select.hs view
@@ -2,17 +2,21 @@ module Aws.SimpleDb.Commands.Select where +import Aws.Response import Aws.Signature import Aws.SimpleDb.Info+import Aws.SimpleDb.Metadata import Aws.SimpleDb.Model import Aws.SimpleDb.Query import Aws.SimpleDb.Response import Aws.Transaction import Aws.Util+import Aws.Xml import Control.Monad-import Control.Monad.Compose.Class-import Text.XML.Monad-import qualified Data.ByteString.UTF8 as BU+import Data.Maybe+import Text.XML.Enumerator.Cursor (($//), (&|))+import qualified Data.ByteString.UTF8 as BU+import qualified Text.XML.Enumerator.Cursor as Cu data Select = Select {@@ -40,11 +44,13 @@ (guard sConsistentRead >> [("ConsistentRead", awsTrue)]) ++ (guard (not $ null sNextToken) >> [("NextToken", BU.fromString sNextToken)]) -instance SdbFromResponse SelectResponse where- sdbFromResponse = do- testElementNameUI "SelectResponse"- items <- inList readItem <<< findElementsNameUI "Item"- nextToken <- tryMaybe $ strContent <<< findElementNameUI "NextToken"- return $ SelectResponse items nextToken+instance ResponseIteratee SelectResponse where+ type ResponseMetadata SelectResponse = SdbMetadata+ responseIteratee = sdbResponseIteratee parse+ where parse cursor = do+ sdbCheckResponseType () "SelectResponse" cursor+ items <- sequence $ cursor $// Cu.laxElement "Item" &| readItem+ let nextToken = listToMaybe $ cursor $// elCont "NextToken"+ return $ SelectResponse items nextToken -instance Transaction Select (SdbResponse SelectResponse)+instance Transaction Select SelectResponse
Aws/SimpleDb/Error.hs view
@@ -1,12 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, RecordWildCards #-} module Aws.SimpleDb.Error where -import Aws.Metadata-import Aws.SimpleDb.Metadata-import Control.Monad.Error.Class import Data.Typeable-import Text.XML.Monad import qualified Control.Exception as C import qualified Network.HTTP.Types as HTTP @@ -17,26 +13,7 @@ sdbStatusCode :: HTTP.Status , sdbErrorCode :: ErrorCode , sdbErrorMessage :: String- , sdbErrorMetadata :: Maybe SdbMetadata }- | SdbXmlError { - fromSdbXmlError :: XmlError- , sdbXmlErrorMetadata :: Maybe SdbMetadata- } deriving (Show, Typeable)--instance FromXmlError SdbError where- fromXmlError = flip SdbXmlError Nothing--instance WithMetadata SdbError SdbMetadata where- getMetadata SdbError { sdbErrorMetadata = err } = err- getMetadata SdbXmlError { sdbXmlErrorMetadata = err } = err-- setMetadata m e@SdbError{} = e { sdbErrorMetadata = Just m }- setMetadata m e@SdbXmlError{} = e { sdbXmlErrorMetadata = Just m }--instance Error SdbError where- noMsg = fromXmlError noMsg- strMsg = fromXmlError . strMsg instance C.Exception SdbError
Aws/SimpleDb/Metadata.hs view
@@ -1,9 +1,18 @@+{-# LANGUAGE DeriveDataTypeable #-} module Aws.SimpleDb.Metadata where+ +import Control.Monad+import Data.Monoid+import Data.Typeable data SdbMetadata = SdbMetadata {- requestId :: String+ requestId :: Maybe String , boxUsage :: Maybe String }- deriving (Show)+ deriving (Show, Typeable)++instance Monoid SdbMetadata where+ mempty = SdbMetadata Nothing Nothing+ SdbMetadata r1 b1 `mappend` SdbMetadata r2 b2 = SdbMetadata (r1 `mplus` r2) (b1 `mplus` b2)
Aws/SimpleDb/Model.hs view
@@ -1,24 +1,25 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Aws.SimpleDb.Model where -import Aws.SimpleDb.Error import Aws.SimpleDb.Response import Aws.Util-import Control.Monad.Compose.Class-import Text.XML.Monad-import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as BU-import qualified Text.XML.Light as XL+import Aws.Xml+import Control.Monad+import Text.XML.Enumerator.Cursor (($/), (&|))+import qualified Control.Failure as F+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as BU+import qualified Text.XML.Enumerator.Cursor as Cu data Attribute a = ForAttribute { attributeName :: String, attributeData :: a } deriving (Show) -readAttribute :: Xml SdbError XL.Element (Attribute String)-readAttribute = do- name <- decodeBase64 <<< findElementNameUI "Name"- value <- decodeBase64 <<< findElementNameUI "Value"+readAttribute :: F.Failure XmlException m => Cu.Cursor -> m (Attribute String)+readAttribute cursor = do+ name <- forceM "Missing Name" $ cursor $/ Cu.laxElement "Name" &| decodeBase64+ value <- forceM "Missing Value" $ cursor $/ Cu.laxElement "Value" &| decodeBase64 return $ ForAttribute name value data SetAttribute@@ -66,10 +67,10 @@ = Item { itemName :: String, itemData :: a } deriving (Show) -readItem :: Xml SdbError XL.Element (Item [Attribute String])-readItem = do- name <- decodeBase64 <<< findElementNameUI "Name"- attributes <- inList readAttribute <<< findElementsNameUI "Attribute"+readItem :: F.Failure XmlException m => Cu.Cursor -> m (Item [Attribute String])+readItem cursor = do+ name <- force "Missing Name" <=< sequence $ cursor $/ Cu.laxElement "Name" &| decodeBase64+ attributes <- sequence $ cursor $/ Cu.laxElement "Attribute" &| readAttribute return $ Item name attributes itemQuery :: (a -> [(B.ByteString, B.ByteString)]) -> Item a -> [(B.ByteString, B.ByteString)]
Aws/SimpleDb/Response.hs view
@@ -1,62 +1,54 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies #-} module Aws.SimpleDb.Response where -import Aws.Metadata import Aws.Response import Aws.SimpleDb.Error import Aws.SimpleDb.Metadata-import Control.Applicative-import Control.Arrow ((+++))-import Control.Monad.Compose.Class-import Data.Char-import Text.XML.Monad-import qualified Data.ByteString.Base64 as Base64-import qualified Data.ByteString.UTF8 as BU-import qualified Text.XML.Light as XL--data SdbResponse a- = SdbResponse { - fromSdbResponse :: a- , sdbResponseMetadata :: SdbMetadata- }- deriving (Show)--instance Functor SdbResponse where- fmap f (SdbResponse a m) = SdbResponse (f a) m+import Aws.Xml+import Data.IORef+import Data.Maybe+import Text.XML.Enumerator.Cursor (($|), ($/), ($//), (&|))+import qualified Control.Failure as F+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.UTF8 as BU+import qualified Data.Enumerator as En+import qualified Data.Text as T+import qualified Network.HTTP.Types as HTTP+import qualified Text.XML.Enumerator.Cursor as Cu -instance (SdbFromResponse a) => ResponseIteratee (SdbResponse a) where- responseIteratee status headers = xmlResponseIteratee (fromXml <<< parseXmlResponse) status headers- where fromXml :: SdbFromResponse a => Xml SdbError XL.Element (SdbResponse a)- fromXml = do- requestId' <- strContent <<< findElementNameUI "RequestID"- boxUsage' <- tryMaybe $ strContent <<< findElementNameUI "BoxUsage"- let metadata = SdbMetadata requestId' boxUsage'- innerTry <- try $ fromXmlInner- inner <- case innerTry of- Left err -> raise $ setMetadata metadata err- Right response -> return response- return $ SdbResponse inner metadata- fromXmlInner :: SdbFromResponse a => Xml SdbError XL.Element a- fromXmlInner = do- xmlError <- tryMaybe $ findElementNameUI "Error"- case xmlError of- Just err -> mapply fromError err- Nothing -> sdbFromResponse- fromError :: Xml SdbError XL.Element a- fromError = do- errCode <- strContent <<< findElementNameUI "Code"- errMessage <- strContent <<< findElementNameUI "Message"- raise $ SdbError status errCode errMessage Nothing+sdbResponseIteratee :: + (Cu.Cursor -> Response SdbMetadata a) + -> IORef SdbMetadata+ -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a+sdbResponseIteratee inner metadataRef status headers = xmlCursorIteratee parse metadataRef status headers+ where parse cursor+ = do let requestId' = listToMaybe $ cursor $// elCont "RequestID"+ let boxUsage' = listToMaybe $ cursor $// elCont "BoxUsage"+ tellMetadata $ SdbMetadata requestId' boxUsage'+ case cursor $/ Cu.laxElement "Error" of+ [] -> inner cursor+ (err:_) -> fromError err+ fromError cursor = do errCode <- force "Missing Error Code" $ cursor $// elCont "Code"+ errMessage <- force "Missing Error Message" $ cursor $// elCont "Message"+ F.failure $ SdbError status errCode errMessage class SdbFromResponse a where- sdbFromResponse :: Xml SdbError XL.Element a+ sdbFromResponse :: Cu.Cursor -> Response SdbMetadata a -decodeBase64 :: Xml SdbError XL.Element String-decodeBase64 = do- encoded <- strContent- encoding <- tryMaybe $ findAttr (XL.unqual "encoding")- raisesXml $ case map toLower <$> encoding of- Nothing -> Right encoded- Just "base64" -> (EncodingError . ("Invalid Base64 data: "++) +++ BU.toString) . Base64.decode . BU.fromString $ encoded- Just actual -> Left $ UnexpectedAttributeValueQ actual "base64"+sdbCheckResponseType :: F.Failure XmlException m => a -> T.Text -> Cu.Cursor -> m a+sdbCheckResponseType a n c = do _ <- force ("Expected response type " ++ T.unpack n) (Cu.laxElement n c)+ return a++decodeBase64 :: F.Failure XmlException m => Cu.Cursor -> m String+decodeBase64 cursor =+ let encoded = T.unpack . T.concat $ cursor $/ Cu.content+ encoding = listToMaybe $ cursor $| Cu.laxAttribute "encoding" &| T.toCaseFold+ in+ case encoding of+ Nothing -> return encoded+ Just "base64" -> case fmap BU.toString $ Base64.decode . BU.fromString $ encoded of+ Left msg -> F.failure $ XmlException ("Invalid Base64 data: " ++ msg)+ Right x -> return x+ Just actual -> F.failure $ XmlException ("Unrecognized encoding " ++ T.unpack actual)
Aws/Transaction.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-} module Aws.Transaction where import Aws.Response import Aws.Signature+import Data.Monoid -class (SignQuery r, ResponseIteratee a)+class (SignQuery r, ResponseIteratee a, Monoid (ResponseMetadata a)) => Transaction r a | r -> a, a -> r
Aws/Util.hs view
@@ -37,11 +37,17 @@ fmtTime :: String -> UTCTime -> B.ByteString fmtTime s t = BU.fromString $ formatTime defaultTimeLocale s t +rfc822Time :: String+rfc822Time = "%a, %_d %b %Y %H:%M:%S GMT"+ fmtRfc822Time :: UTCTime -> B.ByteString-fmtRfc822Time = fmtTime "%a, %_d %b %Y %H:%M:%S GMT"+fmtRfc822Time = fmtTime rfc822Time +amzTime :: String+amzTime = "%Y-%m-%dT%H:%M:%S"+ fmtAmzTime :: UTCTime -> B.ByteString-fmtAmzTime = fmtTime "%Y-%m-%dT%H:%M:%S"+fmtAmzTime = fmtTime amzTime fmtTimeEpochSeconds :: UTCTime -> B.ByteString fmtTimeEpochSeconds = fmtTime "%s"
+ Aws/Xml.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-}+module Aws.Xml+where+ +import Aws.Response+import Control.Monad.IO.Class+import Data.Attempt (Attempt(..))+import Data.Enumerator ((=$))+import Data.IORef+import Data.Monoid+import Data.Typeable+import Text.XML.Enumerator.Cursor+import qualified Control.Exception as C+import qualified Control.Failure as F+import qualified Data.ByteString as B+import qualified Data.Enumerator as En+import qualified Data.Text as T+import qualified Network.HTTP.Types as HTTP+import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Text.XML.Enumerator.Parse as XML+import qualified Text.XML.Enumerator.Resolved as XML++newtype XmlException = XmlException { xmlErrorMessage :: String }+ deriving (Show, Typeable)++instance C.Exception XmlException++elCont :: T.Text -> Cursor -> [String]+elCont name = laxElement name &/ content &| T.unpack++force :: F.Failure XmlException m => String -> [a] -> m a+force = Cu.force . XmlException++forceM :: F.Failure XmlException m => String -> [m a] -> m a+forceM = Cu.forceM . XmlException++readInt :: (F.Failure XmlException m, Num a) => String -> m a+readInt s = case reads s of+ [(n,"")] -> return $ fromInteger n+ _ -> F.failure $ XmlException "Invalid Integer"++xmlCursorIteratee ::+ (Monoid m)+ => (Cu.Cursor -> Response m a)+ -> IORef m+ -> HTTP.Status + -> HTTP.ResponseHeaders + -> En.Iteratee B.ByteString IO a+xmlCursorIteratee parse metadataRef _status _headers+ = do doc <- XML.parseBytes XML.decodeEntities =$ XML.fromEvents+ let cursor = Cu.fromDocument doc+ let Response metadata x = parse cursor+ liftIO $ tellMetadataRef metadataRef metadata+ case x of + Failure err -> En.throwError err+ Success v -> return v
aws.cabal view
@@ -6,7 +6,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.0.3+Version: 0.0.4 -- A short (one-line) description of the package. Synopsis: Amazon Web Services (AWS) for Haskell@@ -53,7 +53,6 @@ Aws.Credentials, Aws.Debug, Aws.Http,- Aws.Metadata, Aws.Query, Aws.Response, Aws.S3,@@ -86,32 +85,34 @@ Aws.SimpleDb.Query, Aws.SimpleDb.Response, Aws.Transaction,- Aws.Util+ Aws.Util,+ Aws.Xml -- Packages needed in order to build this package. Build-depends:+ attempt >=0.3.1.1 && <0.4, base ==4.*, base64-bytestring ==0.1.*, blaze-builder >=0.2.1.4 && <0.4, bytestring ==0.9.*, cereal ==0.3.*, containers >=0.3 && <0.5,- crypto-api ==0.5.*,- cryptohash ==0.6.*,+ crypto-api >= 0.5 && < 0.7,+ cryptohash >= 0.6 && < 0.8, directory >=1.0 && <1.2, enumerator ==0.4.*,+ failure >=0.1.0.1 && <0.2, filepath >=1.1 && <1.3,- http-enumerator >=0.5 && < 0.6,+ http-enumerator >=0.6 && < 0.7, http-types >=0.6 && <0.7, mtl ==2.*, old-locale ==1.*, shortcircuit ==0.1.*,+ text >=0.11 && <0.12, time >=1.1.4 && <1.3, transformers >=0.2.2.0 && <0.3,- transformers-compose ==0.1.*, utf8-string ==0.3.*,- xml ==1.3.*,- xml-monad >=0.5 && <0.6+ xml-enumerator >=0.3.3.667 && <0.4 GHC-Options: -Wall @@ -120,4 +121,15 @@ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: - +++-- Source repository+source-repository head+ type: git+ location: git://github.com/aristidb/aws.git+ branch: master++source-repository this+ type: git+ location: git://github.com/aristidb/aws.git+ tag: 0.0.4