diff --git a/Aws.hs b/Aws.hs --- a/Aws.hs +++ b/Aws.hs @@ -49,12 +49,16 @@ , IteratedTransaction -- * Credentials , Credentials(..) +, makeCredentials , credentialsDefaultFile , credentialsDefaultKey , loadCredentialsFromFile , loadCredentialsFromEnv +, loadCredentialsFromInstanceMetadata , loadCredentialsFromEnvOrFile +, loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault +, anonymousCredentials ) where diff --git a/Aws/Aws.hs b/Aws/Aws.hs --- a/Aws/Aws.hs +++ b/Aws/Aws.hs @@ -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 diff --git a/Aws/Core.hs b/Aws/Core.hs --- a/Aws/Core.hs +++ b/Aws/Core.hs @@ -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: //@/.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 : 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 diff --git a/Aws/DynamoDb.hs b/Aws/DynamoDb.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb.hs @@ -0,0 +1,20 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Aws.DynaboDb +-- Copyright : Ozgun Ataman, Soostone Inc. +-- License : BSD3 +-- +-- Maintainer : Ozgun Ataman +-- Stability : experimental +-- +---------------------------------------------------------------------------- + +module Aws.DynamoDb + ( module Aws.DynamoDb.Core + , module Aws.DynamoDb.Commands + ) where + +------------------------------------------------------------------------------- +import Aws.DynamoDb.Commands +import Aws.DynamoDb.Core +------------------------------------------------------------------------------- diff --git a/Aws/DynamoDb/Commands.hs b/Aws/DynamoDb/Commands.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands.hs @@ -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 +------------------------------------------------------------------------------- diff --git a/Aws/DynamoDb/Commands/BatchGetItem.hs b/Aws/DynamoDb/Commands/BatchGetItem.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/BatchGetItem.hs @@ -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 +-- 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 + + diff --git a/Aws/DynamoDb/Commands/BatchWriteItem.hs b/Aws/DynamoDb/Commands/BatchWriteItem.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/BatchWriteItem.hs @@ -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 +-- 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 diff --git a/Aws/DynamoDb/Commands/DeleteItem.hs b/Aws/DynamoDb/Commands/DeleteItem.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/DeleteItem.hs @@ -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 +-- 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 + + + + + + + + diff --git a/Aws/DynamoDb/Commands/GetItem.hs b/Aws/DynamoDb/Commands/GetItem.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/GetItem.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Aws.DynamoDb.Commands.GetItem +-- Copyright : Soostone Inc +-- License : BSD3 +-- +-- Maintainer : Ozgun Ataman +-- 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 diff --git a/Aws/DynamoDb/Commands/PutItem.hs b/Aws/DynamoDb/Commands/PutItem.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/PutItem.hs @@ -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 +-- 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 + + + + + + + + diff --git a/Aws/DynamoDb/Commands/Query.hs b/Aws/DynamoDb/Commands/Query.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/Query.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Aws.DynamoDb.Commands.Query +-- Copyright : Soostone Inc +-- License : BSD3 +-- +-- Maintainer : Ozgun Ataman +-- 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)) diff --git a/Aws/DynamoDb/Commands/Scan.hs b/Aws/DynamoDb/Commands/Scan.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/Scan.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Aws.DynamoDb.Commands.Scan +-- Copyright : Soostone Inc +-- License : BSD3 +-- +-- Maintainer : Ozgun Ataman +-- 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 } diff --git a/Aws/DynamoDb/Commands/Table.hs b/Aws/DynamoDb/Commands/Table.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/Table.hs @@ -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 diff --git a/Aws/DynamoDb/Commands/UpdateItem.hs b/Aws/DynamoDb/Commands/UpdateItem.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Commands/UpdateItem.hs @@ -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 +-- 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 + + + + + + + + diff --git a/Aws/DynamoDb/Core.hs b/Aws/DynamoDb/Core.hs new file mode 100644 --- /dev/null +++ b/Aws/DynamoDb/Core.hs @@ -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 +-- 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 "" rid `mappend` + ", x-amz-id-2=" `mappend` + fromMaybe "" 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 diff --git a/Aws/Ec2/InstanceMetadata.hs b/Aws/Ec2/InstanceMetadata.hs new file mode 100644 --- /dev/null +++ b/Aws/Ec2/InstanceMetadata.hs @@ -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 diff --git a/Aws/Iam.hs b/Aws/Iam.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam.hs @@ -0,0 +1,7 @@ +module Aws.Iam + ( module Aws.Iam.Commands + , module Aws.Iam.Core + ) where + +import Aws.Iam.Commands +import Aws.Iam.Core diff --git a/Aws/Iam/Commands.hs b/Aws/Iam/Commands.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands.hs @@ -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 diff --git a/Aws/Iam/Commands/AddUserToGroup.hs b/Aws/Iam/Commands/AddUserToGroup.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/AddUserToGroup.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/CreateAccessKey.hs b/Aws/Iam/Commands/CreateAccessKey.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/CreateAccessKey.hs @@ -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. +-- +-- +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. +-- +-- +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 diff --git a/Aws/Iam/Commands/CreateGroup.hs b/Aws/Iam/Commands/CreateGroup.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/CreateGroup.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/CreateUser.hs b/Aws/Iam/Commands/CreateUser.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/CreateUser.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/DeleteAccessKey.hs b/Aws/Iam/Commands/DeleteAccessKey.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/DeleteAccessKey.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/DeleteGroup.hs b/Aws/Iam/Commands/DeleteGroup.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/DeleteGroup.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/DeleteGroupPolicy.hs b/Aws/Iam/Commands/DeleteGroupPolicy.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/DeleteGroupPolicy.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/DeleteUser.hs b/Aws/Iam/Commands/DeleteUser.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/DeleteUser.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/DeleteUserPolicy.hs b/Aws/Iam/Commands/DeleteUserPolicy.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/DeleteUserPolicy.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/GetGroupPolicy.hs b/Aws/Iam/Commands/GetGroupPolicy.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/GetGroupPolicy.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/GetUser.hs b/Aws/Iam/Commands/GetUser.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/GetUser.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/GetUserPolicy.hs b/Aws/Iam/Commands/GetUserPolicy.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/GetUserPolicy.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/ListAccessKeys.hs b/Aws/Iam/Commands/ListAccessKeys.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/ListAccessKeys.hs @@ -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. +-- +-- +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. +-- +-- +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 diff --git a/Aws/Iam/Commands/ListGroupPolicies.hs b/Aws/Iam/Commands/ListGroupPolicies.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/ListGroupPolicies.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/ListGroups.hs b/Aws/Iam/Commands/ListGroups.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/ListGroups.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/ListMfaDevices.hs b/Aws/Iam/Commands/ListMfaDevices.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/ListMfaDevices.hs @@ -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. +-- +-- + +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 diff --git a/Aws/Iam/Commands/ListUserPolicies.hs b/Aws/Iam/Commands/ListUserPolicies.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/ListUserPolicies.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/ListUsers.hs b/Aws/Iam/Commands/ListUsers.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/ListUsers.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/PutGroupPolicy.hs b/Aws/Iam/Commands/PutGroupPolicy.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/PutGroupPolicy.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/PutUserPolicy.hs b/Aws/Iam/Commands/PutUserPolicy.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/PutUserPolicy.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/RemoveUserFromGroup.hs b/Aws/Iam/Commands/RemoveUserFromGroup.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/RemoveUserFromGroup.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/UpdateAccessKey.hs b/Aws/Iam/Commands/UpdateAccessKey.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/UpdateAccessKey.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/UpdateGroup.hs b/Aws/Iam/Commands/UpdateGroup.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/UpdateGroup.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Commands/UpdateUser.hs b/Aws/Iam/Commands/UpdateUser.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Commands/UpdateUser.hs @@ -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. +-- +-- +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 diff --git a/Aws/Iam/Core.hs b/Aws/Iam/Core.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Core.hs @@ -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 "" 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. +-- +-- +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. +-- +-- +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. +-- +-- +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 diff --git a/Aws/Iam/Internal.hs b/Aws/Iam/Internal.hs new file mode 100644 --- /dev/null +++ b/Aws/Iam/Internal.hs @@ -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 diff --git a/Aws/Network.hs b/Aws/Network.hs new file mode 100644 --- /dev/null +++ b/Aws/Network.hs @@ -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 diff --git a/Aws/S3/Commands.hs b/Aws/S3/Commands.hs --- a/Aws/S3/Commands.hs +++ b/Aws/S3/Commands.hs @@ -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 diff --git a/Aws/S3/Commands/CopyObject.hs b/Aws/S3/Commands/CopyObject.hs --- a/Aws/S3/Commands/CopyObject.hs +++ b/Aws/S3/Commands/CopyObject.hs @@ -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 diff --git a/Aws/S3/Commands/DeleteBucket.hs b/Aws/S3/Commands/DeleteBucket.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/DeleteBucket.hs @@ -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 diff --git a/Aws/S3/Commands/DeleteObject.hs b/Aws/S3/Commands/DeleteObject.hs --- a/Aws/S3/Commands/DeleteObject.hs +++ b/Aws/S3/Commands/DeleteObject.hs @@ -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 diff --git a/Aws/S3/Commands/DeleteObjectVersion.hs b/Aws/S3/Commands/DeleteObjectVersion.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/DeleteObjectVersion.hs @@ -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 diff --git a/Aws/S3/Commands/DeleteObjects.hs b/Aws/S3/Commands/DeleteObjects.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/DeleteObjects.hs @@ -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 diff --git a/Aws/S3/Commands/GetBucket.hs b/Aws/S3/Commands/GetBucket.hs --- a/Aws/S3/Commands/GetBucket.hs +++ b/Aws/S3/Commands/GetBucket.hs @@ -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 diff --git a/Aws/S3/Commands/GetBucketLocation.hs b/Aws/S3/Commands/GetBucketLocation.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/GetBucketLocation.hs @@ -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 diff --git a/Aws/S3/Commands/GetBucketObjectVersions.hs b/Aws/S3/Commands/GetBucketObjectVersions.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/GetBucketObjectVersions.hs @@ -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 diff --git a/Aws/S3/Commands/GetBucketVersioning.hs b/Aws/S3/Commands/GetBucketVersioning.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/GetBucketVersioning.hs @@ -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 diff --git a/Aws/S3/Commands/GetObject.hs b/Aws/S3/Commands/GetObject.hs --- a/Aws/S3/Commands/GetObject.hs +++ b/Aws/S3/Commands/GetObject.hs @@ -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 + } diff --git a/Aws/S3/Commands/GetService.hs b/Aws/S3/Commands/GetService.hs --- a/Aws/S3/Commands/GetService.hs +++ b/Aws/S3/Commands/GetService.hs @@ -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' diff --git a/Aws/S3/Commands/HeadObject.hs b/Aws/S3/Commands/HeadObject.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/HeadObject.hs @@ -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) diff --git a/Aws/S3/Commands/Multipart.hs b/Aws/S3/Commands/Multipart.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/Multipart.hs @@ -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 diff --git a/Aws/S3/Commands/PutBucket.hs b/Aws/S3/Commands/PutBucket.hs --- a/Aws/S3/Commands/PutBucket.hs +++ b/Aws/S3/Commands/PutBucket.hs @@ -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 diff --git a/Aws/S3/Commands/PutBucketVersioning.hs b/Aws/S3/Commands/PutBucketVersioning.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/PutBucketVersioning.hs @@ -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 diff --git a/Aws/S3/Commands/PutObject.hs b/Aws/S3/Commands/PutObject.hs --- a/Aws/S3/Commands/PutObject.hs +++ b/Aws/S3/Commands/PutObject.hs @@ -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 diff --git a/Aws/S3/Commands/RestoreObject.hs b/Aws/S3/Commands/RestoreObject.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/RestoreObject.hs @@ -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 diff --git a/Aws/S3/Core.hs b/Aws/S3/Core.hs --- a/Aws/S3/Core.hs +++ b/Aws/S3/Core.hs @@ -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 + -- * + -- * + -- * + 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 +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: +-- 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..amazonaws.com + -- s3-.amazonaws.com + -- s3..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 diff --git a/Aws/Ses/Commands.hs b/Aws/Ses/Commands.hs --- a/Aws/Ses/Commands.hs +++ b/Aws/Ses/Commands.hs @@ -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 diff --git a/Aws/Ses/Commands/DeleteIdentity.hs b/Aws/Ses/Commands/DeleteIdentity.hs new file mode 100644 --- /dev/null +++ b/Aws/Ses/Commands/DeleteIdentity.hs @@ -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 diff --git a/Aws/Ses/Commands/GetIdentityDkimAttributes.hs b/Aws/Ses/Commands/GetIdentityDkimAttributes.hs new file mode 100644 --- /dev/null +++ b/Aws/Ses/Commands/GetIdentityDkimAttributes.hs @@ -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 diff --git a/Aws/Ses/Commands/GetIdentityNotificationAttributes.hs b/Aws/Ses/Commands/GetIdentityNotificationAttributes.hs new file mode 100644 --- /dev/null +++ b/Aws/Ses/Commands/GetIdentityNotificationAttributes.hs @@ -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 diff --git a/Aws/Ses/Commands/GetIdentityVerificationAttributes.hs b/Aws/Ses/Commands/GetIdentityVerificationAttributes.hs new file mode 100644 --- /dev/null +++ b/Aws/Ses/Commands/GetIdentityVerificationAttributes.hs @@ -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 diff --git a/Aws/Ses/Commands/ListIdentities.hs b/Aws/Ses/Commands/ListIdentities.hs new file mode 100644 --- /dev/null +++ b/Aws/Ses/Commands/ListIdentities.hs @@ -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 diff --git a/Aws/Ses/Commands/SendRawEmail.hs b/Aws/Ses/Commands/SendRawEmail.hs --- a/Aws/Ses/Commands/SendRawEmail.hs +++ b/Aws/Ses/Commands/SendRawEmail.hs @@ -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) diff --git a/Aws/Ses/Commands/SetIdentityDkimEnabled.hs b/Aws/Ses/Commands/SetIdentityDkimEnabled.hs new file mode 100644 --- /dev/null +++ b/Aws/Ses/Commands/SetIdentityDkimEnabled.hs @@ -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 diff --git a/Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs b/Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs new file mode 100644 --- /dev/null +++ b/Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs @@ -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 diff --git a/Aws/Ses/Commands/SetIdentityNotificationTopic.hs b/Aws/Ses/Commands/SetIdentityNotificationTopic.hs new file mode 100644 --- /dev/null +++ b/Aws/Ses/Commands/SetIdentityNotificationTopic.hs @@ -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 diff --git a/Aws/Ses/Commands/VerifyDomainDkim.hs b/Aws/Ses/Commands/VerifyDomainDkim.hs new file mode 100644 --- /dev/null +++ b/Aws/Ses/Commands/VerifyDomainDkim.hs @@ -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 diff --git a/Aws/Ses/Commands/VerifyDomainIdentity.hs b/Aws/Ses/Commands/VerifyDomainIdentity.hs new file mode 100644 --- /dev/null +++ b/Aws/Ses/Commands/VerifyDomainIdentity.hs @@ -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 diff --git a/Aws/Ses/Commands/VerifyEmailIdentity.hs b/Aws/Ses/Commands/VerifyEmailIdentity.hs new file mode 100644 --- /dev/null +++ b/Aws/Ses/Commands/VerifyEmailIdentity.hs @@ -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 diff --git a/Aws/Ses/Core.hs b/Aws/Ses/Core.hs --- a/Aws/Ses/Core.hs +++ b/Aws/Ses/Core.hs @@ -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 "" 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 diff --git a/Aws/SimpleDb/Commands/Attributes.hs b/Aws/SimpleDb/Commands/Attributes.hs --- a/Aws/SimpleDb/Commands/Attributes.hs +++ b/Aws/SimpleDb/Commands/Attributes.hs @@ -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 diff --git a/Aws/SimpleDb/Commands/Domain.hs b/Aws/SimpleDb/Commands/Domain.hs --- a/Aws/SimpleDb/Commands/Domain.hs +++ b/Aws/SimpleDb/Commands/Domain.hs @@ -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" diff --git a/Aws/SimpleDb/Commands/Select.hs b/Aws/SimpleDb/Commands/Select.hs --- a/Aws/SimpleDb/Commands/Select.hs +++ b/Aws/SimpleDb/Commands/Select.hs @@ -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 diff --git a/Aws/SimpleDb/Core.hs b/Aws/SimpleDb/Core.hs --- a/Aws/SimpleDb/Core.hs +++ b/Aws/SimpleDb/Core.hs @@ -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 "" 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 diff --git a/Aws/Sqs/Commands/Message.hs b/Aws/Sqs/Commands/Message.hs --- a/Aws/Sqs/Commands/Message.hs +++ b/Aws/Sqs/Commands/Message.hs @@ -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. +-- +-- +-- +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). +-- +-- +-- +-- /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 +-- 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] +-- +-- +-- +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 +-- +-- all fields of @SendMessageResult@ are denoted as optional. +-- At +-- +-- 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 . + + , 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 . + } + 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. +-- +-- +-- +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 +-- +-- 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 +-- . +-- +-- * 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. +-- +-- +-- +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 +-- +-- all elements are denoted as optional. +-- In +-- +-- 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 . + + , 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. +-- +-- +-- +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 diff --git a/Aws/Sqs/Commands/Permission.hs b/Aws/Sqs/Commands/Permission.hs --- a/Aws/Sqs/Commands/Permission.hs +++ b/Aws/Sqs/Commands/Permission.hs @@ -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 {} diff --git a/Aws/Sqs/Commands/Queue.hs b/Aws/Sqs/Commands/Queue.hs --- a/Aws/Sqs/Commands/Queue.hs +++ b/Aws/Sqs/Commands/Queue.hs @@ -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 diff --git a/Aws/Sqs/Commands/QueueAttributes.hs b/Aws/Sqs/Commands/QueueAttributes.hs --- a/Aws/Sqs/Commands/QueueAttributes.hs +++ b/Aws/Sqs/Commands/QueueAttributes.hs @@ -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 {} diff --git a/Aws/Sqs/Core.hs b/Aws/Sqs/Core.hs --- a/Aws/Sqs/Core.hs +++ b/Aws/Sqs/Core.hs @@ -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 "" 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 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. + + diff --git a/Examples/DynamoDb.hs b/Examples/DynamoDb.hs new file mode 100644 --- /dev/null +++ b/Examples/DynamoDb.hs @@ -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 + + diff --git a/Examples/GetObject.hs b/Examples/GetObject.hs --- a/Examples/GetObject.hs +++ b/Examples/GetObject.hs @@ -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" diff --git a/Examples/GetObjectGoogle.hs b/Examples/GetObjectGoogle.hs new file mode 100644 --- /dev/null +++ b/Examples/GetObjectGoogle.hs @@ -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" diff --git a/Examples/GetObjectV4.hs b/Examples/GetObjectV4.hs new file mode 100644 --- /dev/null +++ b/Examples/GetObjectV4.hs @@ -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" diff --git a/Examples/MultipartTransfer.hs b/Examples/MultipartTransfer.hs new file mode 100644 --- /dev/null +++ b/Examples/MultipartTransfer.hs @@ -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" + diff --git a/Examples/MultipartUpload.hs b/Examples/MultipartUpload.hs new file mode 100644 --- /dev/null +++ b/Examples/MultipartUpload.hs @@ -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) diff --git a/Examples/NukeBucket.hs b/Examples/NukeBucket.hs new file mode 100644 --- /dev/null +++ b/Examples/NukeBucket.hs @@ -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 () diff --git a/Examples/PutBucketNearLine.hs b/Examples/PutBucketNearLine.hs new file mode 100644 --- /dev/null +++ b/Examples/PutBucketNearLine.hs @@ -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 diff --git a/Examples/Sqs.hs b/Examples/Sqs.hs new file mode 100644 --- /dev/null +++ b/Examples/Sqs.hs @@ -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 + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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..Commands.` module for each command. For easier +usage, there are the "bundling" modules `Aws` (general support), and +`Aws.`. + +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 + + diff --git a/README.org b/README.org deleted file mode 100644 --- a/README.org +++ /dev/null @@ -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..Commands.= -module for each command. For easier usage, there are the "bundling" modules =Aws= (general support), and =Aws.=. - -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 | diff --git a/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -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 . -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 . +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 diff --git a/tests/DynamoDb/Main.hs b/tests/DynamoDb/Main.hs new file mode 100644 --- /dev/null +++ b/tests/DynamoDb/Main.hs @@ -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 +-- 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 + } + diff --git a/tests/DynamoDb/Utils.hs b/tests/DynamoDb/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/DynamoDb/Utils.hs @@ -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 +-- 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 + } + + diff --git a/tests/S3/Main.hs b/tests/S3/Main.hs new file mode 100644 --- /dev/null +++ b/tests/S3/Main.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module: Main +-- Copyright: Copyright © 2016 Soostone, Inc. +-- License: BSD3 +-- Maintainer: Michael Xavier +-- 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 diff --git a/tests/Sqs/Main.hs b/tests/Sqs/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Sqs/Main.hs @@ -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 +-- 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 + } + diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Utils.hs @@ -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 +-- 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] +