aws 0.10.3 → 0.10.4

raw patch · 13 files changed

+1042/−48 lines, 13 filesdep +http-clientdep +transformers-basedep ~aesondep ~basedep ~bytestringnew-component:exe:MultipartUploadPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: http-client, transformers-base

Dependency ranges changed: aeson, base, bytestring, conduit, conduit-extra, errors, http-conduit, lifted-base, mtl, resourcet, tagged, text, time, transformers

API changes (from Hackage documentation)

Files

• Aws/Aws.hs +10/−4
• Aws/DynamoDb/Commands/Table.hs +11/−6
• Aws/DynamoDb/Core.hs +9/−5
• Aws/S3/Commands.hs +2/−0
• Aws/S3/Commands/Multipart.hs +430/−0
• Aws/Ses/Core.hs +15/−3
• Examples/MultipartUpload.hs +29/−0
• README.org +9/−0
• aws.cabal +59/−3
• tests/DynamoDb/Main.hs +157/−0
• tests/DynamoDb/Utils.hs +167/−0
• tests/Sqs/Main.hs +81/−18
• tests/Utils.hs +63/−9

@@ -209,12 +209,18 @@ unsafeAwsRef cfg info manager metadataRef request = do   sd <- liftIO $ signatureData <$> timeInfo <*> credentials $ cfg   let q = signQuery request info sd-  liftIO $ logger cfg Debug $ T.pack $ "String to sign: " ++ show (sqStringToSign q)+  let logDebug = liftIO . logger cfg Debug . T.pack+  logDebug $ "String to sign: " ++ show (sqStringToSign q)   httpRequest <- liftIO $ queryToHttpRequest q-  liftIO $ logger cfg Debug $ T.pack $ "Host: " ++ show (HTTP.host httpRequest)-  liftIO $ logger cfg Debug $ T.pack $ "Path: " ++ show (HTTP.path httpRequest)-  liftIO $ logger cfg Debug $ T.pack $ "Query string: " ++ show (HTTP.queryString httpRequest)+  logDebug $ "Host: " ++ show (HTTP.host httpRequest)+  logDebug $ "Path: " ++ show (HTTP.path httpRequest)+  logDebug $ "Query string: " ++ show (HTTP.queryString httpRequest)+  case HTTP.requestBody httpRequest of+    HTTP.RequestBodyLBS lbs -> logDebug $ "Body: " ++ show lbs+    HTTP.RequestBodyBS bs -> logDebug $ "Body: " ++ show bs+    _ -> return ()   hresp <- HTTP.http httpRequest manager+  logDebug $ "Response status: " ++ show (HTTP.responseStatus hresp)   forM_ (HTTP.responseHeaders hresp) $ \(hname,hvalue) -> liftIO $     logger cfg Debug $ T.decodeUtf8 $ "Response header '" `mappend` CI.original hname `mappend` "': '" `mappend` hvalue `mappend` "'"   responseConsumer request metadataRef hresp

@@ -263,10 +263,10 @@         rTableName              :: T.Text       , rTableSizeBytes         :: Integer       , rTableStatus            :: T.Text -- ^ one of CREATING, UPDATING, DELETING, ACTIVE-      , rCreationDateTime       :: UTCTime+      , rCreationDateTime       :: Maybe UTCTime       , rItemCount              :: Integer       , rAttributeDefinitions   :: [AttributeDefinition]-      , rKeySchema              :: KeySchema+      , rKeySchema              :: Maybe KeySchema       , rProvisionedThroughput  :: ProvisionedThroughputStatus       , rLocalSecondaryIndexes  :: [LocalSecondaryIndexStatus]       , rGlobalSecondaryIndexes :: [GlobalSecondaryIndexStatus]@@ -282,10 +282,10 @@         TableDescription <$> t .: "TableName"                          <*> t .: "TableSizeBytes"                          <*> t .: "TableStatus"-                         <*> (posixSecondsToUTCTime . fromInteger <$> t .: "CreationDateTime")+                         <*> (fmap (posixSecondsToUTCTime . fromInteger) <$> t .:? "CreationDateTime")                          <*> t .: "ItemCount"-                         <*> t .: "AttributeDefinitions"-                         <*> t .: "KeySchema"+                         <*> t .:? "AttributeDefinitions" .!= []+                         <*> t .:? "KeySchema"                          <*> t .: "ProvisionedThroughput"                          <*> t .:? "LocalSecondaryIndexes" .!= []                          <*> t .:? "GlobalSecondaryIndexes" .!= []@@ -391,7 +391,12 @@       }     deriving (Show, Generic) instance A.ToJSON UpdateTable where-    toJSON = A.genericToJSON $ dropOpt 6+    toJSON a = A.object+        $ "TableName" .= updateTableName a+        : "ProvisionedThroughput" .= updateProvisionedThroughput a+        : case updateGlobalSecondaryIndexUpdates a of+            [] -> []+            l -> [ "GlobalSecondaryIndexUpdates" .= l ]  -- | ServiceConfiguration: 'DdbConfiguration' instance SignQuery UpdateTable where

