835 lines
30 KiB
Haskell
835 lines
30 KiB
Haskell
--
|
|
-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc.
|
|
--
|
|
-- Licensed under the Apache License, Version 2.0 (the "License");
|
|
-- you may not use this file except in compliance with the License.
|
|
-- You may obtain a copy of the License at
|
|
--
|
|
-- http://www.apache.org/licenses/LICENSE-2.0
|
|
--
|
|
-- Unless required by applicable law or agreed to in writing, software
|
|
-- distributed under the License is distributed on an "AS IS" BASIS,
|
|
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
-- See the License for the specific language governing permissions and
|
|
-- limitations under the License.
|
|
--
|
|
|
|
import qualified Test.QuickCheck as Q
|
|
import Test.Tasty
|
|
import Test.Tasty.HUnit
|
|
import Test.Tasty.QuickCheck as QC
|
|
|
|
import Conduit (replicateC)
|
|
import qualified Control.Monad.Catch as MC
|
|
import qualified Control.Monad.Trans.Resource as R
|
|
import qualified Data.ByteString as BS
|
|
import Data.Conduit (yield)
|
|
import qualified Data.Conduit as C
|
|
import qualified Data.Conduit.Binary as CB
|
|
import Data.Conduit.Combinators (sinkList)
|
|
import Data.Default (Default (..))
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Text as T
|
|
import Data.Time (fromGregorian)
|
|
import qualified Data.Time as Time
|
|
import qualified Network.HTTP.Client.MultipartFormData as Form
|
|
import qualified Network.HTTP.Conduit as NC
|
|
import qualified Network.HTTP.Types as HT
|
|
import System.Directory (getTemporaryDirectory)
|
|
import System.Environment (lookupEnv)
|
|
import qualified System.IO as SIO
|
|
|
|
import Lib.Prelude
|
|
|
|
import Network.Minio
|
|
import Network.Minio.Data
|
|
import Network.Minio.PutObject
|
|
import Network.Minio.S3API
|
|
import Network.Minio.Utils
|
|
|
|
main :: IO ()
|
|
main = defaultMain tests
|
|
|
|
tests :: TestTree
|
|
tests = testGroup "Tests" [liveServerUnitTests]
|
|
|
|
-- conduit that generates random binary stream of given length
|
|
randomDataSrc :: MonadIO m => Int64 -> C.ConduitM () ByteString m ()
|
|
randomDataSrc s' = genBS s'
|
|
where
|
|
concatIt bs n = BS.concat $ replicate (fromIntegral q) bs ++
|
|
[BS.take (fromIntegral r) bs]
|
|
where (q, r) = n `divMod` fromIntegral (BS.length bs)
|
|
|
|
genBS s = do
|
|
w8s <- liftIO $ generate $ Q.vectorOf 64 (Q.choose (0, 255))
|
|
let byteArr64 = BS.pack w8s
|
|
if s < oneMiB
|
|
then yield $ concatIt byteArr64 s
|
|
else do yield $ concatIt byteArr64 oneMiB
|
|
genBS (s - oneMiB)
|
|
|
|
mkRandFile :: R.MonadResource m => Int64 -> m FilePath
|
|
mkRandFile size = do
|
|
dir <- liftIO $ getTemporaryDirectory
|
|
C.runConduit $ randomDataSrc size C..| CB.sinkTempFile dir "miniohstest.random"
|
|
|
|
funTestBucketPrefix :: Text
|
|
funTestBucketPrefix = "miniohstest-"
|
|
|
|
funTestWithBucket :: TestName
|
|
-> (([Char] -> Minio ()) -> Bucket -> Minio ()) -> TestTree
|
|
funTestWithBucket t minioTest = testCaseSteps t $ \step -> do
|
|
-- generate a random name for the bucket
|
|
bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z'))
|
|
let b = T.concat [funTestBucketPrefix, T.pack bktSuffix]
|
|
liftStep = liftIO . step
|
|
connInfo <- maybe minioPlayCI (const def) <$> lookupEnv "MINIO_LOCAL"
|
|
ret <- runMinio connInfo $ do
|
|
liftStep $ "Creating bucket for test - " ++ t
|
|
foundBucket <- bucketExists b
|
|
liftIO $ foundBucket @?= False
|
|
makeBucket b def
|
|
minioTest liftStep b
|
|
deleteBucket b
|
|
isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)
|
|
|
|
lowLevelMultipartTest :: TestTree
|
|
lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $
|
|
\step bucket -> do
|
|
-- low-level multipart operation tests.
|
|
let object = "newmpupload"
|
|
mb15 = 15 * 1024 * 1024
|
|
|
|
step "Prepare for low-level multipart tests."
|
|
step "create new multipart upload"
|
|
uid <- newMultipartUpload bucket object []
|
|
liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
|
|
|
|
randFile <- mkRandFile mb15
|
|
|
|
step "put object parts 1 of 1"
|
|
h <- liftIO $ SIO.openBinaryFile randFile SIO.ReadMode
|
|
partInfo <- putObjectPart bucket object uid 1 [] $ PayloadH h 0 mb15
|
|
|
|
step "complete multipart"
|
|
void $ completeMultipartUpload bucket object uid [partInfo]
|
|
|
|
destFile <- mkRandFile 0
|
|
step "Retrieve the created object and check size"
|
|
fGetObject bucket object destFile def
|
|
gotSize <- withNewHandle destFile getFileSize
|
|
liftIO $ gotSize == Right (Just mb15) @?
|
|
"Wrong file size of put file after getting"
|
|
|
|
step "Cleanup actions"
|
|
removeObject bucket object
|
|
|
|
putObjectSizeTest :: TestTree
|
|
putObjectSizeTest = funTestWithBucket "PutObject of conduit source with size" $
|
|
\step bucket -> do
|
|
-- putObject test (conduit source, size specified)
|
|
let obj = "msingle"
|
|
mb1 = 1 * 1024 * 1024
|
|
|
|
step "Prepare for putObject with from source with size."
|
|
rFile <- mkRandFile mb1
|
|
|
|
step "Upload single file."
|
|
putObject bucket obj (CB.sourceFile rFile) (Just mb1) def
|
|
|
|
step "Retrieve and verify file size"
|
|
destFile <- mkRandFile 0
|
|
fGetObject bucket obj destFile def
|
|
gotSize <- withNewHandle destFile getFileSize
|
|
liftIO $ gotSize == Right (Just mb1) @?
|
|
"Wrong file size of put file after getting"
|
|
|
|
step "Cleanup actions"
|
|
deleteObject bucket obj
|
|
|
|
putObjectNoSizeTest :: TestTree
|
|
putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no size" $
|
|
\step bucket -> do
|
|
-- putObject test (conduit source, no size specified)
|
|
let obj = "mpart"
|
|
mb70 = 70 * 1024 * 1024
|
|
|
|
step "Prepare for putObject with from source without providing size."
|
|
rFile <- mkRandFile mb70
|
|
|
|
step "Upload multipart file."
|
|
putObject bucket obj (CB.sourceFile rFile) Nothing def
|
|
|
|
step "Retrieve and verify file size"
|
|
destFile <- mkRandFile 0
|
|
fGetObject bucket obj destFile def
|
|
gotSize <- withNewHandle destFile getFileSize
|
|
liftIO $ gotSize == Right (Just mb70) @?
|
|
"Wrong file size of put file after getting"
|
|
|
|
step "Cleanup actions"
|
|
deleteObject bucket obj
|
|
|
|
highLevelListingTest :: TestTree
|
|
highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
|
|
\step bucket -> do
|
|
step "High-level listObjects Test"
|
|
step "put 3 objects"
|
|
let expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3"]
|
|
forM_ expectedObjects $
|
|
\obj -> fPutObject bucket obj "/etc/lsb-release" def
|
|
|
|
step "High-level listing of objects"
|
|
objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList
|
|
|
|
liftIO $ assertEqual "Objects match failed!" (sort expectedObjects)
|
|
(map oiObject objects)
|
|
|
|
step "High-level listing of objects (version 1)"
|
|
objectsV1 <- C.runConduit $ listObjectsV1 bucket Nothing True C..|
|
|
sinkList
|
|
|
|
liftIO $ assertEqual "Objects match failed!" (sort expectedObjects)
|
|
(map oiObject objectsV1)
|
|
|
|
step "Cleanup actions"
|
|
forM_ expectedObjects $
|
|
\obj -> removeObject bucket obj
|
|
|
|
step "High-level listIncompleteUploads Test"
|
|
let object = "newmpupload"
|
|
step "create 10 multipart uploads"
|
|
forM_ [1..10::Int] $ \_ -> do
|
|
uid <- newMultipartUpload bucket object []
|
|
liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
|
|
|
|
step "High-level listing of incomplete multipart uploads"
|
|
uploads <- C.runConduit $
|
|
listIncompleteUploads bucket (Just "newmpupload") True C..|
|
|
sinkList
|
|
liftIO $ length uploads @?= 10
|
|
|
|
step "cleanup"
|
|
forM_ uploads $ \(UploadInfo _ uid _ _) ->
|
|
abortMultipartUpload bucket object uid
|
|
|
|
step "High-level listIncompleteParts Test"
|
|
let mb5 = 5 * 1024 * 1024
|
|
|
|
step "create a multipart upload"
|
|
uid <- newMultipartUpload bucket object []
|
|
liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."
|
|
|
|
step "put object parts 1..10"
|
|
inputFile <- mkRandFile mb5
|
|
h <- liftIO $ SIO.openBinaryFile inputFile SIO.ReadMode
|
|
forM_ [1..10] $ \pnum ->
|
|
putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5
|
|
|
|
step "fetch list parts"
|
|
incompleteParts <- C.runConduit $ listIncompleteParts bucket object uid
|
|
C..| sinkList
|
|
liftIO $ length incompleteParts @?= 10
|
|
|
|
step "cleanup"
|
|
abortMultipartUpload bucket object uid
|
|
|
|
listingTest :: TestTree
|
|
listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do
|
|
step "listObjects' test"
|
|
step "put 10 objects"
|
|
let objects = (\s ->T.concat ["lsb-release", T.pack (show s)]) <$> [1..10::Int]
|
|
|
|
forM_ [1..10::Int] $ \s ->
|
|
fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release" def
|
|
|
|
step "Simple list"
|
|
res <- listObjects' bucket Nothing Nothing Nothing Nothing
|
|
let expectedObjects = sort objects
|
|
liftIO $ assertEqual "Objects match failed!" expectedObjects
|
|
(map oiObject $ lorObjects res)
|
|
|
|
step "Simple list version 1"
|
|
resV1 <- listObjectsV1' bucket Nothing Nothing Nothing Nothing
|
|
let expected = sort $ map (T.concat .
|
|
("lsb-release":) .
|
|
(\x -> [x]) .
|
|
T.pack .
|
|
show) [1..10::Int]
|
|
liftIO $ assertEqual "Objects match failed!" expected
|
|
(map oiObject $ lorObjects' resV1)
|
|
|
|
step "Cleanup actions"
|
|
forM_ objects $ \obj -> deleteObject bucket obj
|
|
|
|
step "listIncompleteUploads' test"
|
|
step "create 10 multipart uploads"
|
|
let object = "newmpupload"
|
|
forM_ [1..10::Int] $ \_ -> do
|
|
uid <- newMultipartUpload bucket object []
|
|
liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
|
|
|
|
step "list incomplete multipart uploads"
|
|
incompleteUploads <- listIncompleteUploads' bucket (Just "newmpupload") Nothing
|
|
Nothing Nothing Nothing
|
|
liftIO $ (length $ lurUploads incompleteUploads) @?= 10
|
|
|
|
step "cleanup"
|
|
forM_ (lurUploads incompleteUploads) $
|
|
\(_, uid, _) -> abortMultipartUpload bucket object uid
|
|
|
|
step "Basic listIncompleteParts Test"
|
|
let mb5 = 5 * 1024 * 1024
|
|
|
|
step "create a multipart upload"
|
|
uid <- newMultipartUpload bucket object []
|
|
liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
|
|
|
|
step "put object parts 1..10"
|
|
inputFile <- mkRandFile mb5
|
|
h <- liftIO $ SIO.openBinaryFile inputFile SIO.ReadMode
|
|
forM_ [1..10] $ \pnum ->
|
|
putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5
|
|
|
|
step "fetch list parts"
|
|
listPartsResult <- listIncompleteParts' bucket object uid Nothing Nothing
|
|
liftIO $ (length $ lprParts listPartsResult) @?= 10
|
|
abortMultipartUpload bucket object uid
|
|
|
|
|
|
liveServerUnitTests :: TestTree
|
|
liveServerUnitTests = testGroup "Unit tests against a live server"
|
|
[ basicTests
|
|
, listingTest
|
|
, highLevelListingTest
|
|
, 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 def $ ODFile "/dev/zero" (Just mb80)
|
|
|
|
step "Retrieve and verify file size"
|
|
destFile <- mkRandFile 0
|
|
fGetObject bucket obj destFile def
|
|
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 def{
|
|
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 def {
|
|
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 def{
|
|
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 def{
|
|
pooStorageClass = Just "STANDARD"
|
|
}
|
|
|
|
fPutObject bucket object' inputFile' def{
|
|
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 <- MC.try $ fPutObject bucket object'' inputFile'' def{
|
|
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 def
|
|
|
|
step "copy object"
|
|
let srcInfo = def { 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 def
|
|
|
|
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' = def { srcBucket = bucket, srcObject = srcObj }
|
|
dstInfo' = def { 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' def
|
|
|
|
step "make small and large object copy"
|
|
forM_ (zip copyObjs srcs) $ \(cp, src) ->
|
|
copyObject def {dstBucket = bucket, dstObject = cp} def{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' def
|
|
|
|
step "copy last 10MiB of object"
|
|
copyObject def { dstBucket = bucket, dstObject = copyObj } def{
|
|
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)
|
|
|
|
, 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.")
|
|
|
|
step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised."
|
|
mbE <- MC.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 <- MC.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" def
|
|
|
|
step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception"
|
|
fpE <- MC.try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" def
|
|
case fpE of
|
|
Left exn -> liftIO $ exn @?= NoSuchBucket
|
|
_ -> return ()
|
|
|
|
outFile <- mkRandFile 0
|
|
step "simple fGetObject works"
|
|
fGetObject bucket "lsb-release" outFile def
|
|
|
|
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 <- MC.try $ fGetObject bucket "lsb-release" outFile def{
|
|
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 <- MC.try $ fGetObject bucket "lsb-release" outFile def{
|
|
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 <- MC.try $ fGetObject bucket "lsb-release" outFile def{
|
|
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 def{
|
|
gooRange = (Just $ HT.ByteRangeFrom 1)
|
|
}
|
|
|
|
step "fGetObject a non-existent object and check for NoSuchKey exception"
|
|
resE3 <- MC.try $ fGetObject bucket "noSuchKey" outFile def
|
|
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 def
|
|
|
|
step "get metadata of the object"
|
|
res <- statObject bucket object
|
|
liftIO $ (oiSize res) @?= 0
|
|
|
|
step "delete object"
|
|
deleteObject bucket object
|
|
|
|
presignedUrlFunTest :: TestTree
|
|
presignedUrlFunTest = funTestWithBucket "presigned Url tests" $
|
|
\step bucket -> do
|
|
let obj = "mydir/myput"
|
|
obj2 = "mydir1/myfile1"
|
|
|
|
-- manager for http requests
|
|
mgr <- liftIO $ NC.newManager NC.tlsManagerSettings
|
|
|
|
step "PUT object presigned URL - makePresignedUrl"
|
|
putUrl <- makePresignedUrl 3600 HT.methodPut (Just bucket)
|
|
(Just obj) (Just "us-east-1") [] []
|
|
|
|
let size1 = 1000 :: Int64
|
|
inputFile <- mkRandFile size1
|
|
|
|
-- attempt to upload using the presigned URL
|
|
putResp <- putR size1 inputFile mgr putUrl
|
|
liftIO $ (NC.responseStatus putResp == HT.status200) @?
|
|
"presigned PUT failed"
|
|
|
|
step "GET object presigned URL - makePresignedUrl"
|
|
getUrl <- makePresignedUrl 3600 HT.methodGet (Just bucket)
|
|
(Just obj) (Just "us-east-1") [] []
|
|
|
|
getResp <- getR mgr getUrl
|
|
liftIO $ (NC.responseStatus getResp == HT.status200) @?
|
|
"presigned GET failed"
|
|
|
|
-- read content from file to compare with response above
|
|
bs <- C.runConduit $ CB.sourceFile inputFile C..| CB.sinkLbs
|
|
liftIO $ (bs == NC.responseBody getResp) @?
|
|
"presigned put and get got mismatched data"
|
|
|
|
step "PUT object presigned - presignedPutObjectURL"
|
|
putUrl2 <- presignedPutObjectUrl bucket obj2 3600 []
|
|
|
|
let size2 = 1200
|
|
testFile <- mkRandFile size2
|
|
|
|
putResp2 <- putR size2 testFile mgr putUrl2
|
|
liftIO $ (NC.responseStatus putResp2 == HT.status200) @?
|
|
"presigned PUT failed (presignedPutObjectUrl)"
|
|
|
|
step "HEAD object presigned URL - presignedHeadObjectUrl"
|
|
headUrl <- presignedHeadObjectUrl bucket obj2 3600 []
|
|
|
|
headResp <- do req <- NC.parseRequest $ toS headUrl
|
|
NC.httpLbs (req {NC.method = HT.methodHead}) mgr
|
|
liftIO $ (NC.responseStatus headResp == HT.status200) @?
|
|
"presigned HEAD failed (presignedHeadObjectUrl)"
|
|
|
|
-- check that header info is accurate
|
|
let h = Map.fromList $ NC.responseHeaders headResp
|
|
cLen = Map.findWithDefault "0" HT.hContentLength h
|
|
liftIO $ (cLen == show size2) @? "Head req returned bad content length"
|
|
|
|
step "GET object presigned URL - presignedGetObjectUrl"
|
|
getUrl2 <- presignedGetObjectUrl bucket obj2 3600 [] []
|
|
|
|
getResp2 <- getR mgr getUrl2
|
|
liftIO $ (NC.responseStatus getResp2 == HT.status200) @?
|
|
"presigned GET failed (presignedGetObjectUrl)"
|
|
|
|
-- read content from file to compare with response above
|
|
bs2 <- C.runConduit $ CB.sourceFile testFile C..| CB.sinkLbs
|
|
liftIO $ (bs2 == NC.responseBody getResp2) @?
|
|
"presigned put and get got mismatched data (presigned*Url)"
|
|
|
|
|
|
mapM_ (removeObject bucket) [obj, obj2]
|
|
where
|
|
putR size filePath mgr url = do
|
|
req <- NC.parseRequest $ toS url
|
|
let req' = req { NC.method = HT.methodPut
|
|
, NC.requestBody = NC.requestBodySource size $
|
|
CB.sourceFile filePath}
|
|
NC.httpLbs req' mgr
|
|
|
|
getR mgr url = do
|
|
req <- NC.parseRequest $ toS url
|
|
NC.httpLbs req mgr
|
|
|
|
presignedPostPolicyFunTest :: TestTree
|
|
presignedPostPolicyFunTest = funTestWithBucket "Presigned Post Policy tests" $
|
|
\step bucket -> do
|
|
|
|
step "presignedPostPolicy basic test"
|
|
now <- liftIO $ Time.getCurrentTime
|
|
|
|
let key = "presignedPostPolicyTest/myfile"
|
|
policyConds = [ ppCondBucket bucket
|
|
, ppCondKey key
|
|
, ppCondContentLengthRange 1 1000
|
|
, ppCondContentType "application/octet-stream"
|
|
, ppCondSuccessActionStatus 200
|
|
]
|
|
|
|
expirationTime = Time.addUTCTime 3600 now
|
|
postPolicyE = newPostPolicy expirationTime policyConds
|
|
|
|
size = 1000 :: Int64
|
|
|
|
inputFile <- mkRandFile size
|
|
|
|
case postPolicyE of
|
|
Left err -> liftIO $ assertFailure $ show err
|
|
Right postPolicy -> do
|
|
(url, formData) <- presignedPostPolicy postPolicy
|
|
-- liftIO (print url) >> liftIO (print formData)
|
|
result <- liftIO $ postForm url formData inputFile
|
|
liftIO $ (NC.responseStatus result == HT.status200) @?
|
|
"presigned POST failed"
|
|
|
|
mapM_ (removeObject bucket) [key]
|
|
where
|
|
|
|
postForm url formData inputFile = do
|
|
req <- NC.parseRequest $ toS url
|
|
let parts = map (\(x, y) -> Form.partBS x y) $
|
|
Map.toList formData
|
|
parts' = parts ++ [Form.partFile "file" inputFile]
|
|
req' <- Form.formDataBody parts' req
|
|
mgr <- NC.newManager NC.tlsManagerSettings
|
|
NC.httpLbs req' mgr
|
|
|
|
bucketPolicyFunTest :: TestTree
|
|
bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $
|
|
\step bucket -> do
|
|
|
|
step "bucketPolicy basic test - no policy exception"
|
|
resE <- MC.try $ getBucketPolicy bucket
|
|
case resE of
|
|
Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist"
|
|
_ -> return ()
|
|
|
|
resE' <- MC.try $ setBucketPolicy bucket T.empty
|
|
case resE' of
|
|
Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist"
|
|
_ -> return ()
|
|
|
|
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/*\"]}]}"
|
|
|
|
step "try a malformed policy, expect error"
|
|
resE'' <- MC.try $ setBucketPolicy bucket expectedPolicyJSON
|
|
case resE'' of
|
|
Left exn -> liftIO $ exn @?= ServiceErr "MalformedPolicy" "Policy has invalid resource."
|
|
_ -> return ()
|
|
|
|
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 <> "/*\"]}]}"
|
|
|
|
step "set bucket policy"
|
|
setBucketPolicy bucket expectedPolicyJSON'
|
|
|
|
let obj = "myobject"
|
|
|
|
step "verify bucket policy: (1) create `myobject`"
|
|
putObject bucket obj (replicateC 100 "c") Nothing def
|
|
|
|
step "verify bucket policy: (2) get `myobject` anonymously"
|
|
connInfo <- asks mcConnInfo
|
|
let proto = bool "http://" "https://" $ connectIsSecure connInfo
|
|
url = BS.concat [proto, getHostAddr connInfo, "/", toS bucket,
|
|
"/", toS obj]
|
|
respE <- liftIO $ (fmap (Right . toS) $ NC.simpleHttp $ toS url) `catch`
|
|
(\(e :: NC.HttpException) -> return $ Left (show e :: Text))
|
|
case respE of
|
|
Left err -> liftIO $ assertFailure $ show err
|
|
Right s -> liftIO $ s @?= (BS.concat $ replicate 100 "c")
|
|
|
|
deleteObject bucket obj
|
|
|
|
step "delete bucket policy"
|
|
setBucketPolicy bucket T.empty
|