haskell/minio-hs
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Implement list object parts of an ongoing multipart upload.

Browse Source
This commit is contained in:
Krishnan Parthasarathi 2017-01-28 18:58:22 +05:30 committed by Aditya Manthramurthy
parent 74748cfb16
commit 5f1ee7fc67
6 changed files with 175 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/Network/Minio/Data.hs
View File

@ -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 {

71
src/Network/Minio/S3API.hs
View File

@ -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
ctokList = map ((\k -> ("continuation_token", k)) . Just . encodeUtf8) $
maybeToList nextToken
prefixList = map ((\k -> ("prefix", k)) . Just . encodeUtf8) $
maybeToList prefix
delimList = map ((\k -> ("delimiter", k)) . Just . encodeUtf8) $
maybeToList delimiter
qp = concat [ctokList, prefixList, delimList]
params = [
("list-type", Just "2")
, ("continuation_token", nextToken)
, ("prefix", prefix)
, ("delimiter", delimiter)
]
-- | 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 $
show partNumber),
("uploadId", Just $ encodeUtf8 uploadId)]
, riQueryParams = mkOptionalParams params
, 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",
Just $ encodeUtf8 uploadId)]
, riQueryParams = mkOptionalParams params
}
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) $
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]
params = [
("prefix", prefix)
, ("delimiter", delimiter)
, ("key-marker", keyMarker)
, ("upload-id-marker", uploadIdMarker)
]
-- | 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)
]

10
src/Network/Minio/Utils.hs
View File

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

43
src/Network/Minio/XmlParser.hs
View File

@ -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 ->
either (throwError . MErrXml . show) return $ fst <$> decimal str
sizes <- parseDecimals sizeStr
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

47
test/Network/Minio/XmlParser/Test.hs
View File

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

21
test/Spec.hs
View File

@ -128,8 +128,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server"
(map oiObject $ lorObjects res)
step "Cleanup actions"
forM_ [1..10::Int] $ \s ->
deleteObject bucket (T.concat ["lsb-release", T.pack (show s)])
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"
@ -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