From 41d86e86ff8bb5bf9f5c1fe228fe7458a0385a3a Mon Sep 17 00:00:00 2001 From: Krishnan Parthasarathi Date: Sun, 22 Jan 2017 19:25:06 +0530 Subject: [PATCH] Add listIncompleteUploads s3 api. --- src/Network/Minio/Data.hs | 14 +++++ src/Network/Minio/S3API.hs | 26 +++++++- src/Network/Minio/XmlParser.hs | 28 ++++++++- test/Network/Minio/XmlParser/Test.hs | 93 +++++++++++++++++++++------- test/Spec.hs | 10 +++ 5 files changed, 145 insertions(+), 26 deletions(-) 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