packages feed

aws 0.12.1 → 0.25.3

raw patch · 102 files changed

Files

Aws.hs view
@@ -58,6 +58,7 @@ , loadCredentialsFromEnvOrFile , loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault+, anonymousCredentials ) where
Aws/Aws.hs view
@@ -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)
Aws/Core.hs view
@@ -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,14 +277,22 @@ makeCredentials accessKeyID secretAccessKey = liftIO $ do     v4SigningKeys <- newIORef []     let iamToken = Nothing+    let isAnonymousCredentials = False     return Credentials { .. }  -- | The file where access credentials are loaded, when using 'loadCredentialsDefault'.+-- May return 'Nothing' if @HOME@ is unset. -- -- Value: /<user directory>/@/.aws-keys@-credentialsDefaultFile :: MonadIO io => io FilePath-credentialsDefaultFile = liftIO $ (</> ".aws-keys") <$> getHomeDirectory+credentialsDefaultFile :: MonadIO io => io (Maybe FilePath)+credentialsDefaultFile = liftIO $ tryMaybe ((</> ".aws-keys") <$> getHomeDirectory) +tryMaybe :: IO a -> IO (Maybe a)+tryMaybe action = E.catch (Just <$> action) f+  where+    f :: E.SomeException -> IO (Maybe a)+    f _ = return Nothing+ -- | The key to be used in the access credential file that is loaded, when using 'loadCredentialsDefault'. -- -- Value: @default@@@ -302,16 +323,16 @@ loadCredentialsFromEnv :: MonadIO io => io (Maybe Credentials) loadCredentialsFromEnv = liftIO $ do   env <- getEnvironment-  let lk = flip lookup env+  let lk = fmap (T.encodeUtf8 . T.pack) . flip lookup env       keyID = lk "AWS_ACCESS_KEY_ID"       secret = lk "AWS_ACCESS_KEY_SECRET" `mplus` lk "AWS_SECRET_ACCESS_KEY"-  Traversable.sequence-      (makeCredentials <$> (T.encodeUtf8 . T.pack <$> keyID)-                       <*> (T.encodeUtf8 . T.pack <$> secret))+      setSession creds = creds { iamToken = lk "AWS_SESSION_TOKEN" }+      makeCredentials' k s = setSession <$> makeCredentials k s+  Traversable.sequence $ makeCredentials' <$> keyID <*> secret  loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials)-loadCredentialsFromInstanceMetadata = 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@@ -334,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.@@ -373,9 +395,18 @@ -- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details. loadCredentialsDefault :: MonadIO io => io (Maybe Credentials) loadCredentialsDefault = do-  file <- credentialsDefaultFile-  loadCredentialsFromEnvOrFileOrInstanceMetadata file credentialsDefaultKey+  mfile <- credentialsDefaultFile+  case mfile of+      Just file -> loadCredentialsFromEnvOrFileOrInstanceMetadata file credentialsDefaultKey+      Nothing   -> loadCredentialsFromEnv +-- | Make a dummy Credentials that can be used to access some AWS services+-- anonymously.+anonymousCredentials :: MonadIO io => io Credentials+anonymousCredentials = do+  cr <- makeCredentials mempty mempty+  return (cr { isAnonymousCredentials = True })+ -- | Protocols supported by AWS. Currently, all AWS services use the HTTP or HTTPS protocols. data Protocol     = HTTP@@ -429,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@@ -468,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 ->@@ -485,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       }@@ -497,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@@ -564,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@@ -587,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 <http://docs.aws.amazon.com/general/latest/gr/signature-version-4.html>: you must create the -- canonical request as explained by Step 1 and this function takes care of Steps 2 and 3.@@ -605,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.@@ -711,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@@ -732,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@@ -783,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]@@ -800,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@@ -823,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
Aws/DynamoDb/Commands.hs view
@@ -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
+ Aws/DynamoDb/Commands/BatchGetItem.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Aws.DynamoDb.Commands.BatchGetItem+-- Copyright   :  Soostone Inc+-- License     :  BSD3+--+-- Maintainer  :  Justin Dawson <jtdawso@gmail.com>+-- Stability   :  experimental+--+-- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_BatchGetItem.html@+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.BatchGetItem where++-------------------------------------------------------------------------------+import           Control.Applicative+import           Data.Aeson+import           Data.Default+import qualified Data.HashMap.Strict as HM+import qualified Data.Text           as T+import           Prelude+-------------------------------------------------------------------------------+import           Aws.Core+import           Aws.DynamoDb.Core+import           Aws.DynamoDb.Commands.GetItem+-------------------------------------------------------------------------------+++data GetRequestItem = GetRequestItem{+         griProjExpr :: Maybe T.Text+       , griConsistent ::Bool+       , griKeys :: [PrimaryKey]  +     } deriving (Eq,Show,Read,Ord)++data BatchGetItem = BatchGetItem {+      bgRequests :: [(T.Text,GetRequestItem)]+    -- ^ Get Requests for a specified table+    , bgRetCons :: ReturnConsumption+    } deriving (Eq,Show,Read,Ord)++-------------------------------------------------------------------------------++-- | Construct a RequestItem .+batchGetRequestItem :: Maybe T.Text+               -- ^ Projection Expression+               -> Bool+               -- ^ Consistent Read+               -> [PrimaryKey]+               -- ^ Items to be deleted+               -> GetRequestItem+batchGetRequestItem expr consistent keys = GetRequestItem expr consistent keys++toBatchGet :: [GetItem] -> BatchGetItem+toBatchGet gs = BatchGetItem (convert gs) def++  where+    groupItems :: [GetItem]-> HM.HashMap T.Text [GetItem] -> HM.HashMap T.Text [GetItem]+    groupItems [] hm = hm+    groupItems (x:xs) hm = let key = giTableName x+                             in groupItems xs (HM.insert key (x : (HM.lookupDefault [] key hm)) hm)+    +    convert :: [GetItem] -> [(T.Text,GetRequestItem)] +    convert gs' = let l = HM.toList $ groupItems gs' HM.empty+                    -- Uses one GetItem to specify ProjectionExpression+                    -- and ConsistentRead for the entire batch+                    in map (\(table,items@(i:_)) ->(table,GetRequestItem +                                                    (T.intercalate "," <$> giAttrs i)+                                                    (giConsistent i)+                                                    (map giKey items)) ) l++-- | Construct a BatchGetItem+batchGetItem :: [(T.Text, GetRequestItem)]+               -> BatchGetItem+batchGetItem reqs = BatchGetItem reqs def+++instance ToJSON GetRequestItem where+   toJSON GetRequestItem{..} =+       (object $ maybe [] (return . ("ProjectionExpression" .=)) griProjExpr +++                 ["ConsistentRead" .= griConsistent+                 , "Keys" .= griKeys])+         ++instance ToJSON BatchGetItem where+    toJSON BatchGetItem{..} =+        object $+          [ "RequestItems" .= HM.fromList bgRequests+          , "ReturnConsumedCapacity" .= bgRetCons+          ]++instance FromJSON GetRequestItem where+    parseJSON (Object p) = do+                 GetRequestItem <$> p .:? "ProjectionExpression"+                                <*> p .: "ConsistentRead"+                                <*> p .: "Keys"+    parseJSON _ = fail "unable to parse GetRequestItem"+    +         +data BatchGetItemResponse = BatchGetItemResponse {+      bgResponses :: [(T.Text, [Item])]+    , bgUnprocessed    :: Maybe [(T.Text,GetRequestItem)]+    -- ^ Unprocessed Requests on failure+    , bgConsumed :: Maybe ConsumedCapacity+    -- ^ Amount of capacity consumed+    } deriving (Eq,Show,Read,Ord)++++instance Transaction BatchGetItem BatchGetItemResponse+++instance SignQuery BatchGetItem where+    type ServiceConfiguration BatchGetItem = DdbConfiguration+    signQuery gi = ddbSignQuery "BatchGetItem" gi+++instance FromJSON BatchGetItemResponse where+    parseJSON (Object v) = BatchGetItemResponse+        <$> (HM.toList <$> (v .: "Responses"))+        <*> v .:? "UnprocessedItems"+        <*> v .:? "ConsumedCapacity"++    parseJSON _ = fail "BatchGetItemResponse must be an object."++instance ResponseConsumer r BatchGetItemResponse where+    type ResponseMetadata BatchGetItemResponse = DdbResponse+    responseConsumer _ _ ref resp = ddbResponseConsumer ref resp++instance AsMemoryResponse BatchGetItemResponse where+    type MemoryResponse BatchGetItemResponse = BatchGetItemResponse+    loadToMemory = return++
+ Aws/DynamoDb/Commands/BatchWriteItem.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Aws.DynamoDb.Commands.BatchWriteItem+-- Copyright   :  Soostone Inc+-- License     :  BSD3+--+-- Maintainer  :  Justin Dawson <jtdawso@gmail.com>+-- Stability   :  experimental+--+-- @http:\/\/docs.aws.amazon.com\/amazondynamodb\/latest\/APIReference\/API_BatchWriteItem.html@+----------------------------------------------------------------------------++module Aws.DynamoDb.Commands.BatchWriteItem where++-------------------------------------------------------------------------------+import           Control.Applicative+import           Data.Aeson+import           Data.Default+import qualified Data.Foldable as F (asum)+import qualified Data.HashMap.Strict as HM+import qualified Data.Text           as T+import           Prelude+-------------------------------------------------------------------------------+import           Aws.Core+import           Aws.DynamoDb.Core+import           Aws.DynamoDb.Commands.PutItem+import           Aws.DynamoDb.Commands.DeleteItem+-------------------------------------------------------------------------------+++data Request = PutRequest { prItem :: Item }+             | DeleteRequest {drKey :: PrimaryKey}+     deriving (Eq,Show,Read,Ord)++data BatchWriteItem = BatchWriteItem {+      bwRequests :: [(T.Text,[Request])]+    -- ^ Put or Delete Requests for a specified table+    , bwRetCons :: ReturnConsumption+    , bwRetMet  :: ReturnItemCollectionMetrics+    } deriving (Eq,Show,Read,Ord)+++-------------------------------------------------------------------------------++toBatchWrite :: [PutItem]+           -> [DeleteItem]+           -> BatchWriteItem+toBatchWrite ps ds =BatchWriteItem maps def def  +      where+        maps :: [(T.Text,[Request])]+        maps = let pMap = foldl (\acc p -> let key = piTable p+                                             in HM.insert key (PutRequest (piItem p) : (HM.lookupDefault [] key acc)) acc) HM.empty ps +                   totalMap = foldl (\acc d -> let key = diTable d+                                                 in  HM.insert key (DeleteRequest (diKey d) : (HM.lookupDefault [] key acc)) acc) pMap ds+                 in  HM.toList totalMap+-- | Construct a BatchWriteItem+batchWriteItem :: [(T.Text,[Request])]+               -> BatchWriteItem+batchWriteItem reqs = BatchWriteItem reqs def def+++instance ToJSON Request where+   toJSON PutRequest{..} =+       object $+         [ "PutRequest" .= (object $ ["Item" .= prItem])+         ]+   toJSON DeleteRequest{..} =+       object $+         [ "DeleteRequest" .=  (object $ ["Key" .= drKey])+         ]++instance ToJSON BatchWriteItem where+    toJSON BatchWriteItem{..} =+        object $+          [ "RequestItems" .= HM.fromList bwRequests+          , "ReturnConsumedCapacity" .= bwRetCons+          , "ReturnItemCollectionMetrics" .= bwRetMet+          ]++instance FromJSON Request where+    parseJSON = withObject "PutRequest or DeleteRequest" $ \o ->+     +     F.asum [+           do+             pr <- o .: "PutRequest"+             i  <- pr .: "Item"+             return $ PutRequest i ,+           do+             dr <- o .: "DeleteRequest"+             pk <- dr .: "Key"+             return $ DeleteRequest pk+          ]+    +data BatchWriteItemResponse = BatchWriteItemResponse {+      bwUnprocessed    :: [(T.Text,[Request])]+    -- ^ Unprocessed Requests on failure+    , bwConsumed :: Maybe ConsumedCapacity+    -- ^ Amount of capacity consumed+    , bwColMet   :: Maybe ItemCollectionMetrics+    -- ^ Collection metrics for tables affected by BatchWriteItem.+    } deriving (Eq,Show,Read,Ord)++++instance Transaction BatchWriteItem BatchWriteItemResponse+++instance SignQuery BatchWriteItem where+    type ServiceConfiguration BatchWriteItem = DdbConfiguration+    signQuery gi = ddbSignQuery "BatchWriteItem" gi+++instance FromJSON BatchWriteItemResponse where+    parseJSON (Object v) = BatchWriteItemResponse+        <$> HM.toList <$> (v .: "UnprocessedItems")+        <*> v .:? "ConsumedCapacity"+        <*> v .:? "ItemCollectionMetrics"+    parseJSON _ = fail "BatchWriteItemResponse must be an object."+++instance ResponseConsumer r BatchWriteItemResponse where+    type ResponseMetadata BatchWriteItemResponse = DdbResponse+    responseConsumer _ _ ref resp = ddbResponseConsumer ref resp+++instance AsMemoryResponse BatchWriteItemResponse where+    type MemoryResponse BatchWriteItemResponse = BatchWriteItemResponse+    loadToMemory = return
Aws/DynamoDb/Commands/DeleteItem.hs view
@@ -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
Aws/DynamoDb/Commands/GetItem.hs view
@@ -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
Aws/DynamoDb/Commands/PutItem.hs view
@@ -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
Aws/DynamoDb/Commands/Query.hs view
@@ -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
Aws/DynamoDb/Commands/Scan.hs view
@@ -36,20 +36,24 @@  -- | A Scan command that uses primary keys for an expedient scan. data Scan = Scan {-      sTableName     :: T.Text+      sTableName      :: T.Text     -- ^ Required.-    , sFilter        :: Conditions+    , sConsistentRead :: Bool+    -- ^ Whether to require a consistent read+    , sFilter         :: Conditions     -- ^ Whether to filter results before returning to client-    , sStartKey      :: Maybe [Attribute]+    , sStartKey       :: Maybe [Attribute]     -- ^ Exclusive start key to resume a previous query.-    , sLimit         :: Maybe Int+    , sLimit          :: Maybe Int     -- ^ Whether to limit result set size-    , sSelect        :: QuerySelect+    , sIndex          :: Maybe T.Text+    -- ^ Optional. Index to 'Scan'+    , sSelect         :: QuerySelect     -- ^ What to return from 'Scan'-    , sRetCons       :: ReturnConsumption-    , sSegment       :: Int+    , sRetCons        :: ReturnConsumption+    , sSegment        :: Int     -- ^ Segment number, starting at 0, for parallel queries.-    , sTotalSegments :: Int+    , sTotalSegments  :: Int     -- ^ Total number of parallel segments. 1 means sequential scan.     } deriving (Eq,Show,Read,Ord,Typeable) @@ -57,7 +61,7 @@ -- | Construct a minimal 'Scan' request. scan :: T.Text                   -- ^ Table name      -> Scan-scan tn = Scan tn def Nothing Nothing def def 0 1+scan tn = Scan tn False def Nothing Nothing Nothing def def 0 1   -- | Response to a 'Scan' query.@@ -76,6 +80,7 @@       catMaybes         [ (("ExclusiveStartKey" .= ) . attributesJson) <$> sStartKey         , ("Limit" .= ) <$> sLimit+        , ("IndexName" .= ) <$> sIndex         ] ++       conditionsJson "ScanFilter" sFilter ++       querySelectJson sSelect ++@@ -83,6 +88,7 @@       , "ReturnConsumedCapacity" .= sRetCons       , "Segment" .= sSegment       , "TotalSegments" .= sTotalSegments+      , "ConsistentRead" .= sConsistentRead       ]  @@ -108,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
Aws/DynamoDb/Commands/Table.hs view
@@ -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
Aws/DynamoDb/Commands/UpdateItem.hs view
@@ -19,13 +19,22 @@ -- ---------------------------------------------------------------------------- -module Aws.DynamoDb.Commands.UpdateItem where+module Aws.DynamoDb.Commands.UpdateItem+    ( UpdateItem(..)+    , updateItem+    , AttributeUpdate(..)+    , au+    , UpdateAction(..)+    , UpdateItemResponse(..)+    ) where  ------------------------------------------------------------------------------- import           Control.Applicative import           Data.Aeson+import qualified Data.Aeson.Key      as AK import           Data.Default import qualified Data.Text           as T+import           Prelude ------------------------------------------------------------------------------- import           Aws.Core import           Aws.DynamoDb.Core@@ -55,7 +64,10 @@ updateItem tn key ups = UpdateItem tn key ups def def def def  -type AttributeUpdates = [AttributeUpdate]+-- | A helper to avoid overlapping instances for 'ToJSON'.+newtype AttributeUpdates = AttributeUpdates {+    getAttributeUpdates :: [AttributeUpdate]+    }   data AttributeUpdate = AttributeUpdate {@@ -77,9 +89,12 @@   instance ToJSON AttributeUpdates where-    toJSON = object . map mk+    toJSON = object . map mk . getAttributeUpdates         where-          mk AttributeUpdate{..} = (attrName auAttr) .= object+          mk AttributeUpdate { auAction = UDelete, auAttr = auAttr } =+            (AK.fromText (attrName auAttr)) .= object+            ["Action" .= UDelete]+          mk AttributeUpdate { .. } = AK.fromText (attrName auAttr) .= object             ["Value" .= (attrVal auAttr), "Action" .= auAction]  @@ -90,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)@@ -111,7 +126,7 @@         object $ expectsJson uiExpect ++           [ "TableName" .= uiTable           , "Key" .= uiKey-          , "AttributeUpdates" .= uiUpdates+          , "AttributeUpdates" .= AttributeUpdates uiUpdates           , "ReturnValues" .= uiReturn           , "ReturnConsumedCapacity" .= uiRetCons           , "ReturnItemCollectionMetrics" .= uiRetMet@@ -144,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
Aws/DynamoDb/Core.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                        #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FlexibleInstances          #-}@@ -31,6 +32,8 @@     , ddbUsWest1     , ddbUsWest2     , ddbEuWest1+    , ddbEuWest2+    , ddbEuCentral1     , ddbApNe1     , ddbApSe1     , ddbApSe2@@ -44,10 +47,11 @@     , DynVal(..)     , toValue, fromValue     , Bin (..)+    , OldBool(..)      -- * Defining new 'DynVal' instances     , DynData(..)-    , DynBinary(..), DynNumber(..), DynString(..)+    , DynBinary(..), DynNumber(..), DynString(..), DynBool(..)      -- * Working with key/value pairs     , Attribute (..)@@ -73,6 +77,7 @@     , Parser (..)     , getAttr     , getAttr'+    , parseAttr      -- * Common types used by operations     , Conditions (..)@@ -115,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@@ -133,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@@ -150,6 +161,7 @@ import qualified Data.Text.Encoding           as T import           Data.Time import           Data.Typeable+import qualified Data.Vector                  as V import           Data.Word import qualified Network.HTTP.Conduit         as HTTP import qualified Network.HTTP.Types           as HTTP@@ -158,6 +170,11 @@ import           Aws.Core ------------------------------------------------------------------------------- +-------------------------------------------------------------------------------+-- | Boolean values stored in DynamoDb. Only used in defining new+-- 'DynVal' instances.+newtype DynBool = DynBool { unDynBool :: Bool }+    deriving (Eq,Show,Read,Ord,Typeable)   -------------------------------------------------------------------------------@@ -195,6 +212,22 @@     fromData :: a -> DValue     toData :: DValue -> Maybe a +instance DynData DynBool where+    fromData (DynBool i) = DBool i+    toData (DBool i) = Just $ DynBool i+    toData (DNum i) = DynBool `fmap` do+        (i' :: Int) <- toIntegral i+        case i' of+          0 -> return False+          1 -> return True+          _ -> Nothing+    toData _ = Nothing++instance DynData (S.Set DynBool) where+    fromData set = DBoolSet (S.map unDynBool set)+    toData (DBoolSet i) = Just $ S.map DynBool i+    toData _ = Nothing+ instance DynData DynNumber where     fromData (DynNumber i) = DNum i     toData (DNum i) = Just $ DynNumber i@@ -273,6 +306,10 @@     fromRep = Just     toRep   = id +instance DynVal Bool where+    type DynRep Bool = DynBool+    fromRep (DynBool i) = Just i+    toRep i = DynBool i  instance DynVal Int where     type DynRep Int = DynNumber@@ -370,7 +407,7 @@  ------------------------------------------------------------------------------- pico :: Rational-pico = toRational $ 10 ^ (12 :: Integer)+pico = toRational $ (10 :: Integer) ^ (12 :: Integer)   -------------------------------------------------------------------------------@@ -400,19 +437,7 @@       diff = fromRational ((toRational secs) / pico)  --- | Encoded as 0 and 1.-instance DynVal Bool where-    type DynRep Bool = DynNumber-    fromRep (DynNumber i) = do-        (i' :: Int) <- toIntegral i-        case i' of-          0 -> return False-          1 -> return True-          _ -> Nothing-    toRep b = DynNumber (if b then 1 else 0) -- -- | Type wrapper for binary data to be written to DynamoDB. Wrap any -- 'Serialize' instance in there and 'DynVal' will know how to -- automatically handle conversions in binary form.@@ -426,8 +451,19 @@     fromRep (DynBinary i) = either (const Nothing) (Just . Bin) $                             Ser.decode i +newtype OldBool = OldBool Bool +instance DynVal OldBool where+    type DynRep OldBool = DynNumber+    fromRep (DynNumber i) = OldBool `fmap` do+        (i' :: Int) <- toIntegral i+        case i' of+          0 -> return False+          1 -> return True+          _ -> Nothing+    toRep (OldBool b) = DynNumber (if b then 1 else 0) + ------------------------------------------------------------------------------- -- | Encode a Haskell value. toValue :: DynVal a  => a -> DValue@@ -448,7 +484,8 @@ -- | Value types natively recognized by DynamoDb. We pretty much -- exactly reflect the AWS API onto Haskell types. data DValue-    = DNum Scientific+    = DNull+    | DNum Scientific     | DString T.Text     | DBinary B.ByteString     -- ^ Binary data will automatically be base64 marshalled.@@ -456,6 +493,11 @@     | DStringSet (S.Set T.Text)     | DBinSet (S.Set B.ByteString)     -- ^ Binary data will automatically be base64 marshalled.+    | DBool Bool+    | DBoolSet (S.Set Bool)+    -- ^ Composite data+    | DList (V.Vector DValue)+    | DMap (M.Map T.Text DValue)     deriving (Eq,Show,Read,Ord,Typeable)  @@ -496,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@@ -560,12 +611,16 @@   instance ToJSON DValue where+    toJSON DNull = object ["NULL" .= True]     toJSON (DNum i) = object ["N" .= showT i]     toJSON (DString i) = object ["S" .= i]     toJSON (DBinary i) = object ["B" .= (T.decodeUtf8 $ Base64.encode i)]     toJSON (DNumSet i) = object ["NS" .= map showT (S.toList i)]     toJSON (DStringSet i) = object ["SS" .= S.toList i]     toJSON (DBinSet i) = object ["BS" .= map (T.decodeUtf8 . Base64.encode) (S.toList i)]+    toJSON (DBool i) = object ["BOOL" .= i]+    toJSON (DList i) = object ["L" .= i]+    toJSON (DMap i) = object ["M" .= i]     toJSON x = error $ "aws: bug: DynamoDB can't handle " ++ show x  @@ -573,6 +628,7 @@     parseJSON o = do       (obj :: [(T.Text, Value)]) <- M.toList `liftM` parseJSON o       case obj of+        [("NULL", _)] -> return DNull         [("N", numStr)] -> DNum <$> parseScientific numStr         [("S", str)] -> DString <$> parseJSON str         [("B", bin)] -> do@@ -585,6 +641,9 @@             xs <- mapM (either fail return . Base64.decode . T.encodeUtf8)                   =<< parseJSON s             return $ DBinSet $ S.fromList xs+        [("BOOL", b)] -> DBool <$> parseJSON b+        [("L", attrs)] -> DList <$> parseJSON attrs+        [("M", attrs)] -> DMap <$> parseJSON attrs          x -> fail $ "aws: unknown dynamodb value: " ++ show x @@ -604,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"  @@ -617,7 +676,7 @@  -- | Convert into JSON pair attributeJson :: Attribute -> Pair-attributeJson (Attribute nm v) = nm .= v+attributeJson (Attribute nm v) = AK.fromText nm .= v   -------------------------------------------------------------------------------@@ -697,9 +756,12 @@         ", x-amz-id-2=" `mappend`         fromMaybe "<none>" id2 +instance Sem.Semigroup DdbResponse where+    a <> b = DdbResponse (ddbrCrc a `mplus` ddbrCrc b) (ddbrMsgId a `mplus` ddbrMsgId b)+ instance Monoid DdbResponse where     mempty = DdbResponse Nothing Nothing-    mappend a b = DdbResponse (ddbrCrc a `mplus` ddbrCrc b) (ddbrMsgId a `mplus` ddbrMsgId b)+    mappend = (Sem.<>)   data Region = Region {@@ -740,8 +802,14 @@ ddbUsWest2 = Region "dynamodb.us-west-2.amazonaws.com" "us-west-2"  ddbEuWest1 :: Region-ddbEuWest1 = Region "dynamodb.eu-west-1.amazonaws.com" "us-west-1"+ddbEuWest1 = Region "dynamodb.eu-west-1.amazonaws.com" "eu-west-1" +ddbEuWest2 :: Region+ddbEuWest2 = Region "dynamodb.eu-west-2.amazonaws.com" "eu-west-2"++ddbEuCentral1 :: Region+ddbEuCentral1 = Region "dynamodb.eu-central-1.amazonaws.com" "eu-central-1"+ ddbApNe1 :: Region ddbApNe1 = Region "dynamodb.ap-northeast-1.amazonaws.com" "ap-northeast-1" @@ -794,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 ++@@ -837,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@@ -896,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) ]@@ -980,7 +1048,7 @@   conditionJson :: Condition -> Pair-conditionJson Condition{..} = condAttr .= condOp+conditionJson Condition{..} = AK.fromText condAttr .= condOp   instance ToJSON CondOp where@@ -1010,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."  @@ -1049,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."  @@ -1097,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]@@ -1112,12 +1181,17 @@     dynSize :: a -> Int  instance DynSize DValue where+    dynSize DNull = 8+    dynSize (DBool _) = 8+    dynSize (DBoolSet s) = sum $ map (dynSize . DBool) $ S.toList s     dynSize (DNum _) = 8     dynSize (DString a) = T.length a     dynSize (DBinary bs) = T.length . T.decodeUtf8 $ Base64.encode bs     dynSize (DNumSet s) = 8 * S.size s     dynSize (DStringSet s) = sum $ map (dynSize . DString) $ S.toList s     dynSize (DBinSet s) = sum $ map (dynSize . DBinary) $ S.toList s+    dynSize (DList s) = sum $ map dynSize $ V.toList s+    dynSize (DMap s) = sum $ map dynSize $ M.elems s  instance DynSize Attribute where     dynSize (Attribute k v) = T.length k + dynSize v@@ -1180,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 (<*>) #-}@@ -1209,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@@ -1266,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@@ -1281,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@@ -1299,15 +1385,22 @@       Nothing -> return Nothing       Just dv -> return $ fromValue dv +-- | Combinator for parsing an attribute into a 'FromDynItem'.+parseAttr+    :: FromDynItem a+    => T.Text+    -- ^ Attribute name+    -> Item+    -- ^ Item from DynamoDb+    -> Parser a+parseAttr k m =+  case M.lookup k m of+    Nothing -> fail ("Key " Sem.<> T.unpack k Sem.<> " not found")+    Just (DMap dv) -> either (const (fail "...")) return $ fromItem dv+    _       -> fail ("Key " Sem.<> T.unpack k Sem.<> " is not a map!")  ------------------------------------------------------------------------------- -- | Parse an 'Item' into target type using the 'FromDynItem' -- instance. fromItem :: FromDynItem a => Item -> Either String a fromItem i = runParser (parseItem i) Left Right------
Aws/Ec2/InstanceMetadata.hs view
@@ -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 ""
Aws/Iam/Commands.hs view
@@ -1,29 +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
+ Aws/Iam/Commands/AddUserToGroup.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeFamilies          #-}+module Aws.Iam.Commands.AddUserToGroup+    ( AddUserToGroup(..)+    , AddUserToGroupResponse(..)+    ) where++import           Aws.Core+import           Aws.Iam.Core+import           Aws.Iam.Internal+import           Data.Text        (Text)+import           Data.Typeable++-- | Adds the specified user to the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_AddUserToGroup.html>+data AddUserToGroup+    = AddUserToGroup {+        autgGroupName :: Text+      -- ^ Name of the group to update.+      , autgUserName  :: Text+      -- ^ The of the user to add.+      }+    deriving (Eq, Ord, Show, Typeable)++instance SignQuery AddUserToGroup where+    type ServiceConfiguration AddUserToGroup = IamConfiguration+    signQuery AddUserToGroup{..}+        = iamAction "AddUserToGroup" [+              ("GroupName"     , autgGroupName)+            , ("UserName"      , autgUserName)+            ]++data AddUserToGroupResponse = AddUserToGroupResponse+    deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer AddUserToGroup AddUserToGroupResponse where+    type ResponseMetadata AddUserToGroupResponse = IamMetadata+    responseConsumer _ _+        = iamResponseConsumer (const $ return AddUserToGroupResponse)++instance Transaction AddUserToGroup AddUserToGroupResponse++instance AsMemoryResponse AddUserToGroupResponse where+    type MemoryResponse AddUserToGroupResponse = AddUserToGroupResponse+    loadToMemory = return
Aws/Iam/Commands/CreateAccessKey.hs view
@@ -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
+ Aws/Iam/Commands/CreateGroup.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeFamilies          #-}+module Aws.Iam.Commands.CreateGroup+    ( CreateGroup(..)+    , CreateGroupResponse(..)+    , Group(..)+    ) where++import           Aws.Core+import           Aws.Iam.Core+import           Aws.Iam.Internal+import           Control.Applicative+import           Data.Text           (Text)+import           Data.Typeable+import           Prelude++-- | Creates a new group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_CreateGroup.html>+data CreateGroup+    = CreateGroup {+        cgGroupName :: Text+      -- ^ Name of the new group+      , cgPath     :: Maybe Text+      -- ^ Path under which the group will be created. Defaults to @/@ if+      -- omitted.+      }+    deriving (Eq, Ord, Show, Typeable)++instance SignQuery CreateGroup where+    type ServiceConfiguration CreateGroup = IamConfiguration+    signQuery CreateGroup{..}+        = iamAction' "CreateGroup" [+              Just ("GroupName", cgGroupName)+            , ("Path",) <$> cgPath+            ]++data CreateGroupResponse = CreateGroupResponse Group+    deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer CreateGroup CreateGroupResponse where+    type ResponseMetadata CreateGroupResponse = IamMetadata+    responseConsumer _ _+        = iamResponseConsumer $+          fmap CreateGroupResponse . parseGroup++instance Transaction CreateGroup CreateGroupResponse++instance AsMemoryResponse CreateGroupResponse where+    type MemoryResponse CreateGroupResponse = CreateGroupResponse+    loadToMemory = return
Aws/Iam/Commands/CreateUser.hs view
@@ -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
Aws/Iam/Commands/DeleteAccessKey.hs view
@@ -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
+ Aws/Iam/Commands/DeleteGroup.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+module Aws.Iam.Commands.DeleteGroup+    ( DeleteGroup(..)+    , DeleteGroupResponse(..)+    ) where++import           Aws.Core+import           Aws.Iam.Core+import           Aws.Iam.Internal+import           Data.Text          (Text)+import           Data.Typeable++-- | Deletes the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_DeleteGroup.html>+data DeleteGroup = DeleteGroup Text+    deriving (Eq, Ord, Show, Typeable)++instance SignQuery DeleteGroup where+    type ServiceConfiguration DeleteGroup = IamConfiguration+    signQuery (DeleteGroup groupName)+        = iamAction "DeleteGroup" [("GroupName", groupName)]++data DeleteGroupResponse = DeleteGroupResponse+    deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer DeleteGroup DeleteGroupResponse where+    type ResponseMetadata DeleteGroupResponse = IamMetadata+    responseConsumer _ _+        = iamResponseConsumer (const $ return DeleteGroupResponse)++instance Transaction DeleteGroup DeleteGroupResponse++instance AsMemoryResponse DeleteGroupResponse where+    type MemoryResponse DeleteGroupResponse = DeleteGroupResponse+    loadToMemory = return
+ Aws/Iam/Commands/DeleteGroupPolicy.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeFamilies          #-}+module Aws.Iam.Commands.DeleteGroupPolicy+    ( DeleteGroupPolicy(..)+    , DeleteGroupPolicyResponse(..)+    ) where++import           Aws.Core+import           Aws.Iam.Core+import           Aws.Iam.Internal+import           Data.Text          (Text)+import           Data.Typeable++-- | Deletes the specified policy associated with the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_DeleteGroupPolicy.html>+data DeleteGroupPolicy+    = DeleteGroupPolicy {+        dgpPolicyName :: Text+      -- ^ Name of the policy to be deleted.+      , dgpGroupName   :: Text+      -- ^ Name of the group with whom the policy is associated.+      }+    deriving (Eq, Ord, Show, Typeable)++instance SignQuery DeleteGroupPolicy where+    type ServiceConfiguration DeleteGroupPolicy = IamConfiguration+    signQuery DeleteGroupPolicy{..}+        = iamAction "DeleteGroupPolicy" [+              ("PolicyName", dgpPolicyName)+            , ("GroupName", dgpGroupName)+            ]++data DeleteGroupPolicyResponse = DeleteGroupPolicyResponse+    deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer DeleteGroupPolicy DeleteGroupPolicyResponse where+    type ResponseMetadata DeleteGroupPolicyResponse = IamMetadata+    responseConsumer _ _ =+        iamResponseConsumer (const $ return DeleteGroupPolicyResponse)++instance Transaction DeleteGroupPolicy DeleteGroupPolicyResponse++instance AsMemoryResponse DeleteGroupPolicyResponse where+    type MemoryResponse DeleteGroupPolicyResponse = DeleteGroupPolicyResponse+    loadToMemory = return
Aws/Iam/Commands/DeleteUser.hs view
@@ -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
Aws/Iam/Commands/DeleteUserPolicy.hs view
@@ -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
+ Aws/Iam/Commands/GetGroupPolicy.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeFamilies          #-}+module Aws.Iam.Commands.GetGroupPolicy+    ( GetGroupPolicy(..)+    , GetGroupPolicyResponse(..)+    ) where++import           Aws.Core+import           Aws.Iam.Core+import           Aws.Iam.Internal+import           Control.Applicative+import           Data.Text           (Text)+import qualified Data.Text           as Text+import qualified Data.Text.Encoding  as Text+import           Data.Typeable+import qualified Network.HTTP.Types  as HTTP+import           Text.XML.Cursor     (($//))+import           Prelude++-- | Retrieves the specified policy document for the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_GetGroupPolicy.html>+data GetGroupPolicy+    = GetGroupPolicy {+        ggpPolicyName :: Text+      -- ^ Name of the policy.+      , ggpGroupName   :: Text+      -- ^ Name of the group with whom the policy is associated.+      }+    deriving (Eq, Ord, Show, Typeable)++instance SignQuery GetGroupPolicy where+    type ServiceConfiguration GetGroupPolicy = IamConfiguration+    signQuery GetGroupPolicy{..}+        = iamAction "GetGroupPolicy" [+              ("PolicyName", ggpPolicyName)+            , ("GroupName", ggpGroupName)+            ]++data GetGroupPolicyResponse+    = GetGroupPolicyResponse {+        ggprPolicyDocument :: Text+      -- ^ The policy document.+      , ggprPolicyName     :: Text+      -- ^ Name of the policy.+      , ggprGroupName       :: Text+      -- ^ Name of the group with whom the policy is associated.+      }+    deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer GetGroupPolicy GetGroupPolicyResponse where+    type ResponseMetadata GetGroupPolicyResponse = IamMetadata+    responseConsumer _ _+        = iamResponseConsumer $ \cursor -> do+            let attr name = force ("Missing " ++ Text.unpack name) $+                            cursor $// elContent name+            ggprPolicyDocument <- decodePolicy <$>+                                  attr "PolicyDocument"+            ggprPolicyName     <- attr "PolicyName"+            ggprGroupName       <- attr "GroupName"+            return GetGroupPolicyResponse{..}+        where+          decodePolicy = Text.decodeUtf8 . HTTP.urlDecode False+                       . Text.encodeUtf8+++instance Transaction GetGroupPolicy GetGroupPolicyResponse++instance AsMemoryResponse GetGroupPolicyResponse where+    type MemoryResponse GetGroupPolicyResponse = GetGroupPolicyResponse+    loadToMemory = return
Aws/Iam/Commands/GetUser.hs view
@@ -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
Aws/Iam/Commands/GetUserPolicy.hs view
@@ -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. -- -- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_GetUserPolicy.html> 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
Aws/Iam/Commands/ListAccessKeys.hs view
@@ -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 $
+ Aws/Iam/Commands/ListGroupPolicies.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeFamilies          #-}+module Aws.Iam.Commands.ListGroupPolicies+    ( ListGroupPolicies(..)+    , ListGroupPoliciesResponse(..)+    ) where++import           Aws.Core+import           Aws.Iam.Core+import           Aws.Iam.Internal+import           Data.Text        (Text)+import           Data.Typeable+import           Text.XML.Cursor  (content, laxElement, ($//), (&/))++-- | Lists the group policies associated with the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_ListGroupPolicies.html>+data ListGroupPolicies+    = ListGroupPolicies {+        lgpGroupName :: Text+      -- ^ Policies associated with this group will be listed.+      , lgpMarker   :: Maybe Text+      -- ^ Used for paginating requests. Marks the position of the last+      -- request.+      , lgpMaxItems :: Maybe Integer+      -- ^ Used for paginating requests. Specifies the maximum number of items+      -- to return in the response. Defaults to 100.+      }+    deriving (Eq, Ord, Show, Typeable)++instance SignQuery ListGroupPolicies where+    type ServiceConfiguration ListGroupPolicies = IamConfiguration+    signQuery ListGroupPolicies{..}+        = iamAction' "ListGroupPolicies" $ [+              Just ("GroupName", lgpGroupName)+            ] <> markedIter lgpMarker lgpMaxItems++data ListGroupPoliciesResponse+    = ListGroupPoliciesResponse {+        lgprPolicyNames :: [Text]+      -- ^ List of policy names.+      , lgprIsTruncated :: Bool+      -- ^ @True@ if the request was truncated because of too many items.+      , lgprMarker      :: Maybe Text+      -- ^ Marks the position at which the request was truncated. This value+      -- must be passed with the next request to continue listing from the+      -- last position.+      }+    deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer ListGroupPolicies ListGroupPoliciesResponse where+    type ResponseMetadata ListGroupPoliciesResponse = IamMetadata+    responseConsumer _ _+        = iamResponseConsumer $ \cursor -> do+            (lgprIsTruncated, lgprMarker) <- markedIterResponse cursor+            let lgprPolicyNames = cursor $// laxElement "member" &/ content+            return ListGroupPoliciesResponse{..}++instance Transaction ListGroupPolicies ListGroupPoliciesResponse++instance IteratedTransaction ListGroupPolicies ListGroupPoliciesResponse where+    nextIteratedRequest request response+        = case lgprMarker response of+            Nothing     -> Nothing+            Just marker -> Just $ request { lgpMarker = Just marker }++instance AsMemoryResponse ListGroupPoliciesResponse where+    type MemoryResponse ListGroupPoliciesResponse = ListGroupPoliciesResponse+    loadToMemory = return
+ Aws/Iam/Commands/ListGroups.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeFamilies          #-}+module Aws.Iam.Commands.ListGroups+    ( ListGroups(..)+    , ListGroupsResponse(..)+    , Group(..)+    ) where++import           Aws.Core+import           Aws.Iam.Core+import           Aws.Iam.Internal+import           Control.Applicative+import           Data.Text           (Text)+import           Data.Typeable+import           Prelude+import           Text.XML.Cursor     (laxElement, ($//), (&|))++-- | Lists groups that have the specified path prefix.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_ListGroups.html>+data ListGroups+    = ListGroups {+        lgPathPrefix :: Maybe Text+      -- ^ Groups defined under this path will be listed. If omitted, defaults+      -- to @/@, which lists all groups.+      , lgMarker     :: Maybe Text+      -- ^ Used for paginating requests. Marks the position of the last+      -- request.+      , lgMaxItems   :: Maybe Integer+      -- ^ Used for paginating requests. Specifies the maximum number of items+      -- to return in the response. Defaults to 100.+      }+    deriving (Eq, Ord, Show, Typeable)++instance SignQuery ListGroups where+    type ServiceConfiguration ListGroups = IamConfiguration+    signQuery ListGroups{..}+        = iamAction' "ListGroups" $ [+              ("PathPrefix",) <$> lgPathPrefix+            ] <> markedIter lgMarker lgMaxItems++data ListGroupsResponse+    = ListGroupsResponse {+        lgrGroups       :: [Group]+      -- ^ List of 'Group's.+      , lgrIsTruncated :: Bool+      -- ^ @True@ if the request was truncated because of too many items.+      , lgrMarker      :: Maybe Text+      -- ^ Marks the position at which the request was truncated. This value+      -- must be passed with the next request to continue listing from the+      -- last position.+      }+    deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer ListGroups ListGroupsResponse where+    type ResponseMetadata ListGroupsResponse = IamMetadata+    responseConsumer _ _+        = iamResponseConsumer $ \cursor -> do+            (lgrIsTruncated, lgrMarker) <- markedIterResponse cursor+            lgrGroups <- sequence $+                cursor $// laxElement "member" &| parseGroup+            return ListGroupsResponse{..}++instance Transaction ListGroups ListGroupsResponse++instance IteratedTransaction ListGroups ListGroupsResponse where+    nextIteratedRequest request response+        = case lgrMarker response of+            Nothing     -> Nothing+            Just marker -> Just $ request { lgMarker = Just marker }++instance AsMemoryResponse ListGroupsResponse where+    type MemoryResponse ListGroupsResponse = ListGroupsResponse+    loadToMemory = return
+ Aws/Iam/Commands/ListMfaDevices.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE RecordWildCards       #-}+module Aws.Iam.Commands.ListMfaDevices+       ( ListMfaDevices(..)+       , ListMfaDevicesResponse(..)+       ) where++import Aws.Core+import Aws.Iam.Core+import Aws.Iam.Internal+import Control.Applicative+import Data.Text (Text)+import Data.Typeable+import Prelude+import Text.XML.Cursor (laxElement, ($//), (&|))+-- | Lists the MFA devices. If the request includes the user name,+-- then this action lists all the MFA devices associated with the+-- specified user name. If you do not specify a user name, IAM+-- determines the user name implicitly based on the AWS access key ID+-- signing the request.+--+-- <https://docs.aws.amazon.com/IAM/latest/APIReference/API_ListMFADevices.html>++data ListMfaDevices = ListMfaDevices+                      { lmfaUserName :: Maybe Text+                        -- ^ The name of the user whose MFA devices+                        -- you want to list.  If you do not specify a+                        -- user name, IAM determines the user name+                        -- implicitly based on the AWS access key ID+                        -- signing the request+                      , lmfaMarker   :: Maybe Text+                        -- ^ Used for paginating requests. Marks the+                        -- position of the last request.+                      , lmfaMaxItems :: Maybe Integer+                        -- ^ Used for paginating requests. Specifies+                        -- the maximum number of items to return in+                        -- the response. Defaults to 100.+                      } deriving (Eq, Ord, Show, Typeable)++instance SignQuery ListMfaDevices where+  type ServiceConfiguration ListMfaDevices = IamConfiguration+  signQuery ListMfaDevices{..} = iamAction' "ListMFADevices"+                                 ([ ("UserName",) <$> lmfaUserName ]+                                 <> markedIter lmfaMarker lmfaMaxItems)++data ListMfaDevicesResponse = ListMfaDevicesResponse+                              { lmfarMfaDevices :: [MfaDevice]+                                -- ^ List of 'MFA Device's.+                              , lmfarIsTruncated :: Bool+                                -- ^ @True@ if the request was+                                -- truncated because of too many+                                -- items.+                              , lmfarMarker :: Maybe Text+                                -- ^ Marks the position at which the+                                -- request was truncated. This value+                                -- must be passed with the next+                                -- request to continue listing from+                                -- the last position.+                              } deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer ListMfaDevices ListMfaDevicesResponse where+  type ResponseMetadata ListMfaDevicesResponse = IamMetadata+  responseConsumer _ _req =+    iamResponseConsumer $ \ cursor -> do+      (lmfarIsTruncated, lmfarMarker) <- markedIterResponse cursor+      lmfarMfaDevices <-+        sequence $ cursor $// laxElement "member" &| parseMfaDevice+      return ListMfaDevicesResponse{..}++instance Transaction ListMfaDevices ListMfaDevicesResponse++instance IteratedTransaction ListMfaDevices ListMfaDevicesResponse where+    nextIteratedRequest request response+        = case lmfarMarker response of+            Nothing     -> Nothing+            Just marker -> Just $ request { lmfaMarker = Just marker }++instance AsMemoryResponse ListMfaDevicesResponse where+    type MemoryResponse ListMfaDevicesResponse = ListMfaDevicesResponse+    loadToMemory = return
Aws/Iam/Commands/ListUserPolicies.hs view
@@ -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
Aws/Iam/Commands/ListUsers.hs view
@@ -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 $
+ Aws/Iam/Commands/PutGroupPolicy.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeFamilies          #-}+module Aws.Iam.Commands.PutGroupPolicy+    ( PutGroupPolicy(..)+    , PutGroupPolicyResponse(..)+    ) where++import           Aws.Core+import           Aws.Iam.Core+import           Aws.Iam.Internal+import           Data.Text        (Text)+import           Data.Typeable++-- | Adds a policy document with the specified name, associated with the+-- specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_PutGroupPolicy.html>+data PutGroupPolicy+    = PutGroupPolicy {+        pgpPolicyDocument :: Text+      -- ^ The policy document.+      , pgpPolicyName     :: Text+      -- ^ Name of the policy.+      , pgpGroupName       :: Text+      -- ^ Name of the group with whom this policy is associated.+      }+    deriving (Eq, Ord, Show, Typeable)++instance SignQuery PutGroupPolicy where+    type ServiceConfiguration PutGroupPolicy = IamConfiguration+    signQuery PutGroupPolicy{..}+        = iamAction "PutGroupPolicy" [+              ("PolicyDocument", pgpPolicyDocument)+            , ("PolicyName"    , pgpPolicyName)+            , ("GroupName"      , pgpGroupName)+            ]++data PutGroupPolicyResponse = PutGroupPolicyResponse+    deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer PutGroupPolicy PutGroupPolicyResponse where+    type ResponseMetadata PutGroupPolicyResponse = IamMetadata+    responseConsumer _ _+        = iamResponseConsumer (const $ return PutGroupPolicyResponse)++instance Transaction PutGroupPolicy PutGroupPolicyResponse++instance AsMemoryResponse PutGroupPolicyResponse where+    type MemoryResponse PutGroupPolicyResponse = PutGroupPolicyResponse+    loadToMemory = return
Aws/Iam/Commands/PutUserPolicy.hs view
@@ -41,7 +41,7 @@  instance ResponseConsumer PutUserPolicy PutUserPolicyResponse where     type ResponseMetadata PutUserPolicyResponse = IamMetadata-    responseConsumer _+    responseConsumer _ _         = iamResponseConsumer (const $ return PutUserPolicyResponse)  instance Transaction PutUserPolicy PutUserPolicyResponse
+ Aws/Iam/Commands/RemoveUserFromGroup.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TypeFamilies          #-}+module Aws.Iam.Commands.RemoveUserFromGroup+    ( RemoveUserFromGroup(..)+    , RemoveUserFromGroupResponse(..)+    ) where++import           Aws.Core+import           Aws.Iam.Core+import           Aws.Iam.Internal+import           Data.Text        (Text)+import           Data.Typeable++-- | Removes the specified user from the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_RemoveUserFromGroup.html>+data RemoveUserFromGroup+    = RemoveUserFromGroup {+        rufgGroupName :: Text+      -- ^ Name of the group to update.+      , rufgUserName  :: Text+      -- ^ The of the user to add.+      }+    deriving (Eq, Ord, Show, Typeable)++instance SignQuery RemoveUserFromGroup where+    type ServiceConfiguration RemoveUserFromGroup = IamConfiguration+    signQuery RemoveUserFromGroup{..}+        = iamAction "RemoveUserFromGroup" [+              ("GroupName"     , rufgGroupName)+            , ("UserName"      , rufgUserName)+            ]++data RemoveUserFromGroupResponse = RemoveUserFromGroupResponse+    deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer RemoveUserFromGroup RemoveUserFromGroupResponse where+    type ResponseMetadata RemoveUserFromGroupResponse = IamMetadata+    responseConsumer _ _+        = iamResponseConsumer (const $ return RemoveUserFromGroupResponse)++instance Transaction RemoveUserFromGroup RemoveUserFromGroupResponse++instance AsMemoryResponse RemoveUserFromGroupResponse where+    type MemoryResponse RemoveUserFromGroupResponse = RemoveUserFromGroupResponse+    loadToMemory = return
Aws/Iam/Commands/UpdateAccessKey.hs view
@@ -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
+ Aws/Iam/Commands/UpdateGroup.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeFamilies          #-}+module Aws.Iam.Commands.UpdateGroup+    ( UpdateGroup(..)+    , UpdateGroupResponse(..)+    ) where++import           Aws.Core+import           Aws.Iam.Core+import           Aws.Iam.Internal+import           Control.Applicative+import           Data.Text           (Text)+import           Data.Typeable+import           Prelude++-- | Updates the name and/or path of the specified group.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_UpdateGroup.html>+data UpdateGroup+    = UpdateGroup {+        ugGroupName    :: Text+      -- ^ Name of the group to be updated.+      , ugNewGroupName :: Maybe Text+      -- ^ New name for the group.+      , ugNewPath     :: Maybe Text+      -- ^ New path to which the group will be moved.+      }+    deriving (Eq, Ord, Show, Typeable)++instance SignQuery UpdateGroup where+    type ServiceConfiguration UpdateGroup = IamConfiguration+    signQuery UpdateGroup{..}+        = iamAction' "UpdateGroup" [+              Just ("GroupName", ugGroupName)+            , ("NewGroupName",) <$> ugNewGroupName+            , ("NewPath",) <$> ugNewPath+            ]++data UpdateGroupResponse = UpdateGroupResponse+    deriving (Eq, Ord, Show, Typeable)++instance ResponseConsumer UpdateGroup UpdateGroupResponse where+    type ResponseMetadata UpdateGroupResponse = IamMetadata+    responseConsumer _ _+        = iamResponseConsumer (const $ return UpdateGroupResponse)++instance Transaction UpdateGroup UpdateGroupResponse++instance AsMemoryResponse UpdateGroupResponse where+    type MemoryResponse UpdateGroupResponse = UpdateGroupResponse+    loadToMemory = return
Aws/Iam/Commands/UpdateUser.hs view
@@ -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
Aws/Iam/Core.hs view
@@ -14,6 +14,10 @@     , AccessKeyStatus(..)     , User(..)     , parseUser+    , Group(..)+    , parseGroup+    , MfaDevice(..)+    , parseMfaDevice     ) where  import           Aws.Core@@ -26,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                (($//))@@ -58,11 +61,14 @@     deriving (Show, Typeable)  instance Loggable IamMetadata where-    toLogText (IamMetadata r) = "IAM: request ID=" <> fromMaybe "<none>" r+    toLogText (IamMetadata r) = "IAM: request ID=" Sem.<> fromMaybe "<none>" r +instance Sem.Semigroup IamMetadata where+    IamMetadata r1 <> IamMetadata r2 = IamMetadata (r1 `mplus` r2)+ instance Monoid IamMetadata where     mempty = IamMetadata Nothing-    IamMetadata r1 `mappend` IamMetadata r2 = IamMetadata (r1 `mplus` r2)+    mappend = (Sem.<>)  data IamConfiguration qt     = IamConfiguration {@@ -162,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 @@ -198,5 +204,64 @@                 cursor $// elContent name  +-- | The IAM @Group@ data type.+--+-- <http://docs.aws.amazon.com/IAM/latest/APIReference/API_Group.html>+data Group+    = Group {+        groupArn        :: Text+      -- ^ ARN used to refer to this group.+      , groupCreateDate :: UTCTime+      -- ^ Date and time at which the group was created.+      , groupPath       :: Text+      -- ^ Path under which the group was created.+      , groupGroupId     :: Text+      -- ^ Unique identifier used to refer to this group. +      , groupGroupName   :: Text+      -- ^ Name of the group.+      }+    deriving (Eq, Ord, Show, Typeable)++-- | Parses the IAM @Group@ data type.+parseGroup :: MonadThrow m => Cu.Cursor -> m Group+parseGroup cursor = do+    groupArn        <- attr "Arn"+    groupCreateDate <- attr "CreateDate" >>= parseDateTime . Text.unpack+    groupPath       <- attr "Path"+    groupGroupId     <- attr "GroupId"+    groupGroupName   <- attr "GroupName"+    return Group{..}+  where+    attr name = force ("Missing " ++ Text.unpack name) $+                cursor $// elContent name++ data AccessKeyStatus = AccessKeyActive | AccessKeyInactive     deriving (Eq, Ord, Show, Typeable)++-- | The IAM @MFADevice@ data type.+--+-- <https://docs.aws.amazon.com/IAM/latest/APIReference/API_MFADevice.html>+data MfaDevice = MfaDevice+                 { mfaEnableDate   :: UTCTime+                   -- ^ The date when the MFA device was enabled for+                   -- the user.+                 , mfaSerialNumber :: Text+                   -- ^ The serial number that uniquely identifies the+                   -- MFA device. For virtual MFA devices, the serial+                   -- number is the device ARN.+                 , mfaUserName     :: Text+                   -- ^ The user with whom the MFA device is+                   -- associated. Minimum length of 1. Maximum length+                   -- of 64.+                 } deriving (Eq, Ord, Show, Typeable)++-- | Parses the IAM @MFADevice@ data type.+parseMfaDevice :: MonadThrow m => Cu.Cursor -> m MfaDevice+parseMfaDevice cursor = do+  mfaEnableDate   <- attr "EnableDate" >>= parseDateTime . Text.unpack+  mfaSerialNumber <- attr "SerialNumber"+  mfaUserName     <- attr "UserName"+  return MfaDevice{..}+ where attr name = force ("Missing " ++ Text.unpack name) $+               cursor $// elContent name
Aws/Iam/Internal.hs view
@@ -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
Aws/Network.hs view
@@ -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
Aws/S3/Commands.hs view
@@ -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
Aws/S3/Commands/CopyObject.hs view
@@ -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)
Aws/S3/Commands/DeleteBucket.hs view
@@ -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
Aws/S3/Commands/DeleteObject.hs view
@@ -10,10 +10,10 @@ data DeleteObject = DeleteObject {   doObjectName :: T.Text,   doBucket :: Bucket-}+} deriving (Show)  data DeleteObjectResponse = DeleteObjectResponse{-}+} deriving (Show)  -- | ServiceConfiguration: 'S3Configuration' instance SignQuery DeleteObject where@@ -33,7 +33,8 @@  instance ResponseConsumer DeleteObject DeleteObjectResponse where     type ResponseMetadata DeleteObjectResponse = S3Metadata-    responseConsumer _ = s3ResponseConsumer $ \_ -> return DeleteObjectResponse+    responseConsumer _ _+        = s3ResponseConsumer $ \_ -> return DeleteObjectResponse  instance Transaction DeleteObject DeleteObjectResponse
+ Aws/S3/Commands/DeleteObjectVersion.hs view
@@ -0,0 +1,52 @@+module Aws.S3.Commands.DeleteObjectVersion+where++import           Aws.Core+import           Aws.S3.Core+import           Data.ByteString.Char8      ({- IsString -})+import qualified Data.Text                  as T+import qualified Data.Text.Encoding         as T++data DeleteObjectVersion = DeleteObjectVersion {+  dovObjectName :: T.Text,+  dovBucket :: Bucket,+  dovVersionId :: T.Text+} deriving (Show)++deleteObjectVersion :: Bucket -> T.Text -> T.Text -> DeleteObjectVersion+deleteObjectVersion bucket object version+    = DeleteObjectVersion {+          dovObjectName = object+        , dovBucket = bucket+        , dovVersionId = version+        }++data DeleteObjectVersionResponse = DeleteObjectVersionResponse {+} deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery DeleteObjectVersion where+    type ServiceConfiguration DeleteObjectVersion = S3Configuration+    signQuery DeleteObjectVersion {..} = s3SignQuery S3Query {+                                 s3QMethod = Delete+                               , s3QBucket = Just $ T.encodeUtf8 dovBucket+                               , s3QSubresources = [ ("versionId", Just $ T.encodeUtf8 dovVersionId) ]+                               , s3QQuery = []+                               , s3QContentType = Nothing+                               , s3QContentMd5 = Nothing+                               , s3QAmzHeaders = []+                               , s3QOtherHeaders = []+                               , s3QRequestBody = Nothing+                               , s3QObject = Just $ T.encodeUtf8 dovObjectName+                               }++instance ResponseConsumer DeleteObjectVersion DeleteObjectVersionResponse where+    type ResponseMetadata DeleteObjectVersionResponse = S3Metadata+    responseConsumer _ _+        = s3ResponseConsumer $ \_ -> return DeleteObjectVersionResponse++instance Transaction DeleteObjectVersion DeleteObjectVersionResponse++instance AsMemoryResponse DeleteObjectVersionResponse where+    type MemoryResponse DeleteObjectVersionResponse = DeleteObjectVersionResponse+    loadToMemory = return
Aws/S3/Commands/DeleteObjects.hs view
@@ -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
Aws/S3/Commands/GetBucket.hs view
@@ -11,6 +11,7 @@ import qualified Data.Text             as T import qualified Data.Text.Encoding    as T import qualified Data.Traversable+import           Prelude import qualified Network.HTTP.Types    as HTTP import qualified Text.XML.Cursor       as Cu @@ -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"
Aws/S3/Commands/GetBucketLocation.hs view
@@ -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 }
+ Aws/S3/Commands/GetBucketObjectVersions.hs view
@@ -0,0 +1,125 @@+module Aws.S3.Commands.GetBucketObjectVersions+where++import           Aws.Core+import           Aws.S3.Core+import           Control.Applicative+import           Data.ByteString.Char8 ({- IsString -})+import           Data.Maybe+import           Text.XML.Cursor       (($/), (&|), (&//))+import qualified Data.ByteString.Char8 as B8+import qualified Data.Text             as T+import qualified Data.Text.Encoding    as T+import qualified Data.Traversable+import           Prelude+import qualified Network.HTTP.Types    as HTTP+import qualified Text.XML.Cursor       as Cu+import qualified Text.XML              as XML++data GetBucketObjectVersions+    = GetBucketObjectVersions {+        gbovBucket          :: Bucket+      , gbovDelimiter       :: Maybe T.Text+      , gbovKeyMarker       :: Maybe T.Text+      , gbovMaxKeys         :: Maybe Int+      , gbovPrefix          :: Maybe T.Text+      , gbovVersionIdMarker :: Maybe T.Text+      }+    deriving (Show)++getBucketObjectVersions :: Bucket -> GetBucketObjectVersions+getBucketObjectVersions bucket+    = GetBucketObjectVersions {+        gbovBucket          = bucket+      , gbovDelimiter       = Nothing+      , gbovKeyMarker       = Nothing+      , gbovMaxKeys         = Nothing+      , gbovPrefix          = Nothing+      , gbovVersionIdMarker = Nothing+      }++data GetBucketObjectVersionsResponse+    = GetBucketObjectVersionsResponse {+        gbovrName                :: Bucket+      , gbovrDelimiter           :: Maybe T.Text+      , gbovrKeyMarker           :: Maybe T.Text+      , gbovrMaxKeys             :: Maybe Int+      , gbovrPrefix              :: Maybe T.Text+      , gbovrVersionIdMarker     :: Maybe T.Text+      , gbovrContents            :: [ObjectVersionInfo]+      , gbovrCommonPrefixes      :: [T.Text]+      , gbovrIsTruncated         :: Bool+      , gbovrNextKeyMarker       :: Maybe T.Text+      , gbovrNextVersionIdMarker :: Maybe T.Text+      }+    deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery GetBucketObjectVersions where+    type ServiceConfiguration GetBucketObjectVersions = S3Configuration+    signQuery GetBucketObjectVersions {..} = s3SignQuery S3Query {+                                 s3QMethod = Get+                               , s3QBucket = Just $ T.encodeUtf8 gbovBucket+                               , s3QObject = Nothing+                               , s3QSubresources = [ ("versions", Nothing) ]+                               , s3QQuery = HTTP.toQuery [+                                              ("delimiter" :: B8.ByteString ,) <$> gbovDelimiter+                                            , ("key-marker",) <$> gbovKeyMarker+                                            , ("max-keys",) . T.pack . show <$> gbovMaxKeys+                                            , ("prefix",) <$> gbovPrefix+                                            , ("version-id-marker",) <$> gbovVersionIdMarker+                                            ]+                               , s3QContentType = Nothing+                               , s3QContentMd5 = Nothing+                               , s3QAmzHeaders = []+                               , s3QOtherHeaders = []+                               , s3QRequestBody = Nothing+                               }++instance ResponseConsumer r GetBucketObjectVersionsResponse where+    type ResponseMetadata GetBucketObjectVersionsResponse = S3Metadata++    responseConsumer _ _ = s3XmlResponseConsumer parse+        where parse cursor+                  = do name <- force "Missing Name" $ cursor $/ elContent "Name"+                       let delimiter = listToMaybe $ cursor $/ elContent "Delimiter"+                       let keyMarker = listToMaybe $ cursor $/ elContent "KeyMarker"+                       let versionMarker = listToMaybe $ cursor $/ elContent "VersionIdMarker"+                       maxKeys <- Data.Traversable.sequence . listToMaybe $ cursor $/ elContent "MaxKeys" &| textReadInt+                       let truncated = maybe True (/= "false") $ listToMaybe $ cursor $/ elContent "IsTruncated"+                       let nextKeyMarker = listToMaybe $ cursor $/ elContent "NextKeyMarker"+                       let nextVersionMarker = listToMaybe $ cursor $/ elContent "NextVersionIdMarker"+                       let prefix = listToMaybe $ cursor $/ elContent "Prefix"+                       contents <- sequence $ cursor $/ Cu.checkName objectNodeName &| parseObjectVersionInfo+                       let commonPrefixes = cursor $/ Cu.laxElement "CommonPrefixes" &// Cu.content+                       return GetBucketObjectVersionsResponse{+                                                gbovrName                = name+                                              , gbovrDelimiter           = delimiter+                                              , gbovrKeyMarker           = keyMarker+                                              , gbovrMaxKeys             = maxKeys+                                              , gbovrPrefix              = prefix+                                              , gbovrVersionIdMarker     = versionMarker+                                              , gbovrContents            = contents+                                              , gbovrCommonPrefixes      = commonPrefixes+                                              , gbovrIsTruncated         = truncated+                                              , gbovrNextKeyMarker       = nextKeyMarker+                                              , gbovrNextVersionIdMarker = nextVersionMarker+                                              }+              objectNodeName n = let fn = T.toCaseFold $ XML.nameLocalName n+                                  in fn == T.toCaseFold "Version" || fn == T.toCaseFold "DeleteMarker"++instance Transaction GetBucketObjectVersions GetBucketObjectVersionsResponse++instance IteratedTransaction GetBucketObjectVersions GetBucketObjectVersionsResponse where+    nextIteratedRequest request response+        = case (gbovrIsTruncated response, gbovrNextKeyMarker response, gbovrNextVersionIdMarker response, gbovrContents response) of+            (True, Just keyMarker, Just versionMarker, _             ) -> Just $ request { gbovKeyMarker = Just keyMarker, gbovVersionIdMarker = Just versionMarker }+            (True, Nothing,        Nothing,            contents@(_:_)) -> Just $ request { gbovKeyMarker = Just $ oviKey $ last contents, gbovVersionIdMarker = Just $ oviVersionId $ last contents }+            (_,    _,              _,                  _             ) -> Nothing++instance ListResponse GetBucketObjectVersionsResponse ObjectVersionInfo where+    listResponse = gbovrContents++instance AsMemoryResponse GetBucketObjectVersionsResponse where+    type MemoryResponse GetBucketObjectVersionsResponse = GetBucketObjectVersionsResponse+    loadToMemory = return
+ Aws/S3/Commands/GetBucketVersioning.hs view
@@ -0,0 +1,65 @@+module Aws.S3.Commands.GetBucketVersioning +( +  module Aws.S3.Commands.GetBucketVersioning+, VersioningState(..)+) where++import           Aws.Core+import           Aws.S3.Commands.PutBucketVersioning (VersioningState(..))+import           Aws.S3.Core+import           Control.Monad.Trans.Resource (throwM)+import           Network.HTTP.Types (toQuery)+import qualified Data.Text.Encoding   as T+import           Text.XML.Cursor (($.//))+import qualified Data.ByteString.Lazy.Char8 as B8++-- | Gets the versioning state of an existing bucket.+data GetBucketVersioning+    = GetBucketVersioning+      { gbvBucket :: Bucket+      }+    deriving (Show)++getBucketVersioning :: Bucket -> GetBucketVersioning+getBucketVersioning = GetBucketVersioning++data GetBucketVersioningResponse+    = GetBucketVersioningResponse+        { gbvVersioning :: Maybe VersioningState }+        -- ^ Nothing when the bucket is not versioned+    deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery GetBucketVersioning where+    type ServiceConfiguration GetBucketVersioning = S3Configuration++    signQuery GetBucketVersioning{..} = s3SignQuery $ S3Query+      { s3QMethod       = Get+      , s3QBucket       = Just $ T.encodeUtf8 gbvBucket+      , s3QSubresources = toQuery [("versioning" :: B8.ByteString, Nothing :: Maybe B8.ByteString)]+      , s3QQuery        = []+      , s3QContentType  = Nothing+      , s3QContentMd5   = Nothing+      , s3QObject       = Nothing+      , s3QAmzHeaders   = []+      , s3QOtherHeaders = []+      , s3QRequestBody  = Nothing+      }++instance ResponseConsumer r GetBucketVersioningResponse where+    type ResponseMetadata GetBucketVersioningResponse = S3Metadata++    responseConsumer _ _ = s3XmlResponseConsumer parse+      where parse cursor = do+              v <- case cursor $.// elContent "Status" of+                   [] -> return Nothing+                   ("Enabled":[]) -> return (Just VersioningEnabled)+                   ("Suspended":[]) -> return (Just VersioningSuspended)+                   _ -> throwM $ XmlException "Invalid Status"+              return GetBucketVersioningResponse { gbvVersioning = v }++instance Transaction GetBucketVersioning GetBucketVersioningResponse++instance AsMemoryResponse GetBucketVersioningResponse where+    type MemoryResponse GetBucketVersioningResponse = GetBucketVersioningResponse+    loadToMemory = return
Aws/S3/Commands/GetObject.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Aws.S3.Commands.GetObject where @@ -9,10 +11,12 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy  as L import qualified Data.Conduit          as C+import           Data.Conduit ((.|)) import qualified Data.Conduit.List     as CL import           Data.Maybe import qualified Data.Text             as T import qualified Data.Text.Encoding    as T+import           Prelude import qualified Network.HTTP.Conduit  as HTTP import qualified Network.HTTP.Types    as HTTP @@ -28,16 +32,20 @@       , goResponseContentDisposition :: Maybe T.Text       , goResponseContentEncoding :: Maybe T.Text       , goResponseContentRange :: Maybe (Int,Int)+      , goIfMatch :: Maybe T.Text+      -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is the same as the one specified; otherwise, catch a 'StatusCodeException' with a status of 412 precondition failed.+      , goIfNoneMatch :: Maybe T.Text+      -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is different from the one specified; otherwise, catch a 'StatusCodeException' with a status of 304 not modified.       }   deriving (Show)  getObject :: Bucket -> T.Text -> GetObject-getObject b o = GetObject b o Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+getObject b o = GetObject b o Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing  data GetObjectResponse     = GetObjectResponse {         gorMetadata :: ObjectMetadata,-        gorResponse :: HTTP.Response (C.ResumableSource (ResourceT IO) B8.ByteString)+        gorResponse :: HTTP.Response (C.ConduitM () B8.ByteString (ResourceT IO) ())       }  data GetObjectMemoryResponse@@ -66,6 +74,8 @@                                  , s3QAmzHeaders = []                                  , s3QOtherHeaders = catMaybes [                                                        decodeRange <$> goResponseContentRange+                                                     , ("if-match",) . T.encodeUtf8 <$> goIfMatch+                                                     , ("if-none-match",) . T.encodeUtf8 <$> goIfNoneMatch                                                      ]                                  , s3QRequestBody = Nothing                                  }@@ -73,17 +83,21 @@  instance ResponseConsumer GetObject GetObjectResponse where     type ResponseMetadata GetObjectResponse = S3Metadata-    responseConsumer GetObject{..} metadata resp-        = do rsp <- s3BinaryResponseConsumer return metadata resp-             om <- parseObjectMetadata (HTTP.responseHeaders resp)-             return $ GetObjectResponse om rsp+    responseConsumer httpReq GetObject{} metadata resp+        | status == HTTP.status200 = do+            rsp <- s3BinaryResponseConsumer return metadata resp+            om <- parseObjectMetadata (HTTP.responseHeaders resp)+            return $ GetObjectResponse om rsp+        | otherwise = throwStatusCodeException httpReq resp+      where+        status  = HTTP.responseStatus    resp  instance Transaction GetObject GetObjectResponse  instance AsMemoryResponse GetObjectResponse where     type MemoryResponse GetObjectResponse = GetObjectMemoryResponse     loadToMemory (GetObjectResponse om x) = 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             }
Aws/S3/Commands/GetService.hs view
@@ -6,16 +6,14 @@ import           Aws.S3.Core import           Data.Maybe import           Data.Time.Format-#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  (($/), ($//), (&|)) import qualified Data.Text        as T import qualified Text.XML.Cursor  as Cu -data GetService = GetService+data GetService = GetService deriving (Show)  data GetServiceResponse     = GetServiceResponse {@@ -27,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@@ -37,7 +35,7 @@           parseBucket el = do             name <- force "Missing owner Name" $ el $/ elContent "Name"             creationDateString <- force "Missing owner CreationDate" $ el $/ elContent "CreationDate" &| T.unpack-            creationDate <- force "Invalid CreationDate" . maybeToList $ parseTime defaultTimeLocale iso8601UtcDate creationDateString+            creationDate <- force "Invalid CreationDate" . maybeToList $ parseTimeM True defaultTimeLocale iso8601UtcDate creationDateString             return BucketInfo { bucketName = name, bucketCreationDate = creationDate }  -- | ServiceConfiguration: 'S3Configuration'
Aws/S3/Commands/HeadObject.hs view
@@ -4,11 +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 @@ -17,16 +18,20 @@         hoBucket :: Bucket       , hoObjectName :: Object       , hoVersionId :: Maybe T.Text+      , hoIfMatch :: Maybe T.Text+      -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is the same as the one specified; otherwise, catch a 'StatusCodeException' with a status of 412 precondition failed.+      , hoIfNoneMatch :: Maybe T.Text+      -- ^ Return the object only if its entity tag (ETag, which is an md5sum of the content) is different from the one specified; otherwise, catch a 'StatusCodeException' with a status of 304 not modified.       }   deriving (Show)  headObject :: Bucket -> T.Text -> HeadObject-headObject b o = HeadObject b o Nothing+headObject b o = HeadObject b o Nothing Nothing Nothing  data HeadObjectResponse     = HeadObjectResponse {         horMetadata :: Maybe ObjectMetadata-      }+      } deriving (Show)  data HeadObjectMemoryResponse     = HeadObjectMemoryResponse (Maybe ObjectMetadata)@@ -46,20 +51,22 @@                                  , s3QContentType = Nothing                                  , s3QContentMd5 = Nothing                                  , s3QAmzHeaders = []-                                 , s3QOtherHeaders = []+                                 , s3QOtherHeaders = catMaybes [+                                                       ("if-match",) . T.encodeUtf8 <$> hoIfMatch+                                                     , ("if-none-match",) . T.encodeUtf8 <$> hoIfNoneMatch+                                                     ]                                  , s3QRequestBody = Nothing                                  }  instance ResponseConsumer HeadObject HeadObjectResponse where     type ResponseMetadata HeadObjectResponse = S3Metadata-    responseConsumer 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
Aws/S3/Commands/Multipart.hs view
@@ -1,18 +1,18 @@ 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 import           Data.Maybe-import           Data.Monoid import           Text.XML.Cursor       (($/)) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy  as BL@@ -23,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.@@ -100,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"@@ -128,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@@ -141,7 +142,6 @@  data UploadPartResponse   = UploadPartResponse {-      uprVersionId :: !(Maybe T.Text),       uprETag :: !T.Text     }   deriving (Show)@@ -173,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 @@ -197,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 {@@ -210,7 +208,8 @@     , cmurBucket   :: !Bucket     , cmurKey      :: !T.Text     , cmurETag     :: !T.Text-    }+    , cmurVersionId :: !(Maybe T.Text)+    } deriving (Show)  -- | ServiceConfiguration: 'S3Configuration' instance SignQuery CompleteMultipartUpload where@@ -229,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@@ -260,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"@@ -271,6 +270,7 @@                                               , cmurBucket         = bucket                                               , cmurKey            = key                                               , cmurETag           = etag+                                              , cmurVersionId      = vid                                               }  instance Transaction CompleteMultipartUpload CompleteMultipartUploadResponse@@ -296,7 +296,7 @@  data AbortMultipartUploadResponse   = AbortMultipartUploadResponse {-    }+    } deriving (Show)  -- | ServiceConfiguration: 'S3Configuration' instance SignQuery AbortMultipartUpload where@@ -319,7 +319,7 @@ instance ResponseConsumer r AbortMultipartUploadResponse where     type ResponseMetadata AbortMultipartUploadResponse = S3Metadata -    responseConsumer _ = s3XmlResponseConsumer parse+    responseConsumer _ _ = s3XmlResponseConsumer parse         where parse _cursor                   = return AbortMultipartUploadResponse {} @@ -357,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 =>@@ -371,57 +370,63 @@   -> 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 size = do-  loop 0 ""+chunkedConduit :: (MonadResource m) => Integer -> ConduitT B8.ByteString BL.ByteString m ()+chunkedConduit size = loop 0 []   where-    loop :: MonadResource m => Int -> BL.ByteString -> Conduit B8.ByteString m BL.ByteString-    loop cnt str = do-      line' <- await-      case line' of -        Nothing -> do-          yield str-          return ()-        Just line -> do-          let len = B8.length line+cnt-          let newStr = str <> BL.fromStrict line-          if len >= (fromIntegral size)-            then do-            yield newStr-            loop 0 ""-            else-            loop len newStr+    loop :: Monad m => Integer -> [B8.ByteString] -> ConduitT B8.ByteString BL.ByteString m ()+    loop cnt str = await >>= maybe (yieldChunk str) go+      where+        go :: Monad m => B8.ByteString -> ConduitT B8.ByteString BL.ByteString m ()+        go line+          | size <= len = yieldChunk newStr >> loop 0 []+          | otherwise   = loop len newStr+          where+            len = fromIntegral (B8.length line) + cnt+            newStr = line:str +    yieldChunk :: Monad m => [B8.ByteString] -> ConduitT i BL.ByteString m ()+    yieldChunk = yield . BL.fromChunks . reverse+ multipartUpload ::   Configuration   -> S3Configuration NormalQuery   -> HTTP.Manager   -> T.Text   -> T.Text-  -> 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+  -> S3Configuration NormalQuery+  -> HTTP.Manager+  -> T.Text    -- ^ Bucket name+  -> T.Text    -- ^ Object name+  -> Integer   -- ^ chunkSize (minimum: 5MB)+  -> ConduitT B8.ByteString Void m ()+multipartUploadSink cfg s3cfg = multipartUploadSinkWithInitiator cfg s3cfg postInitiateMultipartUpload+ multipartUploadWithInitiator ::   Configuration   -> S3Configuration NormalQuery@@ -429,13 +434,29 @@   -> 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+  -> S3Configuration NormalQuery+  -> (Bucket -> T.Text -> InitiateMultipartUpload) -- ^ Initiator+  -> HTTP.Manager+  -> T.Text    -- ^ Bucket name+  -> T.Text    -- ^ Object name+  -> Integer   -- ^ chunkSize (minimum: 5MB)+  -> ConduitT B8.ByteString Void m ()+multipartUploadSinkWithInitiator cfg s3cfg initiator mgr bucket object chunkSize = do+  uploadId <- liftIO $ imurUploadId <$> memoryAws cfg s3cfg mgr (initiator bucket object)+  etags <- chunkedConduit chunkSize+           .| putConduit cfg s3cfg mgr bucket object uploadId+           .| CL.consume+  void $ liftIO $ sendEtag cfg s3cfg mgr bucket object uploadId etags
Aws/S3/Commands/PutBucket.hs view
@@ -3,6 +3,7 @@ import           Aws.Core import           Aws.S3.Core import           Control.Monad+import           Data.Maybe import qualified Data.Map             as M import qualified Data.Text            as T import qualified Data.Text.Encoding   as T@@ -14,9 +15,13 @@         pbBucket :: Bucket       , pbCannedAcl :: Maybe CannedAcl       , pbLocationConstraint :: LocationConstraint+      , pbXStorageClass :: Maybe StorageClass -- ^ Google Cloud Storage S3 nonstandard extension       }     deriving (Show) +putBucket :: Bucket -> PutBucket+putBucket bucket = PutBucket bucket Nothing locationUsClassic Nothing+ data PutBucketResponse     = PutBucketResponse     deriving (Show)@@ -38,7 +43,7 @@                                                                  Just acl -> [("x-amz-acl", T.encodeUtf8 $ writeCannedAcl acl)]                                            , s3QOtherHeaders = []                                            , s3QRequestBody-                                               = guard (not . T.null $ pbLocationConstraint) >>+                                               = guard (not (null elts)) >>                                                  (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def)                                                  XML.Document {                                                           XML.documentPrologue = XML.Prologue [] Nothing []@@ -49,19 +54,27 @@         where root = XML.Element {                                XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}CreateBucketConfiguration"                              , XML.elementAttributes = M.empty-                             , XML.elementNodes = [-                                                   XML.NodeElement (XML.Element {-                                                                             XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}LocationConstraint"-                                                                           , XML.elementAttributes = M.empty-                                                                           , XML.elementNodes = [XML.NodeContent pbLocationConstraint]-                                                                           })-                                                  ]+                             , XML.elementNodes = elts                              }+              elts = catMaybes+                             [ if T.null pbLocationConstraint then Nothing else Just (locationconstraint pbLocationConstraint)+                             , fmap storageclass pbXStorageClass+                             ]+              locationconstraint c = XML.NodeElement (XML.Element {+                               XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}LocationConstraint"+                             , XML.elementAttributes = M.empty+                             , XML.elementNodes = [XML.NodeContent c]+                             })+              storageclass c = XML.NodeElement (XML.Element {+                               XML.elementName = "StorageClass"+                             , XML.elementAttributes = M.empty+                             , XML.elementNodes = [XML.NodeContent (writeStorageClass c)]+                             })  instance ResponseConsumer r PutBucketResponse where     type ResponseMetadata PutBucketResponse = S3Metadata -    responseConsumer _ = s3ResponseConsumer $ \_ -> return PutBucketResponse+    responseConsumer _ _ = s3ResponseConsumer $ \_ -> return PutBucketResponse  instance Transaction PutBucket PutBucketResponse
+ Aws/S3/Commands/PutBucketVersioning.hs view
@@ -0,0 +1,71 @@+module Aws.S3.Commands.PutBucketVersioning where++import           Aws.Core+import           Aws.S3.Core+import           Network.HTTP.Types (toQuery)+import qualified Data.Map             as M+import qualified Data.Text.Encoding   as T+import qualified Network.HTTP.Conduit as HTTP+import qualified Text.XML             as XML+import qualified Data.ByteString.Lazy.Char8 as B8++data VersioningState = VersioningSuspended | VersioningEnabled+    deriving (Show)++-- | Sets the versioning state of an existing bucket.+data PutBucketVersioning+    = PutBucketVersioning+      { pbvBucket :: Bucket+      , pbvVersioningConfiguration :: VersioningState+      }+    deriving (Show)++putBucketVersioning :: Bucket -> VersioningState -> PutBucketVersioning+putBucketVersioning = PutBucketVersioning++data PutBucketVersioningResponse+    = PutBucketVersioningResponse+    deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery PutBucketVersioning where+    type ServiceConfiguration PutBucketVersioning = S3Configuration++    signQuery PutBucketVersioning{..} = s3SignQuery $ S3Query+      { s3QMethod       = Put+      , s3QBucket       = Just $ T.encodeUtf8 pbvBucket+      , s3QSubresources = toQuery [("versioning" :: B8.ByteString, Nothing :: Maybe B8.ByteString)]+      , s3QQuery        = []+      , s3QContentType  = Nothing+      , s3QContentMd5   = Nothing+      , s3QObject       = Nothing+      , s3QAmzHeaders   = []+      , s3QOtherHeaders = []+      , s3QRequestBody  = (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def)+         XML.Document+          { XML.documentPrologue = XML.Prologue [] Nothing []+          , XML.documentRoot = XML.Element+            { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}VersioningConfiguration"+            , XML.elementAttributes = M.empty+            , XML.elementNodes = [ XML.NodeElement (XML.Element+              { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}Status"+              , XML.elementAttributes = M.empty+              , XML.elementNodes = case pbvVersioningConfiguration of+                VersioningSuspended -> [XML.NodeContent "Suspended"]+                VersioningEnabled ->  [XML.NodeContent "Enabled"]+              })]+            }+          , XML.documentEpilogue = []+          }+      }++instance ResponseConsumer r PutBucketVersioningResponse where+    type ResponseMetadata PutBucketVersioningResponse = S3Metadata++    responseConsumer _ _ = s3ResponseConsumer $ \_ -> return PutBucketVersioningResponse++instance Transaction PutBucketVersioning PutBucketVersioningResponse++instance AsMemoryResponse PutBucketVersioningResponse where+    type MemoryResponse PutBucketVersioningResponse = PutBucketVersioningResponse+    loadToMemory = return
Aws/S3/Commands/PutObject.hs view
@@ -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+                                            , 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
+ Aws/S3/Commands/RestoreObject.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}+module Aws.S3.Commands.RestoreObject+where++import           Aws.Core+import           Aws.S3.Core+import qualified Data.ByteString.Lazy.Char8 as B8+import qualified Data.Map as M+import           Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Types as HTTP+import qualified Network.HTTP.Conduit as HTTP+import qualified Text.XML as XML+#if !MIN_VERSION_time(1,5,0)+import           System.Locale+#endif+import           Prelude++data RestoreObject+  = RestoreObject { roObjectName :: Object+                  , roBucket :: Bucket+                  , roVersionId :: Maybe T.Text+                  , roTier :: RestoreObjectTier+                  , roObjectLifetimeDays :: RestoreObjectLifetimeDays+                  }+  deriving (Show)++data RestoreObjectTier+  = RestoreObjectTierExpedited+  | RestoreObjectTierStandard+  | RestoreObjectTierBulk+  deriving (Show)++data RestoreObjectLifetimeDays = RestoreObjectLifetimeDays Integer+  deriving (Show)++restoreObject :: Bucket -> T.Text -> RestoreObjectTier -> RestoreObjectLifetimeDays -> RestoreObject+restoreObject bucket obj tier lifetime = RestoreObject obj bucket Nothing tier lifetime++data RestoreObjectResponse+  = RestoreObjectAccepted+  | RestoreObjectAlreadyRestored+  | RestoreObjectAlreadyInProgress+  deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery RestoreObject where+    type ServiceConfiguration RestoreObject = S3Configuration+    signQuery RestoreObject {..} = s3SignQuery S3Query+      { s3QMethod = Post+      , s3QBucket = Just $ T.encodeUtf8 roBucket+      , s3QObject = Just $ T.encodeUtf8 roObjectName+      , s3QSubresources = HTTP.toQuery+         [ Just ( "restore" :: B8.ByteString, Nothing :: Maybe T.Text)+         , case roVersionId of+           Nothing -> Nothing+           Just v -> Just ("versionId" :: B8.ByteString, Just v)+         ]+      , s3QQuery = []+      , s3QContentType = Nothing+      , s3QContentMd5 = Nothing+      , s3QAmzHeaders = []+      , s3QOtherHeaders = []+      , s3QRequestBody = (Just . HTTP.RequestBodyLBS . XML.renderLBS XML.def)+         XML.Document+          { XML.documentPrologue = XML.Prologue [] Nothing []+          , XML.documentRoot = XML.Element+            { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}RestoreRequest"+            , XML.elementAttributes = M.empty+            , XML.elementNodes =+              [ XML.NodeElement (XML.Element+                { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}Days"+                , XML.elementAttributes = M.empty+                , XML.elementNodes = case roObjectLifetimeDays of+                        RestoreObjectLifetimeDays n -> [XML.NodeContent (T.pack (show n))]+                })+              , XML.NodeElement (XML.Element+                { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}GlacierJobParameters"+                , XML.elementAttributes = M.empty+                , XML.elementNodes =+                  [ XML.NodeElement (XML.Element+                    { XML.elementName = "{http://s3.amazonaws.com/doc/2006-03-01/}Tier"+                    , XML.elementAttributes = M.empty+                    , XML.elementNodes = case roTier of+                      RestoreObjectTierExpedited -> [XML.NodeContent "Expedited"]+                      RestoreObjectTierStandard ->  [XML.NodeContent "Standard"]+                      RestoreObjectTierBulk ->      [XML.NodeContent "Bulk"] +                    })+                  ]+                })+              ]+            }+          , XML.documentEpilogue = []+          }+      }++instance ResponseConsumer RestoreObject RestoreObjectResponse where+    type ResponseMetadata RestoreObjectResponse = S3Metadata+    responseConsumer httpReq _ _ resp+        | status == HTTP.status202 = return RestoreObjectAccepted+        | status == HTTP.status200 = return RestoreObjectAlreadyRestored+        | status == HTTP.status409 = return RestoreObjectAlreadyInProgress+        | otherwise = throwStatusCodeException httpReq resp+      where+        status = HTTP.responseStatus resp++instance Transaction RestoreObject RestoreObjectResponse++instance AsMemoryResponse RestoreObjectResponse where+    type MemoryResponse RestoreObjectResponse = RestoreObjectResponse+    loadToMemory = return
Aws/S3/Core.hs view
@@ -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+        -- * <http://docs.aws.amazon.com/general/latest/gr/sigv4_signing.html>+        -- * <http://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-auth-using-authorization-header.html>+        -- * <http://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-query-string-auth.html> +        iamTok = maybe [] (\x -> [(hAmzSecurityToken, x)]) $ iamToken signatureCredentials++        amzHeaders = Map.fromList $ (hAmzDate, sigTime):(hAmzContentSha256, payloadHash):iamTok ++ s3QAmzHeaders+            where+                -- needs to match the one produces in the @authorizationV4@+                sigTime = fmtTime "%Y%m%dT%H%M%SZ" $ signatureTime+                payloadHash = case (signpayload, s3QRequestBody) of+                    (AlwaysUnsigned, _)                 -> "UNSIGNED-PAYLOAD"+                    (_, Nothing)                        -> emptyBodyHash+                    (_, Just (HTTP.RequestBodyLBS lbs)) -> Base16.encode $ ByteArray.convert (CH.hashlazy lbs :: CH.Digest CH.SHA256)+                    (_, Just (HTTP.RequestBodyBS bs))   -> Base16.encode $ ByteArray.convert (CH.hash bs :: CH.Digest CH.SHA256)+                    (SignWithEffort, _)                 -> "UNSIGNED-PAYLOAD"+                    (AlwaysSigned, _)                   -> error "aws: RequestBody must be a on-memory one when AlwaysSigned mode."+                emptyBodyHash = "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"++        (host, path) = case s3RequestStyle of+            PathStyle   -> ([Just s3Endpoint], [Just "/", fmap (`B8.snoc` '/') s3QBucket, urlEncodedS3QObject])+            BucketStyle -> ([s3QBucket, Just s3Endpoint], [Just "/", urlEncodedS3QObject])+            VHostStyle  -> ([Just $ fromMaybe s3Endpoint s3QBucket], [Just "/", urlEncodedS3QObject])+            where+                urlEncodedS3QObject = s3UriEncode False <$> s3QObject++        -- must provide host in the canonical headers.+        canonicalHeaders = Map.union amzHeaders . Map.fromList $ catMaybes+            [ Just ("host", B.intercalate "." $ catMaybes host)+            , ("content-type",) <$> s3QContentType+            ]+        signedHeaders = B8.intercalate ";" (map CI.foldedCase $ Map.keys canonicalHeaders)+        stringToSign = B.intercalate "\n" $+            [ httpMethod s3QMethod                   -- method+            , mconcat . catMaybes $ path             -- path+            , s3RenderQuery False $ sort queryString -- query string+            ] +++            Map.foldMapWithKey (\a b -> [CI.foldedCase a Sem.<> ":" Sem.<> b]) canonicalHeaders +++            [ "" -- end headers+            , signedHeaders+            , amzHeaders Map.! hAmzContentSha256+            ]++        (authorization, signatureQuery, queryString) = case ti of+            AbsoluteTimestamp _  -> (Just auth, [], allQueries)+            AbsoluteExpires time ->+                ( Nothing+                , [(CI.original hAmzSignature, Just sig)]+                , (allQueries ++) . HTTP.toQuery . map (first CI.original) $+                    [ (hAmzAlgorithm, "AWS4-HMAC-SHA256")+                    , (hAmzCredential, cred)+                    , (hAmzDate, amzHeaders Map.! hAmzDate)+                    , (hAmzExpires, B8.pack . (show :: Integer -> String) . floor $ diffUTCTime time signatureTime)+                    , (hAmzSignedHeaders, signedHeaders)+                    ] ++ iamTok+                )+            where+                allQueries = s3QSubresources ++ s3QQuery+                region = fromMaybe (s3ExtractRegion s3Endpoint) s3Region+                auth = authorizationV4 sd HmacSHA256 region "s3" signedHeaders stringToSign+                sig  = signatureV4     sd HmacSHA256 region "s3"               stringToSign+                cred = credentialV4    sd            region "s3"+                ti = case (s3UseUri, signatureTimeInfo) of+                    (False, t) -> t+                    (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time+                    (True, AbsoluteExpires time) -> AbsoluteExpires time+        +        useragent = maybeToList $ (HTTP.hUserAgent,) . T.encodeUtf8 <$> s3UserAgent++-- | Custom UriEncode function+-- see <http://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html>+s3UriEncode+    :: Bool         -- ^ Whether encode slash characters+    -> B.ByteString+    -> B.ByteString+s3UriEncode encodeSlash = B8.concatMap $ \c ->+    if (isAscii c && isAlphaNum c) || (c `elem` nonEncodeMarks)+        then B8.singleton c+        else B8.pack $ '%' : map toUpper (showHex (ord c) "")+    where+        nonEncodeMarks :: String+        nonEncodeMarks = if encodeSlash+            then "_-~."+            else "_-~./"++s3RenderQuery+    :: Bool -- ^ Whether prepend a question mark+    -> HTTP.Query+    -> B.ByteString+s3RenderQuery qm = mconcat . qmf . intersperse (B8.singleton '&') . map renderItem+    where+        qmf = if qm then ("?":) else id++        renderItem :: HTTP.QueryItem -> B8.ByteString+        renderItem (k, Just v) = s3UriEncode True k Sem.<> "=" Sem.<> s3UriEncode True v+        renderItem (k, Nothing) = s3UriEncode True k Sem.<> "="++-- | Extract a S3 region from the S3 endpoint. AWS encodes the region names+-- in the hostnames of endpoints in a way that makes this possible,+-- see: <http://docs.aws.amazon.com/general/latest/gr/rande.html#s3_region>+-- For other S3 implementations, may instead need to specify s3Region.+s3ExtractRegion :: B.ByteString -> B.ByteString+s3ExtractRegion "s3.amazonaws.com"            = "us-east-1"+s3ExtractRegion "s3-external-1.amazonaws.com" = "us-east-1"+s3ExtractRegion domain = either (const domain) B.pack $ Atto.parseOnly parser domain+    where+        -- s3.dualstack.<WA-DIR-N>.amazonaws.com+        -- s3-<WA-DIR-N>.amazonaws.com+        -- s3.<WA-DIR-N>.amazonaws.com+        parser = do+            _ <- Atto.string "s3"+            _ <- Atto.string ".dualstack." <|> Atto.string "-" <|> Atto.string "."+            r <- Atto.manyTill Atto.anyWord8 $ Atto.string ".amazonaws.com"+            Atto.endOfInput+            return r+ s3ResponseConsumer :: HTTPResponseConsumer a                          -> IORef S3Metadata                          -> HTTPResponseConsumer a@@ -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@@ -326,20 +539,25 @@  data StorageClass     = Standard+    | StandardInfrequentAccess     | ReducedRedundancy     | Glacier+    | OtherStorageClass T.Text     deriving (Show) -parseStorageClass :: MonadThrow m => T.Text -> m StorageClass-parseStorageClass "STANDARD"           = return Standard-parseStorageClass "REDUCED_REDUNDANCY" = return ReducedRedundancy-parseStorageClass "GLACIER"            = return Glacier-parseStorageClass s = throwM . XmlException $ "Invalid Storage Class: " ++ T.unpack s+parseStorageClass :: T.Text -> StorageClass+parseStorageClass "STANDARD"           = Standard+parseStorageClass "STANDARD_IA"        = StandardInfrequentAccess+parseStorageClass "REDUCED_REDUNDANCY" = ReducedRedundancy+parseStorageClass "GLACIER"            = Glacier+parseStorageClass s                    = OtherStorageClass s  writeStorageClass :: StorageClass -> T.Text-writeStorageClass Standard          = "STANDARD"-writeStorageClass ReducedRedundancy = "REDUCED_REDUNDANCY"-writeStorageClass Glacier           = "GLACIER"+writeStorageClass Standard                 = "STANDARD"+writeStorageClass StandardInfrequentAccess = "STANDARD_IA"+writeStorageClass ReducedRedundancy        = "REDUCED_REDUNDANCY"+writeStorageClass Glacier                  = "GLACIER"+writeStorageClass (OtherStorageClass s) = s  data ServerSideEncryption     = AES256@@ -371,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@@ -385,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" &| 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@@ -459,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"
Aws/Ses/Commands/DeleteIdentity.hs view
@@ -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
Aws/Ses/Commands/GetIdentityDkimAttributes.hs view
@@ -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"
Aws/Ses/Commands/GetIdentityNotificationAttributes.hs view
@@ -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"
Aws/Ses/Commands/GetIdentityVerificationAttributes.hs view
@@ -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"
Aws/Ses/Commands/ListIdentities.hs view
@@ -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
Aws/Ses/Commands/SendRawEmail.hs view
@@ -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)
Aws/Ses/Commands/SetIdentityDkimEnabled.hs view
@@ -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
Aws/Ses/Commands/SetIdentityFeedbackForwardingEnabled.hs view
@@ -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
Aws/Ses/Commands/SetIdentityNotificationTopic.hs view
@@ -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
Aws/Ses/Commands/VerifyDomainDkim.hs view
@@ -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)
Aws/Ses/Commands/VerifyDomainIdentity.hs view
@@ -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)
Aws/Ses/Commands/VerifyEmailIdentity.hs view
@@ -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
Aws/Ses/Core.hs view
@@ -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 "<none>" rid +instance Sem.Semigroup SesMetadata where+    SesMetadata r1 <> SesMetadata r2 = SesMetadata (r1 `mplus` r2)+ instance Monoid SesMetadata where     mempty = SesMetadata Nothing-    SesMetadata r1 `mappend` SesMetadata r2 = SesMetadata (r1 `mplus` r2)+    mappend = (Sem.<>)  data SesConfiguration qt     = SesConfiguration {@@ -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
Aws/SimpleDb/Commands/Attributes.hs view
@@ -5,6 +5,7 @@ import           Control.Applicative import           Control.Monad import           Data.Maybe+import           Prelude import           Text.XML.Cursor            (($//), (&|)) import qualified Data.Text                  as T import qualified Data.Text.Encoding         as T@@ -39,7 +40,8 @@  instance ResponseConsumer r GetAttributesResponse where     type ResponseMetadata GetAttributesResponse = SdbMetadata-    responseConsumer _ = sdbResponseConsumer parse+    responseConsumer _ _+        = sdbResponseConsumer parse         where parse cursor = do                 sdbCheckResponseType () "GetAttributesResponse" cursor                 attributes <- sequence $ cursor $// Cu.laxElement "Attribute" &| readAttribute@@ -83,7 +85,8 @@  instance ResponseConsumer r PutAttributesResponse where     type ResponseMetadata PutAttributesResponse = SdbMetadata-    responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType PutAttributesResponse "PutAttributesResponse"+    responseConsumer _ _+        = sdbResponseConsumer $ sdbCheckResponseType PutAttributesResponse "PutAttributesResponse"  instance Transaction PutAttributes PutAttributesResponse @@ -123,7 +126,8 @@  instance ResponseConsumer r DeleteAttributesResponse where     type ResponseMetadata DeleteAttributesResponse = SdbMetadata-    responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType DeleteAttributesResponse "DeleteAttributesResponse"+    responseConsumer _ _+        = sdbResponseConsumer $ sdbCheckResponseType DeleteAttributesResponse "DeleteAttributesResponse"  instance Transaction DeleteAttributes DeleteAttributesResponse @@ -156,7 +160,8 @@  instance ResponseConsumer r BatchPutAttributesResponse where     type ResponseMetadata BatchPutAttributesResponse = SdbMetadata-    responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType BatchPutAttributesResponse "BatchPutAttributesResponse"+    responseConsumer _ _+        = sdbResponseConsumer $ sdbCheckResponseType BatchPutAttributesResponse "BatchPutAttributesResponse"  instance Transaction BatchPutAttributes BatchPutAttributesResponse @@ -189,7 +194,8 @@  instance ResponseConsumer r BatchDeleteAttributesResponse where     type ResponseMetadata BatchDeleteAttributesResponse = SdbMetadata-    responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType BatchDeleteAttributesResponse "BatchDeleteAttributesResponse"+    responseConsumer _ _+        = sdbResponseConsumer $ sdbCheckResponseType BatchDeleteAttributesResponse "BatchDeleteAttributesResponse"  instance Transaction BatchDeleteAttributes BatchDeleteAttributesResponse
Aws/SimpleDb/Commands/Domain.hs view
@@ -6,6 +6,7 @@ import           Data.Maybe import           Data.Time import           Data.Time.Clock.POSIX+import           Prelude import           Text.XML.Cursor       (($//), (&|)) import qualified Data.Text             as T import qualified Data.Text.Encoding    as T@@ -30,7 +31,8 @@  instance ResponseConsumer r CreateDomainResponse where     type ResponseMetadata CreateDomainResponse = SdbMetadata-    responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType CreateDomainResponse "CreateDomainResponse"+    responseConsumer _ _+        = sdbResponseConsumer $ sdbCheckResponseType CreateDomainResponse "CreateDomainResponse"  instance Transaction CreateDomain CreateDomainResponse @@ -58,7 +60,8 @@  instance ResponseConsumer r DeleteDomainResponse where     type ResponseMetadata DeleteDomainResponse = SdbMetadata-    responseConsumer _ = sdbResponseConsumer $ sdbCheckResponseType DeleteDomainResponse "DeleteDomainResponse"+    responseConsumer _ _+        = sdbResponseConsumer $ sdbCheckResponseType DeleteDomainResponse "DeleteDomainResponse"  instance Transaction DeleteDomain DeleteDomainResponse @@ -95,7 +98,8 @@ instance ResponseConsumer r DomainMetadataResponse where     type ResponseMetadata DomainMetadataResponse = SdbMetadata -    responseConsumer _ = sdbResponseConsumer parse+    responseConsumer _ _+        = sdbResponseConsumer parse         where parse cursor = do                 sdbCheckResponseType () "DomainMetadataResponse" cursor                 dmrTimestamp <- forceM "Timestamp expected" $ cursor $// elCont "Timestamp" &| (fmap posixSecondsToUTCTime . readInt)@@ -141,7 +145,7 @@  instance ResponseConsumer r ListDomainsResponse where     type ResponseMetadata ListDomainsResponse = SdbMetadata-    responseConsumer _ = sdbResponseConsumer parse+    responseConsumer _ _ = sdbResponseConsumer parse         where parse cursor = do                 sdbCheckResponseType () "ListDomainsResponse" cursor                 let names = cursor $// elContent "DomainName"
Aws/SimpleDb/Commands/Select.hs view
@@ -6,6 +6,7 @@ import           Control.Applicative import           Control.Monad import           Data.Maybe+import           Prelude import           Text.XML.Cursor            (($//), (&|)) import qualified Data.Text                  as T import qualified Data.Text.Encoding         as T@@ -42,7 +43,7 @@  instance ResponseConsumer r SelectResponse where     type ResponseMetadata SelectResponse = SdbMetadata-    responseConsumer _ = sdbResponseConsumer parse+    responseConsumer _ _ = sdbResponseConsumer parse         where parse cursor = do                 sdbCheckResponseType () "SelectResponse" cursor                 items <- sequence $ cursor $// Cu.laxElement "Item" &| readItem
Aws/SimpleDb/Core.hs view
@@ -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                (($|), ($/), ($//), (&|))@@ -32,7 +34,7 @@  instance C.Exception SdbError -data SdbMetadata +data SdbMetadata     = SdbMetadata {         requestId :: Maybe T.Text       , boxUsage :: Maybe T.Text@@ -45,9 +47,12 @@                                      ", box usage=" `mappend`                                      fromMaybe "<not available>" bu +instance Sem.Semigroup SdbMetadata where+    SdbMetadata r1 b1 <> SdbMetadata r2 b2 = SdbMetadata (r1 `mplus` r2) (b1 `mplus` b2)+ instance Monoid SdbMetadata where     mempty = SdbMetadata Nothing Nothing-    SdbMetadata r1 b1 `mappend` SdbMetadata r2 b2 = SdbMetadata (r1 `mplus` r2) (b1 `mplus` b2)+    mappend = (Sem.<>)  data SdbConfiguration qt     = SdbConfiguration {@@ -63,11 +68,11 @@   debugServiceConfig = sdbHttpPost sdbUsEast  instance DefaultServiceConfiguration (SdbConfiguration UriOnlyQuery) where-  defServiceConfig = sdbHttpsGet sdbUsEast  +  defServiceConfig = sdbHttpsGet sdbUsEast   debugServiceConfig = sdbHttpGet sdbUsEast-             + sdbUsEast :: B.ByteString-sdbUsEast = "sdb.amazonaws.com" +sdbUsEast = "sdb.amazonaws.com"  sdbUsWest :: B.ByteString sdbUsWest = "sdb.us-west-1.amazonaws.com"@@ -80,16 +85,16 @@  sdbApNortheast :: B.ByteString sdbApNortheast = "sdb.ap-northeast-1.amazonaws.com"-             + sdbHttpGet :: B.ByteString -> SdbConfiguration qt sdbHttpGet endpoint = SdbConfiguration HTTP Get endpoint (defaultPort HTTP)-                          + sdbHttpPost :: B.ByteString -> SdbConfiguration NormalQuery sdbHttpPost endpoint = SdbConfiguration HTTP PostQuery endpoint (defaultPort HTTP)-              + sdbHttpsGet :: B.ByteString -> SdbConfiguration qt sdbHttpsGet endpoint = SdbConfiguration HTTPS Get endpoint (defaultPort HTTPS)-             + sdbHttpsPost :: B.ByteString -> SdbConfiguration NormalQuery sdbHttpsPost endpoint = SdbConfiguration HTTPS PostQuery endpoint (defaultPort HTTPS) @@ -122,13 +127,13 @@                   , ("AWSAccessKeyId", accessKeyID cr)                   , ("SignatureMethod", amzHash ah)                   , ("SignatureVersion", "2")]-		  ++ maybe [] (\tok -> [("SecurityToken", tok)]) (iamToken cr)+                  ++ maybe [] (\tok -> [("SecurityToken", tok)]) (iamToken cr)       sq = ("Signature", Just sig) : q'       method = sdbiHttpMethod si       host = sdbiHost si       path = "/"       sig = signature cr ah stringToSign-      stringToSign = Blaze.toByteString . mconcat $ +      stringToSign = Blaze.toByteString . mconcat $                      intersperse (Blaze8.fromChar '\n')                        [Blaze.copyByteString $ httpMethod method                        , Blaze.copyByteString $ host
Aws/Sqs/Commands/Message.hs view
@@ -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 @@ -- <http://queue.amazonaws.com/doc/2012-11-05/QueueService.wsdl> -- all elements except for the attributes are specified as required. -- At least for the field 'mMD5OfMessageAttributes' the the service--- is not always returning a value and 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 {}
Aws/Sqs/Commands/Permission.hs view
@@ -25,7 +25,7 @@  instance ResponseConsumer r AddPermissionResponse where     type ResponseMetadata AddPermissionResponse = SqsMetadata-    responseConsumer _ = sqsXmlResponseConsumer parse+    responseConsumer _ _ = sqsXmlResponseConsumer parse        where          parse _ = do            return AddPermissionResponse {}@@ -55,7 +55,7 @@  instance ResponseConsumer r RemovePermissionResponse where     type ResponseMetadata RemovePermissionResponse = SqsMetadata-    responseConsumer _ = sqsXmlResponseConsumer parse+    responseConsumer _ _ = sqsXmlResponseConsumer parse       where          parse _ = do           return RemovePermissionResponse {}
Aws/Sqs/Commands/Queue.hs view
@@ -5,6 +5,7 @@ import           Aws.Sqs.Core import           Control.Applicative import           Data.Maybe+import           Prelude import           Text.XML.Cursor       (($//), (&/)) import qualified Data.Text             as T import qualified Data.Text.Encoding    as TE@@ -23,7 +24,7 @@  instance ResponseConsumer r CreateQueueResponse where     type ResponseMetadata CreateQueueResponse = SqsMetadata-    responseConsumer _ = sqsXmlResponseConsumer parse+    responseConsumer _ _ = sqsXmlResponseConsumer parse       where         parse el = do           url <- force "Missing Queue Url" $ el $// Cu.laxElement "QueueUrl" &/ Cu.content@@ -55,7 +56,7 @@  instance ResponseConsumer r DeleteQueueResponse where     type ResponseMetadata DeleteQueueResponse = SqsMetadata-    responseConsumer _ = sqsXmlResponseConsumer parse+    responseConsumer _ _ = sqsXmlResponseConsumer parse       where         parse _ = do return DeleteQueueResponse{}           @@ -82,7 +83,7 @@  instance ResponseConsumer r ListQueuesResponse where     type ResponseMetadata ListQueuesResponse = SqsMetadata-    responseConsumer _ = sqsXmlResponseConsumer parse+    responseConsumer _ _ = sqsXmlResponseConsumer parse       where         parse el = do             let queues = el $// Cu.laxElement "QueueUrl" &/ Cu.content
Aws/Sqs/Commands/QueueAttributes.hs view
@@ -27,7 +27,7 @@  instance ResponseConsumer r GetQueueAttributesResponse where     type ResponseMetadata GetQueueAttributesResponse = SqsMetadata-    responseConsumer _ = sqsXmlResponseConsumer parse+    responseConsumer _ _ = sqsXmlResponseConsumer parse       where         parse el = do           let attributes = concat $ el $// Cu.laxElement "Attribute" &| parseAttributes@@ -64,7 +64,7 @@  instance ResponseConsumer r SetQueueAttributesResponse where     type ResponseMetadata SetQueueAttributesResponse = SqsMetadata-    responseConsumer _ = sqsXmlResponseConsumer parse+    responseConsumer _ _ = sqsXmlResponseConsumer parse       where          parse _ = do           return SetQueueAttributesResponse {}
Aws/Sqs/Core.hs view
@@ -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 "<none>" id2 +instance Sem.Semigroup SqsMetadata where+    SqsMetadata a1 r1 <> SqsMetadata a2 r2 = SqsMetadata (a1 `mplus` a2) (r1 `mplus` r2)+ instance Monoid SqsMetadata where     mempty = SqsMetadata Nothing Nothing-    SqsMetadata a1 r1 `mappend` SqsMetadata a2 r2 = SqsMetadata (a1 `mplus` a2) (r1 `mplus` r2)+    mappend = (Sem.<>)  data SqsAuthorization      = SqsAuthorizationHeader @@ -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
+ CHANGELOG.md view
@@ -0,0 +1,429 @@+0.25 series+-----------++NOTES: 0.25 brings technically breaking changes, which should not affect+most users. I recommend using smart constructors and {} matching syntax+whenever possible when interacting with aws types.++-   0.25.3+    - Switch from memory to ram to allow building with http-client-tls 0.4.x+-   0.25.2+    - S3: Add RestoreObject command+-   0.25.1+    - S3: Make getBucket support Google Object Storage, which does+      not include StorageClass in its response, by defaulting to Standard.+-   0.25+    - [breaking change] Added poTagging constructor to PutObject+    - Switch from no longer maintained cryptonite to crypton.+    - Removed support for building with network-2.x, and removed the+      NetworkBSD build flag.+++0.24 series+-----------++NOTES: 0.24 brings technically breaking changes, which should not affect+most users. I recommend using smart constructors and {} matching syntax+whenever possible when interacting with aws types.++-   0.24.4+    - Support filepath 1.5+    - Support data-default 0.8+-   0.24.3+    - [breaking change] Added s3UserAgent constructor to S3Configuration+    - S3: Add GetBucketVersioning command+-   0.24.2+    - Support bytestring 0.12+    - Support building with aeson 2.2, adding dependency on+      attoparsec-json.+-   0.24.1+    - Support resourcet 1.3+    - Support transformers 0.6+-   0.24+    - [breaking change] Added s3Region constructor to S3Configuration, to+      support custom S3 regions.+    - Fixed several build warnings.+    - Needs base-4.9 or newer.++0.23 series+-----------++NOTES: 0.23 brings technically breaking changes, which should not affect+most users. I recommend using smart constructors and {} matching syntax+whenever possible when interacting with aws types.++-   0.23+    - Support anonymous access of S3 buckets.+    - [breaking change] added isAnonymousCredentials to Credentials.+    - Support bytestring 0.11++0.22 series+-----------++-   0.22.1+    - Update to aeson-2+    - Support http-client 0.7+    - Support base64-bytestring 1.2+    - Support attoparsec 0.14+    - Support base16-bytestring 1.0+-   0.22+    - Support GHC 8.8+    - Support network-3+    - Support http-client 0.6++    - S3: add etag to PutObjectResponse+    - Add IAM group manipulation methods++0.21 series+-----------++-   0.21.1+    - S3: Add PutBucketVersioning command++-   0.21+    - S3: Make user DisplayName field optional (used in "GetBucket"+      among other places)+    - Use HTTP.getGlobalManager from http-client-tls by default (more+      efficient, and we have a transitive dependency on the package+      anyways)++0.20 series+-----------++-   0.20+    - Update to conduit 1.3 and http-conduit 2.3 (breaking API change+      due to removal of ResumableSource, which was used in public APIs)+    - S3: Fix to V2 string signing++0.19 series+-----------++-   0.19+    - Experimental support for V4 signing+    - Add "eu-west-2" endpoint for some services+    - Loosen http-conduit bounds++0.18 series+-----------++-   0.18+    -   Switch from cryptohash to cryptonite+    -   Loosen boundaries for http-types and conduit-extra++0.17 series+-----------++-   0.17.1+    -   Fix testsuite build++-   0.17+    -   HTTP proxy support+    -   DDB: Support for additional interfaces, bug fixes+    -   Relax version bounds++0.16 series+-----------++NOTES: 0.16 brings technically breaking changes, which should not affect+most users. I recommend using smart constructors and {} matching syntax+whenever possible when interacting with aws types.++-   0.16+    -   S3: Add support for versioning+    -   S3: [breaking change] Move version ID from UploadPartResponse to+        CompleteMultipartUpload.++0.15 series+-----------++NOTES: 0.15 brings technically breaking changes, but should not affect+most users.++-   0.15.1+    -   Support xml-conduit 1.4++-   0.15+    -   Drop support for time <1.5+    -   Support http-client 2.2+    -   Support directory 1.3+    -   Add upper bound on http-client in testsuite+    -   DynamoDB: Eliminate orphan instance that conflicted with aeson-1.0+    -   S3: Don't URI encode response header override query params when signing+    -   Use HTTP.newManager instead of deprecated HTTP.withManager+    -   Signing: Change date format from space-padding to zero-padding++0.14 series+-----------++NOTES: 0.14 brings potentially breaking changes++-   0.14+    -   transformers 0.5 support+    -   data-default 0.6 support (also in 0.13.1)+    -   time < 2.0 support+    -   General: Use `AWS_SESSION_TOKEN` if in environment for loading credentials+    -   General: loadCredentialsDefault fails gracefully if HOME is not set+    -   DDB: Add parseAttr combinator for parsing an attribute into a FromDynItem+    -   DDB: Expose the new DynBool type+    -   S3: Add ETag fields to get/head object++0.13 series+-----------++NOTE: 0.13 brings breaking changes compared to 0.12.1!++-   0.13.1+    -   data-default 0.6 support+-   0.13+    -   DDB: Add support for scanning an index+    -   DDB: Allow deleting an attribute on update+    -   DDB: !BREAKING! Add support for native boolean values+        via "Bool". Can read old values, and there's a compatibility+        wrapper OldBool that behaves exactly the same way it used to.+    -   DDB: Add support for Null, L (list) and M (map) data types.+    -   DDB: Support consistent reads in Scan requests+    -   IAM: Add list-mfa-devices command+    -   S3: Extend StorageClass to support arbitrary classes, and+        StandardInfrequentAccess+    -   S3: Add a Sink interface for multipart uploading+    -   S3: Performance improvement for chunkedConduit+    -   S3: Partial support for Google Nearline++0.12 series+-----------++-   0.12.1+    -   DDB: Fix eu-west-1, add eu-central-1+    -   attoparsec 0.13+    -   xml-conduit 1.3+-   0.12+    -   S3: Support for "Expect: 100-continue" (optional, technically+        API breaking)+    -   S3: Properly treat errors with a "301 Permanent Redirect" as+        errors and expose endpoint information++0.11 series+-----------++-   0.11.4+    -   Url-encode S3 object names in URLs+    -   filepath 1.4+    -   tagged 0.8.x+    -   limit errors to &lt;2 to avoid compatibility problems+-   0.11.3+    -   Support for blaze-builder 0.4+    -   Support for utf8-string 1.0+    -   New function: multipartUploadWithInitiator+    -   Fix issue in DynamoDB error parsing+    -   Ord instance for Aws.Core.Method+-   0.11.2+    -   Support for time 1.5 (we previously forgot to relax the upper+        bound in Cabal)+-   0.11.1+    -   Support time 1.5+    -   Fix duplicate sending of query when using PostQuery+-   0.11+    -   New functions for running AWS transactions+    -   Performance optimizations for DynamoDB and S3 MultiPartUpload+    -   New DynamoDB commands & features+    -   S3 endpoint eu-central-1++0.10 series+-----------++-   0.10.5+    -   support for conduit 1.2+-   0.10.4+    -   S3: support for multi-part uploads+    -   DynamoDB: fixes for JSON serialization WARNING: This includes+        making some fields in TableDescription Maybe fields, which+        is breaking. But DynamoDB support was and is also marked+        as EXPERIMENTAL.+    -   DynamoDB: TCP connection reuse where possible+        (improving performance)+    -   DynamoDB: Added test suite+    -   SES: support for additional regions+-   0.10.3+    -   fix bug introduced in 0.10.2 that broke SQS and IAM connections+        without STS+-   0.10.2+    -   support STS / IAM temporary credentials in all services+-   0.10+    -   \[EXPERIMENTAL!\] DynamoDB: support for+        creating/updating/querying and scanning items+    -   SQS: complete overhaul to support 2012-11-05 features+    -   SQS: test suite+    -   S3: use Maybe for 404 HEAD requests on objects instead of+        throwing a misleading exception+    -   S3: support of poAutoMakeBucket for Internet Archive users+    -   S3: implement GetBucketLocation+    -   S3: add South American region+    -   S3: allow specifying the Content-Type when copying objects+    -   core: fix typo in NoCredentialsException accessor++0.9 series+----------++-   0.9.4+    -   allow conduit 1.2+-   0.9.3+    -   fix performance regression for loadCredentialsDefault+    -   add generic makeCredentials function+    -   add S3 DeleteBucket operation+    -   add S3 NukeBucket example+    -   SES: use security token if enabled (should allow using it with+        IAM roles on EC2 instances)+-   0.9.2+    -   Support for credentials from EC2 instance metadata (only S3+        for now)+    -   aeson 0.8 compatibility+-   0.9.1+    -   Support for multi-page S3 GetBucket requests+    -   S3 GLACIER support+    -   Applicative instance for Response to conform to the+        Applicative-Monad Proposal+    -   Compatibility with transformers 0.4+-   0.9+    -   Interface changes:+        -   attempt and failure were deprecated, remove+        -   switch to new cryptohash interface+    -   updated version bounds of conduit and xml-conduit++0.8 series+----------++-   0.8.6+    -   move Instance metadata functions out of ResourceT to remove+        problem with exceptions-0.5 (this makes a fresh install of aws+        on a clean system possible again)+-   0.8.5+    -   compatibility with case-insensitive 1.2+    -   support for V4 signatures+    -   experimental support for DynamoDB+-   0.8.4+    -   compatibility with http-conduit 2.0+-   0.8.3+    -   compatibility with cryptohash 0.11+    -   experimental IAM support+-   0.8.2+    -   compatibility with cereal 0.4.x+-   0.8.1+    -   compatibility with case-insensitive 1.1+-   0.8.0+    -   S3, SQS: support for US-West2 (\#58)+    -   S3: GetObject now has support for Content-Range (\#22, \#50)+    -   S3: GetBucket now supports the "IsTruncated" flag (\#39)+    -   S3: PutObject now supports web page redirects (\#46)+    -   S3: support for (multi-object) DeleteObjects (\#47, \#56)+    -   S3: HeadObject now uses an actual HEAD request (\#53)+    -   S3: fixed signing issues for GetObject call (\#54)+    -   SES: support for many more operations (\#65, \#66, \#70, \#71,+        \#72, \#74)+    -   SES: SendRawEmail now correctly encodes destinations and allows+        multiple destinations (\#73)+    -   EC2: support for Instance metadata (\#37)+    -   Core: queryToHttpRequest allows overriding "Date" for the+        benefit of Chris Dornan's Elastic Transcoder bindings (\#77)++0.7 series+----------++-   0.7.6.4+    -   CryptoHash update+-   0.7.6.3+    -   In addition to supporting http-conduit 1.9, it would seem nice+        to support conduit 1.0. Previously slipped through the radar.+-   0.7.6.2+    -   Support for http-conduit 1.9+-   0.7.6.1+    -   Support for case-insensitive 1.0 and http-types 0.8+-   0.7.6+    -   Parsing of SimpleDB error responses was too strict, fixed+    -   Support for cryptohash 0.8+    -   Failure 0.1 does not work with aws, stricter lower bound+-   0.7.5+    -   Support for http-conduit 1.7 and 1.8+-   0.7.1-0.7.4+    -   Support for GHC 7.6+    -   Wider constraints to support newer versions of various+        dependencies+    -   Update maintainer e-mail address and project categories in cabal+        file+-   0.7.0+    -   Change ServiceConfiguration concept so as to indicate in the+        type whether this is for URI-only requests (i.e. awsUri)+    -   EXPERIMENTAL: Direct support for iterated transaction, i.e. such+        where multiple HTTP requests might be necessary due to e.g.+        response size limits.+    -   Put aws functions in ResourceT to be able to safely return+        Sources and streams.+        -   simpleAws\* does not require ResourceT and converts streams+            into memory values (like ByteStrings) first.+    -   Log response metadata (level Info), and do not let all aws+        runners return it.+    -   S3:+        -   GetObject: No longer require a response consumer in the+            request, return the HTTP response (with the body as+            a stream) instead.+        -   Add CopyObject (PUT Object Copy) request type.+    -   Add Examples cabal flag for building code examples.+    -   Many more, small improvements.++0.6 series+----------++-   0.6.2+    -   Properly parse Last-Modified header in accordance with RFC 2616.+-   0.6.1+    -   Fix for MD5 encoding issue in S3 PutObject requests.+-   0.6.0+    -   API Cleanup+        -   General: Use Crypto.Hash.MD5.MD5 when a Content-MD5 hash is+            required, instead of ByteString.+        -   S3: Made parameter order to S3.putObject consistent+            with S3.getObject.+    -   Updated dependencies:+        -   conduit 0.5 (as well as http-conduit 1.5 and+            xml-conduit 1.0).+        -   http-types 0.7.+    -   Minor changes.+    -   Internal changes (notable for people who want to add more+        commands):+        -   http-types' new 'QueryLike' interface allows creating query+            lists more conveniently.++0.5 series+----------++0.5.0++:   New configuration system: configuration split into general and+    service-specific parts.++    Significantly improved API reference documentation.++    Re-organised modules to make library easier to understand.++    Smaller improvements.++0.4 series+----------++0.4.1+:   Documentation improvements.++0.4.0.1+:   Change dependency bounds to allow the transformers 0.3 package.++0.4.0+:   Update conduit to 0.4.0, which is incompatible with+    earlier versions.++0.3 series+----------++0.3.2+:   Add awsRef / simpleAwsRef request variants for those who prefer an+    `IORef` over a `Data.Attempt.Attempt` value. Also improve README and+    add simple example.++
Examples/DynamoDb.hs view
@@ -11,10 +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 ()@@ -33,6 +36,25 @@   resp1 <- runCommand req1   print resp1 +data ExampleItem = ExampleItem {+      name :: T.Text+    , class_ :: T.Text+    , boolAttr :: Bool+    , oldBoolAttr :: Bool+    }+    deriving (Show)++instance ToDynItem ExampleItem where+    toItem (ExampleItem name class_ boolAttr oldBoolAttr) =+        item [ attr "name" name+             , attr "class" class_+             , attr "boolattr" boolAttr+             , attr "oldboolattr" (OldBool oldBoolAttr)+             ]++instance FromDynItem ExampleItem where+    parseItem x = ExampleItem <$> getAttr "name" x <*> getAttr "class" x <*> getAttr "boolattr" x <*> getAttr "oldboolattr" x+ main :: IO () main = do   cfg <- Aws.baseConfiguration@@ -41,10 +63,10 @@    putStrLn "Putting an item..." -  let x = item [ attrAs text "name" "josh"-               , attrAs text "class" "not-so-awesome"]+  let x = ExampleItem { name = "josh", class_ = "not-so-awesome",+                        boolAttr = False, oldBoolAttr = True } -  let req1 = (putItem "devel-1" x ) { piReturn = URAllOld+  let req1 = (putItem "devel-1" (toItem x)) { piReturn = URAllOld                                     , piRetCons =  RCTotal                                     , piRetMet = RICMSize                                     }@@ -59,6 +81,9 @@   resp2 <- runCommand req2   print resp2 +  let y = fromItem (fromMaybe (item []) $ girItem resp2) :: Either String ExampleItem+  print y+   print =<< runCommand     (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesome")]) @@ -74,7 +99,7 @@    echo "Updating with true conditional"   print =<< runCommand-    (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesomer")])+    (updateItem "devel-1" (hk "name" "josh") [au (Attribute "class" "awesomer"), au (attr "oldboolattr" False)])       { uiExpect = Conditions CondAnd [Condition "name" (DEq "josh")] }    echo "Getting the item back..."@@ -95,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")
Examples/GetObject.hs view
@@ -2,9 +2,10 @@  import qualified Aws import qualified Aws.S3 as S3-import           Data.Conduit (($$+-))+import           Control.Monad.Trans.Resource+import           Data.Conduit ((.|), runConduit) import           Data.Conduit.Binary (sinkFile)-import           Network.HTTP.Conduit (withManager, responseBody)+import           Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)  main :: IO () main = do@@ -13,11 +14,12 @@   let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery    {- Set up a ResourceT region with an available HTTP manager. -}-  withManager $ \mgr -> do+  mgr <- newManager tlsManagerSettings+  runResourceT $ do     {- Create a request object with S3.getObject and run the request with pureAws. -}     S3.GetObjectResponse { S3.gorResponse = rsp } <-       Aws.pureAws cfg s3cfg mgr $         S3.getObject "haskell-aws" "cloud-remote.pdf"      {- Save the response to a file. -}-    responseBody rsp $$+- sinkFile "cloud-remote.pdf"+    runConduit $ responseBody rsp .| sinkFile "cloud-remote.pdf"
+ Examples/GetObjectGoogle.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++import qualified Aws+import qualified Aws.Core as Aws+import qualified Aws.S3 as S3+import           Control.Monad.Trans.Resource+import           Data.Conduit ((.|), runConduit)+import           Data.Conduit.Binary (sinkFile)+import           Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)++main :: IO ()+main = do+  Just creds <- Aws.loadCredentialsFromEnv+  let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing+  let s3cfg = S3.s3 Aws.HTTP "storage.googleapis.com" False+  {- Set up a ResourceT region with an available HTTP manager. -}+  mgr <- newManager tlsManagerSettings+  runResourceT $ do+    {- Create a request object with S3.getObject and run the request with pureAws. -}+    S3.GetObjectResponse { S3.gorResponse = rsp } <-+      Aws.pureAws cfg s3cfg mgr $+        {- Public bucket from GCP examples -}+        S3.getObject "uspto-pair" "applications/05900016.zip"++    {- Save the response to a file. -}+    runConduit $ responseBody rsp .| sinkFile "getobject-test.zip"
+ Examples/GetObjectV4.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++import qualified Aws+import qualified Aws.Core as Aws+import qualified Aws.S3 as S3+import           Control.Monad.Trans.Resource+import           Data.Conduit ((.|), runConduit)+import           Data.Conduit.Binary (sinkFile)+import           Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)++main :: IO ()+main = do+  {- Set up AWS credentials and the default configuration. -}+  Just creds <- Aws.loadCredentialsDefault+  let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing+  let s3cfg = S3.s3v4 Aws.HTTP "s3.amazonaws.com" False S3.SignWithEffort++  {- Set up a ResourceT region with an available HTTP manager. -}+  mgr <- newManager tlsManagerSettings+  runResourceT $ do+    {- Create a request object with S3.getObject and run the request with pureAws. -}+    S3.GetObjectResponse { S3.gorResponse = rsp } <-+      Aws.pureAws cfg s3cfg mgr $+        S3.getObject "haskell-aws" "cloud-remote.pdf"++    {- Save the response to a file. -}+    runConduit $ responseBody rsp .| sinkFile "cloud-remote.pdf"
Examples/MultipartTransfer.hs view
@@ -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
Examples/MultipartUpload.hs view
@@ -1,29 +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           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-          S3.multipartUpload cfg s3cfg mgr (T.pack bucket) (T.pack obj) (sourceFile file) (chunkSize*1024*1024)-   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)
Examples/NukeBucket.hs view
@@ -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 ()
+ Examples/PutBucketNearLine.hs view
@@ -0,0 +1,38 @@+-- | Example of creating a Nearline bucket on Google Cloud Storage.++{-# LANGUAGE OverloadedStrings #-}++import qualified Aws+import qualified Aws.Core as Aws+import qualified Aws.S3 as S3+import           Data.Conduit.Binary (sinkFile)+import           Control.Monad.Trans.Resource+import           Network.HTTP.Conduit (newManager, tlsManagerSettings, RequestBody(..))+import Control.Monad.IO.Class+import Control.Concurrent+import System.IO+import Control.Applicative+import qualified Data.Text as T+import System.Environment++sc :: S3.StorageClass+sc = S3.OtherStorageClass (T.pack "NEARLINE")++main :: IO ()+main = do+  [bucket] <- fmap (map T.pack) getArgs++  {- Set up AWS credentials and S3 configuration using the Google Cloud+   - Storage endpoint. -}+  Just creds <- Aws.loadCredentialsFromEnv+  let cfg = Aws.Configuration Aws.Timestamp creds (Aws.defaultLog Aws.Debug) Nothing+  let s3cfg = S3.s3 Aws.HTTP "storage.googleapis.com" False++  {- Set up a ResourceT region with an available HTTP manager. -}+  mgr <- newManager tlsManagerSettings+  runResourceT $ do+    {- Create a request object with S3.PutBucket and run the request with pureAws. -}+    rsp <-+      Aws.pureAws cfg s3cfg mgr $+        S3.PutBucket bucket Nothing "US" (Just sc)+    liftIO $ print rsp
Examples/Sqs.hs view
@@ -67,11 +67,11 @@   let receiveMessageReq = Sqs.ReceiveMessage Nothing [] (Just 1) [] sqsQName (Just 20)   let numMessages = length messages   removedMsgs <- replicateM numMessages $ do-      msgs <- eitherT (const $ return []) return . retryT 2 $ do+      msgs <- exceptT (const $ return []) return . retryT 2 $ do         Sqs.ReceiveMessageResponse r <- liftIO $ Aws.simpleAws cfg sqscfg receiveMessageReq         case r of-          [] -> left "no message received"-          _ -> right r+          [] -> throwE "no message received"+          _ -> return r       putStrLn $ "number of messages received: " ++ show (length msgs)       forM msgs (\msg -> do                      -- here we remove a message, delete it from the queue, and then return the@@ -88,24 +88,24 @@   {- | Let's make sure the queue was actually deleted and that the same number of queues exist at when      | the program ends as when it started.   -}-  eitherT T.putStrLn T.putStrLn . retryT 4 $ do+  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_      if qUrl `elem` qUrls-        then left $ " *\n *\n * Warning, '" <> sshow qName <> "' was not deleted\n"+        then throwE $ " *\n *\n * Warning, '" <> sshow qName <> "' was not deleted\n"                     <> " * This is probably just a race condition."-        else right $ "     The queue '" <> sshow qName <> "' was correctly deleted"+        else return $ "     The queue '" <> sshow qName <> "' was correctly deleted" -retryT :: MonadIO m => Int -> EitherT T.Text m a -> EitherT T.Text m a+retryT :: MonadIO m => Int -> ExceptT T.Text m a -> ExceptT T.Text m a retryT i f = go 1   where     go x         | x >= i = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) f-        | otherwise = f `catchT` \_ -> do+        | otherwise = f `catchE` \_ -> do             liftIO $ threadDelay (1000000 * min 60 (2^(x-1)))             go (succ x)
+ README.md view
@@ -0,0 +1,141 @@+Introduction+============++The `aws` package attempts to provide support for using Amazon Web+Services like S3 (storage), SQS (queuing) and others to Haskell+programmers. The ultimate goal is to support all Amazon Web Services.++Installation+============++Make sure you have a recent GHC installed, as well as cabal-install, and+installation should be as easy as:++``` {.bash}+$ cabal install aws+```++If you prefer to install from source yourself, you should first get a+clone of the `aws` repository, and install it from inside the source+directory:++``` {.bash}+$ git clone https://github.com/haskell-pkg-janitors/aws.git+$ cd aws+$ cabal install+```++Using aws+=========++Concepts and organisation+-------------------------++The aws package is organised into the general `Aws` module namespace,+and subnamespaces like `Aws.S3` for each Amazon Web Service. Under each+service namespace in turn, there are general support modules and and+`Aws.<Service>.Commands.<Command>` module for each command. For easier+usage, there are the "bundling" modules `Aws` (general support), and+`Aws.<Service>`.++The primary concept in aws is the *Transaction*, which corresponds to a+single HTTP request to the Amazon Web Services. A transaction consists+of a request and a response, which are associated together via the+`Transaction` typeclass. Requests and responses are simple Haskell+records, but for some requests there are convenience functions to fill+in default values for many parameters.++Example usage+-------------++To be able to access AWS resources, you should put your into a+configuration file. (You don't have to store it in a file, but that's+how we do it in this example.) Save the following in `$HOME/.aws-keys`.++``` {.example}+default AccessKeyID SecretKey+```++You do have to replace AccessKeyID and SecretKey with the Access Key ID+and the Secret Key respectively, of course.++Then, copy this example into a Haskell file, and run it with `runghc`+(after installing aws):++``` {.haskell}+{-# LANGUAGE OverloadedStrings #-}++import qualified Aws+import qualified Aws.S3 as S3+import           Control.Monad.Trans.Resource+import           Data.Conduit ((.|), runConduit)+import           Data.Conduit.Binary (sinkFile)+import           Network.HTTP.Conduit (newManager, tlsManagerSettings, responseBody)++main :: IO ()+main = do+  {- Set up AWS credentials and the default configuration. -}+  cfg <- Aws.baseConfiguration+  let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery++  {- Set up a ResourceT region with an available HTTP manager. -}+  mgr <- newManager tlsManagerSettings+  runResourceT $ do+    {- Create a request object with S3.getObject and run the request with pureAws. -}+    S3.GetObjectResponse { S3.gorResponse = rsp } <-+      Aws.pureAws cfg s3cfg mgr $+        S3.getObject "haskell-aws" "cloud-remote.pdf"++    {- Save the response to a file. -}+    runConduit $ responseBody rsp .| sinkFile "cloud-remote.pdf"+```++You can also find this example in the source distribution in the+`Examples/` folder.++Frequently Asked Questions+==========================++S3 questions+------------++-   I get an error when I try to access my bucket with upper-case+    characters / a very long name.++    Those names are not compliant with DNS. You need to use path-style+    requests, by setting `s3RequestStyle` in the configuration to+    `PathStyle`. Note that such bucket names are only allowed in the US+    standard region, so your endpoint needs to be US standard.++Release Notes+=============++See CHANGELOG++Resources+=========++-   [aws on Github](https://github.com/haskell-pkg-janitors/aws)+-   [aws on Hackage](http://hackage.haskell.org/package/aws) (includes+    reference documentation)+-   [Official Amazon Web Services website](http://aws.amazon.com/)++Contributors+============++  Name                |Github                                           |E-Mail                          |Company                                              |Components+  --------------------|-------------------------------------------------|--------------------------------|-----------------------------------------------------|--------------------+  Abhinav Gupta       |[abhinav](https://github.com/abhinav)            |mail@abhinavg.net               |-                                                    |IAM, SES+  Aristid Breitkreuz  |[aristidb](https://github.com/aristidb)          |aristidb@gmail.com              |-                                                    |Co-Maintainer+  Bas van Dijk        |[basvandijk](https://github.com/basvandijk)      |v.dijk.bas@gmail.com            |[Erudify AG](http://erudify.ch)                      |S3+  David Vollbracht    |[qxjit](https://github.com/qxjit)                |                                |                                                     |+  Felipe Lessa        |[meteficha](https://github.com/meteficha)        |felipe.lessa@gmail.com          |currently secret                                     |Core, S3, SES+  Nathan Howell       |[NathanHowell](https://github.com/NathanHowell)  |nhowell@alphaheavy.com          |[Alpha Heavy Industries](http://www.alphaheavy.com)  |S3+  Ozgun Ataman        |[ozataman](https://github.com/ozataman)          |ozgun.ataman@soostone.com       |[Soostone Inc](http://soostone.com)                  |Core, S3, DynamoDb+  Steve Severance     |[sseveran](https://github.com/sseveran)          |sseverance@alphaheavy.com       |[Alpha Heavy Industries](http://www.alphaheavy.com)  |S3, SQS+  John Wiegley        |[jwiegley](https://github.com/jwiegley)          |johnw@fpcomplete.com            |[FP Complete](http://fpcomplete.com)                 |S3+  Chris Dornan        |[cdornan](https://github.com/cdornan)            |chris.dornan@irisconnect.co.uk  |[Iris Connect](http://irisconnect.co.uk)             |Core+  John Lenz           |[wuzzeb](https://github/com/wuzzeb)              |                                |                                                     |DynamoDB, Core+  Joey Hess           |[joeyh](https://github.com/joeyh)                |id@joeyh.name                   |-                                                    |Co-Maintainer, S3++
− README.org 
@@ -1,326 +0,0 @@-#+TITLE: Amazon Web Services for Haskell--* Introduction--The ~aws~ package attempts to provide support for using Amazon Web Services like S3 (storage), SQS (queuing) and others-to Haskell programmers. The ultimate goal is to support all Amazon Web Services.--* Installation--Make sure you have a recent GHC installed, as well as cabal-install, and installation should be as easy as:--#+BEGIN_SRC bash-$ cabal install aws-#+END_SRC--If you prefer to install from source yourself, you should first get a clone of the ~aws~ repository, and install it from-inside the source directory:--#+BEGIN_SRC bash-$ git clone https://github.com/aristidb/aws.git-$ cd aws-$ cabal install-#+END_SRC--* Using aws--** Concepts and organisation--The aws package is organised into the general =Aws= module namespace, and subnamespaces like =Aws.S3= for each Amazon Web-Service. Under each service namespace in turn, there are general support modules and and =Aws.<Service>.Commands.<Command>=-module for each command. For easier usage, there are the "bundling" modules =Aws= (general support), and =Aws.<Service>=.--The primary concept in aws is the /Transaction/, which corresponds to a single HTTP request to the Amazon Web Services.-A transaction consists of a request and a response, which are associated together via the =Transaction= typeclass. Requests-and responses are simple Haskell records, but for some requests there are convenience functions to fill in default values-for many parameters.--** Example usage--To be able to access AWS resources, you should put your into a configuration file. (You don't have to store it in a file,-but that's how we do it in this example.) Save the following in ~$HOME/.aws-keys~.--#+BEGIN_EXAMPLE-default AccessKeyID SecretKey-#+END_EXAMPLE--You do have to replace AccessKeyID and SecretKey with the Access Key ID and the Secret Key respectively, of course.--Then, copy this example into a Haskell file, and run it with ~runghc~ (after installing aws):--#+BEGIN_SRC haskell-{-# LANGUAGE OverloadedStrings #-}--import qualified Aws-import qualified Aws.S3 as S3-import           Data.Conduit (($$+-))-import           Data.Conduit.Binary (sinkFile)-import           Network.HTTP.Conduit (withManager, responseBody)--main :: IO ()-main = do-  {- Set up AWS credentials and the default configuration. -}-  cfg <- Aws.baseConfiguration-  let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery--  {- Set up a ResourceT region with an available HTTP manager. -}-  withManager $ \mgr -> do-    {- Create a request object with S3.getObject and run the request with pureAws. -}-    S3.GetObjectResponse { S3.gorResponse = rsp } <--      Aws.pureAws cfg s3cfg mgr $-        S3.getObject "haskell-aws" "cloud-remote.pdf"--    {- Save the response to a file. -}-    responseBody rsp $$+- sinkFile "cloud-remote.pdf"-#+END_SRC--You can also find this example in the source distribution in the ~Examples/~ folder.---* Frequently Asked Questions--** S3 questions--- I get an error when I try to access my bucket with upper-case characters / a very long name.--  Those names are not compliant with DNS. You need to use path-style requests, by setting ~s3RequestStyle~ in the configuration to-  ~PathStyle~. Note that such bucket names are only allowed in the US standard region, so your endpoint needs to be US standard.--* Release Notes--** 0.12 series--- 0.12.1-  - DDB: Fix eu-west-1, add eu-central-1-  - attoparsec 0.13-  - xml-conduit 1.3--- 0.12-  - S3: Support for "Expect: 100-continue" (optional, technically API breaking)-  - S3: Properly treat errors with a "301 Permanent Redirect" as errors and expose endpoint information--** 0.11 series--- 0.11.4-  - Url-encode S3 object names in URLs-  - filepath 1.4-  - tagged 0.8.x-  - limit errors to <2 to avoid compatibility problems--- 0.11.3-  - Support for blaze-builder 0.4-  - Support for utf8-string 1.0-  - New function: multipartUploadWithInitiator-  - Fix issue in DynamoDB error parsing-  - Ord instance for Aws.Core.Method--- 0.11.2-  - Support for time 1.5 (we previously forgot to relax the upper bound in Cabal)--- 0.11.1-  - Support time 1.5-  - Fix duplicate sending of query when using PostQuery--- 0.11-  - New functions for running AWS transactions-  - Performance optimizations for DynamoDB and S3 MultiPartUpload-  - New DynamoDB commands & features-  - S3 endpoint eu-central-1--** 0.10 series--- 0.10.5-  - support for conduit 1.2--- 0.10.4-  - S3: support for multi-part uploads-  - DynamoDB: fixes for JSON serialization-      WARNING: This includes making some fields in TableDescription Maybe fields, which is breaking. But DynamoDB support was-               and is also marked as EXPERIMENTAL.-  - DynamoDB: TCP connection reuse where possible (improving performance)-  - DynamoDB: Added test suite-  - SES: support for additional regions--- 0.10.3-  - fix bug introduced in 0.10.2 that broke SQS and IAM connections without STS--- 0.10.2-  - support STS / IAM temporary credentials in all services--- 0.10-  - [EXPERIMENTAL!] DynamoDB: support for creating/updating/querying and scanning items-  - SQS: complete overhaul to support 2012-11-05 features-  - SQS: test suite-  - S3: use Maybe for 404 HEAD requests on objects instead of throwing a misleading exception-  - S3: support of poAutoMakeBucket for Internet Archive users-  - S3: implement GetBucketLocation-  - S3: add South American region-  - S3: allow specifying the Content-Type when copying objects-  - core: fix typo in NoCredentialsException accessor--** 0.9 series--- 0.9.4-  - allow conduit 1.2--- 0.9.3-  - fix performance regression for loadCredentialsDefault-  - add generic makeCredentials function-  - add S3 DeleteBucket operation-  - add S3 NukeBucket example-  - SES: use security token if enabled (should allow using it with IAM roles on EC2 instances)--- 0.9.2-  - Support for credentials from EC2 instance metadata (only S3 for now)-  - aeson 0.8 compatibility--- 0.9.1-  - Support for multi-page S3 GetBucket requests-  - S3 GLACIER support-  - Applicative instance for Response to conform to the Applicative-Monad Proposal-  - Compatibility with transformers 0.4--- 0.9-  - Interface changes:-    - attempt and failure were deprecated, remove-    - switch to new cryptohash interface-  - updated version bounds of conduit and xml-conduit--** 0.8 series--- 0.8.6-  - move Instance metadata functions out of ResourceT to remove problem with exceptions-0.5-    (this makes a fresh install of aws on a clean system possible again)--- 0.8.5-  - compatibility with case-insensitive 1.2-  - support for V4 signatures-  - experimental support for DynamoDB--- 0.8.4-  - compatibility with http-conduit 2.0--- 0.8.3-  - compatibility with cryptohash 0.11-  - experimental IAM support--- 0.8.2-  - compatibility with cereal 0.4.x--- 0.8.1-  - compatibility with case-insensitive 1.1--- 0.8.0-  - S3, SQS: support for US-West2 (#58)-  - S3: GetObject now has support for Content-Range (#22, #50)-  - S3: GetBucket now supports the "IsTruncated" flag (#39)-  - S3: PutObject now supports web page redirects (#46)-  - S3: support for (multi-object) DeleteObjects (#47, #56)-  - S3: HeadObject now uses an actual HEAD request (#53)-  - S3: fixed signing issues for GetObject call (#54)-  - SES: support for many more operations (#65, #66, #70, #71, #72, #74)-  - SES: SendRawEmail now correctly encodes destinations and allows multiple destinations (#73)-  - EC2: support fo Instance metadata (#37)-  - Core: queryToHttpRequest allows overriding "Date" for the benefit of Chris Dornan's Elastic Transcoder bindings (#77)--** 0.7 series--- 0.7.6.4-  - CryptoHash update-- 0.7.6.3-  - In addition to supporting http-conduit 1.9, it would seem nice to support conduit 1.0. Previously slipped through the radar.--- 0.7.6.2-  - Support for http-conduit 1.9--- 0.7.6.1-  - Support for case-insensitive 1.0 and http-types 0.8--- 0.7.6-  - Parsing of SimpleDB error responses was too strict, fixed-  - Support for cryptohash 0.8-  - Failure 0.1 does not work with aws, stricter lower bound--- 0.7.5-  - Support for http-conduit 1.7 and 1.8--- 0.7.1-0.7.4-  - Support for GHC 7.6-  - Wider constraints to support newer versions of various dependencies-  - Update maintainer e-mail address and project categories in cabal file--- 0.7.0-  - Change ServiceConfiguration concept so as to indicate in the type whether this is for URI-only requests-    (i.e. awsUri)-  - EXPERIMENTAL: Direct support for iterated transaction, i.e. such where multiple HTTP requests might be necessary due to e.g. response size limits.-  - Put aws functions in ResourceT to be able to safely return Sources and streams.-    - simpleAws* does not require ResourceT and converts streams into memory values (like ByteStrings) first.-  - Log response metadata (level Info), and do not let all aws runners return it.-  - S3:-    - GetObject: No longer require a response consumer in the request, return the HTTP response (with the body as a stream) instead.-    - Add CopyObject (PUT Object Copy) request type.-  - Add Examples cabal flag for building code examples.-  - Many more, small improvements.--** 0.6 series--- 0.6.2-  - Properly parse Last-Modified header in accordance with RFC 2616.--- 0.6.1-  - Fix for MD5 encoding issue in S3 PutObject requests.--- 0.6.0-  - API Cleanup-    - General: Use Crypto.Hash.MD5.MD5 when a Content-MD5 hash is required, instead of ByteString.-    - S3: Made parameter order to S3.putObject consistent with S3.getObject.-  - Updated dependencies:-    - conduit 0.5 (as well as http-conduit 1.5 and xml-conduit 1.0).-    - http-types 0.7.-  - Minor changes.-  - Internal changes (notable for people who want to add more commands):-    - http-types' new 'QueryLike' interface allows creating query lists more conveniently.--** 0.5 series--- 0.5.0 ::-    New configuration system: configuration split into general and service-specific parts.--    Significantly improved API reference documentation.--    Re-organised modules to make library easier to understand.--    Smaller improvements.--** 0.4 series--- 0.4.1 :: Documentation improvements.-- 0.4.0.1 :: Change dependency bounds to allow the transformers 0.3 package.-- 0.4.0 :: Update conduit to 0.4.0, which is incompatible with earlier versions.--** 0.3 series--- 0.3.2 :: Add awsRef / simpleAwsRef request variants for those who prefer an =IORef= over a =Data.Attempt.Attempt= value.-           Also improve README and add simple example.--* Resources--- [[https://github.com/aristidb/aws][aws on Github]]-- [[http://hackage.haskell.org/package/aws][aws on Hackage]] (includes reference documentation)-- [[http://aws.amazon.com/][Official Amazon Web Services website]]--* Contributors--| Name               | Github       | E-Mail                    | Company                | Components    |-|--------------------+--------------+---------------------------+------------------------+---------------|-| Abhinav Gupta      | [[https://github.com/abhinav][abhinav]]  | mail@abhinavg.net | -  | IAM, SES      |-| Aristid Breitkreuz | [[https://github.com/aristidb][aristidb]]     | aristidb@gmail.com        | -                      | Co-Maintainer    |-| Bas van Dijk       | [[https://github.com/basvandijk][basvandijk]]   | v.dijk.bas@gmail.com      | [[http://erudify.ch][Erudify AG]]             | S3            |-| David Vollbracht   | [[https://github.com/qxjit][qxjit]]        |                           |                        |               |-| Felipe Lessa       | [[https://github.com/meteficha][meteficha]]    | felipe.lessa@gmail.com    | currently secret       | Core, S3, SES |-| Nathan Howell      | [[https://github.com/NathanHowell][NathanHowell]] | nhowell@alphaheavy.com    | [[http://www.alphaheavy.com][Alpha Heavy Industries]] | S3            |-| Ozgun Ataman       | [[https://github.com/ozataman][ozataman]]     | ozgun.ataman@soostone.com | [[http://soostone.com][Soostone Inc]]           | Core, S3, DynamoDb |-| Steve Severance    | [[https://github.com/sseveran][sseveran]]     | sseverance@alphaheavy.com | [[http://www.alphaheavy.com][Alpha Heavy Industries]] | S3, SQS       |-| John Wiegley       | [[https://github.com/jwiegley][jwiegley]]     | johnw@fpcomplete.com      | [[http://fpcomplete.com][FP Complete]]            | Co-Maintainer, S3            |-| Chris Dornan | [[https://github.com/cdornan][cdornan]] | chris.dornan@irisconnect.co.uk | [[http://irisconnect.co.uk][Iris Connect]] | Core |-| John Lenz | [[https://github/com/wuzzeb][wuzzeb]] | | | DynamoDB, Core |
aws.cabal view
@@ -1,8 +1,8 @@ Name:                aws-Version:             0.12.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 <https://github.com/aristidb/aws/blob/master/README.org>.-Homepage:            http://github.com/aristidb/aws+Description:         Bindings for Amazon Web Services (AWS), with the aim of supporting all AWS services. To see a high level overview of the library, see the README at <https://github.com/haskell-pkg-janitors/aws/blob/master/README.md>.+Homepage:            http://github.com/haskell-pkg-janitors/aws License:             BSD3 License-file:        LICENSE Author:              Aristid Breitkreuz, contributors see README@@ -11,20 +11,19 @@ Category:            Network, Web, AWS, Cloud, Distributed Computing Build-type:          Simple -Extra-source-files:  README.org-                     Examples/GetObject.hs-                     Examples/SimpleDb.hs+Extra-source-files:  README.md+                     CHANGELOG.md  Cabal-version:       >=1.10  Source-repository this   type: git-  location: https://github.com/aristidb/aws.git-  tag: 0.12.1+  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.@@ -37,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@@ -48,18 +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.5,-                       conduit              >= 1.1     && < 1.3,-                       conduit-extra        >= 1.1     && < 1.2,+                       cereal               >= 0.3     && < 0.6,+                       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.6,-                       directory            >= 1.0     && < 1.3,-                       filepath             >= 1.1     && < 1.5,-                       http-conduit         >= 2.1     && < 2.2,-                       http-types           >= 0.7     && < 0.9,+                       crypton              >= 0.34,+                       data-default         >= 0.5.3   && < 0.9,+                       directory            >= 1.0     && < 2.0,+                       filepath             >= 1.1     && < 1.6,+                       http-conduit         >= 2.3     && < 2.4,+                       http-client-tls      >= 0.4     && < 0.5,+                       http-types           >= 0.7     && < 1.0,                        lifted-base          >= 0.1     && < 0.3,+                       ram,                        monad-control        >= 0.3,+                       exceptions           >= 0.8     && < 0.11,                        mtl                  == 2.*,-                       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   && < 1.6,-                       transformers         >= 0.2.2   && < 0.5,+                       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,10 +250,12 @@     Build-depends:                        base == 4.*,                        aws,+                       bytestring,                        http-conduit,                        conduit,                        conduit-extra,-                       text+                       text,+                       resourcet    Default-Language: Haskell2010 @@ -216,7 +273,8 @@                        http-conduit,                        conduit,                        conduit-extra,-                       text+                       text,+                       resourcet    Default-Language: Haskell2010 @@ -235,10 +293,31 @@                        conduit,                        conduit-extra,                        text >=0.1,-                       transformers+                       transformers,+                       resourcet    Default-Language: Haskell2010 +Executable PutBucketNearLine+  Main-is: PutBucketNearLine.hs+  Hs-source-dirs: Examples++  if !flag(Examples)+    Buildable: False+  else+    Buildable: True+    Build-depends:+                       base == 4.*,+                       aws,+                       http-conduit,+                       conduit,+                       conduit-extra,+                       text >=0.1,+                       transformers,+                       resourcet++  Default-Language: Haskell2010+ Executable SimpleDb   Main-is: SimpleDb.hs   Hs-source-dirs: Examples@@ -268,6 +347,7 @@                        data-default,                        exceptions,                        http-conduit,+                       resourcet,                        text,                        conduit @@ -285,7 +365,7 @@     Build-depends:                        base == 4.*,                        aws,-                       errors >= 1.4 && < 2.0,+                       errors >= 2.0,                        text >=0.11,                        transformers >= 0.3 @@ -306,8 +386,8 @@         aws,         base == 4.*,         bytestring >= 0.10,-        errors >= 1.4.7 && < 2.0,-        http-client >= 0.3,+        errors >= 2.0,+        http-client >= 0.3 && < 0.8,         lifted-base >= 0.2,         monad-control >= 0.3,         mtl >= 2.1,@@ -339,7 +419,7 @@         aws,         base == 4.*,         bytestring >= 0.10,-        errors >= 1.4.7 && < 2.0,+        errors >= 2.0,         http-client >= 0.3,         lifted-base >= 0.2,         monad-control >= 0.3,@@ -354,3 +434,36 @@         transformers >= 0.3,         transformers-base >= 0.4 ++test-suite s3-tests+    type: exitcode-stdio-1.0+    default-language: Haskell2010+    hs-source-dirs: tests+    main-is: S3/Main.hs++    other-modules:+        Utils++    build-depends:+        aws,+        base == 4.*,+        QuickCheck >= 2.7,+        aeson >= 0.7,+        bytestring,+        conduit,+        errors >= 2.0,+        lifted-base >= 0.2,+        monad-control >= 0.3,+        mtl >= 2.1,+        http-client < 0.8,+        http-client-tls < 0.5,+        http-types,+        resourcet,+        tasty >= 0.8,+        tasty-hunit >= 0.8,+        tasty-quickcheck >= 0.8,+        text,+        time,+        tagged >= 0.7,+        transformers >= 0.3,+        transformers-base >= 0.4
tests/DynamoDb/Main.hs view
@@ -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"@@ -112,12 +112,12 @@     :: Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)     -> Int -- ^ write capacity (#writes * itemsize/1KB)     -> T.Text -- ^ table name-    -> EitherT T.Text IO ()+    -> ExceptT T.Text IO () prop_createDescribeDeleteTable readCapacity writeCapacity tableName = do     tTableName <- testData tableName     tryT $ createTestTable tTableName readCapacity writeCapacity     let deleteTable = retryT 6 . void $ simpleDyT (DY.DeleteTable tTableName)-    handleT (\e -> deleteTable >> left e) $ do+    flip catchE (\e -> deleteTable >> throwE e) $ do         retryT 6 . void . simpleDyT $ DY.DescribeTable tTableName         deleteTable @@ -130,7 +130,7 @@         ]  prop_connectionReuse-    :: EitherT T.Text IO ()+    :: ExceptT T.Text IO () prop_connectionReuse = do     c <- liftIO $ do         cfg <- baseConfiguration@@ -138,14 +138,15 @@         -- counts the number of TCP connections         ref <- newIORef (0 :: Int) -        void . HTTP.withManager (managerSettings ref) $ \manager -> runEitherT $-            handleT (error . T.unpack) . replicateM_ 3 $ do+        manager <- HTTP.newManager (managerSettings ref)+        void $ runExceptT $+            flip catchE (error . T.unpack) . replicateM_ 3 $ do                 void $ dyT cfg manager DY.ListTables                 mustFail . dyT cfg manager $ DY.DescribeTable "____"          readIORef ref     unless (c == 1) $-        left "The TCP connection has not been reused"+        throwE "The TCP connection has not been reused"   where     managerSettings ref = HTTP.defaultManagerSettings         { HTTP.managerRawConnection = do
tests/DynamoDb/Utils.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}  -- | -- Module: DynamoDb.Utils@@ -96,7 +97,7 @@ simpleDyT     :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadBaseControl IO m, MonadIO m)     => r-    -> EitherT T.Text m (MemoryResponse a)+    -> ExceptT T.Text m (MemoryResponse a) simpleDyT = tryT . simpleDy  dyT@@ -104,7 +105,7 @@     => Configuration     -> HTTP.Manager     -> r-    -> EitherT T.Text IO a+    -> ExceptT T.Text IO a dyT cfg manager req = do     Response _ r <- liftIO . runResourceT $ aws cfg dyConfiguration manager req     hoistEither $ fmapL sshow r@@ -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)@@ -129,17 +130,17 @@       tTableName <- if prefix then testData tableName else return tableName        let deleteTable = do-            r <- runEitherT . retryT 6 $-                void (simpleDyT $ DY.DeleteTable tTableName) `catchT` \e ->+            r <- runExceptT . retryT 6 $+                void (simpleDyT $ DY.DeleteTable tTableName) `catchE` \e ->                     liftIO . T.hPutStrLn stderr $ "attempt to delete table failed: " <> e             either (error . T.unpack) (const $ return ()) r        let createTable = do-            r <- runEitherT $ do+            r <- runExceptT $ do                 retryT 3 $ tryT $ createTestTable tTableName readCapacity writeCapacity                 retryT 6 $ do                     tableDesc <- simpleDyT $ DY.DescribeTable tTableName-                    when (DY.rTableStatus tableDesc == "CREATING") $ left "Table not ready: status CREATING"+                    when (DY.rTableStatus tableDesc == "CREATING") $ throwE "Table not ready: status CREATING"             either (error . T.unpack) return r        bracket_ createTable deleteTable $ f tTableName
+ tests/S3/Main.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+-- |+-- Module: Main+-- Copyright: Copyright © 2016 Soostone, Inc.+-- License: BSD3+-- Maintainer: Michael Xavier <michael.xavier@soostone.com>+-- Stability: experimental+--+-- Tests for Haskell AWS S3 bindings+--+module Main+    ( main+    ) where++import           Control.Applicative+import qualified Data.ByteString              as BS+import qualified Data.ByteString.Lazy         as BL+import           Conduit+import           Control.Arrow                (second)+import           Control.Exception+import           Control.Monad+import           Control.Monad.Trans.Resource+import qualified Data.List                    as L+import           Data.Monoid+import qualified Data.Text                    as T+import           Data.Typeable+import           Data.Proxy+import           Network.HTTP.Client          (HttpException (..),+                                               RequestBody (..), newManager,+                                               responseBody)+#if MIN_VERSION_http_client(0, 5, 0)+import           Network.HTTP.Client          (HttpExceptionContent (..),+                                               responseStatus)+#endif+import           Network.HTTP.Client.TLS      (tlsManagerSettings)+import           Network.HTTP.Types.Status+import           System.Environment+import           System.Exit+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.Options++import           Aws+import           Aws.S3+++newtype BucketOption = BucketOption Bucket+                     deriving (Show, Eq, Ord, Typeable)++instance IsOption BucketOption where+  defaultValue = error "The --bucket flag is required"+  parseValue = Just . BucketOption . T.pack+  optionName = return "bucket"+  optionHelp = return "Bucket to use for performing S3 operations. Tests will write to the 's3-test-object' key."+++main :: IO ()+main = do+    args <- getArgs+    runMain args $ map (second tail . span (/= '=')) args+  where+    runMain :: [String] -> [(String,String)] -> IO ()+    runMain args _argsMap+        | any (`elem` helpArgs) args = defaultMainWithIngredients ings tests+        | "--run-with-aws-credentials" `elem` args =+            withArgs (tastyArgs args) . defaultMainWithIngredients ings $ tests+        | otherwise = putStrLn help >> exitFailure+    helpArgs = ["--help", "-h"]+    mainArgs =+        [ "--run-with-aws-credentials"+        ]+    tastyArgs args = flip filter args $ \x -> not+        $ any (`L.isPrefixOf` x) mainArgs+    ings = includingOptions [Option (Proxy :: Proxy BucketOption)]:defaultIngredients+++help :: String+help = L.intercalate "\n"+    [ ""+    , "NOTE"+    , ""+    , "This test suite accesses the AWS account that is associated with"+    , "the default credentials from the credential file ~/.aws-keys."+    , ""+    , "By running the tests in this test-suite costs for usage of AWS"+    , "services may incur."+    , ""+    , "In order to actually execute the tests in this test-suite you must"+    , "provide the command line options:"+    , ""+    , "    --run-with-aws-credentials"+    , ""+    , "When running this test-suite through cabal you may use the following"+    , "command:"+    , ""+    , "    cabal test --test-option=--run-with-aws-credentials s3-tests"+    , ""+    ]+++tests :: TestTree+tests = testGroup "S3 Tests"+    [ test_head+    , test_get+    , test_versioning+    ]+++-------------------------------------------------------------------------------+-- HeadObject Tests+-------------------------------------------------------------------------------+++test_head :: TestTree+test_head = askOption $ \(BucketOption bucket) -> testGroup "HeadObject"+  [ test_head_caching bucket+  ]+++test_head_caching :: Bucket -> TestTree+test_head_caching bucket = withResource mkSetup teardown $ \setup -> testGroup "Caches"+  [ testCase "If-Matches match succeeds" $ do+      (cfg, s3cfg, mgr) <- setup+      void (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfMatch = Just payloadMD5 }))+  , testCase "If-Matches mismatch fails with 412" $ do+      (cfg, s3cfg, mgr) <- setup+      assertStatus 412 (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfMatch = Just (T.reverse payloadMD5) }))+  , testCase "If-None-Match mismatch succeeds" $ do+      (cfg, s3cfg, mgr) <- setup+      void (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfNoneMatch = Just (T.reverse payloadMD5) }))+  , testCase "If-None-Match match fails with 304" $ do+      (cfg, s3cfg, mgr) <- setup+      assertStatus 304 (runResourceT (pureAws cfg s3cfg mgr (headObject bucket k) { hoIfNoneMatch = Just payloadMD5 }))+  ]+  where+    k = "s3-test-object"+    content = "example"+    payloadMD5 = "1a79a4d60de6718e8e5b326e338ae533"+    mkSetup = do+      cfg <- baseConfiguration+      let s3cfg = defServiceConfig+      mgr <- newManager tlsManagerSettings+      void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))+      return (cfg, s3cfg, mgr)+    teardown (cfg, s3cfg, mgr) =+      void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket)))+++-------------------------------------------------------------------------------+-- GetObject Tests+-------------------------------------------------------------------------------+++test_get :: TestTree+test_get = askOption $ \(BucketOption bucket) -> testGroup "GetObject"+  [ test_get_caching bucket+  ]+++test_get_caching :: Bucket -> TestTree+test_get_caching bucket = withResource mkSetup teardown $ \setup -> testGroup "Caches"+  [ testCase "If-Matches match succeeds" $ do+      (cfg, s3cfg, mgr) <- setup+      void (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfMatch = Just payloadMD5 }))+  , testCase "If-Matches mismatch fails with 412" $ do+      (cfg, s3cfg, mgr) <- setup+      assertStatus 412 (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfMatch = Just (T.reverse payloadMD5) }))+  , testCase "If-None-Match mismatch succeeds" $ do+      (cfg, s3cfg, mgr) <- setup+      void (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfNoneMatch = Just (T.reverse payloadMD5) }))+  , testCase "If-None-Match match fails with 304" $ do+      (cfg, s3cfg, mgr) <- setup+      assertStatus 304 (runResourceT (pureAws cfg s3cfg mgr (getObject bucket k) { goIfNoneMatch = Just payloadMD5 }))+  ]+  where+    k = "s3-test-object"+    content = "example"+    payloadMD5 = "1a79a4d60de6718e8e5b326e338ae533"+    mkSetup = do+      cfg <- baseConfiguration+      let s3cfg = defServiceConfig+      mgr <- newManager tlsManagerSettings+      void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))+      return (cfg, s3cfg, mgr)+    teardown (cfg, s3cfg, mgr) =+      void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket)))+++-------------------------------------------------------------------------------+-- GetBucketObjectVersions Tests+-------------------------------------------------------------------------------+++test_versioning :: TestTree+test_versioning = askOption $ \(BucketOption bucket) ->+  withResource (mkSetup bucket) (teardown bucket) $ \setup -> testGroup "Versioning"+    [ testCase "GetBucketObjectVersions succeeds" $ do+        (cfg, s3cfg, mgr) <- setup+        resp <- runResourceT $ pureAws cfg s3cfg mgr $ (getBucketObjectVersions bucket)+          { gbovPrefix = Just k+          }+        let [o1, o2, o3, o4] = take 4 $ gbovrContents resp+        checkObject True o1+        checkDeleteMarker False o2+        checkObject False o3+        checkObject False o4+    , testCase "DeleteObjectVersion succeeds" $ do+        -- Note: this test requires bucket with versioning enabled+        (cfg, s3cfg, mgr) <- setup+        resp <- runResourceT $ pureAws cfg s3cfg mgr $ (getBucketObjectVersions bucket)+          { gbovPrefix = Just k+          }+        let [v1, v2, v3, v4] = map oviVersionId $ take 4 $ gbovrContents resp+        void (runResourceT (pureAws cfg s3cfg mgr (deleteObjectVersion bucket k v2)))+        void (runResourceT (pureAws cfg s3cfg mgr (deleteObjectVersion bucket k v3)))++        resp' <- runResourceT $ pureAws cfg s3cfg mgr $ (getBucketObjectVersions bucket)+          { gbovPrefix = Just k+          }+        let [v1', v4'] = map oviVersionId $ take 2 $ gbovrContents resp'+        assertEqual "invalid v1 version" v1 v1'+        assertEqual "invalid v4 version" v4 v4'+    , testCase "Multipart upload succeeds" $ do+        -- Note: this test requires bucket with versioning enabled+        (cfg, s3cfg, mgr) <- setup+        resp <- runResourceT $ do+            uploadId <- liftIO $ getUploadId cfg s3cfg mgr bucket k+            etags <- (sourceLazy testStr+                .| chunkedConduit 65536+                .| putConduit cfg s3cfg mgr bucket k uploadId+                ) `connect` sinkList+            liftIO $ sendEtag cfg s3cfg mgr bucket k uploadId etags+        let Just vid = cmurVersionId resp+        bs <- runResourceT $ do+            gor <- pureAws cfg s3cfg mgr (getObject bucket k) { goVersionId = Just vid }+            sealConduitT (responseBody (gorResponse gor)) $$+- sinkLazy++        assertEqual "data do not match" testStr bs+    ]+  where+    testStr = "foobar" :: BL.ByteString+    k = "s3-test-object"+    content = "example"+    payloadMD5 = "1a79a4d60de6718e8e5b326e338ae533"+    checkObject marker obj@ObjectVersion{} = do+        assertEqual "invalid object key" k (oviKey obj)+        assertEqual "invalid isLatest flag" marker (oviIsLatest obj)+        assertEqual "invalid object size" (fromIntegral $ BS.length content) (oviSize obj)+    checkObject _ obj = assertFailure $ "Invalid object type " <> show obj+    checkDeleteMarker marker obj@DeleteMarker{} = do+        assertEqual "invalid object key" k (oviKey obj)+        assertEqual "invalid isLatest flag" marker (oviIsLatest obj)+    checkDeleteMarker _ obj = assertFailure $ "Invalid object type " <> show obj+    mkSetup bucket = do+      cfg <- baseConfiguration+      let s3cfg = defServiceConfig+      mgr <- newManager tlsManagerSettings+      void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))+      void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))+      void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket)))+      void (runResourceT (pureAws cfg s3cfg mgr (putObject bucket k (RequestBodyBS content))))+      return (cfg, s3cfg, mgr)+    teardown bucket (cfg, s3cfg, mgr) =+      void (runResourceT (pureAws cfg s3cfg mgr (DeleteObject k bucket)))+++assertStatus :: Int -> IO a -> Assertion+assertStatus expectedStatus f = do+  res <- catchJust selector+                   (Right <$> f)+                   (return . Left)+  case res of+    Right _ -> assertFailure ("Expected error with status " <> show expectedStatus <> ", but got success.")+    Left _ -> return ()+  where+#if MIN_VERSION_http_client(0, 5, 0)+    selector (HttpExceptionRequest _ (StatusCodeException res _))+      | statusCode (responseStatus res) == expectedStatus = Just ()+    selector _ = Nothing+#else+    selector (StatusCodeException s _ _)+      | statusCode s == expectedStatus = Just ()+      | otherwise = Nothing+    selector  _ = Nothing+#endif
tests/Sqs/Main.hs view
@@ -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"@@ -141,7 +143,7 @@     => Configuration     -> HTTP.Manager     -> r-    -> EitherT T.Text IO a+    -> ExceptT T.Text IO a sqsT cfg manager req = do     Response _ r <- liftIO . runResourceT $ aws cfg sqsConfiguration manager req     hoistEither $ fmapL sshow r@@ -157,7 +159,7 @@ simpleSqsT     :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadBaseControl IO m, MonadIO m)     => r-    -> EitherT T.Text m (MemoryResponse a)+    -> ExceptT T.Text m (MemoryResponse a) simpleSqsT = tryT . simpleSqs  withQueueTest@@ -186,16 +188,16 @@ -- prop_createListDeleteQueue     :: T.Text -- ^ queue name-    -> EitherT T.Text IO ()+    -> ExceptT T.Text IO () prop_createListDeleteQueue queueName = do     tQueueName <- testData queueName     SQS.CreateQueueResponse queueUrl <- simpleSqsT $ SQS.CreateQueue Nothing tQueueName     let queue = sqsQueueName queueUrl-    handleT (\e -> deleteQueue queue >> left e) $ do+    flip catchE (\e -> deleteQueue queue >> throwE e) $ do         retryT 6 $ do             SQS.ListQueuesResponse allQueueUrls <- simpleSqsT (SQS.ListQueues Nothing)             unless (queueUrl `elem` allQueueUrls)-                . left $ "queue " <> sshow queueUrl <> " not listed"+                . throwE $ "queue " <> sshow queueUrl <> " not listed"         deleteQueue queue   where     deleteQueue queueUrl = void $ simpleSqsT (SQS.DeleteQueue queueUrl)@@ -221,7 +223,7 @@ -- prop_sendReceiveDeleteMessage     :: SQS.QueueName-    -> EitherT T.Text IO ()+    -> ExceptT T.Text IO () prop_sendReceiveDeleteMessage queue = do      -- a visibility timeout should be used only if either @receiveBatch == 1@@@ -241,10 +243,10 @@         msgs <- retryT 5 $ do             r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll             case r of-                SQS.ReceiveMessageResponse [] -> left "no message received"+                SQS.ReceiveMessageResponse [] -> throwE "no message received"                 SQS.ReceiveMessageResponse t-                    | length t <= receiveBatch -> right t-                    | otherwise -> left $ "unexpected number of messages received: " <> sshow (length t)+                    | length t <= receiveBatch -> return t+                    | otherwise -> throwE $ "unexpected number of messages received: " <> sshow (length t)         forM_ msgs $ \msg -> retryT 5 $             simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle msg) queue         return (map SQS.mBody msgs)@@ -252,7 +254,7 @@     let recv = L.sort recMsgs     let sent = L.sort messages     unless (sent == recv)-        $ left $ "received messages don't match send messages; sent: "+        $ throwE $ "received messages don't match send messages; sent: "             <> sshow sent <> "; got: " <> sshow recv  -- | Checks for consistent receive: There is no message delay, so all messages@@ -261,7 +263,7 @@ -- prop_sendReceiveDeleteMessageLongPolling     :: SQS.QueueName-    -> EitherT T.Text IO ()+    -> ExceptT T.Text IO () prop_sendReceiveDeleteMessageLongPolling queue = do      let delay = Nothing@@ -279,10 +281,10 @@         msgs <- do             r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll             case r of-                SQS.ReceiveMessageResponse [] -> left "no messages received"+                SQS.ReceiveMessageResponse [] -> throwE "no messages received"                 SQS.ReceiveMessageResponse t-                    | length t == receiveBatch -> right t-                    | otherwise -> left $ "unexpected number of messages received: " <> sshow (length t)+                    | length t == receiveBatch -> return t+                    | otherwise -> throwE $ "unexpected number of messages received: " <> sshow (length t)         forM_ msgs $ \msg -> retryT 5 $             simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle msg) queue         return (map SQS.mBody msgs)@@ -290,18 +292,18 @@     let recv = L.sort recMsgs     let sent = L.sort messages     unless (sent == recv)-        $ left $ "received messages don't match send messages; sent: "+        $ throwE $ "received messages don't match send messages; sent: "             <> sshow sent <> "; got: " <> sshow recv  -- | Checks that long polling is actually enabled. We add a delay to the messages -- and immediately make a receive request with a polling wait time that is larger -- than the delay. Note that even though polling forces consistent reads, messages--- will become available with some (small) offset. 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     :: SQS.QueueName-    -> EitherT T.Text IO ()+    -> ExceptT T.Text IO () prop_sendReceiveDeleteMessageLongPolling1 queue = do      let delay = Just 2@@ -317,10 +319,10 @@         msgs <- do             r <- simpleSqsT $ SQS.ReceiveMessage visTimeout [] (Just receiveBatch) [] queue poll             case r of-                SQS.ReceiveMessageResponse [] -> left "no messages received"+                SQS.ReceiveMessageResponse [] -> throwE "no messages received"                 SQS.ReceiveMessageResponse t-                    | length t == receiveBatch -> right t-                    | otherwise -> left $ "unexpected number of messages received: " <> sshow (length t)+                    | length t == receiveBatch -> return t+                    | otherwise -> throwE $ "unexpected number of messages received: " <> sshow (length t)         forM_ msgs $ \m -> retryT 5 $             simpleSqsT $ SQS.DeleteMessage (SQS.mReceiptHandle m) queue         return (map SQS.mBody msgs)@@ -328,7 +330,7 @@     let recv = L.sort recMsgs     let sent = L.sort messages     unless (sent == recv)-        $ left $ "received messages don't match send messages; sent: "+        $ throwE $ "received messages don't match send messages; sent: "             <> sshow sent <> "; got: " <> sshow recv  @@ -344,7 +346,7 @@  prop_connectionReuse     :: SQS.QueueName-    -> EitherT T.Text IO ()+    -> ExceptT T.Text IO () prop_connectionReuse queue = do     c <- liftIO $ do         cfg <- baseConfiguration@@ -353,9 +355,9 @@         ref <- newIORef (0 :: Int)          -- Use a single manager for all HTTP requests-        void . HTTP.withManager (managerSettings ref) $ \manager -> runEitherT $--            handleT (error . T.unpack) . replicateM_ 3 $ do+        manager <- HTTP.newManager (managerSettings ref)+        void $ runExceptT $+            flip catchE (error . T.unpack) . replicateM_ 3 $ do                 void . sqsT cfg manager $ SQS.ListQueues Nothing                 mustFail . sqsT cfg manager $                     SQS.SendMessage "" (SQS.QueueName "" "") [] Nothing@@ -366,7 +368,7 @@          readIORef ref     unless (c == 1) $-        left "The TCP connection has not been reused"+        throwE "The TCP connection has not been reused"   where      managerSettings ref = HTTP.defaultManagerSettings
tests/Utils.hs view
@@ -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@@ -86,13 +87,13 @@  -- | Catches all exceptions except for asynchronous exceptions found in base. ---tryT :: MonadBaseControl IO m => m a -> EitherT T.Text m a+tryT :: MonadBaseControl IO m => m a -> ExceptT T.Text m a tryT = fmapLT (T.pack . show) . syncIO  -- | Lifted Version of 'syncIO' form "Control.Error.Util". ---syncIO :: MonadBaseControl IO m => m a -> EitherT LE.SomeException m a-syncIO a = EitherT $ LE.catches (Right <$> a)+syncIO :: MonadBaseControl IO m => m a -> ExceptT LE.SomeException m a+syncIO a = ExceptT $ LE.catches (Right <$> a)     [ LE.Handler $ \e -> LE.throw (e :: LE.ArithException)     , LE.Handler $ \e -> LE.throw (e :: LE.ArrayException)     , LE.Handler $ \e -> LE.throw (e :: LE.AssertionFailed)@@ -116,15 +117,15 @@ testData :: (IsString a, Monoid a, MonadBaseControl IO m) => a -> m a testData a = fmap (<> a) testDataPrefix -retryT :: MonadIO m => Int -> EitherT T.Text m a -> EitherT T.Text m a+retryT :: (Functor m, MonadIO m) => Int -> ExceptT T.Text m a -> ExceptT T.Text m a retryT n f = snd <$> retryT_ n f -retryT_ :: MonadIO m => Int -> EitherT T.Text m a -> EitherT T.Text m (Int, a)+retryT_ :: (Functor m, MonadIO m) => Int -> ExceptT T.Text m a -> ExceptT T.Text m (Int, a) retryT_ n f = go 1   where     go x         | x >= n = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) ((x,) <$> f)-        | otherwise = ((x,) <$> f) `catchT` \e -> do+        | otherwise = ((x,) <$> f) `catchE` \e -> do             liftIO $ T.hPutStrLn stderr $ "Retrying after error: " <> e             liftIO $ threadDelay (1000000 * min 60 (2^(x-1)))             go (succ x)@@ -132,31 +133,31 @@ sshow :: (Show a, IsString b) => a -> b sshow = fromString . show -mustFail :: Monad m => EitherT e m a -> EitherT T.Text m ()-mustFail = EitherT . eitherT+mustFail :: Monad m => ExceptT e m a -> ExceptT T.Text m ()+mustFail = ExceptT . exceptT     (const . return $ Right ())     (const . return $ Left "operation succeeded when a failure was expected")  evalTestTM     :: Functor f     => String -- ^ test name-    -> f (EitherT T.Text IO a) -- ^ test+    -> f (ExceptT T.Text IO a) -- ^ test     -> f (PropertyM IO Bool) evalTestTM name = fmap $-    (liftIO . runEitherT) >=> \r -> case r of+    (liftIO . runExceptT) >=> \r -> case r of         Left e ->             fail $ "failed to run test \"" <> name <> "\": " <> show e         Right _ -> return True  evalTestT     :: String -- ^ test name-    -> EitherT T.Text IO a -- ^ test+    -> ExceptT T.Text IO a -- ^ test     -> PropertyM IO Bool evalTestT name = runIdentity . evalTestTM name . Identity  eitherTOnceTest0     :: String -- ^ test name-    -> EitherT T.Text IO a -- ^ test+    -> ExceptT T.Text IO a -- ^ test     -> TestTree eitherTOnceTest0 name test = testProperty name . once . monadicIO     $ evalTestT name test@@ -164,7 +165,7 @@ eitherTOnceTest1     :: (Arbitrary a, Show a)     => String -- ^ test name-    -> (a -> EitherT T.Text IO b)+    -> (a -> ExceptT T.Text IO b)     -> TestTree eitherTOnceTest1 name test = testProperty name . once $ monadicIO     . evalTestTM name test@@ -172,7 +173,7 @@ eitherTOnceTest2     :: (Arbitrary a, Show a, Arbitrary b, Show b)     => String -- ^ test name-    -> (a -> b -> EitherT T.Text IO c)+    -> (a -> b -> ExceptT T.Text IO c)     -> TestTree eitherTOnceTest2 name test = testProperty name . once $ \a b -> monadicIO     $ (evalTestTM name $ uncurry test) (a, b)