PutObjectPart and CompleteMultipartUpload with basic tests

- Functional tests are refactored

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

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

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)
 
 -- |

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
+putObject :: Bucket -> Object -> [HT.Header] -> Handle -> Int64
-          -> Int64 -> Handle -> Minio ()
+          -> Int64 -> Minio ()
-putObject bucket object headers offset size h = do
+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

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)

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 []

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

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 = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><CreateBucketConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
- \<LocationConstraint>EU</LocationConstraint>\
- \</CreateBucketConfiguration>"
-
 testMkCreateBucketConfig :: Assertion
 testMkCreateBucketConfig = do
-  assertEqual "CreateBucketConfiguration xml should match: " euBucketConfig $ mkCreateBucketConfig "EU"
+  assertEqual "CreateBucketConfiguration xml should match: " expected $
+    mkCreateBucketConfig "EU"
+  where
+    expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><CreateBucketConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"><LocationConstraint>EU</LocationConstraint></CreateBucketConfiguration>"
+
+testMkCompleteMultipartUploadRequest :: Assertion
+testMkCompleteMultipartUploadRequest =
+  assertEqual "completeMultipartUpload xml should match: " expected $
+  mkCompleteMultipartUploadRequest [PartInfo 1 "abc"]
+  where
+    expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><CompleteMultipartUpload><Part><PartNumber>1</PartNumber><ETag>abc</ETag></Part></CompleteMultipartUpload>"

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."
+      step "singlepart putObject works"
-        buckets <- getService
+      fPutObject bucket "lsb-release" "/etc/lsb-release"
-        liftIO $ (length buckets == 0) @?
-          ("Live server must have no buckets at beginning.")
 
-        liftIO $ step "putBucket works"
+      step "simple getObject works"
-        putBucket "testbucket" "us-east-1"
+      fGetObject bucket "lsb-release" "/tmp/out"
 
-        liftIO $ step "getLocation works"
+      step "create new multipart upload works"
-        region <- getLocation "testbucket"
+      uid <- newMultipartUpload bucket "newmpupload" []
-        liftIO $ region == "" @? ("Got unexpected region => " ++ show region)
+      liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
 
-        liftIO $ step "singlepart putObject works"
+      step "abort a new multipart upload works"
-        fPutObject "testbucket" "lsb-release" "/etc/lsb-release"
+      abortMultipartUpload bucket "newmpupload" uid
 
-        liftIO $ step "simple getObject works"
+      step "delete object works"
-        fGetObject "testbucket" "lsb-release" "/tmp/out"
+      deleteObject bucket "lsb-release"
 
-        liftIO $ step "create new multipart upload works"
+  , funTestWithBucket "Multipart Upload Test" "testbucket2" $ \step bucket -> do
-        uid <- newMultipartUpload "testbucket" "newmpupload" []
+      let object = "newmpupload"
-        liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
 
-        liftIO $ step "abort a new multipart upload works"
+      step "create new multipart upload"
-        abortMultipartUpload "testbucket" "newmpupload" uid
+      uid <- newMultipartUpload bucket object []
+      liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
 
-        liftIO $ step "delete object works"
+      step "put object parts 1..10"
-        deleteObject "testbucket" "lsb-release"
+      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"
+      step "complete multipart"
-        deleteBucket "testbucket"
+      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