diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs
index 0a295c0..1d1d466 100644
--- a/src/Network/Minio/Data.hs
+++ b/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
diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs
index 705b26a..0af7a64 100644
--- a/src/Network/Minio/S3API.hs
+++ b/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]
diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs
index 7f21b0a..30b0300 100644
--- a/src/Network/Minio/XmlParser.hs
+++ b/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
diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs
index ca71252..dd63ea6 100644
--- a/test/Network/Minio/XmlParser/Test.hs
+++ b/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
- xmldata = "\
- \\
- \bucket\
- \\
- \205\
- \1000\
- \false\
- \\
- \my-image.jpg\
- \2009-10-12T17:50:30.000Z\
- \"fba9dede5f27731c9771645a39863328"\
- \434234\
- \STANDARD\
- \\
- \"
+ let
+ xmldata = "\
+ \\
+ \bucket\
+ \\
+ \205\
+ \1000\
+ \false\
+ \\
+ \my-image.jpg\
+ \2009-10-12T17:50:30.000Z\
+ \"fba9dede5f27731c9771645a39863328"\
+ \434234\
+ \STANDARD\
+ \\
+ \"
- expectedListResult = ListObjectsResult False Nothing [object1] []
- object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234
- modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12
+ expectedListResult = ListObjectsResult False Nothing [object1] []
+ object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234
+ modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12
- parsedListObjectsResult <- runExceptT $ parseListObjectsResponse xmldata
- case parsedListObjectsResult of
- Right listObjectsResult -> listObjectsResult @?= expectedListResult
- _ -> assertFailure $ "Parsing failed => " ++ show parsedListObjectsResult
+ parsedListObjectsResult <- runExceptT $ parseListObjectsResponse xmldata
+ case parsedListObjectsResult of
+ Right listObjectsResult -> listObjectsResult @?= expectedListResult
+ _ -> assertFailure $ "Parsing failed => " ++ show parsedListObjectsResult
+
+testParseListIncompleteUploads :: Assertion
+testParseListIncompleteUploads = do
+ let
+ xmldata = "\
+ \example-bucket\
+ \\
+ \\
+ \sample.jpg\
+ \Xgw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1W99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--\
+ \/\
+ \\
+ \1000\
+ \false\
+ \\
+ \sample.jpg\
+ \Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--\
+ \\
+ \314133b66967d86f031c7249d1d9a80249109428335cd0ef1cdc487b4566cb1b\
+ \s3-nickname\
+ \\
+ \\
+ \314133b66967d86f031c7249d1d9a80249109428335cd0ef1cdc487b4566cb1b\
+ \s3-nickname\
+ \\
+ \STANDARD\
+ \2010-11-26T19:24:17.000Z\
+ \\
+ \\
+ \photos/\
+ \\
+ \\
+ \videos/\
+ \\
+ \"
+ 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
diff --git a/test/Spec.hs b/test/Spec.hs
index a412012..85787ef 100644
--- a/test/Spec.hs
+++ b/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