@@ -114,6 +114,7 @@ import qualified Data.Aeson                   as A 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.ByteString.Base16       as Base16@@ -826,7 +827,7 @@ ------------------------------------------------------------------------------- ddbResponseConsumer :: A.FromJSON a => IORef DdbResponse -> HTTPResponseConsumer a ddbResponseConsumer ref resp = do-    val <- HTTP.responseBody resp $$+- sinkParser A.json'+    val <- HTTP.responseBody resp $$+- sinkParser (A.json' <* AttoB.endOfInput)     case statusCode of       200 -> rSuccess val       _   -> rError val@@ -973,10 +974,13 @@   instance ToJSON CondOp where-    toJSON c = object-      [ "ComparisonOperator" .= String (renderCondOp c)-      , "AttributeValueList" .= getCondValues c ]-+    toJSON c = object $ ("ComparisonOperator" .= String (renderCondOp c)) : valueList+      where+        valueList =+          let vs = getCondValues c in+            if null vs+            then []+            else ["AttributeValueList" .= vs]  ------------------------------------------------------------------------------- dyApiVersion :: B.ByteString

@@ -11,6 +11,7 @@ , module Aws.S3.Commands.HeadObject , module Aws.S3.Commands.PutBucket , module Aws.S3.Commands.PutObject+, module Aws.S3.Commands.Multipart ) where @@ -25,3 +26,4 @@ import Aws.S3.Commands.HeadObject import Aws.S3.Commands.PutBucket import Aws.S3.Commands.PutObject+import Aws.S3.Commands.Multipart

