aws 0.7.6.4 → 0.25.3
raw patch · 105 files changed
Files
- Aws.hs +4/−0
- Aws/Aws.hs +170/−111
- Aws/Core.hs +422/−100
- Aws/DynamoDb.hs +20/−0
- Aws/DynamoDb/Commands.hs +23/−0
- Aws/DynamoDb/Commands/BatchGetItem.hs +142/−0
- Aws/DynamoDb/Commands/BatchWriteItem.hs +137/−0
- Aws/DynamoDb/Commands/DeleteItem.hs +114/−0
- Aws/DynamoDb/Commands/GetItem.hs +93/−0
- Aws/DynamoDb/Commands/PutItem.hs +115/−0
- Aws/DynamoDb/Commands/Query.hs +161/−0
- Aws/DynamoDb/Commands/Scan.hs +131/−0
- Aws/DynamoDb/Commands/Table.hs +473/−0
- Aws/DynamoDb/Commands/UpdateItem.hs +175/−0
- Aws/DynamoDb/Core.hs +1406/−0
- Aws/Ec2/InstanceMetadata.hs +35/−0
- Aws/Iam.hs +7/−0
- Aws/Iam/Commands.hs +51/−0
- Aws/Iam/Commands/AddUserToGroup.hs +47/−0
- Aws/Iam/Commands/CreateAccessKey.hs +85/−0
- Aws/Iam/Commands/CreateGroup.hs +53/−0
- Aws/Iam/Commands/CreateUser.hs +53/−0
- Aws/Iam/Commands/DeleteAccessKey.hs +50/−0
- Aws/Iam/Commands/DeleteGroup.hs +37/−0
- Aws/Iam/Commands/DeleteGroupPolicy.hs +47/−0
- Aws/Iam/Commands/DeleteUser.hs +37/−0
- Aws/Iam/Commands/DeleteUserPolicy.hs +47/−0
- Aws/Iam/Commands/GetGroupPolicy.hs +72/−0
- Aws/Iam/Commands/GetUser.hs +44/−0
- Aws/Iam/Commands/GetUserPolicy.hs +72/−0
- Aws/Iam/Commands/ListAccessKeys.hs +105/−0
- Aws/Iam/Commands/ListGroupPolicies.hs +71/−0
- Aws/Iam/Commands/ListGroups.hs +76/−0
- Aws/Iam/Commands/ListMfaDevices.hs +81/−0
- Aws/Iam/Commands/ListUserPolicies.hs +71/−0
- Aws/Iam/Commands/ListUsers.hs +76/−0
- Aws/Iam/Commands/PutGroupPolicy.hs +51/−0
- Aws/Iam/Commands/PutUserPolicy.hs +51/−0
- Aws/Iam/Commands/RemoveUserFromGroup.hs +47/−0
- Aws/Iam/Commands/UpdateAccessKey.hs +58/−0
- Aws/Iam/Commands/UpdateGroup.hs +53/−0
- Aws/Iam/Commands/UpdateUser.hs +53/−0
- Aws/Iam/Core.hs +267/−0
- Aws/Iam/Internal.hs +77/−0
- Aws/Network.hs +20/−0
- Aws/S3/Commands.hs +20/−0
- Aws/S3/Commands/CopyObject.hs +14/−8
- Aws/S3/Commands/DeleteBucket.hs +39/−0
- Aws/S3/Commands/DeleteObject.hs +4/−3
- Aws/S3/Commands/DeleteObjectVersion.hs +52/−0
- Aws/S3/Commands/DeleteObjects.hs +127/−0
- Aws/S3/Commands/GetBucket.hs +18/−1
- Aws/S3/Commands/GetBucketLocation.hs +56/−0
- Aws/S3/Commands/GetBucketObjectVersions.hs +125/−0
- Aws/S3/Commands/GetBucketVersioning.hs +65/−0
- Aws/S3/Commands/GetObject.hs +39/−16
- Aws/S3/Commands/GetService.hs +6/−3
- Aws/S3/Commands/HeadObject.hs +75/−0
- Aws/S3/Commands/Multipart.hs +462/−0
- Aws/S3/Commands/PutBucket.hs +22/−9
- Aws/S3/Commands/PutBucketVersioning.hs +71/−0
- Aws/S3/Commands/PutObject.hs +39/−21
- Aws/S3/Commands/RestoreObject.hs +112/−0
- Aws/S3/Core.hs +418/−68
- Aws/Ses/Commands.hs +22/−0
- Aws/Ses/Commands/DeleteIdentity.hs +40/−0
- Aws/Ses/Commands/GetIdentityDkimAttributes.hs +64/−0
- Aws/Ses/Commands/GetIdentityNotificationAttributes.hs +65/−0
- Aws/Ses/Commands/GetIdentityVerificationAttributes.hs +65/−0
- Aws/Ses/Commands/ListIdentities.hs +64/−0
- Aws/Ses/Commands/SendRawEmail.hs +11/−3
- Aws/Ses/Commands/SetIdentityDkimEnabled.hs +42/−0
- Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs +44/−0
- Aws/Ses/Commands/SetIdentityNotificationTopic.hs +59/−0
- Aws/Ses/Commands/VerifyDomainDkim.hs +40/−0
- Aws/Ses/Commands/VerifyDomainIdentity.hs +41/−0
- Aws/Ses/Commands/VerifyEmailIdentity.hs +40/−0
- Aws/Ses/Core.hs +39/−15
- Aws/SimpleDb/Commands/Attributes.hs +11/−5
- Aws/SimpleDb/Commands/Domain.hs +8/−4
- Aws/SimpleDb/Commands/Select.hs +2/−1
- Aws/SimpleDb/Core.hs +25/−20
- Aws/Sqs/Commands/Message.hs +620/−116
- Aws/Sqs/Commands/Permission.hs +2/−2
- Aws/Sqs/Commands/Queue.hs +4/−3
- Aws/Sqs/Commands/QueueAttributes.hs +2/−2
- Aws/Sqs/Core.hs +58/−21
- CHANGELOG.md +429/−0
- Examples/DynamoDb.hs +134/−0
- Examples/GetObject.hs +6/−4
- Examples/GetObjectGoogle.hs +26/−0
- Examples/GetObjectV4.hs +27/−0
- Examples/MultipartTransfer.hs +37/−0
- Examples/MultipartUpload.hs +30/−0
- Examples/NukeBucket.hs +36/−0
- Examples/PutBucketNearLine.hs +38/−0
- Examples/Sqs.hs +114/−0
- README.md +141/−0
- README.org +0/−188
- aws.cabal +387/−60
- tests/DynamoDb/Main.hs +158/−0
- tests/DynamoDb/Utils.hs +168/−0
- tests/S3/Main.hs +288/−0
- tests/Sqs/Main.hs +381/−0
- tests/Utils.hs +200/−0
Aws.hs view
@@ -49,12 +49,16 @@ , IteratedTransaction -- * Credentials , Credentials(..)+, makeCredentials , credentialsDefaultFile , credentialsDefaultKey , loadCredentialsFromFile , loadCredentialsFromEnv+, loadCredentialsFromInstanceMetadata , loadCredentialsFromEnvOrFile+, loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault+, anonymousCredentials ) where
Aws/Aws.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE BangPatterns #-}+ module Aws.Aws ( -- * Logging LogLevel(..)@@ -13,6 +17,7 @@ , aws , awsRef , pureAws+, memoryAws , simpleAws -- ** Unsafe runners , unsafeAws@@ -22,29 +27,33 @@ -- * Iterated runners --, awsIteratedAll , awsIteratedSource+, awsIteratedSource' , awsIteratedList+, awsIteratedList' ) where import Aws.Core import Control.Applicative-import qualified Control.Exception.Lifted as E import Control.Monad+import qualified Control.Monad.Catch as E import Control.Monad.IO.Class import Control.Monad.Trans import Control.Monad.Trans.Resource-import Data.Attempt (Attempt(Success, Failure))-import qualified Data.ByteString as B-import qualified Data.CaseInsensitive as CI-import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.CaseInsensitive as CI+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL import Data.IORef import Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.IO as T-import qualified Network.HTTP.Conduit as HTTP-import System.IO (stderr)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Client.TLS as HTTP+import System.IO (stderr)+import Prelude -- | The severity of a log message, in rising order. data LogLevel@@ -69,24 +78,27 @@ = Configuration { -- | Whether to restrict the signature validity with a plain timestamp, or with explicit expiration -- (absolute or relative).- timeInfo :: TimeInfo+ timeInfo :: TimeInfo -- | AWS access credentials. , credentials :: Credentials -- | The error / message logger.- , logger :: Logger+ , logger :: Logger+ , proxy :: Maybe HTTP.Proxy } -- | The default configuration, with credentials loaded from environment variable or configuration file -- (see 'loadCredentialsDefault'). baseConfiguration :: MonadIO io => io Configuration baseConfiguration = liftIO $ do- Just cr <- loadCredentialsDefault- return Configuration {+ cr <- loadCredentialsDefault+ case cr of+ Nothing -> E.throwM $ NoCredentialsException "could not locate aws credentials"+ Just cr' -> return Configuration { timeInfo = Timestamp- , credentials = cr+ , credentials = cr' , logger = defaultLog Warning+ , proxy = Nothing }--- TODO: better error handling when credentials cannot be loaded -- | Debug configuration, which logs much more verbosely. dbgConfiguration :: MonadIO io => io Configuration@@ -95,29 +107,29 @@ return c { logger = defaultLog Debug } -- | Run an AWS transaction, with HTTP manager and metadata wrapped in a 'Response'.--- +-- -- All errors are caught and wrapped in the 'Response' value.--- +-- -- Metadata is logged at level 'Info'.--- +-- -- Usage (with existing 'HTTP.Manager'): -- @ -- resp <- aws cfg serviceCfg manager request -- @ aws :: (Transaction r a)- => Configuration - -> ServiceConfiguration r NormalQuery - -> HTTP.Manager - -> r + => Configuration+ -> ServiceConfiguration r NormalQuery+ -> HTTP.Manager+ -> r -> ResourceT IO (Response (ResponseMetadata a) a) aws = unsafeAws -- | Run an AWS transaction, with HTTP manager and metadata returned in an 'IORef'.--- +-- -- Errors are not caught, and need to be handled with exception handlers.--- +-- -- Metadata is not logged.--- +-- -- Usage (with existing 'HTTP.Manager'): -- @ -- ref <- newIORef mempty;@@ -126,70 +138,82 @@ -- Unfortunately, the ";" above seems necessary, as haddock does not want to split lines for me. awsRef :: (Transaction r a)- => Configuration - -> ServiceConfiguration r NormalQuery - -> HTTP.Manager - -> IORef (ResponseMetadata a) - -> r + => Configuration+ -> ServiceConfiguration r NormalQuery+ -> HTTP.Manager+ -> IORef (ResponseMetadata a)+ -> r -> ResourceT IO a awsRef = unsafeAwsRef -- | Run an AWS transaction, with HTTP manager and without metadata.--- +-- -- Metadata is logged at level 'Info'.--- +-- -- Usage (with existing 'HTTP.Manager'): -- @ -- resp <- aws cfg serviceCfg manager request -- @ pureAws :: (Transaction r a)- => Configuration - -> ServiceConfiguration r NormalQuery - -> HTTP.Manager - -> r + => Configuration+ -> ServiceConfiguration r NormalQuery+ -> HTTP.Manager+ -> r -> ResourceT IO a pureAws cfg scfg mgr req = readResponseIO =<< aws cfg scfg mgr req +-- | Run an AWS transaction, with HTTP manager and without metadata.+--+-- Metadata is logged at level 'Info'.+--+-- Usage (with existing 'HTTP.Manager'):+-- @+-- resp <- aws cfg serviceCfg manager request+-- @+memoryAws :: (Transaction r a, AsMemoryResponse a, MonadIO io)+ => Configuration+ -> ServiceConfiguration r NormalQuery+ -> HTTP.Manager+ -> r+ -> io (MemoryResponse a)+memoryAws cfg scfg mgr req = liftIO $ runResourceT $ loadToMemory =<< readResponseIO =<< aws cfg scfg mgr req+ -- | Run an AWS transaction, /without/ HTTP manager and without metadata.--- +-- -- Metadata is logged at level 'Info'.--- +-- -- Note that this is potentially less efficient than using 'aws', because HTTP connections cannot be re-used.--- +-- -- Usage: -- @ -- resp <- simpleAws cfg serviceCfg request -- @ simpleAws :: (Transaction r a, AsMemoryResponse a, MonadIO io)- => Configuration + => Configuration -> ServiceConfiguration r NormalQuery- -> r + -> r -> io (MemoryResponse a)-simpleAws cfg scfg request- = liftIO $ HTTP.withManager $ \manager ->- loadToMemory =<< readResponseIO =<< aws cfg scfg manager request+simpleAws cfg scfg request = liftIO $ runResourceT $ do+ manager <- liftIO HTTP.getGlobalManager+ loadToMemory =<< readResponseIO =<< aws cfg scfg manager request -- | Run an AWS transaction, without enforcing that response and request type form a valid transaction pair.--- +-- -- This is especially useful for debugging and development, you should not have to use it in production.--- +-- -- All errors are caught and wrapped in the 'Response' value.--- +-- -- Metadata is wrapped in the Response, and also logged at level 'Info'. unsafeAws :: (ResponseConsumer r a,- Monoid (ResponseMetadata a), Loggable (ResponseMetadata a), SignQuery r) => Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r -> ResourceT IO (Response (ResponseMetadata a) a) unsafeAws cfg scfg manager request = do metadataRef <- liftIO $ newIORef mempty - let catchAll :: ResourceT IO a -> ResourceT IO (Attempt a)- catchAll = E.handle (return . failure') . fmap Success-- failure' :: E.SomeException -> Attempt a- failure' = Failure+ let catchAll :: ResourceT IO a -> ResourceT IO (Either E.SomeException a)+ catchAll = E.handle (return . Left) . fmap Right resp <- catchAll $ unsafeAwsRef cfg scfg manager metadataRef request@@ -198,32 +222,40 @@ return $ Response metadata resp -- | Run an AWS transaction, without enforcing that response and request type form a valid transaction pair.--- +-- -- This is especially useful for debugging and development, you should not have to use it in production.--- +-- -- Errors are not caught, and need to be handled with exception handlers.--- +-- -- Metadata is put in the 'IORef', but not logged. unsafeAwsRef :: (ResponseConsumer r a,- Monoid (ResponseMetadata a), SignQuery r) => Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> IORef (ResponseMetadata a) -> r -> ResourceT IO a unsafeAwsRef cfg info manager metadataRef request = do sd <- liftIO $ signatureData <$> timeInfo <*> credentials $ cfg- let q = signQuery request info sd- liftIO $ logger cfg Debug $ T.pack $ "String to sign: " ++ show (sqStringToSign q)- let httpRequest = queryToHttpRequest q- liftIO $ logger cfg Debug $ T.pack $ "Host: " ++ show (HTTP.host httpRequest)- resp <- do- hresp <- HTTP.http httpRequest manager- forM_ (HTTP.responseHeaders hresp) $ \(hname,hvalue) -> liftIO $ do- logger cfg Debug $ T.decodeUtf8 $ "Response header '" `mappend` CI.original hname `mappend` "': '" `mappend` hvalue `mappend` "'"- responseConsumer request metadataRef hresp- return resp+ let !q = {-# SCC "unsafeAwsRef:signQuery" #-} signQuery request info sd+ let logDebug = liftIO . logger cfg Debug . T.pack+ logDebug $ "String to sign: " ++ show (sqStringToSign q)+ !httpRequest <- {-# SCC "unsafeAwsRef:httpRequest" #-} liftIO $ do+ req <- queryToHttpRequest q+ return $ req { HTTP.proxy = proxy cfg }+ logDebug $ "Host: " ++ show (HTTP.host httpRequest)+ logDebug $ "Path: " ++ show (HTTP.path httpRequest)+ logDebug $ "Query string: " ++ show (HTTP.queryString httpRequest)+ logDebug $ "Header: " ++ show (HTTP.requestHeaders httpRequest)+ case HTTP.requestBody httpRequest of+ HTTP.RequestBodyLBS lbs -> logDebug $ "Body: " ++ show (L.take 1000 lbs)+ HTTP.RequestBodyBS bs -> logDebug $ "Body: " ++ show (B.take 1000 bs)+ _ -> return ()+ hresp <- {-# SCC "unsafeAwsRef:http" #-} HTTP.http httpRequest manager+ logDebug $ "Response status: " ++ show (HTTP.responseStatus hresp)+ forM_ (HTTP.responseHeaders hresp) $ \(hname,hvalue) -> liftIO $+ logger cfg Debug $ T.decodeUtf8 $ "Response header '" `mappend` CI.original hname `mappend` "': '" `mappend` hvalue `mappend` "'"+ {-# SCC "unsafeAwsRef:responseConsumer" #-} responseConsumer httpRequest request metadataRef hresp -- | Run a URI-only AWS transaction. Returns a URI that can be sent anywhere. Does not work with all requests.--- +-- -- Usage: -- @ -- uri <- awsUri cfg request@@ -250,49 +282,76 @@ where go request prevResp = do Response meta respAttempt <- aws cfg scfg manager request case maybeCombineIteratedResponse prevResp <$> respAttempt of f@(Failure _) -> return (Response [meta] f)- s@(Success resp) -> + s@(Success resp) -> case nextIteratedRequest request resp of- Nothing -> + Nothing -> return (Response [meta] s)- Just nextRequest -> + Just nextRequest -> mapMetadata (meta:) `liftM` go nextRequest (Just resp) -} -awsIteratedSource :: (IteratedTransaction r a)- => Configuration- -> ServiceConfiguration r NormalQuery- -> HTTP.Manager- -> r-#if MIN_VERSION_conduit(1, 0, 0)- -> C.Producer (ResourceT IO) (Response (ResponseMetadata a) a)-#else- -> C.GSource (ResourceT IO) (Response (ResponseMetadata a) a)-#endif-awsIteratedSource cfg scfg manager req_ = go req_- where go request = do resp <- lift $ aws cfg scfg manager request- C.yield resp- case responseResult resp of- Failure _ -> return ()- Success x ->- case nextIteratedRequest request x of- Nothing -> return ()- Just nextRequest -> go nextRequest+awsIteratedSource+ :: (IteratedTransaction r a)+ => Configuration+ -> ServiceConfiguration r NormalQuery+ -> HTTP.Manager+ -> r+ -> forall i. C.ConduitT i (Response (ResponseMetadata a) a) (ResourceT IO) ()+awsIteratedSource cfg scfg manager req_ = awsIteratedSource' run req_+ where+ run r = do+ res <- aws cfg scfg manager r+ a <- readResponseIO res+ return (a, res) -awsIteratedList :: (IteratedTransaction r a, ListResponse a i)- => Configuration- -> ServiceConfiguration r NormalQuery- -> HTTP.Manager- -> r-#if MIN_VERSION_conduit(1, 0, 0)- -> C.Producer (ResourceT IO) i-#else- -> C.GSource (ResourceT IO) i-#endif-awsIteratedList cfg scfg manager req- = awsIteratedSource cfg scfg manager req-#if MIN_VERSION_conduit(1, 0, 0)- C.=$=-#else- C.>+>-#endif- CL.concatMapM (fmap listResponse . readResponseIO)++awsIteratedList+ :: (IteratedTransaction r a, ListResponse a i)+ => Configuration+ -> ServiceConfiguration r NormalQuery+ -> HTTP.Manager+ -> r+ -> forall j. C.ConduitT j i (ResourceT IO) ()+awsIteratedList cfg scfg manager req = awsIteratedList' run req+ where+ run r = readResponseIO =<< aws cfg scfg manager r+++-------------------------------------------------------------------------------+-- | A more flexible version of 'awsIteratedSource' that uses a+-- user-supplied run function. Useful for embedding AWS functionality+-- within application specific monadic contexts.+awsIteratedSource'+ :: (Monad m, IteratedTransaction r a)+ => (r -> m (a, b))+ -- ^ A runner function for executing transactions.+ -> r+ -- ^ An initial request+ -> forall i. C.ConduitT i b m ()+awsIteratedSource' run r0 = go r0+ where+ go q = do+ (a, b) <- lift $ run q+ C.yield b+ case nextIteratedRequest q a of+ Nothing -> return ()+ Just q' -> go q'+++-------------------------------------------------------------------------------+-- | A more flexible version of 'awsIteratedList' that uses a+-- user-supplied run function. Useful for embedding AWS functionality+-- within application specific monadic contexts.+awsIteratedList'+ :: (Monad m, IteratedTransaction r b, ListResponse b c)+ => (r -> m b)+ -- ^ A runner function for executing transactions.+ -> r+ -- ^ An initial request+ -> forall i. C.ConduitT i c m ()+awsIteratedList' run r0 =+ awsIteratedSource' run' r0 `C.fuse`+ CL.concatMap listResponse+ where+ dupl a = (a,a)+ run' r = dupl `liftM` run r
Aws/Core.hs view
@@ -21,6 +21,8 @@ , XmlException(..) , HeaderException(..) , FormException(..)+, NoCredentialsException(..)+, throwStatusCodeException -- ** Response deconstruction helpers , readHex2 -- *** XML@@ -28,6 +30,7 @@ , elCont , force , forceM+, textReadBool , textReadInt , readInt , xmlCursorConsumer@@ -49,6 +52,10 @@ , AuthorizationHash(..) , amzHash , signature+, credentialV4+, authorizationV4+, authorizationV4'+, signatureV4 -- ** Query construction helpers , queryList , awsBool@@ -68,12 +75,16 @@ , IteratedTransaction(..) -- * Credentials , Credentials(..)+, makeCredentials , credentialsDefaultFile , credentialsDefaultKey , loadCredentialsFromFile , loadCredentialsFromEnv+, loadCredentialsFromInstanceMetadata , loadCredentialsFromEnvOrFile+, loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault+, anonymousCredentials -- * Service configuration , DefaultServiceConfiguration(..) -- * HTTP types@@ -84,61 +95,76 @@ ) where +import Aws.Ec2.InstanceMetadata+import Aws.Network import qualified Blaze.ByteString.Builder as Blaze import Control.Applicative import Control.Arrow import qualified Control.Exception as E-import qualified Control.Failure as F import Control.Monad import Control.Monad.IO.Class-import qualified Crypto.Classes as Crypto-import qualified Crypto.HMAC as HMAC-import Crypto.Hash.CryptoAPI (MD5, SHA1, SHA256)-import Data.Attempt (Attempt(..), FromAttempt(..))+import Control.Monad.Trans.Resource (ResourceT, MonadThrow (throwM))+import qualified Crypto.Hash as CH+import qualified Crypto.MAC.HMAC as CMH+import qualified Data.Aeson as A+import qualified Data.ByteArray as ByteArray import Data.ByteString (ByteString) import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Base64 as Base64 import Data.ByteString.Char8 ({- IsString -}) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as BU import Data.Char-import Data.Conduit (ResourceT, ($$+-))+import Data.Conduit ((.|)) import qualified Data.Conduit as C+#if MIN_VERSION_http_conduit(2,2,0)+import qualified Data.Conduit.Binary as CB+#endif+import qualified Data.Conduit.List as CL+import Data.Kind import Data.IORef import Data.List+import qualified Data.Map as M import Data.Maybe import Data.Monoid-import qualified Data.Serialize as Serialize import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Time+import qualified Data.Traversable as Traversable import Data.Typeable import Data.Word import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Client.TLS as HTTP import qualified Network.HTTP.Types as HTTP import System.Directory import System.Environment import System.FilePath ((</>))+#if !MIN_VERSION_time(1,5,0) import System.Locale+#endif import qualified Text.XML as XML import qualified Text.XML.Cursor as Cu import Text.XML.Cursor hiding (force, forceM)+import Prelude+------------------------------------------------------------------------------- -- | Types that can be logged (textually). class Loggable a where toLogText :: a -> T.Text --- | A response with metadata. Can also contain an error response, or an internal error, via 'Attempt'.+-- | A response with metadata. Can also contain an error response, or+-- an internal error, via 'Attempt'. -- -- Response forms a Writer-like monad. data Response m a = Response { responseMetadata :: m- , responseResult :: Attempt a }+ , responseResult :: Either E.SomeException a } deriving (Show, Functor) -- | Read a response result (if it's a success response, fail otherwise).-readResponse :: FromAttempt f => Response m a -> f a-readResponse = fromAttempt . responseResult+readResponse :: MonadThrow n => Response m a -> n a+readResponse = either throwM return . responseResult -- | Read a response result (if it's a success response, fail otherwise). In MonadIO. readResponseIO :: MonadIO io => Response m a -> io a@@ -154,21 +180,25 @@ --multiResponse :: Monoid m => Response m a -> Response [m] a -> +instance Monoid m => Applicative (Response m) where+ pure x = Response mempty (Right x)+ (<*>) = ap+ instance Monoid m => Monad (Response m) where- return x = Response mempty (Success x)- Response m1 (Failure e) >>= _ = Response m1 (Failure e)- Response m1 (Success x) >>= f = let Response m2 y = f x- in Response (m1 `mappend` m2) y -- currently using First-semantics, Last SHOULD work too+ return = pure+ Response m1 (Left e) >>= _ = Response m1 (Left e)+ Response m1 (Right x) >>= f = let Response m2 y = f x+ in Response (m1 `mappend` m2) y -- currently using First-semantics, Last SHOULD work too -instance (Monoid m, E.Exception e) => F.Failure e (Response m) where- failure e = Response mempty (F.failure e)+instance Monoid m => MonadThrow (Response m) where+ throwM e = Response mempty (throwM e) -- | Add metadata to an 'IORef' (using 'mappend'). tellMetadataRef :: Monoid m => IORef m -> m -> IO () tellMetadataRef r m = modifyIORef r (`mappend` m) -- | A full HTTP response parser. Takes HTTP status, response headers, and response body.-type HTTPResponseConsumer a = HTTP.Response (C.ResumableSource (ResourceT IO) ByteString)+type HTTPResponseConsumer a = HTTP.Response (C.ConduitM () ByteString (ResourceT IO) ()) -> ResourceT IO a -- | Class for types that AWS HTTP responses can be parsed into.@@ -177,40 +207,52 @@ -- -- Note that for debugging, there is an instance for 'L.ByteString'. class Monoid (ResponseMetadata resp) => ResponseConsumer req resp where- -- | Metadata associated with a response. Typically there is one metadata type for each AWS service.+ -- | Metadata associated with a response. Typically there is one+ -- metadata type for each AWS service. type ResponseMetadata resp - -- | Response parser. Takes the corresponding request, an 'IORef' for metadata, and HTTP response data.- responseConsumer :: req -> IORef (ResponseMetadata resp) -> HTTPResponseConsumer resp+ -- | Response parser. Takes the corresponding AWS request, the derived+ -- @http-client@ request (for error reporting), an 'IORef' for metadata, and+ -- HTTP response data.+ responseConsumer :: HTTP.Request -> req -> IORef (ResponseMetadata resp) -> HTTPResponseConsumer resp -- | Does not parse response. For debugging. instance ResponseConsumer r (HTTP.Response L.ByteString) where type ResponseMetadata (HTTP.Response L.ByteString) = ()- responseConsumer _ _ resp = HTTP.lbsResponse resp+ responseConsumer _ _ _ resp = do+ bss <- C.runConduit $ HTTP.responseBody resp .| CL.consume+ return resp+ { HTTP.responseBody = L.fromChunks bss+ } -- | Class for responses that are fully loaded into memory class AsMemoryResponse resp where- type MemoryResponse resp :: *+ type MemoryResponse resp :: Type loadToMemory :: resp -> ResourceT IO (MemoryResponse resp) -- | Responses that have one main list in them, and perhaps some decoration. class ListResponse resp item | resp -> item where listResponse :: resp -> [item] + -- | Associates a request type and a response type in a bi-directional way. ----- This allows the type-checker to infer the response type when given the request type and vice versa.+-- This allows the type-checker to infer the response type when given+-- the request type and vice versa. ----- Note that the actual request generation and response parsing resides in 'SignQuery' and 'ResponseConsumer'--- respectively.+-- Note that the actual request generation and response parsing+-- resides in 'SignQuery' and 'ResponseConsumer' respectively. class (SignQuery r, ResponseConsumer r a, Loggable (ResponseMetadata a)) => Transaction r a- | r -> a, a -> r+ | r -> a -- | A transaction that may need to be split over multiple requests, for example because of upstream response size limits.-class Transaction r a => IteratedTransaction r a | r -> a , a -> r where+class Transaction r a => IteratedTransaction r a | r -> a where nextIteratedRequest :: r -> a -> Maybe r +-- | Signature version 4: ((region, service),(date,key))+type V4Key = ((B.ByteString,B.ByteString),(B.ByteString,B.ByteString))+ -- | AWS access credentials. data Credentials = Credentials {@@ -218,15 +260,39 @@ accessKeyID :: B.ByteString -- | AWS Secret Access Key. , secretAccessKey :: B.ByteString+ -- | Signing keys for signature version 4+ , v4SigningKeys :: IORef [V4Key]+ -- | Signed IAM token+ , iamToken :: Maybe B.ByteString+ -- | Set when the credentials are intended for anonymous access.+ , isAnonymousCredentials :: Bool }- deriving (Show)+instance Show Credentials where+ show c@(Credentials {}) = "Credentials{accessKeyID=" ++ show (accessKeyID c) ++ ",secretAccessKey=" ++ show (secretAccessKey c) ++ ",iamToken=" ++ show (iamToken c) ++ "}" +makeCredentials :: MonadIO io+ => B.ByteString -- ^ AWS Access Key ID+ -> B.ByteString -- ^ AWS Secret Access Key+ -> io Credentials+makeCredentials accessKeyID secretAccessKey = liftIO $ do+ v4SigningKeys <- newIORef []+ let iamToken = Nothing+ let isAnonymousCredentials = False+ return Credentials { .. }+ -- | The file where access credentials are loaded, when using 'loadCredentialsDefault'.+-- May return 'Nothing' if @HOME@ is unset. -- -- Value: /<user directory>/@/.aws-keys@-credentialsDefaultFile :: MonadIO io => io FilePath-credentialsDefaultFile = liftIO $ (</> ".aws-keys") <$> getHomeDirectory+credentialsDefaultFile :: MonadIO io => io (Maybe FilePath)+credentialsDefaultFile = liftIO $ tryMaybe ((</> ".aws-keys") <$> getHomeDirectory) +tryMaybe :: IO a -> IO (Maybe a)+tryMaybe action = E.catch (Just <$> action) f+ where+ f :: E.SomeException -> IO (Maybe a)+ f _ = return Nothing+ -- | The key to be used in the access credential file that is loaded, when using 'loadCredentialsDefault'. -- -- Value: @default@@@ -240,24 +306,59 @@ -- @keyName awsKeyID awsKeySecret@ loadCredentialsFromFile :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) loadCredentialsFromFile file key = liftIO $ do- contents <- map T.words . T.lines <$> T.readFile file- return $ do- [_key, keyID, secret] <- find (hasKey key) contents- return Credentials { accessKeyID = T.encodeUtf8 keyID, secretAccessKey = T.encodeUtf8 secret }- where- hasKey _ [] = False- hasKey k (k2 : _) = k == k2+ exists <- doesFileExist file+ if exists+ then do+ contents <- map T.words . T.lines <$> T.readFile file+ Traversable.sequence $ do+ [_key, keyID, secret] <- find (hasKey key) contents+ return (makeCredentials (T.encodeUtf8 keyID) (T.encodeUtf8 secret))+ else return Nothing+ where+ hasKey _ [] = False+ hasKey k (k2 : _) = k == k2 -- | Load credentials from the environment variables @AWS_ACCESS_KEY_ID@ and @AWS_ACCESS_KEY_SECRET@ -- (or @AWS_SECRET_ACCESS_KEY@), if possible. loadCredentialsFromEnv :: MonadIO io => io (Maybe Credentials) loadCredentialsFromEnv = liftIO $ do env <- getEnvironment- let lk = flip lookup env+ let lk = fmap (T.encodeUtf8 . T.pack) . flip lookup env keyID = lk "AWS_ACCESS_KEY_ID" secret = lk "AWS_ACCESS_KEY_SECRET" `mplus` lk "AWS_SECRET_ACCESS_KEY"- return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID) <*> (T.encodeUtf8 . T.pack <$> secret))+ setSession creds = creds { iamToken = lk "AWS_SESSION_TOKEN" }+ makeCredentials' k s = setSession <$> makeCredentials k s+ Traversable.sequence $ makeCredentials' <$> keyID <*> secret +loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials)+loadCredentialsFromInstanceMetadata = do+ mgr <- liftIO HTTP.getGlobalManager+ -- check if the path is routable+ avail <- liftIO $ hostAvailable "169.254.169.254"+ if not avail+ then return Nothing+ else do+ info <- liftIO $ E.catch (getInstanceMetadata mgr "latest/meta-data/iam" "info" >>= return . Just) (\(_ :: HTTP.HttpException) -> return Nothing)+ let infodict = info >>= A.decode :: Maybe (M.Map String String)+ info' = infodict >>= M.lookup "InstanceProfileArn"+ case info' of+ Just name ->+ do+ let name' = drop 1 $ dropWhile (/= '/') $ name+ creds <- liftIO $ E.catch (getInstanceMetadata mgr "latest/meta-data/iam/security-credentials" name' >>= return . Just) (\(_ :: HTTP.HttpException) -> return Nothing)+ -- this token lasts ~6 hours+ let dict = creds >>= A.decode :: Maybe (M.Map String String)+ keyID = dict >>= M.lookup "AccessKeyId"+ secret = dict >>= M.lookup "SecretAccessKey"+ token = dict >>= M.lookup "Token"+ ref <- liftIO $ newIORef []+ return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID)+ <*> (T.encodeUtf8 . T.pack <$> secret)+ <*> return ref+ <*> (Just . T.encodeUtf8 . T.pack <$> token)+ <*> return False)+ Nothing -> return Nothing+ -- | Load credentials from environment variables if possible, or alternatively from a file with a given key name. -- -- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details.@@ -269,6 +370,22 @@ Just cr -> return (Just cr) Nothing -> loadCredentialsFromFile file key +-- | Load credentials from environment variables if possible, or alternatively from the instance metadata store, or alternatively from a file with a given key name.+--+-- See 'loadCredentialsFromEnv', 'loadCredentialsFromFile' and 'loadCredentialsFromInstanceMetadata' for details.+loadCredentialsFromEnvOrFileOrInstanceMetadata :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials)+loadCredentialsFromEnvOrFileOrInstanceMetadata file key =+ do+ envcr <- loadCredentialsFromEnv+ case envcr of+ Just cr -> return (Just cr)+ Nothing ->+ do+ filecr <- loadCredentialsFromFile file key+ case filecr of+ Just cr -> return (Just cr)+ Nothing -> loadCredentialsFromInstanceMetadata+ -- | Load credentials from environment variables if possible, or alternative from the default file with the default -- key name. --@@ -278,14 +395,23 @@ -- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details. loadCredentialsDefault :: MonadIO io => io (Maybe Credentials) loadCredentialsDefault = do- file <- credentialsDefaultFile- loadCredentialsFromEnvOrFile file credentialsDefaultKey+ mfile <- credentialsDefaultFile+ case mfile of+ Just file -> loadCredentialsFromEnvOrFileOrInstanceMetadata file credentialsDefaultKey+ Nothing -> loadCredentialsFromEnv +-- | Make a dummy Credentials that can be used to access some AWS services+-- anonymously.+anonymousCredentials :: MonadIO io => io Credentials+anonymousCredentials = do+ cr <- makeCredentials mempty mempty+ return (cr { isAnonymousCredentials = True })+ -- | Protocols supported by AWS. Currently, all AWS services use the HTTP or HTTPS protocols. data Protocol = HTTP | HTTPS- deriving (Show)+ deriving (Eq,Read,Show,Ord,Typeable) -- | The default port to be used for a protocol if no specific port is specified. defaultPort :: Protocol -> Int@@ -294,16 +420,18 @@ -- | Request method. Not all request methods are supported by all services. data Method- = Get -- ^ GET method. Put all request parameters in a query string and HTTP headers.+ = Head -- ^ HEAD method. Put all request parameters in a query string and HTTP headers.+ | Get -- ^ GET method. Put all request parameters in a query string and HTTP headers. | PostQuery -- ^ POST method. Put all request parameters in a query string and HTTP headers, but send the query string -- as a POST payload | Post -- ^ POST method. Sends a service- and request-specific request body. | Put -- ^ PUT method. | Delete -- ^ DELETE method.- deriving (Show, Eq)+ deriving (Show, Eq, Ord) -- | HTTP method associated with a request method. httpMethod :: Method -> HTTP.Method+httpMethod Head = "HEAD" httpMethod Get = "GET" httpMethod PostQuery = "POST" httpMethod Post = "POST"@@ -314,40 +442,41 @@ data SignedQuery = SignedQuery { -- | Request method.- sqMethod :: Method+ sqMethod :: !Method -- | Protocol to be used.- , sqProtocol :: Protocol+ , sqProtocol :: !Protocol -- | HTTP host.- , sqHost :: B.ByteString+ , sqHost :: !B.ByteString -- | IP port.- , sqPort :: Int+ , sqPort :: !Int -- | HTTP path.- , sqPath :: B.ByteString+ , sqPath :: !B.ByteString -- | Query string list (used with 'Get' and 'PostQuery').- , sqQuery :: HTTP.Query+ , sqQuery :: !HTTP.Query -- | Request date/time.- , sqDate :: Maybe UTCTime- -- | Authorization string (if applicable), for @Authorization@ header..- , sqAuthorization :: Maybe B.ByteString+ , sqDate :: !(Maybe UTCTime)+ -- | Authorization string (if applicable), for @Authorization@ header. See 'authorizationV4'+ , sqAuthorization :: !(Maybe (IO B.ByteString)) -- | Request body content type.- , sqContentType :: Maybe B.ByteString+ , sqContentType :: !(Maybe B.ByteString) -- | Request body content MD5.- , sqContentMd5 :: Maybe MD5+ , sqContentMd5 :: !(Maybe (CH.Digest CH.MD5)) -- | Additional Amazon "amz" headers.- , sqAmzHeaders :: HTTP.RequestHeaders+ , sqAmzHeaders :: !HTTP.RequestHeaders -- | Additional non-"amz" headers.- , sqOtherHeaders :: HTTP.RequestHeaders+ , sqOtherHeaders :: !HTTP.RequestHeaders -- | Request body (used with 'Post' and 'Put').- , sqBody :: Maybe (HTTP.RequestBody (C.ResourceT IO))+ , sqBody :: !(Maybe HTTP.RequestBody) -- | String to sign. Note that the string is already signed, this is passed mostly for debugging purposes.- , sqStringToSign :: B.ByteString+ , sqStringToSign :: !B.ByteString } --deriving (Show) -- | Create a HTTP request from a 'SignedQuery' object.-queryToHttpRequest :: SignedQuery -> HTTP.Request (C.ResourceT IO)-queryToHttpRequest SignedQuery{..}- = HTTP.def {+queryToHttpRequest :: SignedQuery -> IO HTTP.Request+queryToHttpRequest SignedQuery{..} = do+ mauth <- maybe (return Nothing) (Just<$>) sqAuthorization+ return $ HTTP.defaultRequest { HTTP.method = httpMethod sqMethod , HTTP.secure = case sqProtocol of HTTP -> False@@ -355,30 +484,47 @@ , HTTP.host = sqHost , HTTP.port = sqPort , HTTP.path = sqPath- , HTTP.queryString = HTTP.renderQuery False sqQuery- , HTTP.requestHeaders = catMaybes [fmap (\d -> ("Date", fmtRfc822Time d)) sqDate+ , HTTP.queryString =+ if sqMethod == PostQuery+ then ""+ else HTTP.renderQuery False sqQuery++ , HTTP.requestHeaders = catMaybes [ checkDate (\d -> ("Date", fmtRfc822Time d)) sqDate , fmap (\c -> ("Content-Type", c)) contentType- , fmap (\md5 -> ("Content-MD5", Base64.encode $ Serialize.encode md5)) sqContentMd5- , fmap (\auth -> ("Authorization", auth)) sqAuthorization]+ , fmap (\md5 -> ("Content-MD5", Base64.encode $ ByteArray.convert md5)) sqContentMd5+ , fmap (\auth -> ("Authorization", auth)) mauth] ++ 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.requestBody =++ -- An explicitly defined body parameter should overwrite everything else.+ case sqBody of+ Just x -> x+ Nothing ->+ -- a POST query should convert its query string into the body+ case sqMethod of+ PostQuery -> HTTP.RequestBodyLBS . Blaze.toLazyByteString $+ HTTP.renderQueryBuilder False sqQuery+ _ -> HTTP.RequestBodyBuilder 0 mempty+ , HTTP.decompress = HTTP.alwaysDecompress-#if MIN_VERSION_http_conduit(1, 9, 0)- , HTTP.checkStatus = \_ _ _ -> Nothing+#if MIN_VERSION_http_conduit(2,2,0)+ , HTTP.checkResponse = \_ _ -> return () #else- , HTTP.checkStatus = \_ _ -> Nothing+ , HTTP.checkStatus = \_ _ _-> Nothing #endif++ , HTTP.redirectCount = 10 }- where contentType = case sqMethod of- PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8"- _ -> sqContentType+ where+ checkDate f mb = maybe (f <$> mb) (const Nothing) $ lookup "date" sqOtherHeaders+ -- An explicitly defined content-type should override everything else.+ contentType = sqContentType `mplus` defContentType+ defContentType = case sqMethod of+ PostQuery -> Just "application/x-www-form-urlencoded; charset=utf-8"+ _ -> Nothing --- | Create a URI fro a 'SignedQuery' object.+-- | Create a URI from a 'SignedQuery' object. -- -- Unused / incompatible fields will be silently ignored. queryToUri :: SignedQuery -> B.ByteString@@ -445,7 +591,7 @@ -- | A "signable" request object. Assembles together the Query, and signs it in one go. class SignQuery request where -- | Additional information, like API endpoints and service-specific preferences.- type ServiceConfiguration request :: * {- Query Type -} -> *+ type ServiceConfiguration request :: Type {- Query Type -} -> Type -- | Create a 'SignedQuery' from a request, additional 'Info', and 'SignatureData'. signQuery :: request -> ServiceConfiguration request queryType -> SignatureData -> SignedQuery@@ -468,13 +614,165 @@ signature cr ah input = Base64.encode sig where sig = case ah of- HmacSHA1 -> computeSig (undefined :: SHA1)- HmacSHA256 -> computeSig (undefined :: SHA256)- computeSig :: Crypto.Hash c d => d -> B.ByteString- computeSig t = Serialize.encode (HMAC.hmac' key input `asTypeOf` t)- key :: HMAC.MacKey c d- key = HMAC.MacKey (secretAccessKey cr)+ HmacSHA1 -> ByteArray.convert (CMH.hmac (secretAccessKey cr) input :: CMH.HMAC CH.SHA1)+ HmacSHA256 -> ByteArray.convert (CMH.hmac (secretAccessKey cr) input :: CMH.HMAC CH.SHA256) ++-- | Generates the Credential string, required for V4 signatures.+credentialV4+ :: SignatureData+ -> B.ByteString -- ^ region, e.g. us-east-1+ -> B.ByteString -- ^ service, e.g. dynamodb+ -> B.ByteString+credentialV4 sd region service = B.concat+ [ accessKeyID (signatureCredentials sd)+ , "/"+ , date+ , "/"+ , region+ , "/"+ , service+ , "/aws4_request"+ ]+ where+ date = fmtTime "%Y%m%d" $ signatureTime sd++-- | Use this to create the Authorization header to set into 'sqAuthorization'.+-- See <http://docs.aws.amazon.com/general/latest/gr/signature-version-4.html>: you must create the+-- canonical request as explained by Step 1 and this function takes care of Steps 2 and 3.+authorizationV4 :: SignatureData+ -> AuthorizationHash+ -> B.ByteString -- ^ region, e.g. us-east-1+ -> B.ByteString -- ^ service, e.g. dynamodb+ -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target+ -> B.ByteString -- ^ canonicalRequest (before hashing)+ -> IO B.ByteString+authorizationV4 sd ah region service headers canonicalRequest = do+ let ref = v4SigningKeys $ signatureCredentials sd+ date = fmtTime "%Y%m%d" $ signatureTime sd++ -- Lookup existing signing key+ allkeys <- readIORef ref+ let mkey = case lookup (region,service) allkeys of+ Just (d,k) | d /= date -> Nothing+ | otherwise -> Just k+ Nothing -> Nothing++ -- possibly create a new signing key+ let createNewKey = atomicModifyIORef ref $ \keylist ->+ let kSigning = signingKeyV4 sd ah region service+ lstK = (region,service)+ keylist' = (lstK,(date,kSigning)) : filter ((lstK/=).fst) keylist+ in (keylist', kSigning)++ -- finally, return the header+ constructAuthorizationV4Header sd ah region service headers+ . signatureV4WithKey sd ah region service canonicalRequest+ <$> maybe createNewKey return mkey++-- | IO free version of @authorizationV4@, use this if you need+-- to compute the signature outside of IO.+authorizationV4'+ :: SignatureData+ -> AuthorizationHash+ -> B.ByteString -- ^ region, e.g. us-east-1+ -> B.ByteString -- ^ service, e.g. dynamodb+ -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target+ -> B.ByteString -- ^ canonicalRequest (before hashing)+ -> B.ByteString+authorizationV4' sd ah region service headers canonicalRequest+ = constructAuthorizationV4Header sd ah region service headers+ $ signatureV4 sd ah region service canonicalRequest++constructAuthorizationV4Header+ :: SignatureData+ -> AuthorizationHash+ -> B.ByteString -- ^ region, e.g. us-east-1+ -> B.ByteString -- ^ service, e.g. dynamodb+ -> B.ByteString -- ^ SignedHeaders, e.g. content-type;host;x-amz-date;x-amz-target+ -> B.ByteString -- ^ signature+ -> B.ByteString+constructAuthorizationV4Header sd ah region service headers sig = B.concat+ [ alg+ , " Credential="+ , credentialV4 sd region service+ , ",SignedHeaders="+ , headers+ , ",Signature="+ , sig+ ]+ where+ alg = case ah of+ HmacSHA1 -> "AWS4-HMAC-SHA1"+ HmacSHA256 -> "AWS4-HMAC-SHA256"++-- | Compute the signature for V4+signatureV4WithKey+ :: SignatureData+ -> AuthorizationHash+ -> B.ByteString -- ^ region, e.g. us-east-1+ -> B.ByteString -- ^ service, e.g. dynamodb+ -> B.ByteString -- ^ canonicalRequest (before hashing)+ -> B.ByteString -- ^ signing key+ -> B.ByteString+signatureV4WithKey sd ah region service canonicalRequest key = Base16.encode $ mkHmac key stringToSign+ where+ date = fmtTime "%Y%m%d" $ signatureTime sd+ mkHmac k i = case ah of+ HmacSHA1 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA1)+ HmacSHA256 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA256)+ mkHash i = case ah of+ HmacSHA1 -> ByteArray.convert (CH.hash i :: CH.Digest CH.SHA1)+ HmacSHA256 -> ByteArray.convert (CH.hash i :: CH.Digest CH.SHA256)+ alg = case ah of+ HmacSHA1 -> "AWS4-HMAC-SHA1"+ HmacSHA256 -> "AWS4-HMAC-SHA256"++ -- now do the signature+ canonicalRequestHash = Base16.encode $ mkHash canonicalRequest+ stringToSign = B.concat+ [ alg+ , "\n"+ , fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd+ , "\n"+ , date+ , "/"+ , region+ , "/"+ , service+ , "/aws4_request\n"+ , canonicalRequestHash+ ]++signingKeyV4+ :: SignatureData+ -> AuthorizationHash+ -> B.ByteString -- ^ region, e.g. us-east-1+ -> B.ByteString -- ^ service, e.g. dynamodb+ -> B.ByteString+signingKeyV4 sd ah region service = kSigning+ where+ mkHmac k i = case ah of+ HmacSHA1 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA1)+ HmacSHA256 -> ByteArray.convert (CMH.hmac k i :: CMH.HMAC CH.SHA256)+ date = fmtTime "%Y%m%d" $ signatureTime sd+ secretKey = secretAccessKey $ signatureCredentials sd+ kDate = mkHmac ("AWS4" <> secretKey) date+ kRegion = mkHmac kDate region+ kService = mkHmac kRegion service+ kSigning = mkHmac kService "aws4_request"++signatureV4+ :: SignatureData+ -> AuthorizationHash+ -> B.ByteString -- ^ region, e.g. us-east-1+ -> B.ByteString -- ^ service, e.g. dynamodb+ -> B.ByteString -- ^ canonicalRequest (before hashing)+ -> B.ByteString+signatureV4 sd ah region service canonicalRequest+ = signatureV4WithKey sd ah region service canonicalRequest+ $ signingKeyV4 sd ah region service+ -- | Default configuration for a specific service. class DefaultServiceConfiguration config where -- | Default service configuration.@@ -484,8 +782,9 @@ debugServiceConfig :: config debugServiceConfig = defServiceConfig --- | @queryList f prefix xs@ constructs a query list from a list of elements @xs@, using a common prefix @prefix@,--- and a transformer function @f@.+-- | @queryList f prefix xs@ constructs a query list from a list of+-- elements @xs@, using a common prefix @prefix@, and a transformer+-- function @f@. -- -- A dot (@.@) is interspersed between prefix and generated key. --@@ -517,7 +816,7 @@ fmtTime s t = BU.fromString $ formatTime defaultTimeLocale s t rfc822Time :: String-rfc822Time = "%a, %_d %b %Y %H:%M:%S GMT"+rfc822Time = "%a, %0d %b %Y %H:%M:%S GMT" -- | Format time in RFC 822 format. fmtRfc822Time :: UTCTime -> B.ByteString@@ -536,7 +835,9 @@ parseHttpDate s = p "%a, %d %b %Y %H:%M:%S GMT" s -- rfc1123-date <|> p "%A, %d-%b-%y %H:%M:%S GMT" s -- rfc850-date <|> p "%a %b %_d %H:%M:%S %Y" s -- asctime-date- where p = parseTime defaultTimeLocale+ <|> p "%Y-%m-%dT%H:%M:%S%QZ" s -- iso 8601+ <|> p "%Y-%m-%dT%H:%M:%S%Q%Z" s -- iso 8601+ where p = parseTimeM True defaultTimeLocale -- | HTTP-date (section 3.3.1 of RFC 2616, first type - RFC1123-style) httpDate1 :: String@@ -576,12 +877,26 @@ instance E.Exception HeaderException -- | An error that occurred during form parsing / validation.-newtype FormException = FormException { formErrorMesage :: String }+newtype FormException = FormException { formErrorMesage :: String } deriving (Show, Typeable) instance E.Exception FormException +-- | No credentials were found and an invariant was violated.+newtype NoCredentialsException = NoCredentialsException { noCredentialsErrorMessage :: String }+ deriving (Show, Typeable) +instance E.Exception NoCredentialsException++-- | A helper to throw an 'HTTP.StatusCodeException'.+throwStatusCodeException :: MonadThrow m => HTTP.Request -> HTTP.Response (C.ConduitM () ByteString m ()) -> m a+throwStatusCodeException req resp = do+ let resp' = fmap (const ()) resp+ -- only take first 10kB of error response+ body <- C.runConduit $ HTTP.responseBody resp .| CB.take (10*1024)+ let sce = HTTP.StatusCodeException resp' (L.toStrict body)+ throwM $ HTTP.HttpExceptionRequest req sce+ -- | A specific element (case-insensitive, ignoring namespace - sadly necessary), extracting only the textual contents. elContent :: T.Text -> Cursor -> [T.Text] elContent name = laxElement name &/ content@@ -591,24 +906,31 @@ elCont name = laxElement name &/ content &| T.unpack -- | Extract the first element from a parser result list, and throw an 'XmlException' if the list is empty.-force :: F.Failure XmlException m => String -> [a] -> m a+force :: MonadThrow m => String -> [a] -> m a force = Cu.force . XmlException -- | Extract the first element from a monadic parser result list, and throw an 'XmlException' if the list is empty.-forceM :: F.Failure XmlException m => String -> [m a] -> m a+forceM :: MonadThrow m => String -> [m a] -> m a forceM = Cu.forceM . XmlException +-- | Read a boolean from a 'T.Text', throwing an 'XmlException' on failure.+textReadBool :: MonadThrow m => T.Text -> m Bool+textReadBool s = case T.unpack s of+ "true" -> return True+ "false" -> return False+ _ -> throwM $ XmlException "Invalid Bool"+ -- | Read an integer from a 'T.Text', throwing an 'XmlException' on failure.-textReadInt :: (F.Failure XmlException m, Num a) => T.Text -> m a+textReadInt :: (MonadThrow m, Num a) => T.Text -> m a textReadInt s = case reads $ T.unpack s of [(n,"")] -> return $ fromInteger n- _ -> F.failure $ XmlException "Invalid Integer"+ _ -> throwM $ XmlException "Invalid Integer" -- | Read an integer from a 'String', throwing an 'XmlException' on failure.-readInt :: (F.Failure XmlException m, Num a) => String -> m a+readInt :: (MonadThrow m, Num a) => String -> m a readInt s = case reads s of [(n,"")] -> return $ fromInteger n- _ -> F.failure $ XmlException "Invalid Integer"+ _ -> throwM $ XmlException "Invalid Integer" -- | Create a complete 'HTTPResponseConsumer' from a simple function that takes a 'Cu.Cursor' to XML in the response -- body.@@ -621,10 +943,10 @@ -> IORef m -> HTTPResponseConsumer a xmlCursorConsumer parse metadataRef res- = do doc <- HTTP.responseBody res $$+- XML.sinkDoc XML.def+ = do doc <- C.runConduit $ HTTP.responseBody res .| XML.sinkDoc XML.def let cursor = Cu.fromDocument doc let Response metadata x = parse cursor liftIO $ tellMetadataRef metadataRef metadata case x of- Failure err -> liftIO $ C.monadThrow err- Success v -> return v+ Left err -> liftIO $ throwM err+ Right v -> return v
+ Aws/DynamoDb.hs view
@@ -0,0 +1,20 @@+-----------------------------------------------------------------------------+-- |+-- Module : Aws.DynaboDb+-- Copyright : Ozgun Ataman, Soostone Inc.+-- License : BSD3+--+-- Maintainer : Ozgun Ataman <oz@soostone.com>+-- Stability : experimental+--+----------------------------------------------------------------------------++module Aws.DynamoDb+ ( module Aws.DynamoDb.Core+ , module Aws.DynamoDb.Commands+ ) where++-------------------------------------------------------------------------------+import Aws.DynamoDb.Commands+import Aws.DynamoDb.Core+-------------------------------------------------------------------------------
+ Aws/DynamoDb/Commands.hs view
@@ -0,0 +1,23 @@+module Aws.DynamoDb.Commands+ ( module Aws.DynamoDb.Commands.BatchGetItem+ , module Aws.DynamoDb.Commands.BatchWriteItem+ , module Aws.DynamoDb.Commands.DeleteItem+ , module Aws.DynamoDb.Commands.GetItem+ , module Aws.DynamoDb.Commands.PutItem+ , module Aws.DynamoDb.Commands.Query+ , module Aws.DynamoDb.Commands.Scan+ , module Aws.DynamoDb.Commands.Table+ , module Aws.DynamoDb.Commands.UpdateItem+ ) where++-------------------------------------------------------------------------------+import Aws.DynamoDb.Commands.BatchGetItem+import Aws.DynamoDb.Commands.BatchWriteItem+import Aws.DynamoDb.Commands.DeleteItem+import Aws.DynamoDb.Commands.GetItem+import Aws.DynamoDb.Commands.PutItem+import Aws.DynamoDb.Commands.Query+import Aws.DynamoDb.Commands.Scan+import Aws.DynamoDb.Commands.Table+import Aws.DynamoDb.Commands.UpdateItem+-------------------------------------------------------------------------------
+ Aws/DynamoDb/Commands/BatchGetItem.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module : Aws.DynamoDb.Commands.BatchGetItem+-- Copyright : Soostone Inc+-- License : BSD3+--+-- Maintainer : Justin Dawson <jtdawso@gmail.com>+-- Stability : experimental+--+-- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_BatchGetItem.html@+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.BatchGetItem where++-------------------------------------------------------------------------------+import Control.Applicative+import Data.Aeson+import Data.Default+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Prelude+-------------------------------------------------------------------------------+import Aws.Core+import Aws.DynamoDb.Core+import Aws.DynamoDb.Commands.GetItem+-------------------------------------------------------------------------------+++data GetRequestItem = GetRequestItem{+ griProjExpr :: Maybe T.Text+ , griConsistent ::Bool+ , griKeys :: [PrimaryKey] + } deriving (Eq,Show,Read,Ord)++data BatchGetItem = BatchGetItem {+ bgRequests :: [(T.Text,GetRequestItem)]+ -- ^ Get Requests for a specified table+ , bgRetCons :: ReturnConsumption+ } deriving (Eq,Show,Read,Ord)++-------------------------------------------------------------------------------++-- | Construct a RequestItem .+batchGetRequestItem :: Maybe T.Text+ -- ^ Projection Expression+ -> Bool+ -- ^ Consistent Read+ -> [PrimaryKey]+ -- ^ Items to be deleted+ -> GetRequestItem+batchGetRequestItem expr consistent keys = GetRequestItem expr consistent keys++toBatchGet :: [GetItem] -> BatchGetItem+toBatchGet gs = BatchGetItem (convert gs) def++ where+ groupItems :: [GetItem]-> HM.HashMap T.Text [GetItem] -> HM.HashMap T.Text [GetItem]+ groupItems [] hm = hm+ groupItems (x:xs) hm = let key = giTableName x+ in groupItems xs (HM.insert key (x : (HM.lookupDefault [] key hm)) hm)+ + convert :: [GetItem] -> [(T.Text,GetRequestItem)] + convert gs' = let l = HM.toList $ groupItems gs' HM.empty+ -- Uses one GetItem to specify ProjectionExpression+ -- and ConsistentRead for the entire batch+ in map (\(table,items@(i:_)) ->(table,GetRequestItem + (T.intercalate "," <$> giAttrs i)+ (giConsistent i)+ (map giKey items)) ) l++-- | Construct a BatchGetItem+batchGetItem :: [(T.Text, GetRequestItem)]+ -> BatchGetItem+batchGetItem reqs = BatchGetItem reqs def+++instance ToJSON GetRequestItem where+ toJSON GetRequestItem{..} =+ (object $ maybe [] (return . ("ProjectionExpression" .=)) griProjExpr +++ ["ConsistentRead" .= griConsistent+ , "Keys" .= griKeys])+ ++instance ToJSON BatchGetItem where+ toJSON BatchGetItem{..} =+ object $+ [ "RequestItems" .= HM.fromList bgRequests+ , "ReturnConsumedCapacity" .= bgRetCons+ ]++instance FromJSON GetRequestItem where+ parseJSON (Object p) = do+ GetRequestItem <$> p .:? "ProjectionExpression"+ <*> p .: "ConsistentRead"+ <*> p .: "Keys"+ parseJSON _ = fail "unable to parse GetRequestItem"+ + +data BatchGetItemResponse = BatchGetItemResponse {+ bgResponses :: [(T.Text, [Item])]+ , bgUnprocessed :: Maybe [(T.Text,GetRequestItem)]+ -- ^ Unprocessed Requests on failure+ , bgConsumed :: Maybe ConsumedCapacity+ -- ^ Amount of capacity consumed+ } deriving (Eq,Show,Read,Ord)++++instance Transaction BatchGetItem BatchGetItemResponse+++instance SignQuery BatchGetItem where+ type ServiceConfiguration BatchGetItem = DdbConfiguration+ signQuery gi = ddbSignQuery "BatchGetItem" gi+++instance FromJSON BatchGetItemResponse where+ parseJSON (Object v) = BatchGetItemResponse+ <$> (HM.toList <$> (v .: "Responses"))+ <*> v .:? "UnprocessedItems"+ <*> v .:? "ConsumedCapacity"++ parseJSON _ = fail "BatchGetItemResponse must be an object."++instance ResponseConsumer r BatchGetItemResponse where+ type ResponseMetadata BatchGetItemResponse = DdbResponse+ responseConsumer _ _ ref resp = ddbResponseConsumer ref resp++instance AsMemoryResponse BatchGetItemResponse where+ type MemoryResponse BatchGetItemResponse = BatchGetItemResponse+ loadToMemory = return++
+ Aws/DynamoDb/Commands/BatchWriteItem.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module : Aws.DynamoDb.Commands.BatchWriteItem+-- Copyright : Soostone Inc+-- License : BSD3+--+-- Maintainer : Justin Dawson <jtdawso@gmail.com>+-- Stability : experimental+--+-- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_BatchWriteItem.html@+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.BatchWriteItem where++-------------------------------------------------------------------------------+import Control.Applicative+import Data.Aeson+import Data.Default+import qualified Data.Foldable as F (asum)+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Prelude+-------------------------------------------------------------------------------+import Aws.Core+import Aws.DynamoDb.Core+import Aws.DynamoDb.Commands.PutItem+import Aws.DynamoDb.Commands.DeleteItem+-------------------------------------------------------------------------------+++data Request = PutRequest { prItem :: Item }+ | DeleteRequest {drKey :: PrimaryKey}+ deriving (Eq,Show,Read,Ord)++data BatchWriteItem = BatchWriteItem {+ bwRequests :: [(T.Text,[Request])]+ -- ^ Put or Delete Requests for a specified table+ , bwRetCons :: ReturnConsumption+ , bwRetMet :: ReturnItemCollectionMetrics+ } deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------++toBatchWrite :: [PutItem]+ -> [DeleteItem]+ -> BatchWriteItem+toBatchWrite ps ds =BatchWriteItem maps def def + where+ maps :: [(T.Text,[Request])]+ maps = let pMap = foldl (\acc p -> let key = piTable p+ in HM.insert key (PutRequest (piItem p) : (HM.lookupDefault [] key acc)) acc) HM.empty ps + totalMap = foldl (\acc d -> let key = diTable d+ in HM.insert key (DeleteRequest (diKey d) : (HM.lookupDefault [] key acc)) acc) pMap ds+ in HM.toList totalMap+-- | Construct a BatchWriteItem+batchWriteItem :: [(T.Text,[Request])]+ -> BatchWriteItem+batchWriteItem reqs = BatchWriteItem reqs def def+++instance ToJSON Request where+ toJSON PutRequest{..} =+ object $+ [ "PutRequest" .= (object $ ["Item" .= prItem])+ ]+ toJSON DeleteRequest{..} =+ object $+ [ "DeleteRequest" .= (object $ ["Key" .= drKey])+ ]++instance ToJSON BatchWriteItem where+ toJSON BatchWriteItem{..} =+ object $+ [ "RequestItems" .= HM.fromList bwRequests+ , "ReturnConsumedCapacity" .= bwRetCons+ , "ReturnItemCollectionMetrics" .= bwRetMet+ ]++instance FromJSON Request where+ parseJSON = withObject "PutRequest or DeleteRequest" $ \o ->+ + F.asum [+ do+ pr <- o .: "PutRequest"+ i <- pr .: "Item"+ return $ PutRequest i ,+ do+ dr <- o .: "DeleteRequest"+ pk <- dr .: "Key"+ return $ DeleteRequest pk+ ]+ +data BatchWriteItemResponse = BatchWriteItemResponse {+ bwUnprocessed :: [(T.Text,[Request])]+ -- ^ Unprocessed Requests on failure+ , bwConsumed :: Maybe ConsumedCapacity+ -- ^ Amount of capacity consumed+ , bwColMet :: Maybe ItemCollectionMetrics+ -- ^ Collection metrics for tables affected by BatchWriteItem.+ } deriving (Eq,Show,Read,Ord)++++instance Transaction BatchWriteItem BatchWriteItemResponse+++instance SignQuery BatchWriteItem where+ type ServiceConfiguration BatchWriteItem = DdbConfiguration+ signQuery gi = ddbSignQuery "BatchWriteItem" gi+++instance FromJSON BatchWriteItemResponse where+ parseJSON (Object v) = BatchWriteItemResponse+ <$> HM.toList <$> (v .: "UnprocessedItems")+ <*> v .:? "ConsumedCapacity"+ <*> v .:? "ItemCollectionMetrics"+ parseJSON _ = fail "BatchWriteItemResponse must be an object."+++instance ResponseConsumer r BatchWriteItemResponse where+ type ResponseMetadata BatchWriteItemResponse = DdbResponse+ responseConsumer _ _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse BatchWriteItemResponse where+ type MemoryResponse BatchWriteItemResponse = BatchWriteItemResponse+ loadToMemory = return
+ Aws/DynamoDb/Commands/DeleteItem.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module : Aws.DynamoDb.Commands.DeleteItem+-- Copyright : Soostone Inc+-- License : BSD3+--+-- Maintainer : Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability : experimental+--+-- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_DeleteItem.html@+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.DeleteItem where++-------------------------------------------------------------------------------+import Control.Applicative+import Data.Aeson+import Data.Default+import qualified Data.Text as T+import Prelude+-------------------------------------------------------------------------------+import Aws.Core+import Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++data DeleteItem = DeleteItem {+ diTable :: T.Text+ -- ^ Target table+ , diKey :: PrimaryKey+ -- ^ The item to delete.+ , diExpect :: Conditions+ -- ^ (Possible) set of exceptions for a conditional Put+ , diReturn :: UpdateReturn+ -- ^ What to return from this query.+ , diRetCons :: ReturnConsumption+ , diRetMet :: ReturnItemCollectionMetrics+ } deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------+-- | Construct a minimal 'DeleteItem' request.+deleteItem :: T.Text+ -- ^ A Dynamo table name+ -> PrimaryKey+ -- ^ Item to be saved+ -> DeleteItem+deleteItem tn key = DeleteItem tn key def def def def+++instance ToJSON DeleteItem where+ toJSON DeleteItem{..} =+ object $ expectsJson diExpect +++ [ "TableName" .= diTable+ , "Key" .= diKey+ , "ReturnValues" .= diReturn+ , "ReturnConsumedCapacity" .= diRetCons+ , "ReturnItemCollectionMetrics" .= diRetMet+ ]++++data DeleteItemResponse = DeleteItemResponse {+ dirAttrs :: Maybe Item+ -- ^ Old attributes, if requested+ , dirConsumed :: Maybe ConsumedCapacity+ -- ^ Amount of capacity consumed+ , dirColMet :: Maybe ItemCollectionMetrics+ -- ^ Collection metrics if they have been requested.+ } deriving (Eq,Show,Read,Ord)++++instance Transaction DeleteItem DeleteItemResponse+++instance SignQuery DeleteItem where+ type ServiceConfiguration DeleteItem = DdbConfiguration+ signQuery gi = ddbSignQuery "DeleteItem" gi+++instance FromJSON DeleteItemResponse where+ parseJSON (Object v) = DeleteItemResponse+ <$> v .:? "Attributes"+ <*> v .:? "ConsumedCapacity"+ <*> v .:? "ItemCollectionMetrics"+ parseJSON _ = fail "DeleteItemResponse must be an object."+++instance ResponseConsumer r DeleteItemResponse where+ type ResponseMetadata DeleteItemResponse = DdbResponse+ responseConsumer _ _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse DeleteItemResponse where+ type MemoryResponse DeleteItemResponse = DeleteItemResponse+ loadToMemory = return++++++++
+ Aws/DynamoDb/Commands/GetItem.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module : Aws.DynamoDb.Commands.GetItem+-- Copyright : Soostone Inc+-- License : BSD3+--+-- Maintainer : Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability : experimental+--+--+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.GetItem where++-------------------------------------------------------------------------------+import Control.Applicative+import Data.Aeson+import Data.Default+import qualified Data.Text as T+import Prelude+-------------------------------------------------------------------------------+import Aws.Core+import Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++-- | A GetItem query that fetches a specific object from DDB.+--+-- See: @http://docs.aws.amazon.com/amazondynamodb/latest/developerguide/API_GetItem.html@+data GetItem = GetItem {+ giTableName :: T.Text+ , giKey :: PrimaryKey+ , giAttrs :: Maybe [T.Text]+ -- ^ Attributes to get. 'Nothing' grabs everything.+ , giConsistent :: Bool+ -- ^ Whether to issue a consistent read.+ , giRetCons :: ReturnConsumption+ -- ^ Whether to return consumption stats.+ } deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------+-- | Construct a minimal 'GetItem' request.+getItem+ :: T.Text -- ^ Table name+ -> PrimaryKey -- ^ Primary key+ -> GetItem+getItem tn k = GetItem tn k Nothing False def+++-- | Response to a 'GetItem' query.+data GetItemResponse = GetItemResponse {+ girItem :: Maybe Item+ , girConsumed :: Maybe ConsumedCapacity+ } deriving (Eq,Show,Read,Ord)+++instance Transaction GetItem GetItemResponse+++instance ToJSON GetItem where+ toJSON GetItem{..} = object $+ maybe [] (return . ("AttributesToGet" .=)) giAttrs +++ [ "TableName" .= giTableName+ , "Key" .= giKey+ , "ConsistentRead" .= giConsistent+ , "ReturnConsumedCapacity" .= giRetCons+ ]+++instance SignQuery GetItem where+ type ServiceConfiguration GetItem = DdbConfiguration+ signQuery gi = ddbSignQuery "GetItem" gi++++instance FromJSON GetItemResponse where+ parseJSON (Object v) = GetItemResponse+ <$> v .:? "Item"+ <*> v .:? "ConsumedCapacity"+ parseJSON _ = fail "GetItemResponse must be an object."+++instance ResponseConsumer r GetItemResponse where+ type ResponseMetadata GetItemResponse = DdbResponse+ responseConsumer _ _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse GetItemResponse where+ type MemoryResponse GetItemResponse = GetItemResponse+ loadToMemory = return
+ Aws/DynamoDb/Commands/PutItem.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module : Aws.DynamoDb.Commands.GetItem+-- Copyright : Soostone Inc+-- License : BSD3+--+-- Maintainer : Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability : experimental+--+-- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_PutItem.html@+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.PutItem where++-------------------------------------------------------------------------------+import Control.Applicative+import Data.Aeson+import Data.Default+import qualified Data.Text as T+import Prelude+-------------------------------------------------------------------------------+import Aws.Core+import Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++data PutItem = PutItem {+ piTable :: T.Text+ -- ^ Target table+ , piItem :: Item+ -- ^ An item to Put. Attributes here will replace what maybe under+ -- the key on DDB.+ , piExpect :: Conditions+ -- ^ (Possible) set of exceptions for a conditional Put+ , piReturn :: UpdateReturn+ -- ^ What to return from this query.+ , piRetCons :: ReturnConsumption+ , piRetMet :: ReturnItemCollectionMetrics+ } deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------+-- | Construct a minimal 'PutItem' request.+putItem :: T.Text+ -- ^ A Dynamo table name+ -> Item+ -- ^ Item to be saved+ -> PutItem+putItem tn it = PutItem tn it def def def def+++instance ToJSON PutItem where+ toJSON PutItem{..} =+ object $ expectsJson piExpect +++ [ "TableName" .= piTable+ , "Item" .= piItem+ , "ReturnValues" .= piReturn+ , "ReturnConsumedCapacity" .= piRetCons+ , "ReturnItemCollectionMetrics" .= piRetMet+ ]++++data PutItemResponse = PutItemResponse {+ pirAttrs :: Maybe Item+ -- ^ Old attributes, if requested+ , pirConsumed :: Maybe ConsumedCapacity+ -- ^ Amount of capacity consumed+ , pirColMet :: Maybe ItemCollectionMetrics+ -- ^ Collection metrics if they have been requested.+ } deriving (Eq,Show,Read,Ord)++++instance Transaction PutItem PutItemResponse+++instance SignQuery PutItem where+ type ServiceConfiguration PutItem = DdbConfiguration+ signQuery gi = ddbSignQuery "PutItem" gi+++instance FromJSON PutItemResponse where+ parseJSON (Object v) = PutItemResponse+ <$> v .:? "Attributes"+ <*> v .:? "ConsumedCapacity"+ <*> v .:? "ItemCollectionMetrics"+ parseJSON _ = fail "PutItemResponse must be an object."+++instance ResponseConsumer r PutItemResponse where+ type ResponseMetadata PutItemResponse = DdbResponse+ responseConsumer _ _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse PutItemResponse where+ type MemoryResponse PutItemResponse = PutItemResponse+ loadToMemory = return++++++++
+ Aws/DynamoDb/Commands/Query.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module : Aws.DynamoDb.Commands.Query+-- Copyright : Soostone Inc+-- License : BSD3+--+-- Maintainer : Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability : experimental+--+-- Implementation of Amazon DynamoDb Query command.+--+-- See: @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_Query.html@+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.Query+ ( Query (..)+ , Slice (..)+ , query+ , QueryResponse (..)+ ) where++-------------------------------------------------------------------------------+import Control.Applicative+import Data.Aeson+import Data.Default+import Data.Maybe+import qualified Data.Text as T+import Data.Typeable+import qualified Data.Vector as V+-------------------------------------------------------------------------------+import Aws.Core+import Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++-------------------------------------------------------------------------------+-- | 'Slice' is the primary constraint in a 'Query' command, per AWS+-- requirements.+--+-- All 'Query' commands must specify a hash attribute via 'DEq' and+-- optionally provide a secondary range attribute.+data Slice = Slice {+ sliceHash :: Attribute+ -- ^ Hash value of the primary key or index being used+ , sliceCond :: Maybe Condition+ -- ^ An optional condition specified on the range component, if+ -- present, of the primary key or index being used.+ } deriving (Eq,Show,Read,Ord,Typeable)++++-- | A Query command that uses primary keys for an expedient scan.+data Query = Query {+ qTableName :: T.Text+ -- ^ Required.+ , qKeyConditions :: Slice+ -- ^ Required. Hash or hash-range main condition.+ , qFilter :: Conditions+ -- ^ Whether to filter results before returning to client+ , qStartKey :: Maybe [Attribute]+ -- ^ Exclusive start key to resume a previous query.+ , qLimit :: Maybe Int+ -- ^ Whether to limit result set size+ , qForwardScan :: Bool+ -- ^ Set to False for descending results+ , qSelect :: QuerySelect+ -- ^ What to return from 'Query'+ , qRetCons :: ReturnConsumption+ , qIndex :: Maybe T.Text+ -- ^ Whether to use a secondary/global index+ , qConsistent :: Bool+ } deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+instance ToJSON Query where+ toJSON Query{..} = object $+ catMaybes+ [ (("ExclusiveStartKey" .= ) . attributesJson) <$> qStartKey+ , ("Limit" .= ) <$> qLimit+ , ("IndexName" .= ) <$> qIndex+ ] +++ conditionsJson "QueryFilter" qFilter +++ querySelectJson qSelect +++ [ "ScanIndexForward" .= qForwardScan+ , "TableName".= qTableName+ , "KeyConditions" .= sliceJson qKeyConditions+ , "ReturnConsumedCapacity" .= qRetCons+ , "ConsistentRead" .= qConsistent+ ]+++-------------------------------------------------------------------------------+-- | Construct a minimal 'Query' request.+query+ :: T.Text+ -- ^ Table name+ -> Slice+ -- ^ Primary key slice for query+ -> Query+query tn sl = Query tn sl def Nothing Nothing True def def Nothing False+++-- | Response to a 'Query' query.+data QueryResponse = QueryResponse {+ qrItems :: V.Vector Item+ , qrLastKey :: Maybe [Attribute]+ , qrCount :: Int+ , qrScanned :: Int+ , qrConsumed :: Maybe ConsumedCapacity+ } deriving (Eq,Show,Read,Ord)+++instance FromJSON QueryResponse where+ parseJSON (Object v) = QueryResponse+ <$> v .:? "Items" .!= V.empty+ <*> ((do o <- v .: "LastEvaluatedKey"+ Just <$> parseAttributeJson o)+ <|> pure Nothing)+ <*> v .: "Count"+ <*> v .: "ScannedCount"+ <*> v .:? "ConsumedCapacity"+ parseJSON _ = fail "QueryResponse must be an object."+++instance Transaction Query QueryResponse+++instance SignQuery Query where+ type ServiceConfiguration Query = DdbConfiguration+ signQuery gi = ddbSignQuery "Query" gi+++instance ResponseConsumer r QueryResponse where+ type ResponseMetadata QueryResponse = DdbResponse+ responseConsumer _ _ ref resp+ = ddbResponseConsumer ref resp+++instance AsMemoryResponse QueryResponse where+ type MemoryResponse QueryResponse = QueryResponse+ loadToMemory = return+++instance ListResponse QueryResponse Item where+ listResponse = V.toList . qrItems+++instance IteratedTransaction Query QueryResponse where+ nextIteratedRequest request response = case qrLastKey response of+ Nothing -> Nothing+ key -> Just request { qStartKey = key }+++sliceJson :: Slice -> Value+sliceJson Slice{..} = object (map conditionJson cs)+ where+ cs = maybe [] return sliceCond ++ [hashCond]+ hashCond = Condition (attrName sliceHash) (DEq (attrVal sliceHash))
+ Aws/DynamoDb/Commands/Scan.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module : Aws.DynamoDb.Commands.Scan+-- Copyright : Soostone Inc+-- License : BSD3+--+-- Maintainer : Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability : experimental+--+-- Implementation of Amazon DynamoDb Scan command.+--+-- See: @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_Scan.html@+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.Scan+ ( Scan (..)+ , scan+ , ScanResponse (..)+ ) where++-------------------------------------------------------------------------------+import Control.Applicative+import Data.Aeson+import Data.Default+import Data.Maybe+import qualified Data.Text as T+import Data.Typeable+import qualified Data.Vector as V+-------------------------------------------------------------------------------+import Aws.Core+import Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++-- | A Scan command that uses primary keys for an expedient scan.+data Scan = Scan {+ sTableName :: T.Text+ -- ^ Required.+ , sConsistentRead :: Bool+ -- ^ Whether to require a consistent read+ , sFilter :: Conditions+ -- ^ Whether to filter results before returning to client+ , sStartKey :: Maybe [Attribute]+ -- ^ Exclusive start key to resume a previous query.+ , sLimit :: Maybe Int+ -- ^ Whether to limit result set size+ , sIndex :: Maybe T.Text+ -- ^ Optional. Index to 'Scan'+ , sSelect :: QuerySelect+ -- ^ What to return from 'Scan'+ , sRetCons :: ReturnConsumption+ , sSegment :: Int+ -- ^ Segment number, starting at 0, for parallel queries.+ , sTotalSegments :: Int+ -- ^ Total number of parallel segments. 1 means sequential scan.+ } deriving (Eq,Show,Read,Ord,Typeable)+++-- | Construct a minimal 'Scan' request.+scan :: T.Text -- ^ Table name+ -> Scan+scan tn = Scan tn False def Nothing Nothing Nothing def def 0 1+++-- | Response to a 'Scan' query.+data ScanResponse = ScanResponse {+ srItems :: V.Vector Item+ , srLastKey :: Maybe [Attribute]+ , srCount :: Int+ , srScanned :: Int+ , srConsumed :: Maybe ConsumedCapacity+ } deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------+instance ToJSON Scan where+ toJSON Scan{..} = object $+ catMaybes+ [ (("ExclusiveStartKey" .= ) . attributesJson) <$> sStartKey+ , ("Limit" .= ) <$> sLimit+ , ("IndexName" .= ) <$> sIndex+ ] +++ conditionsJson "ScanFilter" sFilter +++ querySelectJson sSelect +++ [ "TableName".= sTableName+ , "ReturnConsumedCapacity" .= sRetCons+ , "Segment" .= sSegment+ , "TotalSegments" .= sTotalSegments+ , "ConsistentRead" .= sConsistentRead+ ]+++instance FromJSON ScanResponse where+ parseJSON (Object v) = ScanResponse+ <$> v .:? "Items" .!= V.empty+ <*> ((do o <- v .: "LastEvaluatedKey"+ Just <$> parseAttributeJson o)+ <|> pure Nothing)+ <*> v .: "Count"+ <*> v .: "ScannedCount"+ <*> v .:? "ConsumedCapacity"+ parseJSON _ = fail "ScanResponse must be an object."+++instance Transaction Scan ScanResponse+++instance SignQuery Scan where+ type ServiceConfiguration Scan = DdbConfiguration+ signQuery gi = ddbSignQuery "Scan" gi+++instance ResponseConsumer r ScanResponse where+ type ResponseMetadata ScanResponse = DdbResponse+ responseConsumer _ _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse ScanResponse where+ type MemoryResponse ScanResponse = ScanResponse+ loadToMemory = return++instance ListResponse ScanResponse Item where+ listResponse = V.toList . srItems++instance IteratedTransaction Scan ScanResponse where+ nextIteratedRequest request response =+ case srLastKey response of+ Nothing -> Nothing+ key -> Just request { sStartKey = key }
+ Aws/DynamoDb/Commands/Table.hs view
@@ -0,0 +1,473 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Aws.DynamoDb.Commands.Table+ ( -- * Commands+ CreateTable(..)+ , createTable+ , CreateTableResult(..)+ , DescribeTable(..)+ , DescribeTableResult(..)+ , UpdateTable(..)+ , UpdateTableResult(..)+ , DeleteTable(..)+ , DeleteTableResult(..)+ , ListTables(..)+ , ListTablesResult(..)++ -- * Data passed in the commands+ , AttributeType(..)+ , AttributeDefinition(..)+ , KeySchema(..)+ , Projection(..)+ , LocalSecondaryIndex(..)+ , LocalSecondaryIndexStatus(..)+ , ProvisionedThroughput(..)+ , ProvisionedThroughputStatus(..)+ , GlobalSecondaryIndex(..)+ , GlobalSecondaryIndexStatus(..)+ , GlobalSecondaryIndexUpdate(..)+ , TableDescription(..)+ ) where++-------------------------------------------------------------------------------+import Control.Applicative+import Data.Aeson ((.!=), (.:), (.:?), (.=))+import qualified Data.Aeson as A+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Aeson.Types as A+import Data.Char (toUpper)+import Data.Scientific (Scientific)+import qualified Data.Text as T+import Data.Time+import Data.Time.Clock.POSIX+import Data.Typeable+import qualified Data.Vector as V+import GHC.Generics (Generic)+import Prelude+-------------------------------------------------------------------------------+import Aws.Core+import Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++capitalizeOpt :: A.Options+capitalizeOpt = A.defaultOptions+ { A.fieldLabelModifier = \x -> case x of+ (c:cs) -> toUpper c : cs+ [] -> []+ }+++dropOpt :: Int -> A.Options+dropOpt d = A.defaultOptions { A.fieldLabelModifier = drop d }+++convertToUTCTime :: Scientific -> UTCTime+convertToUTCTime = posixSecondsToUTCTime . fromInteger . round+++-- | The type of a key attribute that appears in the table key or as a+-- key in one of the indices.+data AttributeType = AttrString | AttrNumber | AttrBinary+ deriving (Show, Read, Ord, Typeable, Eq, Enum, Bounded, Generic)++instance A.ToJSON AttributeType where+ toJSON AttrString = A.String "S"+ toJSON AttrNumber = A.String "N"+ toJSON AttrBinary = A.String "B"++instance A.FromJSON AttributeType where+ parseJSON (A.String str) =+ case str of+ "S" -> return AttrString+ "N" -> return AttrNumber+ "B" -> return AttrBinary+ _ -> fail $ "Invalid attribute type " ++ T.unpack str+ parseJSON _ = fail "Attribute type must be a string"++-- | A key attribute that appears in the table key or as a key in one of the indices.+data AttributeDefinition = AttributeDefinition {+ attributeName :: T.Text+ , attributeType :: AttributeType+ } deriving (Eq,Read,Ord,Show,Typeable,Generic)++instance A.ToJSON AttributeDefinition where+ toJSON = A.genericToJSON capitalizeOpt++instance A.FromJSON AttributeDefinition where+ parseJSON = A.genericParseJSON capitalizeOpt++-- | The key schema can either be a hash of a single attribute name or a hash attribute name+-- and a range attribute name.+data KeySchema = HashOnly T.Text+ | HashAndRange T.Text T.Text+ deriving (Eq,Read,Show,Ord,Typeable,Generic)+++instance A.ToJSON KeySchema where+ toJSON (HashOnly a)+ = A.Array $ V.fromList [ A.object [ "AttributeName" .= a+ , "KeyType" .= (A.String "HASH")+ ]+ ]++ toJSON (HashAndRange hash range)+ = A.Array $ V.fromList [ A.object [ "AttributeName" .= hash+ , "KeyType" .= (A.String "HASH")+ ]+ , A.object [ "AttributeName" .= range+ , "KeyType" .= (A.String "RANGE")+ ]+ ]++instance A.FromJSON KeySchema where+ parseJSON (A.Array v) =+ case V.length v of+ 1 -> do obj <- A.parseJSON (v V.! 0)+ kt <- obj .: "KeyType"+ if kt /= ("HASH" :: T.Text)+ then fail "With only one key, the type must be HASH"+ else HashOnly <$> obj .: "AttributeName"++ 2 -> do hash <- A.parseJSON (v V.! 0)+ range <- A.parseJSON (v V.! 1)+ hkt <- hash .: "KeyType"+ rkt <- range .: "KeyType"+ if hkt /= ("HASH" :: T.Text) || rkt /= ("RANGE" :: T.Text)+ then fail "With two keys, one must be HASH and the other RANGE"+ else HashAndRange <$> hash .: "AttributeName"+ <*> range .: "AttributeName"+ _ -> fail "Key schema must have one or two entries"+ parseJSON _ = fail "Key schema must be an array"++-- | This determines which attributes are projected into a secondary index.+data Projection = ProjectKeysOnly+ | ProjectAll+ | ProjectInclude [T.Text]+ deriving Show+instance A.ToJSON Projection where+ toJSON ProjectKeysOnly = A.object [ "ProjectionType" .= ("KEYS_ONLY" :: T.Text) ]+ toJSON ProjectAll = A.object [ "ProjectionType" .= ("ALL" :: T.Text) ]+ toJSON (ProjectInclude a) = A.object [ "ProjectionType" .= ("INCLUDE" :: T.Text)+ , "NonKeyAttributes" .= a+ ]+instance A.FromJSON Projection where+ parseJSON (A.Object o) = do+ ty <- (o .: "ProjectionType") :: A.Parser T.Text+ case ty of+ "KEYS_ONLY" -> return ProjectKeysOnly+ "ALL" -> return ProjectAll+ "INCLUDE" -> ProjectInclude <$> o .: "NonKeyAttributes"+ _ -> fail "Invalid projection type"+ parseJSON _ = fail "Projection must be an object"++-- | Describes a single local secondary index. The KeySchema MUST+-- share the same hash key attribute as the parent table, only the+-- range key can differ.+data LocalSecondaryIndex+ = LocalSecondaryIndex {+ localIndexName :: T.Text+ , localKeySchema :: KeySchema+ , localProjection :: Projection+ }+ deriving (Show, Generic)+instance A.ToJSON LocalSecondaryIndex where+ toJSON = A.genericToJSON $ dropOpt 5+instance A.FromJSON LocalSecondaryIndex where+ parseJSON = A.genericParseJSON $ dropOpt 5++-- | This is returned by AWS to describe the local secondary index.+data LocalSecondaryIndexStatus+ = LocalSecondaryIndexStatus {+ locStatusIndexName :: T.Text+ , locStatusIndexSizeBytes :: Integer+ , locStatusItemCount :: Integer+ , locStatusKeySchema :: KeySchema+ , locStatusProjection :: Projection+ }+ deriving (Show, Generic)+instance A.FromJSON LocalSecondaryIndexStatus where+ parseJSON = A.genericParseJSON $ dropOpt 9++-- | The target provisioned throughput you are requesting for the table or global secondary index.+data ProvisionedThroughput+ = ProvisionedThroughput {+ readCapacityUnits :: Int+ , writeCapacityUnits :: Int+ }+ deriving (Show, Generic)+instance A.ToJSON ProvisionedThroughput where+ toJSON = A.genericToJSON capitalizeOpt+instance A.FromJSON ProvisionedThroughput where+ parseJSON = A.genericParseJSON capitalizeOpt++-- | This is returned by AWS as the status of the throughput for a table or global secondary index.+data ProvisionedThroughputStatus+ = ProvisionedThroughputStatus {+ statusLastDecreaseDateTime :: UTCTime+ , statusLastIncreaseDateTime :: UTCTime+ , statusNumberOfDecreasesToday :: Int+ , statusReadCapacityUnits :: Int+ , statusWriteCapacityUnits :: Int+ }+ deriving (Show, Generic)+instance A.FromJSON ProvisionedThroughputStatus where+ parseJSON = A.withObject "Throughput status must be an object" $ \o ->+ ProvisionedThroughputStatus+ <$> (convertToUTCTime <$> o .:? "LastDecreaseDateTime" .!= 0)+ <*> (convertToUTCTime <$> o .:? "LastIncreaseDateTime" .!= 0)+ <*> o .:? "NumberOfDecreasesToday" .!= 0+ <*> o .: "ReadCapacityUnits"+ <*> o .: "WriteCapacityUnits"++-- | Describes a global secondary index.+data GlobalSecondaryIndex+ = GlobalSecondaryIndex {+ globalIndexName :: T.Text+ , globalKeySchema :: KeySchema+ , globalProjection :: Projection+ , globalProvisionedThroughput :: ProvisionedThroughput+ }+ deriving (Show, Generic)+instance A.ToJSON GlobalSecondaryIndex where+ toJSON = A.genericToJSON $ dropOpt 6+instance A.FromJSON GlobalSecondaryIndex where+ parseJSON = A.genericParseJSON $ dropOpt 6++-- | This is returned by AWS to describe the status of a global secondary index.+data GlobalSecondaryIndexStatus+ = GlobalSecondaryIndexStatus {+ gStatusIndexName :: T.Text+ , gStatusIndexSizeBytes :: Integer+ , gStatusIndexStatus :: T.Text+ , gStatusItemCount :: Integer+ , gStatusKeySchema :: KeySchema+ , gStatusProjection :: Projection+ , gStatusProvisionedThroughput :: ProvisionedThroughputStatus+ }+ deriving (Show, Generic)+instance A.FromJSON GlobalSecondaryIndexStatus where+ parseJSON = A.genericParseJSON $ dropOpt 7++-- | This is used to request a change in the provisioned throughput of+-- a global secondary index as part of an 'UpdateTable' operation.+data GlobalSecondaryIndexUpdate+ = GlobalSecondaryIndexUpdate {+ gUpdateIndexName :: T.Text+ , gUpdateProvisionedThroughput :: ProvisionedThroughput+ }+ deriving (Show, Generic)+instance A.ToJSON GlobalSecondaryIndexUpdate where+ toJSON gi = A.object ["Update" .= A.genericToJSON (dropOpt 7) gi]++-- | This describes the table and is the return value from AWS for all+-- the table-related commands.+data TableDescription+ = TableDescription {+ rTableName :: T.Text+ , rTableSizeBytes :: Integer+ , rTableStatus :: T.Text -- ^ one of CREATING, UPDATING, DELETING, ACTIVE+ , rCreationDateTime :: Maybe UTCTime+ , rItemCount :: Integer+ , rAttributeDefinitions :: [AttributeDefinition]+ , rKeySchema :: Maybe KeySchema+ , rProvisionedThroughput :: ProvisionedThroughputStatus+ , rLocalSecondaryIndexes :: [LocalSecondaryIndexStatus]+ , rGlobalSecondaryIndexes :: [GlobalSecondaryIndexStatus]+ }+ deriving (Show, Generic)++instance A.FromJSON TableDescription where+ parseJSON = A.withObject "Table must be an object" $ \o -> do+ t <- case (KM.lookup "Table" o, KM.lookup "TableDescription" o) of+ (Just (A.Object t), _) -> return t+ (_, Just (A.Object t)) -> return t+ _ -> fail "Table description must have key 'Table' or 'TableDescription'"+ TableDescription <$> t .: "TableName"+ <*> t .: "TableSizeBytes"+ <*> t .: "TableStatus"+ <*> (fmap convertToUTCTime <$> t .:? "CreationDateTime")+ <*> t .: "ItemCount"+ <*> t .:? "AttributeDefinitions" .!= []+ <*> t .:? "KeySchema"+ <*> t .: "ProvisionedThroughput"+ <*> t .:? "LocalSecondaryIndexes" .!= []+ <*> t .:? "GlobalSecondaryIndexes" .!= []++{- Can't derive these instances onto the return values+instance ResponseConsumer r TableDescription where+ type ResponseMetadata TableDescription = DyMetadata+ responseConsumer _ _ _ = ddbResponseConsumer+instance AsMemoryResponse TableDescription where+ type MemoryResponse TableDescription = TableDescription+ loadToMemory = return+-}++-------------------------------------------------------------------------------+--- Commands+-------------------------------------------------------------------------------++data CreateTable = CreateTable {+ createTableName :: T.Text+ , createAttributeDefinitions :: [AttributeDefinition]+ -- ^ only attributes appearing in a key must be listed here+ , createKeySchema :: KeySchema+ , createProvisionedThroughput :: ProvisionedThroughput+ , createLocalSecondaryIndexes :: [LocalSecondaryIndex]+ -- ^ at most 5 local secondary indices are allowed+ , createGlobalSecondaryIndexes :: [GlobalSecondaryIndex]+ } deriving (Show, Generic)++createTable :: T.Text -- ^ Table name+ -> [AttributeDefinition]+ -> KeySchema+ -> ProvisionedThroughput+ -> CreateTable+createTable tn ad ks p = CreateTable tn ad ks p [] []++instance A.ToJSON CreateTable where+ toJSON ct = A.object $ m ++ lindex ++ gindex+ where+ m = [ "TableName" .= createTableName ct+ , "AttributeDefinitions" .= createAttributeDefinitions ct+ , "KeySchema" .= createKeySchema ct+ , "ProvisionedThroughput" .= createProvisionedThroughput ct+ ]+ -- AWS will error with 500 if (LocalSecondaryIndexes : []) is present in the JSON+ lindex = if null (createLocalSecondaryIndexes ct)+ then []+ else [ "LocalSecondaryIndexes" .= createLocalSecondaryIndexes ct ]+ gindex = if null (createGlobalSecondaryIndexes ct)+ then []+ else [ "GlobalSecondaryIndexes" .= createGlobalSecondaryIndexes ct ]++--instance A.ToJSON CreateTable where+-- toJSON = A.genericToJSON $ dropOpt 6+++-- | ServiceConfiguration: 'DdbConfiguration'+instance SignQuery CreateTable where+ type ServiceConfiguration CreateTable = DdbConfiguration+ signQuery = ddbSignQuery "CreateTable"++newtype CreateTableResult = CreateTableResult { ctStatus :: TableDescription }+ deriving (Show, A.FromJSON)+-- ResponseConsumer and AsMemoryResponse can't be derived+instance ResponseConsumer r CreateTableResult where+ type ResponseMetadata CreateTableResult = DdbResponse+ responseConsumer _ _ = ddbResponseConsumer+instance AsMemoryResponse CreateTableResult where+ type MemoryResponse CreateTableResult = TableDescription+ loadToMemory = return . ctStatus++instance Transaction CreateTable CreateTableResult++data DescribeTable+ = DescribeTable {+ dTableName :: T.Text+ }+ deriving (Show, Generic)+instance A.ToJSON DescribeTable where+ toJSON = A.genericToJSON $ dropOpt 1++-- | ServiceConfiguration: 'DdbConfiguration'+instance SignQuery DescribeTable where+ type ServiceConfiguration DescribeTable = DdbConfiguration+ signQuery = ddbSignQuery "DescribeTable"++newtype DescribeTableResult = DescribeTableResult { dtStatus :: TableDescription }+ deriving (Show, A.FromJSON)+-- ResponseConsumer can't be derived+instance ResponseConsumer r DescribeTableResult where+ type ResponseMetadata DescribeTableResult = DdbResponse+ responseConsumer _ _ = ddbResponseConsumer+instance AsMemoryResponse DescribeTableResult where+ type MemoryResponse DescribeTableResult = TableDescription+ loadToMemory = return . dtStatus++instance Transaction DescribeTable DescribeTableResult++data UpdateTable+ = UpdateTable {+ updateTableName :: T.Text+ , updateProvisionedThroughput :: ProvisionedThroughput+ , updateGlobalSecondaryIndexUpdates :: [GlobalSecondaryIndexUpdate]+ }+ deriving (Show, Generic)+instance A.ToJSON UpdateTable where+ toJSON a = A.object+ $ "TableName" .= updateTableName a+ : "ProvisionedThroughput" .= updateProvisionedThroughput a+ : case updateGlobalSecondaryIndexUpdates a of+ [] -> []+ l -> [ "GlobalSecondaryIndexUpdates" .= l ]++-- | ServiceConfiguration: 'DdbConfiguration'+instance SignQuery UpdateTable where+ type ServiceConfiguration UpdateTable = DdbConfiguration+ signQuery = ddbSignQuery "UpdateTable"++newtype UpdateTableResult = UpdateTableResult { uStatus :: TableDescription }+ deriving (Show, A.FromJSON)+-- ResponseConsumer can't be derived+instance ResponseConsumer r UpdateTableResult where+ type ResponseMetadata UpdateTableResult = DdbResponse+ responseConsumer _ _ = ddbResponseConsumer+instance AsMemoryResponse UpdateTableResult where+ type MemoryResponse UpdateTableResult = TableDescription+ loadToMemory = return . uStatus++instance Transaction UpdateTable UpdateTableResult++data DeleteTable+ = DeleteTable {+ deleteTableName :: T.Text+ }+ deriving (Show, Generic)+instance A.ToJSON DeleteTable where+ toJSON = A.genericToJSON $ dropOpt 6++-- | ServiceConfiguration: 'DdbConfiguration'+instance SignQuery DeleteTable where+ type ServiceConfiguration DeleteTable = DdbConfiguration+ signQuery = ddbSignQuery "DeleteTable"++newtype DeleteTableResult = DeleteTableResult { dStatus :: TableDescription }+ deriving (Show, A.FromJSON)+-- ResponseConsumer can't be derived+instance ResponseConsumer r DeleteTableResult where+ type ResponseMetadata DeleteTableResult = DdbResponse+ responseConsumer _ _ = ddbResponseConsumer+instance AsMemoryResponse DeleteTableResult where+ type MemoryResponse DeleteTableResult = TableDescription+ loadToMemory = return . dStatus++instance Transaction DeleteTable DeleteTableResult++-- | TODO: currently this does not support restarting a cutoff query because of size.+data ListTables = ListTables+ deriving (Show)+instance A.ToJSON ListTables where+ toJSON _ = A.object []+-- | ServiceConfiguration: 'DdbConfiguration'+instance SignQuery ListTables where+ type ServiceConfiguration ListTables = DdbConfiguration+ signQuery = ddbSignQuery "ListTables"++newtype ListTablesResult+ = ListTablesResult {+ tableNames :: [T.Text]+ }+ deriving (Show, Generic)+instance A.FromJSON ListTablesResult where+ parseJSON = A.genericParseJSON capitalizeOpt+instance ResponseConsumer r ListTablesResult where+ type ResponseMetadata ListTablesResult = DdbResponse+ responseConsumer _ _ = ddbResponseConsumer+instance AsMemoryResponse ListTablesResult where+ type MemoryResponse ListTablesResult = [T.Text]+ loadToMemory = return . tableNames++instance Transaction ListTables ListTablesResult
+ Aws/DynamoDb/Commands/UpdateItem.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module : Aws.DynamoDb.Commands.UpdateItem+-- Copyright : Soostone Inc+-- License : BSD3+--+-- Maintainer : Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability : experimental+--+--+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.UpdateItem+ ( UpdateItem(..)+ , updateItem+ , AttributeUpdate(..)+ , au+ , UpdateAction(..)+ , UpdateItemResponse(..)+ ) where++-------------------------------------------------------------------------------+import Control.Applicative+import Data.Aeson+import qualified Data.Aeson.Key as AK+import Data.Default+import qualified Data.Text as T+import Prelude+-------------------------------------------------------------------------------+import Aws.Core+import Aws.DynamoDb.Core+-------------------------------------------------------------------------------+++-- | An @UpdateItem@ request.+data UpdateItem = UpdateItem {+ uiTable :: T.Text+ , uiKey :: PrimaryKey+ , uiUpdates :: [AttributeUpdate]+ , uiExpect :: Conditions+ -- ^ Conditional update - see DynamoDb documentation+ , uiReturn :: UpdateReturn+ , uiRetCons :: ReturnConsumption+ , uiRetMet :: ReturnItemCollectionMetrics+ } deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------+-- | Construct a minimal 'UpdateItem' request.+updateItem+ :: T.Text -- ^ Table name+ -> PrimaryKey -- ^ Primary key for item+ -> [AttributeUpdate] -- ^ Updates for this item+ -> UpdateItem+updateItem tn key ups = UpdateItem tn key ups def def def def+++-- | A helper to avoid overlapping instances for 'ToJSON'.+newtype AttributeUpdates = AttributeUpdates {+ getAttributeUpdates :: [AttributeUpdate]+ }+++data AttributeUpdate = AttributeUpdate {+ auAttr :: Attribute+ -- ^ Attribute key-value+ , auAction :: UpdateAction+ -- ^ Type of update operation.+ } deriving (Eq,Show,Read,Ord)+++instance DynSize AttributeUpdate where+ dynSize (AttributeUpdate a _) = dynSize a++-------------------------------------------------------------------------------+-- | Shorthand for the 'AttributeUpdate' constructor. Defaults to PUT+-- for the update action.+au :: Attribute -> AttributeUpdate+au a = AttributeUpdate a def+++instance ToJSON AttributeUpdates where+ toJSON = object . map mk . getAttributeUpdates+ where+ mk AttributeUpdate { auAction = UDelete, auAttr = auAttr } =+ (AK.fromText (attrName auAttr)) .= object+ ["Action" .= UDelete]+ mk AttributeUpdate { .. } = AK.fromText (attrName auAttr) .= object+ ["Value" .= (attrVal auAttr), "Action" .= auAction]+++-------------------------------------------------------------------------------+-- | Type of attribute update to perform.+--+-- See AWS docs at:+--+-- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_UpdateItem.html@+data UpdateAction+ = UPut -- ^ Simply write, overwriting any previous value+ | UAdd -- ^ Numerical add or add to set.+ | UDelete -- ^ Empty value: remove; Set value: Subtract from set.+ deriving (Eq,Show,Read,Ord)+++instance ToJSON UpdateAction where+ toJSON UPut = String "PUT"+ toJSON UAdd = String "ADD"+ toJSON UDelete = String "DELETE"+++instance Default UpdateAction where+ def = UPut+++instance ToJSON UpdateItem where+ toJSON UpdateItem{..} =+ object $ expectsJson uiExpect +++ [ "TableName" .= uiTable+ , "Key" .= uiKey+ , "AttributeUpdates" .= AttributeUpdates uiUpdates+ , "ReturnValues" .= uiReturn+ , "ReturnConsumedCapacity" .= uiRetCons+ , "ReturnItemCollectionMetrics" .= uiRetMet+ ]+++data UpdateItemResponse = UpdateItemResponse {+ uirAttrs :: Maybe Item+ -- ^ Old attributes, if requested+ , uirConsumed :: Maybe ConsumedCapacity+ -- ^ Amount of capacity consumed+ } deriving (Eq,Show,Read,Ord)++++instance Transaction UpdateItem UpdateItemResponse+++instance SignQuery UpdateItem where+ type ServiceConfiguration UpdateItem = DdbConfiguration+ signQuery gi = ddbSignQuery "UpdateItem" gi+++instance FromJSON UpdateItemResponse where+ parseJSON (Object v) = UpdateItemResponse+ <$> v .:? "Attributes"+ <*> v .:? "ConsumedCapacity"+ parseJSON _ = fail "UpdateItemResponse expected a JSON object"+++instance ResponseConsumer r UpdateItemResponse where+ type ResponseMetadata UpdateItemResponse = DdbResponse+ responseConsumer _ _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse UpdateItemResponse where+ type MemoryResponse UpdateItemResponse = UpdateItemResponse+ loadToMemory = return++++++++
+ Aws/DynamoDb/Core.hs view
@@ -0,0 +1,1406 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module : Aws.DynamoDb.Core+-- Copyright : Soostone Inc, Chris Allen+-- License : BSD3+--+-- Maintainer : Ozgun Ataman <ozgun.ataman@soostone.com>+-- Stability : experimental+--+-- Shared types and utilities for DyanmoDb functionality.+----------------------------------------------------------------------------++module Aws.DynamoDb.Core+ (+ -- * Configuration and Regions+ Region (..)+ , ddbLocal+ , ddbUsEast1+ , ddbUsWest1+ , ddbUsWest2+ , ddbEuWest1+ , ddbEuWest2+ , ddbEuCentral1+ , ddbApNe1+ , ddbApSe1+ , ddbApSe2+ , ddbSaEast1+ , DdbConfiguration (..)++ -- * DynamoDB values+ , DValue (..)++ -- * Converting to/from 'DValue'+ , DynVal(..)+ , toValue, fromValue+ , Bin (..)+ , OldBool(..)++ -- * Defining new 'DynVal' instances+ , DynData(..)+ , DynBinary(..), DynNumber(..), DynString(..), DynBool(..)++ -- * Working with key/value pairs+ , Attribute (..)+ , parseAttributeJson+ , attributeJson+ , attributesJson++ , attrTuple+ , attr+ , attrAs+ , text, int, double+ , PrimaryKey (..)+ , hk+ , hrk++ -- * Working with objects (attribute collections)+ , Item+ , item+ , attributes+ , ToDynItem (..)+ , FromDynItem (..)+ , fromItem+ , Parser (..)+ , getAttr+ , getAttr'+ , parseAttr++ -- * Common types used by operations+ , Conditions (..)+ , conditionsJson+ , expectsJson++ , Condition (..)+ , conditionJson+ , CondOp (..)+ , CondMerge (..)+ , ConsumedCapacity (..)+ , ReturnConsumption (..)+ , ItemCollectionMetrics (..)+ , ReturnItemCollectionMetrics (..)+ , UpdateReturn (..)+ , QuerySelect (..)+ , querySelectJson++ -- * Size estimation+ , DynSize (..)+ , nullAttr++ -- * Responses & Errors+ , DdbResponse (..)+ , DdbErrCode (..)+ , shouldRetry+ , DdbError (..)++ -- * Internal Helpers+ , ddbSignQuery+ , AmazonError (..)+ , ddbResponseConsumer+ , ddbHttp+ , ddbHttps++ ) where+++-------------------------------------------------------------------------------+import Control.Applicative+import qualified Control.Exception as C+import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif+import Control.Monad.Trans+import Control.Monad.Trans.Resource (throwM)+import qualified Crypto.Hash as CH+import Data.Aeson+import qualified Data.Aeson as A+import qualified Data.Aeson.Key as AK+import qualified Data.Aeson.KeyMap as KM+import Data.Aeson.Parser as A (json')+import Data.Aeson.Types (Pair, parseEither)+import qualified Data.Aeson.Types as A+import qualified Data.Attoparsec.ByteString as AttoB (endOfInput)+import qualified Data.Attoparsec.Text as Atto+import qualified Data.ByteArray as ByteArray+import qualified Data.ByteString.Base16 as Base16+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Char8 as B+import qualified Data.CaseInsensitive as CI+import Data.Conduit+import Data.Conduit.Attoparsec (sinkParser)+import Data.Default+import Data.Function (on)+import Data.Int+import Data.IORef+import Data.List+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid ()+import qualified Data.Semigroup as Sem+import Data.Proxy+import Data.Scientific+import qualified Data.Serialize as Ser+import qualified Data.Set as S+import Data.String+import Data.Tagged+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time+import Data.Typeable+import qualified Data.Vector as V+import Data.Word+import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Types as HTTP+import Safe+-------------------------------------------------------------------------------+import Aws.Core+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- | Boolean values stored in DynamoDb. Only used in defining new+-- 'DynVal' instances.+newtype DynBool = DynBool { unDynBool :: Bool }+ deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+-- | Numeric values stored in DynamoDb. Only used in defining new+-- 'DynVal' instances.+newtype DynNumber = DynNumber { unDynNumber :: Scientific }+ deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+-- | String values stored in DynamoDb. Only used in defining new+-- 'DynVal' instances.+newtype DynString = DynString { unDynString :: T.Text }+ deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+-- | Binary values stored in DynamoDb. Only used in defining new+-- 'DynVal' instances.+newtype DynBinary = DynBinary { unDynBinary :: B.ByteString }+ deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+-- | An internally used closed typeclass for values that have direct+-- DynamoDb representations. Based on AWS API, this is basically+-- numbers, strings and binary blobs.+--+-- This is here so that any 'DynVal' haskell value can automatically+-- be lifted to a list or a 'Set' without any instance code+-- duplication.+--+-- Do not try to create your own instances.+class Ord a => DynData a where+ fromData :: a -> DValue+ toData :: DValue -> Maybe a++instance DynData DynBool where+ fromData (DynBool i) = DBool i+ toData (DBool i) = Just $ DynBool i+ toData (DNum i) = DynBool `fmap` do+ (i' :: Int) <- toIntegral i+ case i' of+ 0 -> return False+ 1 -> return True+ _ -> Nothing+ toData _ = Nothing++instance DynData (S.Set DynBool) where+ fromData set = DBoolSet (S.map unDynBool set)+ toData (DBoolSet i) = Just $ S.map DynBool i+ toData _ = Nothing++instance DynData DynNumber where+ fromData (DynNumber i) = DNum i+ toData (DNum i) = Just $ DynNumber i+ toData _ = Nothing++instance DynData (S.Set DynNumber) where+ fromData set = DNumSet (S.map unDynNumber set)+ toData (DNumSet i) = Just $ S.map DynNumber i+ toData _ = Nothing++instance DynData DynString where+ fromData (DynString i) = DString i+ toData (DString i) = Just $ DynString i+ toData _ = Nothing++instance DynData (S.Set DynString) where+ fromData set = DStringSet (S.map unDynString set)+ toData (DStringSet i) = Just $ S.map DynString i+ toData _ = Nothing++instance DynData DynBinary where+ fromData (DynBinary i) = DBinary i+ toData (DBinary i) = Just $ DynBinary i+ toData _ = Nothing++instance DynData (S.Set DynBinary) where+ fromData set = DBinSet (S.map unDynBinary set)+ toData (DBinSet i) = Just $ S.map DynBinary i+ toData _ = Nothing++instance DynData DValue where+ fromData = id+ toData = Just+++-------------------------------------------------------------------------------+-- | Class of Haskell types that can be represented as DynamoDb values.+--+-- This is the conversion layer; instantiate this class for your own+-- types and then use the 'toValue' and 'fromValue' combinators to+-- convert in application code.+--+-- Each Haskell type instantiated with this class will map to a+-- DynamoDb-supported type that most naturally represents it.+class DynData (DynRep a) => DynVal a where++ -- | Which of the 'DynData' instances does this data type directly+ -- map to?+ type DynRep a++ -- | Convert to representation+ toRep :: a -> DynRep a++ -- | Convert from representation+ fromRep :: DynRep a -> Maybe a+++-------------------------------------------------------------------------------+-- | Any singular 'DynVal' can be upgraded to a list.+instance (DynData (DynRep [a]), DynVal a) => DynVal [a] where+ type DynRep [a] = S.Set (DynRep a)+ fromRep set = mapM fromRep $ S.toList set+ toRep as = S.fromList $ map toRep as+++-------------------------------------------------------------------------------+-- | Any singular 'DynVal' can be upgraded to a 'Set'.+instance (DynData (DynRep (S.Set a)), DynVal a, Ord a) => DynVal (S.Set a) where+ type DynRep (S.Set a) = S.Set (DynRep a)+ fromRep set = fmap S.fromList . mapM fromRep $ S.toList set+ toRep as = S.map toRep as+++instance DynVal DValue where+ type DynRep DValue = DValue+ fromRep = Just+ toRep = id++instance DynVal Bool where+ type DynRep Bool = DynBool+ fromRep (DynBool i) = Just i+ toRep i = DynBool i++instance DynVal Int where+ type DynRep Int = DynNumber+ fromRep (DynNumber i) = toIntegral i+ toRep i = DynNumber (fromIntegral i)+++instance DynVal Int8 where+ type DynRep Int8 = DynNumber+ fromRep (DynNumber i) = toIntegral i+ toRep i = DynNumber (fromIntegral i)+++instance DynVal Int16 where+ type DynRep Int16 = DynNumber+ fromRep (DynNumber i) = toIntegral i+ toRep i = DynNumber (fromIntegral i)+++instance DynVal Int32 where+ type DynRep Int32 = DynNumber+ fromRep (DynNumber i) = toIntegral i+ toRep i = DynNumber (fromIntegral i)+++instance DynVal Int64 where+ type DynRep Int64 = DynNumber+ fromRep (DynNumber i) = toIntegral i+ toRep i = DynNumber (fromIntegral i)+++instance DynVal Word8 where+ type DynRep Word8 = DynNumber+ fromRep (DynNumber i) = toIntegral i+ toRep i = DynNumber (fromIntegral i)+++instance DynVal Word16 where+ type DynRep Word16 = DynNumber+ fromRep (DynNumber i) = toIntegral i+ toRep i = DynNumber (fromIntegral i)+++instance DynVal Word32 where+ type DynRep Word32 = DynNumber+ fromRep (DynNumber i) = toIntegral i+ toRep i = DynNumber (fromIntegral i)+++instance DynVal Word64 where+ type DynRep Word64 = DynNumber+ fromRep (DynNumber i) = toIntegral i+ toRep i = DynNumber (fromIntegral i)+++instance DynVal Integer where+ type DynRep Integer = DynNumber+ fromRep (DynNumber i) = toIntegral i+ toRep i = DynNumber (fromIntegral i)+++instance DynVal T.Text where+ type DynRep T.Text = DynString+ fromRep (DynString i) = Just i+ toRep i = DynString i+++instance DynVal B.ByteString where+ type DynRep B.ByteString = DynBinary+ fromRep (DynBinary i) = Just i+ toRep i = DynBinary i+++instance DynVal Double where+ type DynRep Double = DynNumber+ fromRep (DynNumber i) = Just $ toRealFloat i+ toRep i = DynNumber (fromFloatDigits i)+++-------------------------------------------------------------------------------+-- | Encoded as number of days+instance DynVal Day where+ type DynRep Day = DynNumber+ fromRep (DynNumber i) = ModifiedJulianDay <$> (toIntegral i)+ toRep (ModifiedJulianDay i) = DynNumber (fromIntegral i)+++-------------------------------------------------------------------------------+-- | Losslessly encoded via 'Integer' picoseconds+instance DynVal UTCTime where+ type DynRep UTCTime = DynNumber+ fromRep num = fromTS <$> fromRep num+ toRep x = toRep (toTS x)+++-------------------------------------------------------------------------------+pico :: Rational+pico = toRational $ (10 :: Integer) ^ (12 :: Integer)+++-------------------------------------------------------------------------------+dayPico :: Integer+dayPico = 86400 * round pico+++-------------------------------------------------------------------------------+-- | Convert UTCTime to picoseconds+--+-- TODO: Optimize performance?+toTS :: UTCTime -> Integer+toTS (UTCTime (ModifiedJulianDay i) diff) = i' + diff'+ where+ diff' = floor (toRational diff * pico)+ i' = i * dayPico+++-------------------------------------------------------------------------------+-- | Convert picoseconds to UTCTime+--+-- TODO: Optimize performance?+fromTS :: Integer -> UTCTime+fromTS i = UTCTime (ModifiedJulianDay days) diff+ where+ (days, secs) = i `divMod` dayPico+ diff = fromRational ((toRational secs) / pico)++++-- | Type wrapper for binary data to be written to DynamoDB. Wrap any+-- 'Serialize' instance in there and 'DynVal' will know how to+-- automatically handle conversions in binary form.+newtype Bin a = Bin { getBin :: a }+ deriving (Eq,Show,Read,Ord,Typeable,Enum)+++instance (Ser.Serialize a) => DynVal (Bin a) where+ type DynRep (Bin a) = DynBinary+ toRep (Bin i) = DynBinary (Ser.encode i)+ fromRep (DynBinary i) = either (const Nothing) (Just . Bin) $+ Ser.decode i++newtype OldBool = OldBool Bool++instance DynVal OldBool where+ type DynRep OldBool = DynNumber+ fromRep (DynNumber i) = OldBool `fmap` do+ (i' :: Int) <- toIntegral i+ case i' of+ 0 -> return False+ 1 -> return True+ _ -> Nothing+ toRep (OldBool b) = DynNumber (if b then 1 else 0)+++-------------------------------------------------------------------------------+-- | Encode a Haskell value.+toValue :: DynVal a => a -> DValue+toValue a = fromData $ toRep a+++-------------------------------------------------------------------------------+-- | Decode a Haskell value.+fromValue :: DynVal a => DValue -> Maybe a+fromValue d = toData d >>= fromRep+++toIntegral :: (Integral a, RealFrac a1) => a1 -> Maybe a+toIntegral sc = Just $ floor sc++++-- | Value types natively recognized by DynamoDb. We pretty much+-- exactly reflect the AWS API onto Haskell types.+data DValue+ = DNull+ | DNum Scientific+ | DString T.Text+ | DBinary B.ByteString+ -- ^ Binary data will automatically be base64 marshalled.+ | DNumSet (S.Set Scientific)+ | DStringSet (S.Set T.Text)+ | DBinSet (S.Set B.ByteString)+ -- ^ Binary data will automatically be base64 marshalled.+ | DBool Bool+ | DBoolSet (S.Set Bool)+ -- ^ Composite data+ | DList (V.Vector DValue)+ | DMap (M.Map T.Text DValue)+ deriving (Eq,Show,Read,Ord,Typeable)+++instance IsString DValue where+ fromString t = DString (T.pack t)++-------------------------------------------------------------------------------+-- | Primary keys consist of either just a Hash key (mandatory) or a+-- hash key and a range key (optional).+data PrimaryKey = PrimaryKey {+ pkHash :: Attribute+ , pkRange :: Maybe Attribute+ } deriving (Read,Show,Ord,Eq,Typeable)+++-------------------------------------------------------------------------------+-- | Construct a hash-only primary key.+--+-- >>> hk "user-id" "ABCD"+--+-- >>> hk "user-id" (mkVal 23)+hk :: T.Text -> DValue -> PrimaryKey+hk k v = PrimaryKey (attr k v) Nothing+++-------------------------------------------------------------------------------+-- | Construct a hash-and-range primary key.+hrk :: T.Text -- ^ Hash key name+ -> DValue -- ^ Hash key value+ -> T.Text -- ^ Range key name+ -> DValue -- ^ Range key value+ -> PrimaryKey+hrk k v k2 v2 = PrimaryKey (attr k v) (Just (attr k2 v2))+++instance ToJSON PrimaryKey where+ toJSON (PrimaryKey h Nothing) = toJSON h+ toJSON (PrimaryKey h (Just r)) =+ let Object p1 = toJSON h+ Object p2 = toJSON r+ in Object (p1 `KM.union` p2)++instance FromJSON PrimaryKey where+ parseJSON p = do+ l <- listPKey p+ case length l of+ 1 -> return $ head l + _ -> fail "Unable to parse PrimaryKey" + where listPKey p'= map (\(k,dval)-> hk (AK.toText k) dval)+ . KM.toList <$> parseJSON p'+++-- | A key-value pair+data Attribute = Attribute {+ attrName :: T.Text+ , attrVal :: DValue+ } deriving (Read,Show,Ord,Eq,Typeable)+++-- | Convert attribute to a tuple representation+attrTuple :: Attribute -> (T.Text, DValue)+attrTuple (Attribute a b) = (a,b)+++-- | Convenience function for constructing key-value pairs+attr :: DynVal a => T.Text -> a -> Attribute+attr k v = Attribute k (toValue v)+++-- | 'attr' with type witness to help with cases where you're manually+-- supplying values in code.+--+-- >> item [ attrAs text "name" "john" ]+attrAs :: DynVal a => Proxy a -> T.Text -> a -> Attribute+attrAs _ k v = attr k v+++-- | Type witness for 'Text'. See 'attrAs'.+text :: Proxy T.Text+text = Proxy+++-- | Type witness for 'Integer'. See 'attrAs'.+int :: Proxy Integer+int = Proxy+++-- | Type witness for 'Double'. See 'attrAs'.+double :: Proxy Double+double = Proxy+++-- | A DynamoDb object is simply a key-value dictionary.+type Item = M.Map T.Text DValue+++-------------------------------------------------------------------------------+-- | Pack a list of attributes into an Item.+item :: [Attribute] -> Item+item = M.fromList . map attrTuple+++-------------------------------------------------------------------------------+-- | Unpack an 'Item' into a list of attributes.+attributes :: M.Map T.Text DValue -> [Attribute]+attributes = map (\ (k, v) -> Attribute k v) . M.toList+++showT :: Show a => a -> T.Text+showT = T.pack . show+++instance ToJSON DValue where+ toJSON DNull = object ["NULL" .= True]+ toJSON (DNum i) = object ["N" .= showT i]+ toJSON (DString i) = object ["S" .= i]+ toJSON (DBinary i) = object ["B" .= (T.decodeUtf8 $ Base64.encode i)]+ toJSON (DNumSet i) = object ["NS" .= map showT (S.toList i)]+ toJSON (DStringSet i) = object ["SS" .= S.toList i]+ toJSON (DBinSet i) = object ["BS" .= map (T.decodeUtf8 . Base64.encode) (S.toList i)]+ toJSON (DBool i) = object ["BOOL" .= i]+ toJSON (DList i) = object ["L" .= i]+ toJSON (DMap i) = object ["M" .= i]+ toJSON x = error $ "aws: bug: DynamoDB can't handle " ++ show x+++instance FromJSON DValue where+ parseJSON o = do+ (obj :: [(T.Text, Value)]) <- M.toList `liftM` parseJSON o+ case obj of+ [("NULL", _)] -> return DNull+ [("N", numStr)] -> DNum <$> parseScientific numStr+ [("S", str)] -> DString <$> parseJSON str+ [("B", bin)] -> do+ res <- (Base64.decode . T.encodeUtf8) <$> parseJSON bin+ either fail (return . DBinary) res+ [("NS", s)] -> do xs <- mapM parseScientific =<< parseJSON s+ return $ DNumSet $ S.fromList xs+ [("SS", s)] -> DStringSet <$> parseJSON s+ [("BS", s)] -> do+ xs <- mapM (either fail return . Base64.decode . T.encodeUtf8)+ =<< parseJSON s+ return $ DBinSet $ S.fromList xs+ [("BOOL", b)] -> DBool <$> parseJSON b+ [("L", attrs)] -> DList <$> parseJSON attrs+ [("M", attrs)] -> DMap <$> parseJSON attrs++ x -> fail $ "aws: unknown dynamodb value: " ++ show x++ where+ parseScientific (String str) =+ case Atto.parseOnly Atto.scientific str of+ Left e -> fail ("parseScientific failed: " ++ e)+ Right a -> return a+ parseScientific (Number n) = return n+ parseScientific _ = fail "Unexpected JSON type in parseScientific"+++instance ToJSON Attribute where+ toJSON a = object $ [attributeJson a]+++-------------------------------------------------------------------------------+-- | Parse a JSON object that contains attributes+parseAttributeJson :: Value -> A.Parser [Attribute]+parseAttributeJson (Object v) = mapM conv $ KM.toList v+ where+ conv (k, o) = Attribute (AK.toText k) <$> parseJSON o+parseAttributeJson _ = error "Attribute JSON must be an Object"+++-- | Convert into JSON object for AWS.+attributesJson :: [Attribute] -> Value+attributesJson as = object $ map attributeJson as+++-- | Convert into JSON pair+attributeJson :: Attribute -> Pair+attributeJson (Attribute nm v) = AK.fromText nm .= v+++-------------------------------------------------------------------------------+-- | Errors defined by AWS.+data DdbErrCode+ = AccessDeniedException+ | ConditionalCheckFailedException+ | IncompleteSignatureException+ | InvalidSignatureException+ | LimitExceededException+ | MissingAuthenticationTokenException+ | ProvisionedThroughputExceededException+ | ResourceInUseException+ | ResourceNotFoundException+ | ThrottlingException+ | ValidationException+ | RequestTooLarge+ | InternalFailure+ | InternalServerError+ | ServiceUnavailableException+ | SerializationException+ -- ^ Raised by AWS when the request JSON is missing fields or is+ -- somehow malformed.+ deriving (Read,Show,Eq,Typeable)+++-------------------------------------------------------------------------------+-- | Whether the action should be retried based on the received error.+shouldRetry :: DdbErrCode -> Bool+shouldRetry e = go e+ where+ go LimitExceededException = True+ go ProvisionedThroughputExceededException = True+ go ResourceInUseException = True+ go ThrottlingException = True+ go InternalFailure = True+ go InternalServerError = True+ go ServiceUnavailableException = True+ go _ = False+++-------------------------------------------------------------------------------+-- | Errors related to this library.+data DdbLibraryError+ = UnknownDynamoErrCode T.Text+ -- ^ A DynamoDB error code we do not know about.+ | JsonProtocolError Value T.Text+ -- ^ A JSON response we could not parse.+ deriving (Show,Eq,Typeable)+++-- | Potential errors raised by DynamoDB+data DdbError = DdbError {+ ddbStatusCode :: Int+ -- ^ 200 if successful, 400 for client errors and 500 for+ -- server-side errors.+ , ddbErrCode :: DdbErrCode+ , ddbErrMsg :: T.Text+ } deriving (Show,Eq,Typeable)+++instance C.Exception DdbError+instance C.Exception DdbLibraryError+++-- | Response metadata that is present in every DynamoDB response.+data DdbResponse = DdbResponse {+ ddbrCrc :: Maybe T.Text+ , ddbrMsgId :: Maybe T.Text+ }+++instance Loggable DdbResponse where+ toLogText (DdbResponse id2 rid) =+ "DynamoDB: request ID=" `mappend`+ fromMaybe "<none>" rid `mappend`+ ", x-amz-id-2=" `mappend`+ fromMaybe "<none>" id2++instance Sem.Semigroup DdbResponse where+ a <> b = DdbResponse (ddbrCrc a `mplus` ddbrCrc b) (ddbrMsgId a `mplus` ddbrMsgId b)++instance Monoid DdbResponse where+ mempty = DdbResponse Nothing Nothing+ mappend = (Sem.<>)+++data Region = Region {+ rUri :: B.ByteString+ , rName :: B.ByteString+ } deriving (Eq,Show,Read,Typeable)+++data DdbConfiguration qt = DdbConfiguration {+ ddbcRegion :: Region+ -- ^ The regional endpoint. Ex: 'ddbUsEast'+ , ddbcProtocol :: Protocol+ -- ^ 'HTTP' or 'HTTPS'+ , ddbcPort :: Maybe Int+ -- ^ Port override (mostly for local dev connection)+ } deriving (Show,Typeable)++instance Default (DdbConfiguration NormalQuery) where+ def = DdbConfiguration ddbUsEast1 HTTPS Nothing++instance DefaultServiceConfiguration (DdbConfiguration NormalQuery) where+ defServiceConfig = ddbHttps ddbUsEast1+ debugServiceConfig = ddbHttp ddbUsEast1+++-------------------------------------------------------------------------------+-- | DynamoDb local connection (for development)+ddbLocal :: Region+ddbLocal = Region "127.0.0.1" "local"++ddbUsEast1 :: Region+ddbUsEast1 = Region "dynamodb.us-east-1.amazonaws.com" "us-east-1"++ddbUsWest1 :: Region+ddbUsWest1 = Region "dynamodb.us-west-1.amazonaws.com" "us-west-1"++ddbUsWest2 :: Region+ddbUsWest2 = Region "dynamodb.us-west-2.amazonaws.com" "us-west-2"++ddbEuWest1 :: Region+ddbEuWest1 = Region "dynamodb.eu-west-1.amazonaws.com" "eu-west-1"++ddbEuWest2 :: Region+ddbEuWest2 = Region "dynamodb.eu-west-2.amazonaws.com" "eu-west-2"++ddbEuCentral1 :: Region+ddbEuCentral1 = Region "dynamodb.eu-central-1.amazonaws.com" "eu-central-1"++ddbApNe1 :: Region+ddbApNe1 = Region "dynamodb.ap-northeast-1.amazonaws.com" "ap-northeast-1"++ddbApSe1 :: Region+ddbApSe1 = Region "dynamodb.ap-southeast-1.amazonaws.com" "ap-southeast-1"++ddbApSe2 :: Region+ddbApSe2 = Region "dynamodb.ap-southeast-2.amazonaws.com" "ap-southeast-2"++ddbSaEast1 :: Region+ddbSaEast1 = Region "dynamodb.sa-east-1.amazonaws.com" "sa-east-1"++ddbHttp :: Region -> DdbConfiguration NormalQuery+ddbHttp endpoint = DdbConfiguration endpoint HTTP Nothing++ddbHttps :: Region -> DdbConfiguration NormalQuery+ddbHttps endpoint = DdbConfiguration endpoint HTTPS Nothing+++ddbSignQuery+ :: A.ToJSON a+ => B.ByteString+ -> a+ -> DdbConfiguration qt+ -> SignatureData+ -> SignedQuery+ddbSignQuery target body di sd+ = SignedQuery {+ sqMethod = Post+ , sqProtocol = ddbcProtocol di+ , sqHost = host+ , sqPort = fromMaybe (defaultPort (ddbcProtocol di)) (ddbcPort di)+ , sqPath = "/"+ , sqQuery = []+ , sqDate = Just $ signatureTime sd+ , sqAuthorization = Just auth+ , sqContentType = Just "application/x-amz-json-1.0"+ , sqContentMd5 = Nothing+ , sqAmzHeaders = amzHeaders ++ maybe [] (\tok -> [("x-amz-security-token",tok)]) (iamToken credentials)+ , sqOtherHeaders = []+ , sqBody = Just $ HTTP.RequestBodyLBS bodyLBS+ , sqStringToSign = canonicalRequest+ }+ where+ credentials = signatureCredentials sd++ Region{..} = ddbcRegion di+ host = rUri++ sigTime = fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd++ bodyLBS = A.encode body+ bodyHash = Base16.encode $ ByteArray.convert (CH.hashlazy bodyLBS :: CH.Digest CH.SHA256)++ -- for some reason AWS doesn't want the x-amz-security-token in the canonical request+ amzHeaders = [ ("x-amz-date", sigTime)+ , ("x-amz-target", dyApiVersion Sem.<> target)+ ]++ canonicalHeaders = sortBy (compare `on` fst) $ amzHeaders +++ [("host", host),+ ("content-type", "application/x-amz-json-1.0")]++ canonicalRequest = B.concat $ intercalate ["\n"] (+ [ ["POST"]+ , ["/"]+ , [] -- query string+ ] +++ map (\(a,b) -> [CI.foldedCase a,":",b]) canonicalHeaders +++ [ [] -- end headers+ , intersperse ";" (map (CI.foldedCase . fst) canonicalHeaders)+ , [bodyHash]+ ])++ auth = authorizationV4 sd HmacSHA256 rName "dynamodb"+ "content-type;host;x-amz-date;x-amz-target"+ canonicalRequest++data AmazonError = AmazonError {+ aeType :: T.Text+ , aeMessage :: Maybe T.Text+ }++instance FromJSON AmazonError where+ parseJSON (Object v) = AmazonError+ <$> v .: "__type"+ <*> (Just <$> (v .: "message" <|> v .: "Message") <|> pure Nothing)+ parseJSON _ = error $ "aws: unexpected AmazonError message"+++++-------------------------------------------------------------------------------+ddbResponseConsumer :: A.FromJSON a => IORef DdbResponse -> HTTPResponseConsumer a+ddbResponseConsumer ref resp = do+ val <- runConduit $ HTTP.responseBody resp .| sinkParser (A.json' <* AttoB.endOfInput)+ case statusCode of+ 200 -> rSuccess val+ _ -> rError val+ where++ header = fmap T.decodeUtf8 . flip lookup (HTTP.responseHeaders resp)+ amzId = header "x-amzn-RequestId"+ amzCrc = header "x-amz-crc32"+ meta = DdbResponse amzCrc amzId+ tellMeta = liftIO $ tellMetadataRef ref meta++ rSuccess val =+ case A.fromJSON val of+ A.Success a -> return a+ A.Error err -> do+ tellMeta+ throwM $ JsonProtocolError val (T.pack err)++ rError val = do+ tellMeta+ case parseEither parseJSON val of+ Left e ->+ throwM $ JsonProtocolError val (T.pack e)++ Right err'' -> do+ let e = T.drop 1 . snd . T.breakOn "#" $ aeType err''+ errCode <- readErrCode e+ throwM $ DdbError statusCode errCode (fromMaybe "" $ aeMessage err'')++ readErrCode txt =+ let txt' = T.unpack txt+ in case readMay txt' of+ Just e -> return $ e+ Nothing -> throwM (UnknownDynamoErrCode txt)++ HTTP.Status{..} = HTTP.responseStatus resp+++-- | Conditions used by mutation operations ('PutItem', 'UpdateItem',+-- etc.). The default 'def' instance is empty (no condition).+data Conditions = Conditions CondMerge [Condition]+ deriving (Eq,Show,Read,Ord,Typeable)++instance Default Conditions where+ def = Conditions CondAnd []++++expectsJson :: Conditions -> [A.Pair]+expectsJson = conditionsJson "Expected"+++-- | JSON encoding of conditions parameter in various contexts.+conditionsJson :: T.Text -> Conditions -> [A.Pair]+conditionsJson key (Conditions op es) = b ++ a+ where+ a = if null es+ then []+ else [AK.fromText key .= object (map conditionJson es)]++ b = if length (take 2 es) > 1+ then ["ConditionalOperator" .= String (rendCondOp op) ]+ else []+++-------------------------------------------------------------------------------+rendCondOp :: CondMerge -> T.Text+rendCondOp CondAnd = "AND"+rendCondOp CondOr = "OR"+++-------------------------------------------------------------------------------+-- | How to merge multiple conditions.+data CondMerge = CondAnd | CondOr+ deriving (Eq,Show,Read,Ord,Typeable)+++-- | A condition used by mutation operations ('PutItem', 'UpdateItem', etc.).+data Condition = Condition {+ condAttr :: T.Text+ -- ^ Attribute to use as the basis for this conditional+ , condOp :: CondOp+ -- ^ Operation on the selected attribute+ } deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+-- | Conditional operation to perform on a field.+data CondOp+ = DEq DValue+ | NotEq DValue+ | DLE DValue+ | DLT DValue+ | DGE DValue+ | DGT DValue+ | NotNull+ | IsNull+ | Contains DValue+ | NotContains DValue+ | Begins DValue+ | In [DValue]+ | Between DValue DValue+ deriving (Eq,Show,Read,Ord,Typeable)+++-------------------------------------------------------------------------------+getCondValues :: CondOp -> [DValue]+getCondValues c = case c of+ DEq v -> [v]+ NotEq v -> [v]+ DLE v -> [v]+ DLT v -> [v]+ DGE v -> [v]+ DGT v -> [v]+ NotNull -> []+ IsNull -> []+ Contains v -> [v]+ NotContains v -> [v]+ Begins v -> [v]+ In v -> v+ Between a b -> [a,b]+++-------------------------------------------------------------------------------+renderCondOp :: CondOp -> T.Text+renderCondOp c = case c of+ DEq{} -> "EQ"+ NotEq{} -> "NE"+ DLE{} -> "LE"+ DLT{} -> "LT"+ DGE{} -> "GE"+ DGT{} -> "GT"+ NotNull -> "NOT_NULL"+ IsNull -> "NULL"+ Contains{} -> "CONTAINS"+ NotContains{} -> "NOT_CONTAINS"+ Begins{} -> "BEGINS_WITH"+ In{} -> "IN"+ Between{} -> "BETWEEN"+++conditionJson :: Condition -> Pair+conditionJson Condition{..} = AK.fromText condAttr .= condOp+++instance ToJSON CondOp where+ toJSON c = object $ ("ComparisonOperator" .= String (renderCondOp c)) : valueList+ where+ valueList =+ let vs = getCondValues c in+ if null vs+ then []+ else ["AttributeValueList" .= vs]++-------------------------------------------------------------------------------+dyApiVersion :: B.ByteString+dyApiVersion = "DynamoDB_20120810."++++-------------------------------------------------------------------------------+-- | The standard response metrics on capacity consumption.+data ConsumedCapacity = ConsumedCapacity {+ capacityUnits :: Int64+ , capacityGlobalIndex :: [(T.Text, Int64)]+ , capacityLocalIndex :: [(T.Text, Int64)]+ , capacityTableUnits :: Maybe Int64+ , capacityTable :: T.Text+ } deriving (Eq,Show,Read,Ord,Typeable)+++instance FromJSON ConsumedCapacity where+ parseJSON (Object o) = ConsumedCapacity+ <$> o .: "CapacityUnits"+ <*> (map (\(k, v) -> (AK.toText k, v)) . KM.toList <$> o .:? "GlobalSecondaryIndexes" .!= mempty)+ <*> (map (\(k, v) -> (AK.toText k, v)) . KM.toList <$> o .:? "LocalSecondaryIndexes" .!= mempty)+ <*> (o .:? "Table" >>= maybe (return Nothing) (.: "CapacityUnits"))+ <*> o .: "TableName"+ parseJSON _ = fail "ConsumedCapacity must be an Object."++++data ReturnConsumption = RCIndexes | RCTotal | RCNone+ deriving (Eq,Show,Read,Ord,Typeable)++instance ToJSON ReturnConsumption where+ toJSON RCIndexes = String "INDEXES"+ toJSON RCTotal = String "TOTAL"+ toJSON RCNone = String "NONE"++instance Default ReturnConsumption where+ def = RCNone++data ReturnItemCollectionMetrics = RICMSize | RICMNone+ deriving (Eq,Show,Read,Ord,Typeable)++instance ToJSON ReturnItemCollectionMetrics where+ toJSON RICMSize = String "SIZE"+ toJSON RICMNone = String "NONE"++instance Default ReturnItemCollectionMetrics where+ def = RICMNone+++data ItemCollectionMetrics = ItemCollectionMetrics {+ icmKey :: (T.Text, DValue)+ , icmEstimate :: [Double]+ } deriving (Eq,Show,Read,Ord,Typeable)+++instance FromJSON ItemCollectionMetrics where+ parseJSON (Object o) = ItemCollectionMetrics+ <$> (do m <- o .: "ItemCollectionKey"+ return $ (\(k, v) -> (AK.toText k, v)) $ head $ KM.toList m)+ <*> o .: "SizeEstimateRangeGB"+ parseJSON _ = fail "ItemCollectionMetrics must be an Object."+++-------------------------------------------------------------------------------+-- | What to return from the current update operation+data UpdateReturn+ = URNone -- ^ Return nothing+ | URAllOld -- ^ Return old values+ | URUpdatedOld -- ^ Return old values with a newer replacement+ | URAllNew -- ^ Return new values+ | URUpdatedNew -- ^ Return new values that were replacements+ deriving (Eq,Show,Read,Ord,Typeable)+++instance ToJSON UpdateReturn where+ toJSON URNone = toJSON (String "NONE")+ toJSON URAllOld = toJSON (String "ALL_OLD")+ toJSON URUpdatedOld = toJSON (String "UPDATED_OLD")+ toJSON URAllNew = toJSON (String "ALL_NEW")+ toJSON URUpdatedNew = toJSON (String "UPDATED_NEW")+++instance Default UpdateReturn where+ def = URNone++++-------------------------------------------------------------------------------+-- | What to return from a 'Query' or 'Scan' query.+data QuerySelect+ = SelectSpecific [T.Text]+ -- ^ Only return selected attributes+ | SelectCount+ -- ^ Return counts instead of attributes+ | SelectProjected+ -- ^ Return index-projected attributes+ | SelectAll+ -- ^ Default. Return everything.+ deriving (Eq,Show,Read,Ord,Typeable)+++instance Default QuerySelect where def = SelectAll++-------------------------------------------------------------------------------+querySelectJson :: KeyValue A.Value t => QuerySelect -> [t]+querySelectJson (SelectSpecific as) =+ [ "Select" .= String "SPECIFIC_ATTRIBUTES"+ , "AttributesToGet" .= as]+querySelectJson SelectCount = ["Select" .= String "COUNT"]+querySelectJson SelectProjected = ["Select" .= String "ALL_PROJECTED_ATTRIBUTES"]+querySelectJson SelectAll = ["Select" .= String "ALL_ATTRIBUTES"]+++-------------------------------------------------------------------------------+-- | A class to help predict DynamoDb size of values, attributes and+-- entire items. The result is given in number of bytes.+class DynSize a where+ dynSize :: a -> Int++instance DynSize DValue where+ dynSize DNull = 8+ dynSize (DBool _) = 8+ dynSize (DBoolSet s) = sum $ map (dynSize . DBool) $ S.toList s+ dynSize (DNum _) = 8+ dynSize (DString a) = T.length a+ dynSize (DBinary bs) = T.length . T.decodeUtf8 $ Base64.encode bs+ dynSize (DNumSet s) = 8 * S.size s+ dynSize (DStringSet s) = sum $ map (dynSize . DString) $ S.toList s+ dynSize (DBinSet s) = sum $ map (dynSize . DBinary) $ S.toList s+ dynSize (DList s) = sum $ map dynSize $ V.toList s+ dynSize (DMap s) = sum $ map dynSize $ M.elems s++instance DynSize Attribute where+ dynSize (Attribute k v) = T.length k + dynSize v++instance DynSize Item where+ dynSize m = sum $ map dynSize $ attributes m++instance DynSize a => DynSize [a] where+ dynSize as = sum $ map dynSize as++instance DynSize a => DynSize (Maybe a) where+ dynSize = maybe 0 dynSize++instance (DynSize a, DynSize b) => DynSize (Either a b) where+ dynSize = either dynSize dynSize+++-------------------------------------------------------------------------------+-- | Will an attribute be considered empty by DynamoDb?+--+-- A 'PutItem' (or similar) with empty attributes will be rejected+-- with a 'ValidationException'.+nullAttr :: Attribute -> Bool+nullAttr (Attribute _ val) =+ case val of+ DString "" -> True+ DBinary "" -> True+ DNumSet s | S.null s -> True+ DStringSet s | S.null s -> True+ DBinSet s | S.null s -> True+ _ -> False+++++-------------------------------------------------------------------------------+--+-- | Item Parsing+--+-------------------------------------------------------------------------------++++-- | Failure continuation.+type Failure f r = String -> f r++-- | Success continuation.+type Success a f r = a -> f r+++-- | A continuation-based parser type.+newtype Parser a = Parser {+ runParser :: forall f r.+ Failure f r+ -> Success a f r+ -> f r+ }++instance Monad Parser where+ m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks+ in runParser m kf ks'+ {-# INLINE (>>=) #-}+ return = pure+ {-# INLINE return #-}+#if !(MIN_VERSION_base(4,13,0))+ fail msg = Parser $ \kf _ks -> kf msg+ {-# INLINE fail #-}+#endif++#if MIN_VERSION_base(4,9,0)+instance Fail.MonadFail Parser where+ fail msg = Parser $ \kf _ks -> kf msg+ {-# INLINE fail #-}+#endif++instance Functor Parser where+ fmap f m = Parser $ \kf ks -> let ks' a = ks (f a)+ in runParser m kf ks'+ {-# INLINE fmap #-}++instance Applicative Parser where+ pure a = Parser $ \_kf ks -> ks a+ {-# INLINE pure #-}+ (<*>) = apP+ {-# INLINE (<*>) #-}++instance Alternative Parser where+ empty = fail "empty"+ {-# INLINE empty #-}+ (<|>) = mplus+ {-# INLINE (<|>) #-}++instance MonadPlus Parser where+ mzero = fail "mzero"+ {-# INLINE mzero #-}+ mplus a b = Parser $ \kf ks -> let kf' _ = runParser b kf ks+ in runParser a kf' ks+ {-# INLINE mplus #-}++instance Sem.Semigroup (Parser a) where+ (<>) = mplus+ {-# INLINE (<>) #-}++instance Monoid (Parser a) where+ mempty = fail "mempty"+ {-# INLINE mempty #-}+ mappend = (Sem.<>)+ {-# INLINE mappend #-}++apP :: Parser (a -> b) -> Parser a -> Parser b+apP d e = do+ b <- d+ a <- e+ return (b a)+{-# INLINE apP #-}+++-------------------------------------------------------------------------------+-- | Types convertible to DynamoDb 'Item' collections.+--+-- Use 'attr' and 'attrAs' combinators to conveniently define instances.+class ToDynItem a where+ toItem :: a -> Item+++-------------------------------------------------------------------------------+-- | Types parseable from DynamoDb 'Item' collections.+--+-- User 'getAttr' family of functions to applicatively or monadically+-- parse into your custom types.+class FromDynItem a where+ parseItem :: Item -> Parser a+++instance ToDynItem Item where toItem = id++instance FromDynItem Item where parseItem = return+++instance DynVal a => ToDynItem [(T.Text, a)] where+ toItem as = item $ map (uncurry attr) as++instance (Typeable a, DynVal a) => FromDynItem [(T.Text, a)] where+ parseItem i = mapM f $ M.toList i+ where+ f (k,v) = do+ v' <- maybe (fail (valErr (Tagged v :: Tagged a DValue))) return $+ fromValue v+ return (k, v')+++instance DynVal a => ToDynItem (M.Map T.Text a) where+ toItem m = toItem $ M.toList m+++instance (Typeable a, DynVal a) => FromDynItem (M.Map T.Text a) where+ parseItem i = M.fromList <$> parseItem i+++valErr :: forall a. Typeable a => Tagged a DValue -> String+valErr (Tagged dv) = "Can't convert DynamoDb value " Sem.<> show dv Sem.<>+ " into type " Sem.<> (show (typeOf (undefined :: a)))+++-- | Convenience combinator for parsing fields from an 'Item' returned+-- by DynamoDb.+getAttr+ :: forall a. (Typeable a, DynVal a)+ => T.Text+ -- ^ Attribute name+ -> Item+ -- ^ Item from DynamoDb+ -> Parser a+getAttr k m = do+ case M.lookup k m of+ Nothing -> fail ("Key " Sem.<> T.unpack k Sem.<> " not found")+ Just dv -> maybe (fail (valErr (Tagged dv :: Tagged a DValue))) return $ fromValue dv+++-- | Parse attribute if it's present in the 'Item'. Fail if attribute+-- is present but conversion fails.+getAttr'+ :: forall a. (DynVal a)+ => T.Text+ -- ^ Attribute name+ -> Item+ -- ^ Item from DynamoDb+ -> Parser (Maybe a)+getAttr' k m = do+ case M.lookup k m of+ Nothing -> return Nothing+ Just dv -> return $ fromValue dv++-- | Combinator for parsing an attribute into a 'FromDynItem'.+parseAttr+ :: FromDynItem a+ => T.Text+ -- ^ Attribute name+ -> Item+ -- ^ Item from DynamoDb+ -> Parser a+parseAttr k m =+ case M.lookup k m of+ Nothing -> fail ("Key " Sem.<> T.unpack k Sem.<> " not found")+ Just (DMap dv) -> either (const (fail "...")) return $ fromItem dv+ _ -> fail ("Key " Sem.<> T.unpack k Sem.<> " is not a map!")++-------------------------------------------------------------------------------+-- | Parse an 'Item' into target type using the 'FromDynItem'+-- instance.+fromItem :: FromDynItem a => Item -> Either String a+fromItem i = runParser (parseItem i) Left Right
+ Aws/Ec2/InstanceMetadata.hs view
@@ -0,0 +1,35 @@+module Aws.Ec2.InstanceMetadata where++import Control.Applicative+import Control.Exception+import Control.Monad.Trans.Resource (throwM)+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as B8+import Data.ByteString.Lazy.UTF8 as BU+import Data.Typeable+import qualified Network.HTTP.Conduit as HTTP+import Prelude++data InstanceMetadataException+ = MetadataNotFound String+ deriving (Show, Typeable)++instance Exception InstanceMetadataException++getInstanceMetadata :: HTTP.Manager -> String -> String -> IO L.ByteString+getInstanceMetadata mgr p x = do+ req <- HTTP.parseUrlThrow ("http://169.254.169.254/" ++ p ++ '/' : x)+ HTTP.responseBody <$> HTTP.httpLbs req mgr++getInstanceMetadataListing :: HTTP.Manager -> String -> IO [String]+getInstanceMetadataListing mgr p = map BU.toString . B8.split '\n' <$> getInstanceMetadata mgr p ""++getInstanceMetadataFirst :: HTTP.Manager -> String -> IO L.ByteString+getInstanceMetadataFirst mgr p = do listing <- getInstanceMetadataListing mgr p+ case listing of+ [] -> throwM (MetadataNotFound p)+ (x:_) -> getInstanceMetadata mgr p x++getInstanceMetadataOrFirst :: HTTP.Manager -> String -> Maybe String -> IO L.ByteString+getInstanceMetadataOrFirst mgr p (Just x) = getInstanceMetadata mgr p x+getInstanceMetadataOrFirst mgr p Nothing = getInstanceMetadataFirst mgr p
+ Aws/Iam.hs view
@@ -0,0 +1,7 @@+module Aws.Iam+ ( module Aws.Iam.Commands+ , module Aws.Iam.Core+ ) where++import Aws.Iam.Commands+import Aws.Iam.Core
+ Aws/Iam/Commands.hs view
@@ -0,0 +1,51 @@+module Aws.Iam.Commands+ ( module Aws.Iam.Commands.AddUserToGroup+ , module Aws.Iam.Commands.CreateAccessKey+ , module Aws.Iam.Commands.CreateGroup+ , module Aws.Iam.Commands.CreateUser+ , module Aws.Iam.Commands.DeleteAccessKey+ , module Aws.Iam.Commands.DeleteGroup+ , module Aws.Iam.Commands.DeleteGroupPolicy+ , module Aws.Iam.Commands.DeleteUser+ , module Aws.Iam.Commands.DeleteUserPolicy+ , module Aws.Iam.Commands.GetGroupPolicy+ , module Aws.Iam.Commands.GetUser+ , module Aws.Iam.Commands.GetUserPolicy+ , module Aws.Iam.Commands.ListAccessKeys+ , module Aws.Iam.Commands.ListMfaDevices+ , module Aws.Iam.Commands.ListGroupPolicies+ , module Aws.Iam.Commands.ListGroups+ , module Aws.Iam.Commands.ListUserPolicies+ , module Aws.Iam.Commands.ListUsers+ , module Aws.Iam.Commands.PutGroupPolicy+ , module Aws.Iam.Commands.PutUserPolicy+ , module Aws.Iam.Commands.RemoveUserFromGroup+ , module Aws.Iam.Commands.UpdateAccessKey+ , module Aws.Iam.Commands.UpdateGroup+ , module Aws.Iam.Commands.UpdateUser+ ) where++import Aws.Iam.Commands.AddUserToGroup+import Aws.Iam.Commands.CreateAccessKey+import Aws.Iam.Commands.CreateGroup+import Aws.Iam.Commands.CreateUser+import Aws.Iam.Commands.DeleteAccessKey+import Aws.Iam.Commands.DeleteGroup+import Aws.Iam.Commands.DeleteGroupPolicy+import Aws.Iam.Commands.DeleteUser+import Aws.Iam.Commands.DeleteUserPolicy+import Aws.Iam.Commands.GetGroupPolicy+import Aws.Iam.Commands.GetUser+import Aws.Iam.Commands.GetUserPolicy+import Aws.Iam.Commands.ListAccessKeys+import Aws.Iam.Commands.ListMfaDevices+import Aws.Iam.Commands.ListGroupPolicies+import Aws.Iam.Commands.ListGroups+import Aws.Iam.Commands.ListUserPolicies+import Aws.Iam.Commands.ListUsers+import Aws.Iam.Commands.PutGroupPolicy+import Aws.Iam.Commands.PutUserPolicy+import Aws.Iam.Commands.RemoveUserFromGroup+import Aws.Iam.Commands.UpdateAccessKey+import Aws.Iam.Commands.UpdateGroup+import Aws.Iam.Commands.UpdateUser
+ Aws/Iam/Commands/AddUserToGroup.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.AddUserToGroup+ ( AddUserToGroup(..)+ , AddUserToGroupResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Adds the specified user to the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_AddUserToGroup.html>+data AddUserToGroup+ = AddUserToGroup {+ autgGroupName :: Text+ -- ^ Name of the group to update.+ , autgUserName :: Text+ -- ^ The of the user to add.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery AddUserToGroup where+ type ServiceConfiguration AddUserToGroup = IamConfiguration+ signQuery AddUserToGroup{..}+ = iamAction "AddUserToGroup" [+ ("GroupName" , autgGroupName)+ , ("UserName" , autgUserName)+ ]++data AddUserToGroupResponse = AddUserToGroupResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer AddUserToGroup AddUserToGroupResponse where+ type ResponseMetadata AddUserToGroupResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return AddUserToGroupResponse)++instance Transaction AddUserToGroup AddUserToGroupResponse++instance AsMemoryResponse AddUserToGroupResponse where+ type MemoryResponse AddUserToGroupResponse = AddUserToGroupResponse+ loadToMemory = return
+ Aws/Iam/Commands/CreateAccessKey.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.CreateAccessKey+ ( CreateAccessKey(..)+ , CreateAccessKeyResponse(..)+ , AccessKey(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time+import Data.Typeable+import Prelude+import Text.XML.Cursor (($//))++-- | Creates a new AWS secret access key and corresponding AWS access key ID+-- for the given user name.+--+-- If a user name is not provided, IAM will determine the user name based on+-- the access key signing the request.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_CreateAccessKey.html>+data CreateAccessKey = CreateAccessKey (Maybe Text)+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery CreateAccessKey where+ type ServiceConfiguration CreateAccessKey = IamConfiguration+ signQuery (CreateAccessKey user)+ = iamAction' "CreateAccessKey" [("UserName",) <$> user]++-- | Represents the IAM @AccessKey@ data type.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_AccessKey.html>+data AccessKey+ = AccessKey {+ akAccessKeyId :: Text+ -- ^ The Access Key ID.+ , akCreateDate :: Maybe UTCTime+ -- ^ Date and time at which the access key was created.+ , akSecretAccessKey :: Text+ -- ^ Secret key used to sign requests. The secret key is accessible only+ -- during key creation.+ , akStatus :: AccessKeyStatus+ -- ^ Whether the access key is active or not.+ , akUserName :: Text+ -- ^ The user name for which this key is defined.+ }+ deriving (Eq, Ord, Show, Typeable)++data CreateAccessKeyResponse+ = CreateAccessKeyResponse AccessKey+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer CreateAccessKey CreateAccessKeyResponse where+ type ResponseMetadata CreateAccessKeyResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $ \cursor -> do+ let attr name = force ("Missing " ++ Text.unpack name) $+ cursor $// elContent name+ akAccessKeyId <- attr "AccessKeyId"+ akSecretAccessKey <- attr "SecretAccessKey"+ akStatus <- readAccessKeyStatus <$> attr "Status"+ akUserName <- attr "UserName"+ akCreateDate <- readDate cursor+ return $ CreateAccessKeyResponse AccessKey{..}+ where+ readDate c = case c $// elCont "CreateDate" of+ (x:_) -> Just <$> parseDateTime x+ _ -> return Nothing+ readAccessKeyStatus s+ | Text.toCaseFold s == "Active" = AccessKeyActive+ | otherwise = AccessKeyInactive+++instance Transaction CreateAccessKey CreateAccessKeyResponse++instance AsMemoryResponse CreateAccessKeyResponse where+ type MemoryResponse CreateAccessKeyResponse = CreateAccessKeyResponse+ loadToMemory = return
+ Aws/Iam/Commands/CreateGroup.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.CreateGroup+ ( CreateGroup(..)+ , CreateGroupResponse(..)+ , Group(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude++-- | Creates a new group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_CreateGroup.html>+data CreateGroup+ = CreateGroup {+ cgGroupName :: Text+ -- ^ Name of the new group+ , cgPath :: Maybe Text+ -- ^ Path under which the group will be created. Defaults to @/@ if+ -- omitted.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery CreateGroup where+ type ServiceConfiguration CreateGroup = IamConfiguration+ signQuery CreateGroup{..}+ = iamAction' "CreateGroup" [+ Just ("GroupName", cgGroupName)+ , ("Path",) <$> cgPath+ ]++data CreateGroupResponse = CreateGroupResponse Group+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer CreateGroup CreateGroupResponse where+ type ResponseMetadata CreateGroupResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $+ fmap CreateGroupResponse . parseGroup++instance Transaction CreateGroup CreateGroupResponse++instance AsMemoryResponse CreateGroupResponse where+ type MemoryResponse CreateGroupResponse = CreateGroupResponse+ loadToMemory = return
+ Aws/Iam/Commands/CreateUser.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.CreateUser+ ( CreateUser(..)+ , CreateUserResponse(..)+ , User(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude++-- | Creates a new user.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_CreateUser.html>+data CreateUser+ = CreateUser {+ cuUserName :: Text+ -- ^ Name of the new user+ , cuPath :: Maybe Text+ -- ^ Path under which the user will be created. Defaults to @/@ if+ -- omitted.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery CreateUser where+ type ServiceConfiguration CreateUser = IamConfiguration+ signQuery CreateUser{..}+ = iamAction' "CreateUser" [+ Just ("UserName", cuUserName)+ , ("Path",) <$> cuPath+ ]++data CreateUserResponse = CreateUserResponse User+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer CreateUser CreateUserResponse where+ type ResponseMetadata CreateUserResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $+ fmap CreateUserResponse . parseUser++instance Transaction CreateUser CreateUserResponse++instance AsMemoryResponse CreateUserResponse where+ type MemoryResponse CreateUserResponse = CreateUserResponse+ loadToMemory = return
+ Aws/Iam/Commands/DeleteAccessKey.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.DeleteAccessKey+ ( DeleteAccessKey(..)+ , DeleteAccessKeyResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude++-- | Deletes the access key associated with the specified user.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_DeleteAccessKey.html>+data DeleteAccessKey+ = DeleteAccessKey {+ dakAccessKeyId :: Text+ -- ^ ID of the access key to be deleted.+ , dakUserName :: Maybe Text+ -- ^ User name with which the access key is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery DeleteAccessKey where+ type ServiceConfiguration DeleteAccessKey = IamConfiguration+ signQuery DeleteAccessKey{..}+ = iamAction' "DeleteAccessKey" [+ Just ("AccessKeyId", dakAccessKeyId)+ , ("UserName",) <$> dakUserName+ ]++data DeleteAccessKeyResponse = DeleteAccessKeyResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer DeleteAccessKey DeleteAccessKeyResponse where+ type ResponseMetadata DeleteAccessKeyResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return DeleteAccessKeyResponse)++instance Transaction DeleteAccessKey DeleteAccessKeyResponse++instance AsMemoryResponse DeleteAccessKeyResponse where+ type MemoryResponse DeleteAccessKeyResponse = DeleteAccessKeyResponse+ loadToMemory = return
+ Aws/Iam/Commands/DeleteGroup.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.DeleteGroup+ ( DeleteGroup(..)+ , DeleteGroupResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Deletes the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_DeleteGroup.html>+data DeleteGroup = DeleteGroup Text+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery DeleteGroup where+ type ServiceConfiguration DeleteGroup = IamConfiguration+ signQuery (DeleteGroup groupName)+ = iamAction "DeleteGroup" [("GroupName", groupName)]++data DeleteGroupResponse = DeleteGroupResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer DeleteGroup DeleteGroupResponse where+ type ResponseMetadata DeleteGroupResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return DeleteGroupResponse)++instance Transaction DeleteGroup DeleteGroupResponse++instance AsMemoryResponse DeleteGroupResponse where+ type MemoryResponse DeleteGroupResponse = DeleteGroupResponse+ loadToMemory = return
+ Aws/Iam/Commands/DeleteGroupPolicy.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.DeleteGroupPolicy+ ( DeleteGroupPolicy(..)+ , DeleteGroupPolicyResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Deletes the specified policy associated with the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_DeleteGroupPolicy.html>+data DeleteGroupPolicy+ = DeleteGroupPolicy {+ dgpPolicyName :: Text+ -- ^ Name of the policy to be deleted.+ , dgpGroupName :: Text+ -- ^ Name of the group with whom the policy is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery DeleteGroupPolicy where+ type ServiceConfiguration DeleteGroupPolicy = IamConfiguration+ signQuery DeleteGroupPolicy{..}+ = iamAction "DeleteGroupPolicy" [+ ("PolicyName", dgpPolicyName)+ , ("GroupName", dgpGroupName)+ ]++data DeleteGroupPolicyResponse = DeleteGroupPolicyResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer DeleteGroupPolicy DeleteGroupPolicyResponse where+ type ResponseMetadata DeleteGroupPolicyResponse = IamMetadata+ responseConsumer _ _ =+ iamResponseConsumer (const $ return DeleteGroupPolicyResponse)++instance Transaction DeleteGroupPolicy DeleteGroupPolicyResponse++instance AsMemoryResponse DeleteGroupPolicyResponse where+ type MemoryResponse DeleteGroupPolicyResponse = DeleteGroupPolicyResponse+ loadToMemory = return
+ Aws/Iam/Commands/DeleteUser.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.DeleteUser+ ( DeleteUser(..)+ , DeleteUserResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Deletes the specified user.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_DeleteUser.html>+data DeleteUser = DeleteUser Text+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery DeleteUser where+ type ServiceConfiguration DeleteUser = IamConfiguration+ signQuery (DeleteUser userName)+ = iamAction "DeleteUser" [("UserName", userName)]++data DeleteUserResponse = DeleteUserResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer DeleteUser DeleteUserResponse where+ type ResponseMetadata DeleteUserResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return DeleteUserResponse)++instance Transaction DeleteUser DeleteUserResponse++instance AsMemoryResponse DeleteUserResponse where+ type MemoryResponse DeleteUserResponse = DeleteUserResponse+ loadToMemory = return
+ Aws/Iam/Commands/DeleteUserPolicy.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.DeleteUserPolicy+ ( DeleteUserPolicy(..)+ , DeleteUserPolicyResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Deletes the specified policy associated with the specified user.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_DeleteUserPolicy.html>+data DeleteUserPolicy+ = DeleteUserPolicy {+ dupPolicyName :: Text+ -- ^ Name of the policy to be deleted.+ , dupUserName :: Text+ -- ^ Name of the user with whom the policy is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery DeleteUserPolicy where+ type ServiceConfiguration DeleteUserPolicy = IamConfiguration+ signQuery DeleteUserPolicy{..}+ = iamAction "DeleteUserPolicy" [+ ("PolicyName", dupPolicyName)+ , ("UserName", dupUserName)+ ]++data DeleteUserPolicyResponse = DeleteUserPolicyResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer DeleteUserPolicy DeleteUserPolicyResponse where+ type ResponseMetadata DeleteUserPolicyResponse = IamMetadata+ responseConsumer _ _ =+ iamResponseConsumer (const $ return DeleteUserPolicyResponse)++instance Transaction DeleteUserPolicy DeleteUserPolicyResponse++instance AsMemoryResponse DeleteUserPolicyResponse where+ type MemoryResponse DeleteUserPolicyResponse = DeleteUserPolicyResponse+ loadToMemory = return
+ Aws/Iam/Commands/GetGroupPolicy.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.GetGroupPolicy+ ( GetGroupPolicy(..)+ , GetGroupPolicyResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Typeable+import qualified Network.HTTP.Types as HTTP+import Text.XML.Cursor (($//))+import Prelude++-- | Retrieves the specified policy document for the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_GetGroupPolicy.html>+data GetGroupPolicy+ = GetGroupPolicy {+ ggpPolicyName :: Text+ -- ^ Name of the policy.+ , ggpGroupName :: Text+ -- ^ Name of the group with whom the policy is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery GetGroupPolicy where+ type ServiceConfiguration GetGroupPolicy = IamConfiguration+ signQuery GetGroupPolicy{..}+ = iamAction "GetGroupPolicy" [+ ("PolicyName", ggpPolicyName)+ , ("GroupName", ggpGroupName)+ ]++data GetGroupPolicyResponse+ = GetGroupPolicyResponse {+ ggprPolicyDocument :: Text+ -- ^ The policy document.+ , ggprPolicyName :: Text+ -- ^ Name of the policy.+ , ggprGroupName :: Text+ -- ^ Name of the group with whom the policy is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer GetGroupPolicy GetGroupPolicyResponse where+ type ResponseMetadata GetGroupPolicyResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $ \cursor -> do+ let attr name = force ("Missing " ++ Text.unpack name) $+ cursor $// elContent name+ ggprPolicyDocument <- decodePolicy <$>+ attr "PolicyDocument"+ ggprPolicyName <- attr "PolicyName"+ ggprGroupName <- attr "GroupName"+ return GetGroupPolicyResponse{..}+ where+ decodePolicy = Text.decodeUtf8 . HTTP.urlDecode False+ . Text.encodeUtf8+++instance Transaction GetGroupPolicy GetGroupPolicyResponse++instance AsMemoryResponse GetGroupPolicyResponse where+ type MemoryResponse GetGroupPolicyResponse = GetGroupPolicyResponse+ loadToMemory = return
+ Aws/Iam/Commands/GetUser.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.GetUser+ ( GetUser(..)+ , GetUserResponse(..)+ , User(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude++-- | Retrieves information about the given user.+--+-- If a user name is not given, IAM determines the user name based on the+-- access key signing the request.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_GetUser.html>+data GetUser = GetUser (Maybe Text)+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery GetUser where+ type ServiceConfiguration GetUser = IamConfiguration+ signQuery (GetUser user)+ = iamAction' "GetUser" [("UserName",) <$> user]++data GetUserResponse = GetUserResponse User+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer GetUser GetUserResponse where+ type ResponseMetadata GetUserResponse = IamMetadata+ responseConsumer _ _ = iamResponseConsumer $+ fmap GetUserResponse . parseUser++instance Transaction GetUser GetUserResponse++instance AsMemoryResponse GetUserResponse where+ type MemoryResponse GetUserResponse = GetUserResponse+ loadToMemory = return
+ Aws/Iam/Commands/GetUserPolicy.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.GetUserPolicy+ ( GetUserPolicy(..)+ , GetUserPolicyResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Typeable+import qualified Network.HTTP.Types as HTTP+import Text.XML.Cursor (($//))+import Prelude++-- | Retrieves the specified policy document for the specified user.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_GetUserPolicy.html>+data GetUserPolicy+ = GetUserPolicy {+ gupPolicyName :: Text+ -- ^ Name of the policy.+ , gupUserName :: Text+ -- ^ Name of the user with whom the policy is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery GetUserPolicy where+ type ServiceConfiguration GetUserPolicy = IamConfiguration+ signQuery GetUserPolicy{..}+ = iamAction "GetUserPolicy" [+ ("PolicyName", gupPolicyName)+ , ("UserName", gupUserName)+ ]++data GetUserPolicyResponse+ = GetUserPolicyResponse {+ guprPolicyDocument :: Text+ -- ^ The policy document.+ , guprPolicyName :: Text+ -- ^ Name of the policy.+ , guprUserName :: Text+ -- ^ Name of the user with whom the policy is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer GetUserPolicy GetUserPolicyResponse where+ type ResponseMetadata GetUserPolicyResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $ \cursor -> do+ let attr name = force ("Missing " ++ Text.unpack name) $+ cursor $// elContent name+ guprPolicyDocument <- decodePolicy <$>+ attr "PolicyDocument"+ guprPolicyName <- attr "PolicyName"+ guprUserName <- attr "UserName"+ return GetUserPolicyResponse{..}+ where+ decodePolicy = Text.decodeUtf8 . HTTP.urlDecode False+ . Text.encodeUtf8+++instance Transaction GetUserPolicy GetUserPolicyResponse++instance AsMemoryResponse GetUserPolicyResponse where+ type MemoryResponse GetUserPolicyResponse = GetUserPolicyResponse+ loadToMemory = return
+ Aws/Iam/Commands/ListAccessKeys.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.ListAccessKeys+ ( ListAccessKeys(..)+ , ListAccessKeysResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Time+import Data.Typeable+import Prelude+import Text.XML.Cursor (laxElement, ($/), ($//), (&|))++-- | Returns the access keys associated with the specified user.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_ListAccessKeys.html>+data ListAccessKeys+ = ListAccessKeys {+ lakUserName :: Maybe Text+ -- ^ Name of the user. If the user name is not specified, IAM will+ -- determine the user based on the key sigining the request.+ , lakMarker :: Maybe Text+ -- ^ Used for paginating requests. Marks the position of the last+ -- request.+ , lakMaxItems :: Maybe Integer+ -- ^ Used for paginating requests. Specifies the maximum number of items+ -- to return in the response. Defaults to 100.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery ListAccessKeys where+ type ServiceConfiguration ListAccessKeys = IamConfiguration+ signQuery ListAccessKeys{..}+ = iamAction' "ListAccessKeys" $ [+ ("UserName",) <$> lakUserName+ ] <> markedIter lakMarker lakMaxItems++-- | Represents the IAM @AccessKeyMetadata@ data type.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_AccessKeyMetadata.html>+data AccessKeyMetadata+ = AccessKeyMetadata {+ akmAccessKeyId :: Maybe Text+ -- ^ ID of the access key.+ , akmCreateDate :: Maybe UTCTime+ -- ^ Date and time at which the access key was created.+ , akmStatus :: Maybe Text+ -- ^ Whether the access key is active.+ , akmUserName :: Maybe Text+ -- ^ Name of the user with whom the access key is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++data ListAccessKeysResponse+ = ListAccessKeysResponse {+ lakrAccessKeyMetadata :: [AccessKeyMetadata]+ -- ^ List of 'AccessKeyMetadata' objects+ , lakrIsTruncated :: Bool+ -- ^ @True@ if the request was truncated because of too many items.+ , lakrMarker :: Maybe Text+ -- ^ Marks the position at which the request was truncated. This value+ -- must be passed with the next request to continue listing from the+ -- last position.+ }+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer ListAccessKeys ListAccessKeysResponse where+ type ResponseMetadata ListAccessKeysResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $ \cursor -> do+ (lakrIsTruncated, lakrMarker) <- markedIterResponse cursor+ lakrAccessKeyMetadata <- sequence $+ cursor $// laxElement "member" &| buildAKM+ return ListAccessKeysResponse{..}+ where+ buildAKM m = do+ let mattr name = mhead $ m $/ elContent name+ let akmAccessKeyId = mattr "AccessKeyId"+ akmStatus = mattr "Status"+ akmUserName = mattr "UserName"+ akmCreateDate <- case m $/ elCont "CreateDate" of+ (x:_) -> Just <$> parseDateTime x+ _ -> return Nothing+ return AccessKeyMetadata{..}++ mhead (x:_) = Just x+ mhead _ = Nothing++instance Transaction ListAccessKeys ListAccessKeysResponse++instance IteratedTransaction ListAccessKeys ListAccessKeysResponse where+ nextIteratedRequest request response+ = case lakrMarker response of+ Nothing -> Nothing+ Just marker -> Just $ request { lakMarker = Just marker }++instance AsMemoryResponse ListAccessKeysResponse where+ type MemoryResponse ListAccessKeysResponse = ListAccessKeysResponse+ loadToMemory = return
+ Aws/Iam/Commands/ListGroupPolicies.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.ListGroupPolicies+ ( ListGroupPolicies(..)+ , ListGroupPoliciesResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable+import Text.XML.Cursor (content, laxElement, ($//), (&/))++-- | Lists the group policies associated with the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_ListGroupPolicies.html>+data ListGroupPolicies+ = ListGroupPolicies {+ lgpGroupName :: Text+ -- ^ Policies associated with this group will be listed.+ , lgpMarker :: Maybe Text+ -- ^ Used for paginating requests. Marks the position of the last+ -- request.+ , lgpMaxItems :: Maybe Integer+ -- ^ Used for paginating requests. Specifies the maximum number of items+ -- to return in the response. Defaults to 100.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery ListGroupPolicies where+ type ServiceConfiguration ListGroupPolicies = IamConfiguration+ signQuery ListGroupPolicies{..}+ = iamAction' "ListGroupPolicies" $ [+ Just ("GroupName", lgpGroupName)+ ] <> markedIter lgpMarker lgpMaxItems++data ListGroupPoliciesResponse+ = ListGroupPoliciesResponse {+ lgprPolicyNames :: [Text]+ -- ^ List of policy names.+ , lgprIsTruncated :: Bool+ -- ^ @True@ if the request was truncated because of too many items.+ , lgprMarker :: Maybe Text+ -- ^ Marks the position at which the request was truncated. This value+ -- must be passed with the next request to continue listing from the+ -- last position.+ }+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer ListGroupPolicies ListGroupPoliciesResponse where+ type ResponseMetadata ListGroupPoliciesResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $ \cursor -> do+ (lgprIsTruncated, lgprMarker) <- markedIterResponse cursor+ let lgprPolicyNames = cursor $// laxElement "member" &/ content+ return ListGroupPoliciesResponse{..}++instance Transaction ListGroupPolicies ListGroupPoliciesResponse++instance IteratedTransaction ListGroupPolicies ListGroupPoliciesResponse where+ nextIteratedRequest request response+ = case lgprMarker response of+ Nothing -> Nothing+ Just marker -> Just $ request { lgpMarker = Just marker }++instance AsMemoryResponse ListGroupPoliciesResponse where+ type MemoryResponse ListGroupPoliciesResponse = ListGroupPoliciesResponse+ loadToMemory = return
+ Aws/Iam/Commands/ListGroups.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.ListGroups+ ( ListGroups(..)+ , ListGroupsResponse(..)+ , Group(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude+import Text.XML.Cursor (laxElement, ($//), (&|))++-- | Lists groups that have the specified path prefix.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_ListGroups.html>+data ListGroups+ = ListGroups {+ lgPathPrefix :: Maybe Text+ -- ^ Groups defined under this path will be listed. If omitted, defaults+ -- to @/@, which lists all groups.+ , lgMarker :: Maybe Text+ -- ^ Used for paginating requests. Marks the position of the last+ -- request.+ , lgMaxItems :: Maybe Integer+ -- ^ Used for paginating requests. Specifies the maximum number of items+ -- to return in the response. Defaults to 100.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery ListGroups where+ type ServiceConfiguration ListGroups = IamConfiguration+ signQuery ListGroups{..}+ = iamAction' "ListGroups" $ [+ ("PathPrefix",) <$> lgPathPrefix+ ] <> markedIter lgMarker lgMaxItems++data ListGroupsResponse+ = ListGroupsResponse {+ lgrGroups :: [Group]+ -- ^ List of 'Group's.+ , lgrIsTruncated :: Bool+ -- ^ @True@ if the request was truncated because of too many items.+ , lgrMarker :: Maybe Text+ -- ^ Marks the position at which the request was truncated. This value+ -- must be passed with the next request to continue listing from the+ -- last position.+ }+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer ListGroups ListGroupsResponse where+ type ResponseMetadata ListGroupsResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $ \cursor -> do+ (lgrIsTruncated, lgrMarker) <- markedIterResponse cursor+ lgrGroups <- sequence $+ cursor $// laxElement "member" &| parseGroup+ return ListGroupsResponse{..}++instance Transaction ListGroups ListGroupsResponse++instance IteratedTransaction ListGroups ListGroupsResponse where+ nextIteratedRequest request response+ = case lgrMarker response of+ Nothing -> Nothing+ Just marker -> Just $ request { lgMarker = Just marker }++instance AsMemoryResponse ListGroupsResponse where+ type MemoryResponse ListGroupsResponse = ListGroupsResponse+ loadToMemory = return
+ Aws/Iam/Commands/ListMfaDevices.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+module Aws.Iam.Commands.ListMfaDevices+ ( ListMfaDevices(..)+ , ListMfaDevicesResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude+import Text.XML.Cursor (laxElement, ($//), (&|))+-- | Lists the MFA devices. If the request includes the user name,+-- then this action lists all the MFA devices associated with the+-- specified user name. If you do not specify a user name, IAM+-- determines the user name implicitly based on the AWS access key ID+-- signing the request.+--+-- <https://docs.aws.amazon.com/IAM/latest/APIReference/API_ListMFADevices.html>++data ListMfaDevices = ListMfaDevices+ { lmfaUserName :: Maybe Text+ -- ^ The name of the user whose MFA devices+ -- you want to list. If you do not specify a+ -- user name, IAM determines the user name+ -- implicitly based on the AWS access key ID+ -- signing the request+ , lmfaMarker :: Maybe Text+ -- ^ Used for paginating requests. Marks the+ -- position of the last request.+ , lmfaMaxItems :: Maybe Integer+ -- ^ Used for paginating requests. Specifies+ -- the maximum number of items to return in+ -- the response. Defaults to 100.+ } deriving (Eq, Ord, Show, Typeable)++instance SignQuery ListMfaDevices where+ type ServiceConfiguration ListMfaDevices = IamConfiguration+ signQuery ListMfaDevices{..} = iamAction' "ListMFADevices"+ ([ ("UserName",) <$> lmfaUserName ]+ <> markedIter lmfaMarker lmfaMaxItems)++data ListMfaDevicesResponse = ListMfaDevicesResponse+ { lmfarMfaDevices :: [MfaDevice]+ -- ^ List of 'MFA Device's.+ , lmfarIsTruncated :: Bool+ -- ^ @True@ if the request was+ -- truncated because of too many+ -- items.+ , lmfarMarker :: Maybe Text+ -- ^ Marks the position at which the+ -- request was truncated. This value+ -- must be passed with the next+ -- request to continue listing from+ -- the last position.+ } deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer ListMfaDevices ListMfaDevicesResponse where+ type ResponseMetadata ListMfaDevicesResponse = IamMetadata+ responseConsumer _ _req =+ iamResponseConsumer $ \ cursor -> do+ (lmfarIsTruncated, lmfarMarker) <- markedIterResponse cursor+ lmfarMfaDevices <-+ sequence $ cursor $// laxElement "member" &| parseMfaDevice+ return ListMfaDevicesResponse{..}++instance Transaction ListMfaDevices ListMfaDevicesResponse++instance IteratedTransaction ListMfaDevices ListMfaDevicesResponse where+ nextIteratedRequest request response+ = case lmfarMarker response of+ Nothing -> Nothing+ Just marker -> Just $ request { lmfaMarker = Just marker }++instance AsMemoryResponse ListMfaDevicesResponse where+ type MemoryResponse ListMfaDevicesResponse = ListMfaDevicesResponse+ loadToMemory = return
+ Aws/Iam/Commands/ListUserPolicies.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.ListUserPolicies+ ( ListUserPolicies(..)+ , ListUserPoliciesResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable+import Text.XML.Cursor (content, laxElement, ($//), (&/))++-- | Lists the user policies associated with the specified user.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_ListUserPolicies.html>+data ListUserPolicies+ = ListUserPolicies {+ lupUserName :: Text+ -- ^ Policies associated with this user will be listed.+ , lupMarker :: Maybe Text+ -- ^ Used for paginating requests. Marks the position of the last+ -- request.+ , lupMaxItems :: Maybe Integer+ -- ^ Used for paginating requests. Specifies the maximum number of items+ -- to return in the response. Defaults to 100.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery ListUserPolicies where+ type ServiceConfiguration ListUserPolicies = IamConfiguration+ signQuery ListUserPolicies{..}+ = iamAction' "ListUserPolicies" $ [+ Just ("UserName", lupUserName)+ ] <> markedIter lupMarker lupMaxItems++data ListUserPoliciesResponse+ = ListUserPoliciesResponse {+ luprPolicyNames :: [Text]+ -- ^ List of policy names.+ , luprIsTruncated :: Bool+ -- ^ @True@ if the request was truncated because of too many items.+ , luprMarker :: Maybe Text+ -- ^ Marks the position at which the request was truncated. This value+ -- must be passed with the next request to continue listing from the+ -- last position.+ }+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer ListUserPolicies ListUserPoliciesResponse where+ type ResponseMetadata ListUserPoliciesResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $ \cursor -> do+ (luprIsTruncated, luprMarker) <- markedIterResponse cursor+ let luprPolicyNames = cursor $// laxElement "member" &/ content+ return ListUserPoliciesResponse{..}++instance Transaction ListUserPolicies ListUserPoliciesResponse++instance IteratedTransaction ListUserPolicies ListUserPoliciesResponse where+ nextIteratedRequest request response+ = case luprMarker response of+ Nothing -> Nothing+ Just marker -> Just $ request { lupMarker = Just marker }++instance AsMemoryResponse ListUserPoliciesResponse where+ type MemoryResponse ListUserPoliciesResponse = ListUserPoliciesResponse+ loadToMemory = return
+ Aws/Iam/Commands/ListUsers.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.ListUsers+ ( ListUsers(..)+ , ListUsersResponse(..)+ , User(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude+import Text.XML.Cursor (laxElement, ($//), (&|))++-- | Lists users that have the specified path prefix.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_ListUsers.html>+data ListUsers+ = ListUsers {+ luPathPrefix :: Maybe Text+ -- ^ Users defined under this path will be listed. If omitted, defaults+ -- to @/@, which lists all users.+ , luMarker :: Maybe Text+ -- ^ Used for paginating requests. Marks the position of the last+ -- request.+ , luMaxItems :: Maybe Integer+ -- ^ Used for paginating requests. Specifies the maximum number of items+ -- to return in the response. Defaults to 100.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery ListUsers where+ type ServiceConfiguration ListUsers = IamConfiguration+ signQuery ListUsers{..}+ = iamAction' "ListUsers" $ [+ ("PathPrefix",) <$> luPathPrefix+ ] <> markedIter luMarker luMaxItems++data ListUsersResponse+ = ListUsersResponse {+ lurUsers :: [User]+ -- ^ List of 'User's.+ , lurIsTruncated :: Bool+ -- ^ @True@ if the request was truncated because of too many items.+ , lurMarker :: Maybe Text+ -- ^ Marks the position at which the request was truncated. This value+ -- must be passed with the next request to continue listing from the+ -- last position.+ }+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer ListUsers ListUsersResponse where+ type ResponseMetadata ListUsersResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer $ \cursor -> do+ (lurIsTruncated, lurMarker) <- markedIterResponse cursor+ lurUsers <- sequence $+ cursor $// laxElement "member" &| parseUser+ return ListUsersResponse{..}++instance Transaction ListUsers ListUsersResponse++instance IteratedTransaction ListUsers ListUsersResponse where+ nextIteratedRequest request response+ = case lurMarker response of+ Nothing -> Nothing+ Just marker -> Just $ request { luMarker = Just marker }++instance AsMemoryResponse ListUsersResponse where+ type MemoryResponse ListUsersResponse = ListUsersResponse+ loadToMemory = return
+ Aws/Iam/Commands/PutGroupPolicy.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.PutGroupPolicy+ ( PutGroupPolicy(..)+ , PutGroupPolicyResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Adds a policy document with the specified name, associated with the+-- specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_PutGroupPolicy.html>+data PutGroupPolicy+ = PutGroupPolicy {+ pgpPolicyDocument :: Text+ -- ^ The policy document.+ , pgpPolicyName :: Text+ -- ^ Name of the policy.+ , pgpGroupName :: Text+ -- ^ Name of the group with whom this policy is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery PutGroupPolicy where+ type ServiceConfiguration PutGroupPolicy = IamConfiguration+ signQuery PutGroupPolicy{..}+ = iamAction "PutGroupPolicy" [+ ("PolicyDocument", pgpPolicyDocument)+ , ("PolicyName" , pgpPolicyName)+ , ("GroupName" , pgpGroupName)+ ]++data PutGroupPolicyResponse = PutGroupPolicyResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer PutGroupPolicy PutGroupPolicyResponse where+ type ResponseMetadata PutGroupPolicyResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return PutGroupPolicyResponse)++instance Transaction PutGroupPolicy PutGroupPolicyResponse++instance AsMemoryResponse PutGroupPolicyResponse where+ type MemoryResponse PutGroupPolicyResponse = PutGroupPolicyResponse+ loadToMemory = return
+ Aws/Iam/Commands/PutUserPolicy.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.PutUserPolicy+ ( PutUserPolicy(..)+ , PutUserPolicyResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Adds a policy document with the specified name, associated with the+-- specified user.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_PutUserPolicy.html>+data PutUserPolicy+ = PutUserPolicy {+ pupPolicyDocument :: Text+ -- ^ The policy document.+ , pupPolicyName :: Text+ -- ^ Name of the policy.+ , pupUserName :: Text+ -- ^ Name of the user with whom this policy is associated.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery PutUserPolicy where+ type ServiceConfiguration PutUserPolicy = IamConfiguration+ signQuery PutUserPolicy{..}+ = iamAction "PutUserPolicy" [+ ("PolicyDocument", pupPolicyDocument)+ , ("PolicyName" , pupPolicyName)+ , ("UserName" , pupUserName)+ ]++data PutUserPolicyResponse = PutUserPolicyResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer PutUserPolicy PutUserPolicyResponse where+ type ResponseMetadata PutUserPolicyResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return PutUserPolicyResponse)++instance Transaction PutUserPolicy PutUserPolicyResponse++instance AsMemoryResponse PutUserPolicyResponse where+ type MemoryResponse PutUserPolicyResponse = PutUserPolicyResponse+ loadToMemory = return
+ Aws/Iam/Commands/RemoveUserFromGroup.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.RemoveUserFromGroup+ ( RemoveUserFromGroup(..)+ , RemoveUserFromGroupResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Data.Text (Text)+import Data.Typeable++-- | Removes the specified user from the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_RemoveUserFromGroup.html>+data RemoveUserFromGroup+ = RemoveUserFromGroup {+ rufgGroupName :: Text+ -- ^ Name of the group to update.+ , rufgUserName :: Text+ -- ^ The of the user to add.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery RemoveUserFromGroup where+ type ServiceConfiguration RemoveUserFromGroup = IamConfiguration+ signQuery RemoveUserFromGroup{..}+ = iamAction "RemoveUserFromGroup" [+ ("GroupName" , rufgGroupName)+ , ("UserName" , rufgUserName)+ ]++data RemoveUserFromGroupResponse = RemoveUserFromGroupResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer RemoveUserFromGroup RemoveUserFromGroupResponse where+ type ResponseMetadata RemoveUserFromGroupResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return RemoveUserFromGroupResponse)++instance Transaction RemoveUserFromGroup RemoveUserFromGroupResponse++instance AsMemoryResponse RemoveUserFromGroupResponse where+ type MemoryResponse RemoveUserFromGroupResponse = RemoveUserFromGroupResponse+ loadToMemory = return
+ Aws/Iam/Commands/UpdateAccessKey.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.UpdateAccessKey+ ( UpdateAccessKey(..)+ , UpdateAccessKeyResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude++-- | Changes the status of the specified access key.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_UpdateAccessKey.html>+data UpdateAccessKey+ = UpdateAccessKey {+ uakAccessKeyId :: Text+ -- ^ ID of the access key to update.+ , uakStatus :: AccessKeyStatus+ -- ^ New status of the access key.+ , uakUserName :: Maybe Text+ -- ^ Name of the user to whom the access key belongs. If omitted, the+ -- user will be determined based on the access key used to sign the+ -- request.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery UpdateAccessKey where+ type ServiceConfiguration UpdateAccessKey = IamConfiguration+ signQuery UpdateAccessKey{..}+ = iamAction' "UpdateAccessKey" [+ Just ("AccessKeyId", uakAccessKeyId)+ , Just ("Status", showStatus uakStatus)+ , ("UserName",) <$> uakUserName+ ]+ where+ showStatus AccessKeyActive = "Active"+ showStatus _ = "Inactive"++data UpdateAccessKeyResponse = UpdateAccessKeyResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer UpdateAccessKey UpdateAccessKeyResponse where+ type ResponseMetadata UpdateAccessKeyResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return UpdateAccessKeyResponse)++instance Transaction UpdateAccessKey UpdateAccessKeyResponse++instance AsMemoryResponse UpdateAccessKeyResponse where+ type MemoryResponse UpdateAccessKeyResponse = UpdateAccessKeyResponse+ loadToMemory = return
+ Aws/Iam/Commands/UpdateGroup.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.UpdateGroup+ ( UpdateGroup(..)+ , UpdateGroupResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude++-- | Updates the name and/or path of the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_UpdateGroup.html>+data UpdateGroup+ = UpdateGroup {+ ugGroupName :: Text+ -- ^ Name of the group to be updated.+ , ugNewGroupName :: Maybe Text+ -- ^ New name for the group.+ , ugNewPath :: Maybe Text+ -- ^ New path to which the group will be moved.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery UpdateGroup where+ type ServiceConfiguration UpdateGroup = IamConfiguration+ signQuery UpdateGroup{..}+ = iamAction' "UpdateGroup" [+ Just ("GroupName", ugGroupName)+ , ("NewGroupName",) <$> ugNewGroupName+ , ("NewPath",) <$> ugNewPath+ ]++data UpdateGroupResponse = UpdateGroupResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer UpdateGroup UpdateGroupResponse where+ type ResponseMetadata UpdateGroupResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return UpdateGroupResponse)++instance Transaction UpdateGroup UpdateGroupResponse++instance AsMemoryResponse UpdateGroupResponse where+ type MemoryResponse UpdateGroupResponse = UpdateGroupResponse+ loadToMemory = return
+ Aws/Iam/Commands/UpdateUser.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Aws.Iam.Commands.UpdateUser+ ( UpdateUser(..)+ , UpdateUserResponse(..)+ ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude++-- | Updates the name and/or path of the specified user.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_UpdateUser.html>+data UpdateUser+ = UpdateUser {+ uuUserName :: Text+ -- ^ Name of the user to be updated.+ , uuNewUserName :: Maybe Text+ -- ^ New name for the user.+ , uuNewPath :: Maybe Text+ -- ^ New path to which the user will be moved.+ }+ deriving (Eq, Ord, Show, Typeable)++instance SignQuery UpdateUser where+ type ServiceConfiguration UpdateUser = IamConfiguration+ signQuery UpdateUser{..}+ = iamAction' "UpdateUser" [+ Just ("UserName", uuUserName)+ , ("NewUserName",) <$> uuNewUserName+ , ("NewPath",) <$> uuNewPath+ ]++data UpdateUserResponse = UpdateUserResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer UpdateUser UpdateUserResponse where+ type ResponseMetadata UpdateUserResponse = IamMetadata+ responseConsumer _ _+ = iamResponseConsumer (const $ return UpdateUserResponse)++instance Transaction UpdateUser UpdateUserResponse++instance AsMemoryResponse UpdateUserResponse where+ type MemoryResponse UpdateUserResponse = UpdateUserResponse+ loadToMemory = return
+ Aws/Iam/Core.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+module Aws.Iam.Core+ ( iamSignQuery+ , iamResponseConsumer+ , IamMetadata(..)+ , IamConfiguration(..)+ , IamError(..)++ , parseDateTime++ , AccessKeyStatus(..)+ , User(..)+ , parseUser+ , Group(..)+ , parseGroup+ , MfaDevice(..)+ , parseMfaDevice+ ) where++import Aws.Core+import qualified Blaze.ByteString.Builder as Blaze+import qualified Blaze.ByteString.Builder.Char8 as Blaze8+import Control.Exception (Exception)+import Control.Monad+import Control.Monad.Trans.Resource (MonadThrow, throwM)+import Data.ByteString (ByteString)+import Data.IORef+import Data.List (intersperse, sort)+import Data.Maybe+import Data.Monoid ()+import qualified Data.Semigroup as Sem+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time+import Data.Typeable+import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Types as HTTP+#if !MIN_VERSION_time(1,5,0)+import System.Locale+#endif+import Text.XML.Cursor (($//))+import qualified Text.XML.Cursor as Cu++data IamError+ = IamError {+ iamStatusCode :: HTTP.Status+ , iamErrorCode :: Text+ , iamErrorMessage :: Text+ }+ deriving (Show, Typeable)++instance Exception IamError++data IamMetadata+ = IamMetadata {+ requestId :: Maybe Text+ }+ deriving (Show, Typeable)++instance Loggable IamMetadata where+ toLogText (IamMetadata r) = "IAM: request ID=" Sem.<> fromMaybe "<none>" r++instance Sem.Semigroup IamMetadata where+ IamMetadata r1 <> IamMetadata r2 = IamMetadata (r1 `mplus` r2)++instance Monoid IamMetadata where+ mempty = IamMetadata Nothing+ mappend = (Sem.<>)++data IamConfiguration qt+ = IamConfiguration {+ iamEndpoint :: ByteString+ , iamPort :: Int+ , iamProtocol :: Protocol+ , iamHttpMethod :: Method+ }+ deriving (Show)++instance DefaultServiceConfiguration (IamConfiguration NormalQuery) where+ defServiceConfig = iam PostQuery HTTPS iamEndpointDefault+ debugServiceConfig = iam PostQuery HTTP iamEndpointDefault++instance DefaultServiceConfiguration (IamConfiguration UriOnlyQuery) where+ defServiceConfig = iam Get HTTPS iamEndpointDefault+ debugServiceConfig = iam Get HTTP iamEndpointDefault++-- | The default IAM endpoint.+iamEndpointDefault :: ByteString+iamEndpointDefault = "iam.amazonaws.com"++-- | Constructs an IamConfiguration with the specified parameters.+iam :: Method -> Protocol -> ByteString -> IamConfiguration qt+iam method protocol endpoint+ = IamConfiguration {+ iamEndpoint = endpoint+ , iamProtocol = protocol+ , iamPort = defaultPort protocol+ , iamHttpMethod = method+ }++-- | Constructs a 'SignedQuery' with the specified request parameters.+iamSignQuery+ :: [(ByteString, ByteString)]+ -- ^ Pairs of parameter names and values that will be passed as part of+ -- the request data.+ -> IamConfiguration qt+ -> SignatureData+ -> SignedQuery+iamSignQuery q IamConfiguration{..} SignatureData{..}+ = SignedQuery {+ sqMethod = iamHttpMethod+ , sqProtocol = iamProtocol+ , sqHost = iamEndpoint+ , sqPort = iamPort+ , sqPath = "/"+ , sqQuery = signedQuery+ , sqDate = Just signatureTime+ , sqAuthorization = Nothing+ , sqContentType = Nothing+ , sqContentMd5 = Nothing+ , sqAmzHeaders = []+ , sqOtherHeaders = []+ , sqBody = Nothing+ , sqStringToSign = stringToSign+ }+ where+ sig = signature signatureCredentials HmacSHA256 stringToSign+ signedQuery = ("Signature", Just sig):expandedQuery+ accessKey = accessKeyID signatureCredentials+ timestampHeader =+ case signatureTimeInfo of+ AbsoluteTimestamp time -> ("Timestamp", Just $ fmtAmzTime time)+ AbsoluteExpires time -> ("Expires" , Just $ fmtAmzTime time)+ newline = Blaze8.fromChar '\n'+ stringToSign = Blaze.toByteString . mconcat . intersperse newline $+ map Blaze.copyByteString+ [httpMethod iamHttpMethod, iamEndpoint, "/"]+ ++ [HTTP.renderQueryBuilder False expandedQuery]+ expandedQuery = HTTP.toQuery . sort $ (map (\(a,b) -> (a, Just b)) q ++) [+ ("AWSAccessKeyId" , Just accessKey)+ , ("SignatureMethod" , Just $ amzHash HmacSHA256)+ , ("SignatureVersion", Just "2")+ , ("Version" , Just "2010-05-08")+ , timestampHeader] +++ maybe [] (\tok -> [ ("SecurityToken", Just tok)]) (iamToken signatureCredentials)++-- | Reads the metadata from an IAM response and delegates parsing the rest of+-- the data from the response to the given function.+iamResponseConsumer :: (Cu.Cursor -> Response IamMetadata a)+ -> IORef IamMetadata+ -> HTTPResponseConsumer a+iamResponseConsumer inner md resp = xmlCursorConsumer parse md resp+ where+ parse cursor = do+ let rid = listToMaybe $ cursor $// elContent "RequestID"+ tellMetadata $ IamMetadata rid+ case cursor $// Cu.laxElement "Error" of+ [] -> inner cursor+ (err:_) -> fromError err+ fromError cursor = do+ errCode <- force "Missing Error Code" $ cursor $// elContent "Code"+ errMsg <- force "Missing Error Message" $ cursor $// elContent "Message"+ throwM $ IamError (HTTP.responseStatus resp) errCode errMsg++-- | Parses IAM @DateTime@ data type.+parseDateTime :: MonadThrow m => String -> m UTCTime+parseDateTime x+ = case parseTimeM True defaultTimeLocale iso8601UtcDate x of+ Nothing -> throwM $ XmlException $ "Invalid DateTime: " ++ x+ Just dt -> return dt++-- | The IAM @User@ data type.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_User.html>+data User+ = User {+ userArn :: Text+ -- ^ ARN used to refer to this user.+ , userCreateDate :: UTCTime+ -- ^ Date and time at which the user was created.+ , userPath :: Text+ -- ^ Path under which the user was created.+ , userUserId :: Text+ -- ^ Unique identifier used to refer to this user. + , userUserName :: Text+ -- ^ Name of the user.+ }+ deriving (Eq, Ord, Show, Typeable)++-- | Parses the IAM @User@ data type.+parseUser :: MonadThrow m => Cu.Cursor -> m User+parseUser cursor = do+ userArn <- attr "Arn"+ userCreateDate <- attr "CreateDate" >>= parseDateTime . Text.unpack+ userPath <- attr "Path"+ userUserId <- attr "UserId"+ userUserName <- attr "UserName"+ return User{..}+ where+ attr name = force ("Missing " ++ Text.unpack name) $+ cursor $// elContent name+++-- | The IAM @Group@ data type.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_Group.html>+data Group+ = Group {+ groupArn :: Text+ -- ^ ARN used to refer to this group.+ , groupCreateDate :: UTCTime+ -- ^ Date and time at which the group was created.+ , groupPath :: Text+ -- ^ Path under which the group was created.+ , groupGroupId :: Text+ -- ^ Unique identifier used to refer to this group. + , groupGroupName :: Text+ -- ^ Name of the group.+ }+ deriving (Eq, Ord, Show, Typeable)++-- | Parses the IAM @Group@ data type.+parseGroup :: MonadThrow m => Cu.Cursor -> m Group+parseGroup cursor = do+ groupArn <- attr "Arn"+ groupCreateDate <- attr "CreateDate" >>= parseDateTime . Text.unpack+ groupPath <- attr "Path"+ groupGroupId <- attr "GroupId"+ groupGroupName <- attr "GroupName"+ return Group{..}+ where+ attr name = force ("Missing " ++ Text.unpack name) $+ cursor $// elContent name+++data AccessKeyStatus = AccessKeyActive | AccessKeyInactive+ deriving (Eq, Ord, Show, Typeable)++-- | The IAM @MFADevice@ data type.+--+-- <https://docs.aws.amazon.com/IAM/latest/APIReference/API_MFADevice.html>+data MfaDevice = MfaDevice+ { mfaEnableDate :: UTCTime+ -- ^ The date when the MFA device was enabled for+ -- the user.+ , mfaSerialNumber :: Text+ -- ^ The serial number that uniquely identifies the+ -- MFA device. For virtual MFA devices, the serial+ -- number is the device ARN.+ , mfaUserName :: Text+ -- ^ The user with whom the MFA device is+ -- associated. Minimum length of 1. Maximum length+ -- of 64.+ } deriving (Eq, Ord, Show, Typeable)++-- | Parses the IAM @MFADevice@ data type.+parseMfaDevice :: MonadThrow m => Cu.Cursor -> m MfaDevice+parseMfaDevice cursor = do+ mfaEnableDate <- attr "EnableDate" >>= parseDateTime . Text.unpack+ mfaSerialNumber <- attr "SerialNumber"+ mfaUserName <- attr "UserName"+ return MfaDevice{..}+ where attr name = force ("Missing " ++ Text.unpack name) $+ cursor $// elContent name
+ Aws/Iam/Internal.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+module Aws.Iam.Internal+ ( iamAction+ , iamAction'+ , markedIter+ , markedIterResponse++ -- * Re-exports+ , (<>)+ ) where++import Aws.Core+import Aws.Iam.Core+import Control.Applicative+import Control.Arrow (second)+import Control.Monad+import Control.Monad.Trans.Resource (MonadThrow)+import Data.ByteString (ByteString)+import Data.Maybe+import Data.Monoid+import Prelude+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Text.XML.Cursor (($//))+import qualified Text.XML.Cursor as Cu++-- | Similar to 'iamSignQuery'. Accepts parameters in @Text@ form and UTF-8+-- encodes them. Accepts the @Action@ parameter separately since it's always+-- required.+iamAction+ :: ByteString+ -> [(ByteString, Text)]+ -> IamConfiguration qt+ -> SignatureData+ -> SignedQuery+iamAction action = iamSignQuery+ . (:) ("Action", action)+ . map (second Text.encodeUtf8)++-- | Similar to 'iamAction'. Accepts parameter list with @Maybe@ parameters.+-- Ignores @Nothing@s.+iamAction'+ :: ByteString+ -> [Maybe (ByteString, Text)]+ -> IamConfiguration qt+ -> SignatureData+ -> SignedQuery+iamAction' action = iamAction action . catMaybes++-- | Returns the parameters @Marker@ and @MaxItems@ that are present in all+-- IAM data pagination requests.+markedIter :: Maybe Text -> Maybe Integer -> [Maybe (ByteString, Text)]+markedIter marker maxItems+ = [ ("Marker" ,) <$> marker+ , ("MaxItems",) . encodeInteger <$> maxItems+ ]+ where+ encodeInteger = Text.pack . show++-- | Reads and returns the @IsTruncated@ and @Marker@ attributes present in+-- all IAM data pagination responses.+markedIterResponse+ :: MonadThrow m+ => Cu.Cursor+ -> m (Bool, Maybe Text)+markedIterResponse cursor = do+ isTruncated <- (Text.toCaseFold "true" ==) `liftM` attr "IsTruncated"+ marker <- if isTruncated+ then Just `liftM` attr "Marker"+ else return Nothing+ return (isTruncated, marker)+ where+ attr name = force ("Missing " ++ Text.unpack name) $+ cursor $// elContent name
+ Aws/Network.hs view
@@ -0,0 +1,20 @@+module Aws.Network where++import Data.Maybe+import Control.Exception+import Network.BSD (getProtocolNumber)+import Network.Socket+import System.Timeout++-- Make a good guess if a host is reachable.+hostAvailable :: String -> IO Bool+hostAvailable h = do+ sock <- getProtocolNumber "tcp" >>= socket AF_INET Stream+ addr <- (addrAddress . head) `fmap` getAddrInfo (Just (defaultHints { addrFlags = [ AI_PASSIVE ] } )) (Just h) (Just "80")+ case addr of+ remote@(SockAddrInet _ _) -> do+ v <- catch (timeout 100000 (connect sock remote) >>= return . isJust)+ (\(_ :: SomeException) -> return False)+ close sock+ return v+ _ -> return False
Aws/S3/Commands.hs view
@@ -1,19 +1,39 @@ module Aws.S3.Commands ( module Aws.S3.Commands.CopyObject+, module Aws.S3.Commands.DeleteBucket , module Aws.S3.Commands.DeleteObject+, module Aws.S3.Commands.DeleteObjectVersion+, module Aws.S3.Commands.DeleteObjects , module Aws.S3.Commands.GetBucket+, module Aws.S3.Commands.GetBucketLocation+, module Aws.S3.Commands.GetBucketObjectVersions+, module Aws.S3.Commands.GetBucketVersioning , module Aws.S3.Commands.GetObject , module Aws.S3.Commands.GetService+, module Aws.S3.Commands.HeadObject , module Aws.S3.Commands.PutBucket+, module Aws.S3.Commands.PutBucketVersioning , module Aws.S3.Commands.PutObject+, module Aws.S3.Commands.RestoreObject+, module Aws.S3.Commands.Multipart ) where import Aws.S3.Commands.CopyObject+import Aws.S3.Commands.DeleteBucket import Aws.S3.Commands.DeleteObject+import Aws.S3.Commands.DeleteObjectVersion+import Aws.S3.Commands.DeleteObjects import Aws.S3.Commands.GetBucket+import Aws.S3.Commands.GetBucketLocation+import Aws.S3.Commands.GetBucketObjectVersions+import Aws.S3.Commands.GetBucketVersioning import Aws.S3.Commands.GetObject import Aws.S3.Commands.GetService+import Aws.S3.Commands.HeadObject import Aws.S3.Commands.PutBucket+import Aws.S3.Commands.PutBucketVersioning import Aws.S3.Commands.PutObject+import Aws.S3.Commands.RestoreObject+import Aws.S3.Commands.Multipart
Aws/S3/Commands/CopyObject.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Aws.S3.Commands.CopyObject where @@ -5,7 +6,8 @@ import Aws.S3.Core import Control.Applicative import Control.Arrow (second)-import Control.Failure+import Control.Monad.Trans.Resource (throwM)+import qualified Data.ByteString as B import qualified Data.CaseInsensitive as CI import Data.Maybe import qualified Data.Text as T@@ -13,7 +15,10 @@ import Data.Time import qualified Network.HTTP.Conduit as HTTP import Text.XML.Cursor (($/), (&|))+#if !MIN_VERSION_time(1,5,0) import System.Locale+#endif+import Prelude data CopyMetadataDirective = CopyMetadata | ReplaceMetadata [(T.Text,T.Text)] deriving (Show)@@ -28,13 +33,14 @@ , coIfModifiedSince :: Maybe UTCTime , coStorageClass :: Maybe StorageClass , coAcl :: Maybe CannedAcl+ , coContentType :: Maybe B.ByteString } deriving (Show) copyObject :: Bucket -> T.Text -> ObjectId -> CopyMetadataDirective -> CopyObject-copyObject bucket obj src meta = CopyObject obj bucket src meta Nothing Nothing Nothing Nothing Nothing Nothing+copyObject bucket obj src meta = CopyObject obj bucket src meta Nothing Nothing Nothing Nothing Nothing Nothing Nothing -data CopyObjectResponse +data CopyObjectResponse = CopyObjectResponse { corVersionId :: Maybe T.Text , corLastModified :: UTCTime@@ -51,7 +57,7 @@ , s3QObject = Just $ T.encodeUtf8 coObjectName , s3QSubresources = [] , s3QQuery = []- , s3QContentType = Nothing+ , s3QContentType = coContentType , s3QContentMd5 = Nothing , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [ Just ("x-amz-copy-source",@@ -87,18 +93,18 @@ instance ResponseConsumer CopyObject CopyObjectResponse where type ResponseMetadata CopyObjectResponse = S3Metadata- responseConsumer _ mref = flip s3ResponseConsumer mref $ \resp -> do+ responseConsumer _ _ mref = flip s3ResponseConsumer mref $ \resp -> do let vid = T.decodeUtf8 `fmap` lookup "x-amz-version-id" (HTTP.responseHeaders resp) (lastMod, etag) <- xmlCursorConsumer parse mref resp return $ CopyObjectResponse vid lastMod etag where parse el = do- let parseHttpDate' x = case parseTime defaultTimeLocale iso8601UtcDate x of- Nothing -> failure $ XmlException ("Invalid Last-Modified " ++ x)+ let parseHttpDate' x = case parseTimeM True defaultTimeLocale iso8601UtcDate x of+ Nothing -> throwM $ XmlException ("Invalid Last-Modified " ++ x) Just y -> return y lastMod <- forceM "Missing Last-Modified" $ el $/ elContent "LastModified" &| (parseHttpDate' . T.unpack) etag <- force "Missing ETag" $ el $/ elContent "ETag" return (lastMod, etag)- + instance Transaction CopyObject CopyObjectResponse
+ Aws/S3/Commands/DeleteBucket.hs view
@@ -0,0 +1,39 @@+module Aws.S3.Commands.DeleteBucket+where++import Aws.Core+import Aws.S3.Core+import Data.ByteString.Char8 ({- IsString -})+import qualified Data.Text.Encoding as T++data DeleteBucket = DeleteBucket { dbBucket :: Bucket }+ deriving (Show)++data DeleteBucketResponse = DeleteBucketResponse {}+ deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery DeleteBucket where+ type ServiceConfiguration DeleteBucket = S3Configuration+ signQuery DeleteBucket {..} = s3SignQuery S3Query {+ s3QMethod = Delete+ , s3QBucket = Just $ T.encodeUtf8 dbBucket+ , s3QSubresources = []+ , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = []+ , s3QRequestBody = Nothing+ , s3QObject = Nothing+ }++instance ResponseConsumer DeleteBucket DeleteBucketResponse where+ type ResponseMetadata DeleteBucketResponse = S3Metadata+ responseConsumer _ _ = s3ResponseConsumer $ \_ -> return DeleteBucketResponse++instance Transaction DeleteBucket DeleteBucketResponse++instance AsMemoryResponse DeleteBucketResponse where+ type MemoryResponse DeleteBucketResponse = DeleteBucketResponse+ loadToMemory = return
Aws/S3/Commands/DeleteObject.hs view
@@ -10,10 +10,10 @@ data DeleteObject = DeleteObject { doObjectName :: T.Text, doBucket :: Bucket-}+} deriving (Show) data DeleteObjectResponse = DeleteObjectResponse{-}+} deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery DeleteObject where@@ -33,7 +33,8 @@ instance ResponseConsumer DeleteObject DeleteObjectResponse where type ResponseMetadata DeleteObjectResponse = S3Metadata- responseConsumer _ = s3ResponseConsumer $ \_ -> return DeleteObjectResponse+ responseConsumer _ _+ = s3ResponseConsumer $ \_ -> return DeleteObjectResponse instance Transaction DeleteObject DeleteObjectResponse
+ Aws/S3/Commands/DeleteObjectVersion.hs view
@@ -0,0 +1,52 @@+module Aws.S3.Commands.DeleteObjectVersion+where++import Aws.Core+import Aws.S3.Core+import Data.ByteString.Char8 ({- IsString -})+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++data DeleteObjectVersion = DeleteObjectVersion {+ dovObjectName :: T.Text,+ dovBucket :: Bucket,+ dovVersionId :: T.Text+} deriving (Show)++deleteObjectVersion :: Bucket -> T.Text -> T.Text -> DeleteObjectVersion+deleteObjectVersion bucket object version+ = DeleteObjectVersion {+ dovObjectName = object+ , dovBucket = bucket+ , dovVersionId = version+ }++data DeleteObjectVersionResponse = DeleteObjectVersionResponse {+} deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery DeleteObjectVersion where+ type ServiceConfiguration DeleteObjectVersion = S3Configuration+ signQuery DeleteObjectVersion {..} = s3SignQuery S3Query {+ s3QMethod = Delete+ , s3QBucket = Just $ T.encodeUtf8 dovBucket+ , s3QSubresources = [ ("versionId", Just $ T.encodeUtf8 dovVersionId) ]+ , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = []+ , s3QRequestBody = Nothing+ , s3QObject = Just $ T.encodeUtf8 dovObjectName+ }++instance ResponseConsumer DeleteObjectVersion DeleteObjectVersionResponse where+ type ResponseMetadata DeleteObjectVersionResponse = S3Metadata+ responseConsumer _ _+ = s3ResponseConsumer $ \_ -> return DeleteObjectVersionResponse++instance Transaction DeleteObjectVersion DeleteObjectVersionResponse++instance AsMemoryResponse DeleteObjectVersionResponse where+ type MemoryResponse DeleteObjectVersionResponse = DeleteObjectVersionResponse+ loadToMemory = return
+ Aws/S3/Commands/DeleteObjects.hs view
@@ -0,0 +1,127 @@+module Aws.S3.Commands.DeleteObjects where++import Aws.Core+import Aws.S3.Core+import qualified Crypto.Hash as CH+import qualified Data.Map as M+import Data.Maybe+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+import qualified Text.XML as XML+import qualified Text.XML.Cursor as Cu+import Text.XML.Cursor (($/), (&|))+import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 ({- IsString -})+import Control.Applicative+import Prelude++data DeleteObjects+ = DeleteObjects {+ dosBucket :: Bucket+ , dosObjects :: [(Object, Maybe T.Text)] -- snd is an optional versionId+ , dosQuiet :: Bool+ , dosMultiFactorAuthentication :: Maybe T.Text+ }+ deriving (Show)++-- simple use case: neither mfa, nor version specified, quiet+deleteObjects :: Bucket -> [T.Text] -> DeleteObjects+deleteObjects bucket objs =+ DeleteObjects {+ dosBucket = bucket+ , dosObjects = zip objs $ repeat Nothing+ , dosQuiet = True+ , dosMultiFactorAuthentication = Nothing+ }++data DeleteObjectsResponse+ = DeleteObjectsResponse {+ dorDeleted :: [DORDeleted]+ , dorErrors :: [DORErrors]+ }+ deriving (Show)++--omitting DeleteMarker because it appears superfluous+data DORDeleted+ = DORDeleted {+ ddKey :: T.Text+ , ddVersionId :: Maybe T.Text+ , ddDeleteMarkerVersionId :: Maybe T.Text+ }+ deriving (Show)++data DORErrors+ = DORErrors {+ deKey :: T.Text+ , deCode :: T.Text+ , deMessage :: T.Text+ }+ deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery DeleteObjects where+ type ServiceConfiguration DeleteObjects = S3Configuration++ signQuery DeleteObjects {..} = s3SignQuery S3Query+ {+ s3QMethod = Post+ , s3QBucket = Just $ T.encodeUtf8 dosBucket+ , s3QSubresources = HTTP.toQuery [("delete" :: B.ByteString, Nothing :: Maybe B.ByteString)]+ , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Just $ CH.hashlazy dosBody+ , s3QObject = Nothing+ , s3QAmzHeaders = maybeToList $ (("x-amz-mfa", ) . T.encodeUtf8) <$> dosMultiFactorAuthentication+ , s3QOtherHeaders = []+ , s3QRequestBody = Just $ HTTP.RequestBodyLBS dosBody+ }+ where dosBody = XML.renderLBS XML.def XML.Document {+ XML.documentPrologue = XML.Prologue [] Nothing []+ , XML.documentRoot = root+ , XML.documentEpilogue = []+ }+ root = XML.Element {+ XML.elementName = "Delete"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = quietNode dosQuiet : (objectNode <$> dosObjects)+ }+ objectNode (obj, mbVersion) = XML.NodeElement XML.Element {+ XML.elementName = "Object"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = keyNode obj : maybeToList (versionNode <$> mbVersion)+ }+ versionNode = toNode "VersionId"+ keyNode = toNode "Key"+ quietNode b = toNode "Quiet" $ if b then "true" else "false"+ toNode name content = XML.NodeElement XML.Element {+ XML.elementName = name+ , XML.elementAttributes = M.empty+ , XML.elementNodes = [XML.NodeContent content]+ }++instance ResponseConsumer DeleteObjects DeleteObjectsResponse where+ type ResponseMetadata DeleteObjectsResponse = S3Metadata++ responseConsumer _ _ = s3XmlResponseConsumer parse+ where parse cursor = do+ dorDeleted <- sequence $ cursor $/ Cu.laxElement "Deleted" &| parseDeleted+ dorErrors <- sequence $ cursor $/ Cu.laxElement "Error" &| parseErrors+ return DeleteObjectsResponse {..}+ parseDeleted c = do+ ddKey <- force "Missing Key" $ c $/ elContent "Key"+ let ddVersionId = listToMaybe $ c $/ elContent "VersionId"+ ddDeleteMarkerVersionId = listToMaybe $ c $/ elContent "DeleteMarkerVersionId"+ return DORDeleted {..}+ parseErrors c = do+ deKey <- force "Missing Key" $ c $/ elContent "Key"+ deCode <- force "Missing Code" $ c $/ elContent "Code"+ deMessage <- force "Missing Message" $ c $/ elContent "Message"+ return DORErrors {..}++instance Transaction DeleteObjects DeleteObjectsResponse++instance AsMemoryResponse DeleteObjectsResponse where+ type MemoryResponse DeleteObjectsResponse = DeleteObjectsResponse+ loadToMemory = return
Aws/S3/Commands/GetBucket.hs view
@@ -11,6 +11,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Traversable+import Prelude import qualified Network.HTTP.Types as HTTP import qualified Text.XML.Cursor as Cu @@ -43,6 +44,8 @@ , gbrPrefix :: Maybe T.Text , gbrContents :: [ObjectInfo] , gbrCommonPrefixes :: [T.Text]+ , gbrIsTruncated :: Bool+ , gbrNextMarker :: Maybe T.Text } deriving (Show) @@ -70,12 +73,14 @@ instance ResponseConsumer r GetBucketResponse where type ResponseMetadata GetBucketResponse = S3Metadata - responseConsumer _ = s3XmlResponseConsumer parse+ responseConsumer _ _ = s3XmlResponseConsumer parse where parse cursor = do name <- force "Missing Name" $ cursor $/ elContent "Name" let delimiter = listToMaybe $ cursor $/ elContent "Delimiter" let marker = listToMaybe $ cursor $/ elContent "Marker" maxKeys <- Data.Traversable.sequence . listToMaybe $ cursor $/ elContent "MaxKeys" &| textReadInt+ let truncated = maybe True (/= "false") $ listToMaybe $ cursor $/ elContent "IsTruncated"+ let nextMarker = listToMaybe $ cursor $/ elContent "NextMarker" let prefix = listToMaybe $ cursor $/ elContent "Prefix" contents <- sequence $ cursor $/ Cu.laxElement "Contents" &| parseObjectInfo let commonPrefixes = cursor $/ Cu.laxElement "CommonPrefixes" &// Cu.content@@ -87,9 +92,21 @@ , gbrPrefix = prefix , gbrContents = contents , gbrCommonPrefixes = commonPrefixes+ , gbrIsTruncated = truncated+ , gbrNextMarker = nextMarker } instance Transaction GetBucket GetBucketResponse++instance IteratedTransaction GetBucket GetBucketResponse where+ nextIteratedRequest request response+ = case (gbrIsTruncated response, gbrNextMarker response, gbrContents response) of+ (True, Just marker, _ ) -> Just $ request { gbMarker = Just marker }+ (True, Nothing, contents@(_:_)) -> Just $ request { gbMarker = Just $ objectKey $ last contents }+ (_, _, _ ) -> Nothing++instance ListResponse GetBucketResponse ObjectInfo where+ listResponse = gbrContents instance AsMemoryResponse GetBucketResponse where type MemoryResponse GetBucketResponse = GetBucketResponse
+ Aws/S3/Commands/GetBucketLocation.hs view
@@ -0,0 +1,56 @@+module Aws.S3.Commands.GetBucketLocation+ where++import Aws.Core+import Aws.S3.Core++import qualified Data.ByteString.Char8 as B8++import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Types as HTTP+import Text.XML.Cursor (($.//))++data GetBucketLocation+ = GetBucketLocation {+ gblBucket :: Bucket+ } deriving Show++getBucketLocation :: Bucket -> GetBucketLocation+getBucketLocation bucket+ = GetBucketLocation {+ gblBucket = bucket+ }++data GetBucketLocationResponse+ = GetBucketLocationResponse { gblrLocationConstraint :: LocationConstraint }+ deriving Show++instance SignQuery GetBucketLocation where+ type ServiceConfiguration GetBucketLocation = S3Configuration+ signQuery GetBucketLocation {..} = s3SignQuery S3Query {+ s3QMethod = Get+ , s3QBucket = Just $ T.encodeUtf8 gblBucket+ , s3QObject = Nothing+ , s3QSubresources = [("location" :: B8.ByteString, Nothing :: Maybe B8.ByteString)]+ , s3QQuery = HTTP.toQuery ([] :: [(B8.ByteString, T.Text)]) + , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = []+ , s3QRequestBody = Nothing+ }++instance ResponseConsumer r GetBucketLocationResponse where+ type ResponseMetadata GetBucketLocationResponse = S3Metadata++ responseConsumer _ _ = s3XmlResponseConsumer parse+ where parse cursor = do+ locationConstraint <- force "Missing Location" $ cursor $.// elContent "LocationConstraint"+ return GetBucketLocationResponse { gblrLocationConstraint = normaliseLocation locationConstraint }++instance Transaction GetBucketLocation GetBucketLocationResponse++instance AsMemoryResponse GetBucketLocationResponse where+ type MemoryResponse GetBucketLocationResponse = GetBucketLocationResponse+ loadToMemory = return
+ Aws/S3/Commands/GetBucketObjectVersions.hs view
@@ -0,0 +1,125 @@+module Aws.S3.Commands.GetBucketObjectVersions+where++import Aws.Core+import Aws.S3.Core+import Control.Applicative+import Data.ByteString.Char8 ({- IsString -})+import Data.Maybe+import Text.XML.Cursor (($/), (&|), (&//))+import qualified Data.ByteString.Char8 as B8+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Traversable+import Prelude+import qualified Network.HTTP.Types as HTTP+import qualified Text.XML.Cursor as Cu+import qualified Text.XML as XML++data GetBucketObjectVersions+ = GetBucketObjectVersions {+ gbovBucket :: Bucket+ , gbovDelimiter :: Maybe T.Text+ , gbovKeyMarker :: Maybe T.Text+ , gbovMaxKeys :: Maybe Int+ , gbovPrefix :: Maybe T.Text+ , gbovVersionIdMarker :: Maybe T.Text+ }+ deriving (Show)++getBucketObjectVersions :: Bucket -> GetBucketObjectVersions+getBucketObjectVersions bucket+ = GetBucketObjectVersions {+ gbovBucket = bucket+ , gbovDelimiter = Nothing+ , gbovKeyMarker = Nothing+ , gbovMaxKeys = Nothing+ , gbovPrefix = Nothing+ , gbovVersionIdMarker = Nothing+ }++data GetBucketObjectVersionsResponse+ = GetBucketObjectVersionsResponse {+ gbovrName :: Bucket+ , gbovrDelimiter :: Maybe T.Text+ , gbovrKeyMarker :: Maybe T.Text+ , gbovrMaxKeys :: Maybe Int+ , gbovrPrefix :: Maybe T.Text+ , gbovrVersionIdMarker :: Maybe T.Text+ , gbovrContents :: [ObjectVersionInfo]+ , gbovrCommonPrefixes :: [T.Text]+ , gbovrIsTruncated :: Bool+ , gbovrNextKeyMarker :: Maybe T.Text+ , gbovrNextVersionIdMarker :: Maybe T.Text+ }+ deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery GetBucketObjectVersions where+ type ServiceConfiguration GetBucketObjectVersions = S3Configuration+ signQuery GetBucketObjectVersions {..} = s3SignQuery S3Query {+ s3QMethod = Get+ , s3QBucket = Just $ T.encodeUtf8 gbovBucket+ , s3QObject = Nothing+ , s3QSubresources = [ ("versions", Nothing) ]+ , s3QQuery = HTTP.toQuery [+ ("delimiter" :: B8.ByteString ,) <$> gbovDelimiter+ , ("key-marker",) <$> gbovKeyMarker+ , ("max-keys",) . T.pack . show <$> gbovMaxKeys+ , ("prefix",) <$> gbovPrefix+ , ("version-id-marker",) <$> gbovVersionIdMarker+ ]+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = []+ , s3QRequestBody = Nothing+ }++instance ResponseConsumer r GetBucketObjectVersionsResponse where+ type ResponseMetadata GetBucketObjectVersionsResponse = S3Metadata++ responseConsumer _ _ = s3XmlResponseConsumer parse+ where parse cursor+ = do name <- force "Missing Name" $ cursor $/ elContent "Name"+ let delimiter = listToMaybe $ cursor $/ elContent "Delimiter"+ let keyMarker = listToMaybe $ cursor $/ elContent "KeyMarker"+ let versionMarker = listToMaybe $ cursor $/ elContent "VersionIdMarker"+ maxKeys <- Data.Traversable.sequence . listToMaybe $ cursor $/ elContent "MaxKeys" &| textReadInt+ let truncated = maybe True (/= "false") $ listToMaybe $ cursor $/ elContent "IsTruncated"+ let nextKeyMarker = listToMaybe $ cursor $/ elContent "NextKeyMarker"+ let nextVersionMarker = listToMaybe $ cursor $/ elContent "NextVersionIdMarker"+ let prefix = listToMaybe $ cursor $/ elContent "Prefix"+ contents <- sequence $ cursor $/ Cu.checkName objectNodeName &| parseObjectVersionInfo+ let commonPrefixes = cursor $/ Cu.laxElement "CommonPrefixes" &// Cu.content+ return GetBucketObjectVersionsResponse{+ gbovrName = name+ , gbovrDelimiter = delimiter+ , gbovrKeyMarker = keyMarker+ , gbovrMaxKeys = maxKeys+ , gbovrPrefix = prefix+ , gbovrVersionIdMarker = versionMarker+ , gbovrContents = contents+ , gbovrCommonPrefixes = commonPrefixes+ , gbovrIsTruncated = truncated+ , gbovrNextKeyMarker = nextKeyMarker+ , gbovrNextVersionIdMarker = nextVersionMarker+ }+ objectNodeName n = let fn = T.toCaseFold $ XML.nameLocalName n+ in fn == T.toCaseFold "Version" || fn == T.toCaseFold "DeleteMarker"++instance Transaction GetBucketObjectVersions GetBucketObjectVersionsResponse++instance IteratedTransaction GetBucketObjectVersions GetBucketObjectVersionsResponse where+ nextIteratedRequest request response+ = case (gbovrIsTruncated response, gbovrNextKeyMarker response, gbovrNextVersionIdMarker response, gbovrContents response) of+ (True, Just keyMarker, Just versionMarker, _ ) -> Just $ request { gbovKeyMarker = Just keyMarker, gbovVersionIdMarker = Just versionMarker }+ (True, Nothing, Nothing, contents@(_:_)) -> Just $ request { gbovKeyMarker = Just $ oviKey $ last contents, gbovVersionIdMarker = Just $ oviVersionId $ last contents }+ (_, _, _, _ ) -> Nothing++instance ListResponse GetBucketObjectVersionsResponse ObjectVersionInfo where+ listResponse = gbovrContents++instance AsMemoryResponse GetBucketObjectVersionsResponse where+ type MemoryResponse GetBucketObjectVersionsResponse = GetBucketObjectVersionsResponse+ loadToMemory = return
+ Aws/S3/Commands/GetBucketVersioning.hs view
@@ -0,0 +1,65 @@+module Aws.S3.Commands.GetBucketVersioning +( + module Aws.S3.Commands.GetBucketVersioning+, VersioningState(..)+) where++import Aws.Core+import Aws.S3.Commands.PutBucketVersioning (VersioningState(..))+import Aws.S3.Core+import Control.Monad.Trans.Resource (throwM)+import Network.HTTP.Types (toQuery)+import qualified Data.Text.Encoding as T+import Text.XML.Cursor (($.//))+import qualified Data.ByteString.Lazy.Char8 as B8++-- | Gets the versioning state of an existing bucket.+data GetBucketVersioning+ = GetBucketVersioning+ { gbvBucket :: Bucket+ }+ deriving (Show)++getBucketVersioning :: Bucket -> GetBucketVersioning+getBucketVersioning = GetBucketVersioning++data GetBucketVersioningResponse+ = GetBucketVersioningResponse+ { gbvVersioning :: Maybe VersioningState }+ -- ^ Nothing when the bucket is not versioned+ deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery GetBucketVersioning where+ type ServiceConfiguration GetBucketVersioning = S3Configuration++ signQuery GetBucketVersioning{..} = s3SignQuery $ S3Query+ { s3QMethod = Get+ , s3QBucket = Just $ T.encodeUtf8 gbvBucket+ , s3QSubresources = toQuery [("versioning" :: B8.ByteString, Nothing :: Maybe B8.ByteString)]+ , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QObject = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = []+ , s3QRequestBody = Nothing+ }++instance ResponseConsumer r GetBucketVersioningResponse where+ type ResponseMetadata GetBucketVersioningResponse = S3Metadata++ responseConsumer _ _ = s3XmlResponseConsumer parse+ where parse cursor = do+ v <- case cursor $.// elContent "Status" of+ [] -> return Nothing+ ("Enabled":[]) -> return (Just VersioningEnabled)+ ("Suspended":[]) -> return (Just VersioningSuspended)+ _ -> throwM $ XmlException "Invalid Status"+ return GetBucketVersioningResponse { gbvVersioning = v }++instance Transaction GetBucketVersioning GetBucketVersioningResponse++instance AsMemoryResponse GetBucketVersioningResponse where+ type MemoryResponse GetBucketVersioningResponse = GetBucketVersioningResponse+ loadToMemory = return
Aws/S3/Commands/GetObject.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Aws.S3.Commands.GetObject where @@ -9,8 +11,12 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L import qualified Data.Conduit as C+import Data.Conduit ((.|))+import qualified Data.Conduit.List as CL+import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T+import Prelude import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP @@ -25,16 +31,21 @@ , goResponseCacheControl :: Maybe T.Text , goResponseContentDisposition :: Maybe T.Text , goResponseContentEncoding :: Maybe T.Text+ , goResponseContentRange :: Maybe (Int,Int)+ , goIfMatch :: Maybe T.Text+ -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is the same as the one specified; otherwise, catch a 'StatusCodeException' with a status of 412 precondition failed.+ , goIfNoneMatch :: Maybe T.Text+ -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is different from the one specified; otherwise, catch a 'StatusCodeException' with a status of 304 not modified. } deriving (Show) getObject :: Bucket -> T.Text -> GetObject-getObject b o = GetObject b o Nothing Nothing Nothing Nothing Nothing Nothing Nothing+getObject b o = GetObject b o Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing data GetObjectResponse = GetObjectResponse { gorMetadata :: ObjectMetadata,- gorResponse :: HTTP.Response (C.ResumableSource (ResourceT IO) B8.ByteString)+ gorResponse :: HTTP.Response (C.ConduitM () B8.ByteString (ResourceT IO) ()) } data GetObjectMemoryResponse@@ -50,31 +61,43 @@ , s3QObject = Just $ T.encodeUtf8 goObjectName , s3QSubresources = HTTP.toQuery [ ("versionId" :: B8.ByteString,) <$> goVersionId+ , ("response-content-type" :: B8.ByteString,) <$> goResponseContentType+ , ("response-content-language",) <$> goResponseContentLanguage+ , ("response-expires",) <$> goResponseExpires+ , ("response-cache-control",) <$> goResponseCacheControl+ , ("response-content-disposition",) <$> goResponseContentDisposition+ , ("response-content-encoding",) <$> goResponseContentEncoding ]- , s3QQuery = HTTP.toQuery [- ("response-content-type" :: B8.ByteString,) <$> goResponseContentType- , ("response-content-language",) <$> goResponseContentLanguage- , ("response-expires",) <$> goResponseExpires- , ("response-cache-control",) <$> goResponseCacheControl- , ("response-content-disposition",) <$> goResponseContentDisposition- , ("response-content-encoding",) <$> goResponseContentEncoding- ]+ , s3QQuery = [] , s3QContentType = Nothing , s3QContentMd5 = Nothing , s3QAmzHeaders = []- , s3QOtherHeaders = []+ , s3QOtherHeaders = catMaybes [+ decodeRange <$> goResponseContentRange+ , ("if-match",) . T.encodeUtf8 <$> goIfMatch+ , ("if-none-match",) . T.encodeUtf8 <$> goIfNoneMatch+ ] , s3QRequestBody = Nothing }+ where decodeRange (pos,len) = ("range",B8.concat $ ["bytes=", B8.pack (show pos), "-", B8.pack (show len)]) instance ResponseConsumer GetObject GetObjectResponse where type ResponseMetadata GetObjectResponse = S3Metadata- responseConsumer GetObject{..} metadata resp- = do rsp <- s3BinaryResponseConsumer return metadata resp- om <- parseObjectMetadata (HTTP.responseHeaders resp)- return $ GetObjectResponse om rsp+ responseConsumer httpReq GetObject{} metadata resp+ | status == HTTP.status200 = do+ rsp <- s3BinaryResponseConsumer return metadata resp+ om <- parseObjectMetadata (HTTP.responseHeaders resp)+ return $ GetObjectResponse om rsp+ | otherwise = throwStatusCodeException httpReq resp+ where+ status = HTTP.responseStatus resp instance Transaction GetObject GetObjectResponse instance AsMemoryResponse GetObjectResponse where type MemoryResponse GetObjectResponse = GetObjectMemoryResponse- loadToMemory (GetObjectResponse om x) = GetObjectMemoryResponse om <$> HTTP.lbsResponse x+ loadToMemory (GetObjectResponse om x) = do+ bss <- C.runConduit $ HTTP.responseBody x .| CL.consume+ return $ GetObjectMemoryResponse om x+ { HTTP.responseBody = L.fromChunks bss+ }
Aws/S3/Commands/GetService.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Aws.S3.Commands.GetService where @@ -5,12 +6,14 @@ import Aws.S3.Core import Data.Maybe import Data.Time.Format+#if !MIN_VERSION_time(1,5,0) import System.Locale+#endif import Text.XML.Cursor (($/), ($//), (&|)) import qualified Data.Text as T import qualified Text.XML.Cursor as Cu -data GetService = GetService+data GetService = GetService deriving (Show) data GetServiceResponse = GetServiceResponse {@@ -22,7 +25,7 @@ instance ResponseConsumer r GetServiceResponse where type ResponseMetadata GetServiceResponse = S3Metadata - responseConsumer _ = s3XmlResponseConsumer parse+ responseConsumer _ _ = s3XmlResponseConsumer parse where parse el = do owner <- forceM "Missing Owner" $ el $/ Cu.laxElement "Owner" &| parseUserInfo@@ -32,7 +35,7 @@ parseBucket el = do name <- force "Missing owner Name" $ el $/ elContent "Name" creationDateString <- force "Missing owner CreationDate" $ el $/ elContent "CreationDate" &| T.unpack- creationDate <- force "Invalid CreationDate" . maybeToList $ parseTime defaultTimeLocale iso8601UtcDate creationDateString+ creationDate <- force "Invalid CreationDate" . maybeToList $ parseTimeM True defaultTimeLocale iso8601UtcDate creationDateString return BucketInfo { bucketName = name, bucketCreationDate = creationDate } -- | ServiceConfiguration: 'S3Configuration'
+ Aws/S3/Commands/HeadObject.hs view
@@ -0,0 +1,75 @@+module Aws.S3.Commands.HeadObject+where++import Aws.Core+import Aws.S3.Core+import Control.Applicative+import Data.ByteString.Char8 ({- IsString -})+import qualified Data.ByteString.Char8 as B8+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Prelude+import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Types as HTTP++data HeadObject+ = HeadObject {+ hoBucket :: Bucket+ , hoObjectName :: Object+ , hoVersionId :: Maybe T.Text+ , hoIfMatch :: Maybe T.Text+ -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is the same as the one specified; otherwise, catch a 'StatusCodeException' with a status of 412 precondition failed.+ , hoIfNoneMatch :: Maybe T.Text+ -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is different from the one specified; otherwise, catch a 'StatusCodeException' with a status of 304 not modified.+ }+ deriving (Show)++headObject :: Bucket -> T.Text -> HeadObject+headObject b o = HeadObject b o Nothing Nothing Nothing++data HeadObjectResponse+ = HeadObjectResponse {+ horMetadata :: Maybe ObjectMetadata+ } deriving (Show)++data HeadObjectMemoryResponse+ = HeadObjectMemoryResponse (Maybe ObjectMetadata)+ deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery HeadObject where+ type ServiceConfiguration HeadObject = S3Configuration+ signQuery HeadObject {..} = s3SignQuery S3Query {+ s3QMethod = Head+ , s3QBucket = Just $ T.encodeUtf8 hoBucket+ , s3QObject = Just $ T.encodeUtf8 hoObjectName+ , s3QSubresources = HTTP.toQuery [+ ("versionId" :: B8.ByteString,) <$> hoVersionId+ ]+ , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = catMaybes [+ ("if-match",) . T.encodeUtf8 <$> hoIfMatch+ , ("if-none-match",) . T.encodeUtf8 <$> hoIfNoneMatch+ ]+ , s3QRequestBody = Nothing+ }++instance ResponseConsumer HeadObject HeadObjectResponse where+ type ResponseMetadata HeadObjectResponse = S3Metadata+ responseConsumer httpReq HeadObject{} _ resp+ | status == HTTP.status200 = HeadObjectResponse . Just <$> parseObjectMetadata headers+ | status == HTTP.status404 = return $ HeadObjectResponse Nothing+ | otherwise = throwStatusCodeException httpReq resp+ where+ status = HTTP.responseStatus resp+ headers = HTTP.responseHeaders resp++instance Transaction HeadObject HeadObjectResponse++instance AsMemoryResponse HeadObjectResponse where+ type MemoryResponse HeadObjectResponse = HeadObjectMemoryResponse+ loadToMemory (HeadObjectResponse om) = return (HeadObjectMemoryResponse om)
+ Aws/S3/Commands/Multipart.hs view
@@ -0,0 +1,462 @@+module Aws.S3.Commands.Multipart+where+import Aws.Aws+import Aws.Core+import Aws.S3.Core+import Control.Applicative+import Control.Arrow (second)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource+import qualified Crypto.Hash as CH+import Data.ByteString.Char8 ({- IsString -})+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Maybe+import Text.XML.Cursor (($/))+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import qualified Data.CaseInsensitive as CI+import qualified Data.Map as M+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+import qualified Text.XML as XML+import Prelude++{-+Aws supports following 6 api for Multipart-Upload.+Currently this code does not support number 3 and 6.++1. Initiate Multipart Upload+2. Upload Part+3. Upload Part - Copy+4. Complete Multipart Upload+5. Abort Multipart Upload+6. List Parts++-}++data InitiateMultipartUpload+ = InitiateMultipartUpload {+ imuBucket :: Bucket+ , imuObjectName :: Object+ , imuCacheControl :: Maybe T.Text+ , imuContentDisposition :: Maybe T.Text+ , imuContentEncoding :: Maybe T.Text+ , imuContentType :: Maybe T.Text+ , imuExpires :: Maybe Int+ , imuMetadata :: [(T.Text,T.Text)]+ , imuStorageClass :: Maybe StorageClass+ , imuWebsiteRedirectLocation :: Maybe T.Text+ , imuAcl :: Maybe CannedAcl+ , imuServerSideEncryption :: Maybe ServerSideEncryption+ , imuAutoMakeBucket :: Bool -- ^ Internet Archive S3 nonstandard extension+ }+ deriving (Show)++postInitiateMultipartUpload :: Bucket -> T.Text -> InitiateMultipartUpload+postInitiateMultipartUpload b o =+ InitiateMultipartUpload+ b o+ Nothing Nothing Nothing Nothing Nothing+ [] Nothing Nothing Nothing Nothing+ False++data InitiateMultipartUploadResponse+ = InitiateMultipartUploadResponse {+ imurBucket :: !Bucket+ , imurKey :: !T.Text+ , imurUploadId :: !T.Text+ }++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery InitiateMultipartUpload where+ type ServiceConfiguration InitiateMultipartUpload = S3Configuration+ signQuery InitiateMultipartUpload {..} = s3SignQuery S3Query {+ s3QMethod = Post+ , s3QBucket = Just $ T.encodeUtf8 imuBucket+ , s3QObject = Just $ T.encodeUtf8 $ imuObjectName+ , s3QSubresources = HTTP.toQuery[ ("uploads" :: B8.ByteString , Nothing :: Maybe B8.ByteString)]+ , s3QQuery = []+ , s3QContentType = T.encodeUtf8 <$> imuContentType+ , s3QContentMd5 = Nothing+ , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [+ ("x-amz-acl",) <$> writeCannedAcl <$> imuAcl+ , ("x-amz-storage-class",) <$> writeStorageClass <$> imuStorageClass+ , ("x-amz-website-redirect-location",) <$> imuWebsiteRedirectLocation+ , ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> imuServerSideEncryption+ , if imuAutoMakeBucket then Just ("x-amz-auto-make-bucket", "1") else Nothing+ ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) imuMetadata+ , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [+ ("Expires",) . T.pack . show <$> imuExpires+ , ("Cache-Control",) <$> imuCacheControl+ , ("Content-Disposition",) <$> imuContentDisposition+ , ("Content-Encoding",) <$> imuContentEncoding+ ]+ , s3QRequestBody = Nothing+ }++instance ResponseConsumer r InitiateMultipartUploadResponse where+ type ResponseMetadata InitiateMultipartUploadResponse = S3Metadata++ responseConsumer _ _ = s3XmlResponseConsumer parse+ where parse cursor+ = do bucket <- force "Missing Bucket Name" $ cursor $/ elContent "Bucket"+ key <- force "Missing Key" $ cursor $/ elContent "Key"+ uploadId <- force "Missing UploadID" $ cursor $/ elContent "UploadId"+ return InitiateMultipartUploadResponse{+ imurBucket = bucket+ , imurKey = key+ , imurUploadId = uploadId+ }++instance Transaction InitiateMultipartUpload InitiateMultipartUploadResponse++instance AsMemoryResponse InitiateMultipartUploadResponse where+ type MemoryResponse InitiateMultipartUploadResponse = InitiateMultipartUploadResponse+ loadToMemory = return+++----------------------------------++++data UploadPart = UploadPart {+ upObjectName :: T.Text+ , upBucket :: Bucket+ , upPartNumber :: Integer+ , upUploadId :: T.Text+ , upContentType :: Maybe B8.ByteString+ , upContentMD5 :: Maybe (CH.Digest CH.MD5)+ , upServerSideEncryption :: Maybe ServerSideEncryption+ , upRequestBody :: HTTP.RequestBody+ , upExpect100Continue :: Bool -- ^ Note: Requires http-client >= 0.4.10+}++uploadPart :: Bucket -> T.Text -> Integer -> T.Text -> HTTP.RequestBody -> UploadPart+uploadPart bucket obj p i body =+ UploadPart obj bucket p i+ Nothing Nothing Nothing body False++data UploadPartResponse+ = UploadPartResponse {+ uprETag :: !T.Text+ }+ deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery UploadPart where+ type ServiceConfiguration UploadPart = S3Configuration+ signQuery UploadPart {..} = s3SignQuery S3Query {+ s3QMethod = Put+ , s3QBucket = Just $ T.encodeUtf8 upBucket+ , s3QObject = Just $ T.encodeUtf8 upObjectName+ , s3QSubresources = HTTP.toQuery[+ ("partNumber" :: B8.ByteString , Just (T.pack (show upPartNumber)) :: Maybe T.Text)+ , ("uploadId" :: B8.ByteString, Just upUploadId :: Maybe T.Text)+ ]+ , s3QQuery = []+ , s3QContentType = upContentType+ , s3QContentMd5 = upContentMD5+ , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [+ ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> upServerSideEncryption+ ]+ , s3QOtherHeaders = catMaybes [+ if upExpect100Continue+ then Just ("Expect", "100-continue")+ else Nothing+ ]+ , s3QRequestBody = Just upRequestBody+ }++instance ResponseConsumer UploadPart UploadPartResponse where+ type ResponseMetadata UploadPartResponse = S3Metadata+ responseConsumer _ _ = s3ResponseConsumer $ \resp -> do+ let etag = fromMaybe "" $ T.decodeUtf8 `fmap` lookup "ETag" (HTTP.responseHeaders resp)+ return $ UploadPartResponse etag++instance Transaction UploadPart UploadPartResponse++instance AsMemoryResponse UploadPartResponse where+ type MemoryResponse UploadPartResponse = UploadPartResponse+ loadToMemory = return++----------------------------++++data CompleteMultipartUpload+ = CompleteMultipartUpload {+ cmuBucket :: Bucket+ , cmuObjectName :: Object+ , cmuUploadId :: T.Text+ , cmuPartNumberAndEtags :: [(Integer,T.Text)]+ , cmuExpiration :: Maybe T.Text+ , cmuServerSideEncryption :: Maybe T.Text+ , cmuServerSideEncryptionCustomerAlgorithm :: Maybe T.Text+ }+ deriving (Show)++postCompleteMultipartUpload :: Bucket -> T.Text -> T.Text -> [(Integer,T.Text)]-> CompleteMultipartUpload+postCompleteMultipartUpload b o i p = CompleteMultipartUpload b o i p Nothing Nothing Nothing++data CompleteMultipartUploadResponse+ = CompleteMultipartUploadResponse {+ cmurLocation :: !T.Text+ , cmurBucket :: !Bucket+ , cmurKey :: !T.Text+ , cmurETag :: !T.Text+ , cmurVersionId :: !(Maybe T.Text)+ } deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery CompleteMultipartUpload where+ type ServiceConfiguration CompleteMultipartUpload = S3Configuration+ signQuery CompleteMultipartUpload {..} = s3SignQuery S3Query {+ s3QMethod = Post+ , s3QBucket = Just $ T.encodeUtf8 cmuBucket+ , s3QObject = Just $ T.encodeUtf8 cmuObjectName+ , s3QSubresources = HTTP.toQuery[+ ("uploadId" :: B8.ByteString, Just cmuUploadId :: Maybe T.Text)+ ]+ , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QAmzHeaders = catMaybes [ ("x-amz-expiration",) <$> (T.encodeUtf8 <$> cmuExpiration)+ , ("x-amz-server-side-encryption",) <$> (T.encodeUtf8 <$> cmuServerSideEncryption)+ , ("x-amz-server-side-encryption-customer-algorithm",)+ <$> (T.encodeUtf8 <$> cmuServerSideEncryptionCustomerAlgorithm)+ ]+ , s3QOtherHeaders = []+ , s3QRequestBody = Just $ HTTP.RequestBodyLBS reqBody+ }+ where reqBody = XML.renderLBS XML.def XML.Document {+ XML.documentPrologue = XML.Prologue [] Nothing []+ , XML.documentRoot = root+ , XML.documentEpilogue = []+ }+ root = XML.Element {+ XML.elementName = "CompleteMultipartUpload"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = (partNode <$> cmuPartNumberAndEtags)+ }+ partNode (partNumber, etag) = XML.NodeElement XML.Element {+ XML.elementName = "Part"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = [keyNode (T.pack (show partNumber)),etagNode etag]+ }+ etagNode = toNode "ETag"+ keyNode = toNode "PartNumber"+ toNode name content = XML.NodeElement XML.Element {+ XML.elementName = name+ , XML.elementAttributes = M.empty+ , XML.elementNodes = [XML.NodeContent content]+ }++instance ResponseConsumer r CompleteMultipartUploadResponse where+ type ResponseMetadata CompleteMultipartUploadResponse = S3Metadata++ responseConsumer _ _ metadata resp = s3XmlResponseConsumer parse metadata resp+ where vid = T.decodeUtf8 `fmap` lookup "x-amz-version-id" (HTTP.responseHeaders resp)+ parse cursor+ = do location <- force "Missing Location" $ cursor $/ elContent "Location"+ bucket <- force "Missing Bucket Name" $ cursor $/ elContent "Bucket"+ key <- force "Missing Key" $ cursor $/ elContent "Key"+ etag <- force "Missing ETag" $ cursor $/ elContent "ETag"+ return CompleteMultipartUploadResponse{+ cmurLocation = location+ , cmurBucket = bucket+ , cmurKey = key+ , cmurETag = etag+ , cmurVersionId = vid+ }++instance Transaction CompleteMultipartUpload CompleteMultipartUploadResponse++instance AsMemoryResponse CompleteMultipartUploadResponse where+ type MemoryResponse CompleteMultipartUploadResponse = CompleteMultipartUploadResponse+ loadToMemory = return++----------------------------++++data AbortMultipartUpload+ = AbortMultipartUpload {+ amuBucket :: Bucket+ , amuObjectName :: Object+ , amuUploadId :: T.Text+ }+ deriving (Show)++postAbortMultipartUpload :: Bucket -> T.Text -> T.Text -> AbortMultipartUpload+postAbortMultipartUpload b o i = AbortMultipartUpload b o i++data AbortMultipartUploadResponse+ = AbortMultipartUploadResponse {+ } deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery AbortMultipartUpload where+ type ServiceConfiguration AbortMultipartUpload = S3Configuration+ signQuery AbortMultipartUpload {..} = s3SignQuery S3Query {+ s3QMethod = Delete+ , s3QBucket = Just $ T.encodeUtf8 amuBucket+ , s3QObject = Just $ T.encodeUtf8 amuObjectName+ , s3QSubresources = HTTP.toQuery[+ ("uploadId" :: B8.ByteString, Just amuUploadId :: Maybe T.Text)+ ]+ , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = []+ , s3QRequestBody = Nothing+ }++instance ResponseConsumer r AbortMultipartUploadResponse where+ type ResponseMetadata AbortMultipartUploadResponse = S3Metadata++ responseConsumer _ _ = s3XmlResponseConsumer parse+ where parse _cursor+ = return AbortMultipartUploadResponse {}++instance Transaction AbortMultipartUpload AbortMultipartUploadResponse+++instance AsMemoryResponse AbortMultipartUploadResponse where+ type MemoryResponse AbortMultipartUploadResponse = AbortMultipartUploadResponse+ loadToMemory = return+++----------------------------++getUploadId ::+ Configuration+ -> S3Configuration NormalQuery+ -> HTTP.Manager+ -> T.Text+ -> T.Text+ -> IO T.Text+getUploadId cfg s3cfg mgr bucket object = do+ InitiateMultipartUploadResponse {+ imurBucket = _bucket+ , imurKey = _object'+ , imurUploadId = uploadId+ } <- memoryAws cfg s3cfg mgr $ postInitiateMultipartUpload bucket object+ return uploadId+++sendEtag ::+ Configuration+ -> S3Configuration NormalQuery+ -> HTTP.Manager+ -> T.Text+ -> T.Text+ -> T.Text+ -> [T.Text]+ -> IO CompleteMultipartUploadResponse+sendEtag cfg s3cfg mgr bucket object uploadId etags = do+ memoryAws cfg s3cfg mgr $+ postCompleteMultipartUpload bucket object uploadId (zip [1..] etags)++putConduit ::+ MonadResource m =>+ Configuration+ -> S3Configuration NormalQuery+ -> HTTP.Manager+ -> T.Text+ -> T.Text+ -> T.Text+ -> ConduitT BL.ByteString T.Text m ()+putConduit cfg s3cfg mgr bucket object uploadId = loop 1+ where+ loop n = do+ v' <- await+ case v' of+ Just v -> do+ UploadPartResponse etag <- memoryAws cfg s3cfg mgr $+ uploadPart bucket object n uploadId (HTTP.RequestBodyLBS v)+ yield etag+ loop (n+1)+ Nothing -> return ()++chunkedConduit :: (MonadResource m) => Integer -> ConduitT B8.ByteString BL.ByteString m ()+chunkedConduit size = loop 0 []+ where+ loop :: Monad m => Integer -> [B8.ByteString] -> ConduitT B8.ByteString BL.ByteString m ()+ loop cnt str = await >>= maybe (yieldChunk str) go+ where+ go :: Monad m => B8.ByteString -> ConduitT B8.ByteString BL.ByteString m ()+ go line+ | size <= len = yieldChunk newStr >> loop 0 []+ | otherwise = loop len newStr+ where+ len = fromIntegral (B8.length line) + cnt+ newStr = line:str++ yieldChunk :: Monad m => [B8.ByteString] -> ConduitT i BL.ByteString m ()+ yieldChunk = yield . BL.fromChunks . reverse++multipartUpload ::+ Configuration+ -> S3Configuration NormalQuery+ -> HTTP.Manager+ -> T.Text+ -> T.Text+ -> ConduitT () B8.ByteString (ResourceT IO) ()+ -> Integer+ -> ResourceT IO ()+multipartUpload cfg s3cfg mgr bucket object src chunkSize = do+ uploadId <- liftIO $ getUploadId cfg s3cfg mgr bucket object+ etags <- (src+ .| chunkedConduit chunkSize+ .| putConduit cfg s3cfg mgr bucket object uploadId+ ) `connect` CL.consume+ void $ liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags++multipartUploadSink :: MonadResource m+ => Configuration+ -> S3Configuration NormalQuery+ -> HTTP.Manager+ -> T.Text -- ^ Bucket name+ -> T.Text -- ^ Object name+ -> Integer -- ^ chunkSize (minimum: 5MB)+ -> ConduitT B8.ByteString Void m ()+multipartUploadSink cfg s3cfg = multipartUploadSinkWithInitiator cfg s3cfg postInitiateMultipartUpload++multipartUploadWithInitiator ::+ Configuration+ -> S3Configuration NormalQuery+ -> (Bucket -> T.Text -> InitiateMultipartUpload)+ -> HTTP.Manager+ -> T.Text+ -> T.Text+ -> ConduitT () B8.ByteString (ResourceT IO) ()+ -> Integer+ -> ResourceT IO ()+multipartUploadWithInitiator cfg s3cfg initiator mgr bucket object src chunkSize = do+ uploadId <- liftIO $ imurUploadId <$> memoryAws cfg s3cfg mgr (initiator bucket object)+ etags <- (src+ .| chunkedConduit chunkSize+ .| putConduit cfg s3cfg mgr bucket object uploadId+ ) `connect` CL.consume+ void $ liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags++multipartUploadSinkWithInitiator :: MonadResource m+ => Configuration+ -> S3Configuration NormalQuery+ -> (Bucket -> T.Text -> InitiateMultipartUpload) -- ^ Initiator+ -> HTTP.Manager+ -> T.Text -- ^ Bucket name+ -> T.Text -- ^ Object name+ -> Integer -- ^ chunkSize (minimum: 5MB)+ -> ConduitT B8.ByteString Void m ()+multipartUploadSinkWithInitiator cfg s3cfg initiator mgr bucket object chunkSize = do+ uploadId <- liftIO $ imurUploadId <$> memoryAws cfg s3cfg mgr (initiator bucket object)+ etags <- chunkedConduit chunkSize+ .| putConduit cfg s3cfg mgr bucket object uploadId+ .| CL.consume+ void $ liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags
Aws/S3/Commands/PutBucket.hs view
@@ -3,6 +3,7 @@ import Aws.Core import Aws.S3.Core import Control.Monad+import Data.Maybe import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -14,9 +15,13 @@ pbBucket :: Bucket , pbCannedAcl :: Maybe CannedAcl , pbLocationConstraint :: LocationConstraint+ , pbXStorageClass :: Maybe StorageClass -- ^ Google Cloud Storage S3 nonstandard extension } deriving (Show) +putBucket :: Bucket -> PutBucket+putBucket bucket = PutBucket bucket Nothing locationUsClassic Nothing+ data PutBucketResponse = PutBucketResponse deriving (Show)@@ -38,7 +43,7 @@ Just acl -> [("x-amz-acl", T.encodeUtf8 $ writeCannedAcl acl)] , s3QOtherHeaders = [] , s3QRequestBody- = guard (not . T.null $ pbLocationConstraint) >>+ = guard (not (null elts)) >> (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def) XML.Document { XML.documentPrologue = XML.Prologue [] Nothing []@@ -49,19 +54,27 @@ where root = XML.Element { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}CreateBucketConfiguration" , XML.elementAttributes = M.empty- , XML.elementNodes = [- XML.NodeElement (XML.Element {- XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}LocationConstraint"- , XML.elementAttributes = M.empty- , XML.elementNodes = [XML.NodeContent pbLocationConstraint]- })- ]+ , XML.elementNodes = elts }+ elts = catMaybes+ [ if T.null pbLocationConstraint then Nothing else Just (locationconstraint pbLocationConstraint)+ , fmap storageclass pbXStorageClass+ ]+ locationconstraint c = XML.NodeElement (XML.Element {+ XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}LocationConstraint"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = [XML.NodeContent c]+ })+ storageclass c = XML.NodeElement (XML.Element {+ XML.elementName = "StorageClass"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = [XML.NodeContent (writeStorageClass c)]+ }) instance ResponseConsumer r PutBucketResponse where type ResponseMetadata PutBucketResponse = S3Metadata - responseConsumer _ = s3ResponseConsumer $ \_ -> return PutBucketResponse+ responseConsumer _ _ = s3ResponseConsumer $ \_ -> return PutBucketResponse instance Transaction PutBucket PutBucketResponse
+ Aws/S3/Commands/PutBucketVersioning.hs view
@@ -0,0 +1,71 @@+module Aws.S3.Commands.PutBucketVersioning where++import Aws.Core+import Aws.S3.Core+import Network.HTTP.Types (toQuery)+import qualified Data.Map as M+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Conduit as HTTP+import qualified Text.XML as XML+import qualified Data.ByteString.Lazy.Char8 as B8++data VersioningState = VersioningSuspended | VersioningEnabled+ deriving (Show)++-- | Sets the versioning state of an existing bucket.+data PutBucketVersioning+ = PutBucketVersioning+ { pbvBucket :: Bucket+ , pbvVersioningConfiguration :: VersioningState+ }+ deriving (Show)++putBucketVersioning :: Bucket -> VersioningState -> PutBucketVersioning+putBucketVersioning = PutBucketVersioning++data PutBucketVersioningResponse+ = PutBucketVersioningResponse+ deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery PutBucketVersioning where+ type ServiceConfiguration PutBucketVersioning = S3Configuration++ signQuery PutBucketVersioning{..} = s3SignQuery $ S3Query+ { s3QMethod = Put+ , s3QBucket = Just $ T.encodeUtf8 pbvBucket+ , s3QSubresources = toQuery [("versioning" :: B8.ByteString, Nothing :: Maybe B8.ByteString)]+ , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QObject = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = []+ , s3QRequestBody = (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def)+ XML.Document+ { XML.documentPrologue = XML.Prologue [] Nothing []+ , XML.documentRoot = XML.Element+ { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}VersioningConfiguration"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = [ XML.NodeElement (XML.Element+ { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}Status"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = case pbvVersioningConfiguration of+ VersioningSuspended -> [XML.NodeContent "Suspended"]+ VersioningEnabled -> [XML.NodeContent "Enabled"]+ })]+ }+ , XML.documentEpilogue = []+ }+ }++instance ResponseConsumer r PutBucketVersioningResponse where+ type ResponseMetadata PutBucketVersioningResponse = S3Metadata++ responseConsumer _ _ = s3ResponseConsumer $ \_ -> return PutBucketVersioningResponse++instance Transaction PutBucketVersioning PutBucketVersioningResponse++instance AsMemoryResponse PutBucketVersioningResponse where+ type MemoryResponse PutBucketVersioningResponse = PutBucketVersioningResponse+ loadToMemory = return
Aws/S3/Commands/PutObject.hs view
@@ -1,19 +1,21 @@+{-# LANGUAGE CPP #-} module Aws.S3.Commands.PutObject where import Aws.Core import Aws.S3.Core import Control.Applicative-import Control.Arrow (second)-import Crypto.Hash.CryptoAPI (MD5)-import Data.ByteString.Char8 ({- IsString -})+import Control.Arrow (second)+import qualified Crypto.Hash as CH+import Data.ByteString.Char8 ({- IsString -}) import Data.Maybe-import qualified Data.ByteString.Char8 as B-import qualified Data.CaseInsensitive as CI-import qualified Data.Conduit as C-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Network.HTTP.Conduit as HTTP+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 Prelude+import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Types.URI as URI data PutObject = PutObject { poObjectName :: T.Text,@@ -22,21 +24,27 @@ poCacheControl :: Maybe T.Text, poContentDisposition :: Maybe T.Text, poContentEncoding :: Maybe T.Text,- poContentMD5 :: Maybe MD5,+ poContentMD5 :: Maybe (CH.Digest CH.MD5), poExpires :: Maybe Int, poAcl :: Maybe CannedAcl, poStorageClass :: Maybe StorageClass,- poRequestBody :: HTTP.RequestBody (C.ResourceT IO),- poMetadata :: [(T.Text,T.Text)]+ poWebsiteRedirectLocation :: Maybe T.Text,+ poServerSideEncryption :: Maybe ServerSideEncryption,+ poRequestBody :: HTTP.RequestBody,+ poMetadata :: [(T.Text,T.Text)],+ poAutoMakeBucket :: Bool, -- ^ Internet Archive S3 nonstandard extension+ poExpect100Continue :: Bool, -- ^ Note: Requires http-client >= 0.4.10+ poTagging :: [(T.Text,T.Text)] -- ^ tag-set as key/value pairs } -putObject :: Bucket -> T.Text -> HTTP.RequestBody (C.ResourceT IO) -> PutObject-putObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body []+putObject :: Bucket -> T.Text -> HTTP.RequestBody -> PutObject+putObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body [] False False [] -data PutObjectResponse - = PutObjectResponse {- porVersionId :: Maybe T.Text- }+data PutObjectResponse+ = PutObjectResponse+ { porVersionId :: Maybe T.Text+ , porETag :: T.Text+ } deriving (Show) -- | ServiceConfiguration: 'S3Configuration'@@ -49,15 +57,24 @@ , s3QQuery = [] , s3QContentType = poContentType , s3QContentMd5 = poContentMD5- , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [+ , s3QAmzHeaders = map (second T.encodeUtf8) (catMaybes [ ("x-amz-acl",) <$> writeCannedAcl <$> poAcl , ("x-amz-storage-class",) <$> writeStorageClass <$> poStorageClass+ , ("x-amz-website-redirect-location",) <$> poWebsiteRedirectLocation+ , ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> poServerSideEncryption+ , if poAutoMakeBucket then Just ("x-amz-auto-make-bucket", "1") else Nothing ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) poMetadata+ ) ++ if null poTagging+ then []+ else [("x-amz-tagging", URI.renderQuery False $ URI.queryTextToQuery $ map (second Just) poTagging)] , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [ ("Expires",) . T.pack . show <$> poExpires , ("Cache-Control",) <$> poCacheControl , ("Content-Disposition",) <$> poContentDisposition , ("Content-Encoding",) <$> poContentEncoding+ , if poExpect100Continue+ then Just ("Expect", "100-continue")+ else Nothing ] , s3QRequestBody = Just poRequestBody , s3QObject = Just $ T.encodeUtf8 poObjectName@@ -65,9 +82,10 @@ instance ResponseConsumer PutObject PutObjectResponse where type ResponseMetadata PutObjectResponse = S3Metadata- responseConsumer _ = s3ResponseConsumer $ \resp -> do+ responseConsumer _ _ = s3ResponseConsumer $ \resp -> do let vid = T.decodeUtf8 `fmap` lookup "x-amz-version-id" (HTTP.responseHeaders resp)- return $ PutObjectResponse vid+ let etag = fromMaybe "" $ T.decodeUtf8 `fmap` lookup "ETag" (HTTP.responseHeaders resp)+ return $ PutObjectResponse vid etag instance Transaction PutObject PutObjectResponse
+ Aws/S3/Commands/RestoreObject.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}+module Aws.S3.Commands.RestoreObject+where++import Aws.Core+import Aws.S3.Core+import qualified Data.ByteString.Lazy.Char8 as B8+import qualified Data.Map as M+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Types as HTTP+import qualified Network.HTTP.Conduit as HTTP+import qualified Text.XML as XML+#if !MIN_VERSION_time(1,5,0)+import System.Locale+#endif+import Prelude++data RestoreObject+ = RestoreObject { roObjectName :: Object+ , roBucket :: Bucket+ , roVersionId :: Maybe T.Text+ , roTier :: RestoreObjectTier+ , roObjectLifetimeDays :: RestoreObjectLifetimeDays+ }+ deriving (Show)++data RestoreObjectTier+ = RestoreObjectTierExpedited+ | RestoreObjectTierStandard+ | RestoreObjectTierBulk+ deriving (Show)++data RestoreObjectLifetimeDays = RestoreObjectLifetimeDays Integer+ deriving (Show)++restoreObject :: Bucket -> T.Text -> RestoreObjectTier -> RestoreObjectLifetimeDays -> RestoreObject+restoreObject bucket obj tier lifetime = RestoreObject obj bucket Nothing tier lifetime++data RestoreObjectResponse+ = RestoreObjectAccepted+ | RestoreObjectAlreadyRestored+ | RestoreObjectAlreadyInProgress+ deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery RestoreObject where+ type ServiceConfiguration RestoreObject = S3Configuration+ signQuery RestoreObject {..} = s3SignQuery S3Query+ { s3QMethod = Post+ , s3QBucket = Just $ T.encodeUtf8 roBucket+ , s3QObject = Just $ T.encodeUtf8 roObjectName+ , s3QSubresources = HTTP.toQuery+ [ Just ( "restore" :: B8.ByteString, Nothing :: Maybe T.Text)+ , case roVersionId of+ Nothing -> Nothing+ Just v -> Just ("versionId" :: B8.ByteString, Just v)+ ]+ , s3QQuery = []+ , s3QContentType = Nothing+ , s3QContentMd5 = Nothing+ , s3QAmzHeaders = []+ , s3QOtherHeaders = []+ , s3QRequestBody = (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def)+ XML.Document+ { XML.documentPrologue = XML.Prologue [] Nothing []+ , XML.documentRoot = XML.Element+ { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}RestoreRequest"+ , XML.elementAttributes = M.empty+ , XML.elementNodes =+ [ XML.NodeElement (XML.Element+ { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}Days"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = case roObjectLifetimeDays of+ RestoreObjectLifetimeDays n -> [XML.NodeContent (T.pack (show n))]+ })+ , XML.NodeElement (XML.Element+ { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}GlacierJobParameters"+ , XML.elementAttributes = M.empty+ , XML.elementNodes =+ [ XML.NodeElement (XML.Element+ { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}Tier"+ , XML.elementAttributes = M.empty+ , XML.elementNodes = case roTier of+ RestoreObjectTierExpedited -> [XML.NodeContent "Expedited"]+ RestoreObjectTierStandard -> [XML.NodeContent "Standard"]+ RestoreObjectTierBulk -> [XML.NodeContent "Bulk"] + })+ ]+ })+ ]+ }+ , XML.documentEpilogue = []+ }+ }++instance ResponseConsumer RestoreObject RestoreObjectResponse where+ type ResponseMetadata RestoreObjectResponse = S3Metadata+ responseConsumer httpReq _ _ resp+ | status == HTTP.status202 = return RestoreObjectAccepted+ | status == HTTP.status200 = return RestoreObjectAlreadyRestored+ | status == HTTP.status409 = return RestoreObjectAlreadyInProgress+ | otherwise = throwStatusCodeException httpReq resp+ where+ status = HTTP.responseStatus resp++instance Transaction RestoreObject RestoreObjectResponse++instance AsMemoryResponse RestoreObjectResponse where+ type MemoryResponse RestoreObjectResponse = RestoreObjectResponse+ loadToMemory = return
Aws/S3/Core.hs view
@@ -1,37 +1,48 @@+{-# LANGUAGE CPP, BangPatterns #-} module Aws.S3.Core where import Aws.Core-import Control.Arrow ((***))+import Control.Arrow (first, (***)) import Control.Monad import Control.Monad.IO.Class-import Crypto.Hash.CryptoAPI (MD5)-import Data.Attempt (Attempt(..))-import Data.Conduit (($$+-))+import Control.Monad.Trans.Resource (MonadThrow, throwM)+import Data.Char (isAscii, isAlphaNum, toUpper, ord)+import Data.Conduit ((.|)) import Data.Function+import Data.Functor import Data.IORef import Data.List import Data.Maybe import Data.Monoid+import qualified Data.Semigroup as Sem+import Control.Applicative ((<|>)) import Data.Time import Data.Typeable+import Numeric (showHex)+#if !MIN_VERSION_time(1,5,0) import System.Locale+#endif import Text.XML.Cursor (($/), (&|))+import qualified Data.Attoparsec.ByteString as Atto import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import qualified Control.Exception as C-import qualified Control.Failure as F+import qualified Crypto.Hash as CH+import qualified Data.ByteArray as ByteArray import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Base64 as Base64 import qualified Data.CaseInsensitive as CI import qualified Data.Conduit as C-import qualified Data.Serialize as Serialize+import qualified Data.Map as Map 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 import qualified Text.XML as XML import qualified Text.XML.Cursor as Cu+import Prelude data S3Authorization = S3AuthorizationHeader@@ -44,15 +55,30 @@ | VHostStyle deriving (Show) +data S3SignPayloadMode+ = AlwaysUnsigned -- ^ Always use the "UNSIGNED-PAYLOAD" option.+ | SignWithEffort -- ^ Sign the payload when 'HTTP.RequestBody' is a on-memory one ('HTTP.RequestBodyLBS' or 'HTTP.RequestBodyBS'). Otherwise use the "UNSINGED-PAYLOAD" option.+ | AlwaysSigned -- ^ Always sign the payload. Note: 'error' called when 'HTTP.RequestBody' is a streaming one.+ deriving (Eq, Show, Read, Typeable)++data S3SignVersion+ = S3SignV2+ | S3SignV4 { _s3SignPayloadMode :: S3SignPayloadMode }+ deriving (Eq, Show, Read, Typeable)+ data S3Configuration qt- = S3Configuration {- s3Protocol :: Protocol- , s3Endpoint :: B.ByteString- , s3RequestStyle :: RequestStyle- , s3Port :: Int- , s3UseUri :: Bool- , s3DefaultExpiry :: NominalDiffTime- }+ = S3Configuration+ { s3Protocol :: Protocol+ , s3Endpoint :: B.ByteString+ , s3Region :: Maybe B.ByteString+ , s3RequestStyle :: RequestStyle+ , s3Port :: Int+ , s3ServerSideEncryption :: Maybe ServerSideEncryption+ , s3UseUri :: Bool+ , s3DefaultExpiry :: NominalDiffTime+ , s3SignVersion :: S3SignVersion+ , s3UserAgent :: Maybe T.Text+ } deriving (Show) instance DefaultServiceConfiguration (S3Configuration NormalQuery) where@@ -70,26 +96,55 @@ s3EndpointUsWest :: B.ByteString s3EndpointUsWest = "s3-us-west-1.amazonaws.com" +s3EndpointUsWest2 :: B.ByteString+s3EndpointUsWest2 = "s3-us-west-2.amazonaws.com"+ s3EndpointEu :: B.ByteString s3EndpointEu = "s3-eu-west-1.amazonaws.com" +s3EndpointEuWest2 :: B.ByteString+s3EndpointEuWest2 = "s3-eu-west-2.amazonaws.com"+ s3EndpointApSouthEast :: B.ByteString s3EndpointApSouthEast = "s3-ap-southeast-1.amazonaws.com" +s3EndpointApSouthEast2 :: B.ByteString+s3EndpointApSouthEast2 = "s3-ap-southeast-2.amazonaws.com"+ s3EndpointApNorthEast :: B.ByteString s3EndpointApNorthEast = "s3-ap-northeast-1.amazonaws.com" s3 :: Protocol -> B.ByteString -> Bool -> S3Configuration qt s3 protocol endpoint uri- = S3Configuration {- s3Protocol = protocol+ = S3Configuration+ { s3Protocol = protocol , s3Endpoint = endpoint+ , s3Region = Nothing , s3RequestStyle = BucketStyle , s3Port = defaultPort protocol+ , s3ServerSideEncryption = Nothing , s3UseUri = uri , s3DefaultExpiry = 15*60+ , s3SignVersion = S3SignV2+ , s3UserAgent = Nothing } +s3v4 :: Protocol -> B.ByteString -> Bool -> S3SignPayloadMode -> S3Configuration qt+s3v4 protocol endpoint uri payload+ = S3Configuration+ { s3Protocol = protocol+ , s3Endpoint = endpoint+ , s3Region = Nothing+ , s3RequestStyle = BucketStyle+ , s3Port = defaultPort protocol+ , s3ServerSideEncryption = Nothing+ , s3UseUri = uri+ , s3DefaultExpiry = 15*60+ , s3SignVersion = S3SignV4 payload+ , s3UserAgent = Nothing+ }++ type ErrorCode = T.Text data S3Error@@ -101,6 +156,9 @@ , s3ErrorHostId :: Maybe T.Text -- Error/HostId , s3ErrorAccessKeyId :: Maybe T.Text -- Error/AWSAccessKeyId , s3ErrorStringToSign :: Maybe B.ByteString -- Error/StringToSignBytes (hexadecimal encoding)+ , s3ErrorBucket :: Maybe T.Text -- Error/Bucket+ , s3ErrorEndpointRaw :: Maybe T.Text -- Error/Endpoint (i.e. correct bucket location)+ , s3ErrorEndpoint :: Maybe B.ByteString -- Error/Endpoint without the bucket prefix } deriving (Show, Typeable) @@ -113,9 +171,12 @@ } deriving (Show, Typeable) +instance Sem.Semigroup S3Metadata where+ S3Metadata a1 r1 <> S3Metadata a2 r2 = S3Metadata (a1 `mplus` a2) (r1 `mplus` r2)+ instance Monoid S3Metadata where mempty = S3Metadata Nothing Nothing- S3Metadata a1 r1 `mappend` S3Metadata a2 r2 = S3Metadata (a1 `mplus` a2) (r1 `mplus` r2)+ mappend = (Sem.<>) instance Loggable S3Metadata where toLogText (S3Metadata id2 rid) = "S3: request ID=" `mappend`@@ -131,10 +192,10 @@ , s3QSubresources :: HTTP.Query , s3QQuery :: HTTP.Query , s3QContentType :: Maybe B.ByteString- , s3QContentMd5 :: Maybe MD5+ , s3QContentMd5 :: Maybe (CH.Digest CH.MD5) , s3QAmzHeaders :: HTTP.RequestHeaders , s3QOtherHeaders :: HTTP.RequestHeaders- , s3QRequestBody :: Maybe (HTTP.RequestBody (C.ResourceT IO))+ , s3QRequestBody :: Maybe HTTP.RequestBody } instance Show S3Query where@@ -146,8 +207,18 @@ " ; request body: " ++ (case s3QRequestBody of Nothing -> "no"; _ -> "yes") ++ "]" +hAmzDate, hAmzContentSha256, hAmzAlgorithm, hAmzCredential, hAmzExpires, hAmzSignedHeaders, hAmzSignature, hAmzSecurityToken :: HTTP.HeaderName+hAmzDate = "X-Amz-Date"+hAmzContentSha256 = "X-Amz-Content-Sha256"+hAmzAlgorithm = "X-Amz-Algorithm"+hAmzCredential = "X-Amz-Credential"+hAmzExpires = "X-Amz-Expires"+hAmzSignedHeaders = "X-Amz-SignedHeaders"+hAmzSignature = "X-Amz-Signature"+hAmzSecurityToken = "X-Amz-Security-Token"+ s3SignQuery :: S3Query -> S3Configuration qt -> SignatureData -> SignedQuery-s3SignQuery S3Query{..} S3Configuration{..} SignatureData{..}+s3SignQuery S3Query{..} S3Configuration{ s3SignVersion = S3SignV2, .. } SignatureData{..} = SignedQuery { sqMethod = s3QMethod , sqProtocol = s3Protocol@@ -160,33 +231,55 @@ , sqContentType = s3QContentType , sqContentMd5 = s3QContentMd5 , sqAmzHeaders = amzHeaders- , sqOtherHeaders = s3QOtherHeaders+ , sqOtherHeaders = useragent ++ s3QOtherHeaders , sqBody = s3QRequestBody , sqStringToSign = stringToSign } where- amzHeaders = merge $ sortBy (compare `on` fst) s3QAmzHeaders+ -- This also implements anonymous queries.+ isanon = isAnonymousCredentials signatureCredentials + amzHeaders = merge $ sortBy (compare `on` fst) $ s3QAmzHeaders ++ + if isanon + then []+ else fmap (\(k, v) -> (CI.mk k, v)) iamTok 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 + urlEncodedS3QObject = s3UriEncode False <$> s3QObject (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])+ PathStyle -> ([Just s3Endpoint], [Just "/", fmap (`B8.snoc` '/') s3QBucket, urlEncodedS3QObject])+ BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just "/", urlEncodedS3QObject])+ VHostStyle -> ([Just $ fromMaybe s3Endpoint s3QBucket], [Just "/", urlEncodedS3QObject]) 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+ maybe mempty Blaze.copyByteString urlEncodedS3QObject `mappend`+ encodeQuerySign sortedSubresources+ -- query parameters overriding response headers must not be URI encoded when calculating signature+ -- http://docs.aws.amazon.com/AmazonS3/latest/dev/RESTAuthentication.html#ConstructingTheCanonicalizedResourceElement+ -- Note this is limited to amazon auth version 2 in the new auth version 4 this weird exception is not present+ encodeQuerySign qs =+ let ceq = Blaze8.fromChar '='+ cqt = Blaze8.fromChar '?'+ camp = Blaze8.fromChar '&'+ overrideParams = map B8.pack ["response-content-type", "response-content-language", "response-expires", "response-cache-control", "response-content-disposition", "response-content-encoding"]+ encItem (k, mv) =+ let enc = if k `elem` overrideParams then Blaze.copyByteString else HTTP.urlEncodeBuilder True+ in enc k `mappend` maybe mempty (mappend ceq . enc) mv+ in case intersperse camp (map encItem qs) of+ [] -> mempty+ qs' -> mconcat (cqt :qs')+ ti = case (s3UseUri, signatureTimeInfo) of (False, ti') -> ti' (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time (True, AbsoluteExpires time) -> AbsoluteExpires time sig = signature signatureCredentials HmacSHA1 stringToSign+ iamTok = maybe [] (\x -> [("x-amz-security-token", x)]) (iamToken signatureCredentials) stringToSign = Blaze.toByteString . mconcat . intersperse (Blaze8.fromChar '\n') . concat $ [[Blaze.copyByteString $ httpMethod s3QMethod]- , [maybe mempty (Blaze.copyByteString . Base64.encode . Serialize.encode) s3QContentMd5]+ , [maybe mempty (Blaze.copyByteString . Base64.encode . ByteArray.convert) s3QContentMd5] , [maybe mempty Blaze.copyByteString s3QContentType] , [Blaze.copyByteString $ case ti of AbsoluteTimestamp time -> fmtRfc822Time time@@ -196,18 +289,169 @@ ] where amzHeader (k, v) = Blaze.copyByteString (CI.foldedCase k) `mappend` Blaze8.fromChar ':' `mappend` Blaze.copyByteString v (authorization, authQuery) = case ti of- AbsoluteTimestamp _ -> (Just $ B.concat ["AWS ", accessKeyID signatureCredentials, ":", sig], [])+ AbsoluteTimestamp _+ | isanon -> (Nothing, [])+ | otherwise -> (Just $ return $ B.concat ["AWS ", accessKeyID signatureCredentials, ":", sig], []) AbsoluteExpires time -> (Nothing, HTTP.toQuery $ makeAuthQuery time) makeAuthQuery time- = [("Expires" :: B8.ByteString, fmtTimeEpochSeconds time)- , ("AWSAccessKeyId", accessKeyID signatureCredentials)- , ("SignatureMethod", "HmacSHA256")- , ("Signature", sig)]+ | isanon = []+ | otherwise = + [ ("Expires" :: B8.ByteString, fmtTimeEpochSeconds time)+ , ("AWSAccessKeyId", accessKeyID signatureCredentials)+ , ("SignatureMethod", "HmacSHA256")+ , ("Signature", sig)] ++ iamTok+ + useragent = maybeToList $ (HTTP.hUserAgent,) . T.encodeUtf8 <$> s3UserAgent+s3SignQuery sq@S3Query{..} sc@S3Configuration{ s3SignVersion = S3SignV4 signpayload, .. } sd@SignatureData{..}+ | isAnonymousCredentials signatureCredentials =+ s3SignQuery sq (sc { s3SignVersion = S3SignV2 }) sd+ | otherwise = SignedQuery+ { sqMethod = s3QMethod+ , sqProtocol = s3Protocol+ , sqHost = B.intercalate "." $ catMaybes host+ , sqPort = s3Port+ , sqPath = mconcat $ catMaybes path+ , sqQuery = queryString ++ signatureQuery :: HTTP.Query+ , sqDate = Just signatureTime+ , sqAuthorization = authorization+ , sqContentType = s3QContentType+ , sqContentMd5 = s3QContentMd5+ , sqAmzHeaders = Map.toList amzHeaders+ , sqOtherHeaders = useragent ++ s3QOtherHeaders+ , sqBody = s3QRequestBody+ , sqStringToSign = stringToSign+ }+ where+ -- V4 signing+ -- * <http://docs.aws.amazon.com/general/latest/gr/sigv4_signing.html>+ -- * <http://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-auth-using-authorization-header.html>+ -- * <http://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-query-string-auth.html> + iamTok = maybe [] (\x -> [(hAmzSecurityToken, x)]) $ iamToken signatureCredentials++ amzHeaders = Map.fromList $ (hAmzDate, sigTime):(hAmzContentSha256, payloadHash):iamTok ++ s3QAmzHeaders+ where+ -- needs to match the one produces in the @authorizationV4@+ sigTime = fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime+ payloadHash = case (signpayload, s3QRequestBody) of+ (AlwaysUnsigned, _) -> "UNSIGNED-PAYLOAD"+ (_, Nothing) -> emptyBodyHash+ (_, Just (HTTP.RequestBodyLBS lbs)) -> Base16.encode $ ByteArray.convert (CH.hashlazy lbs :: CH.Digest CH.SHA256)+ (_, Just (HTTP.RequestBodyBS bs)) -> Base16.encode $ ByteArray.convert (CH.hash bs :: CH.Digest CH.SHA256)+ (SignWithEffort, _) -> "UNSIGNED-PAYLOAD"+ (AlwaysSigned, _) -> error "aws: RequestBody must be a on-memory one when AlwaysSigned mode."+ emptyBodyHash = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"++ (host, path) = case s3RequestStyle of+ PathStyle -> ([Just s3Endpoint], [Just "/", fmap (`B8.snoc` '/') s3QBucket, urlEncodedS3QObject])+ BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just "/", urlEncodedS3QObject])+ VHostStyle -> ([Just $ fromMaybe s3Endpoint s3QBucket], [Just "/", urlEncodedS3QObject])+ where+ urlEncodedS3QObject = s3UriEncode False <$> s3QObject++ -- must provide host in the canonical headers.+ canonicalHeaders = Map.union amzHeaders . Map.fromList $ catMaybes+ [ Just ("host", B.intercalate "." $ catMaybes host)+ , ("content-type",) <$> s3QContentType+ ]+ signedHeaders = B8.intercalate ";" (map CI.foldedCase $ Map.keys canonicalHeaders)+ stringToSign = B.intercalate "\n" $+ [ httpMethod s3QMethod -- method+ , mconcat . catMaybes $ path -- path+ , s3RenderQuery False $ sort queryString -- query string+ ] +++ Map.foldMapWithKey (\a b -> [CI.foldedCase a Sem.<> ":" Sem.<> b]) canonicalHeaders +++ [ "" -- end headers+ , signedHeaders+ , amzHeaders Map.! hAmzContentSha256+ ]++ (authorization, signatureQuery, queryString) = case ti of+ AbsoluteTimestamp _ -> (Just auth, [], allQueries)+ AbsoluteExpires time ->+ ( Nothing+ , [(CI.original hAmzSignature, Just sig)]+ , (allQueries ++) . HTTP.toQuery . map (first CI.original) $+ [ (hAmzAlgorithm, "AWS4-HMAC-SHA256")+ , (hAmzCredential, cred)+ , (hAmzDate, amzHeaders Map.! hAmzDate)+ , (hAmzExpires, B8.pack . (show :: Integer -> String) . floor $ diffUTCTime time signatureTime)+ , (hAmzSignedHeaders, signedHeaders)+ ] ++ iamTok+ )+ where+ allQueries = s3QSubresources ++ s3QQuery+ region = fromMaybe (s3ExtractRegion s3Endpoint) s3Region+ auth = authorizationV4 sd HmacSHA256 region "s3" signedHeaders stringToSign+ sig = signatureV4 sd HmacSHA256 region "s3" stringToSign+ cred = credentialV4 sd region "s3"+ ti = case (s3UseUri, signatureTimeInfo) of+ (False, t) -> t+ (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time+ (True, AbsoluteExpires time) -> AbsoluteExpires time+ + useragent = maybeToList $ (HTTP.hUserAgent,) . T.encodeUtf8 <$> s3UserAgent++-- | Custom UriEncode function+-- see <http://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html>+s3UriEncode+ :: Bool -- ^ Whether encode slash characters+ -> B.ByteString+ -> B.ByteString+s3UriEncode encodeSlash = B8.concatMap $ \c ->+ if (isAscii c && isAlphaNum c) || (c `elem` nonEncodeMarks)+ then B8.singleton c+ else B8.pack $ '%' : map toUpper (showHex (ord c) "")+ where+ nonEncodeMarks :: String+ nonEncodeMarks = if encodeSlash+ then "_-~."+ else "_-~./"++s3RenderQuery+ :: Bool -- ^ Whether prepend a question mark+ -> HTTP.Query+ -> B.ByteString+s3RenderQuery qm = mconcat . qmf . intersperse (B8.singleton '&') . map renderItem+ where+ qmf = if qm then ("?":) else id++ renderItem :: HTTP.QueryItem -> B8.ByteString+ renderItem (k, Just v) = s3UriEncode True k Sem.<> "=" Sem.<> s3UriEncode True v+ renderItem (k, Nothing) = s3UriEncode True k Sem.<> "="++-- | Extract a S3 region from the S3 endpoint. AWS encodes the region names+-- in the hostnames of endpoints in a way that makes this possible,+-- see: <http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region>+-- For other S3 implementations, may instead need to specify s3Region.+s3ExtractRegion :: B.ByteString -> B.ByteString+s3ExtractRegion "s3.amazonaws.com" = "us-east-1"+s3ExtractRegion "s3-external-1.amazonaws.com" = "us-east-1"+s3ExtractRegion domain = either (const domain) B.pack $ Atto.parseOnly parser domain+ where+ -- s3.dualstack.<WA-DIR-N>.amazonaws.com+ -- s3-<WA-DIR-N>.amazonaws.com+ -- s3.<WA-DIR-N>.amazonaws.com+ parser = do+ _ <- Atto.string "s3"+ _ <- Atto.string ".dualstack." <|> Atto.string "-" <|> Atto.string "."+ r <- Atto.manyTill Atto.anyWord8 $ Atto.string ".amazonaws.com"+ Atto.endOfInput+ return r+ s3ResponseConsumer :: HTTPResponseConsumer a+ -> IORef S3Metadata+ -> HTTPResponseConsumer a+s3ResponseConsumer inner metadataRef = s3BinaryResponseConsumer inner' metadataRef+ where inner' resp =+ do+ !res <- inner resp+ return res++s3BinaryResponseConsumer :: HTTPResponseConsumer a -> IORef S3Metadata -> HTTPResponseConsumer a-s3ResponseConsumer inner metadata resp = do+s3BinaryResponseConsumer inner metadata resp = do let headerString = fmap T.decodeUtf8 . flip lookup (HTTP.responseHeaders resp) let amzId2 = headerString "x-amz-id-2" let requestId = headerString "x-amz-request-id"@@ -215,7 +459,7 @@ let m = S3Metadata { s3MAmzId2 = amzId2, s3MRequestId = requestId } liftIO $ tellMetadataRef metadata m - if HTTP.responseStatus resp >= HTTP.status400+ if HTTP.responseStatus resp >= HTTP.status300 then s3ErrorResponseConsumer resp else inner resp @@ -225,25 +469,23 @@ s3XmlResponseConsumer parse metadataRef = s3ResponseConsumer (xmlCursorConsumer parse metadataRef) metadataRef -s3BinaryResponseConsumer :: HTTPResponseConsumer a- -> IORef S3Metadata- -> HTTPResponseConsumer a-s3BinaryResponseConsumer inner metadataRef = s3ResponseConsumer inner metadataRef- s3ErrorResponseConsumer :: HTTPResponseConsumer a s3ErrorResponseConsumer resp- = do doc <- HTTP.responseBody resp $$+- XML.sinkDoc XML.def+ = do doc <- C.runConduit $ HTTP.responseBody resp .| XML.sinkDoc XML.def let cursor = Cu.fromDocument doc liftIO $ case parseError cursor of- Success err -> C.monadThrow err- Failure otherErr -> C.monadThrow otherErr+ Right err -> throwM err+ Left otherErr -> throwM otherErr where- parseError :: Cu.Cursor -> Attempt S3Error+ parseError :: Cu.Cursor -> Either C.SomeException S3Error parseError root = do code <- force "Missing error Code" $ root $/ elContent "Code" message <- force "Missing error Message" $ root $/ elContent "Message" let resource = listToMaybe $ root $/ elContent "Resource" hostId = listToMaybe $ root $/ elContent "HostId" accessKeyId = listToMaybe $ root $/ elContent "AWSAccessKeyId"+ bucket = listToMaybe $ root $/ elContent "Bucket"+ endpointRaw = listToMaybe $ root $/ elContent "Endpoint"+ endpoint = T.encodeUtf8 <$> (T.stripPrefix (fromMaybe "" bucket Sem.<> ".") =<< endpointRaw) stringToSign = do unprocessed <- listToMaybe $ root $/ elCont "StringToSignBytes" bytes <- mapM readHex2 $ words unprocessed return $ B.pack bytes@@ -255,6 +497,9 @@ , s3ErrorHostId = hostId , s3ErrorAccessKeyId = accessKeyId , s3ErrorStringToSign = stringToSign+ , s3ErrorBucket = bucket+ , s3ErrorEndpointRaw = endpointRaw+ , s3ErrorEndpoint = endpoint } type CanonicalUserId = T.Text@@ -262,13 +507,15 @@ data UserInfo = UserInfo { userId :: CanonicalUserId- , userDisplayName :: T.Text+ , userDisplayName :: Maybe T.Text } deriving (Show) -parseUserInfo :: F.Failure XmlException m => Cu.Cursor -> m UserInfo+parseUserInfo :: MonadThrow m => Cu.Cursor -> m UserInfo parseUserInfo el = do id_ <- force "Missing user ID" $ el $/ elContent "ID"- displayName <- force "Missing user DisplayName" $ el $/ elContent "DisplayName"+ displayName <- return $ case (el $/ elContent "DisplayName") of+ (x:_) -> Just x+ [] -> Nothing return UserInfo { userId = id_, userDisplayName = displayName } data CannedAcl@@ -292,18 +539,37 @@ data StorageClass = Standard+ | StandardInfrequentAccess | ReducedRedundancy+ | Glacier+ | OtherStorageClass T.Text 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+parseStorageClass :: T.Text -> StorageClass+parseStorageClass "STANDARD" = Standard+parseStorageClass "STANDARD_IA" = StandardInfrequentAccess+parseStorageClass "REDUCED_REDUNDANCY" = ReducedRedundancy+parseStorageClass "GLACIER" = Glacier+parseStorageClass s = OtherStorageClass s writeStorageClass :: StorageClass -> T.Text-writeStorageClass Standard = "STANDARD"-writeStorageClass ReducedRedundancy = "REDUCED_REDUNDANCY"+writeStorageClass Standard = "STANDARD"+writeStorageClass StandardInfrequentAccess = "STANDARD_IA"+writeStorageClass ReducedRedundancy = "REDUCED_REDUNDANCY"+writeStorageClass Glacier = "GLACIER"+writeStorageClass (OtherStorageClass s) = s +data ServerSideEncryption+ = AES256+ deriving (Show)++parseServerSideEncryption :: MonadThrow m => T.Text -> m ServerSideEncryption+parseServerSideEncryption "AES256" = return AES256+parseServerSideEncryption s = throwM . XmlException $ "Invalid Server Side Encryption: " ++ T.unpack s++writeServerSideEncryption :: ServerSideEncryption -> T.Text+writeServerSideEncryption AES256 = "AES256"+ type Bucket = T.Text data BucketInfo@@ -323,6 +589,70 @@ } deriving (Show) +data ObjectVersionInfo+ = ObjectVersion {+ oviKey :: T.Text+ , oviVersionId :: T.Text+ , oviIsLatest :: Bool+ , oviLastModified :: UTCTime+ , oviETag :: T.Text+ , oviSize :: Integer+ , oviStorageClass :: StorageClass+ , oviOwner :: Maybe UserInfo+ }+ | DeleteMarker {+ oviKey :: T.Text+ , oviVersionId :: T.Text+ , oviIsLatest :: Bool+ , oviLastModified :: UTCTime+ , oviOwner :: Maybe UserInfo+ }+ deriving (Show)++parseObjectVersionInfo :: MonadThrow m => Cu.Cursor -> m ObjectVersionInfo+parseObjectVersionInfo el+ = do key <- force "Missing object Key" $ el $/ elContent "Key"+ versionId <- force "Missing object VersionId" $ el $/ elContent "VersionId"+ isLatest <- forceM "Missing object IsLatest" $ el $/ elContent "IsLatest" &| textReadBool+ let time s = case (parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ T.unpack s) <|>+ (parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" $ T.unpack s) of+ Nothing -> throwM $ XmlException "Invalid time"+ Just v -> return v+ lastModified <- forceM "Missing object LastModified" $ el $/ elContent "LastModified" &| time+ owner <- case el $/ Cu.laxElement "Owner" &| parseUserInfo of+ (x:_) -> fmap' Just x+ [] -> return Nothing+ case Cu.node el of+ XML.NodeElement e | elName e == "Version" ->+ do eTag <- force "Missing object ETag" $ el $/ elContent "ETag"+ size <- forceM "Missing object Size" $ el $/ elContent "Size" &| textReadInt+ storageClass <- case el $/ elContent "StorageClass" &| parseStorageClass of+ (x:_) -> return x+ [] -> return Standard+ return ObjectVersion{+ oviKey = key+ , oviVersionId = versionId+ , oviIsLatest = isLatest+ , oviLastModified = lastModified+ , oviETag = eTag+ , oviSize = size+ , oviStorageClass = storageClass+ , oviOwner = owner+ }+ XML.NodeElement e | elName e == "DeleteMarker" ->+ return DeleteMarker{+ oviKey = key+ , oviVersionId = versionId+ , oviIsLatest = isLatest+ , oviLastModified = lastModified+ , oviOwner = owner+ }+ _ -> throwM $ XmlException "Invalid object version tag"+ where+ elName = XML.nameLocalName . XML.elementName+ fmap' :: Monad m => (a -> b) -> m a -> m b+ fmap' f ma = ma >>= return . f+ data ObjectInfo = ObjectInfo { objectKey :: T.Text@@ -330,21 +660,26 @@ , objectETag :: T.Text , objectSize :: Integer , objectStorageClass :: StorageClass- , objectOwner :: UserInfo+ , objectOwner :: Maybe UserInfo } deriving (Show) -parseObjectInfo :: F.Failure XmlException m => Cu.Cursor -> m ObjectInfo+parseObjectInfo :: MonadThrow m => Cu.Cursor -> m ObjectInfo 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"+ let time s = case (parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ T.unpack s) <|>+ (parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" $ T.unpack s) of+ Nothing -> throwM $ XmlException "Invalid time" Just v -> return v 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 <- forceM "Missing object StorageClass" $ el $/ elContent "StorageClass" &| parseStorageClass- owner <- forceM "Missing object Owner" $ el $/ Cu.laxElement "Owner" &| parseUserInfo+ storageClass <- case el $/ elContent "StorageClass" &| parseStorageClass of+ (x:_) -> return x+ [] -> return Standard+ owner <- case el $/ Cu.laxElement "Owner" &| parseUserInfo of+ (x:_) -> fmap' Just x+ [] -> return Nothing return ObjectInfo{ objectKey = key , objectLastModified = lastModified@@ -353,6 +688,9 @@ , objectStorageClass = storageClass , objectOwner = owner }+ where+ fmap' :: Monad m => (a -> b) -> m a -> m b+ fmap' f ma = ma >>= return . f data ObjectMetadata = ObjectMetadata {@@ -364,11 +702,11 @@ -- , omExpiration :: Maybe (UTCTime, T.Text) , omUserMetadata :: [(T.Text, T.Text)] , omMissingUserMetadata :: Maybe T.Text- , omServerSideEncryption :: Maybe T.Text+ , omServerSideEncryption :: Maybe ServerSideEncryption } deriving (Show) -parseObjectMetadata :: F.Failure HeaderException m => HTTP.ResponseHeaders -> m ObjectMetadata+parseObjectMetadata :: MonadThrow m => HTTP.ResponseHeaders -> m ObjectMetadata parseObjectMetadata h = ObjectMetadata `liftM` deleteMarker `ap` etag@@ -377,35 +715,47 @@ -- `ap` expiration `ap` return userMetadata `ap` return missingUserMetadata- `ap` return serverSideEncryption+ `ap` serverSideEncryption where deleteMarker = case B8.unpack `fmap` lookup "x-amz-delete-marker" h of Nothing -> return False Just "true" -> return True Just "false" -> return False- Just x -> F.failure $ HeaderException ("Invalid x-amz-delete-marker " ++ x)+ Just x -> throwM $ HeaderException ("Invalid x-amz-delete-marker " ++ x) etag = case T.decodeUtf8 `fmap` lookup "ETag" h of Just x -> return x- Nothing -> F.failure $ HeaderException "ETag missing"+ Nothing -> throwM $ HeaderException "ETag missing" lastModified = case B8.unpack `fmap` lookup "Last-Modified" h of Just ts -> case parseHttpDate ts of Just t -> return t- Nothing -> F.failure $ HeaderException ("Invalid Last-Modified: " ++ ts)- Nothing -> F.failure $ HeaderException "Last-Modified missing"+ Nothing -> throwM $ HeaderException ("Invalid Last-Modified: " ++ ts)+ Nothing -> throwM $ HeaderException "Last-Modified missing" versionId = T.decodeUtf8 `fmap` lookup "x-amz-version-id" h -- expiration = return undefined userMetadata = flip mapMaybe ht $ \(k, v) -> do i <- T.stripPrefix "x-amz-meta-" k return (i, v) missingUserMetadata = T.decodeUtf8 `fmap` lookup "x-amz-missing-meta" h- serverSideEncryption = T.decodeUtf8 `fmap` lookup "x-amz-server-side-encryption" h+ serverSideEncryption = case T.decodeUtf8 `fmap` lookup "x-amz-server-side-encryption" h of+ Just x -> return $ parseServerSideEncryption x+ Nothing -> return Nothing ht = map ((T.decodeUtf8 . CI.foldedCase) *** T.decodeUtf8) h type LocationConstraint = T.Text -locationUsClassic, locationUsWest, locationEu, locationApSouthEast, locationApNorthEast :: LocationConstraint+locationUsClassic, locationUsWest, locationUsWest2, locationEu, locationEuWest2, locationEuFrankfurt, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationSA :: LocationConstraint locationUsClassic = "" locationUsWest = "us-west-1"+locationUsWest2 = "us-west-2" locationEu = "EU"+locationEuWest2 = "eu-west-2"+locationEuFrankfurt = "eu-central-1" locationApSouthEast = "ap-southeast-1"+locationApSouthEast2 = "ap-southeast-2" locationApNorthEast = "ap-northeast-1"+locationSA = "sa-east-1"++normaliseLocation :: LocationConstraint -> LocationConstraint+normaliseLocation location+ | location == "eu-west-1" = locationEu+ | otherwise = location
Aws/Ses/Commands.hs view
@@ -1,5 +1,27 @@ module Aws.Ses.Commands ( module Aws.Ses.Commands.SendRawEmail+ , module Aws.Ses.Commands.ListIdentities+ , module Aws.Ses.Commands.VerifyEmailIdentity+ , module Aws.Ses.Commands.VerifyDomainIdentity+ , module Aws.Ses.Commands.VerifyDomainDkim+ , module Aws.Ses.Commands.DeleteIdentity+ , module Aws.Ses.Commands.GetIdentityDkimAttributes+ , module Aws.Ses.Commands.GetIdentityNotificationAttributes+ , module Aws.Ses.Commands.GetIdentityVerificationAttributes+ , module Aws.Ses.Commands.SetIdentityNotificationTopic+ , module Aws.Ses.Commands.SetIdentityDkimEnabled+ , module Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled ) where import Aws.Ses.Commands.SendRawEmail+import Aws.Ses.Commands.ListIdentities+import Aws.Ses.Commands.VerifyEmailIdentity+import Aws.Ses.Commands.VerifyDomainIdentity+import Aws.Ses.Commands.VerifyDomainDkim+import Aws.Ses.Commands.DeleteIdentity+import Aws.Ses.Commands.GetIdentityDkimAttributes+import Aws.Ses.Commands.GetIdentityNotificationAttributes+import Aws.Ses.Commands.GetIdentityVerificationAttributes+import Aws.Ses.Commands.SetIdentityNotificationTopic+import Aws.Ses.Commands.SetIdentityDkimEnabled+import Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled
+ Aws/Ses/Commands/DeleteIdentity.hs view
@@ -0,0 +1,40 @@+module Aws.Ses.Commands.DeleteIdentity+ ( DeleteIdentity(..)+ , DeleteIdentityResponse(..)+ ) where++import Data.Text (Text)+import Data.Text.Encoding as T (encodeUtf8)+import Data.Typeable+import Aws.Core+import Aws.Ses.Core++-- | Delete an email address or domain+data DeleteIdentity = DeleteIdentity Text+ deriving (Eq, Ord, Show, Typeable)++-- | ServiceConfiguration: 'SesConfiguration'+instance SignQuery DeleteIdentity where+ type ServiceConfiguration DeleteIdentity = SesConfiguration+ signQuery (DeleteIdentity identity) =+ sesSignQuery [ ("Action", "DeleteIdentity")+ , ("Identity", T.encodeUtf8 identity)+ ]++-- | The response sent back by Amazon SES after a+-- 'DeleteIdentity' command.+data DeleteIdentityResponse = DeleteIdentityResponse+ deriving (Eq, Ord, Show, Typeable)+++instance ResponseConsumer DeleteIdentity DeleteIdentityResponse where+ type ResponseMetadata DeleteIdentityResponse = SesMetadata+ responseConsumer _ _+ = sesResponseConsumer $ \_ -> return DeleteIdentityResponse+++instance Transaction DeleteIdentity DeleteIdentityResponse where++instance AsMemoryResponse DeleteIdentityResponse where+ type MemoryResponse DeleteIdentityResponse = DeleteIdentityResponse+ loadToMemory = return
+ Aws/Ses/Commands/GetIdentityDkimAttributes.hs view
@@ -0,0 +1,64 @@+module Aws.Ses.Commands.GetIdentityDkimAttributes+ ( GetIdentityDkimAttributes(..)+ , GetIdentityDkimAttributesResponse(..)+ , IdentityDkimAttributes(..)+ ) where++import qualified Data.ByteString.Char8 as BS+import Data.Text (Text)+import Data.Text as T (toCaseFold)+import Data.Text.Encoding as T (encodeUtf8)+import Data.Typeable+import Text.XML.Cursor (laxElement, ($/), ($//), (&/), (&|))+import Control.Applicative+import Prelude++import Aws.Core+import Aws.Ses.Core++-- | Get notification settings for the given identities.+data GetIdentityDkimAttributes = GetIdentityDkimAttributes [Text]+ deriving (Eq, Ord, Show, Typeable)++-- | ServiceConfiguration: 'SesConfiguration'+instance SignQuery GetIdentityDkimAttributes where+ type ServiceConfiguration GetIdentityDkimAttributes = SesConfiguration+ signQuery (GetIdentityDkimAttributes identities) =+ sesSignQuery $ ("Action", "GetIdentityDkimAttributes")+ : zip (enumMember <$> [1..]) (T.encodeUtf8 <$> identities)+ where enumMember (n :: Int) = BS.append "Identities.member." (BS.pack $ show n)+++data IdentityDkimAttributes =+ IdentityDkimAttributes+ { idIdentity :: Text+ , idDkimEnabled :: Bool+ , idDkimTokens :: [Text]+ , idDkimVerirficationStatus :: Text }+ deriving (Eq, Ord, Show, Typeable)++-- | The response sent back by Amazon SES after a+-- 'GetIdentityDkimAttributes' command.+data GetIdentityDkimAttributesResponse =+ GetIdentityDkimAttributesResponse [IdentityDkimAttributes]+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer GetIdentityDkimAttributes GetIdentityDkimAttributesResponse where+ type ResponseMetadata GetIdentityDkimAttributesResponse = SesMetadata+ responseConsumer _ _ = sesResponseConsumer $ \cursor -> do+ let buildAttr e = do+ idIdentity <- force "Missing Key" $ e $/ elContent "key"+ enabled <- force "Missing DkimEnabled" $ e $// elContent "DkimEnabled"+ idDkimVerirficationStatus <- force "Missing status" $+ e $// elContent "DkimVerificationStatus"+ let idDkimEnabled = T.toCaseFold enabled == T.toCaseFold "true"+ idDkimTokens = e $// laxElement "DkimTokens" &/ elContent "member"+ return IdentityDkimAttributes{..}+ attributes <- sequence $ cursor $// laxElement "entry" &| buildAttr+ return $ GetIdentityDkimAttributesResponse attributes++instance Transaction GetIdentityDkimAttributes GetIdentityDkimAttributesResponse where++instance AsMemoryResponse GetIdentityDkimAttributesResponse where+ type MemoryResponse GetIdentityDkimAttributesResponse = GetIdentityDkimAttributesResponse+ loadToMemory = return
+ Aws/Ses/Commands/GetIdentityNotificationAttributes.hs view
@@ -0,0 +1,65 @@+module Aws.Ses.Commands.GetIdentityNotificationAttributes+ ( GetIdentityNotificationAttributes(..)+ , GetIdentityNotificationAttributesResponse(..)+ , IdentityNotificationAttributes(..)+ ) where++import Data.Text (Text)+import qualified Data.ByteString.Char8 as BS+import Control.Applicative+import Data.Text.Encoding as T (encodeUtf8)+import Data.Text as T (toCaseFold)+import Data.Typeable+import Text.XML.Cursor (($//), ($/), (&|), laxElement)+import Prelude++import Aws.Core+import Aws.Ses.Core++-- | Get notification settings for the given identities.+data GetIdentityNotificationAttributes = GetIdentityNotificationAttributes [Text]+ deriving (Eq, Ord, Show, Typeable)++-- | ServiceConfiguration: 'SesConfiguration'+instance SignQuery GetIdentityNotificationAttributes where+ type ServiceConfiguration GetIdentityNotificationAttributes = SesConfiguration+ signQuery (GetIdentityNotificationAttributes identities) =+ sesSignQuery $ ("Action", "GetIdentityNotificationAttributes")+ : zip (enumMember <$> [1..]) (T.encodeUtf8 <$> identities)+ where enumMember (n :: Int) = BS.append "Identities.member." (BS.pack $ show n)++data IdentityNotificationAttributes = IdentityNotificationAttributes+ { inIdentity :: Text+ , inBounceTopic :: Maybe Text+ , inComplaintTopic :: Maybe Text+ , inForwardingEnabled :: Bool+ }+ deriving (Eq, Ord, Show, Typeable)++-- | The response sent back by Amazon SES after a+-- 'GetIdentityNotificationAttributes' command.+data GetIdentityNotificationAttributesResponse =+ GetIdentityNotificationAttributesResponse [IdentityNotificationAttributes]+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer GetIdentityNotificationAttributes GetIdentityNotificationAttributesResponse where+ type ResponseMetadata GetIdentityNotificationAttributesResponse = SesMetadata+ responseConsumer _ _ = sesResponseConsumer $ \cursor -> do+ let buildAttr e = do+ inIdentity <- force "Missing Key" $ e $/ elContent "key"+ fwdText <- force "Missing ForwardingEnabled" $ e $// elContent "ForwardingEnabled"+ let inBounceTopic = headOrNothing (e $// elContent "BounceTopic")+ inComplaintTopic = headOrNothing (e $// elContent "ComplaintTopic")+ inForwardingEnabled = T.toCaseFold fwdText == T.toCaseFold "true"+ return IdentityNotificationAttributes{..}+ attributes <- sequence $ cursor $// laxElement "entry" &| buildAttr+ return $ GetIdentityNotificationAttributesResponse attributes+ where+ headOrNothing (x:_) = Just x+ headOrNothing _ = Nothing++instance Transaction GetIdentityNotificationAttributes GetIdentityNotificationAttributesResponse where++instance AsMemoryResponse GetIdentityNotificationAttributesResponse where+ type MemoryResponse GetIdentityNotificationAttributesResponse = GetIdentityNotificationAttributesResponse+ loadToMemory = return
+ Aws/Ses/Commands/GetIdentityVerificationAttributes.hs view
@@ -0,0 +1,65 @@+module Aws.Ses.Commands.GetIdentityVerificationAttributes+ ( GetIdentityVerificationAttributes(..)+ , GetIdentityVerificationAttributesResponse(..)+ , IdentityVerificationAttributes(..)+ ) where++import Data.Text (Text)+import qualified Data.ByteString.Char8 as BS+import Data.Maybe (listToMaybe)+import Control.Applicative+import Data.Text.Encoding as T (encodeUtf8)+import Data.Typeable+import Text.XML.Cursor (($//), ($/), (&|), laxElement)+import Prelude++import Aws.Core+import Aws.Ses.Core++-- | Get verification status for a list of email addresses and/or domains+data GetIdentityVerificationAttributes = GetIdentityVerificationAttributes [Text]+ deriving (Eq, Ord, Show, Typeable)+++-- | ServiceConfiguration: 'SesConfiguration'+instance SignQuery GetIdentityVerificationAttributes where+ type ServiceConfiguration GetIdentityVerificationAttributes = SesConfiguration+ signQuery (GetIdentityVerificationAttributes identities) =+ sesSignQuery $ ("Action", "GetIdentityVerificationAttributes")+ : zip (enumMember <$> [1..]) (T.encodeUtf8 <$> identities)+ where enumMember (n :: Int) = BS.append "Identities.member." (BS.pack $ show n)++data IdentityVerificationAttributes = IdentityVerificationAttributes+ { ivIdentity :: Text+ , ivVerificationStatus :: Text+ , ivVerificationToken :: Maybe Text+ }+ deriving (Eq, Ord, Show, Typeable)+++-- | The response sent back by Amazon SES after a+-- 'GetIdentityVerificationAttributes' command.+data GetIdentityVerificationAttributesResponse =+ GetIdentityVerificationAttributesResponse [IdentityVerificationAttributes]+ deriving (Eq, Ord, Show, Typeable)+++instance ResponseConsumer GetIdentityVerificationAttributes GetIdentityVerificationAttributesResponse where+ type ResponseMetadata GetIdentityVerificationAttributesResponse = SesMetadata+ responseConsumer _ _ =+ sesResponseConsumer $ \cursor -> do+ let buildAttr e = do+ ivIdentity <- force "Missing Key" $ e $/ elContent "key"+ ivVerificationStatus <- force "Missing Verification Status" $ e+ $// elContent "VerificationStatus"+ let ivVerificationToken = listToMaybe $ e $// elContent "VerificationToken"+ return IdentityVerificationAttributes {..}+ attributes <- sequence $ cursor $// laxElement "entry" &| buildAttr+ return $ GetIdentityVerificationAttributesResponse attributes+++instance Transaction GetIdentityVerificationAttributes GetIdentityVerificationAttributesResponse where++instance AsMemoryResponse GetIdentityVerificationAttributesResponse where+ type MemoryResponse GetIdentityVerificationAttributesResponse = GetIdentityVerificationAttributesResponse+ loadToMemory = return
+ Aws/Ses/Commands/ListIdentities.hs view
@@ -0,0 +1,64 @@+module Aws.Ses.Commands.ListIdentities+ ( ListIdentities(..)+ , ListIdentitiesResponse(..)+ , IdentityType(..)+ ) where++import Data.Text (Text)+import qualified Data.ByteString.Char8 as BS+import Data.Maybe (catMaybes)+import Control.Applicative+import Data.Text.Encoding as T (encodeUtf8)+import Data.Typeable+import Text.XML.Cursor (($//), (&/), laxElement)+import Prelude++import Aws.Core+import Aws.Ses.Core++-- | List email addresses and/or domains+data ListIdentities =+ ListIdentities+ { liIdentityType :: Maybe IdentityType+ , liMaxItems :: Maybe Int -- valid range is 1..100+ , liNextToken :: Maybe Text+ }+ deriving (Eq, Ord, Show, Typeable)++data IdentityType = EmailAddress | Domain+ deriving (Eq, Ord, Show, Typeable)++-- | ServiceConfiguration: 'SesConfiguration'+instance SignQuery ListIdentities where+ type ServiceConfiguration ListIdentities = SesConfiguration+ signQuery ListIdentities {..} =+ let it = case liIdentityType of+ Just EmailAddress -> Just "EmailAddress"+ Just Domain -> Just "Domain"+ Nothing -> Nothing+ in sesSignQuery $ ("Action", "ListIdentities")+ : catMaybes+ [ ("IdentityType",) <$> it+ , ("MaxItems",) . BS.pack . show <$> liMaxItems+ , ("NextToken",) . T.encodeUtf8 <$> liNextToken+ ]++-- | The response sent back by Amazon SES after a+-- 'ListIdentities' command.+data ListIdentitiesResponse = ListIdentitiesResponse [Text]+ deriving (Eq, Ord, Show, Typeable)+++instance ResponseConsumer ListIdentities ListIdentitiesResponse where+ type ResponseMetadata ListIdentitiesResponse = SesMetadata+ responseConsumer _ _ =+ sesResponseConsumer $ \cursor -> do+ let ids = cursor $// laxElement "Identities" &/ elContent "member"+ return $ ListIdentitiesResponse ids+++instance Transaction ListIdentities ListIdentitiesResponse where++instance AsMemoryResponse ListIdentitiesResponse where+ type MemoryResponse ListIdentitiesResponse = ListIdentitiesResponse+ loadToMemory = return
Aws/Ses/Commands/SendRawEmail.hs view
@@ -5,7 +5,11 @@ import Data.Text (Text) import Data.Typeable+import Control.Applicative+import qualified Data.ByteString.Char8 as BS import Text.XML.Cursor (($//))+import qualified Data.Text.Encoding as T+import Prelude import Aws.Core import Aws.Ses.Core@@ -13,7 +17,7 @@ -- | Send a raw e-mail message. data SendRawEmail = SendRawEmail- { srmDestinations :: Maybe Destination+ { srmDestinations :: [EmailAddress] , srmRawMessage :: RawMessage , srmSource :: Maybe Sender }@@ -24,10 +28,14 @@ type ServiceConfiguration SendRawEmail = SesConfiguration signQuery SendRawEmail {..} = sesSignQuery $ ("Action", "SendRawEmail") :- concat [ sesAsQuery srmDestinations+ concat [ destinations , sesAsQuery srmRawMessage , sesAsQuery srmSource ]+ where+ destinations = zip (enumMember <$> ([1..] :: [Int]))+ (T.encodeUtf8 <$> srmDestinations)+ enumMember = BS.append "Destinations.member." . BS.pack . show -- | The response sent back by Amazon SES after a -- 'SendRawEmail' command.@@ -38,7 +46,7 @@ instance ResponseConsumer SendRawEmail SendRawEmailResponse where type ResponseMetadata SendRawEmailResponse = SesMetadata- responseConsumer _ =+ responseConsumer _ _ = sesResponseConsumer $ \cursor -> do messageId <- force "MessageId not found" $ cursor $// elContent "MessageId" return (SendRawEmailResponse messageId)
+ Aws/Ses/Commands/SetIdentityDkimEnabled.hs view
@@ -0,0 +1,42 @@+module Aws.Ses.Commands.SetIdentityDkimEnabled+ ( SetIdentityDkimEnabled(..)+ , SetIdentityDkimEnabledResponse(..)+ ) where++import Aws.Core+import Aws.Ses.Core+import Data.Text (Text)+import Data.Text.Encoding as T+import Data.Typeable++-- | Change whether bounces and complaints for the given identity will be+-- DKIM signed.+data SetIdentityDkimEnabled = SetIdentityDkimEnabled+ { sdDkimEnabled :: Bool+ , sdIdentity :: Text+ }+ deriving (Eq, Ord, Show, Typeable)++-- | ServiceConfiguration: 'SesConfiguration'+instance SignQuery SetIdentityDkimEnabled where+ type ServiceConfiguration SetIdentityDkimEnabled = SesConfiguration+ signQuery SetIdentityDkimEnabled{..} =+ sesSignQuery [ ("Action", "SetIdentityDkimEnabled")+ , ("Identity", T.encodeUtf8 sdIdentity)+ , ("DkimEnabled", awsBool sdDkimEnabled)+ ]++-- | The response sent back by SES after the 'SetIdentityDkimEnabled' command.+data SetIdentityDkimEnabledResponse = SetIdentityDkimEnabledResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer SetIdentityDkimEnabled SetIdentityDkimEnabledResponse where+ type ResponseMetadata SetIdentityDkimEnabledResponse = SesMetadata+ responseConsumer _ _+ = sesResponseConsumer $ \_ -> return SetIdentityDkimEnabledResponse++instance Transaction SetIdentityDkimEnabled SetIdentityDkimEnabledResponse++instance AsMemoryResponse SetIdentityDkimEnabledResponse where+ type MemoryResponse SetIdentityDkimEnabledResponse = SetIdentityDkimEnabledResponse+ loadToMemory = return
+ Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs view
@@ -0,0 +1,44 @@+module Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled+ ( SetIdentityFeedbackForwardingEnabled(..)+ , SetIdentityFeedbackForwardingEnabledResponse(..)+ ) where++import Data.Text (Text)+import Data.Text.Encoding as T (encodeUtf8)+import Data.Typeable+import Aws.Core+import Aws.Ses.Core++-- | Change whether bounces and complaints for the given identity will be+-- forwarded as email.+data SetIdentityFeedbackForwardingEnabled =+ SetIdentityFeedbackForwardingEnabled+ { sffForwardingEnabled :: Bool+ , sffIdentity :: Text+ }+ deriving (Eq, Ord, Show, Typeable)++-- | ServiceConfiguration: 'SesConfiguration'+instance SignQuery SetIdentityFeedbackForwardingEnabled where+ type ServiceConfiguration SetIdentityFeedbackForwardingEnabled = SesConfiguration+ signQuery SetIdentityFeedbackForwardingEnabled{..} =+ sesSignQuery [ ("Action", "SetIdentityFeedbackForwardingEnabled")+ , ("Identity", T.encodeUtf8 sffIdentity)+ , ("ForwardingEnabled", awsBool sffForwardingEnabled)+ ]++-- | The response sent back by SES after the+-- 'SetIdentityFeedbackForwardingEnabled' command.+data SetIdentityFeedbackForwardingEnabledResponse = SetIdentityFeedbackForwardingEnabledResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer SetIdentityFeedbackForwardingEnabled SetIdentityFeedbackForwardingEnabledResponse where+ type ResponseMetadata SetIdentityFeedbackForwardingEnabledResponse = SesMetadata+ responseConsumer _ _+ = sesResponseConsumer $ \_ -> return SetIdentityFeedbackForwardingEnabledResponse++instance Transaction SetIdentityFeedbackForwardingEnabled SetIdentityFeedbackForwardingEnabledResponse++instance AsMemoryResponse SetIdentityFeedbackForwardingEnabledResponse where+ type MemoryResponse SetIdentityFeedbackForwardingEnabledResponse = SetIdentityFeedbackForwardingEnabledResponse+ loadToMemory = return
+ Aws/Ses/Commands/SetIdentityNotificationTopic.hs view
@@ -0,0 +1,59 @@+module Aws.Ses.Commands.SetIdentityNotificationTopic+ ( SetIdentityNotificationTopic(..)+ , SetIdentityNotificationTopicResponse(..)+ , NotificationType(..)+ ) where++import Data.Text (Text)+import Control.Applicative+import Data.Maybe (maybeToList)+import Data.Text.Encoding as T (encodeUtf8)+import Data.Typeable+import Prelude+import Aws.Core+import Aws.Ses.Core++data NotificationType = Bounce | Complaint+ deriving (Eq, Ord, Show, Typeable)++-- | Change or remove the Amazon SNS notification topic to which notification+-- of the given type are published.+data SetIdentityNotificationTopic =+ SetIdentityNotificationTopic+ { sntIdentity :: Text+ -- ^ The identity for which the SNS topic will be changed.+ , sntNotificationType :: NotificationType+ -- ^ The type of notifications that will be published to the topic.+ , sntSnsTopic :: Maybe Text+ -- ^ @Just@ the ARN of the SNS topic or @Nothing@ to unset the topic.+ }+ deriving (Eq, Ord, Show, Typeable)++-- | ServiceConfiguration: 'SesConfiguration'+instance SignQuery SetIdentityNotificationTopic where+ type ServiceConfiguration SetIdentityNotificationTopic = SesConfiguration+ signQuery SetIdentityNotificationTopic{..} =+ let notificationType = case sntNotificationType of+ Bounce -> "Bounce"+ Complaint -> "Complaint"+ snsTopic = ("SnsTopic",) . T.encodeUtf8 <$> sntSnsTopic+ in sesSignQuery $ [ ("Action", "SetIdentityNotificationTopic")+ , ("Identity", T.encodeUtf8 sntIdentity)+ , ("NotificationType", notificationType)+ ] ++ maybeToList snsTopic++-- | The response sent back by SES after the 'SetIdentityNotificationTopic'+-- command.+data SetIdentityNotificationTopicResponse = SetIdentityNotificationTopicResponse+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer SetIdentityNotificationTopic SetIdentityNotificationTopicResponse where+ type ResponseMetadata SetIdentityNotificationTopicResponse = SesMetadata+ responseConsumer _ _+ = sesResponseConsumer $ \_ -> return SetIdentityNotificationTopicResponse++instance Transaction SetIdentityNotificationTopic SetIdentityNotificationTopicResponse++instance AsMemoryResponse SetIdentityNotificationTopicResponse where+ type MemoryResponse SetIdentityNotificationTopicResponse = SetIdentityNotificationTopicResponse+ loadToMemory = return
+ Aws/Ses/Commands/VerifyDomainDkim.hs view
@@ -0,0 +1,40 @@+module Aws.Ses.Commands.VerifyDomainDkim+ ( VerifyDomainDkim(..)+ , VerifyDomainDkimResponse(..)+ ) where++import Data.Text (Text)+import Data.Text.Encoding as T (encodeUtf8)+import Data.Typeable+import Aws.Core+import Aws.Ses.Core+import Text.XML.Cursor (($//), laxElement, (&/))++-- | Verify ownership of a domain.+data VerifyDomainDkim = VerifyDomainDkim Text+ deriving (Eq, Ord, Show, Typeable)++-- | ServiceConfiguration: 'SesConfiguration'+instance SignQuery VerifyDomainDkim where+ type ServiceConfiguration VerifyDomainDkim = SesConfiguration+ signQuery (VerifyDomainDkim domain) =+ sesSignQuery [ ("Action", "VerifyDomainDkim")+ , ("Domain", T.encodeUtf8 domain)+ ]++-- | The response sent back by Amazon SES after a 'VerifyDomainDkim' command.+data VerifyDomainDkimResponse = VerifyDomainDkimResponse [Text]+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer VerifyDomainDkim VerifyDomainDkimResponse where+ type ResponseMetadata VerifyDomainDkimResponse = SesMetadata+ responseConsumer _ _ =+ sesResponseConsumer $ \cursor -> do+ let tokens = cursor $// laxElement "DkimTokens" &/ elContent "member"+ return (VerifyDomainDkimResponse tokens)++instance Transaction VerifyDomainDkim VerifyDomainDkimResponse where++instance AsMemoryResponse VerifyDomainDkimResponse where+ type MemoryResponse VerifyDomainDkimResponse = VerifyDomainDkimResponse+ loadToMemory = return
+ Aws/Ses/Commands/VerifyDomainIdentity.hs view
@@ -0,0 +1,41 @@+module Aws.Ses.Commands.VerifyDomainIdentity+ ( VerifyDomainIdentity(..)+ , VerifyDomainIdentityResponse(..)+ ) where++import Data.Text (Text)+import Data.Text.Encoding as T (encodeUtf8)+import Data.Typeable+import Aws.Core+import Aws.Ses.Core+import Text.XML.Cursor (($//))++-- | Verify ownership of a domain.+data VerifyDomainIdentity = VerifyDomainIdentity Text+ deriving (Eq, Ord, Show, Typeable)++-- | ServiceConfiguration: 'SesConfiguration'+instance SignQuery VerifyDomainIdentity where+ type ServiceConfiguration VerifyDomainIdentity = SesConfiguration+ signQuery (VerifyDomainIdentity domain) =+ sesSignQuery [ ("Action", "VerifyDomainIdentity")+ , ("Domain", T.encodeUtf8 domain)+ ]++-- | The response sent back by Amazon SES after a+-- 'VerifyDomainIdentity' command.+data VerifyDomainIdentityResponse = VerifyDomainIdentityResponse Text+ deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer VerifyDomainIdentity VerifyDomainIdentityResponse where+ type ResponseMetadata VerifyDomainIdentityResponse = SesMetadata+ responseConsumer _ _ =+ sesResponseConsumer $ \cursor -> do+ token <- force "Verification token not found" $ cursor $// elContent "VerificationToken"+ return (VerifyDomainIdentityResponse token)++instance Transaction VerifyDomainIdentity VerifyDomainIdentityResponse where++instance AsMemoryResponse VerifyDomainIdentityResponse where+ type MemoryResponse VerifyDomainIdentityResponse = VerifyDomainIdentityResponse+ loadToMemory = return
+ Aws/Ses/Commands/VerifyEmailIdentity.hs view
@@ -0,0 +1,40 @@+module Aws.Ses.Commands.VerifyEmailIdentity+ ( VerifyEmailIdentity(..)+ , VerifyEmailIdentityResponse(..)+ ) where++import Data.Text (Text)+import Data.Text.Encoding as T (encodeUtf8)+import Data.Typeable+import Aws.Core+import Aws.Ses.Core++-- | List email addresses and/or domains+data VerifyEmailIdentity = VerifyEmailIdentity Text+ deriving (Eq, Ord, Show, Typeable)++-- | ServiceConfiguration: 'SesConfiguration'+instance SignQuery VerifyEmailIdentity where+ type ServiceConfiguration VerifyEmailIdentity = SesConfiguration+ signQuery (VerifyEmailIdentity address) =+ sesSignQuery [ ("Action", "VerifyEmailIdentity")+ , ("EmailAddress", T.encodeUtf8 address)+ ]++-- | The response sent back by Amazon SES after a+-- 'VerifyEmailIdentity' command.+data VerifyEmailIdentityResponse = VerifyEmailIdentityResponse+ deriving (Eq, Ord, Show, Typeable)+++instance ResponseConsumer VerifyEmailIdentity VerifyEmailIdentityResponse where+ type ResponseMetadata VerifyEmailIdentityResponse = SesMetadata+ responseConsumer _ _+ = sesResponseConsumer $ \_ -> return VerifyEmailIdentityResponse+++instance Transaction VerifyEmailIdentity VerifyEmailIdentityResponse where++instance AsMemoryResponse VerifyEmailIdentityResponse where+ type MemoryResponse VerifyEmailIdentityResponse = VerifyEmailIdentityResponse+ loadToMemory = return
Aws/Ses/Core.hs view
@@ -3,7 +3,10 @@ , SesMetadata(..) , SesConfiguration(..)+ , sesEuWest1 , sesUsEast+ , sesUsEast1+ , sesUsWest2 , sesHttpsGet , sesHttpsPost @@ -22,17 +25,19 @@ import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import qualified Control.Exception as C-import qualified Control.Failure as F import Control.Monad (mplus)+import Control.Monad.Trans.Resource (throwM) import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 ({-IsString-}) import Data.IORef import Data.Maybe import Data.Monoid+import qualified Data.Semigroup as Sem import Data.Text (Text) import qualified Data.Text.Encoding as TE import Data.Typeable+import Prelude import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP import Text.XML.Cursor (($/), ($//))@@ -57,9 +62,12 @@ instance Loggable SesMetadata where toLogText (SesMetadata rid) = "SES: request ID=" `mappend` fromMaybe "<none>" rid +instance Sem.Semigroup SesMetadata where+ SesMetadata r1 <> SesMetadata r2 = SesMetadata (r1 `mplus` r2)+ instance Monoid SesMetadata where mempty = SesMetadata Nothing- SesMetadata r1 `mappend` SesMetadata r2 = SesMetadata (r1 `mplus` r2)+ mappend = (Sem.<>) data SesConfiguration qt = SesConfiguration {@@ -70,14 +78,23 @@ -- HTTP is not supported right now, always use HTTPS instance DefaultServiceConfiguration (SesConfiguration NormalQuery) where- defServiceConfig = sesHttpsPost sesUsEast+ defServiceConfig = sesHttpsPost sesUsEast1 instance DefaultServiceConfiguration (SesConfiguration UriOnlyQuery) where- defServiceConfig = sesHttpsGet sesUsEast+ defServiceConfig = sesHttpsGet sesUsEast1 +sesEuWest1 :: B.ByteString+sesEuWest1 = "email.eu-west-1.amazonaws.com"+ sesUsEast :: B.ByteString-sesUsEast = "email.us-east-1.amazonaws.com"+sesUsEast = sesUsEast1 +sesUsEast1 :: B.ByteString+sesUsEast1 = "email.us-east-1.amazonaws.com"++sesUsWest2 :: B.ByteString+sesUsWest2 = "email.us-west-2.amazonaws.com"+ sesHttpsGet :: B.ByteString -> SesConfiguration qt sesHttpsGet endpoint = SesConfiguration Get endpoint @@ -97,7 +114,7 @@ , sqAuthorization = Nothing , sqContentType = Nothing , sqContentMd5 = Nothing- , sqAmzHeaders = [("X-Amzn-Authorization", authorization)]+ , sqAmzHeaders = amzHeaders , sqOtherHeaders = [] , sqBody = Nothing , sqStringToSign = stringToSign@@ -106,11 +123,16 @@ stringToSign = fmtRfc822Time (signatureTime sd) credentials = signatureCredentials sd accessKeyId = accessKeyID credentials- authorization = B.concat [ "AWS3-HTTPS AWSAccessKeyId="- , accessKeyId- , ", Algorithm=HmacSHA256, Signature="- , signature credentials HmacSHA256 stringToSign- ]+ amzHeaders = catMaybes+ [ Just ("X-Amzn-Authorization", authorization)+ , ("x-amz-security-token",) `fmap` iamToken credentials+ ]+ authorization = B.concat+ [ "AWS3-HTTPS AWSAccessKeyId="+ , accessKeyId+ , ", Algorithm=HmacSHA256, Signature="+ , signature credentials HmacSHA256 stringToSign+ ] query' = ("AWSAccessKeyId", accessKeyId) : query sesResponseConsumer :: (Cu.Cursor -> Response SesMetadata a)@@ -128,7 +150,7 @@ fromError cursor = do errCode <- force "Missing Error Code" $ cursor $// elContent "Code" errMessage <- force "Missing Error Message" $ cursor $// elContent "Message"- F.failure $ SesError (HTTP.responseStatus resp) errCode errMessage+ throwM $ SesError (HTTP.responseStatus resp) errCode errMessage class SesAsQuery a where -- | Write a data type as a list of query parameters.@@ -166,11 +188,13 @@ s = Blaze.fromByteString one = 1 :: Int -instance Monoid Destination where- mempty = Destination [] [] []- mappend (Destination a1 a2 a3) (Destination b1 b2 b3) =+instance Sem.Semigroup Destination where+ (Destination a1 a2 a3) <> (Destination b1 b2 b3) = Destination (a1 ++ b1) (a2 ++ b2) (a3 ++ b3) +instance Monoid Destination where+ mempty = Destination [] [] []+ mappend = (Sem.<>) -- | An e-mail address. type EmailAddress = Text
Aws/SimpleDb/Commands/Attributes.hs view
@@ -5,6 +5,7 @@ import Control.Applicative import Control.Monad import Data.Maybe+import Prelude import Text.XML.Cursor (($//), (&|)) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -39,7 +40,8 @@ instance ResponseConsumer r GetAttributesResponse where type ResponseMetadata GetAttributesResponse = SdbMetadata- responseConsumer _ = sdbResponseConsumer parse+ responseConsumer _ _+ = sdbResponseConsumer parse where parse cursor = do sdbCheckResponseType () "GetAttributesResponse" cursor attributes <- sequence $ cursor $// Cu.laxElement "Attribute" &| readAttribute@@ -83,7 +85,8 @@ instance ResponseConsumer r PutAttributesResponse where type ResponseMetadata PutAttributesResponse = SdbMetadata- responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType PutAttributesResponse "PutAttributesResponse"+ responseConsumer _ _+ = sdbResponseConsumer $ sdbCheckResponseType PutAttributesResponse "PutAttributesResponse" instance Transaction PutAttributes PutAttributesResponse @@ -123,7 +126,8 @@ instance ResponseConsumer r DeleteAttributesResponse where type ResponseMetadata DeleteAttributesResponse = SdbMetadata- responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType DeleteAttributesResponse "DeleteAttributesResponse"+ responseConsumer _ _+ = sdbResponseConsumer $ sdbCheckResponseType DeleteAttributesResponse "DeleteAttributesResponse" instance Transaction DeleteAttributes DeleteAttributesResponse @@ -156,7 +160,8 @@ instance ResponseConsumer r BatchPutAttributesResponse where type ResponseMetadata BatchPutAttributesResponse = SdbMetadata- responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType BatchPutAttributesResponse "BatchPutAttributesResponse"+ responseConsumer _ _+ = sdbResponseConsumer $ sdbCheckResponseType BatchPutAttributesResponse "BatchPutAttributesResponse" instance Transaction BatchPutAttributes BatchPutAttributesResponse @@ -189,7 +194,8 @@ instance ResponseConsumer r BatchDeleteAttributesResponse where type ResponseMetadata BatchDeleteAttributesResponse = SdbMetadata- responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType BatchDeleteAttributesResponse "BatchDeleteAttributesResponse"+ responseConsumer _ _+ = sdbResponseConsumer $ sdbCheckResponseType BatchDeleteAttributesResponse "BatchDeleteAttributesResponse" instance Transaction BatchDeleteAttributes BatchDeleteAttributesResponse
Aws/SimpleDb/Commands/Domain.hs view
@@ -6,6 +6,7 @@ import Data.Maybe import Data.Time import Data.Time.Clock.POSIX+import Prelude import Text.XML.Cursor (($//), (&|)) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -30,7 +31,8 @@ instance ResponseConsumer r CreateDomainResponse where type ResponseMetadata CreateDomainResponse = SdbMetadata- responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType CreateDomainResponse "CreateDomainResponse"+ responseConsumer _ _+ = sdbResponseConsumer $ sdbCheckResponseType CreateDomainResponse "CreateDomainResponse" instance Transaction CreateDomain CreateDomainResponse @@ -58,7 +60,8 @@ instance ResponseConsumer r DeleteDomainResponse where type ResponseMetadata DeleteDomainResponse = SdbMetadata- responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType DeleteDomainResponse "DeleteDomainResponse"+ responseConsumer _ _+ = sdbResponseConsumer $ sdbCheckResponseType DeleteDomainResponse "DeleteDomainResponse" instance Transaction DeleteDomain DeleteDomainResponse @@ -95,7 +98,8 @@ instance ResponseConsumer r DomainMetadataResponse where type ResponseMetadata DomainMetadataResponse = SdbMetadata - responseConsumer _ = sdbResponseConsumer parse+ responseConsumer _ _+ = sdbResponseConsumer parse where parse cursor = do sdbCheckResponseType () "DomainMetadataResponse" cursor dmrTimestamp <- forceM "Timestamp expected" $ cursor $// elCont "Timestamp" &| (fmap posixSecondsToUTCTime . readInt)@@ -141,7 +145,7 @@ instance ResponseConsumer r ListDomainsResponse where type ResponseMetadata ListDomainsResponse = SdbMetadata- responseConsumer _ = sdbResponseConsumer parse+ responseConsumer _ _ = sdbResponseConsumer parse where parse cursor = do sdbCheckResponseType () "ListDomainsResponse" cursor let names = cursor $// elContent "DomainName"
Aws/SimpleDb/Commands/Select.hs view
@@ -6,6 +6,7 @@ import Control.Applicative import Control.Monad import Data.Maybe+import Prelude import Text.XML.Cursor (($//), (&|)) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -42,7 +43,7 @@ instance ResponseConsumer r SelectResponse where type ResponseMetadata SelectResponse = SdbMetadata- responseConsumer _ = sdbResponseConsumer parse+ responseConsumer _ _ = sdbResponseConsumer parse where parse cursor = do sdbCheckResponseType () "SelectResponse" cursor items <- sequence $ cursor $// Cu.laxElement "Item" &| readItem
Aws/SimpleDb/Core.hs view
@@ -4,17 +4,19 @@ import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import qualified Control.Exception as C-import qualified Control.Failure as F import Control.Monad+import Control.Monad.Trans.Resource (MonadThrow, throwM) import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as Base64 import Data.IORef import Data.List import Data.Maybe import Data.Monoid+import qualified Data.Semigroup as Sem import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable+import Prelude import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP import Text.XML.Cursor (($|), ($/), ($//), (&|))@@ -32,7 +34,7 @@ instance C.Exception SdbError -data SdbMetadata +data SdbMetadata = SdbMetadata { requestId :: Maybe T.Text , boxUsage :: Maybe T.Text@@ -45,9 +47,12 @@ ", box usage=" `mappend` fromMaybe "<not available>" bu +instance Sem.Semigroup SdbMetadata where+ SdbMetadata r1 b1 <> SdbMetadata r2 b2 = SdbMetadata (r1 `mplus` r2) (b1 `mplus` b2)+ instance Monoid SdbMetadata where mempty = SdbMetadata Nothing Nothing- SdbMetadata r1 b1 `mappend` SdbMetadata r2 b2 = SdbMetadata (r1 `mplus` r2) (b1 `mplus` b2)+ mappend = (Sem.<>) data SdbConfiguration qt = SdbConfiguration {@@ -63,11 +68,11 @@ debugServiceConfig = sdbHttpPost sdbUsEast instance DefaultServiceConfiguration (SdbConfiguration UriOnlyQuery) where- defServiceConfig = sdbHttpsGet sdbUsEast + defServiceConfig = sdbHttpsGet sdbUsEast debugServiceConfig = sdbHttpGet sdbUsEast- + sdbUsEast :: B.ByteString-sdbUsEast = "sdb.amazonaws.com" +sdbUsEast = "sdb.amazonaws.com" sdbUsWest :: B.ByteString sdbUsWest = "sdb.us-west-1.amazonaws.com"@@ -80,16 +85,16 @@ sdbApNortheast :: B.ByteString sdbApNortheast = "sdb.ap-northeast-1.amazonaws.com"- + sdbHttpGet :: B.ByteString -> SdbConfiguration qt sdbHttpGet endpoint = SdbConfiguration HTTP Get endpoint (defaultPort HTTP)- + sdbHttpPost :: B.ByteString -> SdbConfiguration NormalQuery sdbHttpPost endpoint = SdbConfiguration HTTP PostQuery endpoint (defaultPort HTTP)- + sdbHttpsGet :: B.ByteString -> SdbConfiguration qt sdbHttpsGet endpoint = SdbConfiguration HTTPS Get endpoint (defaultPort HTTPS)- + sdbHttpsPost :: B.ByteString -> SdbConfiguration NormalQuery sdbHttpsPost endpoint = SdbConfiguration HTTPS PostQuery endpoint (defaultPort HTTPS) @@ -121,14 +126,14 @@ AbsoluteExpires time -> ("Expires", fmtAmzTime time) , ("AWSAccessKeyId", accessKeyID cr) , ("SignatureMethod", amzHash ah)- , ("SignatureVersion", "2")- ]+ , ("SignatureVersion", "2")]+ ++ maybe [] (\tok -> [("SecurityToken", tok)]) (iamToken cr) sq = ("Signature", Just sig) : q' method = sdbiHttpMethod si host = sdbiHost si path = "/" sig = signature cr ah stringToSign- stringToSign = Blaze.toByteString . mconcat $ + stringToSign = Blaze.toByteString . mconcat $ intersperse (Blaze8.fromChar '\n') [Blaze.copyByteString $ httpMethod method , Blaze.copyByteString $ host@@ -149,16 +154,16 @@ (err:_) -> fromError err fromError cursor = do errCode <- force "Missing Error Code" $ cursor $// elCont "Code" errMessage <- force "Missing Error Message" $ cursor $// elCont "Message"- F.failure $ SdbError (HTTP.responseStatus resp) errCode errMessage+ throwM $ SdbError (HTTP.responseStatus resp) errCode errMessage class SdbFromResponse a where sdbFromResponse :: Cu.Cursor -> Response SdbMetadata a -sdbCheckResponseType :: F.Failure XmlException m => a -> T.Text -> Cu.Cursor -> m a+sdbCheckResponseType :: MonadThrow m => a -> T.Text -> Cu.Cursor -> m a sdbCheckResponseType a n c = do _ <- force ("Expected response type " ++ T.unpack n) (Cu.laxElement n c) return a -decodeBase64 :: F.Failure XmlException m => Cu.Cursor -> m T.Text+decodeBase64 :: MonadThrow m => Cu.Cursor -> m T.Text decodeBase64 cursor = let encoded = T.concat $ cursor $/ Cu.content encoding = listToMaybe $ cursor $| Cu.laxAttribute "encoding" &| T.toCaseFold@@ -166,15 +171,15 @@ case encoding of Nothing -> return encoded Just "base64" -> case Base64.decode . T.encodeUtf8 $ encoded of- Left msg -> F.failure $ XmlException ("Invalid Base64 data: " ++ msg)+ Left msg -> throwM $ XmlException ("Invalid Base64 data: " ++ msg) Right x -> return $ T.decodeUtf8 x- Just actual -> F.failure $ XmlException ("Unrecognized encoding " ++ T.unpack actual)+ Just actual -> throwM $ XmlException ("Unrecognized encoding " ++ T.unpack actual) data Attribute a = ForAttribute { attributeName :: T.Text, attributeData :: a } deriving (Show) -readAttribute :: F.Failure XmlException m => Cu.Cursor -> m (Attribute T.Text)+readAttribute :: MonadThrow m => Cu.Cursor -> m (Attribute T.Text) readAttribute cursor = do name <- forceM "Missing Name" $ cursor $/ Cu.laxElement "Name" &| decodeBase64 value <- forceM "Missing Value" $ cursor $/ Cu.laxElement "Value" &| decodeBase64@@ -225,7 +230,7 @@ = Item { itemName :: T.Text, itemData :: a } deriving (Show) -readItem :: F.Failure XmlException m => Cu.Cursor -> m (Item [Attribute T.Text])+readItem :: MonadThrow m => Cu.Cursor -> m (Item [Attribute T.Text]) readItem cursor = do name <- force "Missing Name" <=< sequence $ cursor $/ Cu.laxElement "Name" &| decodeBase64 attributes <- sequence $ cursor $/ Cu.laxElement "Attribute" &| readAttribute
Aws/Sqs/Commands/Message.hs view
@@ -1,43 +1,243 @@+module Aws.Sqs.Commands.Message+(+-- * User Message Attributes+ UserMessageAttributeCustomType+, UserMessageAttributeValue(..)+, UserMessageAttributeName+, UserMessageAttribute -module Aws.Sqs.Commands.Message where+-- * Send Message+, SendMessage(..)+, SendMessageResponse(..) -import Aws.Core-import Aws.Sqs.Core-import Control.Applicative-import Data.Maybe-import Text.XML.Cursor (($/), ($//), (&/), (&|))-import qualified Control.Failure as F+-- * Delete Message+, DeleteMessage(..)+, DeleteMessageResponse(..)++-- * Receive Message+, Message(..)+, ReceiveMessage(..)+, ReceiveMessageResponse(..)++-- * Change Message Visibility+, ChangeMessageVisibility(..)+, ChangeMessageVisibilityResponse(..)+) where++import Aws.Core+import Aws.Sqs.Core+import Control.Applicative+import Control.Monad.Trans.Resource (throwM)+import Data.Maybe+import Data.Monoid+import Text.XML.Cursor (($/), ($//), (&/), (&|))+import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as B-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Text.XML.Cursor as Cu+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Scientific+import qualified Network.HTTP.Types as HTTP+import Text.Read (readEither)+import qualified Text.XML.Cursor as Cu+import Prelude -data SendMessage = SendMessage{- smMessage :: T.Text,- smQueueName :: QueueName-}deriving (Show)+-- -------------------------------------------------------------------------- --+-- User Message Attributes -data SendMessageResponse = SendMessageResponse{- smrMD5OfMessageBody :: T.Text,- smrMessageId :: MessageId-} deriving (Show)+-- | You can append a custom type label to the supported data types (String,+-- Number, and Binary) to create custom data types. This capability is similar+-- to type traits in programming languages. For example, if you have an+-- application that needs to know which type of number is being sent in the+-- message, then you could create custom types similar to the following:+-- Number.byte, Number.short, Number.int, and Number.float. Another example+-- using the binary data type is to use Binary.gif and Binary.png to+-- distinguish among different image file types in a message or batch of+-- messages. The appended data is optional and opaque to Amazon SQS, which+-- means that the appended data is not interpreted, validated, or used by+-- Amazon SQS. The Custom Type extension has the same restrictions on allowed+-- characters as the message body.+--+type UserMessageAttributeCustomType = T.Text +-- | Message Attribute Value+--+-- The user-specified message attribute value. For string data types, the value+-- attribute has the same restrictions on the content as the message body. For+-- more information, see SendMessage.+--+-- Name, type, and value must not be empty or null. In addition, the message+-- body should not be empty or null. All parts of the message attribute,+-- including name, type, and value, are included in the message size+-- restriction, which is currently 256 KB (262,144 bytes).+--+-- The supported message attribute data types are String, Number, and Binary.+-- You can also provide custom information on the type. The data type has the+-- same restrictions on the content as the message body. The data type is case+-- sensitive, and it can be up to 256 bytes long.+--+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_MessageAttributeValue.html>+--+data UserMessageAttributeValue+ = UserMessageAttributeString (Maybe UserMessageAttributeCustomType) T.Text+ -- ^ Strings are Unicode with UTF-8 binary encoding.++ | UserMessageAttributeNumber (Maybe UserMessageAttributeCustomType) Scientific+ -- ^ Numbers are positive or negative integers or floating point numbers.+ -- Numbers have sufficient range and precision to encompass most of the+ -- possible values that integers, floats, and doubles typically support. A+ -- number can have up to 38 digits of precision, and it can be between+ -- 10^-128 to 10^+126. Leading and trailing zeroes are trimmed.++ | UserMessageAttributeBinary (Maybe UserMessageAttributeCustomType) B.ByteString+ -- ^ Binary type attributes can store any binary data, for example,+ -- compressed data, encrypted data, or images.++ -- UserMessageAttributesStringList (Maybe UserMessageAttributeCustomType) [T.Text]+ -- -- ^ Not implemented. Reserved for future use.++ -- UserMessageAttributeBinaryList (Maybe UserMessageAttributeCustomType) [B.ByteString]+ -- -- ^ Not implemented. Reserved for future use.++ deriving (Show, Read, Eq, Ord)++-- | The message attribute name can contain the following characters: A-Z, a-z,+-- 0-9, underscore(_), hyphen(-), and period (.). The name must not start or+-- end with a period, and it should not have successive periods. The name is+-- case sensitive and must be unique among all attribute names for the message.+-- The name can be up to 256 characters long. The name cannot start with "AWS."+-- or "Amazon." (or any variations in casing) because these prefixes are+-- reserved for use by Amazon Web Services.+--+type UserMessageAttributeName = T.Text++-- | Message Attribute+--+-- Name, type, and value must not be empty or null. In addition, the message+-- body should not be empty or null. All parts of the message attribute,+-- including name, type, and value, are included in the message size+-- restriction, which is currently 256 KB (262,144 bytes).+--+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/latest/SQSDeveloperGuide/SQSMessageAttributes.html#SQSMessageAttributes.DataTypes>+--+-- /NOTE/+--+-- The Amazon SQS API reference calls this /MessageAttribute/. The Haskell+-- bindings use this term for what the Amazon documentation calls just+-- /Attributes/. In order to limit backward compatibility issues we keep the+-- terminology of the Haskell bindings and call this type+-- /UserMessageAttributes/.+--+type UserMessageAttribute = (UserMessageAttributeName, UserMessageAttributeValue)++userMessageAttributesQuery :: [UserMessageAttribute] -> HTTP.Query+userMessageAttributesQuery = concat . zipWith msgAttrQuery [1 :: Int ..]+ where+ msgAttrQuery i (name, value) =+ [ ( pre <> "Name", Just $ TE.encodeUtf8 name )+ , ( pre <> "Value.DataType", Just typ )+ , ( pre <> "Value." <> valueKey, Just encodedValue )+ ]+ where+ pre = "MessageAttribute." <> B.pack (show i) <> "."+ customType Nothing t = TE.encodeUtf8 t+ customType (Just c) t = TE.encodeUtf8 $ t <> "." <> c+ (typ, valueKey, encodedValue) = case value of+ UserMessageAttributeString c t ->+ (customType c "String", "StringValue", TE.encodeUtf8 t)+ UserMessageAttributeNumber c n ->+ (customType c "Number", "StringValue", B.pack $ show n)+ UserMessageAttributeBinary c b ->+ (customType c "Binary", "BinaryValue", b)++-- -------------------------------------------------------------------------- --+-- Send Message++-- | Delivers a message to the specified queue. With Amazon SQS, you now have+-- the ability to send large payload messages that are up to 256KB (262,144+-- bytes) in size. To send large payloads, you must use an AWS SDK that+-- supports SigV4 signing. To verify whether SigV4 is supported for an AWS SDK,+-- check the SDK release notes.+--+-- /IMPORTANT/+--+-- The following list shows the characters (in Unicode) allowed in your+-- message, according to the W3C XML specification. For more information, go to+-- <http://www.w3.org/TR/REC-xml/#charsets> If you send any characters not+-- included in the list, your request will be rejected.+--+-- > #x9 | #xA | #xD | [#x20 to #xD7FF] | [#xE000 to #xFFFD] | [#x10000 to #x10FFFF]+--+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_SendMessage.html>+--+data SendMessage = SendMessage+ { smMessage :: !T.Text+ -- ^ The message to send. String maximum 256 KB in size.++ , smQueueName :: !QueueName+ -- ^ The URL of the Amazon SQS queue to take action on.++ , smAttributes :: ![UserMessageAttribute]+ -- ^ Each message attribute consists of a Name, Type, and Value.++ , smDelaySeconds :: !(Maybe Int)+ -- ^ The number of seconds (0 to 900 - 15 minutes) to delay a specific+ -- message. Messages with a positive DelaySeconds value become available for+ -- processing after the delay time is finished. If you don't specify a value,+ -- the default value for the queue applies.+ }+ deriving (Show, Read, Eq, Ord)++-- | At+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_SendMessageResult.html>+-- all fields of @SendMessageResult@ are denoted as optional.+-- At+-- <http://queue.amazonaws.com/doc/2012-11-05/QueueService.wsdl>+-- all fields are specified as required.+--+-- The actual service seems to treat at least 'smrMD5OfMessageAttributes'+-- as optional.+--+data SendMessageResponse = SendMessageResponse+ { smrMD5OfMessageBody :: !T.Text+ -- ^ An MD5 digest of the non-URL-encoded message body string. This can be+ -- used to verify that Amazon SQS received the message correctly. Amazon SQS+ -- first URL decodes the message before creating the MD5 digest. For+ -- information about MD5, go to <http://www.faqs.org/rfcs/rfc1321.html>.++ , smrMessageId :: !MessageId+ -- ^ An element containing the message ID of the message sent to the queue.++ , smrMD5OfMessageAttributes :: !(Maybe T.Text)+ -- ^ An MD5 digest of the non-URL-encoded message attribute string. This can+ -- be used to verify that Amazon SQS received the message correctly. Amazon+ -- SQS first URL decodes the message before creating the MD5 digest. For+ -- information about MD5, go to <http://www.faqs.org/rfcs/rfc1321.html>.+ }+ deriving (Show, Read, Eq, Ord)+ instance ResponseConsumer r SendMessageResponse where type ResponseMetadata SendMessageResponse = SqsMetadata- responseConsumer _ = sqsXmlResponseConsumer parse+ 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 = MessageId mid }+ parse el = SendMessageResponse+ <$> force "Missing MD5 Signature"+ (el $// Cu.laxElement "MD5OfMessageBody" &/ Cu.content)+ <*> (fmap MessageId . force "Missing Message Id")+ (el $// Cu.laxElement "MessageId" &/ Cu.content)+ <*> (pure . listToMaybe)+ (el $// Cu.laxElement "MD5OfMessageAttributes" &/ Cu.content) --- | ServiceConfiguration: 'SqsConfiguration'-instance SignQuery SendMessage where- type ServiceConfiguration SendMessage = SqsConfiguration- signQuery SendMessage {..} = sqsSignQuery SqsQuery {- sqsQueueName = Just smQueueName,- sqsQuery = [("Action", Just "SendMessage"),- ("MessageBody", Just $ TE.encodeUtf8 smMessage )]}+instance SignQuery SendMessage where+ type ServiceConfiguration SendMessage = SqsConfiguration+ signQuery SendMessage{..} = sqsSignQuery SqsQuery+ { sqsQueueName = Just smQueueName+ , sqsQuery =+ [ ("Action", Just "SendMessage")+ , ("MessageBody", Just $ TE.encodeUtf8 smMessage)+ ]+ <> userMessageAttributesQuery smAttributes+ <> maybeToList (("DelaySeconds",) . Just . B.pack . show <$> smDelaySeconds)+ } instance Transaction SendMessage SendMessageResponse @@ -45,133 +245,437 @@ type MemoryResponse SendMessageResponse = SendMessageResponse loadToMemory = return -data DeleteMessage = DeleteMessage{- dmReceiptHandle :: ReceiptHandle,- dmQueueName :: QueueName -}deriving (Show)+-- -------------------------------------------------------------------------- --+-- Delete Message -data DeleteMessageResponse = DeleteMessageResponse{-} deriving (Show)+-- | Deletes the specified message from the specified queue. You specify the+-- message by using the message's receipt handle and not the message ID you+-- received when you sent the message. Even if the message is locked by another+-- reader due to the visibility timeout setting, it is still deleted from the+-- queue. If you leave a message in the queue for longer than the queue's+-- configured retention period, Amazon SQS automatically deletes it.+--+-- /NOTE/+--+-- The receipt handle is associated with a specific instance of receiving the+-- message. If you receive a message more than once, the receipt handle you get+-- each time you receive the message is different. When you request+-- DeleteMessage, if you don't provide the most recently received receipt+-- handle for the message, the request will still succeed, but the message+-- might not be deleted.+--+-- /IMPORTANT/+--+-- It is possible you will receive a message even after you have deleted it.+-- This might happen on rare occasions if one of the servers storing a copy of+-- the message is unavailable when you request to delete the message. The copy+-- remains on the server and might be returned to you again on a subsequent+-- receive request. You should create your system to be idempotent so that+-- receiving a particular message more than once is not a problem.+--+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_DeleteMessage.html>+--+data DeleteMessage = DeleteMessage+ { dmReceiptHandle :: !ReceiptHandle+ -- ^ The receipt handle associated with the message to delete.+ , dmQueueName :: !QueueName+ -- ^ The URL of the Amazon SQS queue to take action on.+ }+ deriving (Show, Read, Eq, Ord) +data DeleteMessageResponse = DeleteMessageResponse {}+ deriving (Show, Read, Eq, Ord)+ instance ResponseConsumer r DeleteMessageResponse where type ResponseMetadata DeleteMessageResponse = SqsMetadata- responseConsumer _ = sqsXmlResponseConsumer parse+ responseConsumer _ _ = sqsXmlResponseConsumer parse where- parse _ = do return DeleteMessageResponse {}- --- | ServiceConfiguration: 'SqsConfiguration'-instance SignQuery DeleteMessage where - type ServiceConfiguration DeleteMessage = SqsConfiguration- signQuery DeleteMessage {..} = sqsSignQuery SqsQuery {- sqsQueueName = Just dmQueueName, - sqsQuery = [("Action", Just "DeleteMessage"), - ("ReceiptHandle", Just $ TE.encodeUtf8 $ printReceiptHandle dmReceiptHandle )]} + parse _ = return DeleteMessageResponse {} +instance SignQuery DeleteMessage where+ type ServiceConfiguration DeleteMessage = SqsConfiguration+ signQuery DeleteMessage{..} = sqsSignQuery SqsQuery+ { sqsQueueName = Just dmQueueName+ , sqsQuery =+ [ ("Action", Just "DeleteMessage")+ , ("ReceiptHandle", Just $ TE.encodeUtf8 $ printReceiptHandle dmReceiptHandle)+ ]+ }+ instance Transaction DeleteMessage DeleteMessageResponse instance AsMemoryResponse DeleteMessageResponse where type MemoryResponse DeleteMessageResponse = DeleteMessageResponse loadToMemory = return -data ReceiveMessage- = ReceiveMessage {- rmVisibilityTimeout :: Maybe Int- , rmAttributes :: [MessageAttribute]- , rmMaxNumberOfMessages :: Maybe Int- , rmQueueName :: QueueName- }- deriving (Show)+-- -------------------------------------------------------------------------- --+-- Receive Message -data Message- = Message {- mMessageId :: T.Text- , mReceiptHandle :: ReceiptHandle- , mMD5OfBody :: T.Text- , mBody :: T.Text- , mAttributes :: [(MessageAttribute,T.Text)]- }- deriving(Show)+-- | Retrieves one or more messages, with a maximum limit of 10 messages, from+-- the specified queue. Long poll support is enabled by using the+-- WaitTimeSeconds parameter. For more information, see+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/latest/SQSDeveloperGuide/sqs-long-polling.html Amazon SQS Long Poll>+-- in the Amazon SQS Developer Guide.+--+-- Short poll is the default behavior where a weighted random set of machines+-- is sampled on a ReceiveMessage call. This means only the messages on the+-- sampled machines are returned. If the number of messages in the queue is+-- small (less than 1000), it is likely you will get fewer messages than you+-- requested per ReceiveMessage call. If the number of messages in the queue is+-- extremely small, you might not receive any messages in a particular+-- ReceiveMessage response; in which case you should repeat the request.+--+-- For each message returned, the response includes the following:+--+-- Message body+--+-- * MD5 digest of the message body. For information about MD5, go to+-- <http://www.faqs.org/rfcs/rfc1321.html>.+--+-- * Message ID you received when you sent the message to the queue.+--+-- * Receipt handle.+--+-- * Message attributes.+--+-- * MD5 digest of the message attributes.+--+-- The receipt handle is the identifier you must provide when deleting the+-- message. For more information, see Queue and Message Identifiers in the+-- Amazon SQS Developer Guide.+--+-- You can provide the VisibilityTimeout parameter in your request, which will+-- be applied to the messages that Amazon SQS returns in the response. If you+-- do not include the parameter, the overall visibility timeout for the queue+-- is used for the returned messages. For more information, see Visibility+-- Timeout in the Amazon SQS Developer Guide.+--+-- /NOTE/+--+-- Going forward, new attributes might be added. If you are writing code that+-- calls this action, we recommend that you structure your code so that it can+-- handle new attributes gracefully.+--+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_ReceiveMessage.html>+--+data ReceiveMessage = ReceiveMessage+ { rmVisibilityTimeout :: !(Maybe Int)+ -- ^ The duration (in seconds) that the received messages are hidden from+ -- subsequent retrieve requests after being retrieved by a ReceiveMessage+ -- request. -data ReceiveMessageResponse- = ReceiveMessageResponse {- rmrMessages :: [Message]- }- deriving (Show)+ , rmAttributes :: ![MessageAttribute]+ -- ^ A list of attributes that need to be returned along with each message.+ --+ -- The following lists the names and descriptions of the attributes that can+ -- be returned:+ --+ -- * All - returns all values.+ --+ -- * ApproximateFirstReceiveTimestamp - returns the time when the message was+ -- first received (epoch time in milliseconds).+ --+ -- * ApproximateReceiveCount - returns the number of times a message has been+ -- received but not deleted.+ --+ -- * SenderId - returns the AWS account number (or the IP address, if+ -- anonymous access is allowed) of the sender.+ --+ -- * SentTimestamp - returns the time when the message was sent (epoch time+ -- in milliseconds). -readMessageAttribute :: F.Failure XmlException m => Cu.Cursor -> m (MessageAttribute,T.Text)+ , rmMaxNumberOfMessages :: !(Maybe Int)+ -- ^ The maximum number of messages to return. Amazon SQS never returns more+ -- messages than this value but may return fewer. Values can be from 1 to 10.+ -- Default is 1.+ --+ -- All of the messages are not necessarily returned.++ , rmUserMessageAttributes :: ![UserMessageAttributeName]+ -- ^ The name of the message attribute, where N is the index. The message+ -- attribute name can contain the following characters: A-Z, a-z, 0-9,+ -- underscore (_), hyphen (-), and period (.). The name must not start or end+ -- with a period, and it should not have successive periods. The name is case+ -- sensitive and must be unique among all attribute names for the message.+ -- The name can be up to 256 characters long. The name cannot start with+ -- "AWS." or "Amazon." (or any variations in casing), because these prefixes+ -- are reserved for use by Amazon Web Services.+ --+ -- When using ReceiveMessage, you can send a list of attribute names to+ -- receive, or you can return all of the attributes by specifying "All" or+ -- ".*" in your request. You can also use "foo.*" to return all message+ -- attributes starting with the "foo" prefix.++ , rmQueueName :: !QueueName+ -- ^The URL of the Amazon SQS queue to take action on.++ , rmWaitTimeSeconds :: !(Maybe Int)+ -- ^ The duration (in seconds) for which the call will wait for a message to+ -- arrive in the queue before returning. If a message is available, the call+ -- will return sooner than WaitTimeSeconds.++ }+ deriving (Show, Read, Eq, Ord)++-- | An Amazon SQS message.+--+-- In+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_Message.html>+-- all elements are denoted as optional.+-- In+-- <http://queue.amazonaws.com/doc/2012-11-05/QueueService.wsdl>+-- all elements except for the attributes are specified as required.+-- At least for the field 'mMD5OfMessageAttributes' the the service+-- is not always returning a value and therefore we make this field optional.+--+data Message = Message+ { mMessageId :: !T.Text+ -- ^ A unique identifier for the message. Message IDs are considered unique+ -- across all AWS accounts for an extended period of time.++ , mReceiptHandle :: !ReceiptHandle+ -- ^ An identifier associated with the act of receiving the message. A new+ -- receipt handle is returned every time you receive a message. When deleting+ -- a message, you provide the last received receipt handle to delete the+ -- message.++ , mMD5OfBody :: !T.Text+ -- ^ An MD5 digest of the non-URL-encoded message body string.++ , mBody :: T.Text+ -- ^ The message's contents (not URL-encoded).++ , mAttributes :: ![(MessageAttribute,T.Text)]+ -- ^ SenderId, SentTimestamp, ApproximateReceiveCount, and/or+ -- ApproximateFirstReceiveTimestamp. SentTimestamp and+ -- ApproximateFirstReceiveTimestamp are each returned as an integer+ -- representing the epoch time in milliseconds.++ , mMD5OfMessageAttributes :: !(Maybe T.Text)+ -- ^ An MD5 digest of the non-URL-encoded message attribute string. This can+ -- be used to verify that Amazon SQS received the message correctly. Amazon+ -- SQS first URL decodes the message before creating the MD5 digest. For+ -- information about MD5, go to <http://www.faqs.org/rfcs/rfc1321.html>.++ , mUserMessageAttributes :: ![UserMessageAttribute]+ -- ^ Each message attribute consists of a Name, Type, and Value.+ }+ deriving(Show, Read, Eq, Ord)++data ReceiveMessageResponse = ReceiveMessageResponse+ { rmrMessages :: ![Message]+ }+ deriving (Show, Read, Eq, Ord)++readMessageAttribute+ :: Cu.Cursor+ -> Response SqsMetadata (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 <- parseMessageAttribute name- return (parsedName, value)+ name <- force "Missing Name" $ cursor $/ Cu.laxElement "Name" &/ Cu.content+ value <- force "Missing Value" $ cursor $/ Cu.laxElement "Value" &/ Cu.content+ parsedName <- parseMessageAttribute name+ return (parsedName, value) -readMessage :: Cu.Cursor -> [Message]+readUserMessageAttribute+ :: Cu.Cursor+ -> Response SqsMetadata UserMessageAttribute+readUserMessageAttribute cursor = (,)+ <$> force "Missing Name" (cursor $/ Cu.laxElement "Name" &/ Cu.content)+ <*> readUserMessageAttributeValue cursor++readUserMessageAttributeValue+ :: Cu.Cursor+ -> Response SqsMetadata UserMessageAttributeValue+readUserMessageAttributeValue cursor = do+ typStr <- force "Missing DataType"+ $ cursor $// Cu.laxElement "DataType" &/ Cu.content+ case parseType typStr of+ ("String", c) -> do+ val <- force "Missing StringValue"+ $ cursor $// Cu.laxElement "StringValue" &/ Cu.content+ return $ UserMessageAttributeString c val++ ("Number", c) -> do+ valStr <- force "Missing StringValue"+ $ cursor $// Cu.laxElement "StringValue" &/ Cu.content+ val <- tryXml . readEither $ T.unpack valStr+ return $ UserMessageAttributeNumber c val++ ("Binary", c) -> do+ val64 <- force "Missing BinaryValue"+ $ cursor $// Cu.laxElement "BinaryValue" &/ Cu.content+ val <- tryXml . B64.decode $ TE.encodeUtf8 val64+ return $ UserMessageAttributeBinary c val++ (x, _) -> throwM . XmlException+ $ "unknown data type for MessageAttributeValue: " <> T.unpack x+ where+ parseType s = case T.break (== '.') s of+ (a, "") -> (a, Nothing)+ (a, x) -> (a, Just (T.tail x))+ tryXml = either (throwM . XmlException) return++readMessage :: Cu.Cursor -> Response SqsMetadata 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 :: [(MessageAttribute, T.Text)] = concat $ cursor $// Cu.laxElement "Attribute" &| readMessageAttribute+ mid <- force "Missing Message Id"+ $ cursor $// Cu.laxElement "MessageId" &/ Cu.content+ rh <- force "Missing Receipt 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+ attributes <- sequence+ $ cursor $// Cu.laxElement "Attribute" &| readMessageAttribute+ userAttributes <- sequence+ $ cursor $// Cu.laxElement "MessageAttribute" &| readUserMessageAttribute+ let md5OfMessageAttributes = listToMaybe+ $ cursor $// Cu.laxElement "MD5OfMessageAttributes" &/ Cu.content - return Message{ mMessageId = mid, mReceiptHandle = ReceiptHandle rh, mMD5OfBody = md5, mBody = body, mAttributes = attributes}+ return Message+ { mMessageId = mid+ , mReceiptHandle = ReceiptHandle rh+ , mMD5OfBody = md5+ , mBody = body+ , mAttributes = attributes+ , mMD5OfMessageAttributes = md5OfMessageAttributes+ , mUserMessageAttributes = userAttributes+ } -formatMAttributes :: [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 $ printMessageAttribute x) ) attrs [1 :: Integer ..]+formatMAttributes :: [MessageAttribute] -> HTTP.Query+formatMAttributes attrs = case attrs of+ [attr] -> [("AttributeName", encodeAttr attr)]+ _ -> zipWith f [1 :: Int ..] attrs+ where+ f x y = ("AttributeName." <> B.pack (show x), encodeAttr y)+ encodeAttr = Just . TE.encodeUtf8 . printMessageAttribute +formatUserMessageAttributes :: [UserMessageAttributeName] -> HTTP.Query+formatUserMessageAttributes attrs = case attrs of+ [attr] -> [("MessageAttributeName", encodeAttr attr)]+ _ -> zipWith f [1 :: Int ..] attrs+ where+ f x y = ("MessageAttributeName." <> B.pack (show x), encodeAttr y)+ encodeAttr = Just . TE.encodeUtf8+ instance ResponseConsumer r ReceiveMessageResponse where type ResponseMetadata ReceiveMessageResponse = SqsMetadata- responseConsumer _ = sqsXmlResponseConsumer parse+ responseConsumer _ _ = sqsXmlResponseConsumer parse where parse el = do- let messages = concat $ el $// Cu.laxElement "Message" &| readMessage- return ReceiveMessageResponse{ rmrMessages = messages }+ result <- force "Missing ReceiveMessageResult"+ $ el $// Cu.laxElement "ReceiveMessageResult"+ messages <- sequence+ $ result $// Cu.laxElement "Message" &| readMessage+ return ReceiveMessageResponse{ rmrMessages = messages } --- | ServiceConfiguration: 'SqsConfiguration' instance SignQuery ReceiveMessage where type ServiceConfiguration ReceiveMessage = SqsConfiguration- 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}+ 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++ , ("WaitTimeSeconds",) <$> case rmWaitTimeSeconds of+ Just x -> Just $ Just $ B.pack $ show x+ Nothing -> Nothing+ ]+ <> formatMAttributes rmAttributes+ <> formatUserMessageAttributes rmUserMessageAttributes+ }+ instance Transaction ReceiveMessage ReceiveMessageResponse instance AsMemoryResponse ReceiveMessageResponse where type MemoryResponse ReceiveMessageResponse = ReceiveMessageResponse loadToMemory = return -data ChangeMessageVisibility = ChangeMessageVisibility {- cmvReceiptHandle :: ReceiptHandle,- cmvVisibilityTimeout :: Int,- cmvQueueName :: QueueName-}deriving (Show)+-- -------------------------------------------------------------------------- --+-- Change Message Visibility -data ChangeMessageVisibilityResponse = ChangeMessageVisibilityResponse{-} deriving (Show)+-- | Changes the visibility timeout of a specified message in a queue to a new+-- value. The maximum allowed timeout value you can set the value to is 12+-- hours. This means you can't extend the timeout of a message in an existing+-- queue to more than a total visibility timeout of 12 hours. (For more+-- information visibility timeout, see Visibility Timeout in the Amazon SQS+-- Developer Guide.)+--+-- For example, let's say you have a message and its default message visibility+-- timeout is 30 minutes. You could call ChangeMessageVisiblity with a value of+-- two hours and the effective timeout would be two hours and 30 minutes. When+-- that time comes near you could again extend the time out by calling+-- ChangeMessageVisiblity, but this time the maximum allowed timeout would be 9+-- hours and 30 minutes.+--+-- /NOTE/+--+-- There is a 120,000 limit for the number of inflight messages per queue.+-- Messages are inflight after they have been received from the queue by a+-- consuming component, but have not yet been deleted from the queue. If you+-- reach the 120,000 limit, you will receive an OverLimit error message from+-- Amazon SQS. To help avoid reaching the limit, you should delete the messages+-- from the queue after they have been processed. You can also increase the+-- number of queues you use to process the messages.+--+-- /IMPORTANT/+--+-- If you attempt to set the VisibilityTimeout to an amount more than the+-- maximum time left, Amazon SQS returns an error. It will not automatically+-- recalculate and increase the timeout to the maximum time remaining.+--+-- /IMPORTANT/+--+-- Unlike with a queue, when you change the visibility timeout for a specific+-- message, that timeout value is applied immediately but is not saved in+-- memory for that message. If you don't delete a message after it is received,+-- the visibility timeout for the message the next time it is received reverts+-- to the original timeout value, not the value you set with the+-- ChangeMessageVisibility action.+--+-- <http://docs.aws.amazon.com/AWSSimpleQueueService/2012-11-05/APIReference/API_ChangeMessageVisibility.html>+--+data ChangeMessageVisibility = ChangeMessageVisibility+ { cmvReceiptHandle :: !ReceiptHandle+ -- ^ The receipt handle associated with the message whose visibility timeout+ -- should be changed. This parameter is returned by the ReceiveMessage+ -- action. + , cmvVisibilityTimeout :: !Int+ -- ^ The new value (in seconds - from 0 to 43200 - maximum 12 hours) for the+ -- message's visibility timeout.++ , cmvQueueName :: !QueueName+ -- ^ The URL of the Amazon SQS queue to take action on.+ }+ deriving (Show, Read, Eq, Ord)++data ChangeMessageVisibilityResponse = ChangeMessageVisibilityResponse {}+ deriving (Show, Read, Eq, Ord)+ instance ResponseConsumer r ChangeMessageVisibilityResponse where type ResponseMetadata ChangeMessageVisibilityResponse = SqsMetadata- responseConsumer _ = sqsXmlResponseConsumer parse- where - parse _ = do return ChangeMessageVisibilityResponse{}- + responseConsumer _ _ = sqsXmlResponseConsumer parse+ where+ parse _ = return ChangeMessageVisibilityResponse {}+ -- | ServiceConfiguration: 'SqsConfiguration'-instance SignQuery ChangeMessageVisibility where +instance SignQuery ChangeMessageVisibility where type ServiceConfiguration ChangeMessageVisibility = SqsConfiguration- signQuery ChangeMessageVisibility {..} = sqsSignQuery SqsQuery { - sqsQueueName = Just cmvQueueName, - sqsQuery = [("Action", Just "ChangeMessageVisibility"), - ("ReceiptHandle", Just $ TE.encodeUtf8 $ printReceiptHandle cmvReceiptHandle),- ("VisibilityTimeout", Just $ B.pack $ show cmvVisibilityTimeout)]}+ signQuery ChangeMessageVisibility {..} = sqsSignQuery SqsQuery+ { sqsQueueName = Just cmvQueueName+ , sqsQuery =+ [ ("Action", Just "ChangeMessageVisibility")+ , ("ReceiptHandle", Just . TE.encodeUtf8 $ printReceiptHandle cmvReceiptHandle)+ , ("VisibilityTimeout", Just . B.pack $ show cmvVisibilityTimeout)+ ]+ } instance Transaction ChangeMessageVisibility ChangeMessageVisibilityResponse
Aws/Sqs/Commands/Permission.hs view
@@ -25,7 +25,7 @@ instance ResponseConsumer r AddPermissionResponse where type ResponseMetadata AddPermissionResponse = SqsMetadata- responseConsumer _ = sqsXmlResponseConsumer parse+ responseConsumer _ _ = sqsXmlResponseConsumer parse where parse _ = do return AddPermissionResponse {}@@ -55,7 +55,7 @@ instance ResponseConsumer r RemovePermissionResponse where type ResponseMetadata RemovePermissionResponse = SqsMetadata- responseConsumer _ = sqsXmlResponseConsumer parse+ responseConsumer _ _ = sqsXmlResponseConsumer parse where parse _ = do return RemovePermissionResponse {}
Aws/Sqs/Commands/Queue.hs view
@@ -5,6 +5,7 @@ import Aws.Sqs.Core import Control.Applicative import Data.Maybe+import Prelude import Text.XML.Cursor (($//), (&/)) import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -23,7 +24,7 @@ instance ResponseConsumer r CreateQueueResponse where type ResponseMetadata CreateQueueResponse = SqsMetadata- responseConsumer _ = sqsXmlResponseConsumer parse+ responseConsumer _ _ = sqsXmlResponseConsumer parse where parse el = do url <- force "Missing Queue Url" $ el $// Cu.laxElement "QueueUrl" &/ Cu.content@@ -55,7 +56,7 @@ instance ResponseConsumer r DeleteQueueResponse where type ResponseMetadata DeleteQueueResponse = SqsMetadata- responseConsumer _ = sqsXmlResponseConsumer parse+ responseConsumer _ _ = sqsXmlResponseConsumer parse where parse _ = do return DeleteQueueResponse{} @@ -82,7 +83,7 @@ instance ResponseConsumer r ListQueuesResponse where type ResponseMetadata ListQueuesResponse = SqsMetadata- responseConsumer _ = sqsXmlResponseConsumer parse+ responseConsumer _ _ = sqsXmlResponseConsumer parse where parse el = do let queues = el $// Cu.laxElement "QueueUrl" &/ Cu.content
Aws/Sqs/Commands/QueueAttributes.hs view
@@ -27,7 +27,7 @@ instance ResponseConsumer r GetQueueAttributesResponse where type ResponseMetadata GetQueueAttributesResponse = SqsMetadata- responseConsumer _ = sqsXmlResponseConsumer parse+ responseConsumer _ _ = sqsXmlResponseConsumer parse where parse el = do let attributes = concat $ el $// Cu.laxElement "Attribute" &| parseAttributes@@ -64,7 +64,7 @@ instance ResponseConsumer r SetQueueAttributesResponse where type ResponseMetadata SetQueueAttributesResponse = SqsMetadata- responseConsumer _ = sqsXmlResponseConsumer parse+ responseConsumer _ _ = sqsXmlResponseConsumer parse where parse _ = do return SetQueueAttributesResponse {}
Aws/Sqs/Core.hs view
@@ -1,31 +1,35 @@+{-# LANGUAGE CPP #-} module Aws.Sqs.Core where import Aws.Core-import Aws.S3.Core (LocationConstraint, locationUsClassic, locationUsWest, locationApSouthEast, locationApNorthEast, locationEu)+import Aws.S3.Core (LocationConstraint, locationUsClassic, locationUsWest, locationUsWest2, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationEu, locationEuWest2) import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char8 as Blaze8 import qualified Control.Exception as C-import qualified Control.Failure as F import Control.Monad import Control.Monad.IO.Class-import Data.Attempt (Attempt(..))+import Control.Monad.Trans.Resource (MonadThrow, throwM) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC-import Data.Conduit (($$+-))-import qualified Data.Conduit as C+import qualified Data.Conduit+import Data.Conduit ((.|)) import Data.IORef import Data.List import Data.Maybe import Data.Monoid+import qualified Data.Semigroup as Sem import Data.Ord import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as TE import Data.Time import Data.Typeable+import Prelude import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Types as HTTP+#if !MIN_VERSION_time(1,5,0) import System.Locale+#endif import qualified Text.XML as XML import Text.XML.Cursor (($/)) import qualified Text.XML.Cursor as Cu@@ -62,9 +66,12 @@ ", x-amz-id-2=" `mappend` fromMaybe "<none>" id2 +instance Sem.Semigroup SqsMetadata where+ SqsMetadata a1 r1 <> SqsMetadata a2 r2 = SqsMetadata (a1 `mplus` a2) (r1 `mplus` r2)+ instance Monoid SqsMetadata where mempty = SqsMetadata Nothing Nothing- SqsMetadata a1 r1 `mappend` SqsMetadata a2 r2 = SqsMetadata (a1 `mplus` a2) (r1 `mplus` r2)+ mappend = (Sem.<>) data SqsAuthorization = SqsAuthorizationHeader @@ -117,6 +124,14 @@ , endpointAllowedLocationConstraints = [locationUsWest] } +sqsEndpointUsWest2 :: Endpoint+sqsEndpointUsWest2+ = Endpoint {+ endpointHost = "us-west-2.queue.amazonaws.com"+ , endpointDefaultLocationConstraint = locationUsWest2+ , endpointAllowedLocationConstraints = [locationUsWest2]+ }+ sqsEndpointEu :: Endpoint sqsEndpointEu = Endpoint {@@ -125,6 +140,14 @@ , endpointAllowedLocationConstraints = [locationEu] } +sqsEndpointEuWest2 :: Endpoint+sqsEndpointEuWest2+ = Endpoint {+ endpointHost = "eu-west-2.queue.amazonaws.com"+ , endpointDefaultLocationConstraint = locationEuWest2+ , endpointAllowedLocationConstraints = [locationEuWest2]+ }+ sqsEndpointApSouthEast :: Endpoint sqsEndpointApSouthEast = Endpoint {@@ -133,6 +156,14 @@ , endpointAllowedLocationConstraints = [locationApSouthEast] } +sqsEndpointApSouthEast2 :: Endpoint+sqsEndpointApSouthEast2+ = Endpoint {+ endpointHost = "sqs.ap-southeast-2.amazonaws.com"+ , endpointDefaultLocationConstraint = locationApSouthEast2+ , endpointAllowedLocationConstraints = [locationApSouthEast2]+ }+ sqsEndpointApNorthEast :: Endpoint sqsEndpointApNorthEast = Endpoint {@@ -182,10 +213,9 @@ 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"))+ ("SignatureMethod", Just("HmacSHA256")), ("SignatureVersion",Just("2")), ("Version",Just("2012-11-05"))] +++ maybe [] (\tok -> [("SecurityToken", Just tok)]) (iamToken signatureCredentials)) - ])- expires = AbsoluteExpires $ sqsDefaultExpiry `addUTCTime` signatureTime expiresString = formatTime defaultTimeLocale "%FT%TZ" (fromAbsoluteTimeInfo expires)@@ -223,13 +253,13 @@ sqsErrorResponseConsumer :: HTTPResponseConsumer a sqsErrorResponseConsumer resp- = do doc <- HTTP.responseBody resp $$+- XML.sinkDoc XML.def+ = do doc <- Data.Conduit.runConduit $ HTTP.responseBody resp .| XML.sinkDoc XML.def let cursor = Cu.fromDocument doc liftIO $ case parseError cursor of- Success err -> C.monadThrow err- Failure otherErr -> C.monadThrow otherErr+ Right err -> throwM err+ Left otherErr -> throwM otherErr where- parseError :: Cu.Cursor -> Attempt SqsError+ parseError :: Cu.Cursor -> Either C.SomeException 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"@@ -248,7 +278,7 @@ data QueueName = QueueName{ qName :: T.Text, qAccountNumber :: T.Text-} deriving(Show)+} deriving(Show, Read, Eq, Ord) printQueueName :: QueueName -> T.Text printQueueName queue = T.concat ["/", (qAccountNumber queue), "/", (qName queue), "/"]@@ -268,11 +298,18 @@ data MessageAttribute = MessageAll+ -- ^ all values | SenderId+ -- ^ the AWS account number (or the IP address, if anonymous access is+ -- allowed) of the sender | SentTimestamp+ -- ^ the time when the message was sent (epoch time in milliseconds) | ApproximateReceiveCount+ -- ^ the number of times a message has been received but not deleted | ApproximateFirstReceiveTimestamp- deriving(Show,Eq,Enum)+ -- ^ the time when the message was first received (epoch time in+ -- milliseconds)+ deriving(Show,Read,Eq,Ord,Enum,Bounded) data SqsPermission = PermissionAll@@ -283,7 +320,7 @@ | PermissionGetQueueAttributes deriving (Show, Enum, Eq) -parseQueueAttribute :: F.Failure XmlException m => T.Text -> m QueueAttribute+parseQueueAttribute :: MonadThrow m => T.Text -> m QueueAttribute parseQueueAttribute "ApproximateNumberOfMessages" = return ApproximateNumberOfMessages parseQueueAttribute "ApproximateNumberOfMessagesNotVisible" = return ApproximateNumberOfMessagesNotVisible parseQueueAttribute "VisibilityTimeout" = return VisibilityTimeout@@ -293,7 +330,7 @@ parseQueueAttribute "MaximumMessageSize" = return MaximumMessageSize parseQueueAttribute "MessageRetentionPeriod" = return MessageRetentionPeriod parseQueueAttribute "QueueArn" = return QueueArn-parseQueueAttribute x = F.failure $ XmlException ( "Invalid Attribute Name. " ++ show x)+parseQueueAttribute x = throwM $ XmlException ( "Invalid Attribute Name. " ++ show x) printQueueAttribute :: QueueAttribute -> T.Text printQueueAttribute QueueAll = "All"@@ -307,12 +344,12 @@ printQueueAttribute MessageRetentionPeriod = "MessageRetentionPeriod" printQueueAttribute QueueArn = "QueueArn" -parseMessageAttribute :: F.Failure XmlException m => T.Text -> m MessageAttribute+parseMessageAttribute :: MonadThrow 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)+parseMessageAttribute x = throwM $ XmlException ( "Invalid Attribute Name. " ++ show x) printMessageAttribute :: MessageAttribute -> T.Text printMessageAttribute MessageAll = "All"@@ -329,8 +366,8 @@ printPermission PermissionChangeMessageVisibility = "ChangeMessageVisibility" printPermission PermissionGetQueueAttributes = "GetQueueAttributes" -newtype ReceiptHandle = ReceiptHandle T.Text deriving(Show,Eq)-newtype MessageId = MessageId T.Text deriving(Show,Eq)+newtype ReceiptHandle = ReceiptHandle T.Text deriving(Show, Read, Eq, Ord)+newtype MessageId = MessageId T.Text deriving(Show, Read, Eq, Ord) printReceiptHandle :: ReceiptHandle -> T.Text printReceiptHandle (ReceiptHandle handle) = handle
+ CHANGELOG.md view
@@ -0,0 +1,429 @@+0.25 series+-----------++NOTES: 0.25 brings technically breaking changes, which should not affect+most users. I recommend using smart constructors and {} matching syntax+whenever possible when interacting with aws types.++- 0.25.3+ - Switch from memory to ram to allow building with http-client-tls 0.4.x+- 0.25.2+ - S3: Add RestoreObject command+- 0.25.1+ - S3: Make getBucket support Google Object Storage, which does+ not include StorageClass in its response, by defaulting to Standard.+- 0.25+ - [breaking change] Added poTagging constructor to PutObject+ - Switch from no longer maintained cryptonite to crypton.+ - Removed support for building with network-2.x, and removed the+ NetworkBSD build flag.+++0.24 series+-----------++NOTES: 0.24 brings technically breaking changes, which should not affect+most users. I recommend using smart constructors and {} matching syntax+whenever possible when interacting with aws types.++- 0.24.4+ - Support filepath 1.5+ - Support data-default 0.8+- 0.24.3+ - [breaking change] Added s3UserAgent constructor to S3Configuration+ - S3: Add GetBucketVersioning command+- 0.24.2+ - Support bytestring 0.12+ - Support building with aeson 2.2, adding dependency on+ attoparsec-json.+- 0.24.1+ - Support resourcet 1.3+ - Support transformers 0.6+- 0.24+ - [breaking change] Added s3Region constructor to S3Configuration, to+ support custom S3 regions.+ - Fixed several build warnings.+ - Needs base-4.9 or newer.++0.23 series+-----------++NOTES: 0.23 brings technically breaking changes, which should not affect+most users. I recommend using smart constructors and {} matching syntax+whenever possible when interacting with aws types.++- 0.23+ - Support anonymous access of S3 buckets.+ - [breaking change] added isAnonymousCredentials to Credentials.+ - Support bytestring 0.11++0.22 series+-----------++- 0.22.1+ - Update to aeson-2+ - Support http-client 0.7+ - Support base64-bytestring 1.2+ - Support attoparsec 0.14+ - Support base16-bytestring 1.0+- 0.22+ - Support GHC 8.8+ - Support network-3+ - Support http-client 0.6++ - S3: add etag to PutObjectResponse+ - Add IAM group manipulation methods++0.21 series+-----------++- 0.21.1+ - S3: Add PutBucketVersioning command++- 0.21+ - S3: Make user DisplayName field optional (used in "GetBucket"+ among other places)+ - Use HTTP.getGlobalManager from http-client-tls by default (more+ efficient, and we have a transitive dependency on the package+ anyways)++0.20 series+-----------++- 0.20+ - Update to conduit 1.3 and http-conduit 2.3 (breaking API change+ due to removal of ResumableSource, which was used in public APIs)+ - S3: Fix to V2 string signing++0.19 series+-----------++- 0.19+ - Experimental support for V4 signing+ - Add "eu-west-2" endpoint for some services+ - Loosen http-conduit bounds++0.18 series+-----------++- 0.18+ - Switch from cryptohash to cryptonite+ - Loosen boundaries for http-types and conduit-extra++0.17 series+-----------++- 0.17.1+ - Fix testsuite build++- 0.17+ - HTTP proxy support+ - DDB: Support for additional interfaces, bug fixes+ - Relax version bounds++0.16 series+-----------++NOTES: 0.16 brings technically breaking changes, which should not affect+most users. I recommend using smart constructors and {} matching syntax+whenever possible when interacting with aws types.++- 0.16+ - S3: Add support for versioning+ - S3: [breaking change] Move version ID from UploadPartResponse to+ CompleteMultipartUpload.++0.15 series+-----------++NOTES: 0.15 brings technically breaking changes, but should not affect+most users.++- 0.15.1+ - Support xml-conduit 1.4++- 0.15+ - Drop support for time <1.5+ - Support http-client 2.2+ - Support directory 1.3+ - Add upper bound on http-client in testsuite+ - DynamoDB: Eliminate orphan instance that conflicted with aeson-1.0+ - S3: Don't URI encode response header override query params when signing+ - Use HTTP.newManager instead of deprecated HTTP.withManager+ - Signing: Change date format from space-padding to zero-padding++0.14 series+-----------++NOTES: 0.14 brings potentially breaking changes++- 0.14+ - transformers 0.5 support+ - data-default 0.6 support (also in 0.13.1)+ - time < 2.0 support+ - General: Use `AWS_SESSION_TOKEN` if in environment for loading credentials+ - General: loadCredentialsDefault fails gracefully if HOME is not set+ - DDB: Add parseAttr combinator for parsing an attribute into a FromDynItem+ - DDB: Expose the new DynBool type+ - S3: Add ETag fields to get/head object++0.13 series+-----------++NOTE: 0.13 brings breaking changes compared to 0.12.1!++- 0.13.1+ - data-default 0.6 support+- 0.13+ - DDB: Add support for scanning an index+ - DDB: Allow deleting an attribute on update+ - DDB: !BREAKING! Add support for native boolean values+ via "Bool". Can read old values, and there's a compatibility+ wrapper OldBool that behaves exactly the same way it used to.+ - DDB: Add support for Null, L (list) and M (map) data types.+ - DDB: Support consistent reads in Scan requests+ - IAM: Add list-mfa-devices command+ - S3: Extend StorageClass to support arbitrary classes, and+ StandardInfrequentAccess+ - S3: Add a Sink interface for multipart uploading+ - S3: Performance improvement for chunkedConduit+ - S3: Partial support for Google Nearline++0.12 series+-----------++- 0.12.1+ - DDB: Fix eu-west-1, add eu-central-1+ - attoparsec 0.13+ - xml-conduit 1.3+- 0.12+ - S3: Support for "Expect: 100-continue" (optional, technically+ API breaking)+ - S3: Properly treat errors with a "301 Permanent Redirect" as+ errors and expose endpoint information++0.11 series+-----------++- 0.11.4+ - Url-encode S3 object names in URLs+ - filepath 1.4+ - tagged 0.8.x+ - limit errors to <2 to avoid compatibility problems+- 0.11.3+ - Support for blaze-builder 0.4+ - Support for utf8-string 1.0+ - New function: multipartUploadWithInitiator+ - Fix issue in DynamoDB error parsing+ - Ord instance for Aws.Core.Method+- 0.11.2+ - Support for time 1.5 (we previously forgot to relax the upper+ bound in Cabal)+- 0.11.1+ - Support time 1.5+ - Fix duplicate sending of query when using PostQuery+- 0.11+ - New functions for running AWS transactions+ - Performance optimizations for DynamoDB and S3 MultiPartUpload+ - New DynamoDB commands & features+ - S3 endpoint eu-central-1++0.10 series+-----------++- 0.10.5+ - support for conduit 1.2+- 0.10.4+ - S3: support for multi-part uploads+ - DynamoDB: fixes for JSON serialization WARNING: This includes+ making some fields in TableDescription Maybe fields, which+ is breaking. But DynamoDB support was and is also marked+ as EXPERIMENTAL.+ - DynamoDB: TCP connection reuse where possible+ (improving performance)+ - DynamoDB: Added test suite+ - SES: support for additional regions+- 0.10.3+ - fix bug introduced in 0.10.2 that broke SQS and IAM connections+ without STS+- 0.10.2+ - support STS / IAM temporary credentials in all services+- 0.10+ - \[EXPERIMENTAL!\] DynamoDB: support for+ creating/updating/querying and scanning items+ - SQS: complete overhaul to support 2012-11-05 features+ - SQS: test suite+ - S3: use Maybe for 404 HEAD requests on objects instead of+ throwing a misleading exception+ - S3: support of poAutoMakeBucket for Internet Archive users+ - S3: implement GetBucketLocation+ - S3: add South American region+ - S3: allow specifying the Content-Type when copying objects+ - core: fix typo in NoCredentialsException accessor++0.9 series+----------++- 0.9.4+ - allow conduit 1.2+- 0.9.3+ - fix performance regression for loadCredentialsDefault+ - add generic makeCredentials function+ - add S3 DeleteBucket operation+ - add S3 NukeBucket example+ - SES: use security token if enabled (should allow using it with+ IAM roles on EC2 instances)+- 0.9.2+ - Support for credentials from EC2 instance metadata (only S3+ for now)+ - aeson 0.8 compatibility+- 0.9.1+ - Support for multi-page S3 GetBucket requests+ - S3 GLACIER support+ - Applicative instance for Response to conform to the+ Applicative-Monad Proposal+ - Compatibility with transformers 0.4+- 0.9+ - Interface changes:+ - attempt and failure were deprecated, remove+ - switch to new cryptohash interface+ - updated version bounds of conduit and xml-conduit++0.8 series+----------++- 0.8.6+ - move Instance metadata functions out of ResourceT to remove+ problem with exceptions-0.5 (this makes a fresh install of aws+ on a clean system possible again)+- 0.8.5+ - compatibility with case-insensitive 1.2+ - support for V4 signatures+ - experimental support for DynamoDB+- 0.8.4+ - compatibility with http-conduit 2.0+- 0.8.3+ - compatibility with cryptohash 0.11+ - experimental IAM support+- 0.8.2+ - compatibility with cereal 0.4.x+- 0.8.1+ - compatibility with case-insensitive 1.1+- 0.8.0+ - S3, SQS: support for US-West2 (\#58)+ - S3: GetObject now has support for Content-Range (\#22, \#50)+ - S3: GetBucket now supports the "IsTruncated" flag (\#39)+ - S3: PutObject now supports web page redirects (\#46)+ - S3: support for (multi-object) DeleteObjects (\#47, \#56)+ - S3: HeadObject now uses an actual HEAD request (\#53)+ - S3: fixed signing issues for GetObject call (\#54)+ - SES: support for many more operations (\#65, \#66, \#70, \#71,+ \#72, \#74)+ - SES: SendRawEmail now correctly encodes destinations and allows+ multiple destinations (\#73)+ - EC2: support for Instance metadata (\#37)+ - Core: queryToHttpRequest allows overriding "Date" for the+ benefit of Chris Dornan's Elastic Transcoder bindings (\#77)++0.7 series+----------++- 0.7.6.4+ - CryptoHash update+- 0.7.6.3+ - In addition to supporting http-conduit 1.9, it would seem nice+ to support conduit 1.0. Previously slipped through the radar.+- 0.7.6.2+ - Support for http-conduit 1.9+- 0.7.6.1+ - Support for case-insensitive 1.0 and http-types 0.8+- 0.7.6+ - Parsing of SimpleDB error responses was too strict, fixed+ - Support for cryptohash 0.8+ - Failure 0.1 does not work with aws, stricter lower bound+- 0.7.5+ - Support for http-conduit 1.7 and 1.8+- 0.7.1-0.7.4+ - Support for GHC 7.6+ - Wider constraints to support newer versions of various+ dependencies+ - Update maintainer e-mail address and project categories in cabal+ file+- 0.7.0+ - Change ServiceConfiguration concept so as to indicate in the+ type whether this is for URI-only requests (i.e. awsUri)+ - EXPERIMENTAL: Direct support for iterated transaction, i.e. such+ where multiple HTTP requests might be necessary due to e.g.+ response size limits.+ - Put aws functions in ResourceT to be able to safely return+ Sources and streams.+ - simpleAws\* does not require ResourceT and converts streams+ into memory values (like ByteStrings) first.+ - Log response metadata (level Info), and do not let all aws+ runners return it.+ - S3:+ - GetObject: No longer require a response consumer in the+ request, return the HTTP response (with the body as+ a stream) instead.+ - Add CopyObject (PUT Object Copy) request type.+ - Add Examples cabal flag for building code examples.+ - Many more, small improvements.++0.6 series+----------++- 0.6.2+ - Properly parse Last-Modified header in accordance with RFC 2616.+- 0.6.1+ - Fix for MD5 encoding issue in S3 PutObject requests.+- 0.6.0+ - API Cleanup+ - General: Use Crypto.Hash.MD5.MD5 when a Content-MD5 hash is+ required, instead of ByteString.+ - S3: Made parameter order to S3.putObject consistent+ with S3.getObject.+ - Updated dependencies:+ - conduit 0.5 (as well as http-conduit 1.5 and+ xml-conduit 1.0).+ - http-types 0.7.+ - Minor changes.+ - Internal changes (notable for people who want to add more+ commands):+ - http-types' new 'QueryLike' interface allows creating query+ lists more conveniently.++0.5 series+----------++0.5.0++: New configuration system: configuration split into general and+ service-specific parts.++ Significantly improved API reference documentation.++ Re-organised modules to make library easier to understand.++ Smaller improvements.++0.4 series+----------++0.4.1+: Documentation improvements.++0.4.0.1+: Change dependency bounds to allow the transformers 0.3 package.++0.4.0+: Update conduit to 0.4.0, which is incompatible with+ earlier versions.++0.3 series+----------++0.3.2+: Add awsRef / simpleAwsRef request variants for those who prefer an+ `IORef` over a `Data.Attempt.Attempt` value. Also improve README and+ add simple example.++
+ Examples/DynamoDb.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++module Main where++-------------------------------------------------------------------------------+import Aws+import Aws.DynamoDb.Commands+import Aws.DynamoDb.Core+import Control.Concurrent+import Control.Monad+import Control.Monad.Catch+import Control.Monad.Trans.Resource+import Control.Applicative+import Data.Conduit+import Data.Maybe+import qualified Data.Conduit.List as C+import qualified Data.Text as T+import Network.HTTP.Conduit (newManager, tlsManagerSettings)+-------------------------------------------------------------------------------++createTableAndWait :: IO ()+createTableAndWait = do+ let req0 = createTable "devel-1"+ [AttributeDefinition "name" AttrString]+ (HashOnly "name")+ (ProvisionedThroughput 1 1)+ resp0 <- runCommand req0+ print resp0++ print "Waiting for table to be created"+ threadDelay (30 * 1000000)++ let req1 = DescribeTable "devel-1"+ resp1 <- runCommand req1+ print resp1++data ExampleItem = ExampleItem {+ name :: T.Text+ , class_ :: T.Text+ , boolAttr :: Bool+ , oldBoolAttr :: Bool+ }+ deriving (Show)++instance ToDynItem ExampleItem where+ toItem (ExampleItem name class_ boolAttr oldBoolAttr) =+ item [ attr "name" name+ , attr "class" class_+ , attr "boolattr" boolAttr+ , attr "oldboolattr" (OldBool oldBoolAttr)+ ]++instance FromDynItem ExampleItem where+ parseItem x = ExampleItem <$> getAttr "name" x <*> getAttr "class" x <*> getAttr "boolattr" x <*> getAttr "oldboolattr" x++main :: IO ()+main = do+ cfg <- Aws.baseConfiguration++ createTableAndWait `catch` (\DdbError{} -> putStrLn "Table already exists")++ putStrLn "Putting an item..."++ let x = ExampleItem { name = "josh", class_ = "not-so-awesome",+ boolAttr = False, oldBoolAttr = True }++ let req1 = (putItem "devel-1" (toItem x)) { piReturn = URAllOld+ , piRetCons = RCTotal+ , piRetMet = RICMSize+ }+++ resp1 <- runCommand req1+ print resp1++ putStrLn "Getting the item back..."++ let req2 = getItem "devel-1" (hk "name" "josh")+ resp2 <- runCommand req2+ print resp2++ let y = fromItem (fromMaybe (item []) $ girItem resp2) :: Either String ExampleItem+ print y++ print =<< runCommand+ (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesome")])++ echo "Updating with false conditional."+ (print =<< runCommand+ (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesomer")])+ { uiExpect = Conditions CondAnd [Condition "name" (DEq "john")] })+ `catch` (\ (e :: DdbError) -> echo ("Eating exception: " ++ show e))++ echo "Getting the item back..."+ print =<< runCommand req2+++ echo "Updating with true conditional"+ print =<< runCommand+ (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesomer"), au (attr "oldboolattr" False)])+ { uiExpect = Conditions CondAnd [Condition "name" (DEq "josh")] }++ echo "Getting the item back..."+ print =<< runCommand req2++ echo "Running a Query command..."+ print =<< runCommand (query "devel-1" (Slice (Attribute "name" "josh") Nothing))++ echo "Running a Scan command..."+ print =<< runCommand (scan "devel-1")++ echo "Filling table with several items..."+ forM_ [0..30] $ \ i -> do+ threadDelay 50000+ runCommand $ putItem "devel-1" $+ item [Attribute "name" (toValue $ T.pack ("lots-" ++ show i)), attrAs int "val" i]++ echo "Now paginating in increments of 5..."+ let q0 = (scan "devel-1") { sLimit = Just 5 }++ mgr <- newManager tlsManagerSettings+ xs <- runResourceT $ awsIteratedList cfg debugServiceConfig mgr q0 `connect` C.consume+ echo ("Pagination returned " ++ show (length xs) ++ " items")+++runCommand r = do+ cfg <- Aws.baseConfiguration+ Aws.simpleAws cfg debugServiceConfig r++echo = putStrLn++
Examples/GetObject.hs view
@@ -2,9 +2,10 @@ import qualified Aws import qualified Aws.S3 as S3-import Data.Conduit (($$+-))+import Control.Monad.Trans.Resource+import Data.Conduit ((.|), runConduit) import Data.Conduit.Binary (sinkFile)-import Network.HTTP.Conduit (withManager, responseBody)+import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody) main :: IO () main = do@@ -13,11 +14,12 @@ let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery {- Set up a ResourceT region with an available HTTP manager. -}- withManager $ \mgr -> do+ mgr <- newManager tlsManagerSettings+ runResourceT $ do {- Create a request object with S3.getObject and run the request with pureAws. -} S3.GetObjectResponse { S3.gorResponse = rsp } <- Aws.pureAws cfg s3cfg mgr $ S3.getObject "haskell-aws" "cloud-remote.pdf" {- Save the response to a file. -}- responseBody rsp $$+- sinkFile "cloud-remote.pdf"+ runConduit $ responseBody rsp .| sinkFile "cloud-remote.pdf"
+ Examples/GetObjectGoogle.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++import qualified Aws+import qualified Aws.Core as Aws+import qualified Aws.S3 as S3+import Control.Monad.Trans.Resource+import Data.Conduit ((.|), runConduit)+import Data.Conduit.Binary (sinkFile)+import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)++main :: IO ()+main = do+ Just creds <- Aws.loadCredentialsFromEnv+ let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing+ let s3cfg = S3.s3 Aws.HTTP "storage.googleapis.com" False+ {- Set up a ResourceT region with an available HTTP manager. -}+ mgr <- newManager tlsManagerSettings+ runResourceT $ do+ {- Create a request object with S3.getObject and run the request with pureAws. -}+ S3.GetObjectResponse { S3.gorResponse = rsp } <-+ Aws.pureAws cfg s3cfg mgr $+ {- Public bucket from GCP examples -}+ S3.getObject "uspto-pair" "applications/05900016.zip"++ {- Save the response to a file. -}+ runConduit $ responseBody rsp .| sinkFile "getobject-test.zip"
+ Examples/GetObjectV4.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++import qualified Aws+import qualified Aws.Core as Aws+import qualified Aws.S3 as S3+import Control.Monad.Trans.Resource+import Data.Conduit ((.|), runConduit)+import Data.Conduit.Binary (sinkFile)+import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)++main :: IO ()+main = do+ {- Set up AWS credentials and the default configuration. -}+ Just creds <- Aws.loadCredentialsDefault+ let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing+ let s3cfg = S3.s3v4 Aws.HTTP "s3.amazonaws.com" False S3.SignWithEffort++ {- Set up a ResourceT region with an available HTTP manager. -}+ mgr <- newManager tlsManagerSettings+ runResourceT $ do+ {- Create a request object with S3.getObject and run the request with pureAws. -}+ S3.GetObjectResponse { S3.gorResponse = rsp } <-+ Aws.pureAws cfg s3cfg mgr $+ S3.getObject "haskell-aws" "cloud-remote.pdf"++ {- Save the response to a file. -}+ runConduit $ responseBody rsp .| sinkFile "cloud-remote.pdf"
+ Examples/MultipartTransfer.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++{- This example demonstrates an ability to stream in constant space content from a remote resource into an S3 object accessible publicly -}+++import qualified Aws+import Aws.Aws (Configuration (..))+import qualified Aws.S3 as S3+import Control.Applicative ((<$>))+import Control.Monad.Trans.Resource+import qualified Data.Text as T+import Network.HTTP.Conduit (http, parseUrl, responseBody,+ newManager, tlsManagerSettings)+import System.Environment (getArgs)++main :: IO ()+main = do+ maybeCreds <- Aws.loadCredentialsFromEnv+ case maybeCreds of+ Nothing -> do+ putStrLn "Please set the environment variables AWS_ACCESS_KEY_ID and AWS_ACCESS_KEY_SECRET"+ Just creds -> do+ args <- getArgs+ cfg <- Aws.dbgConfiguration+ let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery++ case args of+ [sourceUrl,destBucket,destObj] -> do+ request <- parseUrl sourceUrl+ mgr <- newManager tlsManagerSettings+ runResourceT $ do+ source <- responseBody <$> http request mgr+ let initiator b o = (S3.postInitiateMultipartUpload b o){S3.imuAcl = Just S3.AclPublicRead}+ S3.multipartUploadWithInitiator cfg{credentials = creds} s3cfg initiator mgr (T.pack destBucket) (T.pack destObj) source (10*1024*1024)+ _ -> do+ putStrLn "Usage: MultipartTransfer sourceUrl destinationBucket destinationObjectname"+
+ Examples/MultipartUpload.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++import qualified Aws+import qualified Aws.Core as Aws+import qualified Aws.S3 as S3+import qualified Data.ByteString.Char8 as B+import Data.Conduit (connect)+import Data.Conduit.Binary (sourceFile)+import qualified Data.Text as T+import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)+import Control.Monad.Trans.Resource (runResourceT)+import System.Environment (getArgs)++main :: IO ()+main = do+ args <- getArgs+ case args of+ [endpoint, bucket, obj, file] -> doUpload endpoint bucket obj file 10+ [endpoint, bucket, obj, file, chunkSize] -> doUpload endpoint bucket obj file (read chunkSize)+ _ -> mapM_ putStrLn+ [ "Usage: MultipartUpload endpoint bucket dstobject srcfile [chunksize(MB)]"+ , "Example: MultipartUpload s3.us-east-2.amazonaws.com your-bucket tmp/test.bin test.bin"+ ]+ where+ doUpload endpoint bucket obj file chunkSize = do+ cfg <- Aws.dbgConfiguration+ let s3cfg = S3.s3v4 Aws.HTTPS (B.pack endpoint) False S3.SignWithEffort+ mgr <- newManager tlsManagerSettings+ runResourceT $+ sourceFile file `connect` S3.multipartUploadSink cfg s3cfg mgr (T.pack bucket) (T.pack obj) (chunkSize*1024*1024)
+ Examples/NukeBucket.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++import qualified Aws+import qualified Aws.S3 as S3+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import Data.Text (pack)+import Control.Monad ((<=<))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Resource+import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)+import System.Environment (getArgs)++main :: IO ()+main = do+ [bucket] <- fmap (map pack) getArgs++ {- Set up AWS credentials and the default configuration. -}+ cfg <- Aws.baseConfiguration+ let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery++ {- Set up a ResourceT region with an available HTTP manager. -}+ mgr <- newManager tlsManagerSettings+ runResourceT $ do+ let src = Aws.awsIteratedSource cfg s3cfg mgr (S3.getBucket bucket)+ let deleteObjects [] = return ()+ deleteObjects os =+ do+ let keys = map S3.objectKey os+ liftIO $ putStrLn ("Deleting objects: " ++ show keys)+ _ <- Aws.pureAws cfg s3cfg mgr (S3.deleteObjects bucket (map S3.objectKey os))+ return ()+ src `C.connect` CL.mapM_ (deleteObjects . S3.gbrContents <=< Aws.readResponseIO)+ liftIO $ putStrLn ("Deleting bucket: " ++ show bucket)+ _ <- Aws.pureAws cfg s3cfg mgr (S3.DeleteBucket bucket)+ return ()
+ Examples/PutBucketNearLine.hs view
@@ -0,0 +1,38 @@+-- | Example of creating a Nearline bucket on Google Cloud Storage.++{-# LANGUAGE OverloadedStrings #-}++import qualified Aws+import qualified Aws.Core as Aws+import qualified Aws.S3 as S3+import Data.Conduit.Binary (sinkFile)+import Control.Monad.Trans.Resource+import Network.HTTP.Conduit (newManager, tlsManagerSettings, RequestBody(..))+import Control.Monad.IO.Class+import Control.Concurrent+import System.IO+import Control.Applicative+import qualified Data.Text as T+import System.Environment++sc :: S3.StorageClass+sc = S3.OtherStorageClass (T.pack "NEARLINE")++main :: IO ()+main = do+ [bucket] <- fmap (map T.pack) getArgs++ {- Set up AWS credentials and S3 configuration using the Google Cloud+ - Storage endpoint. -}+ Just creds <- Aws.loadCredentialsFromEnv+ let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing+ let s3cfg = S3.s3 Aws.HTTP "storage.googleapis.com" False++ {- Set up a ResourceT region with an available HTTP manager. -}+ mgr <- newManager tlsManagerSettings+ runResourceT $ do+ {- Create a request object with S3.PutBucket and run the request with pureAws. -}+ rsp <-+ Aws.pureAws cfg s3cfg mgr $+ S3.PutBucket bucket Nothing "US" (Just sc)+ liftIO $ print rsp
+ Examples/Sqs.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedStrings #-}++import qualified Aws+import qualified Aws.Core+import qualified Aws.Sqs as Sqs+import Control.Concurrent+import Control.Error+import Control.Monad.IO.Class+import Data.Monoid+import Data.String+import qualified Data.Text.IO as T+import qualified Data.Text as T+import qualified Data.Text.Read as TR+import Control.Monad (forM_, forM, replicateM)++{-| Created by Tim Perry on September 18, 2013+ |+ | All code relies on a correctly configured ~/.aws-keys and will access that account which+ | may incur charges for the user!+ |+ | This code will demonstrate:+ | - Listing all queue's attached to the current AWS account.+ | - Creating a queue+ | - Adding messages to the queue+ | - Retrieving messages from the queue+ | - Deleting messages from the queue+ | and finally+ | - Deleting the queue.+ | -}+main :: IO ()+main = do+ {- Set up AWS credentials and the default configuration. -}+ cfg <- Aws.baseConfiguration+ let sqscfg = Sqs.sqs Aws.Core.HTTP Sqs.sqsEndpointUsWest2 False :: Sqs.SqsConfiguration Aws.NormalQuery++ {- List any Queues you have already created in your SQS account -}+ Sqs.ListQueuesResponse qUrls <- Aws.simpleAws cfg sqscfg $ Sqs.ListQueues Nothing+ let origQUrlCount = length qUrls+ putStrLn $ "originally had " ++ show origQUrlCount ++ " queue urls"+ mapM_ print qUrls++ {- Create a request object to create a queue and then print out the Queue URL -}+ let qName = "scaledsoftwaretest1"+ let createQReq = Sqs.CreateQueue (Just 8400) qName+ Sqs.CreateQueueResponse qUrl <- Aws.simpleAws cfg sqscfg createQReq+ T.putStrLn $ T.concat ["queue was created with Url: ", qUrl]++ {- Create a QueueName object, sqsQName, to hold the name of this queue for the duration -}+ let awsAccountNum = T.split (== '/') qUrl !! 3+ let sqsQName = Sqs.QueueName qName awsAccountNum++ {- list queue attributes -- for this example we will only list the approximateNumberOfMessages in this queue. -}+ let qAttReq = Sqs.GetQueueAttributes sqsQName [Sqs.ApproximateNumberOfMessages]+ Sqs.GetQueueAttributesResponse attPairs <- Aws.simpleAws cfg sqscfg qAttReq+ mapM_ (\(attName, attText) -> T.putStrLn $ T.concat [" ", Sqs.printQueueAttribute attName, " ", attText]) attPairs++ {- Here we add some messages to the queue -}+ let messages = map (\n -> T.pack $ "msg" ++ show n) [1 .. 10]+ {- Add messages to the queue -}+ forM_ messages $ \mText -> do+ T.putStrLn $ " Adding: " <> mText+ let sqsSendMessage = Sqs.SendMessage mText sqsQName [] (Just 0)+ Sqs.SendMessageResponse _ mid _ <- Aws.simpleAws cfg sqscfg sqsSendMessage+ T.putStrLn $ " message id: " <> sshow mid++ {- Here we remove messages from the queue one at a time. -}+ let receiveMessageReq = Sqs.ReceiveMessage Nothing [] (Just 1) [] sqsQName (Just 20)+ let numMessages = length messages+ removedMsgs <- replicateM numMessages $ do+ msgs <- exceptT (const $ return []) return . retryT 2 $ do+ Sqs.ReceiveMessageResponse r <- liftIO $ Aws.simpleAws cfg sqscfg receiveMessageReq+ case r of+ [] -> throwE "no message received"+ _ -> return r+ putStrLn $ "number of messages received: " ++ show (length msgs)+ forM msgs (\msg -> do+ -- here we remove a message, delete it from the queue, and then return the+ -- text sent in the body of the message+ putStrLn $ " Received " ++ show (Sqs.mBody msg)+ Aws.simpleAws cfg sqscfg $ Sqs.DeleteMessage (Sqs.mReceiptHandle msg) sqsQName+ return $ Sqs.mBody msg)++ {- Now we'll delete the queue we created at the start of this program -}+ putStrLn $ "Deleting the queue: " ++ show (Sqs.qName sqsQName)+ let dQReq = Sqs.DeleteQueue sqsQName+ _ <- Aws.simpleAws cfg sqscfg dQReq++ {- | Let's make sure the queue was actually deleted and that the same number of queues exist at when+ | the program ends as when it started.+ -}+ exceptT T.putStrLn T.putStrLn . retryT 4 $ do+ qUrls <- liftIO $ do+ putStrLn $ "Listing all queues to check to see if " ++ show (Sqs.qName sqsQName) ++ " is gone"+ Sqs.ListQueuesResponse qUrls_ <- Aws.simpleAws cfg sqscfg $ Sqs.ListQueues Nothing+ mapM_ T.putStrLn qUrls_+ return qUrls_++ if qUrl `elem` qUrls+ then throwE $ " *\n *\n * Warning, '" <> sshow qName <> "' was not deleted\n"+ <> " * This is probably just a race condition."+ else return $ " The queue '" <> sshow qName <> "' was correctly deleted"++retryT :: MonadIO m => Int -> ExceptT T.Text m a -> ExceptT T.Text m a+retryT i f = go 1+ where+ go x+ | x >= i = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) f+ | otherwise = f `catchE` \_ -> do+ liftIO $ threadDelay (1000000 * min 60 (2^(x-1)))+ go (succ x)++sshow :: (Show a, IsString b) => a -> b+sshow = fromString . show+
+ README.md view
@@ -0,0 +1,141 @@+Introduction+============++The `aws` package attempts to provide support for using Amazon Web+Services like S3 (storage), SQS (queuing) and others to Haskell+programmers. The ultimate goal is to support all Amazon Web Services.++Installation+============++Make sure you have a recent GHC installed, as well as cabal-install, and+installation should be as easy as:++``` {.bash}+$ cabal install aws+```++If you prefer to install from source yourself, you should first get a+clone of the `aws` repository, and install it from inside the source+directory:++``` {.bash}+$ git clone https://github.com/haskell-pkg-janitors/aws.git+$ cd aws+$ cabal install+```++Using aws+=========++Concepts and organisation+-------------------------++The aws package is organised into the general `Aws` module namespace,+and subnamespaces like `Aws.S3` for each Amazon Web Service. Under each+service namespace in turn, there are general support modules and and+`Aws.<Service>.Commands.<Command>` module for each command. For easier+usage, there are the "bundling" modules `Aws` (general support), and+`Aws.<Service>`.++The primary concept in aws is the *Transaction*, which corresponds to a+single HTTP request to the Amazon Web Services. A transaction consists+of a request and a response, which are associated together via the+`Transaction` typeclass. Requests and responses are simple Haskell+records, but for some requests there are convenience functions to fill+in default values for many parameters.++Example usage+-------------++To be able to access AWS resources, you should put your into a+configuration file. (You don't have to store it in a file, but that's+how we do it in this example.) Save the following in `$HOME/.aws-keys`.++``` {.example}+default AccessKeyID SecretKey+```++You do have to replace AccessKeyID and SecretKey with the Access Key ID+and the Secret Key respectively, of course.++Then, copy this example into a Haskell file, and run it with `runghc`+(after installing aws):++``` {.haskell}+{-# LANGUAGE OverloadedStrings #-}++import qualified Aws+import qualified Aws.S3 as S3+import Control.Monad.Trans.Resource+import Data.Conduit ((.|), runConduit)+import Data.Conduit.Binary (sinkFile)+import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)++main :: IO ()+main = do+ {- Set up AWS credentials and the default configuration. -}+ cfg <- Aws.baseConfiguration+ let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery++ {- Set up a ResourceT region with an available HTTP manager. -}+ mgr <- newManager tlsManagerSettings+ runResourceT $ do+ {- Create a request object with S3.getObject and run the request with pureAws. -}+ S3.GetObjectResponse { S3.gorResponse = rsp } <-+ Aws.pureAws cfg s3cfg mgr $+ S3.getObject "haskell-aws" "cloud-remote.pdf"++ {- Save the response to a file. -}+ runConduit $ responseBody rsp .| sinkFile "cloud-remote.pdf"+```++You can also find this example in the source distribution in the+`Examples/` folder.++Frequently Asked Questions+==========================++S3 questions+------------++- I get an error when I try to access my bucket with upper-case+ characters / a very long name.++ Those names are not compliant with DNS. You need to use path-style+ requests, by setting `s3RequestStyle` in the configuration to+ `PathStyle`. Note that such bucket names are only allowed in the US+ standard region, so your endpoint needs to be US standard.++Release Notes+=============++See CHANGELOG++Resources+=========++- [aws on Github](https://github.com/haskell-pkg-janitors/aws)+- [aws on Hackage](http://hackage.haskell.org/package/aws) (includes+ reference documentation)+- [Official Amazon Web Services website](http://aws.amazon.com/)++Contributors+============++ Name |Github |E-Mail |Company |Components+ --------------------|-------------------------------------------------|--------------------------------|-----------------------------------------------------|--------------------+ Abhinav Gupta |[abhinav](https://github.com/abhinav) |mail@abhinavg.net |- |IAM, SES+ Aristid Breitkreuz |[aristidb](https://github.com/aristidb) |aristidb@gmail.com |- |Co-Maintainer+ Bas van Dijk |[basvandijk](https://github.com/basvandijk) |v.dijk.bas@gmail.com |[Erudify AG](http://erudify.ch) |S3+ David Vollbracht |[qxjit](https://github.com/qxjit) | | |+ Felipe Lessa |[meteficha](https://github.com/meteficha) |felipe.lessa@gmail.com |currently secret |Core, S3, SES+ Nathan Howell |[NathanHowell](https://github.com/NathanHowell) |nhowell@alphaheavy.com |[Alpha Heavy Industries](http://www.alphaheavy.com) |S3+ Ozgun Ataman |[ozataman](https://github.com/ozataman) |ozgun.ataman@soostone.com |[Soostone Inc](http://soostone.com) |Core, S3, DynamoDb+ Steve Severance |[sseveran](https://github.com/sseveran) |sseverance@alphaheavy.com |[Alpha Heavy Industries](http://www.alphaheavy.com) |S3, SQS+ John Wiegley |[jwiegley](https://github.com/jwiegley) |johnw@fpcomplete.com |[FP Complete](http://fpcomplete.com) |S3+ Chris Dornan |[cdornan](https://github.com/cdornan) |chris.dornan@irisconnect.co.uk |[Iris Connect](http://irisconnect.co.uk) |Core+ John Lenz |[wuzzeb](https://github/com/wuzzeb) | | |DynamoDB, Core+ Joey Hess |[joeyh](https://github.com/joeyh) |id@joeyh.name |- |Co-Maintainer, S3++
− README.org
@@ -1,188 +0,0 @@-#+TITLE: Amazon Web Services for Haskell--* Introduction--The ~aws~ package attempts to provide support for using Amazon Web Services like S3 (storage), SQS (queuing) and others-to Haskell programmers. The ultimate goal is to support all Amazon Web Services.--(If you are viewing this README online, please note that you can find the README-for the latest stable version at https://github.com/aristidb/aws/blob/stable/README.org).--* Installation--Make sure you have a recent GHC installed, as well as cabal-install, and installation should be as easy as:--#+BEGIN_SRC bash-$ cabal install aws-#+END_SRC--If you prefer to install from source yourself, you should first get a clone of the ~aws~ repository, and install it from-inside the source directory:--#+BEGIN_SRC bash-$ git clone https://github.com/aristidb/aws.git-$ cd aws-$ cabal install-#+END_SRC--* Using aws--** Concepts and organisation--The aws package is organised into the general =Aws= module namespace, and subnamespaces like =Aws.S3= for each Amazon Web-Service. Under each service namespace in turn, there are general support modules and and =Aws.<Service>.Commands.<Command>=-module for each command. For easier usage, there are the "bundling" modules =Aws= (general support), and =Aws.<Service>=.--The primary concept in aws is the /Transaction/, which corresponds to a single HTTP request to the Amazon Web Services.-A transaction consists of a request and a response, which are associated together via the =Transaction= typeclass. Requests-and responses are simple Haskell records, but for some requests there are convenience functions to fill in default values-for many parameters.--** Example usage--To be able to access AWS resources, you should put your into a configuration file. (You don't have to store it in a file,-but that's how we do it in this example.) Save the following in ~$HOME/.aws-keys~.--#+BEGIN_EXAMPLE-default AccessKeyID SecretKey-#+END_EXAMPLE--You do have to replace AccessKeyID and SecretKey with the Access Key ID and the Secret Key respectively, of course.--Then, copy this example into a Haskell file, and run it with ~runghc~ (after installing aws):--#+BEGIN_SRC haskell-{-# LANGUAGE OverloadedStrings #-}--import qualified Aws-import qualified Aws.S3 as S3-import Data.Conduit (($$+-))-import Data.Conduit.Binary (sinkFile)-import Network.HTTP.Conduit (withManager, responseBody)--main :: IO ()-main = do- {- Set up AWS credentials and the default configuration. -}- cfg <- Aws.baseConfiguration- let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery-- {- Set up a ResourceT region with an available HTTP manager. -}- withManager $ \mgr -> do- {- Create a request object with S3.getObject and run the request with pureAws. -}- S3.GetObjectResponse { S3.gorResponse = rsp } <-- Aws.pureAws cfg s3cfg mgr $- S3.getObject "haskell-aws" "cloud-remote.pdf"-- {- Save the response to a file. -}- responseBody rsp $$+- sinkFile "cloud-remote.pdf"-#+END_SRC--You can also find this example in the source distribution in the ~Examples/~ folder.---* Frequently Asked Questions--** S3 questions--- I get an error when I try to access my bucket with upper-case characters / a very long name.-- Those names are not compliant with DNS. You need to use path-style requests, by setting ~s3RequestStyle~ in the configuration to- ~PathStyle~. Note that such bucket names are only allowed in the US standard region, so your endpoint needs to be US standard.--* Release Notes--** 0.7 series--- 0.7.6.3- - In addition to supporting http-conduit 1.9, it would seem nice to support conduit 1.0. Previously slipped through the radar.--- 0.7.6.2- - Support for http-conduit 1.9--- 0.7.6.1- - Support for case-insensitive 1.0 and http-types 0.8--- 0.7.6- - Parsing of SimpleDB error responses was too strict, fixed- - Support for cryptohash 0.8- - Failure 0.1 does not work with aws, stricter lower bound--- 0.7.5- - Support for http-conduit 1.7 and 1.8--- 0.7.1-0.7.4- - Support for GHC 7.6- - Wider constraints to support newer versions of various dependencies- - Update maintainer e-mail address and project categories in cabal file--- 0.7.0- - Change ServiceConfiguration concept so as to indicate in the type whether this is for URI-only requests- (i.e. awsUri)- - EXPERIMENTAL: Direct support for iterated transaction, i.e. such where multiple HTTP requests might be necessary due to e.g. response size limits.- - Put aws functions in ResourceT to be able to safely return Sources and streams.- - simpleAws* does not require ResourceT and converts streams into memory values (like ByteStrings) first.- - Log response metadata (level Info), and do not let all aws runners return it.- - S3:- - GetObject: No longer require a response consumer in the request, return the HTTP response (with the body as a stream) instead.- - Add CopyObject (PUT Object Copy) request type.- - Add Examples cabal flag for building code examples.- - Many more, small improvements.--** 0.6 series--- 0.6.2- - Properly parse Last-Modified header in accordance with RFC 2616.--- 0.6.1- - Fix for MD5 encoding issue in S3 PutObject requests.--- 0.6.0- - API Cleanup- - General: Use Crypto.Hash.MD5.MD5 when a Content-MD5 hash is required, instead of ByteString.- - S3: Made parameter order to S3.putObject consistent with S3.getObject.- - Updated dependencies:- - conduit 0.5 (as well as http-conduit 1.5 and xml-conduit 1.0).- - http-types 0.7.- - Minor changes.- - Internal changes (notable for people who want to add more commands):- - http-types' new 'QueryLike' interface allows creating query lists more conveniently.--** 0.5 series--- 0.5.0 ::- New configuration system: configuration split into general and service-specific parts.-- Significantly improved API reference documentation.-- Re-organised modules to make library easier to understand.-- Smaller improvements.--** 0.4 series--- 0.4.1 :: Documentation improvements.-- 0.4.0.1 :: Change dependency bounds to allow the transformers 0.3 package.-- 0.4.0 :: Update conduit to 0.4.0, which is incompatible with earlier versions.--** 0.3 series--- 0.3.2 :: Add awsRef / simpleAwsRef request variants for those who prefer an =IORef= over a =Data.Attempt.Attempt= value.- Also improve README and add simple example.--* Resources--- [[https://github.com/aristidb/aws][aws on Github]]-- [[http://hackage.haskell.org/package/aws][aws on Hackage]] (includes reference documentation)-- [[http://aws.amazon.com/][Official Amazon Web Services website]]--* Contributors--| Name | Github | E-Mail | Company | Components |-|--------------------+--------------+---------------------------+------------------------+---------------|-| Aristid Breitkreuz | [[https://github.com/aristidb][aristidb]] | aristidb@gmail.com | - | Maintainer |-| Bas van Dijk | [[https://github.com/basvandijk][basvandijk]] | v.dijk.bas@gmail.com | [[http://erudify.ch][Erudify AG]] | S3 |-| David Vollbracht | [[https://github.com/qxjit][qxjit]] | | | |-| Felipe Lessa | [[https://github.com/meteficha][meteficha]] | felipe.lessa@gmail.com | currently secret | Core, S3, SES |-| Nathan Howell | [[https://github.com/NathanHowell][NathanHowell]] | nhowell@alphaheavy.com | [[http://www.alphaheavy.com][Alpha Heavy Industries]] | S3 |-| Ozgun Ataman | [[https://github.com/ozataman][ozataman]] | ozgun.ataman@soostone.com | [[http://soostone.com][Soostone Inc]] | Core, S3 |-| Steve Severance | [[https://github.com/sseveran][sseveran]] | sseverance@alphaheavy.com | [[http://www.alphaheavy.com][Alpha Heavy Industries]] | S3, SQS |
aws.cabal view
@@ -1,8 +1,8 @@ Name: aws-Version: 0.7.6.4+Version: 0.25.3 Synopsis: Amazon Web Services (AWS) for Haskell-Description: Bindings for Amazon Web Services (AWS), with the aim of supporting all AWS services. To see a high level overview of the library, see the README at <https://github.com/aristidb/aws/blob/master/README.org>.-Homepage: http://github.com/aristidb/aws+Description: Bindings for Amazon Web Services (AWS), with the aim of supporting all AWS services. To see a high level overview of the library, see the README at <https://github.com/haskell-pkg-janitors/aws/blob/master/README.md>.+Homepage: http://github.com/haskell-pkg-janitors/aws License: BSD3 License-file: LICENSE Author: Aristid Breitkreuz, contributors see README@@ -11,20 +11,19 @@ Category: Network, Web, AWS, Cloud, Distributed Computing Build-type: Simple -Extra-source-files: README.org- Examples/GetObject.hs- Examples/SimpleDb.hs+Extra-source-files: README.md+ CHANGELOG.md Cabal-version: >=1.10 Source-repository this type: git- location: https://github.com/aristidb/aws.git- tag: 0.7.6.4+ location: https://github.com/haskell-pkg-janitors/aws.git+ tag: 0.25.3 Source-repository head type: git- location: https://github.com/aristidb/aws.git+ location: https://github.com/haskell-pkg-janitors/aws.git Flag Examples Description: Build the examples.@@ -32,65 +31,141 @@ Library Exposed-modules:- Aws,- Aws.Aws,- Aws.Core,- Aws.S3,- Aws.S3.Commands,- Aws.S3.Commands.CopyObject,- 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.Core,- Aws.SimpleDb,- Aws.SimpleDb.Commands,- Aws.SimpleDb.Commands.Attributes,- Aws.SimpleDb.Commands.Domain,- Aws.SimpleDb.Commands.Select,- Aws.SimpleDb.Core,- Aws.Sqs,- Aws.Sqs.Commands,- Aws.Sqs.Commands.Permission,- Aws.Sqs.Commands.Message,- Aws.Sqs.Commands.Queue,- Aws.Sqs.Commands.QueueAttributes,- Aws.Sqs.Core,- Aws.Ses,- Aws.Ses.Commands,- Aws.Ses.Commands.SendRawEmail,+ Aws+ Aws.Aws+ Aws.Core+ Aws.DynamoDb+ Aws.DynamoDb.Commands+ Aws.DynamoDb.Commands.BatchGetItem+ Aws.DynamoDb.Commands.BatchWriteItem+ Aws.DynamoDb.Commands.DeleteItem+ Aws.DynamoDb.Commands.GetItem+ Aws.DynamoDb.Commands.PutItem+ Aws.DynamoDb.Commands.Query+ Aws.DynamoDb.Commands.Scan+ Aws.DynamoDb.Commands.Table+ Aws.DynamoDb.Commands.UpdateItem+ Aws.DynamoDb.Core+ Aws.Ec2.InstanceMetadata+ Aws.Iam+ Aws.Iam.Commands+ Aws.Iam.Commands.AddUserToGroup+ Aws.Iam.Commands.CreateAccessKey+ Aws.Iam.Commands.CreateGroup+ Aws.Iam.Commands.CreateUser+ Aws.Iam.Commands.DeleteAccessKey+ Aws.Iam.Commands.DeleteGroup+ Aws.Iam.Commands.DeleteGroupPolicy+ Aws.Iam.Commands.DeleteUser+ Aws.Iam.Commands.DeleteUserPolicy+ Aws.Iam.Commands.GetGroupPolicy+ Aws.Iam.Commands.GetUser+ Aws.Iam.Commands.GetUserPolicy+ Aws.Iam.Commands.ListAccessKeys+ Aws.Iam.Commands.ListMfaDevices+ Aws.Iam.Commands.ListGroupPolicies+ Aws.Iam.Commands.ListGroups+ Aws.Iam.Commands.ListUserPolicies+ Aws.Iam.Commands.ListUsers+ Aws.Iam.Commands.PutGroupPolicy+ Aws.Iam.Commands.PutUserPolicy+ Aws.Iam.Commands.RemoveUserFromGroup+ Aws.Iam.Commands.UpdateAccessKey+ Aws.Iam.Commands.UpdateGroup+ Aws.Iam.Commands.UpdateUser+ Aws.Iam.Core+ Aws.Iam.Internal+ Aws.Network+ Aws.S3+ Aws.S3.Commands+ Aws.S3.Commands.CopyObject+ Aws.S3.Commands.DeleteBucket+ Aws.S3.Commands.DeleteObject+ Aws.S3.Commands.DeleteObjectVersion+ Aws.S3.Commands.DeleteObjects+ Aws.S3.Commands.GetBucket+ Aws.S3.Commands.GetBucketLocation+ Aws.S3.Commands.GetBucketObjectVersions+ Aws.S3.Commands.GetBucketVersioning+ Aws.S3.Commands.GetObject+ Aws.S3.Commands.GetService+ Aws.S3.Commands.HeadObject+ Aws.S3.Commands.PutBucket+ Aws.S3.Commands.PutBucketVersioning+ Aws.S3.Commands.PutObject+ Aws.S3.Commands.RestoreObject+ Aws.S3.Commands.Multipart+ Aws.S3.Core+ Aws.Ses+ Aws.Ses.Commands+ Aws.Ses.Commands.DeleteIdentity+ Aws.Ses.Commands.GetIdentityDkimAttributes+ Aws.Ses.Commands.GetIdentityNotificationAttributes+ Aws.Ses.Commands.GetIdentityVerificationAttributes+ Aws.Ses.Commands.ListIdentities+ Aws.Ses.Commands.SendRawEmail+ Aws.Ses.Commands.SetIdentityDkimEnabled+ Aws.Ses.Commands.SetIdentityFeedbackForwardingEnabled+ Aws.Ses.Commands.SetIdentityNotificationTopic+ Aws.Ses.Commands.VerifyDomainDkim+ Aws.Ses.Commands.VerifyDomainIdentity+ Aws.Ses.Commands.VerifyEmailIdentity Aws.Ses.Core+ Aws.SimpleDb+ Aws.SimpleDb.Commands+ Aws.SimpleDb.Commands.Attributes+ Aws.SimpleDb.Commands.Domain+ Aws.SimpleDb.Commands.Select+ Aws.SimpleDb.Core+ Aws.Sqs+ Aws.Sqs.Commands+ Aws.Sqs.Commands.Message+ Aws.Sqs.Commands.Permission+ Aws.Sqs.Commands.Queue+ Aws.Sqs.Commands.QueueAttributes+ Aws.Sqs.Core Build-depends:- attempt >= 0.3.1.1 && < 0.5,- base == 4.*,- base64-bytestring == 1.0.*,- blaze-builder >= 0.2.1.4 && < 0.4,- bytestring >= 0.9 && < 0.11,- case-insensitive >= 0.2 && < 1.1,- cereal == 0.3.*,- conduit >= 0.5 && < 1.1,+ aeson >= 2.2.0.0,+ attoparsec >= 0.11 && < 0.15,+ attoparsec-aeson >= 2.1.0.0,+ base >= 4.9 && < 5,+ base16-bytestring >= 0.1 && < 1.1,+ base64-bytestring >= 1.0 && < 1.3,+ blaze-builder >= 0.2.1.4 && < 0.5,+ byteable == 0.1.*,+ bytestring >= 0.9 && < 0.13,+ case-insensitive >= 0.2 && < 1.3,+ cereal >= 0.3 && < 0.6,+ conduit >= 1.3 && < 1.4,+ conduit-extra >= 1.3 && < 1.4, containers >= 0.4,- crypto-api >= 0.9,- cryptohash >= 0.6 && < 0.10,- cryptohash-cryptoapi == 0.1.*,- directory >= 1.0 && < 1.3,- failure >= 0.2.0.1 && < 0.3,- filepath >= 1.1 && < 1.4,- http-conduit >= 1.6 && < 1.10,- http-types >= 0.7 && < 0.9,+ crypton >= 0.34,+ data-default >= 0.5.3 && < 0.9,+ directory >= 1.0 && < 2.0,+ filepath >= 1.1 && < 1.6,+ http-conduit >= 2.3 && < 2.4,+ http-client-tls >= 0.4 && < 0.5,+ http-types >= 0.7 && < 1.0, lifted-base >= 0.1 && < 0.3,+ ram, monad-control >= 0.3,+ exceptions >= 0.8 && < 0.11, mtl == 2.*, old-locale == 1.*,- resourcet >= 0.3.3 && <0.5,+ resourcet >= 1.2 && < 1.4,+ safe >= 0.3 && < 0.4,+ scientific >= 0.3,+ tagged >= 0.7 && < 0.9, text >= 0.11,- time >= 1.1.4 && < 1.5,- transformers >= 0.2.2.0 && < 0.4,- utf8-string == 0.3.*,- xml-conduit >= 1.0.1 && <1.2+ time >= 1.4.0 && < 2.0,+ transformers >= 0.2.2 && < 0.7,+ unordered-containers >= 0.2,+ utf8-string >= 0.3 && < 1.1,+ vector >= 0.10,+ xml-conduit >= 1.8 && <2.0,+ network == 3.*,+ network-bsd == 2.8.* GHC-Options: -Wall @@ -110,6 +185,24 @@ EmptyDataDecls, Rank2Types +Executable GetObjectV4+ Main-is: GetObjectV4.hs+ Hs-source-dirs: Examples++ if !flag(Examples)+ Buildable: False+ else+ Buildable: True+ Build-depends:+ base == 4.*,+ aws,+ http-conduit,+ conduit,+ conduit-extra,+ resourcet++ Default-Language: Haskell2010+ Executable GetObject Main-is: GetObject.hs Hs-source-dirs: Examples@@ -122,10 +215,109 @@ base == 4.*, aws, http-conduit,- conduit+ conduit,+ conduit-extra,+ resourcet Default-Language: Haskell2010 +Executable GetObjectGoogle+ Main-is: GetObjectGoogle.hs+ Hs-source-dirs: Examples++ if !flag(Examples)+ Buildable: False+ else+ Buildable: True+ Build-depends:+ base == 4.*,+ aws,+ http-conduit,+ conduit,+ conduit-extra,+ resourcet++ Default-Language: Haskell2010++Executable MultipartUpload+ Main-is: MultipartUpload.hs+ Hs-source-dirs: Examples++ if !flag(Examples)+ Buildable: False+ else+ Buildable: True+ Build-depends:+ base == 4.*,+ aws,+ bytestring,+ http-conduit,+ conduit,+ conduit-extra,+ text,+ resourcet++ Default-Language: Haskell2010++Executable MultipartTransfer+ Main-is: MultipartTransfer.hs+ Hs-source-dirs: Examples++ if !flag(Examples)+ Buildable: False+ else+ Buildable: True+ Build-depends:+ base == 4.*,+ aws,+ http-conduit,+ conduit,+ conduit-extra,+ text,+ resourcet++ Default-Language: Haskell2010++Executable NukeBucket+ Main-is: NukeBucket.hs+ Hs-source-dirs: Examples++ if !flag(Examples)+ Buildable: False+ else+ Buildable: True+ Build-depends:+ base == 4.*,+ aws,+ http-conduit,+ conduit,+ conduit-extra,+ text >=0.1,+ transformers,+ resourcet++ Default-Language: Haskell2010++Executable PutBucketNearLine+ Main-is: PutBucketNearLine.hs+ Hs-source-dirs: Examples++ if !flag(Examples)+ Buildable: False+ else+ Buildable: True+ Build-depends:+ base == 4.*,+ aws,+ http-conduit,+ conduit,+ conduit-extra,+ text >=0.1,+ transformers,+ resourcet++ Default-Language: Haskell2010+ Executable SimpleDb Main-is: SimpleDb.hs Hs-source-dirs: Examples@@ -140,3 +332,138 @@ text >=0.11 Default-Language: Haskell2010++Executable DynamoDb+ Main-is: DynamoDb.hs+ Hs-source-dirs: Examples++ if !flag(Examples)+ Buildable: False+ else+ Buildable: True+ Build-depends:+ aws,+ base == 4.*,+ data-default,+ exceptions,+ http-conduit,+ resourcet,+ text,+ conduit++ Default-Language: Haskell2010+++Executable Sqs+ Main-is: Sqs.hs+ Hs-source-dirs: Examples++ if !flag(Examples)+ Buildable: False+ else+ Buildable: True+ Build-depends:+ base == 4.*,+ aws,+ errors >= 2.0,+ text >=0.11,+ transformers >= 0.3++ Default-Language: Haskell2010++test-suite sqs-tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: tests+ main-is: Sqs/Main.hs++ other-modules:+ Utils++ build-depends:+ QuickCheck >= 2.7,+ aeson >= 0.7,+ aws,+ base == 4.*,+ bytestring >= 0.10,+ errors >= 2.0,+ http-client >= 0.3 && < 0.8,+ lifted-base >= 0.2,+ monad-control >= 0.3,+ mtl >= 2.1,+ quickcheck-instances >= 0.3,+ resourcet >= 1.1,+ tagged >= 0.7,+ tasty >= 0.8,+ tasty-quickcheck >= 0.8,+ text >= 1.1,+ time,+ transformers >= 0.3,+ transformers-base >= 0.4++ ghc-options: -Wall -threaded++test-suite dynamodb-tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: tests+ main-is: DynamoDb/Main.hs++ other-modules:+ Utils+ DynamoDb.Utils++ build-depends:+ QuickCheck >= 2.7,+ aeson >= 0.7,+ aws,+ base == 4.*,+ bytestring >= 0.10,+ errors >= 2.0,+ http-client >= 0.3,+ lifted-base >= 0.2,+ monad-control >= 0.3,+ mtl >= 2.1,+ quickcheck-instances >= 0.3,+ resourcet >= 1.1,+ tagged >= 0.7,+ tasty >= 0.8,+ tasty-quickcheck >= 0.8,+ text >= 1.1,+ time,+ transformers >= 0.3,+ transformers-base >= 0.4+++test-suite s3-tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: tests+ main-is: S3/Main.hs++ other-modules:+ Utils++ build-depends:+ aws,+ base == 4.*,+ QuickCheck >= 2.7,+ aeson >= 0.7,+ bytestring,+ conduit,+ errors >= 2.0,+ lifted-base >= 0.2,+ monad-control >= 0.3,+ mtl >= 2.1,+ http-client < 0.8,+ http-client-tls < 0.5,+ http-types,+ resourcet,+ tasty >= 0.8,+ tasty-hunit >= 0.8,+ tasty-quickcheck >= 0.8,+ text,+ time,+ tagged >= 0.7,+ transformers >= 0.3,+ transformers-base >= 0.4
+ tests/DynamoDb/Main.hs view
@@ -0,0 +1,158 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module: Main+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: BSD3+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Tests for Haskell AWS DynamoDb bindings+--++module Main+( main+) where++import Aws+import qualified Aws.DynamoDb as DY++import Control.Arrow (second)+import Control.Error+import Control.Monad+import Control.Monad.IO.Class++import Data.IORef+import qualified Data.List as L+import qualified Data.Text as T++import qualified Network.HTTP.Client as HTTP++import Test.Tasty+import Test.QuickCheck.Instances ()++import System.Environment+import System.Exit++import Utils+import DynamoDb.Utils++-- -------------------------------------------------------------------------- --+-- Main++main :: IO ()+main = do+ args <- getArgs+ runMain args $ map (second tail . span (/= '=')) args+ where+ runMain :: [String] -> [(String,String)] -> IO ()+ runMain args _argsMap+ | any (`elem` helpArgs) args = defaultMain tests+ | "--run-with-aws-credentials" `elem` args =+ withArgs (tastyArgs args) . defaultMain $ tests+ | otherwise = putStrLn help >> exitFailure++ helpArgs = ["--help", "-h"]+ mainArgs =+ [ "--run-with-aws-credentials"+ ]+ tastyArgs args = flip filter args $ \x -> not+ $ any (`L.isPrefixOf` x) mainArgs+++help :: String+help = L.intercalate "\n"+ [ ""+ , "NOTE"+ , ""+ , "This test suite accesses the AWS account that is associated with"+ , "the default credentials from the credential file ~/.aws-keys."+ , ""+ , "By running the tests in this test-suite costs for usage of AWS"+ , "services may incur."+ , ""+ , "In order to actually execute the tests in this test-suite you must"+ , "provide the command line options:"+ , ""+ , " --run-with-aws-credentials"+ , ""+ , "When running this test-suite through cabal you may use the following"+ , "command:"+ , ""+ , " cabal test --test-option=--run-with-aws-credentials dynamodb-tests"+ , ""+ ]++tests :: TestTree+tests = testGroup "DynamoDb Tests"+ [ test_table+ -- , test_message+ , test_core+ ]++-- -------------------------------------------------------------------------- --+-- Table Tests++test_table :: TestTree+test_table = testGroup "Table Tests"+ [ eitherTOnceTest1 "CreateDescribeDeleteTable" (prop_createDescribeDeleteTable 10 10)+ ]++-- |+--+prop_createDescribeDeleteTable+ :: Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)+ -> Int -- ^ write capacity (#writes * itemsize/1KB)+ -> T.Text -- ^ table name+ -> ExceptT T.Text IO ()+prop_createDescribeDeleteTable readCapacity writeCapacity tableName = do+ tTableName <- testData tableName+ tryT $ createTestTable tTableName readCapacity writeCapacity+ let deleteTable = retryT 6 . void $ simpleDyT (DY.DeleteTable tTableName)+ flip catchE (\e -> deleteTable >> throwE e) $ do+ retryT 6 . void . simpleDyT $ DY.DescribeTable tTableName+ deleteTable++-- -------------------------------------------------------------------------- --+-- Test core functionality++test_core :: TestTree+test_core = testGroup "Core Tests"+ [ eitherTOnceTest0 "connectionReuse" prop_connectionReuse+ ]++prop_connectionReuse+ :: ExceptT T.Text IO ()+prop_connectionReuse = do+ c <- liftIO $ do+ cfg <- baseConfiguration++ -- counts the number of TCP connections+ ref <- newIORef (0 :: Int)++ manager <- HTTP.newManager (managerSettings ref)+ void $ runExceptT $+ flip catchE (error . T.unpack) . replicateM_ 3 $ do+ void $ dyT cfg manager DY.ListTables+ mustFail . dyT cfg manager $ DY.DescribeTable "____"++ readIORef ref+ unless (c == 1) $+ throwE "The TCP connection has not been reused"+ where+ managerSettings ref = HTTP.defaultManagerSettings+ { HTTP.managerRawConnection = do+ mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings+ return $ \a b c -> do+ atomicModifyIORef ref $ \i -> (succ i, ())+ mkConn a b c+ }+
+ tests/DynamoDb/Utils.hs view
@@ -0,0 +1,168 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module: DynamoDb.Utils+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: BSD3+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Tests for Haskell SQS bindings+--++module DynamoDb.Utils+(+-- * Static Parameters+ testProtocol+, testRegion+, defaultTableName++-- * Static Configuration+, dyConfiguration++-- * DynamoDb Utils+, simpleDy+, simpleDyT+, dyT+, withTable+, withTable_+, createTestTable+) where++import Aws+import Aws.Core+import qualified Aws.DynamoDb as DY++import Control.Error+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource++import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.IO as T++import qualified Network.HTTP.Client as HTTP++import Test.Tasty+import Test.QuickCheck.Instances ()++import System.IO++import Utils++-- -------------------------------------------------------------------------- --+-- Static Test parameters+--+-- TODO make these configurable++testProtocol :: Protocol+testProtocol = HTTP++testRegion :: DY.Region+testRegion = DY.ddbUsWest2++defaultTableName :: T.Text+defaultTableName = "test-table"++-- -------------------------------------------------------------------------- --+-- Dynamo Utils++dyConfiguration :: DY.DdbConfiguration qt+dyConfiguration = DY.DdbConfiguration+ { DY.ddbcRegion = testRegion+ , DY.ddbcProtocol = testProtocol+ , DY.ddbcPort = Nothing+ }++simpleDy+ :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadIO m)+ => r+ -> m (MemoryResponse a)+simpleDy command = do+ c <- dbgConfiguration+ simpleAws c dyConfiguration command++simpleDyT+ :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadBaseControl IO m, MonadIO m)+ => r+ -> ExceptT T.Text m (MemoryResponse a)+simpleDyT = tryT . simpleDy++dyT+ :: (Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration)+ => Configuration+ -> HTTP.Manager+ -> r+ -> ExceptT T.Text IO a+dyT cfg manager req = do+ Response _ r <- liftIO . runResourceT $ aws cfg dyConfiguration manager req+ hoistEither $ fmapL sshow r++withTable+ :: T.Text -- ^ table Name+ -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)+ -> Int -- ^ write capacity (#writes * itemsize/1KB)+ -> (T.Text -> IO a) -- ^ test tree+ -> IO a+withTable = withTable_ True++withTable_+ :: Bool -- ^ whether to prefix the table name+ -> T.Text -- ^ table Name+ -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)+ -> Int -- ^ write capacity (#writes * itemsize/1KB)+ -> (T.Text -> IO a) -- ^ test tree+ -> IO a+withTable_ prefix tableName readCapacity writeCapacity f =+ do+ tTableName <- if prefix then testData tableName else return tableName++ let deleteTable = do+ r <- runExceptT . retryT 6 $+ void (simpleDyT $ DY.DeleteTable tTableName) `catchE` \e ->+ liftIO . T.hPutStrLn stderr $ "attempt to delete table failed: " <> e+ either (error . T.unpack) (const $ return ()) r++ let createTable = do+ r <- runExceptT $ do+ retryT 3 $ tryT $ createTestTable tTableName readCapacity writeCapacity+ retryT 6 $ do+ tableDesc <- simpleDyT $ DY.DescribeTable tTableName+ when (DY.rTableStatus tableDesc == "CREATING") $ throwE "Table not ready: status CREATING"+ either (error . T.unpack) return r++ bracket_ createTable deleteTable $ f tTableName++createTestTable+ :: T.Text -- ^ table Name+ -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)+ -> Int -- ^ write capacity (#writes * itemsize/1KB)+ -> IO ()+createTestTable tableName readCapacity writeCapacity = void . simpleDy $+ DY.createTable+ tableName+ attrs+ (DY.HashOnly keyName)+ throughPut+ where+ keyName = "Id"+ keyType = DY.AttrString+ attrs = [DY.AttributeDefinition keyName keyType]+ throughPut = DY.ProvisionedThroughput+ { DY.readCapacityUnits = readCapacity+ , DY.writeCapacityUnits = writeCapacity+ }++
+ tests/S3/Main.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module: Main+-- Copyright: Copyright © 2016 Soostone, Inc.+-- License: BSD3+-- Maintainer: Michael Xavier <michael.xavier@soostone.com>+-- Stability: experimental+--+-- Tests for Haskell AWS S3 bindings+--+module Main+ ( main+ ) where++import Control.Applicative+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Conduit+import Control.Arrow (second)+import Control.Exception+import Control.Monad+import Control.Monad.Trans.Resource+import qualified Data.List as L+import Data.Monoid+import qualified Data.Text as T+import Data.Typeable+import Data.Proxy+import Network.HTTP.Client (HttpException (..),+ RequestBody (..), newManager,+ responseBody)+#if MIN_VERSION_http_client(0, 5, 0)+import Network.HTTP.Client (HttpExceptionContent (..),+ responseStatus)+#endif+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types.Status+import System.Environment+import System.Exit+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Options++import Aws+import Aws.S3+++newtype BucketOption = BucketOption Bucket+ deriving (Show, Eq, Ord, Typeable)++instance IsOption BucketOption where+ defaultValue = error "The --bucket flag is required"+ parseValue = Just . BucketOption . T.pack+ optionName = return "bucket"+ optionHelp = return "Bucket to use for performing S3 operations. Tests will write to the 's3-test-object' key."+++main :: IO ()+main = do+ args <- getArgs+ runMain args $ map (second tail . span (/= '=')) args+ where+ runMain :: [String] -> [(String,String)] -> IO ()+ runMain args _argsMap+ | any (`elem` helpArgs) args = defaultMainWithIngredients ings tests+ | "--run-with-aws-credentials" `elem` args =+ withArgs (tastyArgs args) . defaultMainWithIngredients ings $ tests+ | otherwise = putStrLn help >> exitFailure+ helpArgs = ["--help", "-h"]+ mainArgs =+ [ "--run-with-aws-credentials"+ ]+ tastyArgs args = flip filter args $ \x -> not+ $ any (`L.isPrefixOf` x) mainArgs+ ings = includingOptions [Option (Proxy :: Proxy BucketOption)]:defaultIngredients+++help :: String+help = L.intercalate "\n"+ [ ""+ , "NOTE"+ , ""+ , "This test suite accesses the AWS account that is associated with"+ , "the default credentials from the credential file ~/.aws-keys."+ , ""+ , "By running the tests in this test-suite costs for usage of AWS"+ , "services may incur."+ , ""+ , "In order to actually execute the tests in this test-suite you must"+ , "provide the command line options:"+ , ""+ , " --run-with-aws-credentials"+ , ""+ , "When running this test-suite through cabal you may use the following"+ , "command:"+ , ""+ , " cabal test --test-option=--run-with-aws-credentials s3-tests"+ , ""+ ]+++tests :: TestTree+tests = testGroup "S3 Tests"+ [ test_head+ , test_get+ , test_versioning+ ]+++-------------------------------------------------------------------------------+-- HeadObject Tests+-------------------------------------------------------------------------------+++test_head :: TestTree+test_head = askOption $ \(BucketOption bucket) -> testGroup "HeadObject"+ [ test_head_caching bucket+ ]+++test_head_caching :: Bucket -> TestTree+test_head_caching bucket = withResource mkSetup teardown $ \setup -> testGroup "Caches"+ [ testCase "If-Matches match succeeds" $ do+ (cfg, s3cfg, mgr) <- setup+ void (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfMatch = Just payloadMD5 }))+ , testCase "If-Matches mismatch fails with 412" $ do+ (cfg, s3cfg, mgr) <- setup+ assertStatus 412 (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfMatch = Just (T.reverse payloadMD5) }))+ , testCase "If-None-Match mismatch succeeds" $ do+ (cfg, s3cfg, mgr) <- setup+ void (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfNoneMatch = Just (T.reverse payloadMD5) }))+ , testCase "If-None-Match match fails with 304" $ do+ (cfg, s3cfg, mgr) <- setup+ assertStatus 304 (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfNoneMatch = Just payloadMD5 }))+ ]+ where+ k = "s3-test-object"+ content = "example"+ payloadMD5 = "1a79a4d60de6718e8e5b326e338ae533"+ mkSetup = do+ cfg <- baseConfiguration+ let s3cfg = defServiceConfig+ mgr <- newManager tlsManagerSettings+ void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))+ return (cfg, s3cfg, mgr)+ teardown (cfg, s3cfg, mgr) =+ void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket)))+++-------------------------------------------------------------------------------+-- GetObject Tests+-------------------------------------------------------------------------------+++test_get :: TestTree+test_get = askOption $ \(BucketOption bucket) -> testGroup "GetObject"+ [ test_get_caching bucket+ ]+++test_get_caching :: Bucket -> TestTree+test_get_caching bucket = withResource mkSetup teardown $ \setup -> testGroup "Caches"+ [ testCase "If-Matches match succeeds" $ do+ (cfg, s3cfg, mgr) <- setup+ void (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfMatch = Just payloadMD5 }))+ , testCase "If-Matches mismatch fails with 412" $ do+ (cfg, s3cfg, mgr) <- setup+ assertStatus 412 (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfMatch = Just (T.reverse payloadMD5) }))+ , testCase "If-None-Match mismatch succeeds" $ do+ (cfg, s3cfg, mgr) <- setup+ void (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfNoneMatch = Just (T.reverse payloadMD5) }))+ , testCase "If-None-Match match fails with 304" $ do+ (cfg, s3cfg, mgr) <- setup+ assertStatus 304 (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfNoneMatch = Just payloadMD5 }))+ ]+ where+ k = "s3-test-object"+ content = "example"+ payloadMD5 = "1a79a4d60de6718e8e5b326e338ae533"+ mkSetup = do+ cfg <- baseConfiguration+ let s3cfg = defServiceConfig+ mgr <- newManager tlsManagerSettings+ void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))+ return (cfg, s3cfg, mgr)+ teardown (cfg, s3cfg, mgr) =+ void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket)))+++-------------------------------------------------------------------------------+-- GetBucketObjectVersions Tests+-------------------------------------------------------------------------------+++test_versioning :: TestTree+test_versioning = askOption $ \(BucketOption bucket) ->+ withResource (mkSetup bucket) (teardown bucket) $ \setup -> testGroup "Versioning"+ [ testCase "GetBucketObjectVersions succeeds" $ do+ (cfg, s3cfg, mgr) <- setup+ resp <- runResourceT $ pureAws cfg s3cfg mgr $ (getBucketObjectVersions bucket)+ { gbovPrefix = Just k+ }+ let [o1, o2, o3, o4] = take 4 $ gbovrContents resp+ checkObject True o1+ checkDeleteMarker False o2+ checkObject False o3+ checkObject False o4+ , testCase "DeleteObjectVersion succeeds" $ do+ -- Note: this test requires bucket with versioning enabled+ (cfg, s3cfg, mgr) <- setup+ resp <- runResourceT $ pureAws cfg s3cfg mgr $ (getBucketObjectVersions bucket)+ { gbovPrefix = Just k+ }+ let [v1, v2, v3, v4] = map oviVersionId $ take 4 $ gbovrContents resp+ void (runResourceT (pureAws cfg s3cfg mgr (deleteObjectVersion bucket k v2)))+ void (runResourceT (pureAws cfg s3cfg mgr (deleteObjectVersion bucket k v3)))++ resp' <- runResourceT $ pureAws cfg s3cfg mgr $ (getBucketObjectVersions bucket)+ { gbovPrefix = Just k+ }+ let [v1', v4'] = map oviVersionId $ take 2 $ gbovrContents resp'+ assertEqual "invalid v1 version" v1 v1'+ assertEqual "invalid v4 version" v4 v4'+ , testCase "Multipart upload succeeds" $ do+ -- Note: this test requires bucket with versioning enabled+ (cfg, s3cfg, mgr) <- setup+ resp <- runResourceT $ do+ uploadId <- liftIO $ getUploadId cfg s3cfg mgr bucket k+ etags <- (sourceLazy testStr+ .| chunkedConduit 65536+ .| putConduit cfg s3cfg mgr bucket k uploadId+ ) `connect` sinkList+ liftIO $ sendEtag cfg s3cfg mgr bucket k uploadId etags+ let Just vid = cmurVersionId resp+ bs <- runResourceT $ do+ gor <- pureAws cfg s3cfg mgr (getObject bucket k) { goVersionId = Just vid }+ sealConduitT (responseBody (gorResponse gor)) $$+- sinkLazy++ assertEqual "data do not match" testStr bs+ ]+ where+ testStr = "foobar" :: BL.ByteString+ k = "s3-test-object"+ content = "example"+ payloadMD5 = "1a79a4d60de6718e8e5b326e338ae533"+ checkObject marker obj@ObjectVersion{} = do+ assertEqual "invalid object key" k (oviKey obj)+ assertEqual "invalid isLatest flag" marker (oviIsLatest obj)+ assertEqual "invalid object size" (fromIntegral $ BS.length content) (oviSize obj)+ checkObject _ obj = assertFailure $ "Invalid object type " <> show obj+ checkDeleteMarker marker obj@DeleteMarker{} = do+ assertEqual "invalid object key" k (oviKey obj)+ assertEqual "invalid isLatest flag" marker (oviIsLatest obj)+ checkDeleteMarker _ obj = assertFailure $ "Invalid object type " <> show obj+ mkSetup bucket = do+ cfg <- baseConfiguration+ let s3cfg = defServiceConfig+ mgr <- newManager tlsManagerSettings+ void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))+ void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))+ void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket)))+ void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))+ return (cfg, s3cfg, mgr)+ teardown bucket (cfg, s3cfg, mgr) =+ void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket)))+++assertStatus :: Int -> IO a -> Assertion+assertStatus expectedStatus f = do+ res <- catchJust selector+ (Right <$> f)+ (return . Left)+ case res of+ Right _ -> assertFailure ("Expected error with status " <> show expectedStatus <> ", but got success.")+ Left _ -> return ()+ where+#if MIN_VERSION_http_client(0, 5, 0)+ selector (HttpExceptionRequest _ (StatusCodeException res _))+ | statusCode (responseStatus res) == expectedStatus = Just ()+ selector _ = Nothing+#else+ selector (StatusCodeException s _ _)+ | statusCode s == expectedStatus = Just ()+ | otherwise = Nothing+ selector _ = Nothing+#endif
+ tests/Sqs/Main.hs view
@@ -0,0 +1,381 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module: Main+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: BSD3+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Tests for Haskell SQS bindings+--++module Main+( main+) where++import Aws+import Aws.Core+import qualified Aws.Sqs as SQS++import Control.Arrow (second)+import Control.Error+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource++import Data.IORef+import qualified Data.List as L+import qualified Data.Text as T+import Data.Monoid+import Prelude++import qualified Network.HTTP.Client as HTTP++import Test.Tasty+import Test.QuickCheck.Instances ()++import System.Environment+import System.Exit++import Utils++-- -------------------------------------------------------------------------- --+-- Main++main :: IO ()+main = do+ args <- getArgs+ runMain args $ map (second tail . span (/= '=')) args+ where+ runMain :: [String] -> [(String,String)] -> IO ()+ runMain args _argsMap+ | any (`elem` helpArgs) args = defaultMain tests+ | "--run-with-aws-credentials" `elem` args =+ withArgs (tastyArgs args) . defaultMain $ tests+ | otherwise = putStrLn help >> exitFailure++ helpArgs = ["--help", "-h"]+ mainArgs =+ [ "--run-with-aws-credentials"+ ]+ tastyArgs args = flip filter args $ \x -> not+ $ any (`L.isPrefixOf` x) mainArgs+++help :: String+help = L.intercalate "\n"+ [ ""+ , "NOTE"+ , ""+ , "This test suite accesses the AWS account that is associated with"+ , "the default credentials from the credential file ~/.aws-keys."+ , ""+ , "By running the tests in this test-suite costs for usage of AWS"+ , "services may incur."+ , ""+ , "In order to actually execute the tests in this test-suite you must"+ , "provide the command line options:"+ , ""+ , " --run-with-aws-credentials"+ , ""+ , "When running this test-suite through cabal you may use the following"+ , "command:"+ , ""+ , " cabal test --test-option=--run-with-aws-credentials sqs-tests"+ , ""+ ]++tests :: TestTree+tests = withQueueTest defaultQueueName $ \getQueueParams -> testGroup "SQS Tests"+ [ test_queue+ , test_message getQueueParams+ , test_core getQueueParams+ ]++-- -------------------------------------------------------------------------- --+-- Static Test parameters+--+-- TODO make these configurable++testProtocol :: Protocol+testProtocol = HTTP++testSqsEndpoint :: SQS.Endpoint+testSqsEndpoint = SQS.sqsEndpointUsWest2++defaultQueueName :: T.Text+defaultQueueName = "test-queue"++-- -------------------------------------------------------------------------- --+-- SQS Utils++sqsQueueName :: T.Text -> SQS.QueueName+sqsQueueName url = SQS.QueueName (sqsQueueNameText url) (sqsAccountIdText url)++sqsQueueNameText :: T.Text -> T.Text+sqsQueueNameText url = T.split (== '/') url !! 4++sqsAccountIdText :: T.Text -> T.Text+sqsAccountIdText url = T.split (== '/') url !! 3++sqsConfiguration :: SQS.SqsConfiguration qt+sqsConfiguration = SQS.SqsConfiguration+ { SQS.sqsProtocol = testProtocol+ , SQS.sqsEndpoint = testSqsEndpoint+ , SQS.sqsPort = 80+ , SQS.sqsUseUri = False+ , SQS.sqsDefaultExpiry = 180+ }++sqsT+ :: (Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration)+ => Configuration+ -> HTTP.Manager+ -> r+ -> ExceptT T.Text IO a+sqsT cfg manager req = do+ Response _ r <- liftIO . runResourceT $ aws cfg sqsConfiguration manager req+ hoistEither $ fmapL sshow r++simpleSqs+ :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadIO m)+ => r+ -> m (MemoryResponse a)+simpleSqs command = do+ c <- baseConfiguration+ simpleAws c sqsConfiguration command++simpleSqsT+ :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadBaseControl IO m, MonadIO m)+ => r+ -> ExceptT T.Text m (MemoryResponse a)+simpleSqsT = tryT . simpleSqs++withQueueTest+ :: T.Text -- ^ Queue name+ -> (IO (T.Text, SQS.QueueName) -> TestTree) -- ^ test tree+ -> TestTree+withQueueTest queueName f = withResource createQueue deleteQueue $ \getQueueUrl ->+ f $ do+ url <- getQueueUrl+ return (url, sqsQueueName url)+ where+ createQueue = do+ SQS.CreateQueueResponse url <- simpleSqs $ SQS.CreateQueue Nothing queueName+ return url+ deleteQueue url = void $ simpleSqs (SQS.DeleteQueue (sqsQueueName url))++-- -------------------------------------------------------------------------- --+-- Queue Tests++test_queue :: TestTree+test_queue = testGroup "Queue Tests"+ [ eitherTOnceTest1 "CreateListDeleteQueue" prop_createListDeleteQueue+ ]++-- |+--+prop_createListDeleteQueue+ :: T.Text -- ^ queue name+ -> ExceptT T.Text IO ()+prop_createListDeleteQueue queueName = do+ tQueueName <- testData queueName+ SQS.CreateQueueResponse queueUrl <- simpleSqsT $ SQS.CreateQueue Nothing tQueueName+ let queue = sqsQueueName queueUrl+ flip catchE (\e -> deleteQueue queue >> throwE e) $ do+ retryT 6 $ do+ SQS.ListQueuesResponse allQueueUrls <- simpleSqsT (SQS.ListQueues Nothing)+ unless (queueUrl `elem` allQueueUrls)+ . throwE $ "queue " <> sshow queueUrl <> " not listed"+ deleteQueue queue+ where+ deleteQueue queueUrl = void $ simpleSqsT (SQS.DeleteQueue queueUrl)++-- -------------------------------------------------------------------------- --+-- Message Tests++test_message :: IO (T.Text, SQS.QueueName) -> TestTree+test_message getQueueParams = testGroup "Queue Tests"+ [ eitherTOnceTest0 "SendReceiveDeleteMessage" $ do+ (_, queue) <- liftIO getQueueParams+ prop_sendReceiveDeleteMessage queue+ , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling" $ do+ (_, queue) <- liftIO getQueueParams+ prop_sendReceiveDeleteMessageLongPolling queue+ , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling1" $ do+ (_, queue) <- liftIO getQueueParams+ prop_sendReceiveDeleteMessageLongPolling1 queue+ ]++-- | Simple send and short-polling receive. First sends all messages+-- and receives messages thereafter one by one.+--+prop_sendReceiveDeleteMessage+ :: SQS.QueueName+ -> ExceptT T.Text IO ()+prop_sendReceiveDeleteMessage queue = do++ -- a visibility timeout should be used only if either @receiveBatch == 1@+ -- or no retry is used so that all received messages are handled.+ let visTimeout = Just 60+ let delay = Just 0+ let poll = Nothing -- no consistent receive (any number of messages up to the requested number can be returned)+ let receiveBatch = 1+ let msgNum = 10++ let messages = map (\i -> "message" <> sshow i) [1 .. msgNum]++ -- send messages+ forM_ messages $ \msg -> void . simpleSqsT $ SQS.SendMessage msg queue [] delay++ recMsgs <- fmap concat . replicateM msgNum $ do+ msgs <- retryT 5 $ do+ r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll+ case r of+ SQS.ReceiveMessageResponse [] -> throwE "no message received"+ SQS.ReceiveMessageResponse t+ | length t <= receiveBatch -> return t+ | otherwise -> throwE $ "unexpected number of messages received: " <> sshow (length t)+ forM_ msgs $ \msg -> retryT 5 $+ simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle msg) queue+ return (map SQS.mBody msgs)++ let recv = L.sort recMsgs+ let sent = L.sort messages+ unless (sent == recv)+ $ throwE $ "received messages don't match send messages; sent: "+ <> sshow sent <> "; got: " <> sshow recv++-- | Checks for consistent receive: There is no message delay, so all messages+-- are available when the first receive is requested. By enabling long-polling+-- (with value 0) we force SQS to do a consistent receive.+--+prop_sendReceiveDeleteMessageLongPolling+ :: SQS.QueueName+ -> ExceptT T.Text IO ()+prop_sendReceiveDeleteMessageLongPolling queue = do++ let delay = Nothing+ let visTimeout = Just 60+ let poll = Just 1 -- consistent receive (maximum available number of requested messages is returned)+ let receiveBatch = 10+ let msgNum = 40 -- this must be a multiple of 'receiveBatch'++ let messages = map (\i -> "message" <> sshow i) [1 .. msgNum]++ -- send messages+ forM_ messages $ \msg -> void . simpleSqsT $ SQS.SendMessage msg queue [] delay++ recMsgs <- fmap concat . replicateM (msgNum `div` receiveBatch) $ do+ msgs <- do+ r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll+ case r of+ SQS.ReceiveMessageResponse [] -> throwE "no messages received"+ SQS.ReceiveMessageResponse t+ | length t == receiveBatch -> return t+ | otherwise -> throwE $ "unexpected number of messages received: " <> sshow (length t)+ forM_ msgs $ \msg -> retryT 5 $+ simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle msg) queue+ return (map SQS.mBody msgs)++ let recv = L.sort recMsgs+ let sent = L.sort messages+ unless (sent == recv)+ $ throwE $ "received messages don't match send messages; sent: "+ <> sshow sent <> "; got: " <> sshow recv++-- | Checks that long polling is actually enabled. We add a delay to the messages+-- and immediately make a receive request with a polling wait time that is larger+-- than the delay. Note that even though polling forces consistent reads, messages+-- will become available with some (small) offset. Therefore we request only a single+-- message at a time.+--+prop_sendReceiveDeleteMessageLongPolling1+ :: SQS.QueueName+ -> ExceptT T.Text IO ()+prop_sendReceiveDeleteMessageLongPolling1 queue = do++ let delay = Just 2+ let visTimeout = Just 60+ let poll = Just 5 -- consistent receive (maximum available number of requested messages is returned)+ let receiveBatch = 1+ let msgNum = 10 -- this must be a multiple of 'receiveBatch'++ let messages = map (\i -> "message" <> sshow i) [1 :: Int .. msgNum]++ recMsgs <- fmap concat . forM messages $ \msg -> do+ void . simpleSqsT $ SQS.SendMessage msg queue [] delay+ msgs <- do+ r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll+ case r of+ SQS.ReceiveMessageResponse [] -> throwE "no messages received"+ SQS.ReceiveMessageResponse t+ | length t == receiveBatch -> return t+ | otherwise -> throwE $ "unexpected number of messages received: " <> sshow (length t)+ forM_ msgs $ \m -> retryT 5 $+ simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle m) queue+ return (map SQS.mBody msgs)++ let recv = L.sort recMsgs+ let sent = L.sort messages+ unless (sent == recv)+ $ throwE $ "received messages don't match send messages; sent: "+ <> sshow sent <> "; got: " <> sshow recv+++-- -------------------------------------------------------------------------- --+-- Test core functionality++test_core :: IO (T.Text, SQS.QueueName) -> TestTree+test_core getQueueParams = testGroup "Core Tests"+ [ eitherTOnceTest0 "connectionReuse" $ do+ (_, queue) <- liftIO getQueueParams+ prop_connectionReuse queue+ ]++prop_connectionReuse+ :: SQS.QueueName+ -> ExceptT T.Text IO ()+prop_connectionReuse queue = do+ c <- liftIO $ do+ cfg <- baseConfiguration++ -- used for counting the number of TCP connections+ ref <- newIORef (0 :: Int)++ -- Use a single manager for all HTTP requests+ manager <- HTTP.newManager (managerSettings ref)+ void $ runExceptT $+ flip catchE (error . T.unpack) . replicateM_ 3 $ do+ void . sqsT cfg manager $ SQS.ListQueues Nothing+ mustFail . sqsT cfg manager $+ SQS.SendMessage "" (SQS.QueueName "" "") [] Nothing+ void . sqsT cfg manager $+ SQS.SendMessage "test-message" queue [] Nothing+ void . sqsT cfg manager $+ SQS.ReceiveMessage Nothing [] Nothing [] queue (Just 20)++ readIORef ref+ unless (c == 1) $+ throwE "The TCP connection has not been reused"+ where++ managerSettings ref = HTTP.defaultManagerSettings+ { HTTP.managerRawConnection = do+ mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings+ return $ \a b c -> do+ atomicModifyIORef ref $ \i -> (succ i, ())+ mkConn a b c+ }+
+ tests/Utils.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module: Utils+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: BSD3+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Utils for Tests for Haskell AWS bindints+--+module Utils+(+-- * Parameters+ testDataPrefix++-- * General Utils+, sshow+, mustFail+, tryT+, retryT+, retryT_+, testData++, evalTestT+, evalTestTM+, eitherTOnceTest0+, eitherTOnceTest1+, eitherTOnceTest2++-- * Generic Tests+, test_jsonRoundtrip+, prop_jsonRoundtrip+) where++import Control.Concurrent (threadDelay)+import qualified Control.Exception.Lifted as LE+import Control.Error hiding (syncIO)+import Control.Monad+import Control.Monad.Identity+import Control.Monad.IO.Class+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Applicative+import Data.Monoid+import Prelude++import Data.Aeson (FromJSON, ToJSON, encode, eitherDecode)+import Data.Dynamic (Dynamic)+import Data.Proxy+import Data.String+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Typeable++import Test.QuickCheck.Property+import Test.QuickCheck.Monadic+import Test.Tasty+import Test.Tasty.QuickCheck++import System.Exit (ExitCode)+import System.IO (stderr)++import Data.Time.Clock.POSIX (getPOSIXTime)++-- -------------------------------------------------------------------------- --+-- Static Test parameters+--++-- | This prefix is used for the IDs and names of all entities that are+-- created in the AWS account.+--+testDataPrefix :: IsString a => MonadBase IO m => m a+testDataPrefix = do+ t <- liftBase $ getPOSIXTime+ let t' :: Int+ t' = floor (t * 1000)+ return . fromString $ "__TEST_AWSHASKELLBINDINGS__" ++ show t'++-- -------------------------------------------------------------------------- --+-- General Utils++-- | Catches all exceptions except for asynchronous exceptions found in base.+--+tryT :: MonadBaseControl IO m => m a -> ExceptT T.Text m a+tryT = fmapLT (T.pack . show) . syncIO++-- | Lifted Version of 'syncIO' form "Control.Error.Util".+--+syncIO :: MonadBaseControl IO m => m a -> ExceptT LE.SomeException m a+syncIO a = ExceptT $ LE.catches (Right <$> a)+ [ LE.Handler $ \e -> LE.throw (e :: LE.ArithException)+ , LE.Handler $ \e -> LE.throw (e :: LE.ArrayException)+ , LE.Handler $ \e -> LE.throw (e :: LE.AssertionFailed)+ , LE.Handler $ \e -> LE.throw (e :: LE.AsyncException)+ , LE.Handler $ \e -> LE.throw (e :: LE.BlockedIndefinitelyOnMVar)+ , LE.Handler $ \e -> LE.throw (e :: LE.BlockedIndefinitelyOnSTM)+ , LE.Handler $ \e -> LE.throw (e :: LE.Deadlock)+ , LE.Handler $ \e -> LE.throw (e :: Dynamic)+ , LE.Handler $ \e -> LE.throw (e :: LE.ErrorCall)+ , LE.Handler $ \e -> LE.throw (e :: ExitCode)+ , LE.Handler $ \e -> LE.throw (e :: LE.NestedAtomically)+ , LE.Handler $ \e -> LE.throw (e :: LE.NoMethodError)+ , LE.Handler $ \e -> LE.throw (e :: LE.NonTermination)+ , LE.Handler $ \e -> LE.throw (e :: LE.PatternMatchFail)+ , LE.Handler $ \e -> LE.throw (e :: LE.RecConError)+ , LE.Handler $ \e -> LE.throw (e :: LE.RecSelError)+ , LE.Handler $ \e -> LE.throw (e :: LE.RecUpdError)+ , LE.Handler $ return . Left+ ]++testData :: (IsString a, Monoid a, MonadBaseControl IO m) => a -> m a+testData a = fmap (<> a) testDataPrefix++retryT :: (Functor m, MonadIO m) => Int -> ExceptT T.Text m a -> ExceptT T.Text m a+retryT n f = snd <$> retryT_ n f++retryT_ :: (Functor m, MonadIO m) => Int -> ExceptT T.Text m a -> ExceptT T.Text m (Int, a)+retryT_ n f = go 1+ where+ go x+ | x >= n = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) ((x,) <$> f)+ | otherwise = ((x,) <$> f) `catchE` \e -> do+ liftIO $ T.hPutStrLn stderr $ "Retrying after error: " <> e+ liftIO $ threadDelay (1000000 * min 60 (2^(x-1)))+ go (succ x)++sshow :: (Show a, IsString b) => a -> b+sshow = fromString . show++mustFail :: Monad m => ExceptT e m a -> ExceptT T.Text m ()+mustFail = ExceptT . exceptT+ (const . return $ Right ())+ (const . return $ Left "operation succeeded when a failure was expected")++evalTestTM+ :: Functor f+ => String -- ^ test name+ -> f (ExceptT T.Text IO a) -- ^ test+ -> f (PropertyM IO Bool)+evalTestTM name = fmap $+ (liftIO . runExceptT) >=> \r -> case r of+ Left e ->+ fail $ "failed to run test \"" <> name <> "\": " <> show e+ Right _ -> return True++evalTestT+ :: String -- ^ test name+ -> ExceptT T.Text IO a -- ^ test+ -> PropertyM IO Bool+evalTestT name = runIdentity . evalTestTM name . Identity++eitherTOnceTest0+ :: String -- ^ test name+ -> ExceptT T.Text IO a -- ^ test+ -> TestTree+eitherTOnceTest0 name test = testProperty name . once . monadicIO+ $ evalTestT name test++eitherTOnceTest1+ :: (Arbitrary a, Show a)+ => String -- ^ test name+ -> (a -> ExceptT T.Text IO b)+ -> TestTree+eitherTOnceTest1 name test = testProperty name . once $ monadicIO+ . evalTestTM name test++eitherTOnceTest2+ :: (Arbitrary a, Show a, Arbitrary b, Show b)+ => String -- ^ test name+ -> (a -> b -> ExceptT T.Text IO c)+ -> TestTree+eitherTOnceTest2 name test = testProperty name . once $ \a b -> monadicIO+ $ (evalTestTM name $ uncurry test) (a, b)++-- -------------------------------------------------------------------------- --+-- Generic Tests++test_jsonRoundtrip+ :: forall a . (Eq a, Show a, FromJSON a, ToJSON a, Typeable a, Arbitrary a)+ => Proxy a+ -> TestTree+test_jsonRoundtrip proxy = testProperty msg (prop_jsonRoundtrip :: a -> Property)+ where+ msg = "JSON roundtrip for " <> show typ+#if MIN_VERSION_base(4,7,0)+ typ = typeRep proxy+#else+ typ = typeOf (undefined :: a)+#endif++prop_jsonRoundtrip :: forall a . (Eq a, Show a, FromJSON a, ToJSON a) => a -> Property+prop_jsonRoundtrip a = either (const $ property False) (\(b :: [a]) -> [a] === b) $+ eitherDecode $ encode [a]+