@@ -1,5 +1,5 @@
11--
2−-- Minio Haskell SDK, (C) 2017 Minio, Inc.
2+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.
33--
44-- Licensed under the Apache License, Version 2.0 (the "License");
55-- you may not use this file except in compliance with the License.
@@ -14,38 +14,34 @@
1414-- limitations under the License.
1515--
1616
17−import qualified Test.QuickCheck as Q
18−import Test.Tasty
19−import Test.Tasty.HUnit
20−import Test.Tasty.QuickCheck as QC
21−
22−import Lib.Prelude
23−
24−import System.Directory (getTemporaryDirectory)
25−import qualified System.IO as SIO
26−
27−import qualified Control.Monad.Catch as MC
28−import qualified Control.Monad.Trans.Resource as R
29−import qualified Data.ByteString as BS
30−import Data.Conduit (yield, ($$))
31−import qualified Data.Conduit as C
32−import qualified Data.Conduit.Binary as CB
33−import Data.Conduit.Combinators (sinkList)
34−import Data.Default (Default (..))
35−import qualified Data.Map.Strict as Map
36−import qualified Data.Text as T
37−import qualified Data.Time as Time
17+import Conduit (replicateC)
18+import qualified Conduit as C
19+import qualified Control.Monad.Trans.Resource as R
20+import qualified Data.ByteString as BS
21+import Data.Conduit (yield)
22+import qualified Data.Conduit.Binary as CB
23+import Data.Conduit.Combinators (sinkList)
24+import qualified Data.HashMap.Strict as H
25+import qualified Data.Text as T
26+import Data.Time (fromGregorian)
27+import qualified Data.Time as Time
28+import Lib.Prelude
3829import qualified Network.HTTP.Client.MultipartFormData as Form
39−import qualified Network.HTTP.Conduit as NC
40−import qualified Network.HTTP.Types as HT
41−import System.Environment (lookupEnv)
42−
43−import Network.Minio
44−import Network.Minio.Data
45−import Network.Minio.ListOps
46−import Network.Minio.PutObject
47−import Network.Minio.S3API
48−import Network.Minio.Utils
30+import qualified Network.HTTP.Conduit as NC
31+import qualified Network.HTTP.Types as HT
32+import Network.Minio
33+import Network.Minio.Credentials (Creds (CredsStatic))
34+import Network.Minio.Data
35+import Network.Minio.Data.Crypto
36+import Network.Minio.S3API
37+import Network.Minio.Utils
38+import System.Directory (getTemporaryDirectory)
39+import qualified System.Environment as Env
40+import qualified Test.QuickCheck as Q
41+import Test.Tasty
42+import Test.Tasty.HUnit
43+import Test.Tasty.QuickCheck as QC
44+import qualified UnliftIO.IO as UIO
4945
5046main :: IO ()
5147main = defaultMain tests
@@ -53,457 +49,574 @@ main = defaultMain tests
5349tests :: TestTree
5450tests = testGroup "Tests" [liveServerUnitTests]
5551
52+lookupTestEnv :: IO (Maybe ConnectInfo, (AccessKey, SecretKey))
53+lookupTestEnv = do
54+ val <- Env.lookupEnv "MINIO_LOCAL"
55+ secure <- Env.lookupEnv "MINIO_SECURE"
56+ let localServerMaybe = case (val, secure) of
57+ (Just _, Just _) -> Just "https://localhost:9000"
58+ (Just _, Nothing) -> Just "http://localhost:9000"
59+ _ -> Nothing
60+ accessKeyE <- Env.lookupEnv "MINIO_ACCESS_KEY"
61+ let accessKey = maybe "minioadmin" fromString accessKeyE
62+ secretKeyE <- Env.lookupEnv "MINIO_SECRET_KEY"
63+ let secretKey = maybe "minioadmin" fromString secretKeyE
64+ return (localServerMaybe, (accessKey, secretKey))
65+
66+loadTestServerConnInfo :: IO ConnectInfo
67+loadTestServerConnInfo = do
68+ (localServerMaybe, (ak, sk)) <- lookupTestEnv
69+ return $ case localServerMaybe of
70+ Just localServer -> do
71+ setCreds (CredentialValue ak sk mempty) localServer
72+ _ -> minioPlayCI
73+
74+loadTestServerConnInfoSTS :: IO ConnectInfo
75+loadTestServerConnInfoSTS = do
76+ (localServerMaybe, (ak, sk)) <- lookupTestEnv
77+ case localServerMaybe of
78+ Just localServer -> do
79+ let creds = CredentialValue ak sk mempty
80+ assumeRole =
81+ STSAssumeRole
82+ { sarCredentials = creds,
83+ sarOptions = defaultSTSAssumeRoleOptions
84+ }
85+ setSTSCredential assumeRole localServer
86+ Nothing -> do
87+ let creds = case connectCreds minioPlayCI of
88+ CredsStatic c -> c
89+ _ -> error "unexpected play creds"
90+ assumeRole =
91+ STSAssumeRole
92+ { sarCredentials = creds,
93+ sarOptions = defaultSTSAssumeRoleOptions
94+ }
95+ setSTSCredential assumeRole minioPlayCI
96+
5697-- conduit that generates random binary stream of given length
57−randomDataSrc :: MonadIO m => Int64 -> C.Producer m ByteString
58−randomDataSrc s' = genBS s'
98+randomDataSrc :: (MonadIO m) => Int64 -> C.ConduitM () ByteString m ()
99+randomDataSrc = genBS
59100 where
60− oneMiB = 1024*1024
61−
62− concatIt bs n = BS.concat $ replicate (fromIntegral q) bs ++
63− [BS.take (fromIntegral r) bs]
64− where (q, r) = n `divMod` fromIntegral (BS.length bs)
65−
101+ concatIt bs n =
102+ BS.concat $
103+ replicate (fromIntegral q) bs
104+ ++ [BS.take (fromIntegral r) bs]
105+ where
106+ (q, r) = n `divMod` fromIntegral (BS.length bs)
66107 genBS s = do
67108 w8s <- liftIO $ generate $ Q.vectorOf 64 (Q.choose (0, 255))
68109 let byteArr64 = BS.pack w8s
69110 if s < oneMiB
70111 then yield $ concatIt byteArr64 s
71− else do yield $ concatIt byteArr64 oneMiB
72− genBS (s - oneMiB)
112+ else do
113+ yield $ concatIt byteArr64 oneMiB
114+ genBS (s - oneMiB)
73115
74−mkRandFile :: R.MonadResource m => Int64 -> m FilePath
116+mkRandFile :: (R.MonadResource m) => Int64 -> m FilePath
75117mkRandFile size = do
76− dir <- liftIO $ getTemporaryDirectory
77− randomDataSrc size C.$$ CB.sinkTempFile dir "miniohstest.random"
118+ dir <- liftIO getTemporaryDirectory
119+ C.runConduit $ randomDataSrc size C..| CB.sinkTempFile dir "miniohstest.random"
78120
79121funTestBucketPrefix :: Text
80122funTestBucketPrefix = "miniohstest-"
81123
82−funTestWithBucket :: TestName
83− -> (([Char] -> Minio ()) -> Bucket -> Minio ()) -> TestTree
84−funTestWithBucket t minioTest = testCaseSteps t $ \step -> do
124+funTestWithBucketNoSTS ::
125+ TestName ->
126+ (([Char] -> Minio ()) -> Bucket -> Minio ()) ->
127+ TestTree
128+funTestWithBucketNoSTS t minioTest = testCaseSteps t $ \step -> do
85129 -- generate a random name for the bucket
86130 bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z'))
87131 let b = T.concat [funTestBucketPrefix, T.pack bktSuffix]
88132 liftStep = liftIO . step
89− connInfo <- maybe minioPlayCI (const def) <$> lookupEnv "MINIO_LOCAL"
133+ connInfo <- loadTestServerConnInfo
90134 ret <- runMinio connInfo $ do
91135 liftStep $ "Creating bucket for test - " ++ t
92136 foundBucket <- bucketExists b
93137 liftIO $ foundBucket @?= False
94− makeBucket b def
138+ makeBucket b Nothing
95139 minioTest liftStep b
96140 deleteBucket b
97141 isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)
98142
99−lowLevelMultipartTest :: TestTree
100−lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $
101− \step bucket -> do
102− -- low-level multipart operation tests.
103− let object = "newmpupload"
104− mb15 = 15 * 1024 * 1024
105−
106− step "Prepare for low-level multipart tests."
107− step "create new multipart upload"
108− uid <- newMultipartUpload bucket object []
109− liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
110−
111− randFile <- mkRandFile mb15
112−
113− step "put object parts 1 of 1"
114− h <- liftIO $ SIO.openBinaryFile randFile SIO.ReadMode
115− partInfo <- putObjectPart bucket object uid 1 [] $ PayloadH h 0 mb15
116−
117− step "complete multipart"
118− void $ completeMultipartUpload bucket object uid [partInfo]
119−
120− destFile <- mkRandFile 0
121− step "Retrieve the created object and check size"
122− fGetObject bucket object destFile
123− gotSize <- withNewHandle destFile getFileSize
124− liftIO $ gotSize == Right (Just mb15) @?
125− "Wrong file size of put file after getting"
126−
127− step "Cleanup actions"
128− removeObject bucket object
129−
130−putObjectNoSizeTest :: TestTree
131−putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no size" $
132− \step bucket -> do
133− -- putObject test (conduit source, no size specified)
134− let obj = "mpart"
135− mb70 = 70 * 1024 * 1024
136−
137− step "Prepare for putObject with from source without providing size."
138− rFile <- mkRandFile mb70
139−
140− step "Upload multipart file."
141− putObject bucket obj (CB.sourceFile rFile) Nothing
143+funTestWithBucket ::
144+ TestName ->
145+ (([Char] -> Minio ()) -> Bucket -> Minio ()) ->
146+ TestTree
147+funTestWithBucket t minioTest = testCaseSteps t $ \step -> do
148+ -- generate a random name for the bucket
149+ bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z'))
150+ let b = T.concat [funTestBucketPrefix, T.pack bktSuffix]
151+ liftStep = liftIO . step
152+ connInfo <- loadTestServerConnInfo
153+ ret <- runMinio connInfo $ do
154+ liftStep $ "Creating bucket for test - " ++ t
155+ foundBucket <- bucketExists b
156+ liftIO $ foundBucket @?= False
157+ makeBucket b Nothing
158+ minioTest liftStep b
159+ deleteBucket b
160+ isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)
142161
143− step "Retrieve and verify file size"
144− destFile <- mkRandFile 0
145− fGetObject bucket obj destFile
146− gotSize <- withNewHandle destFile getFileSize
147− liftIO $ gotSize == Right (Just mb70) @?
148− "Wrong file size of put file after getting"
162+ connInfoSTS <- loadTestServerConnInfoSTS
163+ let t' = t ++ " (with AssumeRole Credentials)"
164+ ret' <- runMinio connInfoSTS $ do
165+ liftStep $ "Creating bucket for test - " ++ t'
166+ foundBucket <- bucketExists b
167+ liftIO $ foundBucket @?= False
168+ makeBucket b Nothing
169+ minioTest liftStep b
170+ deleteBucket b
171+ isRight ret' @? ("Functional test " ++ t' ++ " failed => " ++ show ret')
149172
150− step "Cleanup actions"
151− deleteObject bucket obj
173+liveServerUnitTests :: TestTree
174+liveServerUnitTests =
175+ testGroup
176+ "Unit tests against a live server"
177+ [ basicTests,
178+ listingTest,
179+ highLevelListingTest,
180+ lowLevelMultipartTest,
181+ putObjectSizeTest,
182+ putObjectNoSizeTest,
183+ multipartTest,
184+ putObjectContentTypeTest,
185+ putObjectContentLanguageTest,
186+ putObjectStorageClassTest,
187+ putObjectUserMetadataTest,
188+ getObjectTest,
189+ copyObjectTests,
190+ presignedUrlFunTest,
191+ presignedPostPolicyFunTest,
192+ bucketPolicyFunTest,
193+ getNPutSSECTest,
194+ assumeRoleRequestTest
195+ ]
152196
153−highLevelListingTest :: TestTree
154−highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
197+basicTests :: TestTree
198+basicTests = funTestWithBucket "Basic tests" $
155199 \step bucket -> do
156− step "High-level listObjects Test"
157− step "put 3 objects"
158− let expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3"]
159− forM_ expectedObjects $
160− \obj -> fPutObject bucket obj "/etc/lsb-release"
161−
162− step "High-level listing of objects"
163− objects <- listObjects bucket Nothing True $$ sinkList
164−
165− liftIO $ assertEqual "Objects match failed!" (sort expectedObjects)
166− (map oiObject objects)
167−
168− step "High-level listing of objects (version 1)"
169− objects <- listObjectsV1 bucket Nothing True $$ sinkList
170−
171− step "Cleanup actions"
172− forM_ expectedObjects $
173− \obj -> removeObject bucket obj
174−
175− step "High-level listIncompleteUploads Test"
176− let object = "newmpupload"
177− step "create 10 multipart uploads"
178− forM_ [1..10::Int] $ \_ -> do
179− uid <- newMultipartUpload bucket object []
180− liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
181−
182− step "High-level listing of incomplete multipart uploads"
183− uploads <- listIncompleteUploads bucket Nothing True $$ sinkList
184− -- Minio server behaviour changed to list no incomplete uploads,
185− -- so the check below reflects this; this test is expected to
186− -- fail on AWS S3.
187− liftIO $ length uploads @?= 0
188−
189− step "cleanup"
190− forM_ uploads $ \(UploadInfo _ uid _ _) ->
191− abortMultipartUpload bucket object uid
192−
193− step "High-level listIncompleteParts Test"
194− let mb5 = 5 * 1024 * 1024
195−
196− step "create a multipart upload"
197− uid <- newMultipartUpload bucket object []
198− liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
200+ step "getService works and contains the test bucket."
201+ buckets <- getService
202+ unless (length (filter (== bucket) $ map biName buckets) == 1) $
203+ liftIO $
204+ assertFailure
205+ ( "The bucket "
206+ ++ show bucket
207+ ++ " was expected to exist."
208+ )
209+
210+ step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised."
211+ mbE <- try $ makeBucket bucket Nothing
212+ case mbE of
213+ Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou
214+ _ -> return ()
215+
216+ step "makeBucket with an invalid bucket name and check for appropriate exception."
217+ invalidMBE <- try $ makeBucket "invalidBucketName" Nothing
218+ case invalidMBE of
219+ Left exn -> liftIO $ exn @?= MErrVInvalidBucketName "invalidBucketName"
220+ _ -> return ()
221+
222+ step "getLocation works"
223+ region <- getLocation bucket
224+ liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region)
225+
226+ step "singlepart putObject works"
227+ testFilepath <- mkRandFile 200
228+ fPutObject bucket "test-file" testFilepath defaultPutObjectOptions
229+
230+ step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception"
231+ fpE <- try $ fPutObject "nosuchbucket" "test-file-2" testFilepath defaultPutObjectOptions
232+ case fpE of
233+ Left exn -> liftIO $ exn @?= NoSuchBucket
234+ _ -> return ()
235+
236+ outFile <- mkRandFile 0
237+ step "simple fGetObject works"
238+ fGetObject bucket "test-file" outFile defaultGetObjectOptions
239+
240+ let unmodifiedTime = UTCTime (fromGregorian 2010 11 26) 69857
241+ step "fGetObject an object which is modified now but requesting as un-modified in past, check for exception"
242+ resE <-
243+ try $
244+ fGetObject
245+ bucket
246+ "test-file"
247+ outFile
248+ defaultGetObjectOptions
249+ { gooIfUnmodifiedSince = Just unmodifiedTime
250+ }
251+ case resE of
252+ Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold"
253+ _ -> return ()
254+
255+ step "fGetObject an object with no matching etag, check for exception"
256+ resE1 <-
257+ try $
258+ fGetObject
259+ bucket
260+ "test-file"
261+ outFile
262+ defaultGetObjectOptions
263+ { gooIfMatch = Just "invalid-etag"
264+ }
265+ case resE1 of
266+ Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold"
267+ _ -> return ()
268+
269+ step "fGetObject an object with no valid range, check for exception"
270+ resE2 <-
271+ try $
272+ fGetObject
273+ bucket
274+ "test-file"
275+ outFile
276+ defaultGetObjectOptions
277+ { gooRange = Just $ HT.ByteRangeFromTo 100 300
278+ }
279+ case resE2 of
280+ Left exn -> liftIO $ exn @?= ServiceErr "InvalidRange" "The requested range is not satisfiable"
281+ _ -> return ()
282+
283+ step "fGetObject on object with a valid range"
284+ fGetObject
285+ bucket
286+ "test-file"
287+ outFile
288+ defaultGetObjectOptions
289+ { gooRange = Just $ HT.ByteRangeFrom 1
290+ }
199291
200− step "put object parts 1..10"
201− inputFile <- mkRandFile mb5
202− h <- liftIO $ SIO.openBinaryFile inputFile SIO.ReadMode
203− forM_ [1..10] $ \pnum ->
204− putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5
292+ step "fGetObject a non-existent object and check for NoSuchKey exception"
293+ resE3 <- try $ fGetObject bucket "noSuchKey" outFile defaultGetObjectOptions
294+ case resE3 of
295+ Left exn -> liftIO $ exn @?= NoSuchKey
296+ _ -> return ()
205297
206− step "fetch list parts"
207− incompleteParts <- listIncompleteParts bucket object uid $$ sinkList
208− -- Minio server behaviour changed to list no incomplete uploads,
209− -- so the check below reflects this; this test is expected to
210− -- fail on AWS S3.
211− liftIO $ length incompleteParts @?= 0
298+ step "create new multipart upload works"
299+ uid <- newMultipartUpload bucket "newmpupload" []
300+ liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
212301
213− step "cleanup"
214− abortMultipartUpload bucket object uid
302+ step "abort a new multipart upload works"
303+ abortMultipartUpload bucket "newmpupload" uid
215304
216−listingTest :: TestTree
217−listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do
218− step "listObjects' test"
219− step "put 10 objects"
220− let objects = (\s ->T.concat ["lsb-release", T.pack (show s)]) <$> [1..10::Int]
221−
222− forM_ [1..10::Int] $ \s ->
223− fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release"
224−
225− step "Simple list"
226− res <- listObjects' bucket Nothing Nothing Nothing Nothing
227− let expectedObjects = sort objects
228− liftIO $ assertEqual "Objects match failed!" expectedObjects
229− (map oiObject $ lorObjects res)
230−
231− step "Simple list version 1"
232− res <- listObjectsV1' bucket Nothing Nothing Nothing Nothing
233− let expected = sort $ map (T.concat .
234− ("lsb-release":) .
235− (\x -> [x]) .
236− T.pack .
237− show) [1..10::Int]
238− liftIO $ assertEqual "Objects match failed!" expected
239− (map oiObject $ lorObjects' res)
240−
241− step "Cleanup actions"
242− forM_ objects $ \obj -> deleteObject bucket obj
243−
244− step "listIncompleteUploads' test"
245− step "create 10 multipart uploads"
246− let object = "newmpupload"
247− forM_ [1..10::Int] $ \_ -> do
248− uid <- newMultipartUpload bucket object []
249− liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
250−
251− step "list incomplete multipart uploads"
252− incompleteUploads <- listIncompleteUploads' bucket Nothing Nothing
253− Nothing Nothing Nothing
254− -- Minio server behaviour changed to list no incomplete uploads,
255− -- so the check below reflects this; this test is expected to
256− -- fail on AWS S3.
257− liftIO $ (length $ lurUploads incompleteUploads) @?= 0
258−
259− step "cleanup"
260− forM_ (lurUploads incompleteUploads) $
261− \(_, uid, _) -> abortMultipartUpload bucket object uid
262−
263− step "Basic listIncompleteParts Test"
264− let mb5 = 5 * 1024 * 1024
265−
266− step "create a multipart upload"
267− uid <- newMultipartUpload bucket object []
268− liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
305+ step "delete object works"
306+ deleteObject bucket "test-file"
269307
270− step "put object parts 1..10"
271− inputFile <- mkRandFile mb5
272− h <- liftIO $ SIO.openBinaryFile inputFile SIO.ReadMode
273− forM_ [1..10] $ \pnum ->
274− putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5
308+ step "statObject test"
309+ let object = "sample"
310+ step "create an object"
311+ inputFile <- mkRandFile 0
312+ fPutObject bucket object inputFile defaultPutObjectOptions
275313
276− step "fetch list parts"
277− listPartsResult <- listIncompleteParts' bucket object uid Nothing Nothing
278− -- Minio server behaviour changed to list no incomplete uploads,
279− -- so the check below reflects this; this test is expected to
280− -- fail on AWS S3.
281− liftIO $ (length $ lprParts listPartsResult) @?= 0
282− abortMultipartUpload bucket object uid
314+ step "get metadata of the object"
315+ res <- statObject bucket object defaultGetObjectOptions
316+ liftIO $ oiSize res @?= 0
283317
318+ step "delete object"
319+ deleteObject bucket object
284320
285−liveServerUnitTests :: TestTree
286−liveServerUnitTests = testGroup "Unit tests against a live server"
287− [ basicTests
288− , listingTest
289− , highLevelListingTest
290− , lowLevelMultipartTest
291− , putObjectNoSizeTest
292− , funTestWithBucket "Multipart Tests" $
293− \step bucket -> do
294− step "Prepare for putObjectInternal with non-seekable file, with size."
295− step "Upload multipart file."
296− let mb80 = 80 * 1024 * 1024
297− obj = "mpart"
298−
299− void $ putObjectInternal bucket obj $ ODFile "/dev/zero" (Just mb80)
300−
301− step "Retrieve and verify file size"
302− destFile <- mkRandFile 0
303− fGetObject bucket obj destFile
304− gotSize <- withNewHandle destFile getFileSize
305− liftIO $ gotSize == Right (Just mb80) @?
306− "Wrong file size of put file after getting"
307−
308− step "Cleanup actions"
309− removeObject bucket obj
310−
311− step "cleanup"
312− removeObject bucket "big"
313−
314− step "Prepare for removeIncompleteUpload"
315− -- low-level multipart operation tests.
316− let object = "newmpupload"
317− kb5 = 5 * 1024
318−
319− step "create new multipart upload"
320− uid <- newMultipartUpload bucket object []
321− liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
322−
323− randFile <- mkRandFile kb5
324−
325− step "upload 2 parts"
326− forM_ [1,2] $ \partNum -> do
327− h <- liftIO $ SIO.openBinaryFile randFile SIO.ReadMode
328− void $ putObjectPart bucket object uid partNum [] $ PayloadH h 0 kb5
329−
330− step "remove ongoing upload"
331− removeIncompleteUpload bucket object
332− uploads <- listIncompleteUploads bucket (Just object) False C.$$ sinkList
333− liftIO $ (null uploads) @? "removeIncompleteUploads didn't complete successfully"
334−
321+lowLevelMultipartTest :: TestTree
322+lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $
323+ \step bucket -> do
324+ -- low-level multipart operation tests.
325+ let object = "newmpupload"
326+ mb15 = 15 * 1024 * 1024
327+
328+ step "Prepare for low-level multipart tests."
329+ step "create new multipart upload"
330+ uid <- newMultipartUpload bucket object []
331+ liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
332+
333+ randFile <- mkRandFile mb15
334+
335+ step "put object parts 1 of 1"
336+ partInfo <-
337+ UIO.withBinaryFile randFile UIO.ReadMode $ \h ->
338+ putObjectPart bucket object uid 1 [] $ PayloadH h 0 mb15
339+
340+ step "complete multipart"
341+ void $ completeMultipartUpload bucket object uid [partInfo]
342+
343+ destFile <- mkRandFile 0
344+ step "Retrieve the created object and check size"
345+ fGetObject bucket object destFile defaultGetObjectOptions
346+ gotSize <- withNewHandle destFile getFileSize
347+ liftIO $
348+ gotSize
349+ == Right (Just mb15)
350+ @? "Wrong file size of put file after getting"
351+
352+ step "Cleanup actions"
353+ removeObject bucket object
354+
355+putObjectSizeTest :: TestTree
356+putObjectSizeTest = funTestWithBucket "PutObject of conduit source with size" $
357+ \step bucket -> do
358+ -- putObject test (conduit source, size specified)
359+ let obj = "msingle"
360+ mb1 = 1 * 1024 * 1024
335361
336− , funTestWithBucket "copyObject related tests" $ \step bucket -> do
337− step "copyObjectSingle basic tests"
338− let object = "xxx"
339− objCopy = "xxxCopy"
340− size1 = 100 :: Int64
362+ step "Prepare for putObject with from source with size."
363+ rFile <- mkRandFile mb1
341364
342− step "create server object to copy"
343− inputFile <- mkRandFile size1
344− fPutObject bucket object inputFile
365+ step "Upload single file."
366+ putObject bucket obj (CB.sourceFile rFile) (Just mb1) defaultPutObjectOptions
345367
346− step "copy object"
347− let cps = def { cpSource = format "/{}/{}" [bucket, object] }
348− (etag, modTime) <- copyObjectSingle bucket objCopy cps []
368+ step "Retrieve and verify file size"
369+ destFile <- mkRandFile 0
370+ fGetObject bucket obj destFile defaultGetObjectOptions
371+ gotSize <- withNewHandle destFile getFileSize
372+ liftIO $
373+ gotSize
374+ == Right (Just mb1)
375+ @? "Wrong file size of put file after getting"
349376
350− -- retrieve obj info to check
351− ObjectInfo _ t e s <- headObject bucket objCopy
377+ step "Cleanup actions"
378+ deleteObject bucket obj
352379
353− let isMTimeDiffOk = abs (diffUTCTime modTime t) < 1.0
380+putObjectNoSizeTest :: TestTree
381+putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no size" $
382+ \step bucket -> do
383+ -- putObject test (conduit source, no size specified)
384+ let obj = "mpart"
385+ mb70 = 70 * 1024 * 1024
354386
355− liftIO $ (s == size1 && e == etag && isMTimeDiffOk) @?
356− "Copied object did not match expected."
387+ step "Prepare for putObject with from source without providing size."
388+ rFile <- mkRandFile mb70
357389
358− step "cleanup actions"
359− removeObject bucket object
360− removeObject bucket objCopy
390+ step "Upload multipart file."
391+ putObject bucket obj (CB.sourceFile rFile) Nothing defaultPutObjectOptions
361392
362− step "copyObjectPart basic tests"
363− let srcObj = "XXX"
364− copyObj = "XXXCopy"
393+ step "Retrieve and verify file size"
394+ destFile <- mkRandFile 0
395+ fGetObject bucket obj destFile defaultGetObjectOptions
396+ gotSize <- withNewHandle destFile getFileSize
397+ liftIO $
398+ gotSize
399+ == Right (Just mb70)
400+ @? "Wrong file size of put file after getting"
365401
366− step "Prepare"
367− let mb15 = 15 * 1024 * 1024
368− mb5 = 5 * 1024 * 1024
369− randFile <- mkRandFile mb15
370− fPutObject bucket srcObj randFile
402+ step "Cleanup actions"
403+ deleteObject bucket obj
371404
372− step "create new multipart upload"
373− uid <- newMultipartUpload bucket copyObj []
405+highLevelListingTest :: TestTree
406+highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
407+ \step bucket -> do
408+ step "High-level listObjects Test"
409+ step "put 3 objects"
410+ let extractObjectsFromList =
411+ mapM
412+ ( \case
413+ ListItemObject o -> Just $ oiObject o
414+ _ -> Nothing
415+ )
416+ extractObjectsAndDirsFromList =
417+ map
418+ ( \case
419+ ListItemObject o -> oiObject o
420+ ListItemPrefix d -> d
421+ )
422+ expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3", "o4"]
423+ expectedNonRecList = ["o4", "dir/"]
424+
425+ testFilepath <- mkRandFile 200
426+ forM_ expectedObjects $
427+ \obj -> fPutObject bucket obj testFilepath defaultPutObjectOptions
428+
429+ step "High-level listing of objects"
430+ items <- C.runConduit $ listObjects bucket Nothing False C..| sinkList
431+ liftIO $
432+ assertEqual "Objects/Dirs match failed!" expectedNonRecList $
433+ extractObjectsAndDirsFromList items
434+
435+ step "High-level recursive listing of objects"
436+ objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList
437+
438+ liftIO
439+ $ assertEqual
440+ "Objects match failed!"
441+ (Just $ sort expectedObjects)
442+ $ extractObjectsFromList objects
443+
444+ step "High-level listing of objects (version 1)"
445+ itemsV1 <- C.runConduit $ listObjectsV1 bucket Nothing False C..| sinkList
446+ liftIO $
447+ assertEqual "Objects/Dirs match failed!" expectedNonRecList $
448+ extractObjectsAndDirsFromList itemsV1
449+
450+ step "High-level recursive listing of objects (version 1)"
451+ objectsV1 <-
452+ C.runConduit $
453+ listObjectsV1 bucket Nothing True
454+ C..| sinkList
455+
456+ liftIO
457+ $ assertEqual
458+ "Objects match failed!"
459+ (Just $ sort expectedObjects)
460+ $ extractObjectsFromList objectsV1
461+
462+ let expectedPrefListing = ["dir/o1", "dir/dir1/", "dir/dir2/"]
463+ expectedPrefListingRec = Just ["dir/dir1/o2", "dir/dir2/o3", "dir/o1"]
464+ step "High-level listing with prefix"
465+ prefItems <- C.runConduit $ listObjects bucket (Just "dir/") False C..| sinkList
466+ liftIO
467+ $ assertEqual
468+ "Objects/Dirs under prefix match failed!"
469+ expectedPrefListing
470+ $ extractObjectsAndDirsFromList prefItems
471+
472+ step "High-level listing with prefix recursive"
473+ prefItemsRec <- C.runConduit $ listObjects bucket (Just "dir/") True C..| sinkList
474+ liftIO
475+ $ assertEqual
476+ "Objects/Dirs under prefix match recursive failed!"
477+ expectedPrefListingRec
478+ $ extractObjectsFromList prefItemsRec
479+
480+ step "High-level listing with prefix (version 1)"
481+ prefItemsV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") False C..| sinkList
482+ liftIO
483+ $ assertEqual
484+ "Objects/Dirs under prefix match failed!"
485+ expectedPrefListing
486+ $ extractObjectsAndDirsFromList prefItemsV1
487+
488+ step "High-level listing with prefix recursive (version 1)"
489+ prefItemsRecV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") True C..| sinkList
490+ liftIO
491+ $ assertEqual
492+ "Objects/Dirs under prefix match recursive failed!"
493+ expectedPrefListingRec
494+ $ extractObjectsFromList prefItemsRecV1
495+
496+ step "Cleanup actions"
497+ forM_ expectedObjects $
498+ \obj -> removeObject bucket obj
499+
500+ step "High-level listIncompleteUploads Test"
501+ let object = "newmpupload"
502+ step "create 10 multipart uploads"
503+ forM_ [1 .. 10 :: Int] $ \_ -> do
504+ uid <- newMultipartUpload bucket object []
374505 liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
375506
376− step "put object parts 1-3"
377− let cps' = def {cpSource = format "/{}/{}" [bucket, srcObj]}
378− parts <- forM [1..3] $ \p -> do
379− (etag', _) <- copyObjectPart bucket copyObj cps'{
380− cpSourceRange = Just ((p-1)*mb5, (p-1)*mb5 + (mb5 - 1))
381− } uid (fromIntegral p) []
382− return (fromIntegral p, etag')
383−
384− step "complete multipart"
385− void $ completeMultipartUpload bucket copyObj uid parts
386−
387− step "verify copied object size"
388− (ObjectInfo _ _ _ s') <- headObject bucket copyObj
389−
390− liftIO $ (s' == mb15) @? "Size failed to match"
391−
392− step "Cleanup actions"
393− removeObject bucket srcObj
394− removeObject bucket copyObj
395−
396− step "copyObject basic tests"
397− let srcs = ["XXX", "XXXL"]
398− copyObjs = ["XXXCopy", "XXXLCopy"]
399− sizes = map (* (1024 * 1024)) [15, 65]
400−
401− step "Prepare"
402− forM_ (zip srcs sizes) $ \(src, size) ->
403− fPutObject bucket src =<< mkRandFile size
404−
405− step "make small and large object copy"
406− forM_ (zip copyObjs srcs) $ \(cp, src) ->
407− copyObject bucket cp def{cpSource = format "/{}/{}" [bucket, src]}
408−
409− step "verify uploaded objects"
410− uploadedSizes <- fmap oiSize <$> forM copyObjs (headObject bucket)
411−
412− liftIO $ (sizes == uploadedSizes) @? "Uploaded obj sizes failed to match"
413−
414− forM_ (srcs ++ copyObjs) (removeObject bucket)
415−
416− step "copyObject with offset test "
417− let src = "XXX"
418− size = 15 * 1024 * 1024
419−
420− step "Prepare"
421− fPutObject bucket src =<< mkRandFile size
422−
423− step "copy last 10MiB of object"
424− copyObject bucket copyObj def{
425− cpSource = format "/{}/{}" [bucket, src]
426− , cpSourceRange = Just (5 * 1024 * 1024, size - 1)
427− }
428−
429− step "verify uploaded object"
430− cSize <- oiSize <$> headObject bucket copyObj
431−
432− liftIO $ (cSize == 10 * 1024 * 1024) @? "Uploaded obj size mismatched!"
433−
434− forM_ [src, copyObj] (removeObject bucket)
435−
436− , presignedUrlFunTest
437− , presignedPostPolicyFunTest
438− ]
439−
440−basicTests :: TestTree
441−basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do
442− step "getService works and contains the test bucket."
443− buckets <- getService
444− unless (length (filter (== bucket) $ map biName buckets) == 1) $
445− liftIO $
446− assertFailure ("The bucket " ++ show bucket ++
447− " was expected to exist.")
448−
449− step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised."
450− mbE <- MC.try $ makeBucket bucket Nothing
451− case mbE of
452− Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou
453− _ -> return ()
454−
455− step "makeBucket with an invalid bucket name and check for appropriate exception."
456− invalidMBE <- MC.try $ makeBucket "invalidBucketName" Nothing
457− case invalidMBE of
458− Left exn -> liftIO $ exn @?= MErrVInvalidBucketName "invalidBucketName"
459− _ -> return ()
460−
461− step "getLocation works"
462− region <- getLocation bucket
463− liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region)
464−
465− step "singlepart putObject works"
466− fPutObject bucket "lsb-release" "/etc/lsb-release"
467−
468− step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception"
469− fpE <- MC.try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release"
470− case fpE of
471− Left exn -> liftIO $ exn @?= NoSuchBucket
472− _ -> return ()
473−
474− outFile <- mkRandFile 0
475− step "simple fGetObject works"
476− fGetObject bucket "lsb-release" outFile
477−
478− step "fGetObject a non-existent object and check for NoSuchKey exception"
479− resE <- MC.try $ fGetObject bucket "noSuchKey" outFile
480− case resE of
481− Left exn -> liftIO $ exn @?= NoSuchKey
482− _ -> return ()
507+ step "High-level listing of incomplete multipart uploads"
508+ uploads <-
509+ C.runConduit $
510+ listIncompleteUploads bucket (Just "newmpupload") True
511+ C..| sinkList
512+ liftIO $ length uploads @?= 10
483513
514+ step "cleanup"
515+ forM_ uploads $ \(UploadInfo _ uid _ _) ->
516+ abortMultipartUpload bucket object uid
484517
485− step "create new multipart upload works"
486− uid <- newMultipartUpload bucket "newmpupload" []
487− liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
518+ step "High-level listIncompleteParts Test"
519+ let mb5 = 5 * 1024 * 1024
488520
489− step "abort a new multipart upload works"
490− abortMultipartUpload bucket "newmpupload" uid
521+ step "create a multipart upload"
522+ uid <- newMultipartUpload bucket object []
523+ liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
491524
492− step "delete object works"
493− deleteObject bucket "lsb-release"
525+ step "put object parts 1..10"
526+ inputFile <- mkRandFile mb5
527+ UIO.withBinaryFile inputFile UIO.ReadMode $ \h ->
528+ forM_ [1 .. 10] $ \pnum ->
529+ putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5
494530
495− step "statObject test"
496− let object = "sample"
497− step "create an object"
498− inputFile <- mkRandFile 0
499− fPutObject bucket object inputFile
531+ step "fetch list parts"
532+ incompleteParts <-
533+ C.runConduit $
534+ listIncompleteParts bucket object uid
535+ C..| sinkList
536+ liftIO $ length incompleteParts @?= 10
500537
501− step "get metadata of the object"
502− res <- statObject bucket object
503− liftIO $ (oiSize res) @?= 0
538+ step "cleanup"
539+ abortMultipartUpload bucket object uid
504540
505− step "delete object"
506− deleteObject bucket object
541+listingTest :: TestTree
542+listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do
543+ step "listObjects' test"
544+ step "put 10 objects"
545+ let objects = (\s -> T.concat ["test-file-", T.pack (show s)]) <$> [1 .. 10 :: Int]
546+
547+ testFilepath <- mkRandFile 200
548+ forM_ [1 .. 10 :: Int] $ \s ->
549+ fPutObject bucket (T.concat ["test-file-", T.pack (show s)]) testFilepath defaultPutObjectOptions
550+
551+ step "Simple list"
552+ res <- listObjects' bucket Nothing Nothing Nothing Nothing
553+ let expectedObjects = sort objects
554+ liftIO $
555+ assertEqual
556+ "Objects match failed!"
557+ expectedObjects
558+ (map oiObject $ lorObjects res)
559+
560+ step "Simple list version 1"
561+ resV1 <- listObjectsV1' bucket Nothing Nothing Nothing Nothing
562+ let expected =
563+ sort $
564+ map
565+ ( T.concat
566+ . ("test-file-" :)
567+ . (: [])
568+ . T.pack
569+ . show
570+ )
571+ [1 .. 10 :: Int]
572+ liftIO $
573+ assertEqual
574+ "Objects match failed!"
575+ expected
576+ (map oiObject $ lorObjects' resV1)
577+
578+ step "Cleanup actions"
579+ forM_ objects $ \obj -> deleteObject bucket obj
580+
581+ step "listIncompleteUploads' test"
582+ step "create 10 multipart uploads"
583+ let object = "newmpupload"
584+ forM_ [1 .. 10 :: Int] $ \_ -> do
585+ uid <- newMultipartUpload bucket object []
586+ liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
587+
588+ step "list incomplete multipart uploads"
589+ incompleteUploads <-
590+ listIncompleteUploads'
591+ bucket
592+ (Just "newmpupload")
593+ Nothing
594+ Nothing
595+ Nothing
596+ Nothing
597+ liftIO $ length (lurUploads incompleteUploads) @?= 10
598+
599+ step "cleanup"
600+ forM_ (lurUploads incompleteUploads) $
601+ \(_, uid, _) -> abortMultipartUpload bucket object uid
602+
603+ step "Basic listIncompleteParts Test"
604+ let mb5 = 5 * 1024 * 1024
605+
606+ step "create a multipart upload"
607+ uid <- newMultipartUpload bucket object []
608+ liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
609+
610+ step "put object parts 1..10"
611+ inputFile <- mkRandFile mb5
612+ UIO.withBinaryFile inputFile UIO.ReadMode $ \h ->
613+ forM_ [1 .. 10] $ \pnum ->
614+ putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5
615+
616+ step "fetch list parts"
617+ listPartsResult <- listIncompleteParts' bucket object uid Nothing Nothing
618+ liftIO $ length (lprParts listPartsResult) @?= 10
619+ abortMultipartUpload bucket object uid
507620
508621presignedUrlFunTest :: TestTree
509622presignedUrlFunTest = funTestWithBucket "presigned Url tests" $
@@ -515,97 +628,120 @@ presignedUrlFunTest = funTestWithBucket "presigned Url tests" $
515628 mgr <- liftIO $ NC.newManager NC.tlsManagerSettings
516629
517630 step "PUT object presigned URL - makePresignedUrl"
518− putUrl <- makePresignedUrl 3600 HT.methodPut (Just bucket)
519− (Just obj) (Just "us-east-1") [] []
520−
631+ putUrl <-
632+ makePresignedUrl
633+ 3600
634+ HT.methodPut
635+ (Just bucket)
636+ (Just obj)
637+ (Just "us-east-1")
638+ []
639+ []
640+
641+ -- print putUrl
521642 let size1 = 1000 :: Int64
522643 inputFile <- mkRandFile size1
523644
524645 -- attempt to upload using the presigned URL
525646 putResp <- putR size1 inputFile mgr putUrl
526− liftIO $ (NC.responseStatus putResp == HT.status200) @?
527− "presigned PUT failed"
647+ liftIO $
648+ (NC.responseStatus putResp == HT.status200)
649+ @? "presigned PUT failed"
528650
529651 step "GET object presigned URL - makePresignedUrl"
530− getUrl <- makePresignedUrl 3600 HT.methodGet (Just bucket)
531− (Just obj) (Just "us-east-1") [] []
652+ getUrl <-
653+ makePresignedUrl
654+ 3600
655+ HT.methodGet
656+ (Just bucket)
657+ (Just obj)
658+ (Just "us-east-1")
659+ []
660+ []
532661
533662 getResp <- getR mgr getUrl
534− liftIO $ (NC.responseStatus getResp == HT.status200) @?
535− "presigned GET failed"
663+ liftIO $
664+ (NC.responseStatus getResp == HT.status200)
665+ @? "presigned GET failed"
536666
537667 -- read content from file to compare with response above
538− bs <- CB.sourceFile inputFile $$ CB.sinkLbs
539− liftIO $ (bs == NC.responseBody getResp) @?
540− "presigned put and get got mismatched data"
668+ bs <- C.runConduit $ CB.sourceFile inputFile C..| CB.sinkLbs
669+ liftIO $
670+ (bs == NC.responseBody getResp)
671+ @? "presigned put and get got mismatched data"
541672
542673 step "PUT object presigned - presignedPutObjectURL"
543− putUrl2 <- presignedPutObjectUrl bucket obj2 3600 []
674+ putUrl2 <- presignedPutObjectUrl bucket obj2 604800 []
544675
545676 let size2 = 1200
546677 testFile <- mkRandFile size2
547678
548679 putResp2 <- putR size2 testFile mgr putUrl2
549− liftIO $ (NC.responseStatus putResp2 == HT.status200) @?
550− "presigned PUT failed (presignedPutObjectUrl)"
680+ liftIO $
681+ (NC.responseStatus putResp2 == HT.status200)
682+ @? "presigned PUT failed (presignedPutObjectUrl)"
551683
552684 step "HEAD object presigned URL - presignedHeadObjectUrl"
553685 headUrl <- presignedHeadObjectUrl bucket obj2 3600 []
554686
555− headResp <- do req <- NC.parseRequest $ toS headUrl
556− NC.httpLbs (req {NC.method = HT.methodHead}) mgr
557− liftIO $ (NC.responseStatus headResp == HT.status200) @?
558− "presigned HEAD failed (presignedHeadObjectUrl)"
687+ headResp <- do
688+ let req = NC.parseRequest_ $ decodeUtf8 headUrl
689+ NC.httpLbs (req {NC.method = HT.methodHead}) mgr
690+ liftIO $
691+ (NC.responseStatus headResp == HT.status200)
692+ @? "presigned HEAD failed (presignedHeadObjectUrl)"
559693
560694 -- check that header info is accurate
561− let h = Map.fromList $ NC.responseHeaders headResp
562− cLen = Map.findWithDefault "0" HT.hContentLength h
563− liftIO $ (cLen == show size2) @? "Head req returned bad content length"
695+ let h = H.fromList $ NC.responseHeaders headResp
696+ cLen = H.lookupDefault "0" HT.hContentLength h
697+ liftIO $ (cLen == showBS size2) @? "Head req returned bad content length"
564698
565699 step "GET object presigned URL - presignedGetObjectUrl"
566700 getUrl2 <- presignedGetObjectUrl bucket obj2 3600 [] []
567701
568702 getResp2 <- getR mgr getUrl2
569− liftIO $ (NC.responseStatus getResp2 == HT.status200) @?
570− "presigned GET failed (presignedGetObjectUrl)"
703+ liftIO $
704+ (NC.responseStatus getResp2 == HT.status200)
705+ @? "presigned GET failed (presignedGetObjectUrl)"
571706
572707 -- read content from file to compare with response above
573− bs2 <- CB.sourceFile testFile $$ CB.sinkLbs
574− liftIO $ (bs2 == NC.responseBody getResp2) @?
575− "presigned put and get got mismatched data (presigned*Url)"
576−
708+ bs2 <- C.runConduit $ CB.sourceFile testFile C..| CB.sinkLbs
709+ liftIO $
710+ (bs2 == NC.responseBody getResp2)
711+ @? "presigned put and get got mismatched data (presigned*Url)"
577712
578713 mapM_ (removeObject bucket) [obj, obj2]
579714 where
580715 putR size filePath mgr url = do
581− req <- NC.parseRequest $ toS url
582− let req' = req { NC.method = HT.methodPut
583− , NC.requestBody = NC.requestBodySource size $
584− CB.sourceFile filePath}
716+ let req = NC.parseRequest_ $ decodeUtf8 url
717+ let req' =
718+ req
719+ { NC.method = HT.methodPut,
720+ NC.requestBody =
721+ NC.requestBodySource size $
722+ CB.sourceFile filePath
723+ }
585724 NC.httpLbs req' mgr
586−
587725 getR mgr url = do
588− req <- NC.parseRequest $ toS url
726+ let req = NC.parseRequest_ $ decodeUtf8 url
589727 NC.httpLbs req mgr
590728
591729presignedPostPolicyFunTest :: TestTree
592−presignedPostPolicyFunTest = funTestWithBucket "Presigned Post Policy tests" $
730+presignedPostPolicyFunTest = funTestWithBucketNoSTS "Presigned Post Policy tests" $
593731 \step bucket -> do
594−
595732 step "presignedPostPolicy basic test"
596− now <- liftIO $ Time.getCurrentTime
733+ now <- liftIO Time.getCurrentTime
597734
598735 let key = "presignedPostPolicyTest/myfile"
599− policyConds = [ ppCondBucket bucket
600− , ppCondKey key
601− , ppCondContentLengthRange 1 1000
602− , ppCondContentType "application/octet-stream"
603− , ppCondSuccessActionStatus 200
604− ]
605−
736+ policyConds =
737+ [ ppCondBucket bucket,
738+ ppCondKey key,
739+ ppCondContentLengthRange 1 1000,
740+ ppCondContentType "application/octet-stream",
741+ ppCondSuccessActionStatus 200
742+ ]
606743 expirationTime = Time.addUTCTime 3600 now
607744 postPolicyE = newPostPolicy expirationTime policyConds
608−
609745 size = 1000 :: Int64
610746
611747 inputFile <- mkRandFile size
@@ -616,17 +752,532 @@ presignedPostPolicyFunTest = funTestWithBucket "Presigned Post Policy tests" $
616752 (url, formData) <- presignedPostPolicy postPolicy
617753 -- liftIO (print url) >> liftIO (print formData)
618754 result <- liftIO $ postForm url formData inputFile
619− liftIO $ (NC.responseStatus result == HT.status200) @?
620− "presigned POST failed"
755+ liftIO $
756+ (NC.responseStatus result == HT.status200)
757+ @? "presigned POST failed"
621758
622759 mapM_ (removeObject bucket) [key]
623− where
624−
625− postForm url formData inputFile = do
626− req <- NC.parseRequest $ toS url
627− let parts = map (\(x, y) -> Form.partBS x y) $
628− Map.toList formData
629− parts' = parts ++ [Form.partFile "file" inputFile]
630− req' <- Form.formDataBody parts' req
631− mgr <- NC.newManager NC.tlsManagerSettings
632− NC.httpLbs req' mgr
760+ where
761+ postForm url formData inputFile = do
762+ req <- NC.parseRequest $ decodeUtf8 url
763+ let parts =
764+ map (uncurry Form.partBS) $
765+ H.toList formData
766+ parts' = parts ++ [Form.partFile "file" inputFile]
767+ req' <- Form.formDataBody parts' req
768+ mgr <- NC.newManager NC.tlsManagerSettings
769+ NC.httpLbs req' mgr
770+
771+bucketPolicyFunTest :: TestTree
772+bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $
773+ \step bucket -> do
774+ step "bucketPolicy basic test - no policy exception"
775+ resE <- try $ getBucketPolicy bucket
776+ case resE of
777+ Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist"
778+ _ -> return ()
779+
780+ resE' <- try $ setBucketPolicy bucket T.empty
781+ case resE' of
782+ Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist"
783+ _ -> return ()
784+
785+ let expectedPolicyJSON = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket\"]},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket/*\"]}]}"
786+
787+ step "try a malformed policy, expect error"
788+ resE'' <- try $ setBucketPolicy bucket expectedPolicyJSON
789+ case resE'' of
790+ Left exn -> liftIO $ exn @?= ServiceErr "MalformedPolicy" "bucket name does not match"
791+ _ -> return ()
792+
793+ let expectedPolicyJSON' = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "\"]},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "/*\"]}]}"
794+
795+ step "set bucket policy"
796+ setBucketPolicy bucket expectedPolicyJSON'
797+
798+ let obj = "myobject"
799+
800+ step "verify bucket policy: (1) create `myobject`"
801+ putObject bucket obj (replicateC 100 "c") Nothing defaultPutObjectOptions
802+
803+ step "verify bucket policy: (2) get `myobject` anonymously"
804+ connInfo <- asks mcConnInfo
805+ let proto = bool "http://" "https://" $ connectIsSecure connInfo
806+ url =
807+ BS.concat
808+ [ proto,
809+ getHostAddr connInfo,
810+ "/",
811+ encodeUtf8 bucket,
812+ "/",
813+ encodeUtf8 obj
814+ ]
815+ respE <-
816+ liftIO $
817+ fmap (Right . toStrictBS) (NC.simpleHttp $ decodeUtf8 url)
818+ `catch` (\(e :: NC.HttpException) -> return $ Left (show e :: Text))
819+ case respE of
820+ Left err -> liftIO $ assertFailure $ show err
821+ Right s -> liftIO $ s @?= BS.concat (replicate 100 "c")
822+
823+ deleteObject bucket obj
824+
825+ step "delete bucket policy"
826+ setBucketPolicy bucket T.empty
827+
828+multipartTest :: TestTree
829+multipartTest = funTestWithBucket "Multipart Tests" $
830+ \step bucket -> do
831+ -- Commenting out test since it's platform specific.
832+ -- FIXME: Need to find a platform agnostic way to test this.
833+ -- step "Prepare for putObjectInternal with non-seekable file, with size."
834+ -- step "Upload multipart file."
835+ -- let mb80 = 80 * 1024 * 1024
836+ -- obj = "mpart"
837+
838+ -- void $ putObjectInternal bucket obj defaultPutObjectOptions $ ODFile "/dev/zero" (Just mb80)
839+
840+ -- step "Retrieve and verify file size"
841+ -- destFile <- mkRandFile 0
842+ -- fGetObject bucket obj destFile defaultGetObjectOptions
843+ -- gotSize <- withNewHandle destFile getFileSize
844+ -- liftIO $
845+ -- gotSize == Right (Just mb80)
846+ -- @? "Wrong file size of put file after getting"
847+
848+ -- step "Cleanup actions"
849+ -- removeObject bucket obj
850+
851+ -- step "cleanup"
852+ -- removeObject bucket "big"
853+
854+ step "Prepare for removeIncompleteUpload"
855+ -- low-level multipart operation tests.
856+ let object = "newmpupload"
857+ kb5 = 5 * 1024
858+
859+ step "create new multipart upload"
860+ uid <- newMultipartUpload bucket object []
861+ liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
862+
863+ randFile <- mkRandFile kb5
864+
865+ step "upload 2 parts"
866+ forM_ [1, 2] $ \partNum -> do
867+ UIO.withBinaryFile randFile UIO.ReadMode $ \h ->
868+ void $ putObjectPart bucket object uid partNum [] $ PayloadH h 0 kb5
869+
870+ step "remove ongoing upload"
871+ removeIncompleteUpload bucket object
872+ uploads <-
873+ C.runConduit $
874+ listIncompleteUploads bucket (Just object) False
875+ C..| sinkList
876+ liftIO $ null uploads @? "removeIncompleteUploads didn't complete successfully"
877+
878+putObjectContentTypeTest :: TestTree
879+putObjectContentTypeTest = funTestWithBucket "putObject contentType tests" $
880+ \step bucket -> do
881+ step "fPutObject content type test"
882+ let object = "xxx-content-type"
883+ size1 = 100 :: Int64
884+
885+ step "create server object with content-type"
886+ inputFile <- mkRandFile size1
887+ fPutObject
888+ bucket
889+ object
890+ inputFile
891+ defaultPutObjectOptions
892+ { pooContentType = Just "application/javascript"
893+ }
894+
895+ -- retrieve obj info to check
896+ oi <- headObject bucket object []
897+ let m = oiMetadata oi
898+
899+ step "Validate content-type"
900+ liftIO $ assertEqual "Content-Type did not match" (Just "application/javascript") (H.lookup "Content-Type" m)
901+
902+ step "upload object with content-encoding set to identity"
903+ fPutObject
904+ bucket
905+ object
906+ inputFile
907+ defaultPutObjectOptions
908+ { pooContentEncoding = Just "identity"
909+ }
910+
911+ oiCE <- headObject bucket object []
912+ let m' = oiMetadata oiCE
913+
914+ step "Validate content-encoding"
915+ liftIO $
916+ assertEqual
917+ "Content-Encoding did not match"
918+ (Just "identity")
919+ (H.lookup "Content-Encoding" m')
920+
921+ step "Cleanup actions"
922+
923+ removeObject bucket object
924+
925+putObjectContentLanguageTest :: TestTree
926+putObjectContentLanguageTest = funTestWithBucket "putObject contentLanguage tests" $
927+ \step bucket -> do
928+ step "fPutObject content language test"
929+ let object = "xxx-content-language"
930+ size1 = 100 :: Int64
931+
932+ step "create server object with content-language"
933+ inputFile <- mkRandFile size1
934+ fPutObject
935+ bucket
936+ object
937+ inputFile
938+ defaultPutObjectOptions
939+ { pooContentLanguage = Just "en-US"
940+ }
941+
942+ -- retrieve obj info to check
943+ oi <- headObject bucket object []
944+ let m = oiMetadata oi
945+
946+ step "Validate content-language"
947+ liftIO $
948+ assertEqual
949+ "content-language did not match"
950+ (Just "en-US")
951+ (H.lookup "Content-Language" m)
952+ step "Cleanup actions"
953+
954+ removeObject bucket object
955+
956+putObjectUserMetadataTest :: TestTree
957+putObjectUserMetadataTest = funTestWithBucket "putObject user-metadata test" $
958+ \step bucket -> do
959+ step "putObject user-metadata test"
960+ let object = "object-with-metadata"
961+ size1 = 100 :: Int64
962+
963+ step "create server object with usermetdata"
964+ inputFile <- mkRandFile size1
965+
966+ fPutObject
967+ bucket
968+ object
969+ inputFile
970+ defaultPutObjectOptions
971+ { pooUserMetadata =
972+ [ ("x-Amz-meta-mykey1", "myval1"),
973+ ("mykey2", "myval2")
974+ ]
975+ }
976+
977+ step "Validate user-metadata"
978+ -- retrieve obj info to check
979+ oi <- headObject bucket object []
980+ let m = oiUserMetadata oi
981+ -- need to do a case-insensitive comparison
982+ sortedMeta =
983+ sort $
984+ map (bimap T.toLower T.toLower) $
985+ H.toList m
986+ ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]
987+
988+ liftIO $ (sortedMeta == ref) @? "Metadata mismatch!"
989+
990+ step "Cleanup actions"
991+ removeObject bucket object
992+
993+getObjectTest :: TestTree
994+getObjectTest = funTestWithBucket "getObject test" $
995+ \step bucket -> do
996+ step "putObject with some metadata"
997+ let object = "object-with-metadata"
998+ size1 = 100 :: Int64
999+
1000+ inputFile <- mkRandFile size1
1001+ fPutObject
1002+ bucket
1003+ object
1004+ inputFile
1005+ defaultPutObjectOptions
1006+ { pooUserMetadata =
1007+ [ ("x-Amz-meta-mykey1", "myval1"),
1008+ ("mykey2", "myval2")
1009+ ]
1010+ }
1011+
1012+ step "get the object - check the metadata matches"
1013+ -- retrieve obj info to check
1014+ gor <- getObject bucket object defaultGetObjectOptions
1015+ let m = oiUserMetadata $ gorObjectInfo gor
1016+ -- need to do a case-insensitive comparison
1017+ sortedMeta =
1018+ sort $
1019+ map (bimap T.toLower T.toLower) $
1020+ H.toList m
1021+ ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]
1022+
1023+ liftIO $ (sortedMeta == ref) @? "Metadata mismatch!"
1024+
1025+ step "get the object content"
1026+ getObjectHash <- hashSHA256FromSource $ gorObjectStream gor
1027+ inputHash <- hashSHA256FromSource $ C.sourceFile inputFile
1028+ liftIO $ (getObjectHash == inputHash) @? "Input file and output file mismatched!"
1029+
1030+ step "Cleanup actions"
1031+ removeObject bucket object
1032+
1033+putObjectStorageClassTest :: TestTree
1034+putObjectStorageClassTest = funTestWithBucket "putObject storageClass tests" $
1035+ \step bucket -> do
1036+ step "fPutObject storage class test"
1037+ let object = "xxx-storage-class-standard"
1038+ object' = "xxx-storage-class-reduced"
1039+ object'' = "xxx-storage-class-invalid"
1040+ size1 = 100 :: Int64
1041+ size0 = 0 :: Int64
1042+
1043+ step "create server objects with storageClass"
1044+ inputFile <- mkRandFile size1
1045+ inputFile' <- mkRandFile size1
1046+ inputFile'' <- mkRandFile size0
1047+
1048+ fPutObject
1049+ bucket
1050+ object
1051+ inputFile
1052+ defaultPutObjectOptions
1053+ { pooStorageClass = Just "STANDARD"
1054+ }
1055+
1056+ fPutObject
1057+ bucket
1058+ object'
1059+ inputFile'
1060+ defaultPutObjectOptions
1061+ { pooStorageClass = Just "REDUCED_REDUNDANCY"
1062+ }
1063+
1064+ removeObject bucket object
1065+
1066+ -- retrieve obj info to check
1067+ oi' <- headObject bucket object' []
1068+ let m' = oiMetadata oi'
1069+
1070+ step "Validate x-amz-storage-class rrs"
1071+ liftIO $
1072+ assertEqual
1073+ "storageClass did not match"
1074+ (Just "REDUCED_REDUNDANCY")
1075+ (H.lookup "X-Amz-Storage-Class" m')
1076+
1077+ fpE <-
1078+ try $
1079+ fPutObject
1080+ bucket
1081+ object''
1082+ inputFile''
1083+ defaultPutObjectOptions
1084+ { pooStorageClass = Just "INVALID_STORAGE_CLASS"
1085+ }
1086+ case fpE of
1087+ Left exn -> liftIO $ exn @?= ServiceErr "InvalidStorageClass" "Invalid storage class."
1088+ _ -> return ()
1089+
1090+ step "Cleanup actions"
1091+
1092+ removeObject bucket object'
1093+
1094+copyObjectTests :: TestTree
1095+copyObjectTests = funTestWithBucket "copyObject related tests" $
1096+ \step bucket -> do
1097+ step "copyObjectSingle basic tests"
1098+ let object = "xxx"
1099+ objCopy = "xxxCopy"
1100+ size1 = 100 :: Int64
1101+
1102+ step "create server object to copy"
1103+ inputFile <- mkRandFile size1
1104+ fPutObject bucket object inputFile defaultPutObjectOptions
1105+
1106+ step "copy object"
1107+ let srcInfo = defaultSourceInfo {srcBucket = bucket, srcObject = object}
1108+ (etag, modTime) <- copyObjectSingle bucket objCopy srcInfo []
1109+
1110+ -- retrieve obj info to check
1111+ oi <- headObject bucket objCopy []
1112+ let t = oiModTime oi
1113+ let e = oiETag oi
1114+ let s = oiSize oi
1115+
1116+ let isMTimeDiffOk = abs (diffUTCTime modTime t) < 1.0
1117+
1118+ liftIO $
1119+ (s == size1 && e == etag && isMTimeDiffOk)
1120+ @? "Copied object did not match expected."
1121+
1122+ step "cleanup actions"
1123+ removeObject bucket object
1124+ removeObject bucket objCopy
1125+
1126+ step "copyObjectPart basic tests"
1127+ let srcObj = "XXX"
1128+ copyObj = "XXXCopy"
1129+
1130+ step "Prepare"
1131+ let mb15 = 15 * 1024 * 1024
1132+ mb5 = 5 * 1024 * 1024
1133+ randFile <- mkRandFile mb15
1134+ fPutObject bucket srcObj randFile defaultPutObjectOptions
1135+
1136+ step "create new multipart upload"
1137+ uid <- newMultipartUpload bucket copyObj []
1138+ liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
1139+
1140+ step "put object parts 1-3"
1141+ let srcInfo' = defaultSourceInfo {srcBucket = bucket, srcObject = srcObj}
1142+ dstInfo' = defaultDestinationInfo {dstBucket = bucket, dstObject = copyObj}
1143+ parts <- forM [1 .. 3] $ \p -> do
1144+ (etag', _) <-
1145+ copyObjectPart
1146+ dstInfo'
1147+ srcInfo'
1148+ { srcRange = Just $ (,) ((p - 1) * mb5) ((p - 1) * mb5 + (mb5 - 1))
1149+ }
1150+ uid
1151+ (fromIntegral p)
1152+ []
1153+ return (fromIntegral p, etag')
1154+
1155+ step "complete multipart"
1156+ void $ completeMultipartUpload bucket copyObj uid parts
1157+
1158+ step "verify copied object size"
1159+ oi' <- headObject bucket copyObj []
1160+ let s' = oiSize oi'
1161+
1162+ liftIO $ (s' == mb15) @? "Size failed to match"
1163+
1164+ step "Cleanup actions"
1165+ removeObject bucket srcObj
1166+ removeObject bucket copyObj
1167+
1168+ step "copyObject basic tests"
1169+ let srcs = ["XXX", "XXXL"]
1170+ copyObjs = ["XXXCopy", "XXXLCopy"]
1171+ sizes = map (* (1024 * 1024)) [15, 65]
1172+
1173+ step "Prepare"
1174+ forM_ (zip srcs sizes) $ \(src, size) -> do
1175+ inputFile' <- mkRandFile size
1176+ fPutObject bucket src inputFile' defaultPutObjectOptions
1177+
1178+ step "make small and large object copy"
1179+ forM_ (zip copyObjs srcs) $ \(cp, src) ->
1180+ copyObject defaultDestinationInfo {dstBucket = bucket, dstObject = cp} defaultSourceInfo {srcBucket = bucket, srcObject = src}
1181+
1182+ step "verify uploaded objects"
1183+ uploadedSizes <- fmap oiSize <$> forM copyObjs (\o -> headObject bucket o [])
1184+
1185+ liftIO $ (sizes == uploadedSizes) @? "Uploaded obj sizes failed to match"
1186+
1187+ forM_ (srcs ++ copyObjs) (removeObject bucket)
1188+
1189+ step "copyObject with offset test "
1190+ let src = "XXX"
1191+ size = 15 * 1024 * 1024
1192+
1193+ step "Prepare"
1194+ inputFile' <- mkRandFile size
1195+ fPutObject bucket src inputFile' defaultPutObjectOptions
1196+
1197+ step "copy last 10MiB of object"
1198+ copyObject
1199+ defaultDestinationInfo {dstBucket = bucket, dstObject = copyObj}
1200+ defaultSourceInfo
1201+ { srcBucket = bucket,
1202+ srcObject = src,
1203+ srcRange = Just $ (,) (5 * 1024 * 1024) (size - 1)
1204+ }
1205+
1206+ step "verify uploaded object"
1207+ cSize <- oiSize <$> headObject bucket copyObj []
1208+
1209+ liftIO $ (cSize == 10 * 1024 * 1024) @? "Uploaded obj size mismatched!"
1210+
1211+ forM_ [src, copyObj] (removeObject bucket)
1212+
1213+getNPutSSECTest :: TestTree
1214+getNPutSSECTest =
1215+ funTestWithBucket "Get and Put SSE-C Test" $ \step bucket -> do
1216+ -- Skip this test if the server is not using TLS as encryption is
1217+ -- disabled anyway.
1218+ isTLSConn <- asks (connectIsSecure . mcConnInfo)
1219+ if isTLSConn
1220+ then do
1221+ step "Make an encryption key"
1222+ key <- case mkSSECKey $ BS.pack [0 .. 31] of
1223+ Nothing -> liftIO $ assertFailure "This should not happen"
1224+ Just k -> return k
1225+
1226+ let mb1 = 1024 * 1024
1227+ obj = "1"
1228+ step "Upload an object using the encryption key"
1229+ rFile <- mkRandFile mb1
1230+ let putOpts = defaultPutObjectOptions {pooSSE = Just $ SSEC key}
1231+ fPutObject bucket obj rFile putOpts
1232+
1233+ step "Stat object without key - should fail"
1234+ headRes <- try $ statObject bucket obj defaultGetObjectOptions
1235+ case headRes of
1236+ Right _ -> liftIO $ assertFailure "Cannot perform head object on encrypted object without specifying key"
1237+ Left ex@(NC.HttpExceptionRequest _ (NC.StatusCodeException rsp _))
1238+ | NC.responseStatus rsp == HT.status400 -> return ()
1239+ | otherwise -> liftIO $ assertFailure $ "Unexpected err: " ++ show ex
1240+ Left ex -> liftIO $ assertFailure $ "Unexpected err: " ++ show ex
1241+
1242+ step "Get file and check length"
1243+ dstFile <- mkRandFile 0
1244+ let getOpts = defaultGetObjectOptions {gooSSECKey = Just key}
1245+ fGetObject bucket obj dstFile getOpts
1246+
1247+ gotSize <- withNewHandle dstFile getFileSize
1248+ liftIO $
1249+ gotSize
1250+ == Right (Just mb1)
1251+ @? "Wrong file size of object when getting"
1252+
1253+ step "Cleanup"
1254+ deleteObject bucket obj
1255+ else step "Skipping encryption test as server is not using TLS"
1256+
1257+assumeRoleRequestTest :: TestTree
1258+assumeRoleRequestTest = testCaseSteps "Assume Role STS API" $ \step -> do
1259+ step "Load credentials"
1260+ (_, (ak, sk)) <- lookupTestEnv
1261+ val <- Env.lookupEnv "MINIO_LOCAL"
1262+ isSecure <- Env.lookupEnv "MINIO_SECURE"
1263+ let localMinioCred = Just $ CredentialValue ak sk mempty
1264+ playCreds =
1265+ case connectCreds minioPlayCI of
1266+ CredsStatic c -> Just c
1267+ _ -> Nothing
1268+ (cvMay, loc) =
1269+ case (val, isSecure) of
1270+ (Just _, Just _) -> (localMinioCred, "https://localhost:9000")
1271+ (Just _, Nothing) -> (localMinioCred, "http://localhost:9000")
1272+ (Nothing, _) -> (playCreds, "https://play.min.io:9000")
1273+ cv <- maybe (assertFailure "bad creds") return cvMay
1274+ let assumeRole =
1275+ STSAssumeRole cv $
1276+ defaultSTSAssumeRoleOptions
1277+ { saroLocation = Just "us-east-1",
1278+ saroEndpoint = Just loc
1279+ }
1280+ step "AssumeRole request"
1281+ res <- requestSTSCredential assumeRole
1282+ let v = credentialValueText $ fst res
1283+ print (v, snd res)