Add listIncompleteUploads s3 api.

src/Network/Minio/Data.hs

@@ -65,6 +65,20 @@ instance Ord PartInfo where
   (PartInfo a _) `compare` (PartInfo b _) = a `compare` b
 
 
+data ListUploadsResult = ListUploadsResult {
+    lurHasMore :: Bool
+  , lurNextKey :: Maybe Text
+  , lurNextUpload :: Maybe Text
+  , lurUploads :: [UploadInfo]
+  , lurCPrefixes :: [Text]
+  } deriving (Show, Eq)
+
+data UploadInfo = UploadInfo {
+    uiKey :: Object
+  , uiUploadId :: UploadId
+  , uiInitTime :: UTCTime
+  } deriving (Show, Eq)
+
 data ListObjectsResult = ListObjectsResult {
     lorHasMore :: Bool
   , lorNextToken :: Maybe Text

src/Network/Minio/S3API.hs

@@ -30,6 +30,7 @@ module Network.Minio.S3API
   , putObjectPart
   , completeMultipartUpload
   , abortMultipartUpload
+  , listIncompleteUploads
   ) where
 
 import qualified Data.Conduit as C
@@ -104,6 +105,9 @@ putObject bucket object headers h offset size = do
         , riPayload = PayloadH h offset size
         }
 
+
+-- | List objects in a bucket matching prefix up to delimiter,
+-- starting from nextToken.
 listObjects :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text
             -> Minio ListObjectsResult
 listObjects bucket prefix nextToken delimiter = do
@@ -122,7 +126,6 @@ listObjects bucket prefix nextToken delimiter = do
                 maybeToList delimiter
     qp = concat [ctokList, prefixList, delimList]
 
-
 -- | DELETE a bucket from the service.
 deleteBucket :: Bucket -> Minio ()
 deleteBucket bucket = do
@@ -194,3 +197,24 @@ abortMultipartUpload bucket object uploadId = do
                               , riQueryParams = [("uploadId",
                                                   Just $ encodeUtf8 uploadId)]
                               }
+
+-- | List incomplete multipart uploads.
+listIncompleteUploads :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text
+                      -> Maybe Text -> Minio ListUploadsResult
+listIncompleteUploads bucket prefix delimiter keyMarker uploadIdMarker = do
+  resp <- executeRequest $ def { riMethod = HT.methodGet
+                               , riBucket = Just bucket
+                               , riQueryParams = ("uploads", Nothing) : qp
+                               }
+  parseListUploadsResponse $ NC.responseBody resp
+  where
+    -- build optional query params
+    prefixList = map ((\k -> ("prefix", k)) . Just . encodeUtf8) $
+                 maybeToList prefix
+    delimList = map ((\k -> ("delimiter", k)) . Just . encodeUtf8) $
+                maybeToList delimiter
+    keyMarkerList = map ((\k -> ("key-marker", k)) . Just . encodeUtf8) $
+                maybeToList keyMarker
+    uploadIdMarkerList = map ((\k -> ("upload-id-marker", k)) . Just . encodeUtf8) $
+                maybeToList uploadIdMarker
+    qp = concat [prefixList, delimList, keyMarkerList, uploadIdMarkerList]

src/Network/Minio/XmlParser.hs

@@ -4,9 +4,10 @@ module Network.Minio.XmlParser
   , parseNewMultipartUpload
   , parseCompleteMultipartUploadResponse
   , parseListObjectsResponse
+  , parseListUploadsResponse
   ) where
 
-import           Data.List (zip4)
+import Data.List (zip3, zip4)
 import qualified Data.Text as T
 import           Data.Text.Read (decimal)
 import           Data.Time
@@ -65,6 +66,7 @@ parseCompleteMultipartUploadResponse xmldata = do
   r <- parseRoot xmldata
   return $ T.concat $ r $// s3Elem "ETag" &/ content
 
+-- | Parse the response XML of a list objects call.
 parseListObjectsResponse :: (MonadError MinioErr m)
                          => LByteString -> m ListObjectsResult
 parseListObjectsResponse xmldata = do
@@ -93,3 +95,27 @@ parseListObjectsResponse xmldata = do
     objects = map (uncurry4 ObjectInfo) $ zip4 keys modTimes etags sizes
 
   return $ ListObjectsResult hasMore nextToken objects prefixes
+
+-- | Parse the response XML of a list incomplete multipart upload call.
+parseListUploadsResponse :: (MonadError MinioErr m)
+                         => LByteString -> m ListUploadsResult
+parseListUploadsResponse xmldata = do
+  r <- parseRoot xmldata
+  let
+    hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content)
+    prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content
+    nextKey = headMay $ r $/ s3Elem "NextKeyMarker" &/ content
+    nextUpload = headMay $ r $/ s3Elem "NextUploadIdMarker" &/ content
+    uploadKeys = r $/ s3Elem "Upload" &/ s3Elem "Key" &/ content
+    uploadIds = r $/ s3Elem "Upload" &/ s3Elem "UploadId" &/ content
+    uploadInitTimeStr = r $/ s3Elem "Upload" &/ s3Elem "Initiated" &/ content
+
+  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

test/Network/Minio/XmlParser/Test.hs

@@ -3,9 +3,9 @@ module Network.Minio.XmlParser.Test
     xmlParserTests
   ) where
 
-import Data.Time (addGregorianYearsClip, fromGregorian, UTCTime(..))
 import Test.Tasty
 import Test.Tasty.HUnit
+import Data.Time (fromGregorian, UTCTime(..))
 
 import Lib.Prelude
 
