diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index a622766..acf5f84 100644 --- a/src/Network/Minio/Data.hs +++ b/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 { diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index 661d99a..441bd0e 100644 --- a/src/Network/Minio/S3API.hs +++ b/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 - 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) + ] diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index 448d241..c92a820 100644 --- a/src/Network/Minio/Utils.hs +++ b/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 diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index 30b0300..5042dd0 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/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 -> - 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 diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs index a212fb6..d060b6d 100644 --- a/test/Network/Minio/XmlParser/Test.hs +++ b/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 = "\ +\\ + \example-bucket\ + \example-object\ + \XXBsb2FkIElEIGZvciBlbHZpbmcncyVcdS1tb3ZpZS5tMnRzEEEwbG9hZA\ + \\ + \arn:aws:iam::111122223333:user/some-user-11116a31-17b5-4fb7-9df5-b288870f11xx\ + \umat-user-11116a31-17b5-4fb7-9df5-b288870f11xx\ + \\ + \\ + \75aa57f09aa0c8caeab4f8c24e99d10f8e7faeebf76c078efc7c6caea54ba06a\ + \someName\ + \\ + \STANDARD\ + \1\ + \3\ + \2\ + \true\ + \\ + \2\ + \2010-11-10T20:48:34.000Z\ + \\"7778aef83f66abc1fa1e8477f296d394\"\ + \10485760\ + \\ + \\ + \3\ + \2010-11-10T20:48:33.000Z\ + \\"aaaa18db4cc2f85cedef654fccc4a4x8\"\ + \10485760\ + \\ +\" + + 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 diff --git a/test/Spec.hs b/test/Spec.hs index efcab1b..60d49e2 100644 --- a/test/Spec.hs +++ b/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 -> - 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