diff --git a/Aws/Aws.hs b/Aws/Aws.hs --- a/Aws/Aws.hs +++ b/Aws/Aws.hs @@ -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 diff --git a/Aws/DynamoDb/Commands/Table.hs b/Aws/DynamoDb/Commands/Table.hs --- a/Aws/DynamoDb/Commands/Table.hs +++ b/Aws/DynamoDb/Commands/Table.hs @@ -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 diff --git a/Aws/DynamoDb/Core.hs b/Aws/DynamoDb/Core.hs --- a/Aws/DynamoDb/Core.hs +++ b/Aws/DynamoDb/Core.hs @@ -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 diff --git a/Aws/S3/Commands.hs b/Aws/S3/Commands.hs --- a/Aws/S3/Commands.hs +++ b/Aws/S3/Commands.hs @@ -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 diff --git a/Aws/S3/Commands/Multipart.hs b/Aws/S3/Commands/Multipart.hs new file mode 100644 --- /dev/null +++ b/Aws/S3/Commands/Multipart.hs @@ -0,0 +1,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 diff --git a/Aws/Ses/Core.hs b/Aws/Ses/Core.hs --- a/Aws/Ses/Core.hs +++ b/Aws/Ses/Core.hs @@ -3,7 +3,10 @@ , SesMetadata(..) , SesConfiguration(..) + , sesEuWest1 , sesUsEast + , sesUsEast1 + , sesUsWest2 , sesHttpsGet , sesHttpsPost @@ -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 diff --git a/Examples/MultipartUpload.hs b/Examples/MultipartUpload.hs new file mode 100644 --- /dev/null +++ b/Examples/MultipartUpload.hs @@ -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)" diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -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 diff --git a/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -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 . 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 diff --git a/tests/DynamoDb/Main.hs b/tests/DynamoDb/Main.hs new file mode 100644 --- /dev/null +++ b/tests/DynamoDb/Main.hs @@ -0,0 +1,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 +-- 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 + } + diff --git a/tests/DynamoDb/Utils.hs b/tests/DynamoDb/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/DynamoDb/Utils.hs @@ -0,0 +1,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 +-- 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 + } + + diff --git a/tests/Sqs/Main.hs b/tests/Sqs/Main.hs --- a/tests/Sqs/Main.hs +++ b/tests/Sqs/Main.hs @@ -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 + } + diff --git a/tests/Utils.hs b/tests/Utils.hs --- a/tests/Utils.hs +++ b/tests/Utils.hs @@ -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