@@ -0,0 +1,430 @@+module Aws.S3.Commands.Multipart+       where+import           Aws.Aws+import           Aws.Core+import           Aws.S3.Core+import           Control.Applicative+import           Control.Arrow         (second)+import           Control.Monad.Trans.Resource+import           Crypto.Hash+import qualified Crypto.Hash.MD5       as MD5+import           Data.ByteString.Char8 ({- IsString -})+import           Data.Conduit+import qualified Data.Conduit.Binary   as CB+import qualified Data.Conduit.List     as CL+import           Data.Maybe+import           Text.XML.Cursor       (($/))+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy  as BL+import qualified Data.CaseInsensitive  as CI+import qualified Data.Map              as M+import qualified Data.Text             as T+import qualified Data.Text.Encoding    as T+import qualified Network.HTTP.Conduit  as HTTP+import qualified Network.HTTP.Types    as HTTP+import           Text.Printf(printf)+import qualified Text.XML              as XML++{-+Aws supports following 6 api for Multipart-Upload.+Currently this code does not support number 3 and 6.++1. Initiate Multipart Upload+2. Upload Part+3. Upload Part - Copy+4. Complete Multipart Upload+5. Abort Multipart Upload+6. List Parts++-}++data InitiateMultipartUpload+  = InitiateMultipartUpload {+      imuBucket :: Bucket+    , imuObjectName :: Object+    , imuCacheControl :: Maybe T.Text+    , imuContentDisposition :: Maybe T.Text+    , imuContentEncoding :: Maybe T.Text+    , imuContentType :: Maybe T.Text+    , imuExpires :: Maybe Int+    , imuMetadata :: [(T.Text,T.Text)]+    , imuStorageClass :: Maybe StorageClass+    , imuWebsiteRedirectLocation :: Maybe T.Text+    , imuAcl :: Maybe CannedAcl+    , imuServerSideEncryption :: Maybe ServerSideEncryption+    , imuAutoMakeBucket :: Bool -- ^ Internet Archive S3 nonstandard extension+    }+  deriving (Show)++postInitiateMultipartUpload :: Bucket -> T.Text -> InitiateMultipartUpload+postInitiateMultipartUpload b o =+  InitiateMultipartUpload+    b o+    Nothing Nothing Nothing Nothing Nothing+    [] Nothing Nothing Nothing Nothing+    False++data InitiateMultipartUploadResponse+  = InitiateMultipartUploadResponse {+      imurBucket   :: Bucket+    , imurKey      :: T.Text+    , imurUploadId :: T.Text+    }++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery InitiateMultipartUpload where+    type ServiceConfiguration InitiateMultipartUpload = S3Configuration+    signQuery InitiateMultipartUpload {..} = s3SignQuery S3Query {+        s3QMethod = Post+      , s3QBucket = Just $ T.encodeUtf8 imuBucket+      , s3QObject = Just $ T.encodeUtf8 $ imuObjectName+      , s3QSubresources = HTTP.toQuery[ ("uploads" :: B8.ByteString , Nothing :: Maybe B8.ByteString)]+      , s3QQuery = []+      , s3QContentType = T.encodeUtf8 <$> imuContentType+      , s3QContentMd5 = Nothing+      , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [+          ("x-amz-acl",) <$> writeCannedAcl <$> imuAcl+        , ("x-amz-storage-class",) <$> writeStorageClass <$> imuStorageClass+        , ("x-amz-website-redirect-location",) <$> imuWebsiteRedirectLocation+        , ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> imuServerSideEncryption+        , if imuAutoMakeBucket then Just ("x-amz-auto-make-bucket", "1")  else Nothing+        ] ++ map( \x -> (CI.mk . T.encodeUtf8 $ T.concat ["x-amz-meta-", fst x], snd x)) imuMetadata+      , s3QOtherHeaders = map (second T.encodeUtf8) $ catMaybes [+          ("Expires",) . T.pack . show <$> imuExpires+        , ("Cache-Control",) <$> imuCacheControl+        , ("Content-Disposition",) <$> imuContentDisposition+        , ("Content-Encoding",) <$> imuContentEncoding+        ]+      , s3QRequestBody = Nothing+      }++instance ResponseConsumer r InitiateMultipartUploadResponse where+    type ResponseMetadata InitiateMultipartUploadResponse = S3Metadata++    responseConsumer _ = s3XmlResponseConsumer parse+        where parse cursor+                  = do bucket <- force "Missing Bucket Name" $ cursor $/ elContent "Bucket"+                       key <- force "Missing Key" $ cursor $/ elContent "Key"+                       uploadId <- force "Missing UploadID" $ cursor $/ elContent "UploadId"+                       return InitiateMultipartUploadResponse{+                                                imurBucket         = bucket+                                              , imurKey            = key+                                              , imurUploadId       = uploadId+                                              }++instance Transaction InitiateMultipartUpload InitiateMultipartUploadResponse++instance AsMemoryResponse InitiateMultipartUploadResponse where+    type MemoryResponse InitiateMultipartUploadResponse = InitiateMultipartUploadResponse+    loadToMemory = return+++----------------------------------++++data UploadPart = UploadPart {+    upObjectName :: T.Text+  , upBucket :: Bucket+  , upPartNumber :: Integer+  , upUploadId :: T.Text+  , upContentType :: Maybe B8.ByteString+  , upContentMD5 :: Maybe (Digest MD5)+  , upServerSideEncryption :: Maybe ServerSideEncryption+  , upRequestBody  :: HTTP.RequestBody+}++uploadPart :: Bucket -> T.Text -> Integer -> T.Text -> HTTP.RequestBody -> UploadPart+uploadPart bucket obj p i body =+  UploadPart obj bucket p i+  Nothing Nothing Nothing body++data UploadPartResponse+  = UploadPartResponse {+      uprVersionId :: Maybe T.Text+    }+  deriving (Show)++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery UploadPart where+    type ServiceConfiguration UploadPart = S3Configuration+    signQuery UploadPart {..} = s3SignQuery S3Query {+                                 s3QMethod = Put+                               , s3QBucket = Just $ T.encodeUtf8 upBucket+                               , s3QObject = Just $ T.encodeUtf8 upObjectName+                               , s3QSubresources = HTTP.toQuery[+                                   ("partNumber" :: B8.ByteString , Just (T.pack (show upPartNumber)) :: Maybe T.Text)+                                 , ("uploadId" :: B8.ByteString, Just upUploadId :: Maybe T.Text)+                                 ]+                               , s3QQuery = []+                               , s3QContentType = upContentType+                               , s3QContentMd5 = upContentMD5+                               , s3QAmzHeaders = map (second T.encodeUtf8) $ catMaybes [+                                   ("x-amz-server-side-encryption",) <$> writeServerSideEncryption <$> upServerSideEncryption+                                 ]+                               , s3QOtherHeaders = []+                               , s3QRequestBody = Just upRequestBody+                               }++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)+      return $ UploadPartResponse vid++instance Transaction UploadPart UploadPartResponse++instance AsMemoryResponse UploadPartResponse where+    type MemoryResponse UploadPartResponse = UploadPartResponse+    loadToMemory = return++----------------------------++++data CompleteMultipartUpload+  = CompleteMultipartUpload {+      cmuBucket :: Bucket+    , cmuObjectName :: Object+    , cmuUploadId :: T.Text+    , cmuPartNumberAndEtags :: [(Integer,T.Text)]+    , cmuExpiration :: Maybe T.Text+    , cmuServerSideEncryption :: Maybe T.Text+    , cmuServerSideEncryptionCustomerAlgorithm :: Maybe T.Text+    , 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++data CompleteMultipartUploadResponse+  = CompleteMultipartUploadResponse {+      cmurLocation :: T.Text+    , cmurBucket   :: Bucket+    , cmurKey      :: T.Text+    , cmurETag     :: T.Text+    }++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery CompleteMultipartUpload where+    type ServiceConfiguration CompleteMultipartUpload = S3Configuration+    signQuery CompleteMultipartUpload {..} = s3SignQuery S3Query {+      s3QMethod = Post+      , s3QBucket = Just $ T.encodeUtf8 cmuBucket+      , s3QObject = Just $ T.encodeUtf8 cmuObjectName+      , s3QSubresources = HTTP.toQuery[+        ("uploadId" :: B8.ByteString, Just cmuUploadId :: Maybe T.Text)+        ]+      , s3QQuery = []+      , s3QContentType = Nothing+      , s3QContentMd5 = Nothing+      , s3QAmzHeaders = catMaybes [ ("x-amz-expiration",) <$> (T.encodeUtf8 <$> cmuExpiration)+                                  , ("x-amz-server-side-encryption",) <$> (T.encodeUtf8 <$> cmuServerSideEncryption)+                                  , ("x-amz-server-side-encryption-customer-algorithm",)+                                    <$> (T.encodeUtf8 <$> cmuServerSideEncryptionCustomerAlgorithm)+                                  , ("x-amz-version-id",) <$> (T.encodeUtf8 <$> cmuVersionId)+                                  ]+      , s3QOtherHeaders = []+      , s3QRequestBody  = Just $ HTTP.RequestBodyLBS reqBody+      }+        where reqBody = XML.renderLBS XML.def XML.Document {+                    XML.documentPrologue = XML.Prologue [] Nothing []+                  , XML.documentRoot = root+                  , XML.documentEpilogue = []+                  }+              root = XML.Element {+                    XML.elementName = "CompleteMultipartUpload"+                  , XML.elementAttributes = M.empty+                  , XML.elementNodes = (partNode <$> cmuPartNumberAndEtags)+                  }+              partNode (partNumber, etag) = XML.NodeElement XML.Element {+                    XML.elementName = "Part"+                  , XML.elementAttributes = M.empty+                  , XML.elementNodes = [keyNode (T.pack (show partNumber)),etagNode etag]+                  }+              etagNode = toNode "ETag"+              keyNode     = toNode "PartNumber"+              toNode name content = XML.NodeElement XML.Element {+                    XML.elementName = name+                  , XML.elementAttributes = M.empty+                  , XML.elementNodes = [XML.NodeContent content]+                  }++instance ResponseConsumer r CompleteMultipartUploadResponse where+    type ResponseMetadata CompleteMultipartUploadResponse = S3Metadata++    responseConsumer _ = s3XmlResponseConsumer parse+        where parse cursor+                  = do location <- force "Missing Location" $ cursor $/ elContent "Location"+                       bucket <- force "Missing Bucket Name" $ cursor $/ elContent "Bucket"+                       key <- force "Missing Key" $ cursor $/ elContent "Key"+                       etag <- force "Missing ETag" $ cursor $/ elContent "ETag"+                       return CompleteMultipartUploadResponse{+                                                cmurLocation       = location+                                              , cmurBucket         = bucket+                                              , cmurKey            = key+                                              , cmurETag           = etag+                                              }++instance Transaction CompleteMultipartUpload CompleteMultipartUploadResponse++instance AsMemoryResponse CompleteMultipartUploadResponse where+    type MemoryResponse CompleteMultipartUploadResponse = CompleteMultipartUploadResponse+    loadToMemory = return++----------------------------++++data AbortMultipartUpload+  = AbortMultipartUpload {+      amuBucket :: Bucket+    , amuObjectName :: Object+    , amuUploadId :: T.Text+    }+  deriving (Show)++postAbortMultipartUpload :: Bucket -> T.Text -> T.Text -> AbortMultipartUpload+postAbortMultipartUpload b o i = AbortMultipartUpload b o i++data AbortMultipartUploadResponse+  = AbortMultipartUploadResponse {+    }++-- | ServiceConfiguration: 'S3Configuration'+instance SignQuery AbortMultipartUpload where+    type ServiceConfiguration AbortMultipartUpload = S3Configuration+    signQuery AbortMultipartUpload {..} = s3SignQuery S3Query {+      s3QMethod = Delete+      , s3QBucket = Just $ T.encodeUtf8 amuBucket+      , s3QObject = Just $ T.encodeUtf8 amuObjectName+      , s3QSubresources = HTTP.toQuery[+        ("uploadId" :: B8.ByteString, Just amuUploadId :: Maybe T.Text)+        ]+      , s3QQuery = []+      , s3QContentType = Nothing+      , s3QContentMd5 = Nothing+      , s3QAmzHeaders = []+      , s3QOtherHeaders = []+      , s3QRequestBody = Nothing+      }++instance ResponseConsumer r AbortMultipartUploadResponse where+    type ResponseMetadata AbortMultipartUploadResponse = S3Metadata++    responseConsumer _ = s3XmlResponseConsumer parse+        where parse _cursor+                  = return AbortMultipartUploadResponse {}++instance Transaction AbortMultipartUpload AbortMultipartUploadResponse+++instance AsMemoryResponse AbortMultipartUploadResponse where+    type MemoryResponse AbortMultipartUploadResponse = AbortMultipartUploadResponse+    loadToMemory = return+++----------------------------++getUploadId ::+  Configuration+  -> S3Configuration NormalQuery+  -> HTTP.Manager+  -> T.Text+  -> T.Text+  -> ResourceT IO T.Text+getUploadId cfg s3cfg mgr bucket object = do+  InitiateMultipartUploadResponse {+      imurBucket = _bucket+    , imurKey = _object'+    , imurUploadId = uploadId+    } <- pureAws cfg s3cfg mgr $ postInitiateMultipartUpload bucket object+  return uploadId+++sendEtag  ::+  Configuration+  -> S3Configuration NormalQuery+  -> HTTP.Manager+  -> T.Text+  -> T.Text+  -> T.Text+  -> [String]+  -> ResourceT IO ()+sendEtag cfg s3cfg mgr bucket object uploadId etags = do+  _ <- pureAws cfg s3cfg mgr $+       postCompleteMultipartUpload bucket object uploadId (zip [1..] (map T.pack etags))+  return ()+++bstr2str :: B8.ByteString -> String+bstr2str bstr =+  foldr1 (++) $ map toHex $ B8.unpack bstr+  where+    toHex :: Char -> String+    toHex chr = printf "%02x" chr++putConduit ::+  MonadResource m =>+  Configuration+  -> S3Configuration NormalQuery+  -> HTTP.Manager+  -> T.Text+  -> T.Text+  -> T.Text+  -> Conduit B8.ByteString m String+putConduit cfg s3cfg mgr bucket object uploadId = loop 1+  where+    loop n = do+      v' <- await+      case v' of+        Just v -> do+          let str= (BL.fromStrict v)+          _ <- liftResourceT $ pureAws cfg s3cfg mgr $+            uploadPart bucket object n uploadId+            (HTTP.requestBodySource+             (BL.length str)+             (CB.sourceLbs str)+            )+          let etag= bstr2str $ MD5.hash v+          yield etag+          loop (n+1)+        Nothing -> return ()++chunkedConduit :: (MonadResource m) => Integer -> Conduit B8.ByteString m B8.ByteString+chunkedConduit size = do+  loop 0 ""+  where+    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 = B8.concat [str, line]+          if len >= (fromIntegral size)+            then do+            yield newStr+            loop 0 ""+            else+            loop len newStr++multipartUpload ::+  Configuration+  -> S3Configuration NormalQuery+  -> HTTP.Manager+  -> T.Text+  -> T.Text+  -> Conduit () (ResourceT IO) B8.ByteString+  -> Integer+  -> ResourceT IO ()+multipartUpload cfg s3cfg mgr bucket object src chunkSize = do+  uploadId <- getUploadId cfg s3cfg mgr bucket object+  etags <- src+           $= chunkedConduit chunkSize+           $= putConduit cfg s3cfg mgr bucket object uploadId+           $$ CL.consume+  sendEtag cfg s3cfg mgr bucket object uploadId etags

@@ -3,7 +3,10 @@     , SesMetadata(..)      , SesConfiguration(..)+    , sesEuWest1     , sesUsEast+    , sesUsEast1+    , sesUsWest2     , sesHttpsGet     , sesHttpsPost @@ -70,13 +73,22 @@  -- HTTP is not supported right now, always use HTTPS instance DefaultServiceConfiguration (SesConfiguration NormalQuery) where-    defServiceConfig = sesHttpsPost sesUsEast+    defServiceConfig = sesHttpsPost sesUsEast1  instance DefaultServiceConfiguration (SesConfiguration UriOnlyQuery) where-    defServiceConfig = sesHttpsGet sesUsEast+    defServiceConfig = sesHttpsGet sesUsEast1 +sesEuWest1 :: B.ByteString+sesEuWest1 = "email.eu-west-1.amazonaws.com"+ sesUsEast :: B.ByteString-sesUsEast = "email.us-east-1.amazonaws.com"+sesUsEast = sesUsEast1++sesUsEast1 :: B.ByteString+sesUsEast1 = "email.us-east-1.amazonaws.com"++sesUsWest2 :: B.ByteString+sesUsWest2 = "email.us-west-2.amazonaws.com"  sesHttpsGet :: B.ByteString -> SesConfiguration qt sesHttpsGet endpoint = SesConfiguration Get endpoint

@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++import qualified Aws+import qualified Aws.S3 as S3+import           Data.Conduit (($$+-))+import           Data.Conduit.Binary (sourceFile)+import qualified Data.Text as T+import           Network.HTTP.Conduit (withManager, responseBody)+import           System.Environment (getArgs)++main :: IO ()+main = do+  {- Set up AWS credentials and the default configuration. -}+  cfg <- Aws.baseConfiguration+  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)"

@@ -90,6 +90,15 @@  ** 0.10 series +- 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 

@@ -1,5 +1,5 @@ Name:                aws-Version:             0.10.3+Version:             0.10.4 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@@ -20,7 +20,7 @@ Source-repository this   type: git   location: https://github.com/aristidb/aws.git-  tag: 0.10.3+  tag: 0.10.4  Source-repository head   type: git@@ -76,6 +76,7 @@                        Aws.S3.Commands.HeadObject                        Aws.S3.Commands.PutBucket                        Aws.S3.Commands.PutObject+                       Aws.S3.Commands.Multipart                        Aws.S3.Core                        Aws.Ses                        Aws.Ses.Commands@@ -182,6 +183,24 @@    Default-Language: Haskell2010 +Executable MultipartUpload+  Main-is: MultipartUpload.hs+  Hs-source-dirs: Examples++  if !flag(Examples)+    Buildable: False+  else+    Buildable: True+    Build-depends:+                       base == 4.*,+                       aws,+                       http-conduit,+                       conduit,+                       conduit-extra,+                       text++  Default-Language: Haskell2010+ Executable NukeBucket   Main-is: NukeBucket.hs   Hs-source-dirs: Examples@@ -269,13 +288,50 @@         base == 4.*,         bytestring >= 0.10,         errors >= 1.4.7,+        http-client >= 0.3,+        lifted-base >= 0.2,+        monad-control >= 0.3,         mtl >= 2.1,         quickcheck-instances >= 0.3,+        resourcet >= 1.1,         tagged >= 0.7,         tasty >= 0.8,         tasty-quickcheck >= 0.8,         text >= 1.1,-        transformers >= 0.3+        time,+        transformers >= 0.3,+        transformers-base >= 0.4      ghc-options: -Wall -threaded++test-suite dynamodb-tests+    type: exitcode-stdio-1.0+    default-language: Haskell2010+    hs-source-dirs: tests+    main-is: DynamoDb/Main.hs++    other-modules:+        Utils+        DynamoDb.Utils++    build-depends:+        QuickCheck >= 2.7,+        aeson >= 0.7,+        aws,+        base == 4.*,+        bytestring >= 0.10,+        errors >= 1.4.7,+        http-client >= 0.3,+        lifted-base >= 0.2,+        monad-control >= 0.3,+        mtl >= 2.1,+        quickcheck-instances >= 0.3,+        resourcet >= 1.1,+        tagged >= 0.7,+        tasty >= 0.8,+        tasty-quickcheck >= 0.8,+        text >= 1.1,+        time,+        transformers >= 0.3,+        transformers-base >= 0.4 

@@ -0,0 +1,157 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module: Main+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: BSD3+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Tests for Haskell AWS DynamoDb bindings+--++module Main+( main+) where++import Aws+import qualified Aws.DynamoDb as DY++import Control.Arrow (second)+import Control.Error+import Control.Monad+import Control.Monad.IO.Class++import Data.IORef+import qualified Data.List as L+import qualified Data.Text as T++import qualified Network.HTTP.Client as HTTP++import Test.Tasty+import Test.QuickCheck.Instances ()++import System.Environment+import System.Exit++import Utils+import DynamoDb.Utils++-- -------------------------------------------------------------------------- --+-- Main++main :: IO ()+main = do+    args <- getArgs+    runMain args $ map (second tail . span (/= '=')) args+  where+    runMain :: [String] -> [(String,String)] -> IO ()+    runMain args _argsMap+        | any (`elem` helpArgs) args = defaultMain tests+        | "--run-with-aws-credentials" `elem` args =+            withArgs (tastyArgs args) . defaultMain $ tests+        | otherwise = putStrLn help >> exitFailure++    helpArgs = ["--help", "-h"]+    mainArgs =+        [ "--run-with-aws-credentials"+        ]+    tastyArgs args = flip filter args $ \x -> not+        $ any (`L.isPrefixOf` x) mainArgs+++help :: String+help = L.intercalate "\n"+    [ ""+    , "NOTE"+    , ""+    , "This test suite accesses the AWS account that is associated with"+    , "the default credentials from the credential file ~/.aws-keys."+    , ""+    , "By running the tests in this test-suite costs for usage of AWS"+    , "services may incur."+    , ""+    , "In order to actually excute the tests in this test-suite you must"+    , "provide the command line options:"+    , ""+    , "    --run-with-aws-credentials"+    , ""+    , "When running this test-suite through cabal you may use the following"+    , "command:"+    , ""+    , "    cabal test --test-option=--run-with-aws-credentials dynamodb-tests"+    , ""+    ]++tests :: TestTree+tests = testGroup "DynamoDb Tests"+    [ test_table+    -- , test_message+    , test_core+    ]++-- -------------------------------------------------------------------------- --+-- Table Tests++test_table :: TestTree+test_table = testGroup "Table Tests"+    [ eitherTOnceTest1 "CreateDescribeDeleteTable" (prop_createDescribeDeleteTable 10 10)+    ]++-- |+--+prop_createDescribeDeleteTable+    :: Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)+    -> Int -- ^ write capacity (#writes * itemsize/1KB)+    -> T.Text -- ^ table name+    -> EitherT 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+        retryT 6 . void . simpleDyT $ DY.DescribeTable tTableName+        deleteTable++-- -------------------------------------------------------------------------- --+-- Test core functionality++test_core :: TestTree+test_core = testGroup "Core Tests"+        [ eitherTOnceTest0 "connectionReuse" prop_connectionReuse+        ]++prop_connectionReuse+    :: EitherT T.Text IO ()+prop_connectionReuse = do+    c <- liftIO $ do+        cfg <- baseConfiguration++        -- counts the number of TCP connections+        ref <- newIORef (0 :: Int)++        void . HTTP.withManager (managerSettings ref) $ \manager -> runEitherT $+            handleT (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"+  where+    managerSettings ref = HTTP.defaultManagerSettings+        { HTTP.managerRawConnection = do+            mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings+            return $ \a b c -> do+                atomicModifyIORef ref $ \i -> (succ i, ())+                mkConn a b c+        }+

@@ -0,0 +1,167 @@+-- ------------------------------------------------------ --+-- Copyright © 2014 AlephCloud Systems, Inc.+-- ------------------------------------------------------ --++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module: DynamoDb.Utils+-- Copyright: Copyright © 2014 AlephCloud Systems, Inc.+-- License: BSD3+-- Maintainer: Lars Kuhtz <lars@alephcloud.com>+-- Stability: experimental+--+-- Tests for Haskell SQS bindings+--++module DynamoDb.Utils+(+-- * Static Parameters+  testProtocol+, testRegion+, defaultTableName++-- * Static Configuration+, dyConfiguration++-- * DynamoDb Utils+, simpleDy+, simpleDyT+, dyT+, withTable+, withTable_+, createTestTable+) where++import Aws+import Aws.Core+import qualified Aws.DynamoDb as DY++import Control.Error+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource++import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.IO as T++import qualified Network.HTTP.Client as HTTP++import Test.Tasty+import Test.QuickCheck.Instances ()++import System.IO++import Utils++-- -------------------------------------------------------------------------- --+-- Static Test parameters+--+-- TODO make these configurable++testProtocol :: Protocol+testProtocol = HTTP++testRegion :: DY.Region+testRegion = DY.ddbUsWest2++defaultTableName :: T.Text+defaultTableName = "test-table"++-- -------------------------------------------------------------------------- --+-- Dynamo Utils++dyConfiguration :: DY.DdbConfiguration qt+dyConfiguration = DY.DdbConfiguration+    { DY.ddbcRegion = testRegion+    , DY.ddbcProtocol = testProtocol+    , DY.ddbcPort = Nothing+    }++simpleDy+    :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadIO m)+    => r+    -> m (MemoryResponse a)+simpleDy command = do+    c <- dbgConfiguration+    simpleAws c dyConfiguration command++simpleDyT+    :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration, MonadBaseControl IO m, MonadIO m)+    => r+    -> EitherT T.Text m (MemoryResponse a)+simpleDyT = tryT . simpleDy++dyT+    :: (Transaction r a, ServiceConfiguration r ~ DY.DdbConfiguration)+    => Configuration+    -> HTTP.Manager+    -> r+    -> EitherT T.Text IO a+dyT cfg manager req = do+    Response _ r <- liftIO . runResourceT $ aws cfg dyConfiguration manager req+    hoistEither $ fmapL sshow r++withTable+    :: T.Text -- ^ table Name+    -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)+    -> Int -- ^ write capacity (#writes * itemsize/1KB)+    -> (T.Text -> IO a) -- ^ test tree+    -> IO a+withTable = withTable_ True++withTable_+    :: Bool -- ^ whether to prefix te table name+    -> T.Text -- ^ table Name+    -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)+    -> Int -- ^ write capacity (#writes * itemsize/1KB)+    -> (T.Text -> IO a) -- ^ test tree+    -> IO a+withTable_ prefix tableName readCapacity writeCapacity f =+    do+      tTableName <- if prefix then testData tableName else return tableName++      let deleteTable = do+            r <- runEitherT . retryT 6 $+                void (simpleDyT $ DY.DeleteTable tTableName) `catchT` \e ->+                    liftIO . T.hPutStrLn stderr $ "attempt to delete table failed: " <> e+            either (error . T.unpack) (const $ return ()) r++      let createTable = do+            r <- runEitherT $ 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"+            either (error . T.unpack) return r++      bracket_ createTable deleteTable $ f tTableName++createTestTable+    :: T.Text -- ^ table Name+    -> Int -- ^ read capacity (#(non-consistent) reads * itemsize/4KB)+    -> Int -- ^ write capacity (#writes * itemsize/1KB)+    -> IO ()+createTestTable tableName readCapacity writeCapacity = void . simpleDy $+    DY.createTable+        tableName+        attrs+        (DY.HashOnly keyName)+        throughPut+  where+    keyName = "Id"+    keyType = DY.AttrString+    attrs = [DY.AttributeDefinition keyName keyType]+    throughPut = DY.ProvisionedThroughput+        { DY.readCapacityUnits = readCapacity+        , DY.writeCapacityUnits = writeCapacity+        }++

@@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}  -- | -- Module: Main@@ -29,11 +30,16 @@ import Control.Error import Control.Monad import Control.Monad.IO.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource +import Data.IORef import qualified Data.List as L import Data.Monoid import qualified Data.Text as T +import qualified Network.HTTP.Client as HTTP+ import Test.Tasty import Test.QuickCheck.Instances () @@ -84,14 +90,15 @@     , "When running this test-suite through cabal you may use the following"     , "command:"     , ""-    , "    cabal test sqs-tests --test-option=--run-with-aws-credentials"+    , "    cabal test --test-option=--run-with-aws-credentials sqs-tests"     , ""     ]  tests :: TestTree-tests = testGroup "SQS Tests"+tests = withQueueTest defaultQueueName $ \getQueueParams -> testGroup "SQS Tests"     [ test_queue-    , test_message+    , test_message getQueueParams+    , test_core getQueueParams     ]  -- -------------------------------------------------------------------------- --@@ -129,6 +136,16 @@     , SQS.sqsDefaultExpiry = 180     } +sqsT+    :: (Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration)+    => Configuration+    -> HTTP.Manager+    -> r+    -> EitherT T.Text IO a+sqsT cfg manager req = do+    Response _ r <- liftIO . runResourceT $ aws cfg sqsConfiguration manager req+    hoistEither $ fmapL sshow r+ simpleSqs     :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadIO m)     => r@@ -138,7 +155,7 @@     simpleAws c sqsConfiguration command  simpleSqsT-    :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadIO m)+    :: (AsMemoryResponse a, Transaction r a, ServiceConfiguration r ~ SQS.SqsConfiguration, MonadBaseControl IO m, MonadIO m)     => r     -> EitherT T.Text m (MemoryResponse a) simpleSqsT = tryT . simpleSqs@@ -171,6 +188,7 @@     :: T.Text -- ^ queue name     -> EitherT 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@@ -180,25 +198,23 @@                 . left $ "queue " <> sshow queueUrl <> " not listed"         deleteQueue queue   where-    tQueueName = testData queueName     deleteQueue queueUrl = void $ simpleSqsT (SQS.DeleteQueue queueUrl)  -- -------------------------------------------------------------------------- -- -- Message Tests -test_message :: TestTree-test_message =-    withQueueTest defaultQueueName $ \getQueueParams -> testGroup "Queue Tests"-        [ eitherTOnceTest0 "SendReceiveDeleteMessage" $ do-            (_, queue) <- liftIO getQueueParams-            prop_sendReceiveDeleteMessage queue-        , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling" $ do-            (_, queue) <- liftIO getQueueParams-            prop_sendReceiveDeleteMessageLongPolling queue-        , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling1" $ do-            (_, queue) <- liftIO getQueueParams-            prop_sendReceiveDeleteMessageLongPolling1 queue-        ]+test_message :: IO (T.Text, SQS.QueueName) -> TestTree+test_message getQueueParams = testGroup "Queue Tests"+    [ eitherTOnceTest0 "SendReceiveDeleteMessage" $ do+        (_, queue) <- liftIO getQueueParams+        prop_sendReceiveDeleteMessage queue+    , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling" $ do+        (_, queue) <- liftIO getQueueParams+        prop_sendReceiveDeleteMessageLongPolling queue+    , eitherTOnceTest0 "SendReceiveDeleteMessageLongPolling1" $ do+        (_, queue) <- liftIO getQueueParams+        prop_sendReceiveDeleteMessageLongPolling1 queue+    ]  -- | Simple send and short-polling receive. First sends all messages -- and receives messages thereafter one by one.@@ -314,3 +330,50 @@     unless (sent == recv)         $ left $ "received messages don't match send messages; sent: "             <> sshow sent <> "; got: " <> sshow recv+++-- -------------------------------------------------------------------------- --+-- Test core functionality++test_core :: IO (T.Text, SQS.QueueName) -> TestTree+test_core getQueueParams = testGroup "Core Tests"+    [ eitherTOnceTest0 "connectionReuse" $ do+        (_, queue) <- liftIO getQueueParams+        prop_connectionReuse queue+    ]++prop_connectionReuse+    :: SQS.QueueName+    -> EitherT T.Text IO ()+prop_connectionReuse queue = do+    c <- liftIO $ do+        cfg <- baseConfiguration++        -- used for counting the number of TCP connections+        ref <- newIORef (0 :: Int)++        -- Use a single manager for all HTTP requests+        void . HTTP.withManager (managerSettings ref) $ \manager -> runEitherT $++            handleT (error . T.unpack) . replicateM_ 3 $ do+                void . sqsT cfg manager $ SQS.ListQueues Nothing+                mustFail . sqsT cfg manager $+                    SQS.SendMessage "" (SQS.QueueName "" "") [] Nothing+                void . sqsT cfg manager $+                    SQS.SendMessage "test-message" queue [] Nothing+                void . sqsT cfg manager $+                    SQS.ReceiveMessage Nothing [] Nothing [] queue (Just 20)++        readIORef ref+    unless (c == 1) $+        left "The TCP connection has not been reused"+  where++    managerSettings ref = HTTP.defaultManagerSettings+        { HTTP.managerRawConnection = do+            mkConn <- HTTP.managerRawConnection HTTP.defaultManagerSettings+            return $ \a b c -> do+                atomicModifyIORef ref $ \i -> (succ i, ())+                mkConn a b c+        }+

@@ -2,6 +2,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}  -- | -- Module: Utils@@ -19,8 +21,10 @@  -- * General Utils , sshow+, mustFail , tryT , retryT+, retryT_ , testData  , evalTestT@@ -34,17 +38,23 @@ , prop_jsonRoundtrip ) where +import Control.Applicative import Control.Concurrent (threadDelay)-import Control.Error+import qualified Control.Exception.Lifted as LE+import Control.Error hiding (syncIO) import Control.Monad import Control.Monad.Identity import Control.Monad.IO.Class+import Control.Monad.Base+import Control.Monad.Trans.Control  import 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+import qualified Data.Text.IO as T import Data.Typeable  import Test.QuickCheck.Property@@ -52,6 +62,11 @@ import Test.Tasty import Test.Tasty.QuickCheck +import System.Exit (ExitCode)+import System.IO (stderr)++import Data.Time.Clock.POSIX (getPOSIXTime)+ -- -------------------------------------------------------------------------- -- -- Static Test parameters --@@ -59,29 +74,68 @@ -- | This prefix is used for the IDs and names of all entities that are -- created in the AWS account. ---testDataPrefix :: IsString a => a-testDataPrefix = "__TEST_AWSHASKELLBINDINGS__"+testDataPrefix :: IsString a => MonadBase IO m => m a+testDataPrefix = do+    t <- liftBase $ getPOSIXTime+    let t' :: Int+        t' = floor (t * 1000)+    return . fromString $ "__TEST_AWSHASKELLBINDINGS__" ++ show t'  -- -------------------------------------------------------------------------- -- -- General Utils -tryT :: MonadIO m => IO a -> EitherT T.Text m a+-- | Catches all exceptions except for asynchronous exceptions found in base.+--+tryT :: MonadBaseControl IO m => m a -> EitherT T.Text m a tryT = fmapLT (T.pack . show) . syncIO -testData :: (IsString a, Monoid a) => a -> a-testData a = testDataPrefix <> a+-- | 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)+    [ LE.Handler $ \e -> LE.throw (e :: LE.ArithException)+    , LE.Handler $ \e -> LE.throw (e :: LE.ArrayException)+    , LE.Handler $ \e -> LE.throw (e :: LE.AssertionFailed)+    , LE.Handler $ \e -> LE.throw (e :: LE.AsyncException)+    , LE.Handler $ \e -> LE.throw (e :: LE.BlockedIndefinitelyOnMVar)+    , LE.Handler $ \e -> LE.throw (e :: LE.BlockedIndefinitelyOnSTM)+    , LE.Handler $ \e -> LE.throw (e :: LE.Deadlock)+    , LE.Handler $ \e -> LE.throw (e ::    Dynamic)+    , LE.Handler $ \e -> LE.throw (e :: LE.ErrorCall)+    , LE.Handler $ \e -> LE.throw (e ::    ExitCode)+    , LE.Handler $ \e -> LE.throw (e :: LE.NestedAtomically)+    , LE.Handler $ \e -> LE.throw (e :: LE.NoMethodError)+    , LE.Handler $ \e -> LE.throw (e :: LE.NonTermination)+    , LE.Handler $ \e -> LE.throw (e :: LE.PatternMatchFail)+    , LE.Handler $ \e -> LE.throw (e :: LE.RecConError)+    , LE.Handler $ \e -> LE.throw (e :: LE.RecSelError)+    , LE.Handler $ \e -> LE.throw (e :: LE.RecUpdError)+    , LE.Handler $ return . Left+    ] +testData :: (IsString a, Monoid a, MonadBaseControl IO m) => a -> m a+testData a = fmap (<> a) testDataPrefix+ retryT :: MonadIO m => Int -> EitherT T.Text m a -> EitherT T.Text m a-retryT i f = go 1+retryT n f = snd <$> retryT_ n f++retryT_ :: MonadIO m => Int -> EitherT T.Text m a -> EitherT T.Text m (Int, a)+retryT_ n f = go 1   where     go x-        | x >= i = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) f-        | otherwise = f `catchT` \_ -> do+        | x >= n = fmapLT (\e -> "error after " <> sshow x <> " retries: " <> e) ((x,) <$> f)+        | otherwise = ((x,) <$> f) `catchT` \e -> do+            liftIO $ T.hPutStrLn stderr $ "Retrying after error: " <> e             liftIO $ threadDelay (1000000 * min 60 (2^(x-1)))             go (succ x)  sshow :: (Show a, IsString b) => a -> b sshow = fromString . show++mustFail :: Monad m => EitherT e m a -> EitherT T.Text m ()+mustFail = EitherT . eitherT+    (const . return $ Right ())+    (const . return $ Left "operation succeeded when a failure was expected")  evalTestTM     :: Functor f