diff --git a/minio-hs.cabal b/minio-hs.cabal
index f4112a1..c19f411 100644
--- a/minio-hs.cabal
+++ b/minio-hs.cabal
@@ -96,6 +96,7 @@ test-suite minio-hs-test
, transformers-base
, xml-conduit
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+ -- ghc-options: -Wall
default-language: Haskell2010
default-extensions: FlexibleContexts
, FlexibleInstances
@@ -118,6 +119,7 @@ test-suite minio-hs-test
, Network.Minio.XmlParser
, Network.Minio.Utils
, Network.Minio.XmlGenerator.Test
+ , Network.Minio.XmlParser.Test
source-repository head
diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs
index 0838145..a6695e3 100644
--- a/src/Network/Minio.hs
+++ b/src/Network/Minio.hs
@@ -63,7 +63,7 @@ fPutObject bucket object fp = do
(releaseKey, h) <- allocateReadFile fp
size <- liftIO $ IO.hFileSize h
- putObject bucket object [] 0 (fromIntegral size) h
+ putObject bucket object [] h 0 (fromIntegral size)
-- release file handle
R.release releaseKey
diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs
index ab07e96..bba6936 100644
--- a/src/Network/Minio/Data.hs
+++ b/src/Network/Minio/Data.hs
@@ -7,7 +7,10 @@ module Network.Minio.Data
, Object
, Region
, BucketInfo(..)
+ , PartNumber
, UploadId
+ , ETag
+ , PartInfo(..)
, getPathFromRI
, getRegionFromRI
, Minio
@@ -60,6 +63,10 @@ type Object = Text
-- TODO: This could be a Sum Type with all defined regions for AWS.
type Region = Text
+-- | A type alias to represent an Entity-Tag returned by S3-compatible
+-- APIs.
+type ETag = Text
+
-- |
-- BucketInfo returned for list buckets call
data BucketInfo = BucketInfo {
@@ -67,10 +74,19 @@ data BucketInfo = BucketInfo {
, biCreationDate :: UTCTime
} deriving (Show, Eq)
+-- | A type alias to represent a part-number for multipart upload
+type PartNumber = Int16
-- | A type alias to represent an upload-id for multipart upload
type UploadId = Text
+-- | A data-type to represent info about a part
+data PartInfo = PartInfo PartNumber ETag
+ deriving (Show, Eq)
+
+instance Ord PartInfo where
+ (PartInfo a _) `compare` (PartInfo b _) = a `compare` b
+
data Payload = PayloadBS ByteString
| PayloadH Handle
Int64 -- offset
@@ -104,6 +120,7 @@ getRegionFromRI ri = maybe "us-east-1" identity (riRegion ri)
-- | Various validation errors
data MErrV = MErrVSinglePUTSizeExceeded Int64
+ | MErrVETagHeaderNotFound
deriving (Show)
-- |
diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs
index 87a3085..ac19e88 100644
--- a/src/Network/Minio/S3API.hs
+++ b/src/Network/Minio/S3API.hs
@@ -24,6 +24,8 @@ module Network.Minio.S3API
-- * Multipart Upload APIs
--------------------------
, newMultipartUpload
+ , putObjectPart
+ , completeMultipartUpload
, abortMultipartUpload
) where
@@ -36,6 +38,7 @@ import Lib.Prelude
import Network.Minio.Data
import Network.Minio.API
+import Network.Minio.Utils
import Network.Minio.XmlParser
import Network.Minio.XmlGenerator
@@ -82,9 +85,9 @@ maxSinglePutObjectSizeBytes = 5 * 1024 * 1024 * 1024
-- | PUT an object into the service. This function performs a single
-- PUT object call, and so can only transfer objects upto 5GiB.
-putObject :: Bucket -> Object -> [HT.Header] -> Int64
- -> Int64 -> Handle -> Minio ()
-putObject bucket object headers offset size h = do
+putObject :: Bucket -> Object -> [HT.Header] -> Handle -> Int64
+ -> Int64 -> Minio ()
+putObject bucket object headers h offset size = do
-- check length is within single PUT object size.
when (size > maxSinglePutObjectSizeBytes) $
throwError $ MErrValidation $ MErrVSinglePUTSizeExceeded size
@@ -126,6 +129,40 @@ newMultipartUpload bucket object headers = do
}
parseNewMultipartUpload $ NC.responseBody resp
+-- | PUT a part of an object as part of a multi-part upload.
+putObjectPart :: Bucket -> Object -> UploadId -> PartNumber -> [HT.Header]
+ -> Handle -> Int64 -> Int64 -> Minio PartInfo
+putObjectPart bucket object uploadId partNumber headers h offset size = do
+ resp <- executeRequest $
+ def { riMethod = HT.methodPut
+ , riBucket = Just bucket
+ , riObject = Just object
+ , riQueryParams = [("partNumber", Just $ encodeUtf8 $
+ show partNumber),
+ ("uploadId", Just $ encodeUtf8 uploadId)]
+ , riHeaders = headers
+ , riPayload = PayloadH h offset size
+ }
+ let rheaders = NC.responseHeaders resp
+ etag = getETagHeader rheaders
+ maybe
+ (throwError $ MErrValidation MErrVETagHeaderNotFound)
+ (return . PartInfo partNumber) etag
+
+-- | Complete a multipart upload.
+completeMultipartUpload :: Bucket -> Object -> UploadId -> [PartInfo]
+ -> Minio ETag
+completeMultipartUpload bucket object uploadId partInfo = do
+ resp <- executeRequest $
+ def { riMethod = HT.methodPost
+ , riBucket = Just bucket
+ , riObject = Just object
+ , riQueryParams = [("uploadId", Just $ encodeUtf8 uploadId)]
+ , riPayload = PayloadBS $
+ mkCompleteMultipartUploadRequest partInfo
+ }
+ parseCompleteMultipartUploadResponse $ NC.responseBody resp
+
-- | Abort a multipart upload.
abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio ()
abortMultipartUpload bucket object uploadId = do
diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs
index cbfb4d0..0c6a7da 100644
--- a/src/Network/Minio/Utils.hs
+++ b/src/Network/Minio/Utils.hs
@@ -7,6 +7,8 @@ import qualified Network.HTTP.Client as NClient
import Network.HTTP.Conduit (Response)
import qualified Data.Conduit as C
import qualified Data.ByteString.Lazy as LBS
+import Data.Text.Encoding.Error (lenientDecode)
+-- import Data.Text.Encoding (decodeUtf8With)
import qualified Network.HTTP.Types as HT
import qualified Control.Exception.Lifted as ExL
@@ -24,6 +26,15 @@ allocateReadFile fp = do
openReadFile f = runExceptT $ tryIO $ IO.openBinaryFile f IO.ReadMode
cleanup = either (const $ return ()) IO.hClose
+lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString
+lookupHeader hdr = headMay . map snd . filter (\(h, _) -> h == hdr)
+
+getETagHeader :: [HT.Header] -> Maybe Text
+getETagHeader hs = decodeUtf8Lenient <$> lookupHeader "ETag" hs
+
+decodeUtf8Lenient :: ByteString -> Text
+decodeUtf8Lenient = decodeUtf8With lenientDecode
+
isSuccessStatus :: HT.Status -> Bool
isSuccessStatus sts = let s = HT.statusCode sts
in (s >= 200 && s < 300)
diff --git a/src/Network/Minio/XmlGenerator.hs b/src/Network/Minio/XmlGenerator.hs
index 60441fa..dbb6f29 100644
--- a/src/Network/Minio/XmlGenerator.hs
+++ b/src/Network/Minio/XmlGenerator.hs
@@ -1,9 +1,11 @@
module Network.Minio.XmlGenerator
( mkCreateBucketConfig
+ , mkCompleteMultipartUploadRequest
) where
import Lib.Prelude
+import qualified Data.Text as T
import qualified Data.ByteString.Lazy as LBS
import Text.XML
import qualified Data.Map as M
@@ -11,12 +13,28 @@ import qualified Data.Map as M
import Network.Minio.Data
+-- | Create a bucketConfig request body XML
mkCreateBucketConfig :: Region -> ByteString
mkCreateBucketConfig location = LBS.toStrict $ renderLBS def bucketConfig
where
s3Element n = Element (s3Name n) M.empty
- root = s3Element "CreateBucketConfiguration"
+ root = s3Element "CreateBucketConfiguration"
[ NodeElement $ s3Element "LocationConstraint"
[ NodeContent location]
]
bucketConfig = Document (Prologue [] Nothing []) root []
+
+-- | Create a completeMultipartUpload request body XML
+mkCompleteMultipartUploadRequest :: [PartInfo] -> ByteString
+mkCompleteMultipartUploadRequest partInfo =
+ LBS.toStrict $ renderLBS def cmur
+ where
+ root = Element "CompleteMultipartUpload" M.empty $
+ map (NodeElement . mkPart) partInfo
+ mkPart (PartInfo n etag) = Element "Part" M.empty
+ [ NodeElement $ Element "PartNumber" M.empty
+ [NodeContent $ T.pack $ show n]
+ , NodeElement $ Element "ETag" M.empty
+ [NodeContent etag]
+ ]
+ cmur = Document (Prologue [] Nothing []) root []
diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs
index be5ffd9..d06c2dc 100644
--- a/src/Network/Minio/XmlParser.hs
+++ b/src/Network/Minio/XmlParser.hs
@@ -2,6 +2,7 @@ module Network.Minio.XmlParser
( parseListBuckets
, parseLocation
, parseNewMultipartUpload
+ , parseCompleteMultipartUploadResponse
) where
import Text.XML
@@ -44,3 +45,11 @@ parseNewMultipartUpload xmldata = do
doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata
return $ T.concat $ fromDocument doc
$// element (s3Name "UploadId") &/ content
+
+-- | Parse the response XML of completeMultipartUpload call.
+parseCompleteMultipartUploadResponse :: (MonadError MinioErr m)
+ => LByteString -> m ETag
+parseCompleteMultipartUploadResponse xmldata = do
+ doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata
+ return $ T.concat $ fromDocument doc
+ $// element (s3Name "ETag") &/ content
diff --git a/test/Network/Minio/XmlGenerator/Test.hs b/test/Network/Minio/XmlGenerator/Test.hs
index fe4d6f9..e445a21 100644
--- a/test/Network/Minio/XmlGenerator/Test.hs
+++ b/test/Network/Minio/XmlGenerator/Test.hs
@@ -8,17 +8,24 @@ import Test.Tasty.HUnit
import Lib.Prelude
import Network.Minio.XmlGenerator
+import Network.Minio.Data
xmlGeneratorTests :: TestTree
xmlGeneratorTests = testGroup "XML Generator Tests"
[ testCase "Test mkCreateBucketConfig" testMkCreateBucketConfig
+ , testCase "Test mkCompleteMultipartUploadRequest" testMkCompleteMultipartUploadRequest
]
-euBucketConfig :: ByteString
-euBucketConfig = "\
- \EU\
- \"
-
testMkCreateBucketConfig :: Assertion
testMkCreateBucketConfig = do
- assertEqual "CreateBucketConfiguration xml should match: " euBucketConfig $ mkCreateBucketConfig "EU"
+ assertEqual "CreateBucketConfiguration xml should match: " expected $
+ mkCreateBucketConfig "EU"
+ where
+ expected = "EU"
+
+testMkCompleteMultipartUploadRequest :: Assertion
+testMkCompleteMultipartUploadRequest =
+ assertEqual "completeMultipartUpload xml should match: " expected $
+ mkCompleteMultipartUploadRequest [PartInfo 1 "abc"]
+ where
+ expected = "1abc"
diff --git a/test/Spec.hs b/test/Spec.hs
index 511617f..a0f30fc 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -3,7 +3,7 @@ import Test.Tasty.HUnit
import Lib.Prelude
--- import qualified System.IO as SIO
+import qualified System.IO as SIO
import Control.Monad.Trans.Resource (runResourceT)
import qualified Data.Text as T
@@ -48,45 +48,70 @@ properties = testGroup "Properties" [] -- [scProps, qcProps]
-- (n :: Integer) >= 3 QC.==> x^n + y^n /= (z^n :: Integer)
-- ]
+funTestWithBucket :: TestName -> Bucket
+ -> (([Char] -> Minio ()) -> Bucket -> Minio ()) -> TestTree
+funTestWithBucket t b minioTest = testCaseSteps t $ \step -> do
+ step $ "Creating bucket for test - " ++ t
+ let liftStep = liftIO . step
+ ret <- runResourceT $ runMinio def $ do
+ putBucket b "us-east-1"
+ minioTest liftStep b
+ deleteBucket b
+ isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)
+
liveServerUnitTests :: TestTree
liveServerUnitTests = testGroup "Unit tests against a live server"
- [ testCaseSteps "Various functional tests" $ \step -> do
+ [ funTestWithBucket "Basic tests" "testbucket1" $ \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.")
- ret <- runResourceT $ runMinio def $ do
+ step "getLocation works"
+ region <- getLocation bucket
+ liftIO $ region == "" @? ("Got unexpected region => " ++ show region)
- liftIO $ step "getService works and returns no buckets in the beginning."
- buckets <- getService
- liftIO $ (length buckets == 0) @?
- ("Live server must have no buckets at beginning.")
+ step "singlepart putObject works"
+ fPutObject bucket "lsb-release" "/etc/lsb-release"
- liftIO $ step "putBucket works"
- putBucket "testbucket" "us-east-1"
+ step "simple getObject works"
+ fGetObject bucket "lsb-release" "/tmp/out"
- liftIO $ step "getLocation works"
- region <- getLocation "testbucket"
- liftIO $ region == "" @? ("Got unexpected region => " ++ show region)
+ step "create new multipart upload works"
+ uid <- newMultipartUpload bucket "newmpupload" []
+ liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
- liftIO $ step "singlepart putObject works"
- fPutObject "testbucket" "lsb-release" "/etc/lsb-release"
+ step "abort a new multipart upload works"
+ abortMultipartUpload bucket "newmpupload" uid
- liftIO $ step "simple getObject works"
- fGetObject "testbucket" "lsb-release" "/tmp/out"
+ step "delete object works"
+ deleteObject bucket "lsb-release"
- liftIO $ step "create new multipart upload works"
- uid <- newMultipartUpload "testbucket" "newmpupload" []
- liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
+ , funTestWithBucket "Multipart Upload Test" "testbucket2" $ \step bucket -> do
+ let object = "newmpupload"
- liftIO $ step "abort a new multipart upload works"
- abortMultipartUpload "testbucket" "newmpupload" uid
+ step "create new multipart upload"
+ uid <- newMultipartUpload bucket object []
+ liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
- liftIO $ step "delete object works"
- deleteObject "testbucket" "lsb-release"
+ step "put object parts 1..10"
+ h <- liftIO $ SIO.openBinaryFile "/tmp/inputfile" SIO.ReadMode
+ let mb15 = 15 * 1024 * 1024
+ partInfo <- forM [1..10] $ \pnum ->
+ putObjectPart bucket object uid pnum [] h 0 mb15
- liftIO $ step "delete bucket works"
- deleteBucket "testbucket"
+ step "complete multipart"
+ etag <- completeMultipartUpload bucket object uid partInfo
- isRight ret @? ("Functional test failure => " ++ show ret)
+ step $ "completeMultipart success - got etag: " ++ show etag
+ step $ "Retrieve the created object"
+ fGetObject bucket object "/tmp/newUpload"
+
+ step $ "Cleanup actions"
+ deleteObject bucket object
]
unitTests :: TestTree