From 0fc264bbc221507d728348b9900aa08f2e6b4d31 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Tue, 26 Feb 2019 15:45:36 -0800 Subject: [PATCH] Fix region setting in presigned url functions (#107) - Also split out live server tests into individual functions --- src/Network/Minio/PresignedOperations.hs | 15 +- test/LiveServer.hs | 687 ++++++++++++----------- 2 files changed, 360 insertions(+), 342 deletions(-) diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs index 92a9c80..9db7825 100644 --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -107,9 +107,10 @@ makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do -- object REST API AWS S3 documentation. presignedPutObjectUrl :: Bucket -> Object -> UrlExpiry -> HT.RequestHeaders -> Minio ByteString -presignedPutObjectUrl bucket object expirySeconds extraHeaders = +presignedPutObjectUrl bucket object expirySeconds extraHeaders = do + region <- asks (Just . connectRegion . mcConnInfo) makePresignedUrl expirySeconds HT.methodPut - (Just bucket) (Just object) Nothing [] extraHeaders + (Just bucket) (Just object) region [] extraHeaders -- | Generate a URL with authentication signature to GET (download) an -- object. All extra query parameters and headers passed here will be @@ -122,9 +123,10 @@ presignedPutObjectUrl bucket object expirySeconds extraHeaders = -- to the GET object REST API AWS S3 documentation. presignedGetObjectUrl :: Bucket -> Object -> UrlExpiry -> HT.Query -> HT.RequestHeaders -> Minio ByteString -presignedGetObjectUrl bucket object expirySeconds extraQuery extraHeaders = +presignedGetObjectUrl bucket object expirySeconds extraQuery extraHeaders = do + region <- asks (Just . connectRegion . mcConnInfo) makePresignedUrl expirySeconds HT.methodGet - (Just bucket) (Just object) Nothing extraQuery extraHeaders + (Just bucket) (Just object) region extraQuery extraHeaders -- | Generate a URL with authentication signature to make a HEAD -- request on an object. This is used to fetch metadata about an @@ -135,9 +137,10 @@ presignedGetObjectUrl bucket object expirySeconds extraQuery extraHeaders = -- object REST API AWS S3 documentation. presignedHeadObjectUrl :: Bucket -> Object -> UrlExpiry -> HT.RequestHeaders -> Minio ByteString -presignedHeadObjectUrl bucket object expirySeconds extraHeaders = +presignedHeadObjectUrl bucket object expirySeconds extraHeaders = do + region <- asks (Just . connectRegion . mcConnInfo) makePresignedUrl expirySeconds HT.methodHead - (Just bucket) (Just object) Nothing [] extraHeaders + (Just bucket) (Just object) region [] extraHeaders -- | Represents individual conditions in a Post Policy document. data PostPolicyCondition = PPCStartsWith Text Text diff --git a/test/LiveServer.hs b/test/LiveServer.hs index bca38fd..139eea7 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -308,357 +308,113 @@ liveServerUnitTests = testGroup "Unit tests against a live server" , lowLevelMultipartTest , putObjectSizeTest , putObjectNoSizeTest - , funTestWithBucket "Multipart Tests" $ - \step bucket -> do - step "Prepare for putObjectInternal with non-seekable file, with size." - step "Upload multipart file." - let mb80 = 80 * 1024 * 1024 - obj = "mpart" - - void $ putObjectInternal bucket obj defaultPutObjectOptions $ ODFile "/dev/zero" (Just mb80) - - step "Retrieve and verify file size" - destFile <- mkRandFile 0 - fGetObject bucket obj destFile defaultGetObjectOptions - gotSize <- withNewHandle destFile getFileSize - liftIO $ gotSize == Right (Just mb80) @? - "Wrong file size of put file after getting" - - step "Cleanup actions" - removeObject bucket obj - - step "cleanup" - removeObject bucket "big" - - step "Prepare for removeIncompleteUpload" - -- low-level multipart operation tests. - let object = "newmpupload" - kb5 = 5 * 1024 - - step "create new multipart upload" - uid <- newMultipartUpload bucket object [] - liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id." - - randFile <- mkRandFile kb5 - - step "upload 2 parts" - forM_ [1,2] $ \partNum -> do - h <- liftIO $ SIO.openBinaryFile randFile SIO.ReadMode - void $ putObjectPart bucket object uid partNum [] $ PayloadH h 0 kb5 - - step "remove ongoing upload" - removeIncompleteUpload bucket object - uploads <- C.runConduit $ listIncompleteUploads bucket (Just object) False - C..| sinkList - liftIO $ (null uploads) @? "removeIncompleteUploads didn't complete successfully" - - , funTestWithBucket "putObject contentType tests" $ \step bucket -> do - step "fPutObject content type test" - let object = "xxx-content-type" - size1 = 100 :: Int64 - - step "create server object with content-type" - inputFile <- mkRandFile size1 - fPutObject bucket object inputFile defaultPutObjectOptions { - pooContentType = Just "application/javascript" - } - - -- retrieve obj info to check - oi <- headObject bucket object - let m = oiMetadata oi - - step "Validate content-type" - liftIO $ assertEqual "Content-Type did not match" (Just "application/javascript") (Map.lookup "Content-Type" m) - - step "upload object with content-encoding set to identity" - fPutObject bucket object inputFile defaultPutObjectOptions { - pooContentEncoding = Just "identity" - } - - oiCE <- headObject bucket object - let m' = oiMetadata oiCE - - step "Validate content-encoding" - liftIO $ assertEqual "Content-Encoding did not match" (Just "identity") - (Map.lookup "Content-Encoding" m') - - step "Cleanup actions" - - removeObject bucket object - - , funTestWithBucket "putObject contentLanguage tests" $ \step bucket -> do - step "fPutObject content language test" - let object = "xxx-content-language" - size1 = 100 :: Int64 - - step "create server object with content-language" - inputFile <- mkRandFile size1 - fPutObject bucket object inputFile defaultPutObjectOptions { - pooContentLanguage = Just "en-US" - } - - -- retrieve obj info to check - oi <- headObject bucket object - let m = oiMetadata oi - - step "Validate content-language" - liftIO $ assertEqual "content-language did not match" (Just "en-US") - (Map.lookup "Content-Language" m) - step "Cleanup actions" - - removeObject bucket object - - , funTestWithBucket "putObject storageClass tests" $ \step bucket -> do - step "fPutObject storage class test" - let object = "xxx-storage-class-standard" - object' = "xxx-storage-class-reduced" - object'' = "xxx-storage-class-invalid" - size1 = 100 :: Int64 - size0 = 0 :: Int64 - - step "create server objects with storageClass" - inputFile <- mkRandFile size1 - inputFile' <- mkRandFile size1 - inputFile'' <- mkRandFile size0 - - fPutObject bucket object inputFile defaultPutObjectOptions { - pooStorageClass = Just "STANDARD" - } - - fPutObject bucket object' inputFile' defaultPutObjectOptions { - pooStorageClass = Just "REDUCED_REDUNDANCY" - } - - removeObject bucket object - - -- retrieve obj info to check - oi' <- headObject bucket object' - let m' = oiMetadata oi' - - step "Validate x-amz-storage-class rrs" - liftIO $ assertEqual "storageClass did not match" (Just "REDUCED_REDUNDANCY") - (Map.lookup "X-Amz-Storage-Class" m') - - fpE <- try $ fPutObject bucket object'' inputFile'' defaultPutObjectOptions { - pooStorageClass = Just "INVALID_STORAGE_CLASS" - } - case fpE of - Left exn -> liftIO $ exn @?= ServiceErr "InvalidStorageClass" "Invalid storage class." - _ -> return () - - step "Cleanup actions" - - removeObject bucket object' - - , funTestWithBucket "copyObject related tests" $ \step bucket -> do - step "copyObjectSingle basic tests" - let object = "xxx" - objCopy = "xxxCopy" - size1 = 100 :: Int64 - - step "create server object to copy" - inputFile <- mkRandFile size1 - fPutObject bucket object inputFile defaultPutObjectOptions - - step "copy object" - let srcInfo = defaultSourceInfo { srcBucket = bucket, srcObject = object} - (etag, modTime) <- copyObjectSingle bucket objCopy srcInfo [] - - -- retrieve obj info to check - oi <- headObject bucket objCopy - let t = oiModTime oi - let e = oiETag oi - let s = oiSize oi - - let isMTimeDiffOk = abs (diffUTCTime modTime t) < 1.0 - - liftIO $ (s == size1 && e == etag && isMTimeDiffOk) @? - "Copied object did not match expected." - - step "cleanup actions" - removeObject bucket object - removeObject bucket objCopy - - step "copyObjectPart basic tests" - let srcObj = "XXX" - copyObj = "XXXCopy" - - step "Prepare" - let mb15 = 15 * 1024 * 1024 - mb5 = 5 * 1024 * 1024 - randFile <- mkRandFile mb15 - fPutObject bucket srcObj randFile defaultPutObjectOptions - - step "create new multipart upload" - uid <- newMultipartUpload bucket copyObj [] - liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id." - - step "put object parts 1-3" - let srcInfo' = defaultSourceInfo { srcBucket = bucket, srcObject = srcObj } - dstInfo' = defaultDestinationInfo { dstBucket = bucket, dstObject = copyObj } - parts <- forM [1..3] $ \p -> do - (etag', _) <- copyObjectPart dstInfo' srcInfo'{ - srcRange = Just $ (,) ((p-1)*mb5) ((p-1)*mb5 + (mb5 - 1)) - } uid (fromIntegral p) [] - return (fromIntegral p, etag') - - step "complete multipart" - void $ completeMultipartUpload bucket copyObj uid parts - - step "verify copied object size" - oi' <- headObject bucket copyObj - let s' = oiSize oi' - - liftIO $ (s' == mb15) @? "Size failed to match" - - step "Cleanup actions" - removeObject bucket srcObj - removeObject bucket copyObj - - step "copyObject basic tests" - let srcs = ["XXX", "XXXL"] - copyObjs = ["XXXCopy", "XXXLCopy"] - sizes = map (* (1024 * 1024)) [15, 65] - - step "Prepare" - forM_ (zip srcs sizes) $ \(src, size) -> do - inputFile' <- mkRandFile size - fPutObject bucket src inputFile' defaultPutObjectOptions - - step "make small and large object copy" - forM_ (zip copyObjs srcs) $ \(cp, src) -> - copyObject defaultDestinationInfo {dstBucket = bucket, dstObject = cp} defaultSourceInfo {srcBucket = bucket, srcObject = src} - - step "verify uploaded objects" - uploadedSizes <- fmap oiSize <$> forM copyObjs (headObject bucket) - - liftIO $ (sizes == uploadedSizes) @? "Uploaded obj sizes failed to match" - - forM_ (srcs ++ copyObjs) (removeObject bucket) - - step "copyObject with offset test " - let src = "XXX" - size = 15 * 1024 * 1024 - - step "Prepare" - inputFile' <- mkRandFile size - fPutObject bucket src inputFile' defaultPutObjectOptions - - step "copy last 10MiB of object" - copyObject defaultDestinationInfo { dstBucket = bucket, dstObject = copyObj } defaultSourceInfo { - srcBucket = bucket - , srcObject = src - , srcRange = Just $ (,) (5 * 1024 * 1024) (size - 1) - } - - step "verify uploaded object" - cSize <- oiSize <$> headObject bucket copyObj - - liftIO $ (cSize == 10 * 1024 * 1024) @? "Uploaded obj size mismatched!" - - forM_ [src, copyObj] (removeObject bucket) - + , multipartTest + , putObjectContentTypeTest + , putObjectContentLanguageTest + , putObjectStorageClassTest + , copyObjectTests , presignedUrlFunTest , presignedPostPolicyFunTest , bucketPolicyFunTest ] basicTests :: TestTree -basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do - step "getService works and contains the test bucket." - buckets <- getService - unless (length (filter (== bucket) $ map biName buckets) == 1) $ - liftIO $ - assertFailure ("The bucket " ++ show bucket ++ - " was expected to exist.") +basicTests = funTestWithBucket "Basic tests" $ + \step bucket -> do + step "getService works and contains the test bucket." + buckets <- getService + unless (length (filter (== bucket) $ map biName buckets) == 1) $ + liftIO $ + assertFailure ("The bucket " ++ show bucket ++ + " was expected to exist.") - step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised." - mbE <- try $ makeBucket bucket Nothing - case mbE of - Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou + step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised." + mbE <- try $ makeBucket bucket Nothing + case mbE of + Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou + _ -> return () + + step "makeBucket with an invalid bucket name and check for appropriate exception." + invalidMBE <- try $ makeBucket "invalidBucketName" Nothing + case invalidMBE of + Left exn -> liftIO $ exn @?= MErrVInvalidBucketName "invalidBucketName" + _ -> return () + + step "getLocation works" + region <- getLocation bucket + liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region) + + step "singlepart putObject works" + fPutObject bucket "lsb-release" "/etc/lsb-release" defaultPutObjectOptions + + step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception" + fpE <- try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" defaultPutObjectOptions + case fpE of + Left exn -> liftIO $ exn @?= NoSuchBucket + _ -> return () + + outFile <- mkRandFile 0 + step "simple fGetObject works" + fGetObject bucket "lsb-release" outFile defaultGetObjectOptions + + let unmodifiedTime = UTCTime (fromGregorian 2010 11 26) 69857 + step "fGetObject an object which is modified now but requesting as un-modified in past, check for exception" + resE <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions { + gooIfUnmodifiedSince = (Just unmodifiedTime) + } + case resE of + Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold" + _ -> return () + + step "fGetObject an object with no matching etag, check for exception" + resE1 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions { + gooIfMatch = (Just "invalid-etag") + } + case resE1 of + Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold" + _ -> return () + + step "fGetObject an object with no valid range, check for exception" + resE2 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions { + gooRange = (Just $ HT.ByteRangeFromTo 100 200) + } + case resE2 of + Left exn -> liftIO $ exn @?= ServiceErr "InvalidRange" "The requested range is not satisfiable" _ -> return () - step "makeBucket with an invalid bucket name and check for appropriate exception." - invalidMBE <- try $ makeBucket "invalidBucketName" Nothing - case invalidMBE of - Left exn -> liftIO $ exn @?= MErrVInvalidBucketName "invalidBucketName" - _ -> return () + step "fGetObject on object with a valid range" + fGetObject bucket "lsb-release" outFile defaultGetObjectOptions { + gooRange = (Just $ HT.ByteRangeFrom 1) + } - step "getLocation works" - region <- getLocation bucket - liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region) + step "fGetObject a non-existent object and check for NoSuchKey exception" + resE3 <- try $ fGetObject bucket "noSuchKey" outFile defaultGetObjectOptions + case resE3 of + Left exn -> liftIO $ exn @?= NoSuchKey + _ -> return () - step "singlepart putObject works" - fPutObject bucket "lsb-release" "/etc/lsb-release" defaultPutObjectOptions + step "create new multipart upload works" + uid <- newMultipartUpload bucket "newmpupload" [] + liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") - step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception" - fpE <- try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" defaultPutObjectOptions - case fpE of - Left exn -> liftIO $ exn @?= NoSuchBucket - _ -> return () + step "abort a new multipart upload works" + abortMultipartUpload bucket "newmpupload" uid - outFile <- mkRandFile 0 - step "simple fGetObject works" - fGetObject bucket "lsb-release" outFile defaultGetObjectOptions + step "delete object works" + deleteObject bucket "lsb-release" - let unmodifiedTime = UTCTime (fromGregorian 2010 11 26) 69857 - step "fGetObject an object which is modified now but requesting as un-modified in past, check for exception" - resE <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions { - gooIfUnmodifiedSince = (Just unmodifiedTime) - } - case resE of - Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold" - _ -> return () + step "statObject test" + let object = "sample" + step "create an object" + inputFile <- mkRandFile 0 + fPutObject bucket object inputFile defaultPutObjectOptions - step "fGetObject an object with no matching etag, check for exception" - resE1 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions { - gooIfMatch = (Just "invalid-etag") - } - case resE1 of - Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold" - _ -> return () + step "get metadata of the object" + res <- statObject bucket object + liftIO $ (oiSize res) @?= 0 - step "fGetObject an object with no valid range, check for exception" - resE2 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions { - gooRange = (Just $ HT.ByteRangeFromTo 100 200) - } - case resE2 of - Left exn -> liftIO $ exn @?= ServiceErr "InvalidRange" "The requested range is not satisfiable" - _ -> return () - - step "fGetObject on object with a valid range" - fGetObject bucket "lsb-release" outFile defaultGetObjectOptions { - gooRange = (Just $ HT.ByteRangeFrom 1) - } - - step "fGetObject a non-existent object and check for NoSuchKey exception" - resE3 <- try $ fGetObject bucket "noSuchKey" outFile defaultGetObjectOptions - case resE3 of - Left exn -> liftIO $ exn @?= NoSuchKey - _ -> return () - - step "create new multipart upload works" - uid <- newMultipartUpload bucket "newmpupload" [] - liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") - - step "abort a new multipart upload works" - abortMultipartUpload bucket "newmpupload" uid - - step "delete object works" - deleteObject bucket "lsb-release" - - step "statObject test" - let object = "sample" - step "create an object" - inputFile <- mkRandFile 0 - fPutObject bucket object inputFile defaultPutObjectOptions - - step "get metadata of the object" - res <- statObject bucket object - liftIO $ (oiSize res) @?= 0 - - step "delete object" - deleteObject bucket object + step "delete object" + deleteObject bucket object presignedUrlFunTest :: TestTree presignedUrlFunTest = funTestWithBucket "presigned Url tests" $ @@ -695,7 +451,7 @@ presignedUrlFunTest = funTestWithBucket "presigned Url tests" $ "presigned put and get got mismatched data" step "PUT object presigned - presignedPutObjectURL" - putUrl2 <- presignedPutObjectUrl bucket obj2 3600 [] + putUrl2 <- presignedPutObjectUrl bucket obj2 604800 [] let size2 = 1200 testFile <- mkRandFile size2 @@ -834,3 +590,262 @@ bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $ step "delete bucket policy" setBucketPolicy bucket T.empty + +multipartTest :: TestTree +multipartTest = funTestWithBucket "Multipart Tests" $ + \step bucket -> do + step "Prepare for putObjectInternal with non-seekable file, with size." + step "Upload multipart file." + let mb80 = 80 * 1024 * 1024 + obj = "mpart" + + void $ putObjectInternal bucket obj defaultPutObjectOptions $ ODFile "/dev/zero" (Just mb80) + + step "Retrieve and verify file size" + destFile <- mkRandFile 0 + fGetObject bucket obj destFile defaultGetObjectOptions + gotSize <- withNewHandle destFile getFileSize + liftIO $ gotSize == Right (Just mb80) @? + "Wrong file size of put file after getting" + + step "Cleanup actions" + removeObject bucket obj + + step "cleanup" + removeObject bucket "big" + + step "Prepare for removeIncompleteUpload" + -- low-level multipart operation tests. + let object = "newmpupload" + kb5 = 5 * 1024 + + step "create new multipart upload" + uid <- newMultipartUpload bucket object [] + liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id." + + randFile <- mkRandFile kb5 + + step "upload 2 parts" + forM_ [1,2] $ \partNum -> do + h <- liftIO $ SIO.openBinaryFile randFile SIO.ReadMode + void $ putObjectPart bucket object uid partNum [] $ PayloadH h 0 kb5 + + step "remove ongoing upload" + removeIncompleteUpload bucket object + uploads <- C.runConduit $ listIncompleteUploads bucket (Just object) False + C..| sinkList + liftIO $ (null uploads) @? "removeIncompleteUploads didn't complete successfully" + +putObjectContentTypeTest :: TestTree +putObjectContentTypeTest = funTestWithBucket "putObject contentType tests" $ + \step bucket -> do + step "fPutObject content type test" + let object = "xxx-content-type" + size1 = 100 :: Int64 + + step "create server object with content-type" + inputFile <- mkRandFile size1 + fPutObject bucket object inputFile defaultPutObjectOptions { + pooContentType = Just "application/javascript" + } + + -- retrieve obj info to check + oi <- headObject bucket object + let m = oiMetadata oi + + step "Validate content-type" + liftIO $ assertEqual "Content-Type did not match" (Just "application/javascript") (Map.lookup "Content-Type" m) + + step "upload object with content-encoding set to identity" + fPutObject bucket object inputFile defaultPutObjectOptions { + pooContentEncoding = Just "identity" + } + + oiCE <- headObject bucket object + let m' = oiMetadata oiCE + + step "Validate content-encoding" + liftIO $ assertEqual "Content-Encoding did not match" (Just "identity") + (Map.lookup "Content-Encoding" m') + + step "Cleanup actions" + + removeObject bucket object + +putObjectContentLanguageTest :: TestTree +putObjectContentLanguageTest = funTestWithBucket "putObject contentLanguage tests" $ + \step bucket -> do + step "fPutObject content language test" + let object = "xxx-content-language" + size1 = 100 :: Int64 + + step "create server object with content-language" + inputFile <- mkRandFile size1 + fPutObject bucket object inputFile defaultPutObjectOptions { + pooContentLanguage = Just "en-US" + } + + -- retrieve obj info to check + oi <- headObject bucket object + let m = oiMetadata oi + + step "Validate content-language" + liftIO $ assertEqual "content-language did not match" (Just "en-US") + (Map.lookup "Content-Language" m) + step "Cleanup actions" + + removeObject bucket object + +putObjectStorageClassTest :: TestTree +putObjectStorageClassTest = funTestWithBucket "putObject storageClass tests" $ + \step bucket -> do + step "fPutObject storage class test" + let object = "xxx-storage-class-standard" + object' = "xxx-storage-class-reduced" + object'' = "xxx-storage-class-invalid" + size1 = 100 :: Int64 + size0 = 0 :: Int64 + + step "create server objects with storageClass" + inputFile <- mkRandFile size1 + inputFile' <- mkRandFile size1 + inputFile'' <- mkRandFile size0 + + fPutObject bucket object inputFile defaultPutObjectOptions { + pooStorageClass = Just "STANDARD" + } + + fPutObject bucket object' inputFile' defaultPutObjectOptions { + pooStorageClass = Just "REDUCED_REDUNDANCY" + } + + removeObject bucket object + + -- retrieve obj info to check + oi' <- headObject bucket object' + let m' = oiMetadata oi' + + step "Validate x-amz-storage-class rrs" + liftIO $ assertEqual "storageClass did not match" (Just "REDUCED_REDUNDANCY") + (Map.lookup "X-Amz-Storage-Class" m') + + fpE <- try $ fPutObject bucket object'' inputFile'' defaultPutObjectOptions { + pooStorageClass = Just "INVALID_STORAGE_CLASS" + } + case fpE of + Left exn -> liftIO $ exn @?= ServiceErr "InvalidStorageClass" "Invalid storage class." + _ -> return () + + step "Cleanup actions" + + removeObject bucket object' + +copyObjectTests :: TestTree +copyObjectTests = funTestWithBucket "copyObject related tests" $ + \step bucket -> do + step "copyObjectSingle basic tests" + let object = "xxx" + objCopy = "xxxCopy" + size1 = 100 :: Int64 + + step "create server object to copy" + inputFile <- mkRandFile size1 + fPutObject bucket object inputFile defaultPutObjectOptions + + step "copy object" + let srcInfo = defaultSourceInfo { srcBucket = bucket, srcObject = object} + (etag, modTime) <- copyObjectSingle bucket objCopy srcInfo [] + + -- retrieve obj info to check + oi <- headObject bucket objCopy + let t = oiModTime oi + let e = oiETag oi + let s = oiSize oi + + let isMTimeDiffOk = abs (diffUTCTime modTime t) < 1.0 + + liftIO $ (s == size1 && e == etag && isMTimeDiffOk) @? + "Copied object did not match expected." + + step "cleanup actions" + removeObject bucket object + removeObject bucket objCopy + + step "copyObjectPart basic tests" + let srcObj = "XXX" + copyObj = "XXXCopy" + + step "Prepare" + let mb15 = 15 * 1024 * 1024 + mb5 = 5 * 1024 * 1024 + randFile <- mkRandFile mb15 + fPutObject bucket srcObj randFile defaultPutObjectOptions + + step "create new multipart upload" + uid <- newMultipartUpload bucket copyObj [] + liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id." + + step "put object parts 1-3" + let srcInfo' = defaultSourceInfo { srcBucket = bucket, srcObject = srcObj } + dstInfo' = defaultDestinationInfo { dstBucket = bucket, dstObject = copyObj } + parts <- forM [1..3] $ \p -> do + (etag', _) <- copyObjectPart dstInfo' srcInfo'{ + srcRange = Just $ (,) ((p-1)*mb5) ((p-1)*mb5 + (mb5 - 1)) + } uid (fromIntegral p) [] + return (fromIntegral p, etag') + + step "complete multipart" + void $ completeMultipartUpload bucket copyObj uid parts + + step "verify copied object size" + oi' <- headObject bucket copyObj + let s' = oiSize oi' + + liftIO $ (s' == mb15) @? "Size failed to match" + + step "Cleanup actions" + removeObject bucket srcObj + removeObject bucket copyObj + + step "copyObject basic tests" + let srcs = ["XXX", "XXXL"] + copyObjs = ["XXXCopy", "XXXLCopy"] + sizes = map (* (1024 * 1024)) [15, 65] + + step "Prepare" + forM_ (zip srcs sizes) $ \(src, size) -> do + inputFile' <- mkRandFile size + fPutObject bucket src inputFile' defaultPutObjectOptions + + step "make small and large object copy" + forM_ (zip copyObjs srcs) $ \(cp, src) -> + copyObject defaultDestinationInfo {dstBucket = bucket, dstObject = cp} defaultSourceInfo {srcBucket = bucket, srcObject = src} + + step "verify uploaded objects" + uploadedSizes <- fmap oiSize <$> forM copyObjs (headObject bucket) + + liftIO $ (sizes == uploadedSizes) @? "Uploaded obj sizes failed to match" + + forM_ (srcs ++ copyObjs) (removeObject bucket) + + step "copyObject with offset test " + let src = "XXX" + size = 15 * 1024 * 1024 + + step "Prepare" + inputFile' <- mkRandFile size + fPutObject bucket src inputFile' defaultPutObjectOptions + + step "copy last 10MiB of object" + copyObject defaultDestinationInfo { dstBucket = bucket, dstObject = copyObj } defaultSourceInfo { + srcBucket = bucket + , srcObject = src + , srcRange = Just $ (,) (5 * 1024 * 1024) (size - 1) + } + + step "verify uploaded object" + cSize <- oiSize <$> headObject bucket copyObj + + liftIO $ (cSize == 10 * 1024 * 1024) @? "Uploaded obj size mismatched!" + + forM_ [src, copyObj] (removeObject bucket)