diff --git a/Aws.hs b/Aws.hs --- a/Aws.hs +++ b/Aws.hs @@ -58,6 +58,7 @@ , loadCredentialsFromEnvOrFile , loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault +, anonymousCredentials ) where diff --git a/Aws/Aws.hs b/Aws/Aws.hs --- a/Aws/Aws.hs +++ b/Aws/Aws.hs @@ -35,8 +35,8 @@ 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 @@ -51,7 +51,9 @@ 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 @@ -81,6 +83,7 @@ , credentials :: Credentials -- | The error / message logger. , logger :: Logger + , proxy :: Maybe HTTP.Proxy } -- | The default configuration, with credentials loaded from environment variable or configuration file @@ -89,11 +92,12 @@ baseConfiguration = liftIO $ do cr <- loadCredentialsDefault case cr of - Nothing -> E.throw $ NoCredentialsException "could not locate aws credentials" + Nothing -> E.throwM $ NoCredentialsException "could not locate aws credentials" Just cr' -> return Configuration { timeInfo = Timestamp , credentials = cr' , logger = defaultLog Warning + , proxy = Nothing } -- | Debug configuration, which logs much more verbosely. @@ -189,9 +193,9 @@ -> ServiceConfiguration r NormalQuery -> 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. -- @@ -202,7 +206,6 @@ -- 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) @@ -227,7 +230,6 @@ -- 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 @@ -235,10 +237,13 @@ 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 $ queryToHttpRequest 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) @@ -247,7 +252,7 @@ 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 request metadataRef hresp + {-# 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. -- @@ -291,7 +296,7 @@ -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r - -> C.Producer (ResourceT IO) (Response (ResponseMetadata a) a) + -> forall i. C.ConduitT i (Response (ResponseMetadata a) a) (ResourceT IO) () awsIteratedSource cfg scfg manager req_ = awsIteratedSource' run req_ where run r = do @@ -306,7 +311,7 @@ -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r - -> C.Producer (ResourceT IO) i + -> 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 @@ -322,7 +327,7 @@ -- ^ A runner function for executing transactions. -> r -- ^ An initial request - -> C.Producer m b + -> forall i. C.ConduitT i b m () awsIteratedSource' run r0 = go r0 where go q = do @@ -343,9 +348,9 @@ -- ^ A runner function for executing transactions. -> r -- ^ An initial request - -> C.Producer m c + -> forall i. C.ConduitT i c m () awsIteratedList' run r0 = - awsIteratedSource' run' r0 C.=$= + awsIteratedSource' run' r0 `C.fuse` CL.concatMap listResponse where dupl a = (a,a) diff --git a/Aws/Core.hs b/Aws/Core.hs --- a/Aws/Core.hs +++ b/Aws/Core.hs @@ -22,6 +22,7 @@ , HeaderException(..) , FormException(..) , NoCredentialsException(..) +, throwStatusCodeException -- ** Response deconstruction helpers , readHex2 -- *** XML @@ -29,6 +30,7 @@ , elCont , force , forceM +, textReadBool , textReadInt , readInt , xmlCursorConsumer @@ -50,7 +52,10 @@ , AuthorizationHash(..) , amzHash , signature +, credentialV4 , authorizationV4 +, authorizationV4' +, signatureV4 -- ** Query construction helpers , queryList , awsBool @@ -79,6 +84,7 @@ , loadCredentialsFromEnvOrFile , loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault +, anonymousCredentials -- * Service configuration , DefaultServiceConfiguration(..) -- * HTTP types @@ -98,9 +104,10 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource (ResourceT, MonadThrow (throwM)) -import Crypto.Hash +import qualified Crypto.Hash as CH +import qualified Crypto.MAC.HMAC as CMH import qualified Data.Aeson as A -import Data.Byteable +import qualified Data.ByteArray as ByteArray import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as Base16 @@ -109,10 +116,13 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as BU import Data.Char -import Data.Conduit (($$+-)) +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.Default (def) +import Data.Kind import Data.IORef import Data.List import qualified Data.Map as M @@ -126,18 +136,18 @@ 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 Data.Time.Format -#else +#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). @@ -175,7 +185,7 @@ (<*>) = ap instance Monoid m => Monad (Response m) where - return x = Response mempty (Right x) + 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 @@ -188,7 +198,7 @@ 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. @@ -201,22 +211,23 @@ -- 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 = do - bss <- HTTP.responseBody resp $$+- CL.consume + 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. @@ -253,9 +264,11 @@ , v4SigningKeys :: IORef [V4Key] -- | Signed IAM token , iamToken :: Maybe B.ByteString + -- | Set when the credentials are intended for anonymous access. + , isAnonymousCredentials :: Bool } instance Show Credentials where - show c = "Credentials{accessKeyID=" ++ show (accessKeyID c) ++ ",secretAccessKey=" ++ show (secretAccessKey c) ++ ",iamToken=" ++ show (iamToken c) ++ "}" + 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 @@ -264,6 +277,7 @@ 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'. @@ -317,8 +331,8 @@ Traversable.sequence $ makeCredentials' <$> keyID <*> secret loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials) -loadCredentialsFromInstanceMetadata = liftIO $ HTTP.withManager $ \mgr -> - do +loadCredentialsFromInstanceMetadata = do + mgr <- liftIO HTTP.getGlobalManager -- check if the path is routable avail <- liftIO $ hostAvailable "169.254.169.254" if not avail @@ -341,7 +355,8 @@ return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID) <*> (T.encodeUtf8 . T.pack <$> secret) <*> return ref - <*> (Just . T.encodeUtf8 . T.pack <$> token)) + <*> (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. @@ -385,6 +400,13 @@ 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 @@ -438,31 +460,23 @@ -- | Request body content type. , sqContentType :: !(Maybe B.ByteString) -- | Request body content MD5. - , sqContentMd5 :: !(Maybe (Digest MD5)) + , sqContentMd5 :: !(Maybe (CH.Digest CH.MD5)) -- | Additional Amazon "amz" headers. , sqAmzHeaders :: !HTTP.RequestHeaders -- | Additional non-"amz" headers. , sqOtherHeaders :: !HTTP.RequestHeaders -- | Request body (used with 'Post' and 'Put'). -#if MIN_VERSION_http_conduit(2, 0, 0) , sqBody :: !(Maybe HTTP.RequestBody) -#else - , sqBody :: !(Maybe (HTTP.RequestBody (C.ResourceT IO))) -#endif -- | String to sign. Note that the string is already signed, this is passed mostly for debugging purposes. , sqStringToSign :: !B.ByteString } --deriving (Show) -- | Create a HTTP request from a 'SignedQuery' object. -#if MIN_VERSION_http_conduit(2, 0, 0) queryToHttpRequest :: SignedQuery -> IO HTTP.Request -#else -queryToHttpRequest :: SignedQuery -> IO (HTTP.Request (C.ResourceT IO)) -#endif queryToHttpRequest SignedQuery{..} = do mauth <- maybe (return Nothing) (Just<$>) sqAuthorization - return $ def { + return $ HTTP.defaultRequest { HTTP.method = httpMethod sqMethod , HTTP.secure = case sqProtocol of HTTP -> False @@ -477,13 +491,13 @@ , HTTP.requestHeaders = catMaybes [ checkDate (\d -> ("Date", fmtRfc822Time d)) sqDate , fmap (\c -> ("Content-Type", c)) contentType - , fmap (\md5 -> ("Content-MD5", Base64.encode $ toBytes md5)) sqContentMd5 + , fmap (\md5 -> ("Content-MD5", Base64.encode $ ByteArray.convert md5)) sqContentMd5 , fmap (\auth -> ("Authorization", auth)) mauth] ++ sqAmzHeaders ++ sqOtherHeaders , HTTP.requestBody = - -- An explicityly defined body parameter should overwrite everything else. + -- An explicitly defined body parameter should overwrite everything else. case sqBody of Just x -> x Nothing -> @@ -494,7 +508,11 @@ _ -> HTTP.RequestBodyBuilder 0 mempty , HTTP.decompress = HTTP.alwaysDecompress - , HTTP.checkStatus = \_ _ _ -> Nothing +#if MIN_VERSION_http_conduit(2,2,0) + , HTTP.checkResponse = \_ _ -> return () +#else + , HTTP.checkStatus = \_ _ _-> Nothing +#endif , HTTP.redirectCount = 10 } @@ -506,7 +524,7 @@ 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 @@ -573,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 @@ -596,11 +614,29 @@ signature cr ah input = Base64.encode sig where sig = case ah of - HmacSHA1 -> computeSig SHA1 - HmacSHA256 -> computeSig SHA256 - computeSig :: HashAlgorithm a => a -> ByteString - computeSig t = toBytes (hmacAlg t (secretAccessKey cr) input) + 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. @@ -614,69 +650,129 @@ authorizationV4 sd ah region service headers canonicalRequest = do let ref = v4SigningKeys $ signatureCredentials sd date = fmtTime "%Y%m%d" $ signatureTime sd - mkHmac k i = case ah of - HmacSHA1 -> toBytes (hmac k i :: HMAC SHA1) - HmacSHA256 -> toBytes (hmac k i :: HMAC SHA256) - mkHash i = case ah of - HmacSHA1 -> toBytes (hash i :: Digest SHA1) - HmacSHA256 -> toBytes (hash i :: Digest SHA256) - alg = case ah of - HmacSHA1 -> "AWS4-HMAC-SHA1" - HmacSHA256 -> "AWS4-HMAC-SHA256" -- 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 + Just (d,k) | d /= date -> Nothing + | otherwise -> Just k + Nothing -> Nothing -- possibly create a new signing key - key <- case mkey of - Just k -> return k - Nothing -> atomicModifyIORef ref $ \keylist -> - let secretKey = secretAccessKey $ signatureCredentials sd - kDate = mkHmac ("AWS4" <> secretKey) date - kRegion = mkHmac kDate region - kService = mkHmac kRegion service - kSigning = mkHmac kService "aws4_request" - lstK = (region,service) - keylist' = (lstK,(date,kSigning)) : filter ((lstK/=).fst) keylist - in (keylist', kSigning) - - -- now do the signature - let 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 - ] - sig = Base16.encode $ mkHmac key stringToSign + 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 - return $ B.concat [ alg - , " Credential=" - , accessKeyID (signatureCredentials sd) - , "/" - , date - , "/" - , region - , "/" - , service - , "/aws4_request," - , "SignedHeaders=" - , headers - , ",Signature=" - , sig - ] + 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. @@ -720,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 @@ -741,7 +837,7 @@ <|> p "%a %b %_d %H:%M:%S %Y" s -- asctime-date <|> 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 = parseTime defaultTimeLocale + where p = parseTimeM True defaultTimeLocale -- | HTTP-date (section 3.3.1 of RFC 2616, first type - RFC1123-style) httpDate1 :: String @@ -792,6 +888,14 @@ 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] @@ -809,6 +913,13 @@ 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 :: (MonadThrow m, Num a) => T.Text -> m a textReadInt s = case reads $ T.unpack s of @@ -832,7 +943,7 @@ -> 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 diff --git a/Aws/DynamoDb/Commands.hs b/Aws/DynamoDb/Commands.hs --- a/Aws/DynamoDb/Commands.hs +++ b/Aws/DynamoDb/Commands.hs @@ -1,5 +1,7 @@ module Aws.DynamoDb.Commands - ( module Aws.DynamoDb.Commands.DeleteItem + ( 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 @@ -9,6 +11,8 @@ ) 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 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 --- a/Aws/DynamoDb/Commands/DeleteItem.hs +++ b/Aws/DynamoDb/Commands/DeleteItem.hs @@ -26,6 +26,7 @@ import Data.Aeson import Data.Default import qualified Data.Text as T +import Prelude ------------------------------------------------------------------------------- import Aws.Core import Aws.DynamoDb.Core @@ -38,7 +39,7 @@ , diKey :: PrimaryKey -- ^ The item to delete. , diExpect :: Conditions - -- ^ (Possible) set of expections for a conditional Put + -- ^ (Possible) set of exceptions for a conditional Put , diReturn :: UpdateReturn -- ^ What to return from this query. , diRetCons :: ReturnConsumption @@ -97,7 +98,7 @@ instance ResponseConsumer r DeleteItemResponse where type ResponseMetadata DeleteItemResponse = DdbResponse - responseConsumer _ ref resp = ddbResponseConsumer ref resp + responseConsumer _ _ ref resp = ddbResponseConsumer ref resp instance AsMemoryResponse DeleteItemResponse where diff --git a/Aws/DynamoDb/Commands/GetItem.hs b/Aws/DynamoDb/Commands/GetItem.hs --- a/Aws/DynamoDb/Commands/GetItem.hs +++ b/Aws/DynamoDb/Commands/GetItem.hs @@ -19,6 +19,7 @@ import Data.Aeson import Data.Default import qualified Data.Text as T +import Prelude ------------------------------------------------------------------------------- import Aws.Core import Aws.DynamoDb.Core @@ -84,7 +85,7 @@ instance ResponseConsumer r GetItemResponse where type ResponseMetadata GetItemResponse = DdbResponse - responseConsumer _ ref resp = ddbResponseConsumer ref resp + responseConsumer _ _ ref resp = ddbResponseConsumer ref resp instance AsMemoryResponse GetItemResponse where diff --git a/Aws/DynamoDb/Commands/PutItem.hs b/Aws/DynamoDb/Commands/PutItem.hs --- a/Aws/DynamoDb/Commands/PutItem.hs +++ b/Aws/DynamoDb/Commands/PutItem.hs @@ -26,6 +26,7 @@ import Data.Aeson import Data.Default import qualified Data.Text as T +import Prelude ------------------------------------------------------------------------------- import Aws.Core import Aws.DynamoDb.Core @@ -39,7 +40,7 @@ -- ^ An item to Put. Attributes here will replace what maybe under -- the key on DDB. , piExpect :: Conditions - -- ^ (Possible) set of expections for a conditional Put + -- ^ (Possible) set of exceptions for a conditional Put , piReturn :: UpdateReturn -- ^ What to return from this query. , piRetCons :: ReturnConsumption @@ -98,7 +99,7 @@ instance ResponseConsumer r PutItemResponse where type ResponseMetadata PutItemResponse = DdbResponse - responseConsumer _ ref resp = ddbResponseConsumer ref resp + responseConsumer _ _ ref resp = ddbResponseConsumer ref resp instance AsMemoryResponse PutItemResponse where diff --git a/Aws/DynamoDb/Commands/Query.hs b/Aws/DynamoDb/Commands/Query.hs --- a/Aws/DynamoDb/Commands/Query.hs +++ b/Aws/DynamoDb/Commands/Query.hs @@ -135,7 +135,8 @@ instance ResponseConsumer r QueryResponse where type ResponseMetadata QueryResponse = DdbResponse - responseConsumer _ ref resp = ddbResponseConsumer ref resp + responseConsumer _ _ ref resp + = ddbResponseConsumer ref resp instance AsMemoryResponse QueryResponse where diff --git a/Aws/DynamoDb/Commands/Scan.hs b/Aws/DynamoDb/Commands/Scan.hs --- a/Aws/DynamoDb/Commands/Scan.hs +++ b/Aws/DynamoDb/Commands/Scan.hs @@ -114,7 +114,7 @@ instance ResponseConsumer r ScanResponse where type ResponseMetadata ScanResponse = DdbResponse - responseConsumer _ ref resp = ddbResponseConsumer ref resp + responseConsumer _ _ ref resp = ddbResponseConsumer ref resp instance AsMemoryResponse ScanResponse where diff --git a/Aws/DynamoDb/Commands/Table.hs b/Aws/DynamoDb/Commands/Table.hs --- a/Aws/DynamoDb/Commands/Table.hs +++ b/Aws/DynamoDb/Commands/Table.hs @@ -35,15 +35,17 @@ 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 qualified Data.HashMap.Strict as M +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 @@ -62,6 +64,10 @@ 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 @@ -210,8 +216,8 @@ instance A.FromJSON ProvisionedThroughputStatus where parseJSON = A.withObject "Throughput status must be an object" $ \o -> ProvisionedThroughputStatus - <$> (posixSecondsToUTCTime . fromInteger <$> o .:? "LastDecreaseDateTime" .!= 0) - <*> (posixSecondsToUTCTime . fromInteger <$> o .:? "LastIncreaseDateTime" .!= 0) + <$> (convertToUTCTime <$> o .:? "LastDecreaseDateTime" .!= 0) + <*> (convertToUTCTime <$> o .:? "LastIncreaseDateTime" .!= 0) <*> o .:? "NumberOfDecreasesToday" .!= 0 <*> o .: "ReadCapacityUnits" <*> o .: "WriteCapacityUnits" @@ -275,14 +281,14 @@ instance A.FromJSON TableDescription where parseJSON = A.withObject "Table must be an object" $ \o -> do - t <- case (M.lookup "Table" o, M.lookup "TableDescription" o) of + 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 (posixSecondsToUTCTime . fromInteger) <$> t .:? "CreationDateTime") + <*> (fmap convertToUTCTime <$> t .:? "CreationDateTime") <*> t .: "ItemCount" <*> t .:? "AttributeDefinitions" .!= [] <*> t .:? "KeySchema" @@ -293,7 +299,7 @@ {- Can't derive these instances onto the return values instance ResponseConsumer r TableDescription where type ResponseMetadata TableDescription = DyMetadata - responseConsumer _ _ = ddbResponseConsumer + responseConsumer _ _ _ = ddbResponseConsumer instance AsMemoryResponse TableDescription where type MemoryResponse TableDescription = TableDescription loadToMemory = return @@ -351,7 +357,7 @@ -- ResponseConsumer and AsMemoryResponse can't be derived instance ResponseConsumer r CreateTableResult where type ResponseMetadata CreateTableResult = DdbResponse - responseConsumer _ = ddbResponseConsumer + responseConsumer _ _ = ddbResponseConsumer instance AsMemoryResponse CreateTableResult where type MemoryResponse CreateTableResult = TableDescription loadToMemory = return . ctStatus @@ -376,7 +382,7 @@ -- ResponseConsumer can't be derived instance ResponseConsumer r DescribeTableResult where type ResponseMetadata DescribeTableResult = DdbResponse - responseConsumer _ = ddbResponseConsumer + responseConsumer _ _ = ddbResponseConsumer instance AsMemoryResponse DescribeTableResult where type MemoryResponse DescribeTableResult = TableDescription loadToMemory = return . dtStatus @@ -408,7 +414,7 @@ -- ResponseConsumer can't be derived instance ResponseConsumer r UpdateTableResult where type ResponseMetadata UpdateTableResult = DdbResponse - responseConsumer _ = ddbResponseConsumer + responseConsumer _ _ = ddbResponseConsumer instance AsMemoryResponse UpdateTableResult where type MemoryResponse UpdateTableResult = TableDescription loadToMemory = return . uStatus @@ -433,7 +439,7 @@ -- ResponseConsumer can't be derived instance ResponseConsumer r DeleteTableResult where type ResponseMetadata DeleteTableResult = DdbResponse - responseConsumer _ = ddbResponseConsumer + responseConsumer _ _ = ddbResponseConsumer instance AsMemoryResponse DeleteTableResult where type MemoryResponse DeleteTableResult = TableDescription loadToMemory = return . dStatus @@ -459,7 +465,7 @@ parseJSON = A.genericParseJSON capitalizeOpt instance ResponseConsumer r ListTablesResult where type ResponseMetadata ListTablesResult = DdbResponse - responseConsumer _ = ddbResponseConsumer + responseConsumer _ _ = ddbResponseConsumer instance AsMemoryResponse ListTablesResult where type MemoryResponse ListTablesResult = [T.Text] loadToMemory = return . tableNames diff --git a/Aws/DynamoDb/Commands/UpdateItem.hs b/Aws/DynamoDb/Commands/UpdateItem.hs --- a/Aws/DynamoDb/Commands/UpdateItem.hs +++ b/Aws/DynamoDb/Commands/UpdateItem.hs @@ -25,15 +25,16 @@ , AttributeUpdate(..) , au , UpdateAction(..) - , UpdateItem(..) , 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 @@ -91,9 +92,9 @@ toJSON = object . map mk . getAttributeUpdates where mk AttributeUpdate { auAction = UDelete, auAttr = auAttr } = - (attrName auAttr) .= object + (AK.fromText (attrName auAttr)) .= object ["Action" .= UDelete] - mk AttributeUpdate { .. } = (attrName auAttr) .= object + mk AttributeUpdate { .. } = AK.fromText (attrName auAttr) .= object ["Value" .= (attrVal auAttr), "Action" .= auAction] @@ -104,7 +105,7 @@ -- -- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_UpdateItem.html@ data UpdateAction - = UPut -- ^ Simpley write, overwriting any previous value + = 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) @@ -158,7 +159,7 @@ instance ResponseConsumer r UpdateItemResponse where type ResponseMetadata UpdateItemResponse = DdbResponse - responseConsumer _ ref resp = ddbResponseConsumer ref resp + responseConsumer _ _ ref resp = ddbResponseConsumer ref resp instance AsMemoryResponse UpdateItemResponse where diff --git a/Aws/DynamoDb/Core.hs b/Aws/DynamoDb/Core.hs --- a/Aws/DynamoDb/Core.hs +++ b/Aws/DynamoDb/Core.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -31,6 +32,7 @@ , ddbUsWest1 , ddbUsWest2 , ddbEuWest1 + , ddbEuWest2 , ddbEuCentral1 , ddbApNe1 , ddbApSe1 @@ -118,16 +120,22 @@ 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 Crypto.Hash +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 Data.Byteable +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 @@ -136,13 +144,13 @@ import Data.Conduit.Attoparsec (sinkParser) import Data.Default import Data.Function (on) -import qualified Data.HashMap.Strict as HM import Data.Int import Data.IORef import Data.List import qualified Data.Map as M import Data.Maybe -import Data.Monoid +import Data.Monoid () +import qualified Data.Semigroup as Sem import Data.Proxy import Data.Scientific import qualified Data.Serialize as Ser @@ -399,7 +407,7 @@ ------------------------------------------------------------------------------- pico :: Rational -pico = toRational $ 10 ^ (12 :: Integer) +pico = toRational $ (10 :: Integer) ^ (12 :: Integer) ------------------------------------------------------------------------------- @@ -530,9 +538,18 @@ toJSON (PrimaryKey h (Just r)) = let Object p1 = toJSON h Object p2 = toJSON r - in Object (p1 `HM.union` p2) + 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 @@ -646,9 +663,9 @@ ------------------------------------------------------------------------------- -- | Parse a JSON object that contains attributes parseAttributeJson :: Value -> A.Parser [Attribute] -parseAttributeJson (Object v) = mapM conv $ HM.toList v +parseAttributeJson (Object v) = mapM conv $ KM.toList v where - conv (k, o) = Attribute k <$> parseJSON o + conv (k, o) = Attribute (AK.toText k) <$> parseJSON o parseAttributeJson _ = error "Attribute JSON must be an Object" @@ -659,7 +676,7 @@ -- | Convert into JSON pair attributeJson :: Attribute -> Pair -attributeJson (Attribute nm v) = nm .= v +attributeJson (Attribute nm v) = AK.fromText nm .= v ------------------------------------------------------------------------------- @@ -739,9 +756,12 @@ ", 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 a b = DdbResponse (ddbrCrc a `mplus` ddbrCrc b) (ddbrMsgId a `mplus` ddbrMsgId b) + mappend = (Sem.<>) data Region = Region { @@ -784,6 +804,9 @@ 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" @@ -839,11 +862,11 @@ sigTime = fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime sd bodyLBS = A.encode body - bodyHash = Base16.encode $ toBytes (hashlazy bodyLBS :: Digest SHA256) + 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 <> target) + , ("x-amz-target", dyApiVersion Sem.<> target) ] canonicalHeaders = sortBy (compare `on` fst) $ amzHeaders ++ @@ -882,7 +905,7 @@ ------------------------------------------------------------------------------- ddbResponseConsumer :: A.FromJSON a => IORef DdbResponse -> HTTPResponseConsumer a ddbResponseConsumer ref resp = do - val <- HTTP.responseBody resp $$+- sinkParser (A.json' <* AttoB.endOfInput) + val <- runConduit $ HTTP.responseBody resp .| sinkParser (A.json' <* AttoB.endOfInput) case statusCode of 200 -> rSuccess val _ -> rError val @@ -941,7 +964,7 @@ where a = if null es then [] - else [key .= object (map conditionJson es)] + else [AK.fromText key .= object (map conditionJson es)] b = if length (take 2 es) > 1 then ["ConditionalOperator" .= String (rendCondOp op) ] @@ -1025,7 +1048,7 @@ conditionJson :: Condition -> Pair -conditionJson Condition{..} = condAttr .= condOp +conditionJson Condition{..} = AK.fromText condAttr .= condOp instance ToJSON CondOp where @@ -1055,12 +1078,12 @@ instance FromJSON ConsumedCapacity where - parseJSON (Object v) = ConsumedCapacity - <$> v .: "CapacityUnits" - <*> (HM.toList <$> v .:? "GlobalSecondaryIndexes" .!= mempty) - <*> (HM.toList <$> v .:? "LocalSecondaryIndexes" .!= mempty) - <*> (v .:? "Table" >>= maybe (return Nothing) (.: "CapacityUnits")) - <*> v .: "TableName" + 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." @@ -1094,10 +1117,10 @@ instance FromJSON ItemCollectionMetrics where - parseJSON (Object v) = ItemCollectionMetrics - <$> (do m <- v .: "ItemCollectionKey" - return $ head $ HM.toList m) - <*> v .: "SizeEstimateRangeGB" + 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." @@ -1142,6 +1165,7 @@ instance Default QuerySelect where def = SelectAll ------------------------------------------------------------------------------- +querySelectJson :: KeyValue A.Value t => QuerySelect -> [t] querySelectJson (SelectSpecific as) = [ "Select" .= String "SPECIFIC_ATTRIBUTES" , "AttributesToGet" .= as] @@ -1230,18 +1254,26 @@ m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks in runParser m kf ks' {-# INLINE (>>=) #-} - return a = Parser $ \_kf ks -> ks a + 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 = return + pure a = Parser $ \_kf ks -> ks a {-# INLINE pure #-} (<*>) = apP {-# INLINE (<*>) #-} @@ -1259,10 +1291,14 @@ 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 = mplus + mappend = (Sem.<>) {-# INLINE mappend #-} apP :: Parser (a -> b) -> Parser a -> Parser b @@ -1316,8 +1352,8 @@ valErr :: forall a. Typeable a => Tagged a DValue -> String -valErr (Tagged dv) = "Can't convert DynamoDb value " <> show dv <> - " into type " <> (show (typeOf (undefined :: a))) +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 @@ -1331,14 +1367,14 @@ -> Parser a getAttr k m = do case M.lookup k m of - Nothing -> fail ("Key " <> T.unpack k <> " not found") + 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. (Typeable a, DynVal a) + :: forall a. (DynVal a) => T.Text -- ^ Attribute name -> Item @@ -1359,9 +1395,9 @@ -> Parser a parseAttr k m = case M.lookup k m of - Nothing -> fail ("Key " <> T.unpack k <> " not found") - Just (DMap dv) -> either (fail "...") return $ fromItem dv - _ -> fail ("Key " <> T.unpack k <> " is not a map!") + 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' diff --git a/Aws/Ec2/InstanceMetadata.hs b/Aws/Ec2/InstanceMetadata.hs --- a/Aws/Ec2/InstanceMetadata.hs +++ b/Aws/Ec2/InstanceMetadata.hs @@ -8,6 +8,7 @@ import Data.ByteString.Lazy.UTF8 as BU import Data.Typeable import qualified Network.HTTP.Conduit as HTTP +import Prelude data InstanceMetadataException = MetadataNotFound String @@ -16,8 +17,9 @@ instance Exception InstanceMetadataException getInstanceMetadata :: HTTP.Manager -> String -> String -> IO L.ByteString -getInstanceMetadata mgr p x = do req <- HTTP.parseUrl ("http://169.254.169.254/" ++ p ++ '/' : x) - HTTP.responseBody <$> HTTP.httpLbs req mgr +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 "" diff --git a/Aws/Iam/Commands.hs b/Aws/Iam/Commands.hs --- a/Aws/Iam/Commands.hs +++ b/Aws/Iam/Commands.hs @@ -1,31 +1,51 @@ module Aws.Iam.Commands - ( module Aws.Iam.Commands.CreateAccessKey + ( 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 --- a/Aws/Iam/Commands/CreateAccessKey.hs +++ b/Aws/Iam/Commands/CreateAccessKey.hs @@ -16,6 +16,7 @@ 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 @@ -58,7 +59,7 @@ instance ResponseConsumer CreateAccessKey CreateAccessKeyResponse where type ResponseMetadata CreateAccessKeyResponse = IamMetadata - responseConsumer _ + responseConsumer _ _ = iamResponseConsumer $ \cursor -> do let attr name = force ("Missing " ++ Text.unpack name) $ cursor $// elContent name 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 --- a/Aws/Iam/Commands/CreateUser.hs +++ b/Aws/Iam/Commands/CreateUser.hs @@ -14,6 +14,7 @@ import Control.Applicative import Data.Text (Text) import Data.Typeable +import Prelude -- | Creates a new user. -- @@ -41,8 +42,9 @@ instance ResponseConsumer CreateUser CreateUserResponse where type ResponseMetadata CreateUserResponse = IamMetadata - responseConsumer _ = iamResponseConsumer $ - fmap CreateUserResponse . parseUser + responseConsumer _ _ + = iamResponseConsumer $ + fmap CreateUserResponse . parseUser instance Transaction CreateUser CreateUserResponse diff --git a/Aws/Iam/Commands/DeleteAccessKey.hs b/Aws/Iam/Commands/DeleteAccessKey.hs --- a/Aws/Iam/Commands/DeleteAccessKey.hs +++ b/Aws/Iam/Commands/DeleteAccessKey.hs @@ -13,6 +13,7 @@ import Control.Applicative import Data.Text (Text) import Data.Typeable +import Prelude -- | Deletes the access key associated with the specified user. -- @@ -39,7 +40,8 @@ instance ResponseConsumer DeleteAccessKey DeleteAccessKeyResponse where type ResponseMetadata DeleteAccessKeyResponse = IamMetadata - responseConsumer _ = iamResponseConsumer (const $ return DeleteAccessKeyResponse) + responseConsumer _ _ + = iamResponseConsumer (const $ return DeleteAccessKeyResponse) instance Transaction DeleteAccessKey DeleteAccessKeyResponse 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 --- a/Aws/Iam/Commands/DeleteUser.hs +++ b/Aws/Iam/Commands/DeleteUser.hs @@ -27,7 +27,8 @@ instance ResponseConsumer DeleteUser DeleteUserResponse where type ResponseMetadata DeleteUserResponse = IamMetadata - responseConsumer _ = iamResponseConsumer (const $ return DeleteUserResponse) + responseConsumer _ _ + = iamResponseConsumer (const $ return DeleteUserResponse) instance Transaction DeleteUser DeleteUserResponse diff --git a/Aws/Iam/Commands/DeleteUserPolicy.hs b/Aws/Iam/Commands/DeleteUserPolicy.hs --- a/Aws/Iam/Commands/DeleteUserPolicy.hs +++ b/Aws/Iam/Commands/DeleteUserPolicy.hs @@ -37,7 +37,8 @@ instance ResponseConsumer DeleteUserPolicy DeleteUserPolicyResponse where type ResponseMetadata DeleteUserPolicyResponse = IamMetadata - responseConsumer _ = iamResponseConsumer (const $ return DeleteUserPolicyResponse) + responseConsumer _ _ = + iamResponseConsumer (const $ return DeleteUserPolicyResponse) instance Transaction DeleteUserPolicy DeleteUserPolicyResponse 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 --- a/Aws/Iam/Commands/GetUser.hs +++ b/Aws/Iam/Commands/GetUser.hs @@ -13,8 +13,9 @@ import Control.Applicative import Data.Text (Text) import Data.Typeable +import Prelude --- | Retreives information about the given user. +-- | 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. @@ -33,8 +34,8 @@ instance ResponseConsumer GetUser GetUserResponse where type ResponseMetadata GetUserResponse = IamMetadata - responseConsumer _ = iamResponseConsumer $ - fmap GetUserResponse . parseUser + responseConsumer _ _ = iamResponseConsumer $ + fmap GetUserResponse . parseUser instance Transaction GetUser GetUserResponse diff --git a/Aws/Iam/Commands/GetUserPolicy.hs b/Aws/Iam/Commands/GetUserPolicy.hs --- a/Aws/Iam/Commands/GetUserPolicy.hs +++ b/Aws/Iam/Commands/GetUserPolicy.hs @@ -16,8 +16,9 @@ import Data.Typeable import qualified Network.HTTP.Types as HTTP import Text.XML.Cursor (($//)) +import Prelude --- | Retreives the specified policy document for the specified user. +-- | Retrieves the specified policy document for the specified user. -- -- data GetUserPolicy @@ -50,7 +51,7 @@ instance ResponseConsumer GetUserPolicy GetUserPolicyResponse where type ResponseMetadata GetUserPolicyResponse = IamMetadata - responseConsumer _ + responseConsumer _ _ = iamResponseConsumer $ \cursor -> do let attr name = force ("Missing " ++ Text.unpack name) $ cursor $// elContent name diff --git a/Aws/Iam/Commands/ListAccessKeys.hs b/Aws/Iam/Commands/ListAccessKeys.hs --- a/Aws/Iam/Commands/ListAccessKeys.hs +++ b/Aws/Iam/Commands/ListAccessKeys.hs @@ -14,6 +14,7 @@ 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. @@ -71,7 +72,7 @@ instance ResponseConsumer ListAccessKeys ListAccessKeysResponse where type ResponseMetadata ListAccessKeysResponse = IamMetadata - responseConsumer _ + responseConsumer _ _ = iamResponseConsumer $ \cursor -> do (lakrIsTruncated, lakrMarker) <- markedIterResponse cursor lakrAccessKeyMetadata <- sequence $ 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 --- a/Aws/Iam/Commands/ListMfaDevices.hs +++ b/Aws/Iam/Commands/ListMfaDevices.hs @@ -12,6 +12,7 @@ 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 @@ -60,7 +61,7 @@ instance ResponseConsumer ListMfaDevices ListMfaDevicesResponse where type ResponseMetadata ListMfaDevicesResponse = IamMetadata - responseConsumer _req = + responseConsumer _ _req = iamResponseConsumer $ \ cursor -> do (lmfarIsTruncated, lmfarMarker) <- markedIterResponse cursor lmfarMfaDevices <- diff --git a/Aws/Iam/Commands/ListUserPolicies.hs b/Aws/Iam/Commands/ListUserPolicies.hs --- a/Aws/Iam/Commands/ListUserPolicies.hs +++ b/Aws/Iam/Commands/ListUserPolicies.hs @@ -52,7 +52,7 @@ instance ResponseConsumer ListUserPolicies ListUserPoliciesResponse where type ResponseMetadata ListUserPoliciesResponse = IamMetadata - responseConsumer _ + responseConsumer _ _ = iamResponseConsumer $ \cursor -> do (luprIsTruncated, luprMarker) <- markedIterResponse cursor let luprPolicyNames = cursor $// laxElement "member" &/ content diff --git a/Aws/Iam/Commands/ListUsers.hs b/Aws/Iam/Commands/ListUsers.hs --- a/Aws/Iam/Commands/ListUsers.hs +++ b/Aws/Iam/Commands/ListUsers.hs @@ -14,6 +14,7 @@ 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. @@ -55,7 +56,7 @@ instance ResponseConsumer ListUsers ListUsersResponse where type ResponseMetadata ListUsersResponse = IamMetadata - responseConsumer _ + responseConsumer _ _ = iamResponseConsumer $ \cursor -> do (lurIsTruncated, lurMarker) <- markedIterResponse cursor lurUsers <- sequence $ 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 --- a/Aws/Iam/Commands/PutUserPolicy.hs +++ b/Aws/Iam/Commands/PutUserPolicy.hs @@ -41,7 +41,7 @@ instance ResponseConsumer PutUserPolicy PutUserPolicyResponse where type ResponseMetadata PutUserPolicyResponse = IamMetadata - responseConsumer _ + responseConsumer _ _ = iamResponseConsumer (const $ return PutUserPolicyResponse) instance Transaction PutUserPolicy PutUserPolicyResponse 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 --- a/Aws/Iam/Commands/UpdateAccessKey.hs +++ b/Aws/Iam/Commands/UpdateAccessKey.hs @@ -13,6 +13,7 @@ import Control.Applicative import Data.Text (Text) import Data.Typeable +import Prelude -- | Changes the status of the specified access key. -- @@ -47,7 +48,7 @@ instance ResponseConsumer UpdateAccessKey UpdateAccessKeyResponse where type ResponseMetadata UpdateAccessKeyResponse = IamMetadata - responseConsumer _ + responseConsumer _ _ = iamResponseConsumer (const $ return UpdateAccessKeyResponse) instance Transaction UpdateAccessKey UpdateAccessKeyResponse 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 --- a/Aws/Iam/Commands/UpdateUser.hs +++ b/Aws/Iam/Commands/UpdateUser.hs @@ -13,6 +13,7 @@ import Control.Applicative import Data.Text (Text) import Data.Typeable +import Prelude -- | Updates the name and/or path of the specified user. -- @@ -42,7 +43,7 @@ instance ResponseConsumer UpdateUser UpdateUserResponse where type ResponseMetadata UpdateUserResponse = IamMetadata - responseConsumer _ + responseConsumer _ _ = iamResponseConsumer (const $ return UpdateUserResponse) instance Transaction UpdateUser UpdateUserResponse diff --git a/Aws/Iam/Core.hs b/Aws/Iam/Core.hs --- a/Aws/Iam/Core.hs +++ b/Aws/Iam/Core.hs @@ -14,6 +14,8 @@ , AccessKeyStatus(..) , User(..) , parseUser + , Group(..) + , parseGroup , MfaDevice(..) , parseMfaDevice ) where @@ -28,16 +30,15 @@ import Data.IORef import Data.List (intersperse, sort) import Data.Maybe -import Data.Monoid +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 Data.Time.Format -#else +#if !MIN_VERSION_time(1,5,0) import System.Locale #endif import Text.XML.Cursor (($//)) @@ -60,11 +61,14 @@ deriving (Show, Typeable) instance Loggable IamMetadata where - toLogText (IamMetadata r) = "IAM: request ID=" <> fromMaybe "" r + 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 - IamMetadata r1 `mappend` IamMetadata r2 = IamMetadata (r1 `mplus` r2) + mappend = (Sem.<>) data IamConfiguration qt = IamConfiguration { @@ -164,7 +168,7 @@ -- | Parses IAM @DateTime@ data type. parseDateTime :: MonadThrow m => String -> m UTCTime parseDateTime x - = case parseTime defaultTimeLocale iso8601UtcDate x of + = case parseTimeM True defaultTimeLocale iso8601UtcDate x of Nothing -> throwM $ XmlException $ "Invalid DateTime: " ++ x Just dt -> return dt @@ -195,6 +199,38 @@ 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 diff --git a/Aws/Iam/Internal.hs b/Aws/Iam/Internal.hs --- a/Aws/Iam/Internal.hs +++ b/Aws/Iam/Internal.hs @@ -19,7 +19,8 @@ import Control.Monad.Trans.Resource (MonadThrow) import Data.ByteString (ByteString) import Data.Maybe -import Data.Monoid ((<>)) +import Data.Monoid +import Prelude import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text diff --git a/Aws/Network.hs b/Aws/Network.hs --- a/Aws/Network.hs +++ b/Aws/Network.hs @@ -15,6 +15,6 @@ remote@(SockAddrInet _ _) -> do v <- catch (timeout 100000 (connect sock remote) >>= return . isJust) (\(_ :: SomeException) -> return False) - sClose sock + 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 @@ -3,14 +3,19 @@ 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 @@ -18,12 +23,17 @@ 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 @@ -15,11 +15,10 @@ import Data.Time import qualified Network.HTTP.Conduit as HTTP import Text.XML.Cursor (($/), (&|)) -#if MIN_VERSION_time(1,5,0) -import Data.Time.Format -#else +#if !MIN_VERSION_time(1,5,0) import System.Locale #endif +import Prelude data CopyMetadataDirective = CopyMetadata | ReplaceMetadata [(T.Text,T.Text)] deriving (Show) @@ -94,12 +93,12 @@ 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 + 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) diff --git a/Aws/S3/Commands/DeleteBucket.hs b/Aws/S3/Commands/DeleteBucket.hs --- a/Aws/S3/Commands/DeleteBucket.hs +++ b/Aws/S3/Commands/DeleteBucket.hs @@ -4,7 +4,6 @@ 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 DeleteBucket = DeleteBucket { dbBucket :: Bucket } @@ -31,7 +30,7 @@ instance ResponseConsumer DeleteBucket DeleteBucketResponse where type ResponseMetadata DeleteBucketResponse = S3Metadata - responseConsumer _ = s3ResponseConsumer $ \_ -> return DeleteBucketResponse + responseConsumer _ _ = s3ResponseConsumer $ \_ -> return DeleteBucketResponse instance Transaction DeleteBucket DeleteBucketResponse 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 --- a/Aws/S3/Commands/DeleteObjects.hs +++ b/Aws/S3/Commands/DeleteObjects.hs @@ -2,6 +2,7 @@ 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 @@ -11,10 +12,10 @@ import qualified Text.XML as XML import qualified Text.XML.Cursor as Cu import Text.XML.Cursor (($/), (&|)) -import Crypto.Hash import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 ({- IsString -}) -import Control.Applicative ((<$>)) +import Control.Applicative +import Prelude data DeleteObjects = DeleteObjects { @@ -70,7 +71,7 @@ , s3QSubresources = HTTP.toQuery [("delete" :: B.ByteString, Nothing :: Maybe B.ByteString)] , s3QQuery = [] , s3QContentType = Nothing - , s3QContentMd5 = Just $ hashlazy dosBody + , s3QContentMd5 = Just $ CH.hashlazy dosBody , s3QObject = Nothing , s3QAmzHeaders = maybeToList $ (("x-amz-mfa", ) . T.encodeUtf8) <$> dosMultiFactorAuthentication , s3QOtherHeaders = [] @@ -103,7 +104,7 @@ instance ResponseConsumer DeleteObjects DeleteObjectsResponse where type ResponseMetadata DeleteObjectsResponse = S3Metadata - responseConsumer _ = s3XmlResponseConsumer parse + responseConsumer _ _ = s3XmlResponseConsumer parse where parse cursor = do dorDeleted <- sequence $ cursor $/ Cu.laxElement "Deleted" &| parseDeleted dorErrors <- sequence $ cursor $/ Cu.laxElement "Error" &| parseErrors 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 @@ -72,7 +73,7 @@ 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" diff --git a/Aws/S3/Commands/GetBucketLocation.hs b/Aws/S3/Commands/GetBucketLocation.hs --- a/Aws/S3/Commands/GetBucketLocation.hs +++ b/Aws/S3/Commands/GetBucketLocation.hs @@ -44,7 +44,7 @@ instance ResponseConsumer r GetBucketLocationResponse where type ResponseMetadata GetBucketLocationResponse = S3Metadata - responseConsumer _ = s3XmlResponseConsumer parse + responseConsumer _ _ = s3XmlResponseConsumer parse where parse cursor = do locationConstraint <- force "Missing Location" $ cursor $.// elContent "LocationConstraint" return GetBucketLocationResponse { gblrLocationConstraint = normaliseLocation locationConstraint } 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,18 +1,22 @@ +{-# LANGUAGE CPP #-} + module Aws.S3.Commands.GetObject where import Aws.Core import Aws.S3.Core import Control.Applicative -import Control.Monad.Trans.Resource (ResourceT, throwM) +import Control.Monad.Trans.Resource (ResourceT) import Data.ByteString.Char8 ({- IsString -}) 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 @@ -41,7 +45,7 @@ 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 @@ -79,23 +83,21 @@ instance ResponseConsumer GetObject GetObjectResponse where type ResponseMetadata GetObjectResponse = S3Metadata - responseConsumer GetObject{..} metadata resp + responseConsumer httpReq GetObject{} metadata resp | status == HTTP.status200 = do rsp <- s3BinaryResponseConsumer return metadata resp om <- parseObjectMetadata (HTTP.responseHeaders resp) return $ GetObjectResponse om rsp - | otherwise = throwM $ HTTP.StatusCodeException status headers cookies + | otherwise = throwStatusCodeException httpReq resp where status = HTTP.responseStatus resp - headers = HTTP.responseHeaders resp - cookies = HTTP.responseCookieJar resp instance Transaction GetObject GetObjectResponse instance AsMemoryResponse GetObjectResponse where type MemoryResponse GetObjectResponse = GetObjectMemoryResponse loadToMemory (GetObjectResponse om x) = do - bss <- HTTP.responseBody x C.$$+- CL.consume + 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 @@ -13,7 +13,7 @@ import qualified Data.Text as T import qualified Text.XML.Cursor as Cu -data GetService = GetService +data GetService = GetService deriving (Show) data GetServiceResponse = GetServiceResponse { @@ -25,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 @@ -35,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 --- a/Aws/S3/Commands/HeadObject.hs +++ b/Aws/S3/Commands/HeadObject.hs @@ -4,12 +4,12 @@ import Aws.Core import Aws.S3.Core import Control.Applicative -import Control.Monad.Trans.Resource (throwM) 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 @@ -31,7 +31,7 @@ data HeadObjectResponse = HeadObjectResponse { horMetadata :: Maybe ObjectMetadata - } + } deriving (Show) data HeadObjectMemoryResponse = HeadObjectMemoryResponse (Maybe ObjectMetadata) @@ -60,14 +60,13 @@ instance ResponseConsumer HeadObject HeadObjectResponse where type ResponseMetadata HeadObjectResponse = S3Metadata - responseConsumer HeadObject{..} _ resp + responseConsumer httpReq HeadObject{} _ resp | status == HTTP.status200 = HeadObjectResponse . Just <$> parseObjectMetadata headers | status == HTTP.status404 = return $ HeadObjectResponse Nothing - | otherwise = throwM $ HTTP.StatusCodeException status headers cookies + | otherwise = throwStatusCodeException httpReq resp where status = HTTP.responseStatus resp headers = HTTP.responseHeaders resp - cookies = HTTP.responseCookieJar resp instance Transaction HeadObject HeadObjectResponse diff --git a/Aws/S3/Commands/Multipart.hs b/Aws/S3/Commands/Multipart.hs --- a/Aws/S3/Commands/Multipart.hs +++ b/Aws/S3/Commands/Multipart.hs @@ -1,13 +1,14 @@ module Aws.S3.Commands.Multipart - where +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 Crypto.Hash +import qualified Crypto.Hash as CH import Data.ByteString.Char8 ({- IsString -}) import Data.Conduit import qualified Data.Conduit.List as CL @@ -22,6 +23,7 @@ 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. @@ -99,7 +101,7 @@ instance ResponseConsumer r InitiateMultipartUploadResponse where type ResponseMetadata InitiateMultipartUploadResponse = S3Metadata - responseConsumer _ = s3XmlResponseConsumer parse + responseConsumer _ _ = s3XmlResponseConsumer parse where parse cursor = do bucket <- force "Missing Bucket Name" $ cursor $/ elContent "Bucket" key <- force "Missing Key" $ cursor $/ elContent "Key" @@ -127,7 +129,7 @@ , upPartNumber :: Integer , upUploadId :: T.Text , upContentType :: Maybe B8.ByteString - , upContentMD5 :: Maybe (Digest MD5) + , upContentMD5 :: Maybe (CH.Digest CH.MD5) , upServerSideEncryption :: Maybe ServerSideEncryption , upRequestBody :: HTTP.RequestBody , upExpect100Continue :: Bool -- ^ Note: Requires http-client >= 0.4.10 @@ -140,7 +142,6 @@ data UploadPartResponse = UploadPartResponse { - uprVersionId :: !(Maybe T.Text), uprETag :: !T.Text } deriving (Show) @@ -172,10 +173,9 @@ instance ResponseConsumer UploadPart UploadPartResponse where type ResponseMetadata UploadPartResponse = S3Metadata - responseConsumer _ = s3ResponseConsumer $ \resp -> do - let vid = T.decodeUtf8 `fmap` lookup "x-amz-version-id" (HTTP.responseHeaders resp) + responseConsumer _ _ = s3ResponseConsumer $ \resp -> do let etag = fromMaybe "" $ T.decodeUtf8 `fmap` lookup "ETag" (HTTP.responseHeaders resp) - return $ UploadPartResponse vid etag + return $ UploadPartResponse etag instance Transaction UploadPart UploadPartResponse @@ -196,12 +196,11 @@ , cmuExpiration :: Maybe T.Text , cmuServerSideEncryption :: Maybe T.Text , cmuServerSideEncryptionCustomerAlgorithm :: Maybe T.Text - , cmuVersionId :: 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 Nothing +postCompleteMultipartUpload b o i p = CompleteMultipartUpload b o i p Nothing Nothing Nothing data CompleteMultipartUploadResponse = CompleteMultipartUploadResponse { @@ -209,7 +208,8 @@ , cmurBucket :: !Bucket , cmurKey :: !T.Text , cmurETag :: !T.Text - } + , cmurVersionId :: !(Maybe T.Text) + } deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery CompleteMultipartUpload where @@ -228,7 +228,6 @@ , ("x-amz-server-side-encryption",) <$> (T.encodeUtf8 <$> cmuServerSideEncryption) , ("x-amz-server-side-encryption-customer-algorithm",) <$> (T.encodeUtf8 <$> cmuServerSideEncryptionCustomerAlgorithm) - , ("x-amz-version-id",) <$> (T.encodeUtf8 <$> cmuVersionId) ] , s3QOtherHeaders = [] , s3QRequestBody = Just $ HTTP.RequestBodyLBS reqBody @@ -259,8 +258,9 @@ instance ResponseConsumer r CompleteMultipartUploadResponse where type ResponseMetadata CompleteMultipartUploadResponse = S3Metadata - responseConsumer _ = s3XmlResponseConsumer parse - where parse cursor + 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" @@ -270,6 +270,7 @@ , cmurBucket = bucket , cmurKey = key , cmurETag = etag + , cmurVersionId = vid } instance Transaction CompleteMultipartUpload CompleteMultipartUploadResponse @@ -295,7 +296,7 @@ data AbortMultipartUploadResponse = AbortMultipartUploadResponse { - } + } deriving (Show) -- | ServiceConfiguration: 'S3Configuration' instance SignQuery AbortMultipartUpload where @@ -318,7 +319,7 @@ instance ResponseConsumer r AbortMultipartUploadResponse where type ResponseMetadata AbortMultipartUploadResponse = S3Metadata - responseConsumer _ = s3XmlResponseConsumer parse + responseConsumer _ _ = s3XmlResponseConsumer parse where parse _cursor = return AbortMultipartUploadResponse {} @@ -356,11 +357,10 @@ -> T.Text -> T.Text -> [T.Text] - -> IO () + -> IO CompleteMultipartUploadResponse sendEtag cfg s3cfg mgr bucket object uploadId etags = do - _ <- memoryAws cfg s3cfg mgr $ + memoryAws cfg s3cfg mgr $ postCompleteMultipartUpload bucket object uploadId (zip [1..] etags) - return () putConduit :: MonadResource m => @@ -370,26 +370,26 @@ -> T.Text -> T.Text -> T.Text - -> Conduit BL.ByteString m 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 $ + 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 -> Conduit B8.ByteString m BL.ByteString +chunkedConduit :: (MonadResource m) => Integer -> ConduitT B8.ByteString BL.ByteString m () chunkedConduit size = loop 0 [] where - loop :: Monad m => Integer -> [B8.ByteString] -> Conduit B8.ByteString m BL.ByteString + 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 -> Conduit B8.ByteString m BL.ByteString + go :: Monad m => B8.ByteString -> ConduitT B8.ByteString BL.ByteString m () go line | size <= len = yieldChunk newStr >> loop 0 [] | otherwise = loop len newStr @@ -397,7 +397,7 @@ len = fromIntegral (B8.length line) + cnt newStr = line:str - yieldChunk :: Monad m => [B8.ByteString] -> Conduit i m BL.ByteString + yieldChunk :: Monad m => [B8.ByteString] -> ConduitT i BL.ByteString m () yieldChunk = yield . BL.fromChunks . reverse multipartUpload :: @@ -406,16 +406,16 @@ -> HTTP.Manager -> T.Text -> T.Text - -> Conduit () (ResourceT IO) B8.ByteString + -> 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 - $$ CL.consume - liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags + 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 @@ -424,7 +424,7 @@ -> T.Text -- ^ Bucket name -> T.Text -- ^ Object name -> Integer -- ^ chunkSize (minimum: 5MB) - -> Sink B8.ByteString m () + -> ConduitT B8.ByteString Void m () multipartUploadSink cfg s3cfg = multipartUploadSinkWithInitiator cfg s3cfg postInitiateMultipartUpload multipartUploadWithInitiator :: @@ -434,16 +434,16 @@ -> HTTP.Manager -> T.Text -> T.Text - -> Conduit () (ResourceT IO) B8.ByteString + -> 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 - $$ CL.consume - liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags + 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 @@ -453,10 +453,10 @@ -> T.Text -- ^ Bucket name -> T.Text -- ^ Object name -> Integer -- ^ chunkSize (minimum: 5MB) - -> Sink B8.ByteString m () + -> 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 - liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags + .| 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 @@ -74,7 +74,7 @@ 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 @@ -5,15 +5,17 @@ import Aws.Core import Aws.S3.Core import Control.Applicative -import Control.Arrow (second) -import Crypto.Hash -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.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,33 +24,27 @@ poCacheControl :: Maybe T.Text, poContentDisposition :: Maybe T.Text, poContentEncoding :: Maybe T.Text, - poContentMD5 :: Maybe (Digest MD5), + poContentMD5 :: Maybe (CH.Digest CH.MD5), poExpires :: Maybe Int, poAcl :: Maybe CannedAcl, poStorageClass :: Maybe StorageClass, poWebsiteRedirectLocation :: Maybe T.Text, poServerSideEncryption :: Maybe ServerSideEncryption, -#if MIN_VERSION_http_conduit(2, 0, 0) poRequestBody :: HTTP.RequestBody, -#else - poRequestBody :: HTTP.RequestBody (C.ResourceT IO), -#endif poMetadata :: [(T.Text,T.Text)], poAutoMakeBucket :: Bool, -- ^ Internet Archive S3 nonstandard extension - poExpect100Continue :: Bool -- ^ Note: Requires http-client >= 0.4.10 + poExpect100Continue :: Bool, -- ^ Note: Requires http-client >= 0.4.10 + poTagging :: [(T.Text,T.Text)] -- ^ tag-set as key/value pairs } -#if MIN_VERSION_http_conduit(2, 0, 0) putObject :: Bucket -> T.Text -> HTTP.RequestBody -> PutObject -#else -putObject :: Bucket -> T.Text -> HTTP.RequestBody (C.ResourceT IO) -> PutObject -#endif -putObject bucket obj body = PutObject obj bucket Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing body [] False False +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 - } + = PutObjectResponse + { porVersionId :: Maybe T.Text + , porETag :: T.Text + } deriving (Show) -- | ServiceConfiguration: 'S3Configuration' @@ -61,13 +57,16 @@ , 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 @@ -83,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 @@ -2,42 +2,47 @@ module Aws.S3.Core where import Aws.Core -import Control.Arrow ((***)) +import Control.Arrow (first, (***)) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource (MonadThrow, throwM) -import Crypto.Hash -import Data.Byteable -import Data.Conduit (($$+-)) +import Data.Char (isAscii, isAlphaNum, toUpper, ord) +import Data.Conduit ((.|)) import Data.Function -import Data.Functor ((<$>)) +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 -#if MIN_VERSION_time(1,5,0) -import Data.Time.Format -#else +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 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.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 @@ -50,16 +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 - , s3ServerSideEncryption :: Maybe ServerSideEncryption - , 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 @@ -83,6 +102,9 @@ 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" @@ -94,16 +116,35 @@ 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 @@ -130,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` @@ -148,14 +192,10 @@ , s3QSubresources :: HTTP.Query , s3QQuery :: HTTP.Query , s3QContentType :: Maybe B.ByteString - , s3QContentMd5 :: Maybe (Digest MD5) + , s3QContentMd5 :: Maybe (CH.Digest CH.MD5) , s3QAmzHeaders :: HTTP.RequestHeaders , s3QOtherHeaders :: HTTP.RequestHeaders -#if MIN_VERSION_http_conduit(2, 0, 0) , s3QRequestBody :: Maybe HTTP.RequestBody -#else - , s3QRequestBody :: Maybe (HTTP.RequestBody (C.ResourceT IO)) -#endif } instance Show S3Query where @@ -167,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 @@ -181,17 +231,22 @@ , sqContentType = s3QContentType , sqContentMd5 = s3QContentMd5 , sqAmzHeaders = amzHeaders - , sqOtherHeaders = s3QOtherHeaders + , sqOtherHeaders = useragent ++ s3QOtherHeaders , sqBody = s3QRequestBody , sqStringToSign = stringToSign } where - amzHeaders = merge $ sortBy (compare `on` fst) (s3QAmzHeaders ++ (fmap (\(k, v) -> (CI.mk k, v)) iamTok)) + -- 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 = HTTP.urlEncode False <$> s3QObject + urlEncodedS3QObject = s3UriEncode False <$> s3QObject (host, path) = case s3RequestStyle of PathStyle -> ([Just s3Endpoint], [Just "/", fmap (`B8.snoc` '/') s3QBucket, urlEncodedS3QObject]) BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just "/", urlEncodedS3QObject]) @@ -200,7 +255,22 @@ canonicalizedResource = Blaze8.fromChar '/' `mappend` maybe mempty (\s -> Blaze.copyByteString s `mappend` Blaze8.fromChar '/') s3QBucket `mappend` maybe mempty Blaze.copyByteString urlEncodedS3QObject `mappend` - HTTP.renderQueryBuilder True sortedSubresources + 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 @@ -209,7 +279,7 @@ 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 . toBytes) s3QContentMd5] + , [maybe mempty (Blaze.copyByteString . Base64.encode . ByteArray.convert) s3QContentMd5] , [maybe mempty Blaze.copyByteString s3QContentType] , [Blaze.copyByteString $ case ti of AbsoluteTimestamp time -> fmtRfc822Time time @@ -219,14 +289,156 @@ ] where amzHeader (k, v) = Blaze.copyByteString (CI.foldedCase k) `mappend` Blaze8.fromChar ':' `mappend` Blaze.copyByteString v (authorization, authQuery) = case ti of - AbsoluteTimestamp _ -> (Just $ return $ 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)] ++ iamTok + | 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 @@ -234,7 +446,6 @@ where inner' resp = do !res <- inner resp - C.closeResumableSource (HTTP.responseBody resp) return res s3BinaryResponseConsumer :: HTTPResponseConsumer a @@ -260,7 +471,7 @@ 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 Right err -> throwM err @@ -274,7 +485,7 @@ accessKeyId = listToMaybe $ root $/ elContent "AWSAccessKeyId" bucket = listToMaybe $ root $/ elContent "Bucket" endpointRaw = listToMaybe $ root $/ elContent "Endpoint" - endpoint = T.encodeUtf8 <$> (T.stripPrefix (fromMaybe "" bucket <> ".") =<< endpointRaw) + 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 @@ -296,13 +507,15 @@ data UserInfo = UserInfo { userId :: CanonicalUserId - , userDisplayName :: T.Text + , userDisplayName :: Maybe T.Text } deriving (Show) 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 @@ -376,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 @@ -390,14 +667,16 @@ 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) <|> - (parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" $ T.unpack s) of + 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" &| return . parseStorageClass + 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 @@ -464,11 +743,12 @@ type LocationConstraint = T.Text -locationUsClassic, locationUsWest, locationUsWest2, locationEu, locationEuFrankfurt, locationApSouthEast, locationApSouthEast2, locationApNorthEast, locationSA :: 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" diff --git a/Aws/Ses/Commands/DeleteIdentity.hs b/Aws/Ses/Commands/DeleteIdentity.hs --- a/Aws/Ses/Commands/DeleteIdentity.hs +++ b/Aws/Ses/Commands/DeleteIdentity.hs @@ -29,7 +29,8 @@ instance ResponseConsumer DeleteIdentity DeleteIdentityResponse where type ResponseMetadata DeleteIdentityResponse = SesMetadata - responseConsumer _ = sesResponseConsumer $ \_ -> return DeleteIdentityResponse + responseConsumer _ _ + = sesResponseConsumer $ \_ -> return DeleteIdentityResponse instance Transaction DeleteIdentity DeleteIdentityResponse where diff --git a/Aws/Ses/Commands/GetIdentityDkimAttributes.hs b/Aws/Ses/Commands/GetIdentityDkimAttributes.hs --- a/Aws/Ses/Commands/GetIdentityDkimAttributes.hs +++ b/Aws/Ses/Commands/GetIdentityDkimAttributes.hs @@ -4,13 +4,14 @@ , IdentityDkimAttributes(..) ) where -import Control.Applicative ((<$>)) 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 @@ -44,7 +45,7 @@ instance ResponseConsumer GetIdentityDkimAttributes GetIdentityDkimAttributesResponse where type ResponseMetadata GetIdentityDkimAttributesResponse = SesMetadata - responseConsumer _ = sesResponseConsumer $ \cursor -> do + responseConsumer _ _ = sesResponseConsumer $ \cursor -> do let buildAttr e = do idIdentity <- force "Missing Key" $ e $/ elContent "key" enabled <- force "Missing DkimEnabled" $ e $// elContent "DkimEnabled" diff --git a/Aws/Ses/Commands/GetIdentityNotificationAttributes.hs b/Aws/Ses/Commands/GetIdentityNotificationAttributes.hs --- a/Aws/Ses/Commands/GetIdentityNotificationAttributes.hs +++ b/Aws/Ses/Commands/GetIdentityNotificationAttributes.hs @@ -6,11 +6,12 @@ import Data.Text (Text) import qualified Data.ByteString.Char8 as BS -import Control.Applicative ((<$>)) +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 @@ -43,7 +44,7 @@ instance ResponseConsumer GetIdentityNotificationAttributes GetIdentityNotificationAttributesResponse where type ResponseMetadata GetIdentityNotificationAttributesResponse = SesMetadata - responseConsumer _ = sesResponseConsumer $ \cursor -> do + responseConsumer _ _ = sesResponseConsumer $ \cursor -> do let buildAttr e = do inIdentity <- force "Missing Key" $ e $/ elContent "key" fwdText <- force "Missing ForwardingEnabled" $ e $// elContent "ForwardingEnabled" diff --git a/Aws/Ses/Commands/GetIdentityVerificationAttributes.hs b/Aws/Ses/Commands/GetIdentityVerificationAttributes.hs --- a/Aws/Ses/Commands/GetIdentityVerificationAttributes.hs +++ b/Aws/Ses/Commands/GetIdentityVerificationAttributes.hs @@ -7,10 +7,11 @@ import Data.Text (Text) import qualified Data.ByteString.Char8 as BS import Data.Maybe (listToMaybe) -import Control.Applicative ((<$>)) +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 @@ -45,7 +46,7 @@ instance ResponseConsumer GetIdentityVerificationAttributes GetIdentityVerificationAttributesResponse where type ResponseMetadata GetIdentityVerificationAttributesResponse = SesMetadata - responseConsumer _ = + responseConsumer _ _ = sesResponseConsumer $ \cursor -> do let buildAttr e = do ivIdentity <- force "Missing Key" $ e $/ elContent "key" diff --git a/Aws/Ses/Commands/ListIdentities.hs b/Aws/Ses/Commands/ListIdentities.hs --- a/Aws/Ses/Commands/ListIdentities.hs +++ b/Aws/Ses/Commands/ListIdentities.hs @@ -7,10 +7,11 @@ import Data.Text (Text) import qualified Data.ByteString.Char8 as BS import Data.Maybe (catMaybes) -import Control.Applicative ((<$>)) +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 @@ -50,7 +51,7 @@ instance ResponseConsumer ListIdentities ListIdentitiesResponse where type ResponseMetadata ListIdentitiesResponse = SesMetadata - responseConsumer _ = + responseConsumer _ _ = sesResponseConsumer $ \cursor -> do let ids = cursor $// laxElement "Identities" &/ elContent "member" return $ ListIdentitiesResponse ids 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,10 +5,11 @@ import Data.Text (Text) import Data.Typeable -import Control.Applicative ((<$>)) +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 @@ -45,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 --- a/Aws/Ses/Commands/SetIdentityDkimEnabled.hs +++ b/Aws/Ses/Commands/SetIdentityDkimEnabled.hs @@ -32,7 +32,8 @@ instance ResponseConsumer SetIdentityDkimEnabled SetIdentityDkimEnabledResponse where type ResponseMetadata SetIdentityDkimEnabledResponse = SesMetadata - responseConsumer _ = sesResponseConsumer $ \_ -> return SetIdentityDkimEnabledResponse + responseConsumer _ _ + = sesResponseConsumer $ \_ -> return SetIdentityDkimEnabledResponse instance Transaction SetIdentityDkimEnabled SetIdentityDkimEnabledResponse diff --git a/Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs b/Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs --- a/Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs +++ b/Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs @@ -34,7 +34,8 @@ instance ResponseConsumer SetIdentityFeedbackForwardingEnabled SetIdentityFeedbackForwardingEnabledResponse where type ResponseMetadata SetIdentityFeedbackForwardingEnabledResponse = SesMetadata - responseConsumer _ = sesResponseConsumer $ \_ -> return SetIdentityFeedbackForwardingEnabledResponse + responseConsumer _ _ + = sesResponseConsumer $ \_ -> return SetIdentityFeedbackForwardingEnabledResponse instance Transaction SetIdentityFeedbackForwardingEnabled SetIdentityFeedbackForwardingEnabledResponse diff --git a/Aws/Ses/Commands/SetIdentityNotificationTopic.hs b/Aws/Ses/Commands/SetIdentityNotificationTopic.hs --- a/Aws/Ses/Commands/SetIdentityNotificationTopic.hs +++ b/Aws/Ses/Commands/SetIdentityNotificationTopic.hs @@ -5,10 +5,11 @@ ) where import Data.Text (Text) -import Control.Applicative ((<$>)) +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 @@ -48,7 +49,8 @@ instance ResponseConsumer SetIdentityNotificationTopic SetIdentityNotificationTopicResponse where type ResponseMetadata SetIdentityNotificationTopicResponse = SesMetadata - responseConsumer _ = sesResponseConsumer $ \_ -> return SetIdentityNotificationTopicResponse + responseConsumer _ _ + = sesResponseConsumer $ \_ -> return SetIdentityNotificationTopicResponse instance Transaction SetIdentityNotificationTopic SetIdentityNotificationTopicResponse diff --git a/Aws/Ses/Commands/VerifyDomainDkim.hs b/Aws/Ses/Commands/VerifyDomainDkim.hs --- a/Aws/Ses/Commands/VerifyDomainDkim.hs +++ b/Aws/Ses/Commands/VerifyDomainDkim.hs @@ -28,7 +28,7 @@ instance ResponseConsumer VerifyDomainDkim VerifyDomainDkimResponse where type ResponseMetadata VerifyDomainDkimResponse = SesMetadata - responseConsumer _ = + responseConsumer _ _ = sesResponseConsumer $ \cursor -> do let tokens = cursor $// laxElement "DkimTokens" &/ elContent "member" return (VerifyDomainDkimResponse tokens) diff --git a/Aws/Ses/Commands/VerifyDomainIdentity.hs b/Aws/Ses/Commands/VerifyDomainIdentity.hs --- a/Aws/Ses/Commands/VerifyDomainIdentity.hs +++ b/Aws/Ses/Commands/VerifyDomainIdentity.hs @@ -29,7 +29,7 @@ instance ResponseConsumer VerifyDomainIdentity VerifyDomainIdentityResponse where type ResponseMetadata VerifyDomainIdentityResponse = SesMetadata - responseConsumer _ = + responseConsumer _ _ = sesResponseConsumer $ \cursor -> do token <- force "Verification token not found" $ cursor $// elContent "VerificationToken" return (VerifyDomainIdentityResponse token) diff --git a/Aws/Ses/Commands/VerifyEmailIdentity.hs b/Aws/Ses/Commands/VerifyEmailIdentity.hs --- a/Aws/Ses/Commands/VerifyEmailIdentity.hs +++ b/Aws/Ses/Commands/VerifyEmailIdentity.hs @@ -29,7 +29,8 @@ instance ResponseConsumer VerifyEmailIdentity VerifyEmailIdentityResponse where type ResponseMetadata VerifyEmailIdentityResponse = SesMetadata - responseConsumer _ = sesResponseConsumer $ \_ -> return VerifyEmailIdentityResponse + responseConsumer _ _ + = sesResponseConsumer $ \_ -> return VerifyEmailIdentityResponse instance Transaction VerifyEmailIdentity VerifyEmailIdentityResponse where diff --git a/Aws/Ses/Core.hs b/Aws/Ses/Core.hs --- a/Aws/Ses/Core.hs +++ b/Aws/Ses/Core.hs @@ -33,9 +33,11 @@ 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 (($/), ($//)) @@ -60,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 { @@ -183,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 @@ -12,9 +12,11 @@ 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 (($|), ($/), ($//), (&|)) @@ -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 { 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 @@ -19,7 +19,7 @@ , ReceiveMessage(..) , ReceiveMessageResponse(..) --- * Change Message Visiblity +-- * Change Message Visibility , ChangeMessageVisibility(..) , ChangeMessageVisibilityResponse(..) ) where @@ -39,6 +39,7 @@ import qualified Network.HTTP.Types as HTTP import Text.Read (readEither) import qualified Text.XML.Cursor as Cu +import Prelude -- -------------------------------------------------------------------------- -- -- User Message Attributes @@ -132,9 +133,9 @@ 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 ) + [ ( pre <> "Name", Just $ TE.encodeUtf8 name ) + , ( pre <> "Value.DataType", Just typ ) + , ( pre <> "Value." <> valueKey, Just encodedValue ) ] where pre = "MessageAttribute." <> B.pack (show i) <> "." @@ -216,7 +217,7 @@ instance ResponseConsumer r SendMessageResponse where type ResponseMetadata SendMessageResponse = SqsMetadata - responseConsumer _ = sqsXmlResponseConsumer parse + responseConsumer _ _ = sqsXmlResponseConsumer parse where parse el = SendMessageResponse <$> force "Missing MD5 Signature" @@ -287,7 +288,7 @@ instance ResponseConsumer r DeleteMessageResponse where type ResponseMetadata DeleteMessageResponse = SqsMetadata - responseConsumer _ = sqsXmlResponseConsumer parse + responseConsumer _ _ = sqsXmlResponseConsumer parse where parse _ = return DeleteMessageResponse {} @@ -425,7 +426,7 @@ -- -- 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 therefor we make this field optional. +-- is not always returning a value and therefore we make this field optional. -- data Message = Message { mMessageId :: !T.Text @@ -487,27 +488,27 @@ -> Response SqsMetadata UserMessageAttributeValue readUserMessageAttributeValue cursor = do typStr <- force "Missing DataType" - $ cursor $/ Cu.laxElement "DataType" &/ Cu.content + $ cursor $// Cu.laxElement "DataType" &/ Cu.content case parseType typStr of ("String", c) -> do val <- force "Missing StringValue" - $ cursor $/ Cu.laxElement "StringValue" &/ Cu.content + $ cursor $// Cu.laxElement "StringValue" &/ Cu.content return $ UserMessageAttributeString c val ("Number", c) -> do valStr <- force "Missing StringValue" - $ cursor $/ Cu.laxElement "StringValue" &/ Cu.content + $ cursor $// Cu.laxElement "StringValue" &/ Cu.content val <- tryXml . readEither $ T.unpack valStr return $ UserMessageAttributeNumber c val ("Binary", c) -> do - val64 <- force "Missing StringValue" - $ cursor $/ Cu.laxElement "StringValue" &/ Cu.content + val64 <- force "Missing BinaryValue" + $ cursor $// Cu.laxElement "BinaryValue" &/ Cu.content val <- tryXml . B64.decode $ TE.encodeUtf8 val64 return $ UserMessageAttributeBinary c val (x, _) -> throwM . XmlException - $ "unkown data type for MessageAttributeValue: " <> T.unpack x + $ "unknown data type for MessageAttributeValue: " <> T.unpack x where parseType s = case T.break (== '.') s of (a, "") -> (a, Nothing) @@ -518,7 +519,7 @@ readMessage cursor = do mid <- force "Missing Message Id" $ cursor $// Cu.laxElement "MessageId" &/ Cu.content - rh <- force "Missing Reciept Handle" + rh <- force "Missing Receipt Handle" $ cursor $// Cu.laxElement "ReceiptHandle" &/ Cu.content md5 <- force "Missing MD5 Signature" $ cursor $// Cu.laxElement "MD5OfBody" &/ Cu.content @@ -559,7 +560,7 @@ instance ResponseConsumer r ReceiveMessageResponse where type ResponseMetadata ReceiveMessageResponse = SqsMetadata - responseConsumer _ = sqsXmlResponseConsumer parse + responseConsumer _ _ = sqsXmlResponseConsumer parse where parse el = do result <- force "Missing ReceiveMessageResult" @@ -660,7 +661,7 @@ instance ResponseConsumer r ChangeMessageVisibilityResponse where type ResponseMetadata ChangeMessageVisibilityResponse = SqsMetadata - responseConsumer _ = sqsXmlResponseConsumer parse + responseConsumer _ _ = sqsXmlResponseConsumer parse where parse _ = return 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 @@ -2,7 +2,7 @@ module Aws.Sqs.Core where import Aws.Core -import Aws.S3.Core (LocationConstraint, locationUsClassic, locationUsWest, locationUsWest2, locationApSouthEast, locationApSouthEast2, 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 @@ -11,22 +11,23 @@ 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 +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 Data.Time.Format -#else +#if !MIN_VERSION_time(1,5,0) import System.Locale #endif import qualified Text.XML as XML @@ -65,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 @@ -136,6 +140,14 @@ , endpointAllowedLocationConstraints = [locationEu] } +sqsEndpointEuWest2 :: Endpoint +sqsEndpointEuWest2 + = Endpoint { + endpointHost = "eu-west-2.queue.amazonaws.com" + , endpointDefaultLocationConstraint = locationEuWest2 + , endpointAllowedLocationConstraints = [locationEuWest2] + } + sqsEndpointApSouthEast :: Endpoint sqsEndpointApSouthEast = Endpoint { @@ -241,7 +253,7 @@ 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 Right err -> throwM err diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,15 +1,166 @@ +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.1 - - Eliminate orphan instance that conflicted with aeson-1.0 - - Add upper bound on http-client in testsuite - 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: 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 @@ -169,7 +320,7 @@ \#72, \#74) - SES: SendRawEmail now correctly encodes destinations and allows multiple destinations (\#73) - - EC2: support fo Instance metadata (\#37) + - EC2: support for Instance metadata (\#37) - Core: queryToHttpRequest allows overriding "Date" for the benefit of Chris Dornan's Elastic Transcoder bindings (\#77) diff --git a/Examples/DynamoDb.hs b/Examples/DynamoDb.hs --- a/Examples/DynamoDb.hs +++ b/Examples/DynamoDb.hs @@ -11,12 +11,13 @@ 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 (withManager) +import Network.HTTP.Conduit (newManager, tlsManagerSettings) ------------------------------------------------------------------------------- createTableAndWait :: IO () @@ -119,8 +120,8 @@ echo "Now paginating in increments of 5..." let q0 = (scan "devel-1") { sLimit = Just 5 } - xs <- withManager $ \mgr -> do - awsIteratedList cfg debugServiceConfig mgr q0 $$ C.consume + mgr <- newManager tlsManagerSettings + xs <- runResourceT $ awsIteratedList cfg debugServiceConfig mgr q0 `connect` C.consume echo ("Pagination returned " ++ show (length xs) ++ " items") 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 --- a/Examples/MultipartTransfer.hs +++ b/Examples/MultipartTransfer.hs @@ -7,10 +7,10 @@ import Aws.Aws (Configuration (..)) import qualified Aws.S3 as S3 import Control.Applicative ((<$>)) -import Data.Conduit (unwrapResumable) +import Control.Monad.Trans.Resource import qualified Data.Text as T import Network.HTTP.Conduit (http, parseUrl, responseBody, - withManager) + newManager, tlsManagerSettings) import System.Environment (getArgs) main :: IO () @@ -27,9 +27,9 @@ case args of [sourceUrl,destBucket,destObj] -> do request <- parseUrl sourceUrl - withManager $ \mgr -> do - resumableSource <- responseBody <$> http request mgr - (source, _) <- unwrapResumable resumableSource + 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 diff --git a/Examples/MultipartUpload.hs b/Examples/MultipartUpload.hs --- a/Examples/MultipartUpload.hs +++ b/Examples/MultipartUpload.hs @@ -1,30 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} import qualified Aws +import qualified Aws.Core as Aws import qualified Aws.S3 as S3 -import Data.Conduit (($$)) +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 (withManager, responseBody) -import Control.Monad.Trans.Resource (ResourceT) +import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody) +import Control.Monad.Trans.Resource (runResourceT) import System.Environment (getArgs) main :: IO () main = do - {- Set up AWS credentials and the default configuration. -} - cfg <- Aws.dbgConfiguration - let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery - args <- getArgs - - let doUpload bucket obj file chunkSize = - withManager $ \mgr -> do - (sourceFile file $$ S3.multipartUploadSink cfg s3cfg mgr (T.pack bucket) (T.pack obj) (chunkSize*1024*1024)) :: ResourceT IO () - case args of - [bucket,obj,file] -> - doUpload bucket obj file 10 - [bucket,obj,file,chunkSize] -> - doUpload bucket obj file (read chunkSize) - _ -> do - putStrLn "Usage: MultipartUpload bucket objectname filename (chunksize(MB)::optinal)" + [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 --- a/Examples/NukeBucket.hs +++ b/Examples/NukeBucket.hs @@ -7,7 +7,8 @@ import Data.Text (pack) import Control.Monad ((<=<)) import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Conduit (withManager, responseBody) +import Control.Monad.Trans.Resource +import Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody) import System.Environment (getArgs) main :: IO () @@ -19,7 +20,8 @@ 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 let src = Aws.awsIteratedSource cfg s3cfg mgr (S3.getBucket bucket) let deleteObjects [] = return () deleteObjects os = @@ -28,7 +30,7 @@ liftIO $ putStrLn ("Deleting objects: " ++ show keys) _ <- Aws.pureAws cfg s3cfg mgr (S3.deleteObjects bucket (map S3.objectKey os)) return () - src C.$$ CL.mapM_ (deleteObjects . S3.gbrContents <=< Aws.readResponseIO) + 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 --- a/Examples/PutBucketNearLine.hs +++ b/Examples/PutBucketNearLine.hs @@ -5,9 +5,9 @@ import qualified Aws import qualified Aws.Core as Aws import qualified Aws.S3 as S3 -import Data.Conduit (($$+-)) import Data.Conduit.Binary (sinkFile) -import Network.HTTP.Conduit (withManager, RequestBody(..)) +import Control.Monad.Trans.Resource +import Network.HTTP.Conduit (newManager, tlsManagerSettings, RequestBody(..)) import Control.Monad.IO.Class import Control.Concurrent import System.IO @@ -25,11 +25,12 @@ {- 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) + 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. -} - withManager $ \mgr -> do + mgr <- newManager tlsManagerSettings + runResourceT $ do {- Create a request object with S3.PutBucket and run the request with pureAws. -} rsp <- Aws.pureAws cfg s3cfg mgr $ diff --git a/Examples/Sqs.hs b/Examples/Sqs.hs --- a/Examples/Sqs.hs +++ b/Examples/Sqs.hs @@ -90,7 +90,7 @@ -} exceptT T.putStrLn T.putStrLn . retryT 4 $ do qUrls <- liftIO $ do - putStrLn $ "Listing all queueus to check to see if " ++ show (Sqs.qName sqsQName) ++ " is gone" + 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_ diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,7 +20,7 @@ directory: ``` {.bash} -$ git clone https://github.com/aristidb/aws.git +$ git clone https://github.com/haskell-pkg-janitors/aws.git $ cd aws $ cabal install ``` @@ -67,9 +67,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 @@ -78,14 +79,15 @@ 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" ``` You can also find this example in the source distribution in the @@ -113,7 +115,7 @@ Resources ========= -- [aws on Github](https://github.com/aristidb/aws) +- [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/) @@ -131,8 +133,9 @@ 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) |Co-Maintainer, S3 + 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/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -1,8 +1,8 @@ Name: aws -Version: 0.14.1 +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 @@ -18,12 +18,12 @@ Source-repository this type: git - location: https://github.com/aristidb/aws.git - tag: 0.14.0 + 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. @@ -36,6 +36,8 @@ 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 @@ -47,19 +49,29 @@ 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 @@ -69,14 +81,19 @@ 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 @@ -109,45 +126,46 @@ Aws.Sqs.Core Build-depends: - aeson >= 0.6, - attoparsec >= 0.11 && < 0.14, - base >= 4.6 && < 5, - base16-bytestring == 0.1.*, - base16-bytestring == 0.1.*, - base64-bytestring == 1.0.*, + 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.11, + bytestring >= 0.9 && < 0.13, case-insensitive >= 0.2 && < 1.3, cereal >= 0.3 && < 0.6, - conduit >= 1.1 && < 1.3, - conduit-extra >= 1.1 && < 1.2, + conduit >= 1.3 && < 1.4, + conduit-extra >= 1.3 && < 1.4, containers >= 0.4, - cryptohash >= 0.11 && < 0.12, - data-default >= 0.5.3 && < 0.8, - directory >= 1.0 && < 1.3, - filepath >= 1.1 && < 1.5, - http-conduit >= 2.1 && < 2.2, - http-types >= 0.7 && < 0.10, + 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.*, - network == 2.*, old-locale == 1.*, - resourcet >= 1.1 && < 1.2, + 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 && < 2.0, - transformers >= 0.2.2 && < 0.6, + 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.2 && <1.4 - - if !impl(ghc >= 7.6) - Build-depends: ghc-prim + xml-conduit >= 1.8 && <2.0, + network == 3.*, + network-bsd == 2.8.* GHC-Options: -Wall @@ -167,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 @@ -180,10 +216,29 @@ aws, http-conduit, conduit, - conduit-extra + 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 @@ -195,6 +250,7 @@ Build-depends: base == 4.*, aws, + bytestring, http-conduit, conduit, conduit-extra, @@ -217,7 +273,8 @@ http-conduit, conduit, conduit-extra, - text + text, + resourcet Default-Language: Haskell2010 @@ -236,7 +293,8 @@ conduit, conduit-extra, text >=0.1, - transformers + transformers, + resourcet Default-Language: Haskell2010 @@ -255,7 +313,8 @@ conduit, conduit-extra, text >=0.1, - transformers + transformers, + resourcet Default-Language: Haskell2010 @@ -288,6 +347,7 @@ data-default, exceptions, http-conduit, + resourcet, text, conduit @@ -327,7 +387,7 @@ base == 4.*, bytestring >= 0.10, errors >= 2.0, - http-client >= 0.3 && < 0.5, + http-client >= 0.3 && < 0.8, lifted-base >= 0.2, monad-control >= 0.3, mtl >= 2.1, @@ -387,12 +447,23 @@ build-depends: aws, base == 4.*, + QuickCheck >= 2.7, + aeson >= 0.7, bytestring, - http-client < 0.5, + 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, - tagged >= 0.7 + time, + tagged >= 0.7, + transformers >= 0.3, + transformers-base >= 0.4 diff --git a/tests/DynamoDb/Main.hs b/tests/DynamoDb/Main.hs --- a/tests/DynamoDb/Main.hs +++ b/tests/DynamoDb/Main.hs @@ -79,7 +79,7 @@ , "By running the tests in this test-suite costs for usage of AWS" , "services may incur." , "" - , "In order to actually excute the tests in this test-suite you must" + , "In order to actually execute the tests in this test-suite you must" , "provide the command line options:" , "" , " --run-with-aws-credentials" @@ -138,7 +138,8 @@ -- counts the number of TCP connections ref <- newIORef (0 :: Int) - void . HTTP.withManager (managerSettings ref) $ \manager -> runExceptT $ + 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 "____" diff --git a/tests/DynamoDb/Utils.hs b/tests/DynamoDb/Utils.hs --- a/tests/DynamoDb/Utils.hs +++ b/tests/DynamoDb/Utils.hs @@ -7,6 +7,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module: DynamoDb.Utils @@ -118,7 +119,7 @@ withTable = withTable_ True withTable_ - :: Bool -- ^ whether to prefix te table name + :: 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) diff --git a/tests/S3/Main.hs b/tests/S3/Main.hs --- a/tests/S3/Main.hs +++ b/tests/S3/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} @@ -15,7 +16,9 @@ ) where import Control.Applicative -import Data.ByteString (ByteString) +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 @@ -26,7 +29,12 @@ import Data.Typeable import Data.Proxy import Network.HTTP.Client (HttpException (..), - RequestBody (..), newManager) + 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 @@ -80,7 +88,7 @@ , "By running the tests in this test-suite costs for usage of AWS" , "services may incur." , "" - , "In order to actually excute the tests in this test-suite you must" + , "In order to actually execute the tests in this test-suite you must" , "provide the command line options:" , "" , " --run-with-aws-credentials" @@ -97,6 +105,7 @@ tests = testGroup "S3 Tests" [ test_head , test_get + , test_versioning ] @@ -180,6 +189,84 @@ 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 @@ -189,7 +276,13 @@ 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 --- a/tests/Sqs/Main.hs +++ b/tests/Sqs/Main.hs @@ -7,6 +7,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module: Main @@ -35,8 +36,9 @@ import Data.IORef import qualified Data.List as L -import Data.Monoid import qualified Data.Text as T +import Data.Monoid +import Prelude import qualified Network.HTTP.Client as HTTP @@ -82,7 +84,7 @@ , "By running the tests in this test-suite costs for usage of AWS" , "services may incur." , "" - , "In order to actually excute the tests in this test-suite you must" + , "In order to actually execute the tests in this test-suite you must" , "provide the command line options:" , "" , " --run-with-aws-credentials" @@ -296,7 +298,7 @@ -- | 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. Therefor we request only a single +-- will become available with some (small) offset. Therefore we request only a single -- message at a time. -- prop_sendReceiveDeleteMessageLongPolling1 @@ -353,8 +355,8 @@ ref <- newIORef (0 :: Int) -- Use a single manager for all HTTP requests - void . HTTP.withManager (managerSettings ref) $ \manager -> runExceptT $ - + 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 $ diff --git a/tests/Utils.hs b/tests/Utils.hs --- a/tests/Utils.hs +++ b/tests/Utils.hs @@ -38,7 +38,6 @@ , prop_jsonRoundtrip ) where -import Control.Applicative import Control.Concurrent (threadDelay) import qualified Control.Exception.Lifted as LE import Control.Error hiding (syncIO) @@ -47,10 +46,12 @@ 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.Monoid import Data.Proxy import Data.String import qualified Data.Text as T