Implement list object parts of an ongoing multipart upload.

src/Network/Minio/Data.hs

@@ -65,6 +65,24 @@ instance Ord PartInfo where
   (PartInfo a _) `compare` (PartInfo b _) = a `compare` b
 
 
+-- | Represents result from a listing of object parts of an ongoing
+-- multipart upload.
+data ListPartsResult = ListPartsResult {
+    lprHasMore :: Bool
+  , lprNextPart :: Maybe Int
+  , lprParts :: [ListPartInfo]
+ } deriving (Show, Eq)
+
+
+-- | Represents information about an object part in an ongoing
+-- multipart upload.
+data ListPartInfo = ListPartInfo {
+    piNumber :: Int
+  , piETag :: ETag
+  , piSize :: Int64
+  , piModTime :: UTCTime
+  } deriving (Show, Eq)
+
 -- | Represents result from a listing of incomplete uploads to a
 -- bucket.
 data ListUploadsResult = ListUploadsResult {

src/Network/Minio/S3API.hs

@@ -26,6 +26,7 @@ module Network.Minio.S3API
   , completeMultipartUpload
   , abortMultipartUpload
   , listIncompleteUploads
+  , listIncompleteParts
 
   -- * Deletion APIs
   --------------------------
@@ -121,18 +122,16 @@ listObjects :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text
 listObjects bucket prefix nextToken delimiter = do
   resp <- executeRequest $ def { riMethod = HT.methodGet
                                , riBucket = Just bucket
-                               , riQueryParams = ("list-type", Just "2") : qp
+                               , riQueryParams = mkOptionalParams params
                                }
   parseListObjectsResponse $ NC.responseBody resp
   where
-    -- build optional query params
+    params = [
-    ctokList = map ((\k -> ("continuation_token", k)) . Just . encodeUtf8) $
+        ("list-type", Just "2")
-               maybeToList nextToken
+      , ("continuation_token", nextToken)
-    prefixList = map ((\k -> ("prefix", k)) . Just . encodeUtf8) $
+      , ("prefix", prefix)
-                 maybeToList prefix
+      , ("delimiter", delimiter)
-    delimList = map ((\k -> ("delimiter", k)) . Just . encodeUtf8) $
+      ]
-                maybeToList delimiter
-    qp = concat [ctokList, prefixList, delimList]
 
 -- | DELETE a bucket from the service.
 deleteBucket :: Bucket -> Minio ()
@@ -170,9 +169,7 @@ putObjectPart bucket object uploadId partNumber headers payload = do
           def { riMethod = HT.methodPut
               , riBucket = Just bucket
               , riObject = Just object
-              , riQueryParams = [("partNumber", Just $ encodeUtf8 $
+              , riQueryParams = mkOptionalParams params
-                                                show partNumber),
-                                 ("uploadId", Just $ encodeUtf8 uploadId)]
               , riHeaders = headers
               , riPayload = payload
               }
@@ -181,6 +178,11 @@ putObjectPart bucket object uploadId partNumber headers payload = do
   maybe
     (throwError $ MErrValidation MErrVETagHeaderNotFound)
     (return . PartInfo partNumber) etag
+  where
+    params = [
+        ("uploadId", Just uploadId)
+      , ("partNumber", Just $ show partNumber)
+      ]
 
 -- | Complete a multipart upload.
 completeMultipartUpload :: Bucket -> Object -> UploadId -> [PartInfo]
@@ -190,11 +192,13 @@ completeMultipartUpload bucket object uploadId partInfo = do
           def { riMethod = HT.methodPost
               , riBucket = Just bucket
               , riObject = Just object
-              , riQueryParams = [("uploadId", Just $ encodeUtf8 uploadId)]
+              , riQueryParams = mkOptionalParams params
               , riPayload = PayloadBS $
                             mkCompleteMultipartUploadRequest partInfo
               }
   parseCompleteMultipartUploadResponse $ NC.responseBody resp
+  where
+    params = [("uploadId", Just uploadId)]
 
 -- | Abort a multipart upload.
 abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio ()
@@ -202,9 +206,10 @@ abortMultipartUpload bucket object uploadId = do
   void $ executeRequest $ def { riMethod = HT.methodDelete
                               , riBucket = Just bucket
                               , riObject = Just object
-                              , riQueryParams = [("uploadId",
+                              , riQueryParams = mkOptionalParams params
-                                                  Just $ encodeUtf8 uploadId)]
                               }
+  where
+    params = [("uploadId", Just uploadId)]
 
 -- | List incomplete multipart uploads.
 listIncompleteUploads :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text
@@ -212,17 +217,33 @@ 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) : qp
+                               , riQueryParams = ("uploads", Nothing): mkOptionalParams params
                                }
   parseListUploadsResponse $ NC.responseBody resp
   where
     -- build optional query params
