diff --git a/minio-hs.cabal b/minio-hs.cabal index f4112a1..c19f411 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -96,6 +96,7 @@ test-suite minio-hs-test , transformers-base , xml-conduit ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + -- ghc-options: -Wall default-language: Haskell2010 default-extensions: FlexibleContexts , FlexibleInstances @@ -118,6 +119,7 @@ test-suite minio-hs-test , Network.Minio.XmlParser , Network.Minio.Utils , Network.Minio.XmlGenerator.Test + , Network.Minio.XmlParser.Test source-repository head diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 0838145..a6695e3 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -63,7 +63,7 @@ fPutObject bucket object fp = do (releaseKey, h) <- allocateReadFile fp size <- liftIO $ IO.hFileSize h - putObject bucket object [] 0 (fromIntegral size) h + putObject bucket object [] h 0 (fromIntegral size) -- release file handle R.release releaseKey diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index ab07e96..bba6936 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -7,7 +7,10 @@ module Network.Minio.Data , Object , Region , BucketInfo(..) + , PartNumber , UploadId + , ETag + , PartInfo(..) , getPathFromRI , getRegionFromRI , Minio @@ -60,6 +63,10 @@ type Object = Text -- TODO: This could be a Sum Type with all defined regions for AWS. type Region = Text +-- | A type alias to represent an Entity-Tag returned by S3-compatible +-- APIs. +type ETag = Text + -- | -- BucketInfo returned for list buckets call data BucketInfo = BucketInfo { @@ -67,10 +74,19 @@ data BucketInfo = BucketInfo { , biCreationDate :: UTCTime } deriving (Show, Eq) +-- | A type alias to represent a part-number for multipart upload +type PartNumber = Int16 -- | A type alias to represent an upload-id for multipart upload type UploadId = Text +-- | A data-type to represent info about a part +data PartInfo = PartInfo PartNumber ETag + deriving (Show, Eq) + +instance Ord PartInfo where + (PartInfo a _) `compare` (PartInfo b _) = a `compare` b + data Payload = PayloadBS ByteString | PayloadH Handle Int64 -- offset @@ -104,6 +120,7 @@ getRegionFromRI ri = maybe "us-east-1" identity (riRegion ri) -- | Various validation errors data MErrV = MErrVSinglePUTSizeExceeded Int64 + | MErrVETagHeaderNotFound deriving (Show) -- | diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index 87a3085..ac19e88 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -24,6 +24,8 @@ module Network.Minio.S3API -- * Multipart Upload APIs -------------------------- , newMultipartUpload + , putObjectPart + , completeMultipartUpload , abortMultipartUpload ) where @@ -36,6 +38,7 @@ import Lib.Prelude import Network.Minio.Data import Network.Minio.API +import Network.Minio.Utils import Network.Minio.XmlParser import Network.Minio.XmlGenerator @@ -82,9 +85,9 @@ maxSinglePutObjectSizeBytes = 5 * 1024 * 1024 * 1024 -- | PUT an object into the service. This function performs a single -- PUT object call, and so can only transfer objects upto 5GiB. -putObject :: Bucket -> Object -> [HT.Header] -> Int64 - -> Int64 -> Handle -> Minio () -putObject bucket object headers offset size h = do +putObject :: Bucket -> Object -> [HT.Header] -> Handle -> Int64 + -> Int64 -> Minio () +putObject bucket object headers h offset size = do -- check length is within single PUT object size. when (size > maxSinglePutObjectSizeBytes) $ throwError $ MErrValidation $ MErrVSinglePUTSizeExceeded size @@ -126,6 +129,40 @@ newMultipartUpload bucket object headers = do } parseNewMultipartUpload $ NC.responseBody resp +-- | PUT a part of an object as part of a multi-part upload. +putObjectPart :: Bucket -> Object -> UploadId -> PartNumber -> [HT.Header] + -> Handle -> Int64 -> Int64 -> Minio PartInfo +putObjectPart bucket object uploadId partNumber headers h offset size = do + resp <- executeRequest $ + def { riMethod = HT.methodPut + , riBucket = Just bucket + , riObject = Just object + , riQueryParams = [("partNumber", Just $ encodeUtf8 $ + show partNumber), + ("uploadId", Just $ encodeUtf8 uploadId)] + , riHeaders = headers + , riPayload = PayloadH h offset size + } + let rheaders = NC.responseHeaders resp + etag = getETagHeader rheaders + maybe + (throwError $ MErrValidation MErrVETagHeaderNotFound) + (return . PartInfo partNumber) etag + +-- | Complete a multipart upload. +completeMultipartUpload :: Bucket -> Object -> UploadId -> [PartInfo] + -> Minio ETag +completeMultipartUpload bucket object uploadId partInfo = do + resp <- executeRequest $ + def { riMethod = HT.methodPost + , riBucket = Just bucket + , riObject = Just object + , riQueryParams = [("uploadId", Just $ encodeUtf8 uploadId)] + , riPayload = PayloadBS $ + mkCompleteMultipartUploadRequest partInfo + } + parseCompleteMultipartUploadResponse $ NC.responseBody resp + -- | Abort a multipart upload. abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio () abortMultipartUpload bucket object uploadId = do diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index cbfb4d0..0c6a7da 100644 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -7,6 +7,8 @@ import qualified Network.HTTP.Client as NClient import Network.HTTP.Conduit (Response) import qualified Data.Conduit as C import qualified Data.ByteString.Lazy as LBS +import Data.Text.Encoding.Error (lenientDecode) +-- import Data.Text.Encoding (decodeUtf8With) import qualified Network.HTTP.Types as HT import qualified Control.Exception.Lifted as ExL @@ -24,6 +26,15 @@ allocateReadFile fp = do openReadFile f = runExceptT $ tryIO $ IO.openBinaryFile f IO.ReadMode cleanup = either (const $ return ()) IO.hClose +lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString +lookupHeader hdr = headMay . map snd . filter (\(h, _) -> h == hdr) + +getETagHeader :: [HT.Header] -> Maybe Text +getETagHeader hs = decodeUtf8Lenient <$> lookupHeader "ETag" hs + +decodeUtf8Lenient :: ByteString -> Text +decodeUtf8Lenient = decodeUtf8With lenientDecode + isSuccessStatus :: HT.Status -> Bool isSuccessStatus sts = let s = HT.statusCode sts in (s >= 200 && s < 300) diff --git a/src/Network/Minio/XmlGenerator.hs b/src/Network/Minio/XmlGenerator.hs index 60441fa..dbb6f29 100644 --- a/src/Network/Minio/XmlGenerator.hs +++ b/src/Network/Minio/XmlGenerator.hs @@ -1,9 +1,11 @@ module Network.Minio.XmlGenerator ( mkCreateBucketConfig + , mkCompleteMultipartUploadRequest ) where import Lib.Prelude +import qualified Data.Text as T import qualified Data.ByteString.Lazy as LBS import Text.XML import qualified Data.Map as M @@ -11,12 +13,28 @@ import qualified Data.Map as M import Network.Minio.Data +-- | Create a bucketConfig request body XML mkCreateBucketConfig :: Region -> ByteString mkCreateBucketConfig location = LBS.toStrict $ renderLBS def bucketConfig where s3Element n = Element (s3Name n) M.empty - root = s3Element "CreateBucketConfiguration" + root = s3Element "CreateBucketConfiguration" [ NodeElement $ s3Element "LocationConstraint" [ NodeContent location] ] bucketConfig = Document (Prologue [] Nothing []) root [] + +-- | Create a completeMultipartUpload request body XML +mkCompleteMultipartUploadRequest :: [PartInfo] -> ByteString +mkCompleteMultipartUploadRequest partInfo = + LBS.toStrict $ renderLBS def cmur + where + root = Element "CompleteMultipartUpload" M.empty $ + map (NodeElement . mkPart) partInfo + mkPart (PartInfo n etag) = Element "Part" M.empty + [ NodeElement $ Element "PartNumber" M.empty + [NodeContent $ T.pack $ show n] + , NodeElement $ Element "ETag" M.empty + [NodeContent etag] + ] + cmur = Document (Prologue [] Nothing []) root [] diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index be5ffd9..d06c2dc 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -2,6 +2,7 @@ module Network.Minio.XmlParser ( parseListBuckets , parseLocation , parseNewMultipartUpload + , parseCompleteMultipartUploadResponse ) where import Text.XML @@ -44,3 +45,11 @@ parseNewMultipartUpload xmldata = do doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata return $ T.concat $ fromDocument doc $// element (s3Name "UploadId") &/ content + +-- | Parse the response XML of completeMultipartUpload call. +parseCompleteMultipartUploadResponse :: (MonadError MinioErr m) + => LByteString -> m ETag +parseCompleteMultipartUploadResponse xmldata = do + doc <- either (throwError . MErrXml . show) return $ parseLBS def xmldata + return $ T.concat $ fromDocument doc + $// element (s3Name "ETag") &/ content diff --git a/test/Network/Minio/XmlGenerator/Test.hs b/test/Network/Minio/XmlGenerator/Test.hs index fe4d6f9..e445a21 100644 --- a/test/Network/Minio/XmlGenerator/Test.hs +++ b/test/Network/Minio/XmlGenerator/Test.hs @@ -8,17 +8,24 @@ import Test.Tasty.HUnit import Lib.Prelude import Network.Minio.XmlGenerator +import Network.Minio.Data xmlGeneratorTests :: TestTree xmlGeneratorTests = testGroup "XML Generator Tests" [ testCase "Test mkCreateBucketConfig" testMkCreateBucketConfig + , testCase "Test mkCompleteMultipartUploadRequest" testMkCompleteMultipartUploadRequest ] -euBucketConfig :: ByteString -euBucketConfig = "\ - \EU\ - \" - testMkCreateBucketConfig :: Assertion testMkCreateBucketConfig = do - assertEqual "CreateBucketConfiguration xml should match: " euBucketConfig $ mkCreateBucketConfig "EU" + assertEqual "CreateBucketConfiguration xml should match: " expected $ + mkCreateBucketConfig "EU" + where + expected = "EU" + +testMkCompleteMultipartUploadRequest :: Assertion +testMkCompleteMultipartUploadRequest = + assertEqual "completeMultipartUpload xml should match: " expected $ + mkCompleteMultipartUploadRequest [PartInfo 1 "abc"] + where + expected = "1abc" diff --git a/test/Spec.hs b/test/Spec.hs index 511617f..a0f30fc 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,7 +3,7 @@ import Test.Tasty.HUnit import Lib.Prelude --- import qualified System.IO as SIO +import qualified System.IO as SIO import Control.Monad.Trans.Resource (runResourceT) import qualified Data.Text as T @@ -48,45 +48,70 @@ properties = testGroup "Properties" [] -- [scProps, qcProps] -- (n :: Integer) >= 3 QC.==> x^n + y^n /= (z^n :: Integer) -- ] +funTestWithBucket :: TestName -> Bucket + -> (([Char] -> Minio ()) -> Bucket -> Minio ()) -> TestTree +funTestWithBucket t b minioTest = testCaseSteps t $ \step -> do + step $ "Creating bucket for test - " ++ t + let liftStep = liftIO . step + ret <- runResourceT $ runMinio def $ do + putBucket b "us-east-1" + minioTest liftStep b + deleteBucket b + isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret) + liveServerUnitTests :: TestTree liveServerUnitTests = testGroup "Unit tests against a live server" - [ testCaseSteps "Various functional tests" $ \step -> do + [ funTestWithBucket "Basic tests" "testbucket1" $ \step bucket -> do + step "getService works and contains the test bucket." + buckets <- getService + unless (length (filter (== bucket) $ map biName buckets) == 1) $ + liftIO $ + assertFailure ("The bucket " ++ show bucket ++ + " was expected to exist.") - ret <- runResourceT $ runMinio def $ do + step "getLocation works" + region <- getLocation bucket + liftIO $ region == "" @? ("Got unexpected region => " ++ show region) - liftIO $ step "getService works and returns no buckets in the beginning." - buckets <- getService - liftIO $ (length buckets == 0) @? - ("Live server must have no buckets at beginning.") + step "singlepart putObject works" + fPutObject bucket "lsb-release" "/etc/lsb-release" - liftIO $ step "putBucket works" - putBucket "testbucket" "us-east-1" + step "simple getObject works" + fGetObject bucket "lsb-release" "/tmp/out" - liftIO $ step "getLocation works" - region <- getLocation "testbucket" - liftIO $ region == "" @? ("Got unexpected region => " ++ show region) + step "create new multipart upload works" + uid <- newMultipartUpload bucket "newmpupload" [] + liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") - liftIO $ step "singlepart putObject works" - fPutObject "testbucket" "lsb-release" "/etc/lsb-release" + step "abort a new multipart upload works" + abortMultipartUpload bucket "newmpupload" uid - liftIO $ step "simple getObject works" - fGetObject "testbucket" "lsb-release" "/tmp/out" + step "delete object works" + deleteObject bucket "lsb-release" - liftIO $ step "create new multipart upload works" - uid <- newMultipartUpload "testbucket" "newmpupload" [] - liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") + , funTestWithBucket "Multipart Upload Test" "testbucket2" $ \step bucket -> do + let object = "newmpupload" - liftIO $ step "abort a new multipart upload works" - abortMultipartUpload "testbucket" "newmpupload" uid + step "create new multipart upload" + uid <- newMultipartUpload bucket object [] + liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") - liftIO $ step "delete object works" - deleteObject "testbucket" "lsb-release" + step "put object parts 1..10" + h <- liftIO $ SIO.openBinaryFile "/tmp/inputfile" SIO.ReadMode + let mb15 = 15 * 1024 * 1024 + partInfo <- forM [1..10] $ \pnum -> + putObjectPart bucket object uid pnum [] h 0 mb15 - liftIO $ step "delete bucket works" - deleteBucket "testbucket" + step "complete multipart" + etag <- completeMultipartUpload bucket object uid partInfo - isRight ret @? ("Functional test failure => " ++ show ret) + step $ "completeMultipart success - got etag: " ++ show etag + step $ "Retrieve the created object" + fGetObject bucket object "/tmp/newUpload" + + step $ "Cleanup actions" + deleteObject bucket object ] unitTests :: TestTree