diff --git a/Aws/Aws.hs b/Aws/Aws.hs --- a/Aws/Aws.hs +++ b/Aws/Aws.hs @@ -10,6 +10,7 @@ import Aws.S3.Info import Aws.Signature import Aws.SimpleDb.Info +import Aws.Sqs.Info import Aws.Transaction import Control.Applicative import Data.Attempt (attemptIO) @@ -28,6 +29,8 @@ , sdbInfoUri :: SdbInfo , s3Info :: S3Info , s3InfoUri :: S3Info + , sqsInfo :: SqsInfo + , sqsInfoUri :: SqsInfo } class ConfigurationFetch a where @@ -46,6 +49,10 @@ configurationFetch = s3Info configurationFetchUri = s3InfoUri +instance ConfigurationFetch SqsInfo where + configurationFetch = sqsInfo + configurationFetchUri = sqsInfoUri + baseConfiguration :: IO Configuration baseConfiguration = do Just cr <- loadCredentialsDefault @@ -56,6 +63,8 @@ , sdbInfoUri = sdbHttpsGet sdbUsEast , s3Info = s3 HTTP s3EndpointUsClassic False , s3InfoUri = s3 HTTP s3EndpointUsClassic True + , sqsInfo = sqs HTTP sqsEndpointUsClassic False + , sqsInfoUri = sqs HTTP sqsEndpointUsClassic True } -- TODO: better error handling when credentials cannot be loaded @@ -70,7 +79,7 @@ aws = unsafeAws unsafeAws - :: (ResponseIteratee a, + :: (ResponseIteratee r a, Monoid (ResponseMetadata a), SignQuery r, ConfigurationFetch (Info r)) => @@ -83,7 +92,7 @@ let httpRequest = queryToHttpRequest q metadataRef <- newIORef mempty resp <- attemptIO (id :: E.SomeException -> E.SomeException) $ - HTTP.withManager $ En.run_ . HTTP.httpRedirect httpRequest (responseIteratee metadataRef) + HTTP.withManager $ En.run_ . HTTP.httpRedirect httpRequest (responseIteratee request metadataRef) metadata <- readIORef metadataRef return $ Response metadata resp @@ -98,3 +107,4 @@ let q = signQuery request info sd debugPrint "String to sign" $ sqStringToSign q return $ queryToUri q + diff --git a/Aws/Http.hs b/Aws/Http.hs --- a/Aws/Http.hs +++ b/Aws/Http.hs @@ -19,6 +19,7 @@ | PostQuery | Post | Put + | Delete deriving (Show, Eq) httpMethod :: Method -> HTTP.Method @@ -26,3 +27,4 @@ httpMethod PostQuery = "POST" httpMethod Post = "POST" httpMethod Put = "PUT" +httpMethod Delete = "DELETE" diff --git a/Aws/Query.hs b/Aws/Query.hs --- a/Aws/Query.hs +++ b/Aws/Query.hs @@ -57,6 +57,7 @@ Just x -> x , HTTP.proxy = Nothing , HTTP.rawBody = False + , HTTP.decompress = HTTP.alwaysDecompress } where contentType = case sqMethod of PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8" diff --git a/Aws/Response.hs b/Aws/Response.hs --- a/Aws/Response.hs +++ b/Aws/Response.hs @@ -31,10 +31,10 @@ tellMetadataRef :: Monoid m => IORef m -> m -> IO () tellMetadataRef r m = modifyIORef r (`mappend` m) -class ResponseIteratee a where +class ResponseIteratee r a where type ResponseMetadata a - responseIteratee :: IORef (ResponseMetadata a) -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a + responseIteratee :: r -> IORef (ResponseMetadata a) -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a -instance ResponseIteratee HTTP.Response where +instance ResponseIteratee r HTTP.Response where type ResponseMetadata HTTP.Response = () - responseIteratee _ = HTTP.lbsIter + responseIteratee _ _ = HTTP.lbsIter diff --git a/Aws/S3/Commands.hs b/Aws/S3/Commands.hs --- a/Aws/S3/Commands.hs +++ b/Aws/S3/Commands.hs @@ -1,11 +1,17 @@ module Aws.S3.Commands ( - module Aws.S3.Commands.GetBucket + module Aws.S3.Commands.DeleteObject +, module Aws.S3.Commands.GetBucket +, module Aws.S3.Commands.GetObject , module Aws.S3.Commands.GetService , module Aws.S3.Commands.PutBucket +, module Aws.S3.Commands.PutObject ) where +import Aws.S3.Commands.DeleteObject import Aws.S3.Commands.GetBucket +import Aws.S3.Commands.GetObject import Aws.S3.Commands.GetService import Aws.S3.Commands.PutBucket +import Aws.S3.Commands.PutObject diff --git a/Aws/S3/Commands/DeleteObject.hs b/Aws/S3/Commands/DeleteObject.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/DeleteObject.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TypeFamilies, RecordWildCards, TupleSections, OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, GADTs, RankNTypes #-} +module Aws.S3.Commands.DeleteObject +where + +import Aws.Http +import Aws.Response +import Aws.S3.Info +import Aws.S3.Metadata +import Aws.S3.Model +import Aws.S3.Query +import Aws.Signature +import Aws.Transaction +import Data.ByteString.Char8 ({- IsString -}) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +data DeleteObject = DeleteObject { + doObjectName :: T.Text, + doBucket :: Bucket +} + +data DeleteObjectResponse = DeleteObjectResponse{ +} + +instance SignQuery DeleteObject where + type Info DeleteObject = S3Info + signQuery DeleteObject {..} = s3SignQuery S3Query { + s3QMethod = Delete + , s3QBucket = Just $ T.encodeUtf8 doBucket + , s3QSubresources = [] + , s3QQuery = [] + , s3QAmzHeaders = [] + , s3QRequestBody = Nothing + , s3QObject = Just $ T.encodeUtf8 doObjectName + } + +instance ResponseIteratee DeleteObject DeleteObjectResponse where + type ResponseMetadata DeleteObjectResponse = S3Metadata + responseIteratee _ _ _ _ = return DeleteObjectResponse + + +instance Transaction DeleteObject DeleteObjectResponse + diff --git a/Aws/S3/Commands/GetBucket.hs b/Aws/S3/Commands/GetBucket.hs --- a/Aws/S3/Commands/GetBucket.hs +++ b/Aws/S3/Commands/GetBucket.hs @@ -60,6 +60,7 @@ signQuery GetBucket {..} = s3SignQuery S3Query { s3QMethod = Get , s3QBucket = Just $ T.encodeUtf8 gbBucket + , s3QObject = Nothing , s3QSubresources = [] , s3QQuery = HTTP.simpleQueryToQuery $ map (second T.encodeUtf8) $ catMaybes [ ("delimiter",) <$> gbDelimiter @@ -71,10 +72,10 @@ , s3QRequestBody = Nothing } -instance ResponseIteratee GetBucketResponse where +instance ResponseIteratee r GetBucketResponse where type ResponseMetadata GetBucketResponse = S3Metadata - responseIteratee = s3XmlResponseIteratee parse + responseIteratee _ = s3XmlResponseIteratee parse where parse cursor = do name <- force "Missing Name" $ cursor $/ elContent "Name" let delimiter = listToMaybe $ cursor $/ elContent "Delimiter" diff --git a/Aws/S3/Commands/GetObject.hs b/Aws/S3/Commands/GetObject.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/GetObject.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE TypeFamilies, RecordWildCards, TupleSections, OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, GADTs, RankNTypes #-} +module Aws.S3.Commands.GetObject +where + +import Aws.Http +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 Control.Applicative +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.Types as HTTP + +data GetObject a + = GetObject { + goBucket :: Bucket + , goObjectName :: Object + , goResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a + , goResponseContentType :: Maybe T.Text + , goResponseContentLanguage :: Maybe T.Text + , goResponseExpires :: Maybe T.Text + , goResponseCacheControl :: Maybe T.Text + , goResponseContentDisposition :: Maybe T.Text + , goResponseContentEncoding :: Maybe T.Text + } + +getObject :: Bucket -> T.Text -> (HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a) -> GetObject a +getObject b o i = GetObject b o i Nothing Nothing Nothing Nothing Nothing Nothing + +data GetObjectResponse a + = GetObjectResponse a + deriving (Show) + +instance SignQuery (GetObject a) where + type Info (GetObject a) = S3Info + signQuery GetObject {..} = s3SignQuery S3Query { + s3QMethod = Get + , s3QBucket = Just $ T.encodeUtf8 goBucket + , s3QObject = Just $ T.encodeUtf8 goObjectName + , s3QSubresources = [] + , s3QQuery = HTTP.simpleQueryToQuery $ map (second T.encodeUtf8) $ catMaybes [ + ("response-content-type",) <$> goResponseContentType + , ("response-content-language",) <$> goResponseContentLanguage + , ("response-expires",) <$> goResponseExpires + , ("response-cache-control",) <$> goResponseCacheControl + , ("response-content-disposition",) <$> goResponseContentDisposition + , ("response-content-encoding",) <$> goResponseContentEncoding + ] + , s3QAmzHeaders = [] + , s3QRequestBody = Nothing + } + +instance ResponseIteratee (GetObject a) (GetObjectResponse a) where + type ResponseMetadata (GetObjectResponse a) = S3Metadata + responseIteratee GetObject{..} metadata status headers + = GetObjectResponse <$> s3BinaryResponseIteratee (goResponseIteratee) metadata status headers + +instance Transaction (GetObject a) (GetObjectResponse a) diff --git a/Aws/S3/Commands/GetService.hs b/Aws/S3/Commands/GetService.hs --- a/Aws/S3/Commands/GetService.hs +++ b/Aws/S3/Commands/GetService.hs @@ -28,10 +28,10 @@ } deriving (Show) -instance ResponseIteratee GetServiceResponse where +instance ResponseIteratee r GetServiceResponse where type ResponseMetadata GetServiceResponse = S3Metadata - responseIteratee = s3XmlResponseIteratee parse + responseIteratee _ = s3XmlResponseIteratee parse where parse el = do owner <- forceM "Missing Owner" $ el $/ Cu.laxElement "Owner" &| parseUserInfo @@ -49,6 +49,7 @@ signQuery GetService = s3SignQuery S3Query { s3QMethod = Get , s3QBucket = Nothing + , s3QObject = Nothing , s3QSubresources = [] , s3QQuery = [] , s3QAmzHeaders = [] diff --git a/Aws/S3/Commands/PutBucket.hs b/Aws/S3/Commands/PutBucket.hs --- a/Aws/S3/Commands/PutBucket.hs +++ b/Aws/S3/Commands/PutBucket.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, TypeFamilies, OverloadedStrings, MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards, TypeFamilies, OverloadedStrings, MultiParamTypeClasses, FlexibleInstances #-} module Aws.S3.Commands.PutBucket where import Aws.Http @@ -36,6 +36,7 @@ , s3QBucket = Just $ T.encodeUtf8 pbBucket , s3QSubresources = [] , s3QQuery = [] + , s3QObject = Nothing , s3QAmzHeaders = case pbCannedAcl of Nothing -> [] Just acl -> [("x-amz-acl", T.encodeUtf8 $ writeCannedAcl acl)] @@ -60,10 +61,10 @@ ] } -instance ResponseIteratee PutBucketResponse where +instance ResponseIteratee r PutBucketResponse where type ResponseMetadata PutBucketResponse = S3Metadata - responseIteratee = s3ResponseIteratee inner + responseIteratee _ = s3ResponseIteratee inner where inner _status _headers = return PutBucketResponse instance Transaction PutBucket PutBucketResponse diff --git a/Aws/S3/Commands/PutObject.hs b/Aws/S3/Commands/PutObject.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/PutObject.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE TypeFamilies, RecordWildCards, TupleSections, OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, GADTs, RankNTypes #-} +module Aws.S3.Commands.PutObject +where + +import Aws.Http +import Aws.Response +import Aws.S3.Info +import Aws.S3.Metadata +import Aws.S3.Model +import Aws.S3.Query +import Aws.Signature +import Aws.Transaction +import Control.Applicative +import Control.Arrow (second) +import Data.ByteString.Char8 ({- IsString -}) +import Data.Maybe +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 + +data PutObject = PutObject { + poObjectName :: T.Text, + poBucket :: Bucket, + poContentType :: Maybe T.Text, + poCacheControl :: Maybe T.Text, + poContentDisposition :: Maybe T.Text, + poContentEncoding :: Maybe T.Text, + poContentMD5 :: Maybe T.Text, + poExpires :: Maybe Int, + poAcl :: Maybe CannedAcl, + poStorageClass :: Maybe StorageClass, + poRequestBody :: HTTP.RequestBody IO, + poMetadata :: [(T.Text,T.Text)] +} + +data PutObjectResponse = PutObjectResponse{ + porVersionId :: Maybe T.Text +} + +instance SignQuery PutObject where + type Info PutObject = S3Info + 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 + , ("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 + type ResponseMetadata PutObjectResponse = S3Metadata + responseIteratee _ _ _ _ = do return $ PutObjectResponse Nothing + +instance Transaction PutObject PutObjectResponse + diff --git a/Aws/S3/Model.hs b/Aws/S3/Model.hs --- a/Aws/S3/Model.hs +++ b/Aws/S3/Model.hs @@ -43,6 +43,20 @@ writeCannedAcl AclBucketOwnerFullControl = "bucket-owner-full-control" writeCannedAcl AclLogDeliveryWrite = "log-delivery-write" +data StorageClass + = Standard + | ReducedRedundancy + deriving (Show) + +parseStorageClass :: F.Failure XmlException m => T.Text -> m StorageClass +parseStorageClass "STANDARD" = return Standard +parseStorageClass "REDUCED_REDUNDANCY" = return ReducedRedundancy +parseStorageClass s = F.failure . XmlException $ "Invalid Storage Class: " ++ T.unpack s + +writeStorageClass :: StorageClass -> T.Text +writeStorageClass Standard = "STANDARD" +writeStorageClass ReducedRedundancy = "REDUCED_REDUNDANCY" + type Bucket = T.Text data BucketInfo @@ -52,13 +66,15 @@ } deriving (Show) +type Object = T.Text + data ObjectInfo = ObjectInfo { objectKey :: T.Text , objectLastModified :: UTCTime , objectETag :: T.Text , objectSize :: Integer - , objectStorageClass :: T.Text + , objectStorageClass :: StorageClass , objectOwner :: UserInfo } deriving (Show) @@ -69,10 +85,10 @@ let time s = case parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ T.unpack s of Nothing -> F.failure $ XmlException "Invalid time" Just v -> return v - lastModified <- forceM "Missing object LastModified" $ el $/ Cu.laxElement "LastModified" >=> Cu.content &| time + lastModified <- forceM "Missing object LastModified" $ el $/ elContent "LastModified" &| time eTag <- force "Missing object ETag" $ el $/ elContent "ETag" size <- forceM "Missing object Size" $ el $/ elContent "Size" &| textReadInt - storageClass <- force "Missing object StorageClass" $ el $/ elContent "StorageClass" + storageClass <- forceM "Missing object StorageClass" $ el $/ elContent "StorageClass" &| parseStorageClass owner <- forceM "Missing object Owner" $ el $/ Cu.laxElement "Owner" &| parseUserInfo return ObjectInfo{ objectKey = key diff --git a/Aws/S3/Query.hs b/Aws/S3/Query.hs --- a/Aws/S3/Query.hs +++ b/Aws/S3/Query.hs @@ -26,6 +26,7 @@ = S3Query { s3QMethod :: Method , s3QBucket :: Maybe B.ByteString + , s3QObject :: Maybe B.ByteString , s3QSubresources :: HTTP.Query , s3QQuery :: HTTP.Query , s3QAmzHeaders :: HTTP.RequestHeaders @@ -66,13 +67,15 @@ then (k1, B8.intercalate "," [v1, v2]):merge xs else x1:x2:merge xs merge xs = xs + (host, path) = case s3RequestStyle of - PathStyle -> ([Just s3Endpoint], [Just "/", fmap (`B8.snoc` '/') s3QBucket]) - BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just "/"]) - VHostStyle -> ([Just $ fromMaybe s3Endpoint s3QBucket], [Just "/"]) + PathStyle -> ([Just s3Endpoint], [Just "/", fmap (`B8.snoc` '/') s3QBucket, s3QObject]) + BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just "/", s3QObject]) + VHostStyle -> ([Just $ fromMaybe s3Endpoint s3QBucket], [Just "/", s3QObject]) sortedSubresources = sort s3QSubresources canonicalizedResource = Blaze8.fromChar '/' `mappend` maybe mempty (\s -> Blaze.copyByteString s `mappend` Blaze8.fromChar '/') s3QBucket `mappend` + maybe mempty Blaze.copyByteString s3QObject `mappend` HTTP.renderQueryBuilder True sortedSubresources ti = case (s3UseUri, signatureTimeInfo) of (False, ti') -> ti' diff --git a/Aws/S3/Response.hs b/Aws/S3/Response.hs --- a/Aws/S3/Response.hs +++ b/Aws/S3/Response.hs @@ -1,18 +1,17 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, RecordWildCards, TypeFamilies #-} +{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, RecordWildCards, TypeFamilies, RankNTypes #-} module Aws.S3.Response where import Aws.Response import Aws.S3.Error import Aws.S3.Metadata +import Aws.Util 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.Enumerator.Cursor (($/)) import qualified Data.ByteString as B import qualified Data.Enumerator as En @@ -44,6 +43,12 @@ -> HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a s3XmlResponseIteratee parse metadataRef = s3ResponseIteratee (xmlCursorIteratee 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 + s3ErrorResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a s3ErrorResponseIteratee status _headers = do doc <- XML.parseBytes XML.decodeEntities =$ XML.fromEvents @@ -70,13 +75,3 @@ , 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 diff --git a/Aws/SimpleDb/Commands/BatchDeleteAttributes.hs b/Aws/SimpleDb/Commands/BatchDeleteAttributes.hs --- a/Aws/SimpleDb/Commands/BatchDeleteAttributes.hs +++ b/Aws/SimpleDb/Commands/BatchDeleteAttributes.hs @@ -36,8 +36,8 @@ , ("DomainName", T.encodeUtf8 bdaDomainName)] ++ queryList (itemQuery $ queryList (attributeQuery deleteAttributeQuery) "Attribute") "Item" bdaItems -instance ResponseIteratee BatchDeleteAttributesResponse where +instance ResponseIteratee r BatchDeleteAttributesResponse where type ResponseMetadata BatchDeleteAttributesResponse = SdbMetadata - responseIteratee = sdbResponseIteratee $ sdbCheckResponseType BatchDeleteAttributesResponse "BatchDeleteAttributesResponse" + responseIteratee _ = sdbResponseIteratee $ sdbCheckResponseType BatchDeleteAttributesResponse "BatchDeleteAttributesResponse" instance Transaction BatchDeleteAttributes BatchDeleteAttributesResponse diff --git a/Aws/SimpleDb/Commands/BatchPutAttributes.hs b/Aws/SimpleDb/Commands/BatchPutAttributes.hs --- a/Aws/SimpleDb/Commands/BatchPutAttributes.hs +++ b/Aws/SimpleDb/Commands/BatchPutAttributes.hs @@ -36,8 +36,8 @@ , ("DomainName", T.encodeUtf8 bpaDomainName)] ++ queryList (itemQuery $ queryList (attributeQuery setAttributeQuery) "Attribute") "Item" bpaItems -instance ResponseIteratee BatchPutAttributesResponse where +instance ResponseIteratee r BatchPutAttributesResponse where type ResponseMetadata BatchPutAttributesResponse = SdbMetadata - responseIteratee = sdbResponseIteratee $ sdbCheckResponseType BatchPutAttributesResponse "BatchPutAttributesResponse" + responseIteratee _ = sdbResponseIteratee $ sdbCheckResponseType BatchPutAttributesResponse "BatchPutAttributesResponse" instance Transaction BatchPutAttributes BatchPutAttributesResponse diff --git a/Aws/SimpleDb/Commands/CreateDomain.hs b/Aws/SimpleDb/Commands/CreateDomain.hs --- a/Aws/SimpleDb/Commands/CreateDomain.hs +++ b/Aws/SimpleDb/Commands/CreateDomain.hs @@ -29,8 +29,8 @@ type Info CreateDomain = SdbInfo signQuery CreateDomain{..} = sdbSignQuery [("Action", "CreateDomain"), ("DomainName", T.encodeUtf8 cdDomainName)] -instance ResponseIteratee CreateDomainResponse where +instance ResponseIteratee r CreateDomainResponse where type ResponseMetadata CreateDomainResponse = SdbMetadata - responseIteratee = sdbResponseIteratee $ sdbCheckResponseType CreateDomainResponse "CreateDomainResponse" + responseIteratee _ = sdbResponseIteratee $ sdbCheckResponseType CreateDomainResponse "CreateDomainResponse" instance Transaction CreateDomain CreateDomainResponse diff --git a/Aws/SimpleDb/Commands/DeleteAttributes.hs b/Aws/SimpleDb/Commands/DeleteAttributes.hs --- a/Aws/SimpleDb/Commands/DeleteAttributes.hs +++ b/Aws/SimpleDb/Commands/DeleteAttributes.hs @@ -43,8 +43,8 @@ queryList (attributeQuery deleteAttributeQuery) "Attribute" daAttributes ++ queryList (attributeQuery expectedAttributeQuery) "Expected" daExpected -instance ResponseIteratee DeleteAttributesResponse where +instance ResponseIteratee r DeleteAttributesResponse where type ResponseMetadata DeleteAttributesResponse = SdbMetadata - responseIteratee = sdbResponseIteratee $ sdbCheckResponseType DeleteAttributesResponse "DeleteAttributesResponse" + responseIteratee _ = sdbResponseIteratee $ sdbCheckResponseType DeleteAttributesResponse "DeleteAttributesResponse" instance Transaction DeleteAttributes DeleteAttributesResponse diff --git a/Aws/SimpleDb/Commands/DeleteDomain.hs b/Aws/SimpleDb/Commands/DeleteDomain.hs --- a/Aws/SimpleDb/Commands/DeleteDomain.hs +++ b/Aws/SimpleDb/Commands/DeleteDomain.hs @@ -29,8 +29,8 @@ type Info DeleteDomain = SdbInfo signQuery DeleteDomain{..} = sdbSignQuery [("Action", "DeleteDomain"), ("DomainName", T.encodeUtf8 ddDomainName)] -instance ResponseIteratee DeleteDomainResponse where +instance ResponseIteratee r DeleteDomainResponse where type ResponseMetadata DeleteDomainResponse = SdbMetadata - responseIteratee = sdbResponseIteratee $ sdbCheckResponseType DeleteDomainResponse "DeleteDomainResponse" + responseIteratee _ = sdbResponseIteratee $ sdbCheckResponseType DeleteDomainResponse "DeleteDomainResponse" instance Transaction DeleteDomain DeleteDomainResponse diff --git a/Aws/SimpleDb/Commands/DomainMetadata.hs b/Aws/SimpleDb/Commands/DomainMetadata.hs --- a/Aws/SimpleDb/Commands/DomainMetadata.hs +++ b/Aws/SimpleDb/Commands/DomainMetadata.hs @@ -41,10 +41,10 @@ type Info DomainMetadata = SdbInfo signQuery DomainMetadata{..} = sdbSignQuery [("Action", "DomainMetadata"), ("DomainName", T.encodeUtf8 dmDomainName)] -instance ResponseIteratee DomainMetadataResponse where +instance ResponseIteratee r DomainMetadataResponse where type ResponseMetadata DomainMetadataResponse = SdbMetadata - responseIteratee = sdbResponseIteratee parse + responseIteratee _ = sdbResponseIteratee parse where parse cursor = do sdbCheckResponseType () "DomainMetadataResponse" cursor dmrTimestamp <- forceM "Timestamp expected" $ cursor $// elCont "Timestamp" &| (fmap posixSecondsToUTCTime . readInt) diff --git a/Aws/SimpleDb/Commands/GetAttributes.hs b/Aws/SimpleDb/Commands/GetAttributes.hs --- a/Aws/SimpleDb/Commands/GetAttributes.hs +++ b/Aws/SimpleDb/Commands/GetAttributes.hs @@ -45,9 +45,9 @@ maybeToList (("AttributeName",) <$> T.encodeUtf8 <$> gaAttributeName) ++ (guard gaConsistentRead >> [("ConsistentRead", awsTrue)]) -instance ResponseIteratee GetAttributesResponse where +instance ResponseIteratee r GetAttributesResponse where type ResponseMetadata GetAttributesResponse = SdbMetadata - responseIteratee = sdbResponseIteratee parse + responseIteratee _ = sdbResponseIteratee parse where parse cursor = do sdbCheckResponseType () "GetAttributesResponse" cursor attributes <- sequence $ cursor $// Cu.laxElement "Attribute" &| readAttribute diff --git a/Aws/SimpleDb/Commands/ListDomains.hs b/Aws/SimpleDb/Commands/ListDomains.hs --- a/Aws/SimpleDb/Commands/ListDomains.hs +++ b/Aws/SimpleDb/Commands/ListDomains.hs @@ -41,9 +41,9 @@ , ("NextToken",) . T.encodeUtf8 <$> ldNextToken ] -instance ResponseIteratee ListDomainsResponse where +instance ResponseIteratee r ListDomainsResponse where type ResponseMetadata ListDomainsResponse = SdbMetadata - responseIteratee = sdbResponseIteratee parse + responseIteratee _ = sdbResponseIteratee parse where parse cursor = do sdbCheckResponseType () "ListDomainsResponse" cursor let names = cursor $// elContent "DomainName" diff --git a/Aws/SimpleDb/Commands/PutAttributes.hs b/Aws/SimpleDb/Commands/PutAttributes.hs --- a/Aws/SimpleDb/Commands/PutAttributes.hs +++ b/Aws/SimpleDb/Commands/PutAttributes.hs @@ -43,8 +43,8 @@ queryList (attributeQuery setAttributeQuery) "Attribute" paAttributes ++ queryList (attributeQuery expectedAttributeQuery) "Expected" paExpected -instance ResponseIteratee PutAttributesResponse where +instance ResponseIteratee r PutAttributesResponse where type ResponseMetadata PutAttributesResponse = SdbMetadata - responseIteratee = sdbResponseIteratee $ sdbCheckResponseType PutAttributesResponse "PutAttributesResponse" + responseIteratee _ = sdbResponseIteratee $ sdbCheckResponseType PutAttributesResponse "PutAttributesResponse" instance Transaction PutAttributes PutAttributesResponse diff --git a/Aws/SimpleDb/Commands/Select.hs b/Aws/SimpleDb/Commands/Select.hs --- a/Aws/SimpleDb/Commands/Select.hs +++ b/Aws/SimpleDb/Commands/Select.hs @@ -48,9 +48,9 @@ , (("NextToken",) . T.encodeUtf8) <$> sNextToken ] -instance ResponseIteratee SelectResponse where +instance ResponseIteratee r SelectResponse where type ResponseMetadata SelectResponse = SdbMetadata - responseIteratee = sdbResponseIteratee parse + responseIteratee _ = sdbResponseIteratee parse where parse cursor = do sdbCheckResponseType () "SelectResponse" cursor items <- sequence $ cursor $// Cu.laxElement "Item" &| readItem diff --git a/Aws/Sqs.hs b/Aws/Sqs.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs.hs @@ -0,0 +1,17 @@ +module Aws.Sqs +( + module Aws.Sqs.Commands +, module Aws.Sqs.Error +, module Aws.Sqs.Info +, module Aws.Sqs.Metadata +, module Aws.Sqs.Query +, module Aws.Sqs.Response +) +where + +import Aws.Sqs.Commands +import Aws.Sqs.Error +import Aws.Sqs.Info +import Aws.Sqs.Metadata +import Aws.Sqs.Query +import Aws.Sqs.Response diff --git a/Aws/Sqs/Commands.hs b/Aws/Sqs/Commands.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Commands.hs @@ -0,0 +1,24 @@ +module Aws.Sqs.Commands( + module Aws.Sqs.Commands.AddPermission, + module Aws.Sqs.Commands.DeleteMessage, + module Aws.Sqs.Commands.DeleteQueue, + module Aws.Sqs.Commands.ListQueues, + module Aws.Sqs.Commands.GetQueueAttributes, + module Aws.Sqs.Commands.ChangeMessageVisibility, + module Aws.Sqs.Commands.CreateQueue, + module Aws.Sqs.Commands.ReceiveMessage, + module Aws.Sqs.Commands.RemovePermission, + module Aws.Sqs.Commands.SendMessage, + module Aws.Sqs.Commands.SetQueueAttributes +)where +import Aws.Sqs.Commands.AddPermission +import Aws.Sqs.Commands.DeleteMessage +import Aws.Sqs.Commands.DeleteQueue +import Aws.Sqs.Commands.ListQueues +import Aws.Sqs.Commands.GetQueueAttributes +import Aws.Sqs.Commands.ChangeMessageVisibility +import Aws.Sqs.Commands.CreateQueue +import Aws.Sqs.Commands.ReceiveMessage +import Aws.Sqs.Commands.RemovePermission +import Aws.Sqs.Commands.SendMessage +import Aws.Sqs.Commands.SetQueueAttributes diff --git a/Aws/Sqs/Commands/AddPermission.hs b/Aws/Sqs/Commands/AddPermission.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Commands/AddPermission.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-} + +module Aws.Sqs.Commands.AddPermission where + +import Aws.Response +import Aws.Sqs.Info +import Aws.Sqs.Metadata +import Aws.Sqs.Model +import Aws.Sqs.Query +import Aws.Sqs.Response +import Aws.Signature +import Aws.Transaction +import qualified Data.Text as T +import qualified Data.ByteString.Char8 as B +import qualified Network.HTTP.Types as HTTP + + +data AddPermission = AddPermission{ + apLabel :: T.Text, + apPermissions :: [(T.Text,SqsPermission)], + apQueueName :: QueueName +}deriving (Show) + +data AddPermissionResponse = AddPermissionResponse{ +} deriving (Show) + + +formatPermissions :: [(T.Text,SqsPermission)] -> [HTTP.QueryItem] +formatPermissions perms = + 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 + type ResponseMetadata AddPermissionResponse = SqsMetadata + responseIteratee _ = sqsXmlResponseIteratee parse + where + parse _ = do + return AddPermissionResponse {} + +instance SignQuery AddPermission where + type Info AddPermission = SqsInfo + signQuery AddPermission {..} = sqsSignQuery SqsQuery { + sqsQueueName = Just apQueueName, + sqsQuery = [("Action", Just "AddPermission"), + ("QueueName", Just $ B.pack $ T.unpack $ printQueueName apQueueName), + ("Label", Just $ B.pack $ T.unpack apLabel)] ++ formatPermissions apPermissions} + +instance Transaction AddPermission AddPermissionResponse diff --git a/Aws/Sqs/Commands/ChangeMessageVisibility.hs b/Aws/Sqs/Commands/ChangeMessageVisibility.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Commands/ChangeMessageVisibility.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-} + +module Aws.Sqs.Commands.ChangeMessageVisibility where + +import Aws.Response +import Aws.Sqs.Info +import Aws.Sqs.Metadata +import qualified Aws.Sqs.Model as M +import Aws.Sqs.Query +import Aws.Sqs.Response +import Aws.Signature +import Aws.Transaction +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.Char8 as B + +data ChangeMessageVisibility = ChangeMessageVisibility { + cmvReceiptHandle :: M.ReceiptHandle, + cmvVisibilityTimeout :: Int, + cmvQueueName :: M.QueueName +}deriving (Show) + +data ChangeMessageVisibilityResponse = ChangeMessageVisibilityResponse{ +} deriving (Show) + +instance ResponseIteratee r ChangeMessageVisibilityResponse where + type ResponseMetadata ChangeMessageVisibilityResponse = SqsMetadata + responseIteratee _ = sqsXmlResponseIteratee parse + where + parse _ = do return ChangeMessageVisibilityResponse{} + +instance SignQuery ChangeMessageVisibility where + type Info ChangeMessageVisibility = SqsInfo + signQuery ChangeMessageVisibility {..} = sqsSignQuery SqsQuery { + sqsQueueName = Just cmvQueueName, + sqsQuery = [("Action", Just "ChangeMessageVisibility"), + ("ReceiptHandle", Just $ TE.encodeUtf8 $ M.printReceiptHandle cmvReceiptHandle), + ("VisibilityTimeout", Just $ B.pack $ show cmvVisibilityTimeout)]} + +instance Transaction ChangeMessageVisibility ChangeMessageVisibilityResponse diff --git a/Aws/Sqs/Commands/CreateQueue.hs b/Aws/Sqs/Commands/CreateQueue.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Commands/CreateQueue.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-} + +module Aws.Sqs.Commands.CreateQueue where + +import Aws.Response +import Aws.Sqs.Info +import Aws.Sqs.Metadata +import Aws.Sqs.Query +import Aws.Sqs.Response +import Aws.Signature +import Aws.Transaction +import Aws.Xml +import Control.Applicative +import Data.Maybe +import Text.XML.Enumerator.Cursor (($//), (&/)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Text.XML.Enumerator.Cursor as Cu +import qualified Data.ByteString.Char8 as B + +data CreateQueue = CreateQueue{ + cqDefaultVisibilityTimeout :: Maybe Int, + cqQueueName :: T.Text +}deriving (Show) + +data CreateQueueResponse = CreateQueueResponse{ + cqrQueueUrl :: T.Text +} deriving (Show) + + +instance ResponseIteratee r CreateQueueResponse where + type ResponseMetadata CreateQueueResponse = SqsMetadata + responseIteratee _ = sqsXmlResponseIteratee parse + where + parse el = do + url <- force "Missing Queue Url" $ el $// Cu.laxElement "QueueUrl" &/ Cu.content + return CreateQueueResponse{ cqrQueueUrl = url} + +instance SignQuery CreateQueue where + type Info CreateQueue = SqsInfo + signQuery CreateQueue {..} = sqsSignQuery SqsQuery { + 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]} + +instance Transaction CreateQueue CreateQueueResponse diff --git a/Aws/Sqs/Commands/DeleteMessage.hs b/Aws/Sqs/Commands/DeleteMessage.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Commands/DeleteMessage.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-} + +module Aws.Sqs.Commands.DeleteMessage where + +import Aws.Response +import Aws.Sqs.Info +import Aws.Sqs.Metadata +import qualified Aws.Sqs.Model as M +import Aws.Sqs.Query +import Aws.Sqs.Response +import Aws.Signature +import Aws.Transaction +import qualified Data.Text.Encoding as TE + +data DeleteMessage = DeleteMessage{ + dmReceiptHandle :: M.ReceiptHandle, + dmQueueName :: M.QueueName +}deriving (Show) + +data DeleteMessageResponse = DeleteMessageResponse{ +} deriving (Show) + +instance ResponseIteratee r DeleteMessageResponse where + type ResponseMetadata DeleteMessageResponse = SqsMetadata + responseIteratee _ = sqsXmlResponseIteratee parse + where + parse _ = do return DeleteMessageResponse {} + +instance SignQuery DeleteMessage where + type Info DeleteMessage = SqsInfo + signQuery DeleteMessage {..} = sqsSignQuery SqsQuery { + sqsQueueName = Just dmQueueName, + sqsQuery = [("Action", Just "DeleteMessage"), + ("ReceiptHandle", Just $ TE.encodeUtf8 $ M.printReceiptHandle dmReceiptHandle )]} + +instance Transaction DeleteMessage DeleteMessageResponse + + diff --git a/Aws/Sqs/Commands/DeleteQueue.hs b/Aws/Sqs/Commands/DeleteQueue.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Commands/DeleteQueue.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-} + +module Aws.Sqs.Commands.DeleteQueue where + +import Aws.Response +import Aws.Sqs.Info +import Aws.Sqs.Metadata +import qualified Aws.Sqs.Model as M +import Aws.Sqs.Query +import Aws.Sqs.Response +import Aws.Signature +import Aws.Transaction + +data DeleteQueue = DeleteQueue{ + dqQueueName :: M.QueueName +}deriving (Show) + +data DeleteQueueResponse = DeleteQueueResponse{ +} deriving (Show) + +instance ResponseIteratee r DeleteQueueResponse where + type ResponseMetadata DeleteQueueResponse = SqsMetadata + responseIteratee _ = sqsXmlResponseIteratee parse + where + parse _ = do return DeleteQueueResponse{} + +instance SignQuery DeleteQueue where + type Info DeleteQueue = SqsInfo + signQuery DeleteQueue {..} = sqsSignQuery SqsQuery { + sqsQueueName = Just dqQueueName, + sqsQuery = [("Action", Just "DeleteQueue")]} + +instance Transaction DeleteQueue DeleteQueueResponse diff --git a/Aws/Sqs/Commands/GetQueueAttributes.hs b/Aws/Sqs/Commands/GetQueueAttributes.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Commands/GetQueueAttributes.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-} + +module Aws.Sqs.Commands.GetQueueAttributes where + +import Aws.Response +import Aws.Sqs.Info +import Aws.Sqs.Metadata +import qualified Aws.Sqs.Model as M +import Aws.Sqs.Query +import Aws.Sqs.Response +import Aws.Signature +import Aws.Transaction +import Aws.Xml +import Text.XML.Enumerator.Cursor (($/), ($//), (&/), (&|)) +import qualified Data.Text as T +import qualified Text.XML.Enumerator.Cursor as Cu +import qualified Data.ByteString.Char8 as B + +data GetQueueAttributes = GetQueueAttributes { + gqaQueueName :: M.QueueName, + gqaAttributes :: [M.QueueAttribute] +}deriving (Show) + +data GetQueueAttributesResponse = GetQueueAttributesResponse{ + gqarAttributes :: [(M.QueueAttribute,T.Text)] +} deriving (Show) + +parseAttributes :: Cu.Cursor -> [(M.QueueAttribute, T.Text)] +parseAttributes el = do + name <- force "Missing Name" $ el $/ Cu.laxElement "Name" &/ Cu.content + value <- force "Missing Value" $ el $/ Cu.laxElement "Value" &/ Cu.content + parsedName <- M.parseQueueAttribute name + return (parsedName, value) + +instance ResponseIteratee r GetQueueAttributesResponse where + type ResponseMetadata GetQueueAttributesResponse = SqsMetadata + responseIteratee _ = sqsXmlResponseIteratee parse + where + parse el = do + 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 + type Info GetQueueAttributes = SqsInfo + signQuery GetQueueAttributes{..} = sqsSignQuery SqsQuery { + sqsQueueName = Just gqaQueueName, + sqsQuery = [("Action", Just "GetQueueAttributes")] ++ (formatAttributes gqaAttributes)} + +instance Transaction GetQueueAttributes GetQueueAttributesResponse diff --git a/Aws/Sqs/Commands/ListQueues.hs b/Aws/Sqs/Commands/ListQueues.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Commands/ListQueues.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-} + +module Aws.Sqs.Commands.ListQueues where + +import Aws.Response +import Aws.Sqs.Info +import Aws.Sqs.Metadata +import Aws.Sqs.Query +import Aws.Sqs.Response +import Aws.Signature +import Aws.Transaction +import Control.Applicative +import Data.Maybe +import Text.XML.Enumerator.Cursor (($//), (&/)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Text.XML.Enumerator.Cursor as Cu + +data ListQueues = ListQueues { + lqQueueNamePrefix :: Maybe T.Text +}deriving (Show) + +data ListQueuesResponse = ListQueuesResponse{ + lqrQueueUrls :: [T.Text] +} deriving (Show) + +instance ResponseIteratee r ListQueuesResponse where + type ResponseMetadata ListQueuesResponse = SqsMetadata + responseIteratee _ = sqsXmlResponseIteratee parse + where + parse el = do + let queues = el $// Cu.laxElement "QueueUrl" &/ Cu.content + return ListQueuesResponse { lqrQueueUrls = queues } + +instance SignQuery ListQueues where + type Info ListQueues = SqsInfo + signQuery ListQueues{..} = sqsSignQuery SqsQuery { + sqsQueueName = Nothing, + sqsQuery = [("Action", Just "ListQueues")] ++ catMaybes [ + ("QueueNamePrefix",) <$> case lqQueueNamePrefix of + Just x -> Just $ Just $ TE.encodeUtf8 x + Nothing -> Nothing]} + +instance Transaction ListQueues ListQueuesResponse + diff --git a/Aws/Sqs/Commands/ReceiveMessage.hs b/Aws/Sqs/Commands/ReceiveMessage.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Commands/ReceiveMessage.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections, FlexibleContexts, ScopedTypeVariables #-} + +module Aws.Sqs.Commands.ReceiveMessage where + +import Aws.Response +import Aws.Signature +import Aws.Sqs.Info +import Aws.Sqs.Metadata +import Aws.Sqs.Query +import Aws.Sqs.Response +import Aws.Transaction +import Aws.Xml +import Control.Applicative +import Data.Maybe +import Text.XML.Enumerator.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 + +data ReceiveMessage + = ReceiveMessage { + rmVisibilityTimeout :: Maybe Int + , rmAttributes :: [M.MessageAttribute] + , rmMaxNumberOfMessages :: Maybe Int + , rmQueueName :: M.QueueName + } + deriving (Show) + +data Message + = Message { + mMessageId :: T.Text + , mReceiptHandle :: M.ReceiptHandle + , mMD5OfBody :: T.Text + , mBody :: T.Text + , mAttributes :: [(M.MessageAttribute,T.Text)] + } + deriving(Show) + +data ReceiveMessageResponse + = ReceiveMessageResponse { + rmrMessages :: [Message] + } + deriving (Show) + +readMessageAttribute :: F.Failure XmlException m => Cu.Cursor -> m (M.MessageAttribute,T.Text) +readMessageAttribute cursor = do + name <- force "Missing Name" $ cursor $/ Cu.laxElement "Name" &/ Cu.content + value <- force "Missing Value" $ cursor $/ Cu.laxElement "Value" &/ Cu.content + parsedName <- M.parseMessageAttribute name + return (parsedName, value) + +readMessage :: Cu.Cursor -> [Message] +readMessage cursor = do + mid :: T.Text <- force "Missing Message Id" $ cursor $// Cu.laxElement "MessageId" &/ Cu.content + rh <- force "Missing Reciept Handle" $ cursor $// Cu.laxElement "ReceiptHandle" &/ Cu.content + 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)] +formatMAttributes attrs = + case length attrs of + 0 -> [] + 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 + type ResponseMetadata ReceiveMessageResponse = SqsMetadata + responseIteratee _ = sqsXmlResponseIteratee parse + where + parse el = do + let messages = concat $ el $// Cu.laxElement "Message" &| readMessage + return ReceiveMessageResponse{ rmrMessages = messages } + +instance SignQuery ReceiveMessage where + type Info ReceiveMessage = SqsInfo + signQuery ReceiveMessage {..} = sqsSignQuery SqsQuery { + sqsQueueName = Just rmQueueName, + sqsQuery = [("Action", Just "ReceiveMessage")] ++ + catMaybes[("VisibilityTimeout",) <$> case rmVisibilityTimeout of + Just x -> Just $ Just $ B.pack $ show x + Nothing -> Nothing, + ("MaxNumberOfMessages",) <$> case rmMaxNumberOfMessages of + Just x -> Just $ Just $ B.pack $ show x + Nothing -> Nothing] ++ formatMAttributes rmAttributes} + +instance Transaction ReceiveMessage ReceiveMessageResponse diff --git a/Aws/Sqs/Commands/RemovePermission.hs b/Aws/Sqs/Commands/RemovePermission.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Commands/RemovePermission.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-} + +module Aws.Sqs.Commands.RemovePermission where + +import Aws.Response +import Aws.Sqs.Info +import Aws.Sqs.Metadata +import qualified Aws.Sqs.Model as M +import Aws.Sqs.Query +import Aws.Sqs.Response +import Aws.Signature +import Aws.Transaction +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +data RemovePermission = RemovePermission{ + rpLabel :: T.Text, + rpQueueName :: M.QueueName +}deriving (Show) + +data RemovePermissionResponse = RemovePermissionResponse{ +} deriving (Show) + +instance ResponseIteratee r RemovePermissionResponse where + type ResponseMetadata RemovePermissionResponse = SqsMetadata + responseIteratee _ = sqsXmlResponseIteratee parse + where + parse _ = do + return RemovePermissionResponse {} + +instance SignQuery RemovePermission where + type Info RemovePermission = SqsInfo + signQuery RemovePermission {..} = sqsSignQuery SqsQuery { + sqsQueueName = Just rpQueueName, + sqsQuery = [("Action", Just "RemovePermission"), + ("Label", Just $ TE.encodeUtf8 rpLabel )]} + +instance Transaction RemovePermission RemovePermissionResponse + + + diff --git a/Aws/Sqs/Commands/SendMessage.hs b/Aws/Sqs/Commands/SendMessage.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Commands/SendMessage.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-} + +module Aws.Sqs.Commands.SendMessage where + +import Aws.Response +import Aws.Sqs.Info +import Aws.Sqs.Metadata +import qualified Aws.Sqs.Model as M +import Aws.Sqs.Query +import Aws.Sqs.Response +import Aws.Signature +import Aws.Transaction +import Aws.Xml +import Text.XML.Enumerator.Cursor (($//), (&/)) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Text.XML.Enumerator.Cursor as Cu + +data SendMessage = SendMessage{ + smMessage :: T.Text, + smQueueName :: M.QueueName +}deriving (Show) + +data SendMessageResponse = SendMessageResponse{ + smrMD5OfMessageBody :: T.Text, + smrMessageId :: M.MessageId +} deriving (Show) + +instance ResponseIteratee r SendMessageResponse where + type ResponseMetadata SendMessageResponse = SqsMetadata + responseIteratee _ = sqsXmlResponseIteratee 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 + type Info SendMessage = SqsInfo + signQuery SendMessage {..} = sqsSignQuery SqsQuery { + sqsQueueName = Just smQueueName, + sqsQuery = [("Action", Just "SendMessage"), + ("MessageBody", Just $ TE.encodeUtf8 smMessage )]} + +instance Transaction SendMessage SendMessageResponse + + + diff --git a/Aws/Sqs/Commands/SetQueueAttributes.hs b/Aws/Sqs/Commands/SetQueueAttributes.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Commands/SetQueueAttributes.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RecordWildCards, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TupleSections #-} + +module Aws.Sqs.Commands.SetQueueAttributes where + +import Aws.Response +import Aws.Sqs.Info +import Aws.Sqs.Metadata +import qualified Aws.Sqs.Model as M +import Aws.Sqs.Query +import Aws.Sqs.Response +import Aws.Signature +import Aws.Transaction +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +data SetQueueAttributes = SetQueueAttributes{ + sqaAttribute :: M.QueueAttribute, + sqaValue :: T.Text, + sqaQueueName :: M.QueueName +}deriving (Show) + +data SetQueueAttributesResponse = SetQueueAttributesResponse{ +} deriving (Show) + +instance ResponseIteratee r SetQueueAttributesResponse where + type ResponseMetadata SetQueueAttributesResponse = SqsMetadata + responseIteratee _ = sqsXmlResponseIteratee parse + where + parse _ = do + return SetQueueAttributesResponse {} + +instance SignQuery SetQueueAttributes where + type Info SetQueueAttributes = SqsInfo + signQuery SetQueueAttributes {..} = sqsSignQuery SqsQuery { + sqsQueueName = Just sqaQueueName, + sqsQuery = [("Action", Just "SetQueueAttributes"), + ("Attribute.Name", Just $ TE.encodeUtf8 $ M.printQueueAttribute sqaAttribute), + ("Attribute.Value", Just $ TE.encodeUtf8 sqaValue)]} + +instance Transaction SetQueueAttributes SetQueueAttributesResponse diff --git a/Aws/Sqs/Error.hs b/Aws/Sqs/Error.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Error.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses #-} +module Aws.Sqs.Error where + +import Aws.Sqs.Metadata +import Data.Typeable +import qualified Control.Exception as C +import qualified Data.Text as T +import qualified Network.HTTP.Types as HTTP + +type ErrorCode = T.Text + +data SqsError + = SqsError { + sqsStatusCode :: HTTP.Status + , sqsErrorCode :: ErrorCode + , sqsErrorType :: T.Text + , sqsErrorMessage :: T.Text + , sqsErrorDetail :: Maybe T.Text + , sqsErrorMetadata :: Maybe SqsMetadata + } + | SqsXmlError { + sqsXmlErrorMessage :: T.Text + , sqsXmlErrorMetadata :: Maybe SqsMetadata + } + deriving (Show, Typeable) + +instance C.Exception SqsError diff --git a/Aws/Sqs/Info.hs b/Aws/Sqs/Info.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Info.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} +module Aws.Sqs.Info where + +import Aws.Http +import Aws.S3.Model +import Data.Time +import qualified Data.ByteString as B + +data SqsAuthorization + = SqsAuthorizationHeader + | SqsAuthorizationQuery + deriving (Show) + +data Endpoint + = Endpoint { + endpointHost :: B.ByteString + , endpointDefaultLocationConstraint :: LocationConstraint + , endpointAllowedLocationConstraints :: [LocationConstraint] + } + deriving (Show) + +data SqsInfo + = SqsInfo { + sqsProtocol :: Protocol + , sqsEndpoint :: Endpoint + , sqsPort :: Int + , sqsUseUri :: Bool + , sqsDefaultExpiry :: NominalDiffTime + } + deriving (Show) + +sqsEndpointUsClassic :: Endpoint +sqsEndpointUsClassic + = Endpoint { + endpointHost = "queue.amazonaws.com" + , endpointDefaultLocationConstraint = locationUsClassic + , endpointAllowedLocationConstraints = [locationUsClassic + , locationUsWest + , locationEu + , locationApSouthEast + , locationApNorthEast] + } + +sqsEndpointUsWest :: Endpoint +sqsEndpointUsWest + = Endpoint { + endpointHost = "us-west-1.queue.amazonaws.com" + , endpointDefaultLocationConstraint = locationUsWest + , endpointAllowedLocationConstraints = [locationUsWest] + } + +sqsEndpointEu :: Endpoint +sqsEndpointEu + = Endpoint { + endpointHost = "eu-west-1.queue.amazonaws.com" + , endpointDefaultLocationConstraint = locationEu + , endpointAllowedLocationConstraints = [locationEu] + } + +sqsEndpointApSouthEast :: Endpoint +sqsEndpointApSouthEast + = Endpoint { + endpointHost = "ap-southeast-1.queue.amazonaws.com" + , endpointDefaultLocationConstraint = locationApSouthEast + , endpointAllowedLocationConstraints = [locationApSouthEast] + } + +sqsEndpointApNorthEast :: Endpoint +sqsEndpointApNorthEast + = Endpoint { + endpointHost = "sqs.ap-northeast-1.amazonaws.com" + , endpointDefaultLocationConstraint = locationApNorthEast + , endpointAllowedLocationConstraints = [locationApNorthEast] + } + +sqs :: Protocol -> Endpoint -> Bool -> SqsInfo +sqs protocol endpoint uri + = SqsInfo { + sqsProtocol = protocol + , sqsEndpoint = endpoint + , sqsPort = defaultPort protocol + , sqsUseUri = uri + , sqsDefaultExpiry = 15*60 + } + diff --git a/Aws/Sqs/Metadata.hs b/Aws/Sqs/Metadata.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Metadata.hs @@ -0,0 +1,16 @@ +module Aws.Sqs.Metadata where + +import Control.Monad +import Data.Monoid +import qualified Data.Text as T + +data SqsMetadata + = SqsMetadata { + sqsMAmzId2 :: Maybe T.Text + , sqsMRequestId :: Maybe T.Text + } + deriving (Show) + +instance Monoid SqsMetadata where + mempty = SqsMetadata Nothing Nothing + SqsMetadata a1 r1 `mappend` SqsMetadata a2 r2 = SqsMetadata (a1 `mplus` a2) (r1 `mplus` r2) diff --git a/Aws/Sqs/Model.hs b/Aws/Sqs/Model.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Model.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} +module Aws.Sqs.Model where + +import Aws.Xml +import qualified Control.Failure as F +import qualified Data.Text as T + +data QueueName = QueueName{ + qName :: T.Text, + qAccountNumber :: T.Text +} deriving(Show) + +printQueueName :: QueueName -> T.Text +printQueueName queue = T.concat ["/", (qAccountNumber queue), "/", (qName queue), "/"] + +data QueueAttribute + = QueueAll + | ApproximateNumberOfMessages + | ApproximateNumberOfMessagesNotVisible + | VisibilityTimeout + | CreatedTimestamp + | LastModifiedTimestamp + | Policy + | MaximumMessageSize + | MessageRetentionPeriod + | QueueArn + deriving(Show, Enum, Eq) + +data MessageAttribute + = MessageAll + | SenderId + | SentTimestamp + | ApproximateReceiveCount + | ApproximateFirstReceiveTimestamp + deriving(Show,Eq,Enum) + +data SqsPermission + = PermissionAll + | SendMessage + | ReceiveMessage + | DeleteMessage + | ChangeMessageVisibility + | GetQueueAttributes + deriving (Show, Enum, Eq) + +parseQueueAttribute :: F.Failure XmlException m => T.Text -> m QueueAttribute +parseQueueAttribute "ApproximateNumberOfMessages" = return ApproximateNumberOfMessages +parseQueueAttribute "ApproximateNumberOfMessagesNotVisible" = return ApproximateNumberOfMessagesNotVisible +parseQueueAttribute "VisibilityTimeout" = return VisibilityTimeout +parseQueueAttribute "CreatedTimestamp" = return CreatedTimestamp +parseQueueAttribute "LastModifiedTimestamp" = return LastModifiedTimestamp +parseQueueAttribute "Policy" = return Policy +parseQueueAttribute "MaximumMessageSize" = return MaximumMessageSize +parseQueueAttribute "MessageRetentionPeriod" = return MessageRetentionPeriod +parseQueueAttribute "QueueArn" = return QueueArn +parseQueueAttribute x = F.failure $ XmlException ( "Invalid Attribute Name. " ++ show x) + +printQueueAttribute :: QueueAttribute -> T.Text +printQueueAttribute QueueAll = "All" +printQueueAttribute ApproximateNumberOfMessages = "ApproximateNumberOfMessages" +printQueueAttribute ApproximateNumberOfMessagesNotVisible = "ApproximateNumberOfMessagesNotVisible" +printQueueAttribute VisibilityTimeout = "VisibilityTimeout" +printQueueAttribute CreatedTimestamp = "CreatedTimestamp" +printQueueAttribute LastModifiedTimestamp = "LastModifiedTimestamp" +printQueueAttribute Policy = "Policy" +printQueueAttribute MaximumMessageSize = "MaximumMessageSize" +printQueueAttribute MessageRetentionPeriod = "MessageRetentionPeriod" +printQueueAttribute QueueArn = "QueueArn" + +parseMessageAttribute :: F.Failure XmlException m => T.Text -> m MessageAttribute +parseMessageAttribute "SenderId" = return SenderId +parseMessageAttribute "SentTimestamp" = return SentTimestamp +parseMessageAttribute "ApproximateReceiveCount" = return ApproximateReceiveCount +parseMessageAttribute "ApproximateFirstReceiveTimestamp" = return ApproximateFirstReceiveTimestamp +parseMessageAttribute x = F.failure $ XmlException ( "Invalid Attribute Name. " ++ show x) + +printMessageAttribute :: MessageAttribute -> T.Text +printMessageAttribute MessageAll = "All" +printMessageAttribute SenderId = "SenderId" +printMessageAttribute SentTimestamp = "SentTimestamp" +printMessageAttribute ApproximateReceiveCount = "ApproximateReceiveCount" +printMessageAttribute ApproximateFirstReceiveTimestamp = "ApproximateFirstReceiveTimestamp" + +printPermission :: SqsPermission -> T.Text +printPermission PermissionAll = "*" +printPermission SendMessage = "SendMessage" +printPermission ReceiveMessage = "ReceiveMessage" +printPermission DeleteMessage = "DeleteMessage" +printPermission ChangeMessageVisibility = "ChangeMessageVisibility" +printPermission GetQueueAttributes = "GetQueueAttributes" + +newtype ReceiptHandle = ReceiptHandle T.Text deriving(Show,Eq) +newtype MessageId = MessageId T.Text deriving(Show,Eq) + +printReceiptHandle :: ReceiptHandle -> T.Text +printReceiptHandle (ReceiptHandle handle) = handle diff --git a/Aws/Sqs/Query.hs b/Aws/Sqs/Query.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Query.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings,RecordWildCards #-} + +module Aws.Sqs.Query where + +import Aws.Credentials +import Aws.Http +import Aws.Query +import Aws.Sqs.Info +import Aws.Sqs.Model +import Aws.Signature +import Data.List +import Data.Monoid +import Data.Ord +import Data.Time +import System.Locale +import qualified Blaze.ByteString.Builder as Blaze +import qualified Blaze.ByteString.Builder.Char8 as Blaze8 +import qualified Data.ByteString.Char8 as BC +import qualified Data.Text.Encoding as TE +import qualified Network.HTTP.Types as HTTP + +data SqsQuery = SqsQuery{ + sqsQueueName :: Maybe QueueName, + sqsQuery :: HTTP.Query +} + +sqsSignQuery :: SqsQuery -> SqsInfo -> SignatureData -> SignedQuery +sqsSignQuery SqsQuery{..} SqsInfo{..} SignatureData{..} + = SignedQuery { + sqMethod = method + , sqProtocol = sqsProtocol + , sqHost = endpointHost sqsEndpoint + , sqPort = sqsPort + , sqPath = path + , sqQuery = signedQuery + , sqDate = Just signatureTime + , sqAuthorization = Nothing + , sqBody = Nothing + , sqStringToSign = stringToSign + , sqContentType = Nothing + , sqContentMd5 = Nothing + , sqAmzHeaders = [] + } + where + method = PostQuery + path = case sqsQueueName of + Just x -> TE.encodeUtf8 $ printQueueName x + Nothing -> "/" + expandedQuery = sortBy (comparing fst) + ( sqsQuery ++ [ ("AWSAccessKeyId", Just(accessKeyID signatureCredentials)), + ("Expires", Just(BC.pack expiresString)), + ("SignatureMethod", Just("HmacSHA256")), ("SignatureVersion",Just("2")), ("Version",Just("2009-02-01")) + + ]) + + expires = AbsoluteExpires $ sqsDefaultExpiry `addUTCTime` signatureTime + + expiresString = formatTime defaultTimeLocale "%FT%TZ" (fromAbsoluteTimeInfo expires) + + sig = signature signatureCredentials HmacSHA256 stringToSign + stringToSign = Blaze.toByteString . mconcat . intersperse (Blaze8.fromChar '\n') . concat $ + [[Blaze.copyByteString $ httpMethod method] + , [Blaze.copyByteString $ endpointHost sqsEndpoint] + , [Blaze.copyByteString path] + , [Blaze.copyByteString $ HTTP.renderQuery False expandedQuery ]] + + signedQuery = expandedQuery ++ (HTTP.simpleQueryToQuery $ makeAuthQuery) + + makeAuthQuery = [("Signature", sig)] diff --git a/Aws/Sqs/Response.hs b/Aws/Sqs/Response.hs new file mode 100644 --- /dev/null +++ b/Aws/Sqs/Response.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, RecordWildCards #-} +module Aws.Sqs.Response where + +import Aws.Response +import Aws.Sqs.Error +import Aws.Sqs.Metadata +import Aws.Xml +import Control.Monad.IO.Class +import Data.Attempt (Attempt(..)) +import Data.Enumerator ((=$)) +import Data.IORef +import Data.Maybe +import Text.XML.Enumerator.Cursor (($/)) +import qualified Data.ByteString as B +import qualified Data.Enumerator as En +import qualified Data.Text.Encoding 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 + +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 + 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 + +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 + +sqsErrorResponseIteratee :: HTTP.Status -> HTTP.ResponseHeaders -> En.Iteratee B.ByteString IO a +sqsErrorResponseIteratee 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 SqsError + 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 + , sqsErrorMessage = message + , sqsErrorType = errorType + , sqsErrorDetail = detail + , sqsErrorMetadata = Nothing + } diff --git a/Aws/Transaction.hs b/Aws/Transaction.hs --- a/Aws/Transaction.hs +++ b/Aws/Transaction.hs @@ -6,5 +6,5 @@ import Aws.Signature import Data.Monoid -class (SignQuery r, ResponseIteratee a, Monoid (ResponseMetadata a)) +class (SignQuery r, ResponseIteratee r a, Monoid (ResponseMetadata a)) => Transaction r a | r -> a, a -> r diff --git a/Aws/Util.hs b/Aws/Util.hs --- a/Aws/Util.hs +++ b/Aws/Util.hs @@ -6,12 +6,13 @@ import Control.Arrow import Control.Exception import Data.ByteString.Char8 ({- IsString -}) +import Data.Char import Data.Time +import Data.Word import System.Locale import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as BU import qualified Data.Enumerator as En -import qualified Data.Text as T -import qualified Data.Text.Encoding as T 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 @@ -21,9 +22,9 @@ queryList :: (a -> [(B.ByteString, B.ByteString)]) -> B.ByteString -> [a] -> [(B.ByteString, B.ByteString)] queryList f prefix xs = concat $ zipWith combine prefixList (map f xs) - where prefixList = map (dot prefix . T.encodeUtf8 . T.pack . show) [(1 :: Int) ..] + where prefixList = map (dot prefix . BU.fromString . show) [(1 :: Int) ..] combine pf = map $ first (pf `dot`) - dot x y = B.concat [x, ".", y] + dot x y = B.concat [x, BU.fromString ".", y] awsBool :: Bool -> B.ByteString awsBool True = "true" @@ -36,19 +37,24 @@ awsFalse = awsBool False fmtTime :: String -> UTCTime -> B.ByteString -fmtTime s t = T.encodeUtf8 . T.pack $ formatTime defaultTimeLocale s t - -rfc822Time :: String -rfc822Time = "%a, %_d %b %Y %H:%M:%S GMT" +fmtTime s t = BU.fromString $ formatTime defaultTimeLocale s t fmtRfc822Time :: UTCTime -> B.ByteString -fmtRfc822Time = fmtTime rfc822Time - -amzTime :: String -amzTime = "%Y-%m-%dT%H:%M:%S" +fmtRfc822Time = fmtTime "%a, %_d %b %Y %H:%M:%S GMT" fmtAmzTime :: UTCTime -> B.ByteString -fmtAmzTime = fmtTime amzTime +fmtAmzTime = fmtTime "%Y-%m-%dT%H:%M:%S" fmtTimeEpochSeconds :: UTCTime -> B.ByteString fmtTimeEpochSeconds = fmtTime "%s" + +readHex2 :: [Char] -> Maybe Word8 +readHex2 [c1,c2] = do n1 <- readHex1 c1 + n2 <- readHex1 c2 + return . fromIntegral $ n1 * 16 + n2 + 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 + readHex1 _ = Nothing +readHex2 _ = Nothing diff --git a/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -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.5 +Version: 0.0.6 -- A short (one-line) description of the package. Synopsis: Amazon Web Services (AWS) for Haskell @@ -57,9 +57,12 @@ Aws.Response, Aws.S3, Aws.S3.Commands, + Aws.S3.Commands.DeleteObject, Aws.S3.Commands.GetBucket, + Aws.S3.Commands.GetObject, Aws.S3.Commands.GetService, Aws.S3.Commands.PutBucket, + Aws.S3.Commands.PutObject, Aws.S3.Error, Aws.S3.Info, Aws.S3.Metadata, @@ -85,6 +88,25 @@ Aws.SimpleDb.Model, Aws.SimpleDb.Query, Aws.SimpleDb.Response, + Aws.Sqs, + Aws.Sqs.Commands, + Aws.Sqs.Commands.AddPermission, + Aws.Sqs.Commands.DeleteMessage, + Aws.Sqs.Commands.DeleteQueue, + Aws.Sqs.Commands.ListQueues, + Aws.Sqs.Commands.GetQueueAttributes, + Aws.Sqs.Commands.ChangeMessageVisibility, + Aws.Sqs.Commands.CreateQueue, + Aws.Sqs.Commands.ReceiveMessage, + Aws.Sqs.Commands.RemovePermission, + Aws.Sqs.Commands.SendMessage, + Aws.Sqs.Commands.SetQueueAttributes, + Aws.Sqs.Error, + Aws.Sqs.Info, + Aws.Sqs.Metadata, + Aws.Sqs.Model, + Aws.Sqs.Query, + Aws.Sqs.Response, Aws.Transaction, Aws.Util, Aws.Xml @@ -105,16 +127,18 @@ enumerator ==0.4.*, failure >=0.1.0.1 && <0.2, filepath >=1.1 && <1.3, - http-enumerator >=0.6.5.5 && < 0.7, + http-enumerator >=0.6.7 && < 0.7, http-types >=0.6 && <0.7, mtl ==2.*, old-locale ==1.*, shortcircuit ==0.1.*, - text >=0.11 && <0.12, + text >= 0.11, time >=1.1.4 && <1.3, - tls >=0.7.1 && <0.8, + tls >= 0.7.1, transformers >=0.2.2.0 && <0.3, - xml-enumerator >=0.3.4 && <0.4 + transformers-compose ==0.1.*, + utf8-string ==0.3.*, + xml-enumerator >= 0.3.4 GHC-Options: -Wall @@ -123,15 +147,4 @@ -- 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 +