-    prefixList = map ((\k -> ("prefix", k)) . Just . encodeUtf8) $
+    params = [
-                 maybeToList prefix
+        ("prefix", prefix)
-    delimList = map ((\k -> ("delimiter", k)) . Just . encodeUtf8) $
+      , ("delimiter", delimiter)
-                maybeToList delimiter
+      , ("key-marker", keyMarker)
-    keyMarkerList = map ((\k -> ("key-marker", k)) . Just . encodeUtf8) $
+      , ("upload-id-marker", uploadIdMarker)
-                maybeToList keyMarker
+      ]
-    uploadIdMarkerList = map ((\k -> ("upload-id-marker", k)) . Just . encodeUtf8) $
+
-                maybeToList uploadIdMarker
+
-    qp = concat [prefixList, delimList, keyMarkerList, uploadIdMarkerList]
+-- | List parts of an ongoing multipart upload.
+listIncompleteParts :: Bucket -> Object -> UploadId -> Maybe Text
+                      -> Maybe Text -> Minio ListPartsResult
+listIncompleteParts bucket object uploadId maxParts partNumMarker = do
+  resp <- executeRequest $ def { riMethod = HT.methodGet
+                               , riBucket = Just bucket
+                               , riObject = Just object
+                               , riQueryParams = mkOptionalParams params
+                               }
+  parseListPartsResponse $ NC.responseBody resp
+  where
+    -- build optional query params
+    params = [
+        ("uploadId", Just uploadId)
+      , ("part-number-marker", partNumMarker)
+      , ("max-parts", maxParts)
+      ]

src/Network/Minio/Utils.hs

@@ -95,3 +95,13 @@ limitedMapConcurrently count act args = do
         thread <- A.async $ act a
         others <- workOn qs as
         return (thread : others)
+
+
+-- helper function to 'drop' empty optional parameter.
+mkQuery :: Text -> Maybe Text -> Maybe (Text, Text)
+mkQuery k mv = (k,) <$> mv
+
+-- helper function to build query parameters that are optional.
+-- don't use it with mandatory query params with empty value.
+mkOptionalParams :: [(Text, Maybe Text)] -> HT.Query
+mkOptionalParams params = HT.toQuery $ (uncurry  mkQuery) <$> params

src/Network/Minio/XmlParser.hs

@@ -5,6 +5,7 @@ module Network.Minio.XmlParser
   , parseCompleteMultipartUploadResponse
   , parseListObjectsResponse
   , parseListUploadsResponse
+  , parseListPartsResponse
   ) where
 
 import Data.List (zip3, zip4)
@@ -18,6 +19,14 @@ import           Lib.Prelude
 
 import           Network.Minio.Data
 
+
+-- | Helper functions.
+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+uncurry3 f (a, b, c) = f a b c
+
+uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
+uncurry4 f (a, b, c, d) = f a b c d
+
 -- | Represent the time format string returned by S3 API calls.
 s3TimeFormat :: [Char]
 s3TimeFormat = iso8601DateFormat $ Just "%T%QZ"
@@ -28,6 +37,10 @@ parseS3XMLTime = either (throwError . MErrXml) return
                . parseTimeM True defaultTimeLocale s3TimeFormat
                . T.unpack
 
+parseDecimals :: (MonadError MinioErr m, Integral a) => [Text] -> m [a]
+parseDecimals numStr = forM numStr $ \str ->
+  either (throwError . MErrXml . show) return $ fst <$> decimal str
+
 s3Elem :: Text -> Axis
 s3Elem = element . s3Name
 
@@ -85,13 +98,9 @@ parseListObjectsResponse xmldata = do
 
   modTimes <- mapM parseS3XMLTime modTimeStr
 
-  sizes <- forM sizeStr $ \str ->
+  sizes <- parseDecimals sizeStr
-    either (throwError . MErrXml . show) return $ fst <$> decimal str
 
   let
-    uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
-    uncurry4 f (a, b, c, d) = f a b c d
-
     objects = map (uncurry4 ObjectInfo) $ zip4 keys modTimes etags sizes
 
   return $ ListObjectsResult hasMore nextToken objects prefixes
@@ -113,9 +122,27 @@ parseListUploadsResponse xmldata = do
   uploadInitTimes <- mapM parseS3XMLTime uploadInitTimeStr
 
   let
-    uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
-    uncurry3 f (a, b, c) = f a b c
-
     uploads = map (uncurry3 UploadInfo) $ zip3 uploadKeys uploadIds uploadInitTimes
 
   return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes
+
+parseListPartsResponse :: (MonadError MinioErr m)
+                       => LByteString -> m ListPartsResult
+parseListPartsResponse xmldata = do
+  r <- parseRoot xmldata
+  let
+    hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content)
+    nextPartNumStr = headMay $ r $/ s3Elem "NextPartNumberMarker" &/ content
+    partNumberStr = r $/ s3Elem "Part" &/ s3Elem "PartNumber" &/ content
+    partModTimeStr = r $/ s3Elem "Part" &/ s3Elem "LastModified" &/ content
+    partETags = r $/ s3Elem "Part" &/ s3Elem "ETag" &/ content
+    partSizeStr = r $/ s3Elem "Part" &/ s3Elem "Size" &/ content
+
+  partModTimes <- mapM parseS3XMLTime partModTimeStr
+  partSizes <- parseDecimals partSizeStr
+  partNumbers <- parseDecimals partNumberStr
+  nextPartNum <- parseDecimals $ maybeToList nextPartNumStr
+
+  let
+    partInfos = map (uncurry4 ListPartInfo) $ zip4 partNumbers partETags partSizes partModTimes
+  return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos

