aws 0.0.6 → 0.1
raw patch · 42 files changed
+354/−352 lines, 42 filesdep +conduitdep +http-conduitdep +lifted-basedep −containersdep −enumeratordep −http-enumeratordep ~case-insensitivedep ~crypto-api
Dependencies added: conduit, http-conduit, lifted-base, xml-conduit
Dependencies removed: containers, enumerator, http-enumerator, transformers-compose, xml-enumerator
Dependency ranges changed: case-insensitive, crypto-api
Files
- Aws/Aws.hs +5/−6
- Aws/Query.hs +8/−8
- Aws/Response.hs +8/−11
- Aws/S3/Commands/DeleteObject.hs +9/−4
- Aws/S3/Commands/GetBucket.hs +10/−7
- Aws/S3/Commands/GetObject.hs +11/−9
- Aws/S3/Commands/GetService.hs +14/−11
- Aws/S3/Commands/PutBucket.hs +14/−11
- Aws/S3/Commands/PutObject.hs +26/−24
- Aws/S3/Model.hs +10/−10
- Aws/S3/Query.hs +17/−16
- Aws/S3/Response.hs +29/−31
- Aws/SimpleDb/Commands/BatchDeleteAttributes.hs +2/−2
- Aws/SimpleDb/Commands/BatchPutAttributes.hs +2/−2
- Aws/SimpleDb/Commands/CreateDomain.hs +2/−2
- Aws/SimpleDb/Commands/DeleteAttributes.hs +2/−2
- Aws/SimpleDb/Commands/DeleteDomain.hs +2/−2
- Aws/SimpleDb/Commands/DomainMetadata.hs +4/−4
- Aws/SimpleDb/Commands/GetAttributes.hs +5/−5
- Aws/SimpleDb/Commands/ListDomains.hs +5/−5
- Aws/SimpleDb/Commands/PutAttributes.hs +2/−2
- Aws/SimpleDb/Commands/Select.hs +4/−4
- Aws/SimpleDb/Model.hs +10/−10
- Aws/SimpleDb/Query.hs +1/−0
- Aws/SimpleDb/Response.hs +8/−10
- Aws/Sqs/Commands/AddPermission.hs +2/−2
- Aws/Sqs/Commands/ChangeMessageVisibility.hs +2/−2
- Aws/Sqs/Commands/CreateQueue.hs +11/−11
- Aws/Sqs/Commands/DeleteMessage.hs +2/−2
- Aws/Sqs/Commands/DeleteQueue.hs +2/−2
- Aws/Sqs/Commands/GetQueueAttributes.hs +10/−10
- Aws/Sqs/Commands/ListQueues.hs +9/−9
- Aws/Sqs/Commands/ReceiveMessage.hs +11/−11
- Aws/Sqs/Commands/RemovePermission.hs +2/−2
- Aws/Sqs/Commands/SendMessage.hs +9/−9
- Aws/Sqs/Commands/SetQueueAttributes.hs +2/−2
- Aws/Sqs/Query.hs +1/−0
- Aws/Sqs/Response.hs +26/−29
- Aws/Transaction.hs +1/−1
- Aws/Util.hs +6/−8
- Aws/Xml.hs +16/−20
- aws.cabal +32/−34
Aws/Aws.hs view
@@ -18,8 +18,7 @@ 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+import qualified Network.HTTP.Conduit as HTTP data Configuration = Configuration {@@ -69,17 +68,17 @@ -- TODO: better error handling when credentials cannot be loaded debugConfiguration :: IO Configuration-debugConfiguration = do +debugConfiguration = do c <- baseConfiguration return c { sdbInfo = sdbHttpPost sdbUsEast, sdbInfoUri = sdbHttpGet sdbUsEast } aws :: (Transaction r a- , ConfigurationFetch (Info r)) + , ConfigurationFetch (Info r)) => Configuration -> r -> IO (Response (ResponseMetadata a) a) aws = unsafeAws unsafeAws- :: (ResponseIteratee r a,+ :: (ResponseConsumer r a, Monoid (ResponseMetadata a), SignQuery r, ConfigurationFetch (Info r)) =>@@ -92,7 +91,7 @@ let httpRequest = queryToHttpRequest q metadataRef <- newIORef mempty resp <- attemptIO (id :: E.SomeException -> E.SomeException) $- HTTP.withManager $ En.run_ . HTTP.httpRedirect httpRequest (responseIteratee request metadataRef)+ HTTP.withManager $ HTTP.httpRedirect httpRequest (responseConsumer request metadataRef) metadata <- readIORef metadataRef return $ Response metadata resp
Aws/Query.hs view
@@ -11,11 +11,11 @@ import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Network.HTTP.Enumerator as HTTP+import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP import qualified Network.TLS as TLS -data SignedQuery +data SignedQuery = SignedQuery { sqMethod :: Method , sqProtocol :: Protocol@@ -28,6 +28,7 @@ , sqContentType :: Maybe B.ByteString , sqContentMd5 :: Maybe B.ByteString , sqAmzHeaders :: HTTP.RequestHeaders+ , sqOtherHeaders :: HTTP.RequestHeaders , sqBody :: Maybe (HTTP.RequestBody IO) , sqStringToSign :: B.ByteString }@@ -35,28 +36,27 @@ queryToHttpRequest :: SignedQuery -> HTTP.Request IO queryToHttpRequest SignedQuery{..}- = HTTP.Request {+ = HTTP.def { HTTP.method = httpMethod sqMethod , HTTP.secure = case sqProtocol of HTTP -> False HTTPS -> True- , HTTP.checkCerts = const (return TLS.CertificateUsageAccept) -- FIXME: actually check certificates+ , HTTP.checkCerts = \_ _ -> return TLS.CertificateUsageAccept -- FIXME: actually check certificates , HTTP.host = sqHost , HTTP.port = sqPort , HTTP.path = sqPath- , HTTP.queryString = sqQuery+ , HTTP.queryString = HTTP.renderQuery False sqQuery , HTTP.requestHeaders = catMaybes [fmap (\d -> ("Date", fmtRfc822Time d)) sqDate , fmap (\c -> ("Content-Type", c)) contentType , fmap (\md5 -> ("Content-MD5", md5)) sqContentMd5 , fmap (\auth -> ("Authorization", auth)) sqAuthorization] ++ sqAmzHeaders+ ++ sqOtherHeaders , HTTP.requestBody = case sqMethod of PostQuery -> HTTP.RequestBodyLBS . Blaze.toLazyByteString $ HTTP.renderQueryBuilder False sqQuery _ -> case sqBody of Nothing -> HTTP.RequestBodyBuilder 0 mempty Just x -> x- , HTTP.proxy = Nothing- , HTTP.rawBody = False , HTTP.decompress = HTTP.alwaysDecompress } where contentType = case sqMethod of@@ -64,7 +64,7 @@ _ -> sqContentType queryToUri :: SignedQuery -> B.ByteString-queryToUri SignedQuery{..} +queryToUri SignedQuery{..} = B.concat [ case sqProtocol of HTTP -> "http://"
Aws/Response.hs view
@@ -2,17 +2,14 @@ module Aws.Response where- + 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- +import qualified Network.HTTP.Conduit as HTTP+ data Response m a = Response m (Attempt a) deriving (Show, Functor) @@ -31,10 +28,10 @@ tellMetadataRef :: Monoid m => IORef m -> m -> IO () tellMetadataRef r m = modifyIORef r (`mappend` m) -class ResponseIteratee r a where+class ResponseConsumer r a where type ResponseMetadata a- responseIteratee :: r -> IORef (ResponseMetadata a) -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a- -instance ResponseIteratee r HTTP.Response where+ responseConsumer :: r -> IORef (ResponseMetadata a) -> HTTP.ResponseConsumer IO a++instance ResponseConsumer r HTTP.Response where type ResponseMetadata HTTP.Response = ()- responseIteratee _ _ = HTTP.lbsIter+ responseConsumer _ _ = HTTP.lbsConsumer
Aws/S3/Commands/DeleteObject.hs view
@@ -8,6 +8,7 @@ import Aws.S3.Metadata import Aws.S3.Model import Aws.S3.Query+import Aws.S3.Response import Aws.Signature import Aws.Transaction import Data.ByteString.Char8 ({- IsString -})@@ -24,20 +25,24 @@ instance SignQuery DeleteObject where type Info DeleteObject = S3Info- signQuery DeleteObject {..} = s3SignQuery S3Query { + signQuery DeleteObject {..} = s3SignQuery S3Query { s3QMethod = Delete , s3QBucket = Just $ T.encodeUtf8 doBucket , s3QSubresources = [] , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing , s3QAmzHeaders = []+ , s3QOtherHeaders = [] , s3QRequestBody = Nothing , s3QObject = Just $ T.encodeUtf8 doObjectName } -instance ResponseIteratee DeleteObject DeleteObjectResponse where+instance ResponseConsumer DeleteObject DeleteObjectResponse where type ResponseMetadata DeleteObjectResponse = S3Metadata- responseIteratee _ _ _ _ = return DeleteObjectResponse- + responseConsumer _ = s3ResponseConsumer $ \_ _ _ ->+ return DeleteObjectResponse+ instance Transaction DeleteObject DeleteObjectResponse
Aws/S3/Commands/GetBucket.hs view
@@ -16,12 +16,12 @@ import Control.Arrow (second) import Data.ByteString.Char8 ({- IsString -}) import Data.Maybe-import Text.XML.Enumerator.Cursor (($/), (&|), (&//))+import Text.XML.Cursor (($/), (&|), (&//)) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Traversable import qualified Network.HTTP.Types as HTTP-import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Text.XML.Cursor as Cu data GetBucket = GetBucket {@@ -34,8 +34,8 @@ deriving (Show) getBucket :: Bucket -> GetBucket-getBucket bucket - = GetBucket { +getBucket bucket+ = GetBucket { gbBucket = bucket , gbDelimiter = Nothing , gbMarker = Nothing@@ -57,7 +57,7 @@ instance SignQuery GetBucket where type Info GetBucket = S3Info- signQuery GetBucket {..} = s3SignQuery S3Query { + signQuery GetBucket {..} = s3SignQuery S3Query { s3QMethod = Get , s3QBucket = Just $ T.encodeUtf8 gbBucket , s3QObject = Nothing@@ -68,14 +68,17 @@ , ("max-keys",) . T.pack . show <$> gbMaxKeys , ("prefix",) <$> gbPrefix ]+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing , s3QAmzHeaders = []+ , s3QOtherHeaders = [] , s3QRequestBody = Nothing } -instance ResponseIteratee r GetBucketResponse where+instance ResponseConsumer r GetBucketResponse where type ResponseMetadata GetBucketResponse = S3Metadata - responseIteratee _ = s3XmlResponseIteratee parse+ responseConsumer _ = s3XmlResponseConsumer parse where parse cursor = do name <- force "Missing Name" $ cursor $/ elContent "Name" let delimiter = listToMaybe $ cursor $/ elContent "Delimiter"
Aws/S3/Commands/GetObject.hs view
@@ -15,17 +15,16 @@ import Control.Arrow (second) import Data.ByteString.Char8 ({- IsString -}) import Data.Maybe-import qualified Data.ByteString as B-import qualified Data.Enumerator as En import qualified Data.Text as T import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP data GetObject a = GetObject { goBucket :: Bucket , goObjectName :: Object- , goResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a+ , goResponseConsumer :: HTTP.ResponseConsumer IO a , goResponseContentType :: Maybe T.Text , goResponseContentLanguage :: Maybe T.Text , goResponseExpires :: Maybe T.Text@@ -34,7 +33,7 @@ , goResponseContentEncoding :: Maybe T.Text } -getObject :: Bucket -> T.Text -> (HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a) -> GetObject a+getObject :: Bucket -> T.Text -> (HTTP.ResponseConsumer IO a) -> GetObject a getObject b o i = GetObject b o i Nothing Nothing Nothing Nothing Nothing Nothing data GetObjectResponse a@@ -43,10 +42,10 @@ instance SignQuery (GetObject a) where type Info (GetObject a) = S3Info- signQuery GetObject {..} = s3SignQuery S3Query { + signQuery GetObject {..} = s3SignQuery S3Query { s3QMethod = Get , s3QBucket = Just $ T.encodeUtf8 goBucket- , s3QObject = Just $ T.encodeUtf8 goObjectName + , s3QObject = Just $ T.encodeUtf8 goObjectName , s3QSubresources = [] , s3QQuery = HTTP.simpleQueryToQuery $ map (second T.encodeUtf8) $ catMaybes [ ("response-content-type",) <$> goResponseContentType@@ -56,13 +55,16 @@ , ("response-content-disposition",) <$> goResponseContentDisposition , ("response-content-encoding",) <$> goResponseContentEncoding ]+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing , s3QAmzHeaders = []+ , s3QOtherHeaders = [] , s3QRequestBody = Nothing } -instance ResponseIteratee (GetObject a) (GetObjectResponse a) where+instance ResponseConsumer (GetObject a) (GetObjectResponse a) where type ResponseMetadata (GetObjectResponse a) = S3Metadata- responseIteratee GetObject{..} metadata status headers- = GetObjectResponse <$> s3BinaryResponseIteratee (goResponseIteratee) metadata status headers+ responseConsumer GetObject{..} metadata status headers source+ = GetObjectResponse <$> s3BinaryResponseConsumer goResponseConsumer metadata status headers source instance Transaction (GetObject a) (GetObjectResponse a)
Aws/S3/Commands/GetService.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, OverloadedStrings #-} module Aws.S3.Commands.GetService where- + import Aws.Http import Aws.Response import Aws.S3.Info@@ -15,29 +15,29 @@ import Data.Maybe import Data.Time.Format import System.Locale-import Text.XML.Enumerator.Cursor (($/), ($//), (&|))-import qualified Data.Text as T-import qualified Text.XML.Enumerator.Cursor as Cu+import Text.XML.Cursor (($/), ($//), (&|))+import qualified Data.Text as T+import qualified Text.XML.Cursor as Cu data GetService = GetService -data GetServiceResponse +data GetServiceResponse = GetServiceResponse { gsrOwner :: UserInfo , gsrBuckets :: [BucketInfo] } deriving (Show) -instance ResponseIteratee r GetServiceResponse where+instance ResponseConsumer r GetServiceResponse where type ResponseMetadata GetServiceResponse = S3Metadata - responseIteratee _ = s3XmlResponseIteratee parse+ responseConsumer _ = s3XmlResponseConsumer parse where 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 el = do name <- force "Missing owner Name" $ el $/ elContent "Name" creationDateString <- force "Missing owner CreationDate" $ el $/ elContent "CreationDate" &| T.unpack@@ -46,14 +46,17 @@ instance SignQuery GetService where type Info GetService = S3Info- signQuery GetService = s3SignQuery S3Query { + signQuery GetService = s3SignQuery S3Query { s3QMethod = Get , s3QBucket = Nothing , s3QObject = Nothing , s3QSubresources = [] , s3QQuery = []- , s3QAmzHeaders = [] - , s3QRequestBody = Nothing + , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = []+ , s3QRequestBody = Nothing } instance Transaction GetService GetServiceResponse
Aws/S3/Commands/PutBucket.hs view
@@ -11,10 +11,10 @@ import Aws.Signature import Aws.Transaction import Control.Monad-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Network.HTTP.Enumerator as HTTPE-import qualified Text.XML.Enumerator.Resolved as XML+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Conduit as HTTP+import qualified Text.XML as XML data PutBucket = PutBucket {@@ -36,13 +36,16 @@ , s3QBucket = Just $ T.encodeUtf8 pbBucket , s3QSubresources = [] , s3QQuery = []- , s3QObject = Nothing- , s3QAmzHeaders = case pbCannedAcl of + , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QObject = Nothing+ , s3QAmzHeaders = case pbCannedAcl of Nothing -> [] Just acl -> [("x-amz-acl", T.encodeUtf8 $ writeCannedAcl acl)]+ , s3QOtherHeaders = [] , s3QRequestBody = guard (not . T.null $ pbLocationConstraint) >>- (Just . HTTPE.RequestBodyLBS . XML.renderLBS) + (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def) XML.Document { XML.documentPrologue = XML.Prologue [] Nothing [] , XML.documentRoot = root@@ -61,10 +64,10 @@ ] } -instance ResponseIteratee r PutBucketResponse where+instance ResponseConsumer r PutBucketResponse where type ResponseMetadata PutBucketResponse = S3Metadata- - responseIteratee _ = s3ResponseIteratee inner- where inner _status _headers = return PutBucketResponse++ responseConsumer _ = s3ResponseConsumer inner+ where inner _status _headers _source = return PutBucketResponse instance Transaction PutBucket PutBucketResponse
Aws/S3/Commands/PutObject.hs view
@@ -8,26 +8,27 @@ import Aws.S3.Metadata import Aws.S3.Model import Aws.S3.Query+import Aws.S3.Response import Aws.Signature import Aws.Transaction import Control.Applicative import Control.Arrow (second) import Data.ByteString.Char8 ({- IsString -}) import Data.Maybe+import qualified Data.ByteString.Char8 as B import qualified Data.CaseInsensitive as CI import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Network.HTTP.Enumerator as HTTP-import qualified Network.HTTP.Types as HTTP+import qualified Network.HTTP.Conduit as HTTP data PutObject = PutObject { poObjectName :: T.Text, poBucket :: Bucket,- poContentType :: Maybe T.Text,+ poContentType :: Maybe B.ByteString, poCacheControl :: Maybe T.Text, poContentDisposition :: Maybe T.Text, poContentEncoding :: Maybe T.Text,- poContentMD5 :: Maybe T.Text,+ poContentMD5 :: Maybe B.ByteString, poExpires :: Maybe Int, poAcl :: Maybe CannedAcl, poStorageClass :: Maybe StorageClass,@@ -35,41 +36,42 @@ poMetadata :: [(T.Text,T.Text)] } -data PutObjectResponse = PutObjectResponse{- porVersionId :: Maybe T.Text-}+putObject :: T.Text -> Bucket -> HTTP.RequestBody IO -> PutObject+putObject obj bucket body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body [] +data PutObjectResponse + = PutObjectResponse {+ porVersionId :: Maybe T.Text+ }+ deriving (Show)+ instance SignQuery PutObject where type Info PutObject = S3Info- signQuery PutObject {..} = s3SignQuery S3Query { + signQuery PutObject {..} = s3SignQuery S3Query { s3QMethod = Put , s3QBucket = Just $ T.encodeUtf8 poBucket , s3QSubresources = []- , s3QQuery = HTTP.simpleQueryToQuery $ map (second T.encodeUtf8) $ catMaybes [- ("Content-Type",) <$> poContentType- , ("Expires",) <$> case poExpires of- Just x -> Just $ T.pack $ show x- Nothing -> Nothing+ , s3QQuery = []+ , s3QContentType = poContentType+ , s3QContentMd5 = poContentMD5+ , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [+ ("x-amz-acl",) <$> writeCannedAcl <$> poAcl+ , ("x-amz-storage-class",) <$> writeStorageClass <$> poStorageClass+ ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) poMetadata+ , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [+ ("Expires",) . T.pack . show <$> poExpires , ("Cache-Control",) <$> poCacheControl , ("Content-Disposition",) <$> poContentDisposition , ("Content-Encoding",) <$> poContentEncoding- , ("Content-MD5",) <$> poContentMD5 ]- , s3QAmzHeaders = catMaybes [- (CI.mk $ T.encodeUtf8 "x-amz-acl",) <$> case poAcl of- Just x -> Just $ T.encodeUtf8 $ writeCannedAcl x- Nothing -> Nothing- , ("x-amz-storage-class",) <$> case poStorageClass of- Just x -> Just $ T.encodeUtf8 $ writeStorageClass x- Nothing -> Nothing- ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], T.encodeUtf8 $ snd x)) poMetadata , s3QRequestBody = Just poRequestBody , s3QObject = Just $ T.encodeUtf8 poObjectName } -instance ResponseIteratee PutObject PutObjectResponse where+instance ResponseConsumer PutObject PutObjectResponse where type ResponseMetadata PutObjectResponse = S3Metadata- responseIteratee _ _ _ _ = do return $ PutObjectResponse Nothing+ responseConsumer _ = s3ResponseConsumer $ \_ _ _ ->+ return $ PutObjectResponse Nothing instance Transaction PutObject PutObjectResponse
Aws/S3/Model.hs view
@@ -5,10 +5,10 @@ import Aws.Xml import Data.Time import System.Locale-import Text.XML.Enumerator.Cursor (($/), (&|), (>=>))-import qualified Control.Failure as F-import qualified Text.XML.Enumerator.Cursor as Cu-import qualified Data.Text as T+import Text.XML.Cursor (($/), (&|))+import qualified Control.Failure as F+import qualified Text.XML.Cursor as Cu+import qualified Data.Text as T type CanonicalUserId = T.Text @@ -25,11 +25,11 @@ return UserInfo { userId = id_, userDisplayName = displayName } data CannedAcl- = AclPrivate - | AclPublicRead - | AclPublicReadWrite - | AclAuthenticatedRead - | AclBucketOwnerRead + = AclPrivate+ | AclPublicRead+ | AclPublicReadWrite+ | AclAuthenticatedRead+ | AclBucketOwnerRead | AclBucketOwnerFullControl | AclLogDeliveryWrite deriving (Show)@@ -80,7 +80,7 @@ deriving (Show) parseObjectInfo :: F.Failure XmlException m => Cu.Cursor -> m ObjectInfo-parseObjectInfo el +parseObjectInfo el = do key <- force "Missing object Key" $ el $/ elContent "Key" let time s = case parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ T.unpack s of Nothing -> F.failure $ XmlException "Invalid time"
Aws/S3/Query.hs view
@@ -19,7 +19,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.CaseInsensitive as CI-import qualified Network.HTTP.Enumerator as HTTPE+import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP data S3Query@@ -29,17 +29,20 @@ , s3QObject :: Maybe B.ByteString , s3QSubresources :: HTTP.Query , s3QQuery :: HTTP.Query+ , s3QContentType :: Maybe B.ByteString+ , s3QContentMd5 :: Maybe B.ByteString , s3QAmzHeaders :: HTTP.RequestHeaders- , s3QRequestBody :: Maybe (HTTPE.RequestBody IO)+ , s3QOtherHeaders :: HTTP.RequestHeaders+ , s3QRequestBody :: Maybe (HTTP.RequestBody IO) } instance Show S3Query where show S3Query{..} = "S3Query [" ++ " method: " ++ show s3QMethod ++- " ; bucket: " ++ show s3QBucket ++ - " ; subresources: " ++ show s3QSubresources ++ + " ; bucket: " ++ show s3QBucket +++ " ; subresources: " ++ show s3QSubresources ++ " ; query: " ++ show s3QQuery ++- " ; request body: " ++ (case s3QRequestBody of Nothing -> "no"; _ -> "yes") ++ + " ; request body: " ++ (case s3QRequestBody of Nothing -> "no"; _ -> "yes") ++ "]" s3SignQuery :: S3Query -> S3Info -> SignatureData -> SignedQuery@@ -53,22 +56,20 @@ , sqQuery = sortedSubresources ++ s3QQuery ++ authQuery , sqDate = Just signatureTime , sqAuthorization = authorization- , sqContentType = contentType- , sqContentMd5 = contentMd5+ , sqContentType = s3QContentType+ , sqContentMd5 = s3QContentMd5 , sqAmzHeaders = amzHeaders+ , sqOtherHeaders = s3QOtherHeaders , sqBody = s3QRequestBody , sqStringToSign = stringToSign } where- contentMd5 = Nothing- contentType = Nothing amzHeaders = merge $ sortBy (compare `on` fst) s3QAmzHeaders- where merge (x1@(k1,v1):x2@(k2,v2):xs) = if k1 == k2- then (k1, B8.intercalate "," [v1, v2]):merge xs- else x1:x2:merge xs+ where merge (x1@(k1,v1):x2@(k2,v2):xs) | k1 == k2 = merge ((k1, B8.intercalate "," [v1, v2]) : xs)+ | otherwise = x1 : merge (x2 : xs) merge xs = xs- - (host, path) = case s3RequestStyle of ++ (host, path) = case s3RequestStyle of PathStyle -> ([Just s3Endpoint], [Just "/", fmap (`B8.snoc` '/') s3QBucket, s3QObject]) BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just "/", s3QObject]) VHostStyle -> ([Just $ fromMaybe s3Endpoint s3QBucket], [Just "/", s3QObject])@@ -84,8 +85,8 @@ sig = signature signatureCredentials HmacSHA1 stringToSign stringToSign = Blaze.toByteString . mconcat . intersperse (Blaze8.fromChar '\n') . concat $ [[Blaze.copyByteString $ httpMethod s3QMethod]- , [maybe mempty Blaze.copyByteString contentMd5]- , [maybe mempty Blaze.copyByteString contentType]+ , [maybe mempty Blaze.copyByteString s3QContentMd5]+ , [maybe mempty Blaze.copyByteString s3QContentType] , [Blaze.copyByteString $ case ti of AbsoluteTimestamp time -> fmtRfc822Time time AbsoluteExpires time -> fmtTimeEpochSeconds time]
Aws/S3/Response.hs view
@@ -9,53 +9,51 @@ import Aws.Xml import Control.Monad.IO.Class import Data.Attempt (Attempt(..))-import Data.Enumerator ((=$))+import Data.Conduit (($$)) import Data.IORef import Data.Maybe-import Text.XML.Enumerator.Cursor (($/))+import Text.XML.Cursor (($/)) import qualified Data.ByteString as B-import qualified Data.Enumerator as En+import qualified Data.Conduit as C import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Conduit as HTTP 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+import qualified Text.XML.Cursor as Cu+import qualified Text.XML as XML -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+s3ResponseConsumer :: HTTP.ResponseConsumer IO a+ -> IORef S3Metadata+ -> HTTP.ResponseConsumer IO a+s3ResponseConsumer inner metadata status headers source = do let headerString = fmap T.decodeUtf8 . flip lookup headers let amzId2 = headerString "x-amz-id-2" let requestId = headerString "x-amz-request-id"- + let m = S3Metadata { s3MAmzId2 = amzId2, s3MRequestId = requestId } liftIO $ tellMetadataRef metadata m- + if status >= HTTP.status400- then s3ErrorResponseIteratee status headers- else inner status headers+ then s3ErrorResponseConsumer status headers source+ else inner status headers source -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+s3XmlResponseConsumer :: (Cu.Cursor -> Response S3Metadata a)+ -> IORef S3Metadata+ -> HTTP.ResponseConsumer IO a+s3XmlResponseConsumer parse metadataRef =+ s3ResponseConsumer (xmlCursorConsumer parse metadataRef) metadataRef -s3BinaryResponseIteratee ::- (HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a)- -> IORef S3Metadata- -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a-s3BinaryResponseIteratee inner metadataRef = s3ResponseIteratee inner metadataRef +s3BinaryResponseConsumer :: HTTP.ResponseConsumer IO a+ -> IORef S3Metadata+ -> HTTP.ResponseConsumer IO a+s3BinaryResponseConsumer inner metadataRef = s3ResponseConsumer inner metadataRef -s3ErrorResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a-s3ErrorResponseIteratee status _headers - = do doc <- XML.parseBytes XML.decodeEntities =$ XML.fromEvents+s3ErrorResponseConsumer :: HTTP.ResponseConsumer IO a+s3ErrorResponseConsumer status _headers source+ = do doc <- source $$ XML.sinkDoc XML.def let cursor = Cu.fromDocument doc- case parseError cursor of- Success err -> En.throwError err- Failure otherErr -> En.throwError otherErr+ liftIO $ case parseError cursor of+ Success err -> C.resourceThrow err+ Failure otherErr -> C.resourceThrow otherErr where parseError :: Cu.Cursor -> Attempt S3Error parseError root = do code <- force "Missing error Code" $ root $/ elContent "Code"
Aws/SimpleDb/Commands/BatchDeleteAttributes.hs view
@@ -36,8 +36,8 @@ , ("DomainName", T.encodeUtf8 bdaDomainName)] ++ queryList (itemQuery $ queryList (attributeQuery deleteAttributeQuery) "Attribute") "Item" bdaItems -instance ResponseIteratee r BatchDeleteAttributesResponse where+instance ResponseConsumer r BatchDeleteAttributesResponse where type ResponseMetadata BatchDeleteAttributesResponse = SdbMetadata- responseIteratee _ = sdbResponseIteratee $ sdbCheckResponseType BatchDeleteAttributesResponse "BatchDeleteAttributesResponse"+ responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType BatchDeleteAttributesResponse "BatchDeleteAttributesResponse" instance Transaction BatchDeleteAttributes BatchDeleteAttributesResponse
Aws/SimpleDb/Commands/BatchPutAttributes.hs view
@@ -36,8 +36,8 @@ , ("DomainName", T.encodeUtf8 bpaDomainName)] ++ queryList (itemQuery $ queryList (attributeQuery setAttributeQuery) "Attribute") "Item" bpaItems -instance ResponseIteratee r BatchPutAttributesResponse where+instance ResponseConsumer r BatchPutAttributesResponse where type ResponseMetadata BatchPutAttributesResponse = SdbMetadata- responseIteratee _ = sdbResponseIteratee $ sdbCheckResponseType BatchPutAttributesResponse "BatchPutAttributesResponse"+ responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType BatchPutAttributesResponse "BatchPutAttributesResponse" instance Transaction BatchPutAttributes BatchPutAttributesResponse
Aws/SimpleDb/Commands/CreateDomain.hs view
@@ -29,8 +29,8 @@ type Info CreateDomain = SdbInfo signQuery CreateDomain{..} = sdbSignQuery [("Action", "CreateDomain"), ("DomainName", T.encodeUtf8 cdDomainName)] -instance ResponseIteratee r CreateDomainResponse where+instance ResponseConsumer r CreateDomainResponse where type ResponseMetadata CreateDomainResponse = SdbMetadata- responseIteratee _ = sdbResponseIteratee $ sdbCheckResponseType CreateDomainResponse "CreateDomainResponse"+ responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType CreateDomainResponse "CreateDomainResponse" instance Transaction CreateDomain CreateDomainResponse
Aws/SimpleDb/Commands/DeleteAttributes.hs view
@@ -43,8 +43,8 @@ queryList (attributeQuery deleteAttributeQuery) "Attribute" daAttributes ++ queryList (attributeQuery expectedAttributeQuery) "Expected" daExpected -instance ResponseIteratee r DeleteAttributesResponse where+instance ResponseConsumer r DeleteAttributesResponse where type ResponseMetadata DeleteAttributesResponse = SdbMetadata- responseIteratee _ = sdbResponseIteratee $ sdbCheckResponseType DeleteAttributesResponse "DeleteAttributesResponse"+ responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType DeleteAttributesResponse "DeleteAttributesResponse" instance Transaction DeleteAttributes DeleteAttributesResponse
Aws/SimpleDb/Commands/DeleteDomain.hs view
@@ -29,8 +29,8 @@ type Info DeleteDomain = SdbInfo signQuery DeleteDomain{..} = sdbSignQuery [("Action", "DeleteDomain"), ("DomainName", T.encodeUtf8 ddDomainName)] -instance ResponseIteratee r DeleteDomainResponse where+instance ResponseConsumer r DeleteDomainResponse where type ResponseMetadata DeleteDomainResponse = SdbMetadata- responseIteratee _ = sdbResponseIteratee $ sdbCheckResponseType DeleteDomainResponse "DeleteDomainResponse"+ responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType DeleteDomainResponse "DeleteDomainResponse" instance Transaction DeleteDomain DeleteDomainResponse
Aws/SimpleDb/Commands/DomainMetadata.hs view
@@ -12,7 +12,7 @@ import Aws.Xml import Data.Time import Data.Time.Clock.POSIX-import Text.XML.Enumerator.Cursor (($//), (&|))+import Text.XML.Cursor (($//), (&|)) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -33,7 +33,7 @@ , dmrAttributeNamesSizeBytes :: Integer } deriving (Show)- + domainMetadata :: T.Text -> DomainMetadata domainMetadata name = DomainMetadata { dmDomainName = name } @@ -41,10 +41,10 @@ type Info DomainMetadata = SdbInfo signQuery DomainMetadata{..} = sdbSignQuery [("Action", "DomainMetadata"), ("DomainName", T.encodeUtf8 dmDomainName)] -instance ResponseIteratee r DomainMetadataResponse where+instance ResponseConsumer r DomainMetadataResponse where type ResponseMetadata DomainMetadataResponse = SdbMetadata - responseIteratee _ = sdbResponseIteratee parse+ responseConsumer _ = sdbResponseConsumer parse where parse cursor = do sdbCheckResponseType () "DomainMetadataResponse" cursor dmrTimestamp <- forceM "Timestamp expected" $ cursor $// elCont "Timestamp" &| (fmap posixSecondsToUTCTime . readInt)
Aws/SimpleDb/Commands/GetAttributes.hs view
@@ -14,10 +14,10 @@ import Control.Applicative import Control.Monad import Data.Maybe-import Text.XML.Enumerator.Cursor (($//), (&|))+import Text.XML.Cursor (($//), (&|)) import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Text.XML.Cursor as Cu data GetAttributes = GetAttributes {@@ -33,7 +33,7 @@ garAttributes :: [Attribute T.Text] } deriving (Show)- + getAttributes :: T.Text -> T.Text -> GetAttributes getAttributes item domain = GetAttributes { gaItemName = item, gaAttributeName = Nothing, gaConsistentRead = False, gaDomainName = domain } @@ -45,9 +45,9 @@ maybeToList (("AttributeName",) <$> T.encodeUtf8 <$> gaAttributeName) ++ (guard gaConsistentRead >> [("ConsistentRead", awsTrue)]) -instance ResponseIteratee r GetAttributesResponse where+instance ResponseConsumer r GetAttributesResponse where type ResponseMetadata GetAttributesResponse = SdbMetadata- responseIteratee _ = sdbResponseIteratee parse+ responseConsumer _ = sdbResponseConsumer parse where parse cursor = do sdbCheckResponseType () "GetAttributesResponse" cursor attributes <- sequence $ cursor $// Cu.laxElement "Attribute" &| readAttribute
Aws/SimpleDb/Commands/ListDomains.hs view
@@ -12,7 +12,7 @@ import Aws.Xml import Control.Applicative import Data.Maybe-import Text.XML.Enumerator.Cursor (($//))+import Text.XML.Cursor (($//)) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -23,7 +23,7 @@ } deriving (Show) -data ListDomainsResponse +data ListDomainsResponse = ListDomainsResponse { ldrDomainNames :: [T.Text] , ldrNextToken :: Maybe T.Text@@ -32,7 +32,7 @@ listDomains :: ListDomains listDomains = ListDomains { ldMaxNumberOfDomains = Nothing, ldNextToken = Nothing }- + instance SignQuery ListDomains where type Info ListDomains = SdbInfo signQuery ListDomains{..} = sdbSignQuery $ catMaybes [@@ -41,9 +41,9 @@ , ("NextToken",) . T.encodeUtf8 <$> ldNextToken ] -instance ResponseIteratee r ListDomainsResponse where+instance ResponseConsumer r ListDomainsResponse where type ResponseMetadata ListDomainsResponse = SdbMetadata- responseIteratee _ = sdbResponseIteratee parse + responseConsumer _ = sdbResponseConsumer parse where parse cursor = do sdbCheckResponseType () "ListDomainsResponse" cursor let names = cursor $// elContent "DomainName"
Aws/SimpleDb/Commands/PutAttributes.hs view
@@ -43,8 +43,8 @@ queryList (attributeQuery setAttributeQuery) "Attribute" paAttributes ++ queryList (attributeQuery expectedAttributeQuery) "Expected" paExpected -instance ResponseIteratee r PutAttributesResponse where+instance ResponseConsumer r PutAttributesResponse where type ResponseMetadata PutAttributesResponse = SdbMetadata- responseIteratee _ = sdbResponseIteratee $ sdbCheckResponseType PutAttributesResponse "PutAttributesResponse"+ responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType PutAttributesResponse "PutAttributesResponse" instance Transaction PutAttributes PutAttributesResponse
Aws/SimpleDb/Commands/Select.hs view
@@ -15,10 +15,10 @@ import Control.Applicative import Control.Monad import Data.Maybe-import Text.XML.Enumerator.Cursor (($//), (&|))+import Text.XML.Cursor (($//), (&|)) import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Text.XML.Cursor as Cu data Select = Select {@@ -48,9 +48,9 @@ , (("NextToken",) . T.encodeUtf8) <$> sNextToken ] -instance ResponseIteratee r SelectResponse where+instance ResponseConsumer r SelectResponse where type ResponseMetadata SelectResponse = SdbMetadata- responseIteratee _ = sdbResponseIteratee parse+ responseConsumer _ = sdbResponseConsumer parse where parse cursor = do sdbCheckResponseType () "SelectResponse" cursor items <- sequence $ cursor $// Cu.laxElement "Item" &| readItem
Aws/SimpleDb/Model.hs view
@@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Aws.SimpleDb.Model where- + import Aws.SimpleDb.Response import Aws.Util import Aws.Xml import Control.Monad-import Text.XML.Enumerator.Cursor (($/), (&|))+import Text.XML.Cursor (($/), (&|)) import qualified Control.Failure as F import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Text.XML.Cursor as Cu data Attribute a = ForAttribute { attributeName :: T.Text, attributeData :: a }@@ -22,20 +22,20 @@ name <- forceM "Missing Name" $ cursor $/ Cu.laxElement "Name" &| decodeBase64 value <- forceM "Missing Value" $ cursor $/ Cu.laxElement "Value" &| decodeBase64 return $ ForAttribute name value- + data SetAttribute = SetAttribute { setAttribute :: T.Text, isReplaceAttribute :: Bool } deriving (Show) attributeQuery :: (a -> [(B.ByteString, B.ByteString)]) -> Attribute a -> [(B.ByteString, B.ByteString)] attributeQuery f (ForAttribute name x) = ("Name", T.encodeUtf8 name) : f x- + addAttribute :: T.Text -> T.Text -> Attribute SetAttribute addAttribute name value = ForAttribute name (SetAttribute value False) replaceAttribute :: T.Text -> T.Text -> Attribute SetAttribute replaceAttribute name value = ForAttribute name (SetAttribute value True)- + setAttributeQuery :: SetAttribute -> [(B.ByteString, B.ByteString)] setAttributeQuery (SetAttribute value replace) = ("Value", T.encodeUtf8 value) : [("Replace", awsTrue) | replace]@@ -48,18 +48,18 @@ deleteAttributeQuery :: DeleteAttribute -> [(B.ByteString, B.ByteString)] deleteAttributeQuery DeleteAttribute = [] deleteAttributeQuery (ValuedDeleteAttribute value) = [("Value", T.encodeUtf8 value)]- + data ExpectedAttribute = ExpectedValue { expectedAttributeValue :: T.Text } | ExpectedExists { expectedAttributeExists :: Bool } deriving (Show)- + expectedValue :: T.Text -> T.Text -> Attribute ExpectedAttribute expectedValue name value = ForAttribute name (ExpectedValue value) expectedExists :: T.Text -> Bool -> Attribute ExpectedAttribute expectedExists name exists = ForAttribute name (ExpectedExists exists)- + expectedAttributeQuery :: ExpectedAttribute -> [(B.ByteString, B.ByteString)] expectedAttributeQuery (ExpectedValue value) = [("Value", T.encodeUtf8 value)] expectedAttributeQuery (ExpectedExists exists) = [("Exists", awsBool exists)]@@ -73,6 +73,6 @@ 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)] itemQuery f (Item name x) = ("ItemName", T.encodeUtf8 name) : f x
Aws/SimpleDb/Query.hs view
@@ -29,6 +29,7 @@ , sqContentType = Nothing , sqContentMd5 = Nothing , sqAmzHeaders = []+ , sqOtherHeaders = [] , sqBody = Nothing , sqStringToSign = stringToSign }
Aws/SimpleDb/Response.hs view
@@ -8,21 +8,19 @@ import Aws.Xml import Data.IORef import Data.Maybe-import Text.XML.Enumerator.Cursor (($|), ($/), ($//), (&|))+import Text.XML.Cursor (($|), ($/), ($//), (&|)) import qualified Control.Failure as F-import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as Base64-import qualified Data.Enumerator as En import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Network.HTTP.Types as HTTP-import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Network.HTTP.Conduit as HTTP+import qualified Text.XML.Cursor as Cu -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+sdbResponseConsumer :: (Cu.Cursor -> Response SdbMetadata a)+ -> IORef SdbMetadata+ -> HTTP.ResponseConsumer IO a+sdbResponseConsumer inner metadataRef status headers source+ = xmlCursorConsumer parse metadataRef status headers source where parse cursor = do let requestId' = listToMaybe $ cursor $// elContent "RequestID" let boxUsage' = listToMaybe $ cursor $// elContent "BoxUsage"
Aws/Sqs/Commands/AddPermission.hs view
@@ -30,9 +30,9 @@ concat $ zipWith(\ x y -> [(B.pack $ "AwsAccountId." ++ show y, Just $ B.pack $ T.unpack $ fst x), (B.pack $ "ActionName." ++ show y, Just $ B.pack $ T.unpack $ printPermission $ snd x)]) perms [1 :: Integer ..] -instance ResponseIteratee r AddPermissionResponse where+instance ResponseConsumer r AddPermissionResponse where type ResponseMetadata AddPermissionResponse = SqsMetadata- responseIteratee _ = sqsXmlResponseIteratee parse+ responseConsumer _ = sqsXmlResponseConsumer parse where parse _ = do return AddPermissionResponse {}
Aws/Sqs/Commands/ChangeMessageVisibility.hs view
@@ -22,9 +22,9 @@ data ChangeMessageVisibilityResponse = ChangeMessageVisibilityResponse{ } deriving (Show) -instance ResponseIteratee r ChangeMessageVisibilityResponse where+instance ResponseConsumer r ChangeMessageVisibilityResponse where type ResponseMetadata ChangeMessageVisibilityResponse = SqsMetadata- responseIteratee _ = sqsXmlResponseIteratee parse+ responseConsumer _ = sqsXmlResponseConsumer parse where parse _ = do return ChangeMessageVisibilityResponse{}
Aws/Sqs/Commands/CreateQueue.hs view
@@ -12,10 +12,10 @@ import Aws.Xml import Control.Applicative import Data.Maybe-import Text.XML.Enumerator.Cursor (($//), (&/))+import Text.XML.Cursor (($//), (&/)) import qualified Data.Text as T import qualified Data.Text.Encoding as TE-import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Text.XML.Cursor as Cu import qualified Data.ByteString.Char8 as B data CreateQueue = CreateQueue{@@ -28,20 +28,20 @@ } deriving (Show) -instance ResponseIteratee r CreateQueueResponse where+instance ResponseConsumer r CreateQueueResponse where type ResponseMetadata CreateQueueResponse = SqsMetadata- responseIteratee _ = sqsXmlResponseIteratee parse- where - parse el = do + responseConsumer _ = sqsXmlResponseConsumer parse+ where+ parse el = do url <- force "Missing Queue Url" $ el $// Cu.laxElement "QueueUrl" &/ Cu.content return CreateQueueResponse{ cqrQueueUrl = url}- -instance SignQuery CreateQueue where ++instance SignQuery CreateQueue where type Info CreateQueue = SqsInfo signQuery CreateQueue {..} = sqsSignQuery SqsQuery {- sqsQueueName = Nothing, - sqsQuery = [("Action", Just "CreateQueue"), - ("QueueName", Just $ TE.encodeUtf8 cqQueueName)] ++ + sqsQueueName = Nothing,+ sqsQuery = [("Action", Just "CreateQueue"),+ ("QueueName", Just $ TE.encodeUtf8 cqQueueName)] ++ catMaybes [("DefaultVisibilityTimeout",) <$> case cqDefaultVisibilityTimeout of Just x -> Just $ Just $ B.pack $ show x Nothing -> Nothing]}
Aws/Sqs/Commands/DeleteMessage.hs view
@@ -20,9 +20,9 @@ data DeleteMessageResponse = DeleteMessageResponse{ } deriving (Show) -instance ResponseIteratee r DeleteMessageResponse where+instance ResponseConsumer r DeleteMessageResponse where type ResponseMetadata DeleteMessageResponse = SqsMetadata- responseIteratee _ = sqsXmlResponseIteratee parse+ responseConsumer _ = sqsXmlResponseConsumer parse where parse _ = do return DeleteMessageResponse {}
Aws/Sqs/Commands/DeleteQueue.hs view
@@ -18,9 +18,9 @@ data DeleteQueueResponse = DeleteQueueResponse{ } deriving (Show) -instance ResponseIteratee r DeleteQueueResponse where+instance ResponseConsumer r DeleteQueueResponse where type ResponseMetadata DeleteQueueResponse = SqsMetadata- responseIteratee _ = sqsXmlResponseIteratee parse+ responseConsumer _ = sqsXmlResponseConsumer parse where parse _ = do return DeleteQueueResponse{}
Aws/Sqs/Commands/GetQueueAttributes.hs view
@@ -11,9 +11,9 @@ import Aws.Signature import Aws.Transaction import Aws.Xml-import Text.XML.Enumerator.Cursor (($/), ($//), (&/), (&|))+import Text.XML.Cursor (($/), ($//), (&/), (&|)) import qualified Data.Text as T-import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Text.XML.Cursor as Cu import qualified Data.ByteString.Char8 as B data GetQueueAttributes = GetQueueAttributes {@@ -32,25 +32,25 @@ parsedName <- M.parseQueueAttribute name return (parsedName, value) -instance ResponseIteratee r GetQueueAttributesResponse where+instance ResponseConsumer r GetQueueAttributesResponse where type ResponseMetadata GetQueueAttributesResponse = SqsMetadata- responseIteratee _ = sqsXmlResponseIteratee parse+ responseConsumer _ = sqsXmlResponseConsumer parse where parse el = do- let attributes = concat $ el $// Cu.laxElement "Attribute" &| parseAttributes + let attributes = concat $ el $// Cu.laxElement "Attribute" &| parseAttributes return GetQueueAttributesResponse{ gqarAttributes = attributes }- + formatAttributes :: [M.QueueAttribute] -> [(B.ByteString, Maybe B.ByteString)] formatAttributes attrs = case length attrs of 0 -> undefined 1 -> [("AttributeName", Just $ B.pack $ T.unpack $ M.printQueueAttribute $ attrs !! 0)] _ -> zipWith (\ x y -> ((B.concat ["AttributeName.", B.pack $ show $ y]), Just $ B.pack $ T.unpack $ M.printQueueAttribute x) ) attrs [1 :: Integer ..]- -instance SignQuery GetQueueAttributes where ++instance SignQuery GetQueueAttributes where type Info GetQueueAttributes = SqsInfo- signQuery GetQueueAttributes{..} = sqsSignQuery SqsQuery { - sqsQueueName = Just gqaQueueName, + signQuery GetQueueAttributes{..} = sqsSignQuery SqsQuery {+ sqsQueueName = Just gqaQueueName, sqsQuery = [("Action", Just "GetQueueAttributes")] ++ (formatAttributes gqaAttributes)} instance Transaction GetQueueAttributes GetQueueAttributesResponse
Aws/Sqs/Commands/ListQueues.hs view
@@ -11,10 +11,10 @@ import Aws.Transaction import Control.Applicative import Data.Maybe-import Text.XML.Enumerator.Cursor (($//), (&/))+import Text.XML.Cursor (($//), (&/)) import qualified Data.Text as T import qualified Data.Text.Encoding as TE-import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Text.XML.Cursor as Cu data ListQueues = ListQueues { lqQueueNamePrefix :: Maybe T.Text@@ -24,18 +24,18 @@ lqrQueueUrls :: [T.Text] } deriving (Show) -instance ResponseIteratee r ListQueuesResponse where+instance ResponseConsumer r ListQueuesResponse where type ResponseMetadata ListQueuesResponse = SqsMetadata- responseIteratee _ = sqsXmlResponseIteratee parse+ responseConsumer _ = sqsXmlResponseConsumer parse where- parse el = do + parse el = do let queues = el $// Cu.laxElement "QueueUrl" &/ Cu.content return ListQueuesResponse { lqrQueueUrls = queues }- -instance SignQuery ListQueues where ++instance SignQuery ListQueues where type Info ListQueues = SqsInfo- signQuery ListQueues{..} = sqsSignQuery SqsQuery { - sqsQueueName = Nothing, + signQuery ListQueues{..} = sqsSignQuery SqsQuery {+ sqsQueueName = Nothing, sqsQuery = [("Action", Just "ListQueues")] ++ catMaybes [ ("QueueNamePrefix",) <$> case lqQueueNamePrefix of Just x -> Just $ Just $ TE.encodeUtf8 x
Aws/Sqs/Commands/ReceiveMessage.hs view
@@ -12,15 +12,15 @@ import Aws.Xml import Control.Applicative import Data.Maybe-import Text.XML.Enumerator.Cursor (($/), ($//), (&/), (&|))+import Text.XML.Cursor (($/), ($//), (&/), (&|)) import qualified Aws.Sqs.Model as M import qualified Control.Failure as F import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE-import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Text.XML.Cursor as Cu -data ReceiveMessage +data ReceiveMessage = ReceiveMessage { rmVisibilityTimeout :: Maybe Int , rmAttributes :: [M.MessageAttribute]@@ -59,7 +59,7 @@ md5 <- force "Missing MD5 Signature" $ cursor $// Cu.laxElement "MD5OfBody" &/ Cu.content body <- force "Missing Body" $ cursor $// Cu.laxElement "Body" &/ Cu.content let attributes :: [(M.MessageAttribute, T.Text)] = concat $ cursor $// Cu.laxElement "Attribute" &| readMessageAttribute- + return Message{ mMessageId = mid, mReceiptHandle = M.ReceiptHandle rh, mMD5OfBody = md5, mBody = body, mAttributes = attributes} formatMAttributes :: [M.MessageAttribute] -> [(B.ByteString, Maybe B.ByteString)]@@ -69,19 +69,19 @@ 1 -> [("AttributeName", Just $ B.pack $ show $ attrs !! 0)] _ -> zipWith (\ x y -> ((B.concat ["AttributeName.", B.pack $ show $ y]), Just $ TE.encodeUtf8 $ M.printMessageAttribute x) ) attrs [1 :: Integer ..] -instance ResponseIteratee r ReceiveMessageResponse where+instance ResponseConsumer r ReceiveMessageResponse where type ResponseMetadata ReceiveMessageResponse = SqsMetadata- responseIteratee _ = sqsXmlResponseIteratee parse- where + responseConsumer _ = sqsXmlResponseConsumer parse+ where parse el = do let messages = concat $ el $// Cu.laxElement "Message" &| readMessage return ReceiveMessageResponse{ rmrMessages = messages }- -instance SignQuery ReceiveMessage where ++instance SignQuery ReceiveMessage where type Info ReceiveMessage = SqsInfo signQuery ReceiveMessage {..} = sqsSignQuery SqsQuery {- sqsQueueName = Just rmQueueName, - sqsQuery = [("Action", Just "ReceiveMessage")] ++ + sqsQueueName = Just rmQueueName,+ sqsQuery = [("Action", Just "ReceiveMessage")] ++ catMaybes[("VisibilityTimeout",) <$> case rmVisibilityTimeout of Just x -> Just $ Just $ B.pack $ show x Nothing -> Nothing,
Aws/Sqs/Commands/RemovePermission.hs view
@@ -21,9 +21,9 @@ data RemovePermissionResponse = RemovePermissionResponse{ } deriving (Show) -instance ResponseIteratee r RemovePermissionResponse where+instance ResponseConsumer r RemovePermissionResponse where type ResponseMetadata RemovePermissionResponse = SqsMetadata- responseIteratee _ = sqsXmlResponseIteratee parse+ responseConsumer _ = sqsXmlResponseConsumer parse where parse _ = do return RemovePermissionResponse {}
Aws/Sqs/Commands/SendMessage.hs view
@@ -11,14 +11,14 @@ import Aws.Signature import Aws.Transaction import Aws.Xml-import Text.XML.Enumerator.Cursor (($//), (&/))+import Text.XML.Cursor (($//), (&/)) import qualified Data.Text as T import qualified Data.Text.Encoding as TE-import qualified Text.XML.Enumerator.Cursor as Cu+import qualified Text.XML.Cursor as Cu data SendMessage = SendMessage{ smMessage :: T.Text,- smQueueName :: M.QueueName + smQueueName :: M.QueueName }deriving (Show) data SendMessageResponse = SendMessageResponse{@@ -26,21 +26,21 @@ smrMessageId :: M.MessageId } deriving (Show) -instance ResponseIteratee r SendMessageResponse where+instance ResponseConsumer r SendMessageResponse where type ResponseMetadata SendMessageResponse = SqsMetadata- responseIteratee _ = sqsXmlResponseIteratee parse- where + responseConsumer _ = sqsXmlResponseConsumer parse+ where parse el = do md5 <- force "Missing MD5 Signature" $ el $// Cu.laxElement "MD5OfMessageBody" &/ Cu.content mid <- force "Missing Message Id" $ el $// Cu.laxElement "MessageId" &/ Cu.content return SendMessageResponse { smrMD5OfMessageBody = md5, smrMessageId = M.MessageId mid } -instance SignQuery SendMessage where +instance SignQuery SendMessage where type Info SendMessage = SqsInfo signQuery SendMessage {..} = sqsSignQuery SqsQuery { sqsQueueName = Just smQueueName,- sqsQuery = [("Action", Just "SendMessage"), - ("MessageBody", Just $ TE.encodeUtf8 smMessage )]} + sqsQuery = [("Action", Just "SendMessage"),+ ("MessageBody", Just $ TE.encodeUtf8 smMessage )]} instance Transaction SendMessage SendMessageResponse
Aws/Sqs/Commands/SetQueueAttributes.hs view
@@ -22,9 +22,9 @@ data SetQueueAttributesResponse = SetQueueAttributesResponse{ } deriving (Show) -instance ResponseIteratee r SetQueueAttributesResponse where+instance ResponseConsumer r SetQueueAttributesResponse where type ResponseMetadata SetQueueAttributesResponse = SqsMetadata- responseIteratee _ = sqsXmlResponseIteratee parse+ responseConsumer _ = sqsXmlResponseConsumer parse where parse _ = do return SetQueueAttributesResponse {}
Aws/Sqs/Query.hs view
@@ -40,6 +40,7 @@ , sqContentType = Nothing , sqContentMd5 = Nothing , sqAmzHeaders = []+ , sqOtherHeaders = [] } where method = PostQuery
Aws/Sqs/Response.hs view
@@ -7,55 +7,52 @@ import Aws.Xml import Control.Monad.IO.Class import Data.Attempt (Attempt(..))-import Data.Enumerator ((=$))+import Data.Conduit (($$)) import Data.IORef import Data.Maybe-import Text.XML.Enumerator.Cursor (($/))-import qualified Data.ByteString as B-import qualified Data.Enumerator as En+import Text.XML.Cursor (($/))+import qualified Data.Conduit as C import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Conduit as HTTP 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+import qualified Text.XML.Cursor as Cu+import qualified Text.XML as XML -sqsResponseIteratee ::- (HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a)- -> IORef SqsMetadata- -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a-sqsResponseIteratee inner metadata status headers = do+sqsResponseConsumer :: HTTP.ResponseConsumer IO a+ -> IORef SqsMetadata+ -> HTTP.ResponseConsumer IO a+sqsResponseConsumer inner metadata status headers source = do let headerString = fmap T.decodeUtf8 . flip lookup headers let amzId2 = headerString "x-amz-id-2" let requestId = headerString "x-amz-request-id"- + let m = SqsMetadata { sqsMAmzId2 = amzId2, sqsMRequestId = requestId } liftIO $ tellMetadataRef metadata m- + if status >= HTTP.status400- then sqsErrorResponseIteratee status headers- else inner status headers+ then sqsErrorResponseConsumer status headers source+ else inner status headers source -sqsXmlResponseIteratee :: - (Cu.Cursor -> Response SqsMetadata a)- -> IORef SqsMetadata- -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a-sqsXmlResponseIteratee parse metadataRef = sqsResponseIteratee (xmlCursorIteratee parse metadataRef) metadataRef+sqsXmlResponseConsumer :: (Cu.Cursor -> Response SqsMetadata a)+ -> IORef SqsMetadata+ -> HTTP.ResponseConsumer IO a+sqsXmlResponseConsumer parse metadataRef = sqsResponseConsumer (xmlCursorConsumer parse metadataRef) metadataRef -sqsErrorResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a-sqsErrorResponseIteratee status _headers - = do doc <- XML.parseBytes XML.decodeEntities =$ XML.fromEvents+sqsErrorResponseConsumer :: HTTP.ResponseConsumer IO a+sqsErrorResponseConsumer status _headers source+ = do doc <- source $$ XML.sinkDoc XML.def let cursor = Cu.fromDocument doc- case parseError cursor of- Success err -> En.throwError err- Failure otherErr -> En.throwError otherErr+ liftIO $ case parseError cursor of+ Success err -> C.resourceThrow err+ Failure otherErr -> C.resourceThrow otherErr where parseError :: Cu.Cursor -> Attempt SqsError- parseError root = do cursor <- force "Missing Error" $ root $/ Cu.laxElement "Error" + parseError root = do cursor <- force "Missing Error" $ root $/ Cu.laxElement "Error" code <- force "Missing error Code" $ cursor $/ elContent "Code" message <- force "Missing error Message" $ cursor $/ elContent "Message" errorType <- force "Missing error Type" $ cursor $/ elContent "Type" let detail = listToMaybe $ cursor $/ elContent "Detail"- + return SqsError { sqsStatusCode = status , sqsErrorCode = code
Aws/Transaction.hs view
@@ -6,5 +6,5 @@ import Aws.Signature import Data.Monoid -class (SignQuery r, ResponseIteratee r a, Monoid (ResponseMetadata a))+class (SignQuery r, ResponseConsumer r a, Monoid (ResponseMetadata a)) => Transaction r a | r -> a, a -> r
Aws/Util.hs view
@@ -2,7 +2,7 @@ module Aws.Util where- + import Control.Arrow import Control.Exception import Data.ByteString.Char8 ({- IsString -})@@ -10,15 +10,13 @@ import Data.Time import Data.Word import System.Locale+import qualified Control.Exception.Lifted import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BU-import qualified Data.Enumerator as En+import qualified Data.Conduit as C -tryError :: (Exception e, Monad m) => En.Iteratee a m b -> En.Iteratee a m (Either e b)-tryError m = En.catchError (fmap Right m) h- where h e = case fromException e of- Just v -> return $ Left v- Nothing -> En.throwError e+tryError :: (Exception e, C.ResourceIO m) => m b -> m (Either e b)+tryError = Control.Exception.Lifted.try queryList :: (a -> [(B.ByteString, B.ByteString)]) -> B.ByteString -> [a] -> [(B.ByteString, B.ByteString)] queryList f prefix xs = concat $ zipWith combine prefixList (map f xs)@@ -52,7 +50,7 @@ readHex2 [c1,c2] = do n1 <- readHex1 c1 n2 <- readHex1 c2 return . fromIntegral $ n1 * 16 + n2- where + where 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
Aws/Xml.hs view
@@ -1,29 +1,27 @@ {-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} module Aws.Xml where- + import Aws.Response import Control.Monad.IO.Class import Data.Attempt (Attempt(..))-import Data.Enumerator ((=$))+import Data.Conduit (($$)) import Data.IORef import Data.Monoid import Data.Typeable-import Text.XML.Enumerator.Cursor-import qualified Control.Exception as C+import Text.XML.Cursor+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 Data.Conduit as C 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+import qualified Network.HTTP.Conduit as HTTP+import qualified Text.XML.Cursor as Cu+import qualified Text.XML as XML newtype XmlException = XmlException { xmlErrorMessage :: String } deriving (Show, Typeable) -instance C.Exception XmlException+instance E.Exception XmlException elContent :: T.Text -> Cursor -> [T.Text] elContent name = laxElement name &/ content@@ -47,18 +45,16 @@ [(n,"")] -> return $ fromInteger n _ -> F.failure $ XmlException "Invalid Integer" -xmlCursorIteratee ::+xmlCursorConsumer :: (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+ -> HTTP.ResponseConsumer IO a+xmlCursorConsumer parse metadataRef _status _headers source+ = do doc <- source $$ XML.sinkDoc XML.def 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+ case x of+ Failure err -> liftIO $ C.resourceThrow 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.6+Version: 0.1 -- A short (one-line) description of the package. Synopsis: Amazon Web Services (AWS) for Haskell@@ -110,41 +110,39 @@ Aws.Transaction, 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.*,- case-insensitive >=0.2 && <0.3,- cereal ==0.3.*,- containers >=0.3 && <0.5,- 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.6.7 && < 0.7,- http-types >=0.6 && <0.7,- mtl ==2.*,- old-locale ==1.*,- shortcircuit ==0.1.*,- text >= 0.11,- time >=1.1.4 && <1.3,- tls >= 0.7.1,- transformers >=0.2.2.0 && <0.3,- transformers-compose ==0.1.*,- utf8-string ==0.3.*,- xml-enumerator >= 0.3.4+ 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.*,+ case-insensitive >= 0.2 && < 0.5,+ cereal == 0.3.*,+ conduit >= 0.0 && < 0.1,+ crypto-api >= 0.5 && < 0.9,+ cryptohash >= 0.6 && < 0.8,+ directory >= 1.0 && < 1.2,+ failure >= 0.1.0.1 && < 0.2,+ filepath >= 1.1 && < 1.3,+ http-conduit >= 1.0 && < 1.1,+ http-types >= 0.6 && < 0.7,+ lifted-base == 0.1.*,+ mtl == 2.*,+ old-locale == 1.*,+ shortcircuit == 0.1.*,+ text >= 0.11,+ time >= 1.1.4 && < 1.3,+ tls >= 0.7.1,+ transformers >= 0.2.2.0 && < 0.3,+ utf8-string == 0.3.*,+ xml-conduit >= 0.5.0 GHC-Options: -Wall- + -- Modules not exported by this package.- -- Other-modules: - + -- Other-modules:+ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.- -- Build-tools: - + -- Build-tools:+