diff --git a/minio-hs.cabal b/minio-hs.cabal
index 2157dfd..6232906 100644
--- a/minio-hs.cabal
+++ b/minio-hs.cabal
@@ -26,6 +26,7 @@ library
, Network.Minio.Data.ByteString
, Network.Minio.Data.Crypto
, Network.Minio.Data.Time
+ , Network.Minio.Errors
, Network.Minio.ListOps
, Network.Minio.PutObject
, Network.Minio.Sign.V4
@@ -55,6 +56,7 @@ library
, monad-control
, resourcet
, text
+ , text-format
, time
, transformers
, transformers-base
@@ -98,6 +100,7 @@ test-suite minio-hs-live-server-test
, Network.Minio.Data.ByteString
, Network.Minio.Data.Crypto
, Network.Minio.Data.Time
+ , Network.Minio.Errors
, Network.Minio.ListOps
, Network.Minio.PutObject
, Network.Minio.S3API
@@ -138,6 +141,7 @@ test-suite minio-hs-live-server-test
, tasty-smallcheck
, temporary
, text
+ , text-format
, time
, transformers
, transformers-base
@@ -180,6 +184,7 @@ test-suite minio-hs-test
, tasty-smallcheck
, temporary
, text
+ , text-format
, time
, transformers
, transformers-base
@@ -204,6 +209,7 @@ test-suite minio-hs-test
, Network.Minio.Data.ByteString
, Network.Minio.Data.Crypto
, Network.Minio.Data.Time
+ , Network.Minio.Errors
, Network.Minio.ListOps
, Network.Minio.PutObject
, Network.Minio.S3API
diff --git a/src/Lib/Prelude.hs b/src/Lib/Prelude.hs
index 8034753..8d665cb 100644
--- a/src/Lib/Prelude.hs
+++ b/src/Lib/Prelude.hs
@@ -6,11 +6,28 @@ https://github.com/sdiehl/protolude/blob/master/Symbols.md
-}
module Lib.Prelude
( module Exports
+ , both
+
+ , format
) where
-import Protolude as Exports
+import Protolude as Exports
-import Data.Time as Exports (UTCTime)
-import Control.Monad.Trans.Maybe as Exports (runMaybeT, MaybeT(..))
+import Data.Time as Exports (UTCTime(..), diffUTCTime)
+import Control.Monad.Trans.Maybe as Exports (runMaybeT, MaybeT(..))
-import Control.Monad.Catch as Exports (throwM, MonadThrow, MonadCatch)
+import Control.Monad.Catch as Exports (throwM, MonadThrow, MonadCatch)
+
+import Data.Text.Format as Exports (Shown(..))
+import qualified Data.Text.Format as TF
+import Data.Text.Format.Params (Params)
+import qualified Data.Text.Lazy as LT
+
+format :: Params ps => TF.Format -> ps -> Text
+format f args = LT.toStrict $ TF.format f args
+
+-- import Data.Tuple as Exports (uncurry)
+
+-- | Apply a function on both elements of a pair
+both :: (a -> b) -> (a, a) -> (b, b)
+both f (a, b) = (f a, f b)
diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs
index aad9fea..0bf3bdc 100644
--- a/src/Network/Minio.hs
+++ b/src/Network/Minio.hs
@@ -44,6 +44,7 @@ module Network.Minio
, fGetObject
, fPutObject
, putObject
+ , copyObject
, getObject
, statObject
@@ -61,6 +62,7 @@ import qualified Data.Conduit.Binary as CB
import Lib.Prelude
import Network.Minio.Data
+import Network.Minio.Errors
import Network.Minio.ListOps
import Network.Minio.PutObject
import Network.Minio.S3API
@@ -79,14 +81,20 @@ fPutObject bucket object f = void $ putObjectInternal bucket object $
ODFile f Nothing
-- | Put an object from a conduit source. The size can be provided if
--- known; this helps the library select optimal part sizes to
--- performing a multipart upload. If not specified, it is assumed that
--- the object can be potentially 5TiB and selects multipart sizes
--- appropriately.
+-- known; this helps the library select optimal part sizes to perform
+-- a multipart upload. If not specified, it is assumed that the object
+-- can be potentially 5TiB and selects multipart sizes appropriately.
putObject :: Bucket -> Object -> C.Producer Minio ByteString
- -> Maybe Int64 -> Minio ()
-putObject bucket object src sizeMay = void $ putObjectInternal bucket object $
- ODStream src sizeMay
+ -> Maybe Int64 -> Minio ()
+putObject bucket object src sizeMay =
+ void $ putObjectInternal bucket object $ ODStream src sizeMay
+
+-- | Perform a server-side copy operation to create an object with the
+-- given bucket and object name from the source specification in
+-- CopyPartSource. This function performs a multipart copy operation
+-- if the new object is to be greater than 5GiB in size.
+copyObject :: Bucket -> Object -> CopyPartSource -> Minio ()
+copyObject bucket object cps = void $ copyObjectInternal bucket object cps
-- | Get an object from the object store as a resumable source (conduit).
getObject :: Bucket -> Object -> Minio (C.ResumableSource Minio ByteString)
diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs
index 1180cdb..31c33d9 100644
--- a/src/Network/Minio/Data.hs
+++ b/src/Network/Minio/Data.hs
@@ -7,7 +7,8 @@ import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource
import qualified Data.ByteString as B
import Data.Default (Default(..))
-import Network.HTTP.Client (defaultManagerSettings, HttpException)
+import qualified Data.Text as T
+import Network.HTTP.Client (defaultManagerSettings)
import qualified Network.HTTP.Conduit as NC
import Network.HTTP.Types (Method, Header, Query)
import qualified Network.HTTP.Types as HT
@@ -15,6 +16,9 @@ import Text.XML
import Lib.Prelude
+import Network.Minio.Errors
+import Network.Minio.Utils
+
-- | Connection Info data type. Use the Default instance to create
-- connection info for your service.
data ConnectInfo = ConnectInfo {
@@ -140,6 +144,47 @@ data ObjectInfo = ObjectInfo {
, oiSize :: Int64
} deriving (Show, Eq)
+data CopyPartSource = CopyPartSource {
+ cpSource :: Text -- | formatted like "/sourceBucket/sourceObject"
+ , cpSourceRange :: Maybe (Int64, Int64) -- | (0, 9) means first ten
+ -- bytes of the source
+ -- object
+ , cpSourceIfMatch :: Maybe Text
+ , cpSourceIfNoneMatch :: Maybe Text
+ , cpSourceIfUnmodifiedSince :: Maybe UTCTime
+ , cpSourceIfModifiedSince :: Maybe UTCTime
+ } deriving (Show, Eq)
+
+instance Default CopyPartSource where
+ def = CopyPartSource "" def def def def def
+
+cpsToHeaders :: CopyPartSource -> [HT.Header]
+cpsToHeaders cps = ("x-amz-copy-source", encodeUtf8 $ cpSource cps) :
+ (rangeHdr ++ (zip names values))
+ where
+ names = ["x-amz-copy-source-if-match", "x-amz-copy-source-if-none-match",
+ "x-amz-copy-source-if-unmodified-since",
+ "x-amz-copy-source-if-modified-since"]
+ values = concatMap (maybeToList . fmap encodeUtf8 . (cps &))
+ [cpSourceIfMatch, cpSourceIfNoneMatch,
+ fmap formatRFC1123 . cpSourceIfUnmodifiedSince,
+ fmap formatRFC1123 . cpSourceIfModifiedSince]
+ rangeHdr = ("x-amz-copy-source-range",)
+ . HT.renderByteRanges
+ . (:[])
+ . uncurry HT.ByteRangeFromTo
+ <$> (map (both fromIntegral) $
+ maybeToList $ cpSourceRange cps)
+
+-- | Extract the source bucket and source object name. TODO: validate
+-- the bucket and object name extracted.
+cpsToObject :: CopyPartSource -> Maybe (Bucket, Object)
+cpsToObject cps = do
+ [_, bucket, object] <- Just splits
+ return (bucket, object)
+ where
+ splits = T.splitOn "/" $ cpSource cps
+
-- | Represents different kinds of payload that are used with S3 API
-- requests.
data Payload = PayloadBS ByteString
@@ -222,29 +267,3 @@ runMinio ci m = do
s3Name :: Text -> Name
s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing
-
----------------------------------
--- Errors
----------------------------------
--- | Various validation errors
-data MErrV = MErrVSinglePUTSizeExceeded Int64
- | MErrVPutSizeExceeded Int64
- | MErrVETagHeaderNotFound
- | MErrVInvalidObjectInfoResponse
- deriving (Show, Eq)
-
--- | Errors thrown by the library
-data MinioErr = ME MError
- | MEHttp HttpException
- | MEFile IOException
- deriving (Show)
-
-instance Exception MinioErr
-
--- | Library internal errors
-data MError = XMLParseError Text
- | ResponseError (NC.Response LByteString)
- | ValidationError MErrV
- deriving (Show, Eq)
-
-instance Exception MError
diff --git a/src/Network/Minio/Errors.hs b/src/Network/Minio/Errors.hs
new file mode 100644
index 0000000..95e9fd8
--- /dev/null
+++ b/src/Network/Minio/Errors.hs
@@ -0,0 +1,36 @@
+module Network.Minio.Errors where
+
+import Control.Exception
+import qualified Network.HTTP.Conduit as NC
+
+import Lib.Prelude
+
+
+---------------------------------
+-- Errors
+---------------------------------
+-- | Various validation errors
+data MErrV = MErrVSinglePUTSizeExceeded Int64
+ | MErrVPutSizeExceeded Int64
+ | MErrVETagHeaderNotFound
+ | MErrVInvalidObjectInfoResponse
+ | MErrVInvalidSrcObjSpec Text
+ | MErrVInvalidSrcObjByteRange (Int64, Int64)
+ | MErrVCopyObjSingleNoRangeAccepted
+ deriving (Show, Eq)
+
+-- | Errors thrown by the library
+data MinioErr = ME MError
+ | MEHttp NC.HttpException
+ | MEFile IOException
+ deriving (Show)
+
+instance Exception MinioErr
+
+-- | Library internal errors
+data MError = XMLParseError Text
+ | ResponseError (NC.Response LByteString)
+ | ValidationError MErrV
+ deriving (Show, Eq)
+
+instance Exception MError
diff --git a/src/Network/Minio/PutObject.hs b/src/Network/Minio/PutObject.hs
index 33d2c71..9751307 100644
--- a/src/Network/Minio/PutObject.hs
+++ b/src/Network/Minio/PutObject.hs
@@ -3,6 +3,9 @@ module Network.Minio.PutObject
putObjectInternal
, ObjectData(..)
, selectPartSizes
+ , copyObjectInternal
+ , selectCopyRanges
+ , minPartSize
) where
@@ -19,6 +22,7 @@ import Lib.Prelude
import Network.Minio.Data
import Network.Minio.Data.Crypto
+import Network.Minio.Errors
import Network.Minio.ListOps
import Network.Minio.S3API
import Network.Minio.Utils
@@ -28,6 +32,14 @@ import Network.Minio.Utils
maxObjectSize :: Int64
maxObjectSize = 5 * 1024 * 1024 * oneMiB
+-- | minimum size of parts used in multipart operations.
+minPartSize :: Int64
+minPartSize = 64 * oneMiB
+
+-- | max part of an object size is 5GiB
+maxObjectPartSize :: Int64
+maxObjectPartSize = 5 * 1024 * oneMiB
+
oneMiB :: Int64
oneMiB = 1024 * 1024
@@ -44,8 +56,9 @@ maxMultipartParts = 10000
-- For streams also, a size may be provided. This is useful to limit
-- the input - if it is not provided, upload will continue until the
-- stream ends or the object reaches `maxObjectsize` size.
-data ObjectData m = ODFile FilePath (Maybe Int64) -- ^ Takes filepath and optional size.
- | ODStream (C.Producer m ByteString) (Maybe Int64) -- ^ Pass size in bytes as maybe if known.
+data ObjectData m =
+ ODFile FilePath (Maybe Int64) -- ^ Takes filepath and optional size.
+ | ODStream (C.Producer m ByteString) (Maybe Int64) -- ^ Pass size in bytes as maybe if known.
-- | Put an object from ObjectData. This high-level API handles
-- objects of all sizes, and even if the object size is unknown.
@@ -77,18 +90,21 @@ putObjectInternal b o (ODFile fp sizeMay) = do
CB.sourceFile fp
-- | Select part sizes - the logic is that the minimum part-size will
--- be 64MiB. TODO: write quickcheck tests.
+-- be 64MiB.
selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]
-selectPartSizes size = List.zip3 [1..] partOffsets partSizes
+selectPartSizes size = uncurry (List.zip3 [1..]) $
+ List.unzip $ loop 0 size
where
ceil :: Double -> Int64
ceil = ceiling
- partSize = max (64 * oneMiB) (ceil $ fromIntegral size /
- fromIntegral maxMultipartParts)
- (numParts, lastPartSize) = size `divMod` partSize
- lastPart = filter (> 0) [lastPartSize]
- partSizes = replicate (fromIntegral numParts) partSize ++ lastPart
- partOffsets = List.scanl' (+) 0 partSizes
+ partSize = max minPartSize (ceil $ fromIntegral size /
+ fromIntegral maxMultipartParts)
+
+ m = fromIntegral partSize
+ loop st sz
+ | st > sz = []
+ | st + m >= sz = [(st, sz - st)]
+ | otherwise = (st, m) : loop (st + m) sz
-- returns partinfo if part is already uploaded.
checkUploadNeeded :: Payload -> PartNumber
@@ -178,3 +194,68 @@ getExistingUpload b o = do
parts <- maybe (return [])
(\uid -> listIncompleteParts b o uid C.$$ CC.sinkList) uidMay
return (uidMay, Map.fromList $ map (\p -> (piNumber p, p)) parts)
+
+-- | Copy an object using single or multipart copy strategy.
+copyObjectInternal :: Bucket -> Object -> CopyPartSource
+ -> Minio ETag
+copyObjectInternal b' o cps = do
+ -- validate and extract the src bucket and object
+ (srcBucket, srcObject) <- maybe
+ (throwM $ ValidationError $ MErrVInvalidSrcObjSpec $ cpSource cps)
+ return $ cpsToObject cps
+
+ -- get source object size with a head request
+ (ObjectInfo _ _ _ srcSize) <- headObject srcBucket srcObject
+
+ -- check that byte offsets are valid if specified in cps
+ when (isJust (cpSourceRange cps) &&
+ or [fst range < 0, snd range < fst range,
+ snd range >= fromIntegral srcSize]) $
+ throwM $ ValidationError $ MErrVInvalidSrcObjByteRange range
+
+ -- 1. If sz > 5gb use multipart copy
+ -- 2. If startOffset /= 0 use multipart copy
+ let destSize = (\(a, b) -> b - a + 1 ) $
+ maybe (0, srcSize - 1) identity $ cpSourceRange cps
+ startOffset = maybe 0 fst $ cpSourceRange cps
+ endOffset = maybe (srcSize - 1) snd $ cpSourceRange cps
+
+ if destSize > maxObjectPartSize || (endOffset - startOffset + 1 /= srcSize)
+ then multiPartCopyObject b' o cps srcSize
+ else fst <$> copyObjectSingle b' o cps{cpSourceRange = Nothing} []
+
+ where
+ range = maybe (0, 0) identity $ cpSourceRange cps
+
+-- | Given the input byte range of the source object, compute the
+-- splits for a multipart copy object procedure. Minimum part size
+-- used is minPartSize.
+selectCopyRanges :: (Int64, Int64) -> [(PartNumber, (Int64, Int64))]
+selectCopyRanges (st, end) = zip pns $
+ map (\(x, y) -> (st + x, st + x + y - 1)) $ zip startOffsets partSizes
+ where
+ size = end - st + 1
+ (pns, startOffsets, partSizes) = List.unzip3 $ selectPartSizes size
+
+-- | Perform a multipart copy object action. Since we cannot verify
+-- existing parts based on the source object, there is no resuming
+-- copy action support.
+multiPartCopyObject :: Bucket -> Object -> CopyPartSource -> Int64
+ -> Minio ETag
+multiPartCopyObject b o cps srcSize = do
+ uid <- newMultipartUpload b o []
+
+ let byteRange = maybe (0, fromIntegral $ srcSize - 1) identity $
+ cpSourceRange cps
+ partRanges = selectCopyRanges byteRange
+ partSources = map (\(x, y) -> (x, cps {cpSourceRange = Just y}))
+ partRanges
+
+ copiedParts <- limitedMapConcurrently 10
+ (\(pn, cps') -> do
+ (etag, _) <- copyObjectPart b o cps' uid pn []
+ return $ PartInfo pn etag
+ )
+ partSources
+
+ completeMultipartUpload b o uid copiedParts
diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs
index 6b747ca..dd9e576 100644
--- a/src/Network/Minio/S3API.hs
+++ b/src/Network/Minio/S3API.hs
@@ -22,6 +22,7 @@ module Network.Minio.S3API
, putBucket
, ETag
, putObjectSingle
+ , copyObjectSingle
-- * Multipart Upload APIs
--------------------------
@@ -29,8 +30,10 @@ module Network.Minio.S3API
, PartInfo
, Payload(..)
, PartNumber
+ , CopyPartSource(..)
, newMultipartUpload
, putObjectPart
+ , copyObjectPart
, completeMultipartUpload
, abortMultipartUpload
, ListUploadsResult
@@ -52,11 +55,12 @@ import qualified Network.HTTP.Types as HT
import Lib.Prelude
-import Network.Minio.Data
import Network.Minio.API
+import Network.Minio.Data
+import Network.Minio.Errors
import Network.Minio.Utils
-import Network.Minio.XmlParser
import Network.Minio.XmlGenerator
+import Network.Minio.XmlParser
-- | Fetch all buckets from the service.
@@ -193,6 +197,43 @@ putObjectPart bucket object uploadId partNumber headers payload = do
, ("partNumber", Just $ show partNumber)
]
+-- | Performs server-side copy of an object or part of an object as an
+-- upload part of an ongoing multi-part upload.
+copyObjectPart :: Bucket -> Object -> CopyPartSource -> UploadId
+ -> PartNumber -> [HT.Header] -> Minio (ETag, UTCTime)
+copyObjectPart bucket object cps uploadId partNumber headers = do
+ resp <- executeRequest $
+ def { riMethod = HT.methodPut
+ , riBucket = Just bucket
+ , riObject = Just object
+ , riQueryParams = mkOptionalParams params
+ , riHeaders = headers ++ cpsToHeaders cps
+ }
+
+ parseCopyObjectResponse $ NC.responseBody resp
+ where
+ params = [
+ ("uploadId", Just uploadId)
+ , ("partNumber", Just $ show partNumber)
+ ]
+
+-- | Performs server-side copy of an object that is upto 5GiB in
+-- size. If the object is greater than 5GiB, this function throws the
+-- error returned by the server.
+copyObjectSingle :: Bucket -> Object -> CopyPartSource -> [HT.Header]
+ -> Minio (ETag, UTCTime)
+copyObjectSingle bucket object cps headers = do
+ -- validate that cpSourceRange is Nothing for this API.
+ when (isJust $ cpSourceRange cps) $
+ throwM $ ValidationError $ MErrVCopyObjSingleNoRangeAccepted
+ resp <- executeRequest $
+ def { riMethod = HT.methodPut
+ , riBucket = Just bucket
+ , riObject = Just object
+ , riHeaders = headers ++ cpsToHeaders cps
+ }
+ parseCopyObjectResponse $ NC.responseBody resp
+
-- | Complete a multipart upload.
completeMultipartUpload :: Bucket -> Object -> UploadId -> [PartInfo]
-> Minio ETag
@@ -226,22 +267,22 @@ listIncompleteUploads' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text
listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker = do
resp <- executeRequest $ def { riMethod = HT.methodGet
, riBucket = Just bucket
- , riQueryParams = ("uploads", Nothing): mkOptionalParams params
+ , riQueryParams = params
}
parseListUploadsResponse $ NC.responseBody resp
where
- -- build optional query params
- params = [
- ("prefix", prefix)
- , ("delimiter", delimiter)
- , ("key-marker", keyMarker)
- , ("upload-id-marker", uploadIdMarker)
- ]
+ -- build query params
+ params = ("uploads", Nothing) : mkOptionalParams
+ [ ("prefix", prefix)
+ , ("delimiter", delimiter)
+ , ("key-marker", keyMarker)
+ , ("upload-id-marker", uploadIdMarker)
+ ]
-- | List parts of an ongoing multipart upload.
listIncompleteParts' :: Bucket -> Object -> UploadId -> Maybe Text
- -> Maybe Text -> Minio ListPartsResult
+ -> Maybe Text -> Minio ListPartsResult
listIncompleteParts' bucket object uploadId maxParts partNumMarker = do
resp <- executeRequest $ def { riMethod = HT.methodGet
, riBucket = Just bucket
diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs
index 0ab0fba..ef95385 100644
--- a/src/Network/Minio/Utils.hs
+++ b/src/Network/Minio/Utils.hs
@@ -22,12 +22,16 @@ import qualified System.IO as IO
import Lib.Prelude
-import Network.Minio.Data
+import Network.Minio.Errors
-- | Represent the time format string returned by S3 API calls.
s3TimeFormat :: [Char]
s3TimeFormat = iso8601DateFormat $ Just "%T%QZ"
+-- | Format as per RFC 1123.
+formatRFC1123 :: UTCTime -> T.Text
+formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"
+
allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m)
=> FilePath -> m (R.ReleaseKey, Handle)
allocateReadFile fp = do
diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs
index 6041279..ec698b3 100644
--- a/src/Network/Minio/XmlParser.hs
+++ b/src/Network/Minio/XmlParser.hs
@@ -3,6 +3,7 @@ module Network.Minio.XmlParser
, parseLocation
, parseNewMultipartUpload
, parseCompleteMultipartUploadResponse
+ , parseCopyObjectResponse
, parseListObjectsResponse
, parseListUploadsResponse
, parseListPartsResponse
@@ -19,6 +20,7 @@ import Text.XML.Cursor
import Lib.Prelude
import Network.Minio.Data
+import Network.Minio.Errors
import Network.Minio.Utils (s3TimeFormat)
@@ -79,6 +81,16 @@ parseCompleteMultipartUploadResponse xmldata = do
r <- parseRoot xmldata
return $ T.concat $ r $// s3Elem "ETag" &/ content
+-- | Parse the response XML of copyObject and copyObjectPart
+parseCopyObjectResponse :: (MonadThrow m) => LByteString -> m (ETag, UTCTime)
+parseCopyObjectResponse xmldata = do
+ r <- parseRoot xmldata
+ let
+ mtimeStr = T.concat $ r $// s3Elem "LastModified" &/ content
+
+ mtime <- parseS3XMLTime mtimeStr
+ return $ (T.concat $ r $// s3Elem "ETag" &/ content, mtime)
+
-- | Parse the response XML of a list objects call.
parseListObjectsResponse :: (MonadThrow m)
=> LByteString -> m ListObjectsResult
diff --git a/test/LiveServer.hs b/test/LiveServer.hs
index b3d9386..380872c 100644
--- a/test/LiveServer.hs
+++ b/test/LiveServer.hs
@@ -290,4 +290,104 @@ liveServerUnitTests = testGroup "Unit tests against a live server"
step "delete object"
deleteObject bucket object
+
+ , funTestWithBucket "copyObjectSingle basic tests" $ \step bucket -> do
+ let object = "xxx"
+ objCopy = "xxxCopy"
+ size1 = 100 :: Int64
+
+ step "create server object to copy"
+ inputFile <- mkRandFile size1
+ fPutObject bucket object inputFile
+
+ step "copy object"
+ let cps = def { cpSource = format "/{}/{}" [bucket, object] }
+ (etag, modTime) <- copyObjectSingle bucket objCopy cps []
+
+ -- retrieve obj info to check
+ ObjectInfo _ t e s <- headObject bucket objCopy
+
+ let isMTimeDiffOk = abs (diffUTCTime modTime t) < 1.0
+
+ liftIO $ (s == size1 && e == etag && isMTimeDiffOk) @?
+ "Copied object did not match expected."
+
+ step "cleanup actions"
+ deleteObject bucket object
+ deleteObject bucket objCopy
+
+ , funTestWithBucket "copyObjectPart basic tests" $ \step bucket -> do
+ let srcObj = "XXX"
+ copyObj = "XXXCopy"
+
+ step "Prepare"
+ let mb15 = 15 * 1024 * 1024
+ mb5 = 5 * 1024 * 1024
+ randFile <- mkRandFile mb15
+ fPutObject bucket srcObj randFile
+
+ 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 cps = def {cpSource = format "/{}/{}" [bucket, srcObj]}
+ parts <- forM [1..3] $ \p -> do
+ (etag, _) <- copyObjectPart bucket copyObj cps{
+ cpSourceRange = Just ((p-1)*mb5, (p-1)*mb5 + (mb5 - 1))
+ } uid (fromIntegral p) []
+ return $ PartInfo (fromIntegral p) etag
+
+ step "complete multipart"
+ void $ completeMultipartUpload bucket copyObj uid parts
+
+ step "verify copied object size"
+ (ObjectInfo _ _ _ s) <- headObject bucket copyObj
+
+ liftIO $ (s == mb15) @? "Size failed to match"
+
+ step $ "Cleanup actions"
+ deleteObject bucket srcObj
+ deleteObject bucket copyObj
+
+ , funTestWithBucket "copyObject basic tests" $ \step bucket -> do
+ let srcs = ["XXX", "XXXL"]
+ copyObjs = ["XXXCopy", "XXXLCopy"]
+ sizes = map (* (1024 * 1024)) [15, 65]
+
+ step "Prepare"
+ forM_ (zip srcs sizes) $ \(src, size) ->
+ fPutObject bucket src =<< mkRandFile size
+
+ step "make small and large object copy"
+ forM_ (zip copyObjs srcs) $ \(cp, src) ->
+ copyObject bucket cp def{cpSource = format "/{}/{}" [bucket, src]}
+
+ step "verify uploaded objects"
+ uploadedSizes <- fmap (fmap oiSize) $ forM copyObjs (headObject bucket)
+
+ liftIO $ (sizes == uploadedSizes) @? "Uploaded obj sizes failed to match"
+
+ forM_ (concat [srcs, copyObjs]) (deleteObject bucket)
+
+ , funTestWithBucket "copyObject with offset test " $ \step bucket -> do
+ let src = "XXX"
+ copyObj = "XXXCopy"
+ size = 15 * 1024 * 1024
+
+ step "Prepare"
+ fPutObject bucket src =<< mkRandFile size
+
+ step "copy last 10MiB of object"
+ copyObject bucket copyObj def{
+ cpSource = format "/{}/{}" [bucket, src]
+ , cpSourceRange = 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] (deleteObject bucket)
]
diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs
index b1058f3..a29e918 100644
--- a/test/Network/Minio/XmlParser/Test.hs
+++ b/test/Network/Minio/XmlParser/Test.hs
@@ -4,13 +4,14 @@ module Network.Minio.XmlParser.Test
) where
import qualified Control.Monad.Catch as MC
-import Data.Time (fromGregorian, UTCTime(..))
+import Data.Time (fromGregorian)
import Test.Tasty
import Test.Tasty.HUnit
import Lib.Prelude
import Network.Minio.Data
+import Network.Minio.Errors
import Network.Minio.XmlParser
xmlParserTests :: TestTree
@@ -21,6 +22,7 @@ xmlParserTests = testGroup "XML Parser Tests"
, testCase "Test parseListUploadsresponse" testParseListIncompleteUploads
, testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse
, testCase "Test parseListPartsResponse" testParseListPartsResponse
+ , testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse
]
tryMError :: (MC.MonadCatch m) => m a -> m (Either MError a)
@@ -210,3 +212,25 @@ testParseListPartsResponse = do
parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata
eitherMError parsedListPartsResult (@?= expectedListResult)
+
+testParseCopyObjectResponse :: Assertion
+testParseCopyObjectResponse = do
+ let
+ cases = [ ("\
+\\
+ \2009-10-28T22:32:00.000Z\
+ \\"9b2cf535f27731c974343645a3985328\"\
+\",
+ ("\"9b2cf535f27731c974343645a3985328\"",
+ UTCTime (fromGregorian 2009 10 28) 81120))
+ , ("\
+\\
+ \2009-10-28T22:32:00.000Z\
+ \\"9b2cf535f27731c974343645a3985328\"\
+\",
+ ("\"9b2cf535f27731c974343645a3985328\"",
+ UTCTime (fromGregorian 2009 10 28) 81120))]
+
+ forM_ cases $ \(xmldata, (etag, modTime)) -> do
+ parseResult <- runExceptT $ parseCopyObjectResponse xmldata
+ eitherMError parseResult (@?= (etag, modTime))
diff --git a/test/Spec.hs b/test/Spec.hs
index b98d387..fe9cff5 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -31,7 +31,7 @@ properties = testGroup "Properties" [qcProps] -- [scProps]
qcProps :: TestTree
qcProps = testGroup "(checked by QuickCheck)"
- [ QC.testProperty "selectPartSizes: simple properties" $
+ [ QC.testProperty "selectPartSizes:" $
\n -> let (pns, offs, sizes) = L.unzip3 (selectPartSizes n)
-- check that pns increments from 1.
@@ -45,22 +45,52 @@ qcProps = testGroup "(checked by QuickCheck)"
isOffsetsAsc = all (\(a, b) -> a < b) $ consPairs offs
-- check sizes sums to n.
- isSumSizeOk = n < 0 || (sum sizes == n && all (> 0) sizes)
+ isSumSizeOk = sum sizes == n
-- check sizes are constant except last
isSizesConstantExceptLast =
- n <= 0 || all (\(a, b) -> a == b) (consPairs $ L.init sizes)
+ all (\(a, b) -> a == b) (consPairs $ L.init sizes)
- in isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk &&
- isSizesConstantExceptLast
+ -- check each part except last is at least minPartSize;
+ -- last part may be 0 only if it is the only part.
+ nparts = length sizes
+ isMinPartSizeOk =
+ if | nparts > 1 -> -- last part can be smaller but > 0
+ all (>= minPartSize) (take (nparts - 1) sizes) &&
+ all (\s -> s > 0) (drop (nparts - 1) sizes)
+ | nparts == 1 -> -- size may be 0 here.
+ maybe True (\x -> x >= 0 && x <= minPartSize) $
+ headMay sizes
+ | otherwise -> False
- , QC.testProperty "selectPartSizes: part-size is at least 64MiB" $
- \n -> let (_, _, sizes) = L.unzip3 (selectPartSizes n)
- mib64 = 64 * 1024 * 1024
- in if | length sizes > 1 -> -- last part can be smaller but > 0
- all (>= mib64) (L.init sizes) && L.last sizes > 0
- | length sizes == 1 -> maybe True (> 0) $ head sizes
- | otherwise -> True
+ in n < 0 ||
+ (isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk &&
+ isSizesConstantExceptLast && isMinPartSizeOk)
+
+ , QC.testProperty "selectCopyRanges:" $
+ \(start, end) ->
+ let (_, pairs) = L.unzip (selectCopyRanges (start, end))
+
+ -- is last part's snd offset end?
+ isLastPartOk = maybe False ((end ==) . snd) $ lastMay pairs
+ -- is first part's fst offset start
+ isFirstPartOk = maybe False ((start ==) . fst) $ headMay pairs
+
+ -- each pair is >=64MiB except last, and all those parts
+ -- have same size.
+ initSizes = maybe [] (map (\(a, b) -> b - a + 1)) $ initMay pairs
+ isPartSizesOk = all (>= minPartSize) initSizes &&
+ maybe True (\k -> all (== k) initSizes)
+ (headMay initSizes)
+
+ -- returned offsets are contiguous.
+ fsts = drop 1 $ map fst pairs
+ snds = take (length pairs - 1) $ map snd pairs
+ isContParts = length fsts == length snds &&
+ and (map (\(a, b) -> a == b + 1) $ zip fsts snds)
+
+ in start < 0 || start > end ||
+ (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts)
]
unitTests :: TestTree