test/Network/Minio/XmlParser/Test.hs

@@ -19,6 +19,7 @@ xmlParserTests = testGroup "XML Parser Tests"
   , testCase "Test parseListObjectsResponse" testParseListObjectsResult
   , testCase "Test parseListUploadsresponse" testParseListIncompleteUploads
   , testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse
+  , testCase "Test parseListPartsResponse" testParseListPartsResponse
   ]
 
 testParseLocation :: Assertion
@@ -165,3 +166,49 @@ testParseCompleteMultipartUploadResponse = do
   case parsedETagE of
     Right actualETag -> actualETag @?= expectedETag
     _ -> assertFailure $ "Parsing failed => " ++ show parsedETagE
+
+testParseListPartsResponse :: Assertion
+testParseListPartsResponse = do
+  let
+    xmldata = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+\<ListPartsResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+  \<Bucket>example-bucket</Bucket>\
+  \<Key>example-object</Key>\
+  \<UploadId>XXBsb2FkIElEIGZvciBlbHZpbmcncyVcdS1tb3ZpZS5tMnRzEEEwbG9hZA</UploadId>\
+  \<Initiator>\
+      \<ID>arn:aws:iam::111122223333:user/some-user-11116a31-17b5-4fb7-9df5-b288870f11xx</ID>\
+      \<DisplayName>umat-user-11116a31-17b5-4fb7-9df5-b288870f11xx</DisplayName>\
+  \</Initiator>\
+  \<Owner>\
+    \<ID>75aa57f09aa0c8caeab4f8c24e99d10f8e7faeebf76c078efc7c6caea54ba06a</ID>\
+    \<DisplayName>someName</DisplayName>\
+  \</Owner>\
+  \<StorageClass>STANDARD</StorageClass>\
+  \<PartNumberMarker>1</PartNumberMarker>\
+  \<NextPartNumberMarker>3</NextPartNumberMarker>\
+  \<MaxParts>2</MaxParts>\
+  \<IsTruncated>true</IsTruncated>\
+  \<Part>\
+    \<PartNumber>2</PartNumber>\
+    \<LastModified>2010-11-10T20:48:34.000Z</LastModified>\
+    \<ETag>\"7778aef83f66abc1fa1e8477f296d394\"</ETag>\
+    \<Size>10485760</Size>\
+  \</Part>\
+  \<Part>\
+    \<PartNumber>3</PartNumber>\
+    \<LastModified>2010-11-10T20:48:33.000Z</LastModified>\
+    \<ETag>\"aaaa18db4cc2f85cedef654fccc4a4x8\"</ETag>\
+    \<Size>10485760</Size>\
+  \</Part>\
+\</ListPartsResult>"
+
+    expectedListResult = ListPartsResult True (Just 3) [part1, part2]
+    part1 = ListPartInfo 2 "\"7778aef83f66abc1fa1e8477f296d394\"" 10485760 modifiedTime1
+    modifiedTime1 = flip UTCTime 74914 $ fromGregorian 2010 11 10
+    part2 = ListPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2
+    modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10
+
+  parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata
+  case parsedListPartsResult of
+    Right listPartsResult -> listPartsResult @?= expectedListResult
+    _ -> assertFailure $ "Parsing failed => " ++ show parsedListPartsResult

test/Spec.hs

@@ -128,8 +128,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server"
         (map oiObject $ lorObjects res)
 
       step "Cleanup actions"
-      forM_ [1..10::Int] $ \s ->
+      forM_ [1..10::Int] $ \s -> deleteObject bucket (T.concat ["lsb-release", T.pack (show s)])
-        deleteObject bucket (T.concat ["lsb-release", T.pack (show s)])
 
   , funTestWithBucket "Basic listMultipartUploads Test" "testbucket4" $ \step bucket -> do
       let object = "newmpupload"
@@ -152,6 +151,24 @@ liveServerUnitTests = testGroup "Unit tests against a live server"
 
       step "cleanup"
       deleteObject bucket "big"
+
+  , funTestWithBucket "Basic listIncompleteParts Test" "testbucket6" $ \step bucket -> do
+      let
+        object = "newmpupload"
+        mb15 = 15 * 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"
+      h <- liftIO $ SIO.openBinaryFile "/tmp/inputfile" SIO.ReadMode
+      forM [1..10] $ \pnum ->
+        putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb15
+
+      step "fetch list parts"
+      listPartsResult <- listIncompleteParts bucket object uid Nothing Nothing
+      liftIO $ (length $ lprParts listPartsResult) @?= 10
   ]
 
 unitTests :: TestTree