@@ -17,6 +17,7 @@ xmlParserTests = testGroup "XML Parser Tests"
   [ testCase "Test parseLocation" testParseLocation
   , testCase "Test parseNewMultipartUpload" testParseNewMultipartUpload
   , testCase "Test parseListObjectsResponse" testParseListObjectsResult
+  , testCase "Test parseListUploadsresponse" testParseListIncompleteUploads
   ]
 
 testParseLocation :: Assertion
@@ -76,28 +77,72 @@ testParseNewMultipartUpload = do
 
 testParseListObjectsResult :: Assertion
 testParseListObjectsResult = do
-    let
+  let
-        xmldata = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+    xmldata = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
-                \<ListBucketResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+              \<ListBucketResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
-                \<Name>bucket</Name>\
+              \<Name>bucket</Name>\
-                \<Prefix/>\
+              \<Prefix/>\
-                \<KeyCount>205</KeyCount>\
+              \<KeyCount>205</KeyCount>\
-                \<MaxKeys>1000</MaxKeys>\
+              \<MaxKeys>1000</MaxKeys>\
-                \<IsTruncated>false</IsTruncated>\
+              \<IsTruncated>false</IsTruncated>\
-                \<Contents>\
+              \<Contents>\
-                    \<Key>my-image.jpg</Key>\
+              \<Key>my-image.jpg</Key>\
-                    \<LastModified>2009-10-12T17:50:30.000Z</LastModified>\
+              \<LastModified>2009-10-12T17:50:30.000Z</LastModified>\
-                    \<ETag>&quot;fba9dede5f27731c9771645a39863328&quot;</ETag>\
+              \<ETag>&quot;fba9dede5f27731c9771645a39863328&quot;</ETag>\
-                    \<Size>434234</Size>\
+              \<Size>434234</Size>\
-                    \<StorageClass>STANDARD</StorageClass>\
+              \<StorageClass>STANDARD</StorageClass>\
-                \</Contents>\
+              \</Contents>\
-                \</ListBucketResult>"
+              \</ListBucketResult>"
 
-        expectedListResult = ListObjectsResult False Nothing [object1] []
+    expectedListResult = ListObjectsResult False Nothing [object1] []
-        object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234
+    object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234
-        modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12
+    modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12
 
-    parsedListObjectsResult <- runExceptT $ parseListObjectsResponse xmldata
+  parsedListObjectsResult <- runExceptT $ parseListObjectsResponse xmldata
-    case parsedListObjectsResult of
+  case parsedListObjectsResult of
-        Right listObjectsResult -> listObjectsResult @?= expectedListResult
+    Right listObjectsResult -> listObjectsResult @?= expectedListResult
-        _ -> assertFailure $ "Parsing failed => " ++ show parsedListObjectsResult
+    _ -> assertFailure $ "Parsing failed => " ++ show parsedListObjectsResult
+
+testParseListIncompleteUploads :: Assertion
+testParseListIncompleteUploads = do
+  let
+    xmldata = "<ListMultipartUploadsResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+  \<Bucket>example-bucket</Bucket>\
+  \<KeyMarker/>\
+  \<UploadIdMarker/>\
+  \<NextKeyMarker>sample.jpg</NextKeyMarker>\
+  \<NextUploadIdMarker>Xgw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1W99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--</NextUploadIdMarker>\
+  \<Delimiter>/</Delimiter>\
+  \<Prefix/>\
+  \<MaxUploads>1000</MaxUploads>\
+  \<IsTruncated>false</IsTruncated>\
+  \<Upload>\
+    \<Key>sample.jpg</Key>\
+    \<UploadId>Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--</UploadId>\
+    \<Initiator>\
+      \<ID>314133b66967d86f031c7249d1d9a80249109428335cd0ef1cdc487b4566cb1b</ID>\
+      \<DisplayName>s3-nickname</DisplayName>\
+    \</Initiator>\
+    \<Owner>\
+      \<ID>314133b66967d86f031c7249d1d9a80249109428335cd0ef1cdc487b4566cb1b</ID>\
+      \<DisplayName>s3-nickname</DisplayName>\
+    \</Owner>\
+    \<StorageClass>STANDARD</StorageClass>\
+    \<Initiated>2010-11-26T19:24:17.000Z</Initiated>\
+  \</Upload>\
+  \<CommonPrefixes>\
+    \<Prefix>photos/</Prefix>\
+  \</CommonPrefixes>\
+  \<CommonPrefixes>\
+    \<Prefix>videos/</Prefix>\
+  \</CommonPrefixes>\
+  \</ListMultipartUploadsResult>"
+    expectedListResult = ListUploadsResult False (Just "sample.jpg") (Just "Xgw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1W99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--") uploads prefixes
+    uploads = [UploadInfo "sample.jpg" "Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--" initTime]
+    initTime = UTCTime (fromGregorian 2010 11 26) 69857
+    prefixes = ["photos/", "videos/"]
+
+  parsedListUploadsResult <- runExceptT $ parseListUploadsResponse xmldata
+  case parsedListUploadsResult of
+    Right listUploadsResult -> listUploadsResult @?= expectedListResult
+    _ -> assertFailure $ "Parsing failed => " ++ show parsedListUploadsResult

test/Spec.hs

@@ -130,6 +130,16 @@ liveServerUnitTests = testGroup "Unit tests against a live server"
       step "cleanup"
       forM_ [1..10::Int] $ \s ->
         deleteObject bucket (T.concat ["lsb-release", T.pack (show s)])
+  , funTestWithBucket "Basic listMultipartUploads Test" "testbucket4" $ \step bucket -> do
+      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 "list incomplete multipart uploads"
+      incompleteUploads <- listIncompleteUploads bucket Nothing Nothing Nothing Nothing
+      liftIO $ (length $ lurUploads incompleteUploads) @?= 10
   ]
 
 unitTests :: TestTree