diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,3 @@ - Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ @@ -179,7 +178,7 @@ APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following - boilerplate notice, with the fields enclosed by brackets "[]" + boilerplate notice, with the fields enclosed by brackets "{}" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a @@ -187,7 +186,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright {yyyy} {name of copyright owner} Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,18 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + import Distribution.Simple main = defaultMain diff --git a/minio-hs.cabal b/minio-hs.cabal --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -1,14 +1,17 @@ name: minio-hs -version: 0.1.0 +version: 0.2.0 synopsis: A Minio client library, compatible with S3 like services. -description: Please see README.md -homepage: https://github.com/donatello/minio-hs#readme +description: minio-hs provides simple APIs to access Minio and Amazon + S3 compatible object storage server. For more details, + please see README.md. +homepage: https://github.com/minio/minio-hs#readme license: Apache-2.0 license-file: LICENSE author: Aditya Manthramurthy, Krishnan Parthasarathi -maintainer: aditya.mmy@gmail.com +maintainer: dev@minio.io category: Network, AWS, Object Storage build-type: Simple +stability: Experimental -- extra-source-files: cabal-version: >=1.10 @@ -23,6 +26,7 @@ , Network.Minio.Data.ByteString , Network.Minio.Data.Crypto , Network.Minio.Data.Time + , Network.Minio.Errors , Network.Minio.ListOps , Network.Minio.PutObject , Network.Minio.Sign.V4 @@ -52,6 +56,7 @@ , monad-control , resourcet , text + , text-format , time , transformers , transformers-base @@ -68,6 +73,82 @@ , TypeFamilies , TupleSections +Flag live-test + Default: True + Manual: True + +test-suite minio-hs-live-server-test + type: exitcode-stdio-1.0 + hs-source-dirs: test, src + main-is: LiveServer.hs + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + default-extensions: FlexibleContexts + , FlexibleInstances + , OverloadedStrings + , NoImplicitPrelude + , MultiParamTypeClasses + , MultiWayIf + , ScopedTypeVariables + , RankNTypes + , TupleSections + , TypeFamilies + other-modules: Lib.Prelude + , Network.Minio + , Network.Minio.API + , Network.Minio.Data + , Network.Minio.Data.ByteString + , Network.Minio.Data.Crypto + , Network.Minio.Data.Time + , Network.Minio.Errors + , Network.Minio.ListOps + , Network.Minio.PutObject + , Network.Minio.S3API + , Network.Minio.Sign.V4 + , Network.Minio.Utils + , Network.Minio.XmlGenerator + , Network.Minio.XmlGenerator.Test + , Network.Minio.XmlParser + , Network.Minio.XmlParser.Test + build-depends: base + , minio-hs + , protolude >= 0.1.6 && < 0.2 + , async + , bytestring + , case-insensitive + , conduit + , conduit-combinators + , conduit-extra + , containers + , cryptonite + , cryptonite-conduit + , data-default + , directory + , exceptions + , filepath + , http-client + , http-conduit + , http-types + , lifted-async + , lifted-base + , memory + , monad-control + , QuickCheck + , resourcet + , tasty + , tasty-hunit + , tasty-quickcheck + , tasty-smallcheck + , temporary + , text + , text-format + , time + , transformers + , transformers-base + , xml-conduit + if !flag(live-test) + buildable: False + test-suite minio-hs-test type: exitcode-stdio-1.0 hs-source-dirs: test, src @@ -103,6 +184,7 @@ , tasty-smallcheck , temporary , text + , text-format , time , transformers , transformers-base @@ -127,6 +209,7 @@ , Network.Minio.Data.ByteString , Network.Minio.Data.Crypto , Network.Minio.Data.Time + , Network.Minio.Errors , Network.Minio.ListOps , Network.Minio.PutObject , Network.Minio.S3API @@ -140,4 +223,4 @@ source-repository head type: git - location: https://github.com/donatello/minio-hs + location: https://github.com/minio/minio-hs diff --git a/src/Lib/Prelude.hs b/src/Lib/Prelude.hs --- a/src/Lib/Prelude.hs +++ b/src/Lib/Prelude.hs @@ -1,3 +1,19 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + {- Welcome to your custom Prelude Export here everything that should always be in your library scope @@ -6,11 +22,28 @@ -} module Lib.Prelude ( module Exports + , both + + , format ) where -import Protolude as Exports +import Protolude as Exports -import Data.Time as Exports (UTCTime) -import Control.Monad.Trans.Maybe as Exports (runMaybeT, MaybeT(..)) +import Data.Time as Exports (UTCTime(..), diffUTCTime) +import Control.Monad.Trans.Maybe as Exports (runMaybeT, MaybeT(..)) -import Control.Monad.Catch as Exports (throwM, MonadThrow, MonadCatch) +import Control.Monad.Catch as Exports (throwM, MonadThrow, MonadCatch) + +import Data.Text.Format as Exports (Shown(..)) +import qualified Data.Text.Format as TF +import Data.Text.Format.Params (Params) +import qualified Data.Text.Lazy as LT + +format :: Params ps => TF.Format -> ps -> Text +format f args = LT.toStrict $ TF.format f args + +-- import Data.Tuple as Exports (uncurry) + +-- | Apply a function on both elements of a pair +both :: (a -> b) -> (a, a) -> (b, b) +both f (a, b) = (f a, f b) diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -1,13 +1,32 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio ( ConnectInfo(..) , awsCI + , awsWithRegionCI , minioPlayCI + , minioCI , Minio , runMinio , runResourceT + , def -- * Error handling ----------------------- @@ -15,7 +34,7 @@ -- with an object storage service. , MinioErr(..) , MErrV(..) - , MError(..) + , ServiceErr(..) -- * Data Types ---------------- @@ -25,25 +44,28 @@ , BucketInfo(..) , ObjectInfo(..) , UploadInfo(..) - , ListPartInfo(..) + , ObjectPartInfo(..) , UploadId , ObjectData(..) + , CopyPartSource(..) -- * Bucket Operations ---------------------- - , getService + , listBuckets , getLocation , makeBucket + , removeBucket , listObjects , listIncompleteUploads - , listIncompleteParts -- * Object Operations ---------------------- , fGetObject , fPutObject - , putObjectFromSource + , putObject + , copyObject + , removeObject , getObject , statObject @@ -57,14 +79,21 @@ import Control.Monad.Trans.Resource (runResourceT) import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB +import Data.Default (def) +import qualified Data.Map as Map import Lib.Prelude import Network.Minio.Data +import Network.Minio.Errors import Network.Minio.ListOps import Network.Minio.PutObject import Network.Minio.S3API +-- | Lists buckets. +listBuckets :: Minio [BucketInfo] +listBuckets = getService + -- | Fetch the object and write it to the given file safely. The -- object is first written to a temporary file in the same directory -- and then moved to the given path. @@ -75,23 +104,37 @@ -- | Upload the given file to the given object. fPutObject :: Bucket -> Object -> FilePath -> Minio () -fPutObject bucket object f = void $ putObject bucket object $ +fPutObject bucket object f = void $ putObjectInternal bucket object $ ODFile f Nothing -- | Put an object from a conduit source. The size can be provided if --- known; this helps the library select optimal part sizes to --- performing a multipart upload. If not specified, it is assumed that --- the object can be potentially 5TiB and selects multipart sizes --- appropriately. -putObjectFromSource :: Bucket -> Object -> C.Producer Minio ByteString - -> Maybe Int64 -> Minio () -putObjectFromSource bucket object src sizeMay = void $ putObject bucket object $ - ODStream src sizeMay +-- known; this helps the library select optimal part sizes to perform +-- a multipart upload. If not specified, it is assumed that the object +-- can be potentially 5TiB and selects multipart sizes appropriately. +putObject :: Bucket -> Object -> C.Producer Minio ByteString + -> Maybe Int64 -> Minio () +putObject bucket object src sizeMay = + void $ putObjectInternal bucket object $ ODStream src sizeMay +-- | Perform a server-side copy operation to create an object with the +-- given bucket and object name from the source specification in +-- CopyPartSource. This function performs a multipart copy operation +-- if the new object is to be greater than 5GiB in size. +copyObject :: Bucket -> Object -> CopyPartSource -> Minio () +copyObject bucket object cps = void $ copyObjectInternal bucket object cps + +-- | Remove an object from the object store. +removeObject :: Bucket -> Object -> Minio () +removeObject = deleteObject + -- | Get an object from the object store as a resumable source (conduit). getObject :: Bucket -> Object -> Minio (C.ResumableSource Minio ByteString) getObject bucket object = snd <$> getObject' bucket object [] [] +-- | Get an object's metadata from the object store. +statObject :: Bucket -> Object -> Minio ObjectInfo +statObject bucket object = headObject bucket object + -- | Creates a new bucket in the object store. The Region can be -- optionally specified. If not specified, it will use the region -- configured in ConnectInfo, which is by default, the US Standard @@ -100,7 +143,9 @@ makeBucket bucket regionMay= do region <- maybe (asks $ connectRegion . mcConnInfo) return regionMay putBucket bucket region + modify (Map.insert bucket region) --- | Get an object's metadata from the object store. -statObject :: Bucket -> Object -> Minio ObjectInfo -statObject bucket object = headObject bucket object +removeBucket :: Bucket -> Minio () +removeBucket bucket = do + deleteBucket bucket + modify (Map.delete bucket) diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -1,3 +1,19 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio.API ( connect @@ -5,10 +21,14 @@ , runMinio , executeRequest , mkStreamRequest + , getLocation ) where import qualified Data.Conduit as C import Data.Conduit.Binary (sourceHandleRange) +import Data.Default (def) +import qualified Data.Map as Map +import qualified Data.Text as T import Network.HTTP.Conduit (Response) import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT @@ -17,8 +37,10 @@ import Network.Minio.Data import Network.Minio.Data.Crypto +import Network.Minio.Errors import Network.Minio.Sign.V4 import Network.Minio.Utils +import Network.Minio.XmlParser sha256Header :: ByteString -> HT.Header sha256Header = ("x-amz-content-sha256", ) @@ -38,24 +60,76 @@ (return . fromIntegral $ off) (return . fromIntegral $ size) -buildRequest :: (MonadIO m, MonadReader MinioConn m) - => RequestInfo -> m NC.Request + +-- | Fetch bucket location (region) +getLocation :: Bucket -> Minio Region +getLocation bucket = do + resp <- executeRequest $ def { + riBucket = Just bucket + , riQueryParams = [("location", Nothing)] + , riNeedsLocation = False + } + parseLocation $ NC.responseBody resp + + +-- | Looks for region in RegionMap and updates it using getLocation if +-- absent. +discoverRegion :: RequestInfo -> Minio (Maybe Region) +discoverRegion ri = runMaybeT $ do + bucket <- MaybeT $ return $ riBucket ri + regionMay <- gets (Map.lookup bucket) + maybe (do + l <- lift $ getLocation bucket + modify $ Map.insert bucket l + return l + ) return regionMay + + +buildRequest :: RequestInfo -> Minio NC.Request buildRequest ri = do - sha256Hash <- getPayloadSHA256Hash (riPayload ri) - let newRi = ri { - riPayloadHash = sha256Hash - , riHeaders = sha256Header sha256Hash : (riHeaders ri) - } + {- + If ListBuckets/MakeBucket/GetLocation then use connectRegion ci + Else If discovery off use connectRegion ci + Else { + // Here discovery is on + Lookup region in regionMap + If present use that + Else getLocation + } + -} ci <- asks mcConnInfo + region <- if | not $ riNeedsLocation ri -> -- getService/makeBucket/getLocation + -- don't need location + return $ Just $ connectRegion ci + | not $ connectAutoDiscoverRegion ci -> -- if autodiscovery of location is disabled by user + return $ Just $ connectRegion ci + | otherwise -> discoverRegion ri - reqHeaders <- liftIO $ signV4 ci newRi + regionHost <- case region of + Nothing -> return $ connectHost ci + Just r -> if "amazonaws.com" `T.isSuffixOf` (connectHost ci) + then maybe + (throwM $ MErrVRegionNotSupported r) + return + (Map.lookup r awsRegionMap) + else return $ connectHost ci + + sha256Hash <- getPayloadSHA256Hash (riPayload ri) + let newRi = ri { riPayloadHash = sha256Hash + , riHeaders = sha256Header sha256Hash : (riHeaders ri) + , riRegion = region + } + newCi = ci { connectHost = regionHost } + + reqHeaders <- liftIO $ signV4 newCi newRi + return NC.defaultRequest { NC.method = riMethod newRi - , NC.secure = connectIsSecure ci - , NC.host = encodeUtf8 $ connectHost ci - , NC.port = connectPort ci + , NC.secure = connectIsSecure newCi + , NC.host = encodeUtf8 $ connectHost newCi + , NC.port = connectPort newCi , NC.path = getPathFromRI newRi , NC.queryString = HT.renderQuery False $ riQueryParams newRi , NC.requestHeaders = reqHeaders diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -1,3 +1,19 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} module Network.Minio.Data where @@ -5,18 +21,47 @@ import qualified Control.Monad.Catch as MC import Control.Monad.Trans.Control import Control.Monad.Trans.Resource + import qualified Data.ByteString as B import Data.Default (Default(..)) -import Network.HTTP.Client (defaultManagerSettings, HttpException) +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.Time (formatTime, defaultTimeLocale) +import Network.HTTP.Client (defaultManagerSettings) import qualified Network.HTTP.Conduit as NC import Network.HTTP.Types (Method, Header, Query) import qualified Network.HTTP.Types as HT +import Network.Minio.Errors import Text.XML import Lib.Prelude --- | Connection Info data type. Use the Default instance to create --- connection info for your service. + +-- TODO: Add a type which provides typed constants for region. this +-- type should have a IsString instance to infer the appropriate +-- constant. +-- | awsRegionMap - library constant +awsRegionMap :: Map.Map Text Text +awsRegionMap = Map.fromList [ + ("us-east-1", "s3.amazonaws.com") + , ("us-east-2", "s3-us-east-2.amazonaws.com") + , ("us-west-1", "s3-us-west-1.amazonaws.com") + , ("us-east-2", "s3-us-west-2.amazonaws.com") + , ("ca-central-1", "s3-ca-central-1.amazonaws.com") + , ("ap-south-1", "s3-ap-south-1.amazonaws.com") + , ("ap-northeast-1", "s3-ap-northeast-1.amazonaws.com") + , ("ap-northeast-2", "s3-ap-northeast-2.amazonaws.com") + , ("ap-southeast-1", "s3-ap-southeast-1.amazonaws.com") + , ("ap-southeast-2", "s3-ap-southeast-2.amazonaws.com") + , ("eu-west-1", "s3-eu-west-1.amazonaws.com") + , ("eu-west-2", "s3-eu-west-2.amazonaws.com") + , ("eu-central-1", "s3-eu-central-1.amazonaws.com") + , ("sa-east-1", "s3-sa-east-1.amazonaws.com") + ] + +-- | Connection Info data type. To create a 'ConnectInfo' value, use one +-- of the provided smart constructors or override fields of the +-- Default instance. data ConnectInfo = ConnectInfo { connectHost :: Text , connectPort :: Int @@ -24,13 +69,22 @@ , connectSecretKey :: Text , connectIsSecure :: Bool , connectRegion :: Region + , connectAutoDiscoverRegion :: Bool } deriving (Eq, Show) +-- | Connects to a Minio server located at @localhost:9000@ with access +-- key /minio/ and secret key /minio123/. It is over __HTTP__ by +-- default. instance Default ConnectInfo where - def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" + def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" True --- | --- Default aws ConnectInfo. Credentials should be supplied before use. +-- | Default AWS ConnectInfo. Connects to "us-east-1". Credentials +-- should be supplied before use, for e.g.: +-- +-- > awsCI { +-- > connectAccessKey = "my-access-key" +-- > , connectSecretKey = "my-secret-key" +-- > } awsCI :: ConnectInfo awsCI = def { connectHost = "s3.amazonaws.com" @@ -40,8 +94,30 @@ , connectIsSecure = True } --- | --- Default minio play server ConnectInfo. Credentials are already filled. +-- | AWS ConnectInfo with a specified region. It can optionally +-- disable the automatic discovery of a bucket's region via the +-- Boolean argument. +-- +-- > awsWithRegionCI "us-west-1" False { +-- > connectAccessKey = "my-access-key" +-- > , connectSecretKey = "my-secret-key" +-- > } +-- +-- This restricts all operations to the "us-west-1" region and does +-- not perform any bucket location requests. +awsWithRegionCI :: Region -> Bool -> ConnectInfo +awsWithRegionCI region autoDiscoverRegion = + let host = maybe "s3.amazonaws.com" identity $ + Map.lookup region awsRegionMap + in awsCI { + connectHost = host + , connectRegion = region + , connectAutoDiscoverRegion = autoDiscoverRegion + } + + +-- | +-- ConnectInfo. Credentials are already filled in. minioPlayCI :: ConnectInfo minioPlayCI = def { connectHost = "play.minio.io" @@ -49,8 +125,28 @@ , connectAccessKey = "Q3AM3UQ867SPQQA43P2F" , connectSecretKey = "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG" , connectIsSecure = True + , connectAutoDiscoverRegion = False } +-- | ConnectInfo for Minio server. Takes hostname, port and a Boolean +-- to enable TLS. +-- +-- > minioCI "minio.example.com" 9000 True { +-- > connectAccessKey = "my-access-key" +-- > , connectSecretKey = "my-secret-key" +-- > } +-- +-- This connects to a Minio server at the given hostname and port over +-- HTTPS. +minioCI :: Text -> Int -> Bool -> ConnectInfo +minioCI host port isSecure = def { + connectHost = host + , connectPort = port + , connectRegion = "us-east-1" + , connectIsSecure = isSecure + , connectAutoDiscoverRegion = False + } + -- | -- Represents a bucket in the object store type Bucket = Text @@ -81,30 +177,25 @@ -- | 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 - +-- | A type to represent a part-number and etag. +type PartTuple = (PartNumber, ETag) -- | Represents result from a listing of object parts of an ongoing -- multipart upload. data ListPartsResult = ListPartsResult { lprHasMore :: Bool , lprNextPart :: Maybe Int - , lprParts :: [ListPartInfo] + , lprParts :: [ObjectPartInfo] } deriving (Show, Eq) -- | Represents information about an object part in an ongoing -- multipart upload. -data ListPartInfo = ListPartInfo { - piNumber :: PartNumber - , piETag :: ETag - , piSize :: Int64 - , piModTime :: UTCTime +data ObjectPartInfo = ObjectPartInfo { + opiNumber :: PartNumber + , opiETag :: ETag + , opiSize :: Int64 + , opiModTime :: UTCTime } deriving (Show, Eq) -- | Represents result from a listing of incomplete uploads to a @@ -113,7 +204,7 @@ lurHasMore :: Bool , lurNextKey :: Maybe Text , lurNextUpload :: Maybe Text - , lurUploads :: [UploadInfo] + , lurUploads :: [(Object, UploadId, UTCTime)] , lurCPrefixes :: [Text] } deriving (Show, Eq) @@ -122,6 +213,7 @@ uiKey :: Object , uiUploadId :: UploadId , uiInitTime :: UTCTime + , uiSize :: Int64 } deriving (Show, Eq) -- | Represents result from a listing of objects in a bucket. @@ -140,6 +232,47 @@ , oiSize :: Int64 } deriving (Show, Eq) +data CopyPartSource = CopyPartSource { + cpSource :: Text -- | formatted like "/sourceBucket/sourceObject" + , cpSourceRange :: Maybe (Int64, Int64) -- | (0, 9) means first ten + -- bytes of the source + -- object + , cpSourceIfMatch :: Maybe Text + , cpSourceIfNoneMatch :: Maybe Text + , cpSourceIfUnmodifiedSince :: Maybe UTCTime + , cpSourceIfModifiedSince :: Maybe UTCTime + } deriving (Show, Eq) + +instance Default CopyPartSource where + def = CopyPartSource "" def def def def def + +cpsToHeaders :: CopyPartSource -> [HT.Header] +cpsToHeaders cps = ("x-amz-copy-source", encodeUtf8 $ cpSource cps) : + (rangeHdr ++ (zip names values)) + where + names = ["x-amz-copy-source-if-match", "x-amz-copy-source-if-none-match", + "x-amz-copy-source-if-unmodified-since", + "x-amz-copy-source-if-modified-since"] + values = concatMap (maybeToList . fmap encodeUtf8 . (cps &)) + [cpSourceIfMatch, cpSourceIfNoneMatch, + fmap formatRFC1123 . cpSourceIfUnmodifiedSince, + fmap formatRFC1123 . cpSourceIfModifiedSince] + rangeHdr = ("x-amz-copy-source-range",) + . HT.renderByteRanges + . (:[]) + . uncurry HT.ByteRangeFromTo + <$> (map (both fromIntegral) $ + maybeToList $ cpSourceRange cps) + +-- | Extract the source bucket and source object name. TODO: validate +-- the bucket and object name extracted. +cpsToObject :: CopyPartSource -> Maybe (Bucket, Object) +cpsToObject cps = do + [_, bucket, object] <- Just splits + return (bucket, object) + where + splits = T.splitOn "/" $ cpSource cps + -- | Represents different kinds of payload that are used with S3 API -- requests. data Payload = PayloadBS ByteString @@ -159,10 +292,11 @@ , riPayload :: Payload , riPayloadHash :: ByteString , riRegion :: Maybe Region + , riNeedsLocation :: Bool } instance Default RequestInfo where - def = RequestInfo HT.methodGet def def def def def "" def + def = RequestInfo HT.methodGet def def def def def "" def True getPathFromRI :: RequestInfo -> ByteString getPathFromRI ri = B.concat $ parts @@ -170,11 +304,10 @@ objPart = maybe [] (\o -> ["/", encodeUtf8 o]) $ riObject ri parts = maybe ["/"] (\b -> "/" : encodeUtf8 b : objPart) $ riBucket ri -getRegionFromRI :: RequestInfo -> Text -getRegionFromRI ri = maybe "us-east-1" identity (riRegion ri) +type RegionMap = Map.Map Bucket Region newtype Minio a = Minio { - unMinio :: ReaderT MinioConn (ResourceT IO) a + unMinio :: ReaderT MinioConn (StateT RegionMap (ResourceT IO)) a } deriving ( Functor @@ -182,6 +315,7 @@ , Monad , MonadIO , MonadReader MinioConn + , MonadState RegionMap , MonadThrow , MonadCatch , MonadBase IO @@ -189,7 +323,7 @@ ) instance MonadBaseControl IO Minio where - type StM Minio a = a + type StM Minio a = (a, RegionMap) liftBaseWith f = Minio $ liftBaseWith $ \q -> f (q . unMinio) restoreM = Minio . restoreM @@ -212,39 +346,22 @@ runMinio :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a) runMinio ci m = do conn <- liftIO $ connect ci - flip runReaderT conn . unMinio $ + flip evalStateT Map.empty . flip runReaderT conn . unMinio $ (m >>= (return . Right)) `MC.catches` - [MC.Handler handlerME, MC.Handler handlerHE, MC.Handler handlerFE] + [ MC.Handler handlerServiceErr + , MC.Handler handlerHE + , MC.Handler handlerFE + , MC.Handler handlerValidation + ] where - handlerME = return . Left . ME - handlerHE = return . Left . MEHttp - handlerFE = return . Left . MEFile + handlerServiceErr = return . Left . MErrService + handlerHE = return . Left . MErrHTTP + handlerFE = return . Left . MErrIO + handlerValidation = return . Left . MErrValidation s3Name :: Text -> Name s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing ---------------------------------- --- Errors ---------------------------------- --- | Various validation errors -data MErrV = MErrVSinglePUTSizeExceeded Int64 - | MErrVPutSizeExceeded Int64 - | MErrVETagHeaderNotFound - | MErrVInvalidObjectInfoResponse - deriving (Show, Eq) - --- | Errors thrown by the library -data MinioErr = ME MError - | MEHttp HttpException - | MEFile IOException - deriving (Show) - -instance Exception MinioErr - --- | Library internal errors -data MError = XMLParseError Text - | ResponseError (NC.Response LByteString) - | ValidationError MErrV - deriving (Show, Eq) - -instance Exception MError +-- | Format as per RFC 1123. +formatRFC1123 :: UTCTime -> T.Text +formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" diff --git a/src/Network/Minio/Data/ByteString.hs b/src/Network/Minio/Data/ByteString.hs --- a/src/Network/Minio/Data/ByteString.hs +++ b/src/Network/Minio/Data/ByteString.hs @@ -1,3 +1,19 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + {-# LANGUAGE FlexibleInstances #-} module Network.Minio.Data.ByteString ( diff --git a/src/Network/Minio/Data/Crypto.hs b/src/Network/Minio/Data/Crypto.hs --- a/src/Network/Minio/Data/Crypto.hs +++ b/src/Network/Minio/Data/Crypto.hs @@ -1,3 +1,19 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio.Data.Crypto ( hashSHA256 diff --git a/src/Network/Minio/Data/Time.hs b/src/Network/Minio/Data/Time.hs --- a/src/Network/Minio/Data/Time.hs +++ b/src/Network/Minio/Data/Time.hs @@ -1,3 +1,19 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio.Data.Time ( awsTimeFormat diff --git a/src/Network/Minio/Errors.hs b/src/Network/Minio/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Network/Minio/Errors.hs @@ -0,0 +1,79 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +module Network.Minio.Errors where + +import Control.Exception +import qualified Network.HTTP.Conduit as NC + +import Lib.Prelude + + +--------------------------------- +-- Errors +--------------------------------- +-- | Various validation errors +data MErrV = MErrVSinglePUTSizeExceeded Int64 + | MErrVPutSizeExceeded Int64 + | MErrVETagHeaderNotFound + | MErrVInvalidObjectInfoResponse + | MErrVInvalidSrcObjSpec Text + | MErrVInvalidSrcObjByteRange (Int64, Int64) + | MErrVCopyObjSingleNoRangeAccepted + | MErrVRegionNotSupported Text + | MErrXmlParse Text + deriving (Show, Eq) + +instance Exception MErrV + +-- | Errors returned by S3 compatible service +data ServiceErr = BucketAlreadyExists + | BucketAlreadyOwnedByYou + | NoSuchBucket + | InvalidBucketName + | NoSuchKey + | ServiceErr Text Text + deriving (Show, Eq) + +instance Exception ServiceErr + +toServiceErr :: Text -> Text -> ServiceErr +toServiceErr "NoSuchKey" _ = NoSuchKey +toServiceErr "NoSuchBucket" _ = NoSuchBucket +toServiceErr "InvalidBucketName" _ = InvalidBucketName +toServiceErr "BucketAlreadyOwnedByYou" _ = BucketAlreadyOwnedByYou +toServiceErr "BucketAlreadyExists" _ = BucketAlreadyExists +toServiceErr code message = ServiceErr code message + + +-- | Errors thrown by the library +data MinioErr = MErrHTTP NC.HttpException + | MErrIO IOException + | MErrService ServiceErr + | MErrValidation MErrV + deriving (Show) + +instance Eq MinioErr where + MErrHTTP _ == MErrHTTP _ = True + MErrHTTP _ == _ = False + MErrIO _ == MErrIO _ = True + MErrIO _ == _ = False + MErrService a == MErrService b = a == b + MErrService _ == _ = False + MErrValidation a == MErrValidation b = a == b + MErrValidation _ == _ = False + +instance Exception MinioErr diff --git a/src/Network/Minio/ListOps.hs b/src/Network/Minio/ListOps.hs --- a/src/Network/Minio/ListOps.hs +++ b/src/Network/Minio/ListOps.hs @@ -1,6 +1,23 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio.ListOps where import qualified Data.Conduit as C +import qualified Data.Conduit.Combinators as CC import qualified Data.Conduit.List as CL import Lib.Prelude @@ -37,17 +54,28 @@ res <- lift $ listIncompleteUploads' bucket prefix delimiter nextKeyMarker nextUploadIdMarker - CL.sourceList $ lurUploads res + + aggrSizes <- lift $ forM (lurUploads res) $ \((uKey, uId, _)) -> do + partInfos <- listIncompleteParts bucket uKey uId C.$$ CC.sinkList + return $ foldl (\sizeSofar p -> opiSize p + sizeSofar) 0 + $ partInfos + + CL.sourceList $ + map (\((uKey, uId, uInitTime), size) -> + UploadInfo uKey uId uInitTime size + ) $ zip (lurUploads res) aggrSizes + when (lurHasMore res) $ - loop nextKeyMarker nextUploadIdMarker + loop (lurNextKey res) (lurNextUpload res) + -- | List object parts of an ongoing multipart upload for given -- bucket, object and uploadId. listIncompleteParts :: Bucket -> Object -> UploadId - -> C.Producer Minio ListPartInfo + -> C.Producer Minio ObjectPartInfo listIncompleteParts bucket object uploadId = loop Nothing where - loop :: Maybe Text -> C.Producer Minio ListPartInfo + loop :: Maybe Text -> C.Producer Minio ObjectPartInfo loop nextPartMarker = do res <- lift $ listIncompleteParts' bucket object uploadId Nothing nextPartMarker diff --git a/src/Network/Minio/PutObject.hs b/src/Network/Minio/PutObject.hs --- a/src/Network/Minio/PutObject.hs +++ b/src/Network/Minio/PutObject.hs @@ -1,8 +1,27 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio.PutObject ( - putObject + putObjectInternal , ObjectData(..) , selectPartSizes + , copyObjectInternal + , selectCopyRanges + , minPartSize ) where @@ -19,6 +38,7 @@ import Network.Minio.Data import Network.Minio.Data.Crypto +import Network.Minio.Errors import Network.Minio.ListOps import Network.Minio.S3API import Network.Minio.Utils @@ -28,6 +48,10 @@ maxObjectSize :: Int64 maxObjectSize = 5 * 1024 * 1024 * oneMiB +-- | minimum size of parts used in multipart operations. +minPartSize :: Int64 +minPartSize = 64 * oneMiB + oneMiB :: Int64 oneMiB = 1024 * 1024 @@ -44,14 +68,15 @@ -- For streams also, a size may be provided. This is useful to limit -- the input - if it is not provided, upload will continue until the -- stream ends or the object reaches `maxObjectsize` size. -data ObjectData m = ODFile FilePath (Maybe Int64) -- ^ Takes filepath and optional size. - | ODStream (C.Producer m ByteString) (Maybe Int64) -- ^ Pass size in bytes as maybe if known. +data ObjectData m = + ODFile FilePath (Maybe Int64) -- ^ Takes filepath and optional size. + | ODStream (C.Producer m ByteString) (Maybe Int64) -- ^ Pass size in bytes as maybe if known. -- | Put an object from ObjectData. This high-level API handles -- objects of all sizes, and even if the object size is unknown. -putObject :: Bucket -> Object -> ObjectData Minio -> Minio ETag -putObject b o (ODStream src sizeMay) = sequentialMultipartUpload b o sizeMay src -putObject b o (ODFile fp sizeMay) = do +putObjectInternal :: Bucket -> Object -> ObjectData Minio -> Minio ETag +putObjectInternal b o (ODStream src sizeMay) = sequentialMultipartUpload b o sizeMay src +putObjectInternal b o (ODFile fp sizeMay) = do hResE <- withNewHandle fp $ \h -> liftM2 (,) (isHandleSeekable h) (getFileSize h) @@ -70,30 +95,32 @@ Just size -> if | size <= 64 * oneMiB -> either throwM return =<< withNewHandle fp (\h -> putObjectSingle b o [] h 0 size) - | size > maxObjectSize -> throwM $ ValidationError $ - MErrVPutSizeExceeded size + | size > maxObjectSize -> throwM $ MErrVPutSizeExceeded size | isSeekable -> parallelMultipartUpload b o fp size | otherwise -> sequentialMultipartUpload b o (Just size) $ CB.sourceFile fp -- | Select part sizes - the logic is that the minimum part-size will --- be 64MiB. TODO: write quickcheck tests. +-- be 64MiB. selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)] -selectPartSizes size = List.zip3 [1..] partOffsets partSizes +selectPartSizes size = uncurry (List.zip3 [1..]) $ + List.unzip $ loop 0 size where ceil :: Double -> Int64 ceil = ceiling - partSize = max (64 * oneMiB) (ceil $ fromIntegral size / - fromIntegral maxMultipartParts) - (numParts, lastPartSize) = size `divMod` partSize - lastPart = filter (> 0) [lastPartSize] - partSizes = replicate (fromIntegral numParts) partSize ++ lastPart - partOffsets = List.scanl' (+) 0 partSizes + partSize = max minPartSize (ceil $ fromIntegral size / + fromIntegral maxMultipartParts) + m = fromIntegral partSize + loop st sz + | st > sz = [] + | st + m >= sz = [(st, sz - st)] + | otherwise = (st, m) : loop (st + m) sz + -- returns partinfo if part is already uploaded. checkUploadNeeded :: Payload -> PartNumber - -> Map.Map PartNumber ListPartInfo - -> Minio (Maybe PartInfo) + -> Map.Map PartNumber ObjectPartInfo + -> Minio (Maybe PartTuple) checkUploadNeeded payload n pmap = do (md5hash, pSize) <- case payload of PayloadBS bs -> return (hashMD5 bs, fromIntegral $ B.length bs) @@ -102,8 +129,8 @@ (Just $ fromIntegral size) case Map.lookup n pmap of Nothing -> return Nothing - Just (ListPartInfo _ etag size _) -> return $ - bool Nothing (Just (PartInfo n etag)) $ + Just (ObjectPartInfo _ etag size _) -> return $ + bool Nothing (Just (n, etag)) $ md5hash == encodeUtf8 etag && size == pSize parallelMultipartUpload :: Bucket -> Object -> FilePath -> Int64 @@ -171,10 +198,76 @@ -- | Looks for incomplete uploads for an object. Returns the first one -- if there are many. getExistingUpload :: Bucket -> Object - -> Minio (Maybe UploadId, Map.Map PartNumber ListPartInfo) + -> Minio (Maybe UploadId, Map.Map PartNumber ObjectPartInfo) getExistingUpload b o = do uidMay <- (fmap . fmap) uiUploadId $ listIncompleteUploads b (Just o) False C.$$ CC.head parts <- maybe (return []) (\uid -> listIncompleteParts b o uid C.$$ CC.sinkList) uidMay - return (uidMay, Map.fromList $ map (\p -> (piNumber p, p)) parts) + return (uidMay, Map.fromList $ map (\p -> (opiNumber p, p)) parts) + +-- | Copy an object using single or multipart copy strategy. +copyObjectInternal :: Bucket -> Object -> CopyPartSource + -> Minio ETag +copyObjectInternal b' o cps = do + -- validate and extract the src bucket and object + (srcBucket, srcObject) <- maybe + (throwM $ MErrVInvalidSrcObjSpec $ cpSource cps) + return $ cpsToObject cps + + -- get source object size with a head request + (ObjectInfo _ _ _ srcSize) <- headObject srcBucket srcObject + + -- check that byte offsets are valid if specified in cps + when (isJust (cpSourceRange cps) && + or [fst range < 0, snd range < fst range, + snd range >= fromIntegral srcSize]) $ + throwM $ MErrVInvalidSrcObjByteRange range + + -- 1. If sz > 64MiB (minPartSize) use multipart copy, OR + -- 2. If startOffset /= 0 use multipart copy + let destSize = (\(a, b) -> b - a + 1 ) $ + maybe (0, srcSize - 1) identity $ cpSourceRange cps + startOffset = maybe 0 fst $ cpSourceRange cps + endOffset = maybe (srcSize - 1) snd $ cpSourceRange cps + + if destSize > minPartSize || (endOffset - startOffset + 1 /= srcSize) + then multiPartCopyObject b' o cps srcSize + + else fst <$> copyObjectSingle b' o cps{cpSourceRange = Nothing} [] + + where + range = maybe (0, 0) identity $ cpSourceRange cps + +-- | Given the input byte range of the source object, compute the +-- splits for a multipart copy object procedure. Minimum part size +-- used is minPartSize. +selectCopyRanges :: (Int64, Int64) -> [(PartNumber, (Int64, Int64))] +selectCopyRanges (st, end) = zip pns $ + map (\(x, y) -> (st + x, st + x + y - 1)) $ zip startOffsets partSizes + where + size = end - st + 1 + (pns, startOffsets, partSizes) = List.unzip3 $ selectPartSizes size + +-- | Perform a multipart copy object action. Since we cannot verify +-- existing parts based on the source object, there is no resuming +-- copy action support. +multiPartCopyObject :: Bucket -> Object -> CopyPartSource -> Int64 + -> Minio ETag +multiPartCopyObject b o cps srcSize = do + uid <- newMultipartUpload b o [] + + let byteRange = maybe (0, fromIntegral $ srcSize - 1) identity $ + cpSourceRange cps + partRanges = selectCopyRanges byteRange + partSources = map (\(x, y) -> (x, cps {cpSourceRange = Just y})) + partRanges + + copiedParts <- limitedMapConcurrently 10 + (\(pn, cps') -> do + (etag, _) <- copyObjectPart b o cps' uid pn [] + return $ (pn, etag) + ) + partSources + + completeMultipartUpload b o uid copiedParts diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -1,3 +1,19 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio.S3API ( Region @@ -22,20 +38,23 @@ , putBucket , ETag , putObjectSingle + , copyObjectSingle -- * Multipart Upload APIs -------------------------- , UploadId - , PartInfo + , PartTuple , Payload(..) , PartNumber + , CopyPartSource(..) , newMultipartUpload , putObjectPart + , copyObjectPart , completeMultipartUpload , abortMultipartUpload , ListUploadsResult , listIncompleteUploads' - , ListPartsResult + , ListPartsResult(..) , listIncompleteParts' -- * Deletion APIs @@ -52,27 +71,22 @@ import Lib.Prelude -import Network.Minio.Data import Network.Minio.API +import Network.Minio.Data +import Network.Minio.Errors import Network.Minio.Utils -import Network.Minio.XmlParser import Network.Minio.XmlGenerator +import Network.Minio.XmlParser -- | Fetch all buckets from the service. getService :: Minio [BucketInfo] getService = do - resp <- executeRequest $ def + resp <- executeRequest $ def { + riNeedsLocation = False + } parseListBuckets $ NC.responseBody resp --- | Fetch bucket location (region) -getLocation :: Bucket -> Minio Region -getLocation bucket = do - resp <- executeRequest $ def { riBucket = Just bucket - , riQueryParams = [("location", Nothing)] - } - parseLocation $ NC.responseBody resp - -- | GET an object from the service and return the response headers -- and a conduit source for the object content getObject' :: Bucket -> Object -> HT.Query -> [HT.Header] @@ -94,6 +108,7 @@ def { riMethod = HT.methodPut , riBucket = Just bucket , riPayload = PayloadBS $ mkCreateBucketConfig location + , riNeedsLocation = False } -- | Single PUT object size. @@ -107,7 +122,7 @@ putObjectSingle bucket object headers h offset size = do -- check length is within single PUT object size. when (size > maxSinglePutObjectSizeBytes) $ - throwM $ ValidationError $ MErrVSinglePUTSizeExceeded size + throwM $ MErrVSinglePUTSizeExceeded size -- content-length header is automatically set by library. resp <- executeRequest $ @@ -121,7 +136,7 @@ let rheaders = NC.responseHeaders resp etag = getETagHeader rheaders maybe - (throwM $ ValidationError MErrVETagHeaderNotFound) + (throwM MErrVETagHeaderNotFound) return etag -- | List objects in a bucket matching prefix up to delimiter, @@ -172,7 +187,7 @@ -- | PUT a part of an object as part of a multipart upload. putObjectPart :: Bucket -> Object -> UploadId -> PartNumber -> [HT.Header] - -> Payload -> Minio PartInfo + -> Payload -> Minio PartTuple putObjectPart bucket object uploadId partNumber headers payload = do resp <- executeRequest $ def { riMethod = HT.methodPut @@ -185,25 +200,62 @@ let rheaders = NC.responseHeaders resp etag = getETagHeader rheaders maybe - (throwM $ ValidationError MErrVETagHeaderNotFound) - (return . PartInfo partNumber) etag + (throwM MErrVETagHeaderNotFound) + (return . (partNumber, )) etag where params = [ ("uploadId", Just uploadId) , ("partNumber", Just $ show partNumber) ] +-- | Performs server-side copy of an object or part of an object as an +-- upload part of an ongoing multi-part upload. +copyObjectPart :: Bucket -> Object -> CopyPartSource -> UploadId + -> PartNumber -> [HT.Header] -> Minio (ETag, UTCTime) +copyObjectPart bucket object cps uploadId partNumber headers = do + resp <- executeRequest $ + def { riMethod = HT.methodPut + , riBucket = Just bucket + , riObject = Just object + , riQueryParams = mkOptionalParams params + , riHeaders = headers ++ cpsToHeaders cps + } + + parseCopyObjectResponse $ NC.responseBody resp + where + params = [ + ("uploadId", Just uploadId) + , ("partNumber", Just $ show partNumber) + ] + +-- | Performs server-side copy of an object that is upto 5GiB in +-- size. If the object is greater than 5GiB, this function throws the +-- error returned by the server. +copyObjectSingle :: Bucket -> Object -> CopyPartSource -> [HT.Header] + -> Minio (ETag, UTCTime) +copyObjectSingle bucket object cps headers = do + -- validate that cpSourceRange is Nothing for this API. + when (isJust $ cpSourceRange cps) $ + throwM MErrVCopyObjSingleNoRangeAccepted + resp <- executeRequest $ + def { riMethod = HT.methodPut + , riBucket = Just bucket + , riObject = Just object + , riHeaders = headers ++ cpsToHeaders cps + } + parseCopyObjectResponse $ NC.responseBody resp + -- | Complete a multipart upload. -completeMultipartUpload :: Bucket -> Object -> UploadId -> [PartInfo] +completeMultipartUpload :: Bucket -> Object -> UploadId -> [PartTuple] -> Minio ETag -completeMultipartUpload bucket object uploadId partInfo = do +completeMultipartUpload bucket object uploadId partTuple = do resp <- executeRequest $ def { riMethod = HT.methodPost , riBucket = Just bucket , riObject = Just object , riQueryParams = mkOptionalParams params , riPayload = PayloadBS $ - mkCompleteMultipartUploadRequest partInfo + mkCompleteMultipartUploadRequest partTuple } parseCompleteMultipartUploadResponse $ NC.responseBody resp where @@ -226,22 +278,22 @@ listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker = do resp <- executeRequest $ def { riMethod = HT.methodGet , riBucket = Just bucket - , riQueryParams = ("uploads", Nothing): mkOptionalParams params + , riQueryParams = params } parseListUploadsResponse $ NC.responseBody resp where - -- build optional query params - params = [ - ("prefix", prefix) - , ("delimiter", delimiter) - , ("key-marker", keyMarker) - , ("upload-id-marker", uploadIdMarker) - ] + -- build query params + params = ("uploads", Nothing) : mkOptionalParams + [ ("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 + -> Maybe Text -> Minio ListPartsResult listIncompleteParts' bucket object uploadId maxParts partNumMarker = do resp <- executeRequest $ def { riMethod = HT.methodGet , riBucket = Just bucket @@ -271,5 +323,5 @@ etag = getETagHeader headers size = getContentLength headers - maybe (throwM $ ValidationError MErrVInvalidObjectInfoResponse) return $ + maybe (throwM MErrVInvalidObjectInfoResponse) return $ ObjectInfo <$> Just object <*> modTime <*> etag <*> size diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -1,3 +1,19 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio.Sign.V4 ( signV4 @@ -82,14 +98,17 @@ outHeaders = authHeader : headersWithDate timeBS = awsTimeFormatBS ts dateHeader = (mk "X-Amz-Date", timeBS) - hostHeader = (mk "host", encodeUtf8 $ connectHost ci) + hostHeader = (mk "host", encodeUtf8 $ format "{}:{}" $ + [connectHost ci, show $ connectPort ci]) headersWithDate = dateHeader : hostHeader : (riHeaders ri) authHeader = (mk "Authorization", authHeaderValue) - scope = getScope ts ri + region = maybe (connectRegion ci) identity $ riRegion ri + scope = getScope ts region + authHeaderValue = B.concat [ "AWS4-HMAC-SHA256 Credential=", encodeUtf8 (connectAccessKey ci), "/", scope, @@ -105,7 +124,7 @@ signingKey = hmacSHA256RawBS "aws4_request" . hmacSHA256RawBS "s3" - . hmacSHA256RawBS (encodeUtf8 $ getRegionFromRI ri) + . hmacSHA256RawBS (encodeUtf8 region) . hmacSHA256RawBS (awsDateFormatBS ts) $ (B.concat ["AWS4", encodeUtf8 $ connectSecretKey ci]) @@ -119,10 +138,10 @@ canonicalRequest = getCanonicalRequest ri headersToSign -getScope :: UTCTime -> RequestInfo -> ByteString -getScope ts ri = B.intercalate "/" $ [ +getScope :: UTCTime -> Region -> ByteString +getScope ts region = B.intercalate "/" $ [ pack $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts, - encodeUtf8 $ getRegionFromRI ri, "s3", "aws4_request" + encodeUtf8 region, "s3", "aws4_request" ] getHeadersToSign :: [Header] -> [(ByteString, ByteString)] diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -1,3 +1,19 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio.Utils where import qualified Control.Concurrent.Async.Lifted as A @@ -9,6 +25,8 @@ import qualified Data.ByteString as B import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import Data.Default (Default(..)) import qualified Data.Text as T import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Read (decimal) @@ -22,17 +40,14 @@ import Lib.Prelude -import Network.Minio.Data - --- | Represent the time format string returned by S3 API calls. -s3TimeFormat :: [Char] -s3TimeFormat = iso8601DateFormat $ Just "%T%QZ" +import Network.Minio.Errors +import Network.Minio.XmlParser (parseErrResponse) -allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m) +allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m, MonadCatch m) => FilePath -> m (R.ReleaseKey, Handle) allocateReadFile fp = do (rk, hdlE) <- R.allocate (openReadFile fp) cleanup - either (throwM . MEFile) (return . (rk,)) hdlE + either (\(e :: IOException) -> throwM e) (return . (rk,)) hdlE where openReadFile f = ExL.try $ IO.openBinaryFile f IO.ReadMode cleanup = either (const $ return ()) IO.hClose @@ -62,7 +77,7 @@ -- returned - both during file handle allocation and when the action -- is run. withNewHandle :: (R.MonadResourceBase m, R.MonadResource m, MonadCatch m) - => FilePath -> (Handle -> m a) -> m (Either MError a) + => FilePath -> (Handle -> m a) -> m (Either IOException a) withNewHandle fp fileAction = do -- opening a handle can throw MError exception. handleE <- MC.try $ allocateReadFile fp @@ -107,12 +122,19 @@ respE <- liftIO $ tryHttpEx $ (NClient.httpLbs req mgr) resp <- either throwM return respE unless (isSuccessStatus $ NC.responseStatus resp) $ - throwM $ ResponseError resp + case contentTypeMay resp of + Just "application/xml" -> do + sErr <- parseErrResponse $ NC.responseBody resp + throwM sErr + + _ -> throwM $ NC.StatusCodeException (NC.responseStatus resp) [] def + return resp where tryHttpEx :: (IO (NC.Response LByteString)) -> IO (Either NC.HttpException (NC.Response LByteString)) tryHttpEx = try + contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp http :: (R.MonadResourceBase m, R.MonadResource m) => NC.Request -> NC.Manager @@ -120,14 +142,21 @@ http req mgr = do respE <- tryHttpEx $ NC.http req mgr resp <- either throwM return respE - unless (isSuccessStatus $ NC.responseStatus resp) $ do - lbsResp <- NC.lbsResponse resp - throwM $ ResponseError lbsResp + unless (isSuccessStatus $ NC.responseStatus resp) $ + case contentTypeMay resp of + Just "application/xml" -> do + respBody <- NC.responseBody resp C.$$+- CB.sinkLbs + sErr <- parseErrResponse $ respBody + throwM sErr + + _ -> throwM $ NC.StatusCodeException (NC.responseStatus resp) [] def + return resp where tryHttpEx :: (R.MonadResourceBase m) => (m a) - -> m (Either NC.HttpException a) + -> m (Either MinioErr a) tryHttpEx = ExL.try + contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp -- like mapConcurrently but with a limited number of concurrent -- threads. diff --git a/src/Network/Minio/XmlGenerator.hs b/src/Network/Minio/XmlGenerator.hs --- a/src/Network/Minio/XmlGenerator.hs +++ b/src/Network/Minio/XmlGenerator.hs @@ -1,3 +1,19 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio.XmlGenerator ( mkCreateBucketConfig , mkCompleteMultipartUploadRequest @@ -26,13 +42,13 @@ bucketConfig = Document (Prologue [] Nothing []) root [] -- | Create a completeMultipartUpload request body XML -mkCompleteMultipartUploadRequest :: [PartInfo] -> ByteString +mkCompleteMultipartUploadRequest :: [PartTuple] -> 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 + mkPart (n, etag) = Element "Part" M.empty [ NodeElement $ Element "PartNumber" M.empty [NodeContent $ T.pack $ show n] , NodeElement $ Element "ETag" M.empty diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -1,11 +1,29 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio.XmlParser ( parseListBuckets , parseLocation , parseNewMultipartUpload , parseCompleteMultipartUploadResponse + , parseCopyObjectResponse , parseListObjectsResponse , parseListUploadsResponse , parseListPartsResponse + , parseErrResponse ) where import Control.Monad.Trans.Resource @@ -14,29 +32,30 @@ import Data.Text.Read (decimal) import Data.Time import Text.XML -import Text.XML.Cursor +import Text.XML.Cursor hiding (bool) import Lib.Prelude import Network.Minio.Data -import Network.Minio.Utils (s3TimeFormat) +import Network.Minio.Errors --- | Helper functions. -uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d -uncurry3 f (a, b, c) = f a b c +-- | Represent the time format string returned by S3 API calls. +s3TimeFormat :: [Char] +s3TimeFormat = iso8601DateFormat $ Just "%T%QZ" +-- | Helper functions. uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e uncurry4 f (a, b, c, d) = f a b c d -- | Parse time strings from XML parseS3XMLTime :: (MonadThrow m) => Text -> m UTCTime -parseS3XMLTime = either (throwM . XMLParseError) return +parseS3XMLTime = either (throwM . MErrXmlParse) return . parseTimeM True defaultTimeLocale s3TimeFormat . T.unpack parseDecimal :: (MonadThrow m, Integral a) => Text -> m a -parseDecimal numStr = either (throwM . XMLParseError . show) return $ fst <$> decimal numStr +parseDecimal numStr = either (throwM . MErrXmlParse . show) return $ fst <$> decimal numStr parseDecimals :: (MonadThrow m, Integral a) => [Text] -> m [a] parseDecimals numStr = forM numStr parseDecimal @@ -45,7 +64,7 @@ s3Elem = element . s3Name parseRoot :: (MonadThrow m) => LByteString -> m Cursor -parseRoot = either (throwM . XMLParseError . show) (return . fromDocument) +parseRoot = either (throwM . MErrXmlParse . show) (return . fromDocument) . parseLBS def -- | Parse the response XML of a list buckets call. @@ -63,7 +82,8 @@ parseLocation :: (MonadThrow m) => LByteString -> m Region parseLocation xmldata = do r <- parseRoot xmldata - return $ T.concat $ r $/ content + let region = T.concat $ r $/ content + return $ bool "us-east-1" region $ region /= "" -- | Parse the response XML of an newMultipartUpload call. parseNewMultipartUpload :: (MonadThrow m) @@ -79,6 +99,16 @@ r <- parseRoot xmldata return $ T.concat $ r $// s3Elem "ETag" &/ content +-- | Parse the response XML of copyObject and copyObjectPart +parseCopyObjectResponse :: (MonadThrow m) => LByteString -> m (ETag, UTCTime) +parseCopyObjectResponse xmldata = do + r <- parseRoot xmldata + let + mtimeStr = T.concat $ r $// s3Elem "LastModified" &/ content + + mtime <- parseS3XMLTime mtimeStr + return $ (T.concat $ r $// s3Elem "ETag" &/ content, mtime) + -- | Parse the response XML of a list objects call. parseListObjectsResponse :: (MonadThrow m) => LByteString -> m ListObjectsResult @@ -124,8 +154,7 @@ uploadInitTimes <- mapM parseS3XMLTime uploadInitTimeStr let - uploads = map (uncurry3 UploadInfo) $ - zip3 uploadKeys uploadIds uploadInitTimes + uploads = zip3 uploadKeys uploadIds uploadInitTimes return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes @@ -147,7 +176,16 @@ nextPartNum <- parseDecimals $ maybeToList nextPartNumStr let - partInfos = map (uncurry4 ListPartInfo) $ + partInfos = map (uncurry4 ObjectPartInfo) $ zip4 partNumbers partETags partSizes partModTimes return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos + + +parseErrResponse :: (MonadThrow m) + => LByteString -> m ServiceErr +parseErrResponse xmldata = do + r <- parseRoot xmldata + let code = T.concat $ r $/ element "Code" &/ content + message = T.concat $ r $/ element "Message" &/ content + return $ toServiceErr code message diff --git a/test/LiveServer.hs b/test/LiveServer.hs new file mode 100644 --- /dev/null +++ b/test/LiveServer.hs @@ -0,0 +1,443 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +import qualified Test.QuickCheck as Q +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC + +import Lib.Prelude + +import System.Directory (getTemporaryDirectory) +import qualified System.IO as SIO + +import qualified Control.Monad.Catch as MC +import qualified Control.Monad.Trans.Resource as R +import qualified Data.ByteString as BS +import Data.Conduit (($$), yield) +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import Data.Conduit.Combinators (sinkList) +import Data.Default (Default(..)) +import qualified Data.Text as T +import System.Environment (lookupEnv) + +import Network.Minio +import Network.Minio.Data +import Network.Minio.Errors +import Network.Minio.ListOps +import Network.Minio.PutObject +import Network.Minio.S3API +import Network.Minio.Utils + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [liveServerUnitTests] + +-- conduit that generates random binary stream of given length +randomDataSrc :: MonadIO m => Int64 -> C.Producer m ByteString +randomDataSrc s' = genBS s' + where + oneMiB = 1024*1024 + + concatIt bs n = BS.concat $ replicate (fromIntegral q) bs ++ + [BS.take (fromIntegral r) bs] + where (q, r) = n `divMod` fromIntegral (BS.length bs) + + genBS s = do + w8s <- liftIO $ generate $ Q.vectorOf 64 (Q.choose (0, 255)) + let byteArr64 = BS.pack w8s + if s < oneMiB + then yield $ concatIt byteArr64 s + else do yield $ concatIt byteArr64 oneMiB + genBS (s - oneMiB) + +mkRandFile :: R.MonadResource m => Int64 -> m FilePath +mkRandFile size = do + dir <- liftIO $ getTemporaryDirectory + randomDataSrc size C.$$ CB.sinkTempFile dir "miniohstest.random" + +funTestBucketPrefix :: Text +funTestBucketPrefix = "miniohstest-" + +funTestWithBucket :: TestName + -> (([Char] -> Minio ()) -> Bucket -> Minio ()) -> TestTree +funTestWithBucket t minioTest = testCaseSteps t $ \step -> do + -- generate a random name for the bucket + bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z')) + let b = T.concat [funTestBucketPrefix, T.pack bktSuffix] + liftStep = liftIO . step + connInfo <- maybe minioPlayCI (const def) <$> lookupEnv "MINIO_LOCAL" + ret <- runResourceT $ runMinio connInfo $ do + liftStep $ "Creating bucket for test - " ++ t + makeBucket b def + minioTest liftStep b + deleteBucket b + isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret) + +liveServerUnitTests :: TestTree +liveServerUnitTests = testGroup "Unit tests against a live server" + [ funTestWithBucket "Basic tests" $ \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.") + + step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised." + mbE <- MC.try $ makeBucket bucket Nothing + case mbE of + Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou + _ -> return () + + step "makeBucket with an invalid bucket name and check for appropriate exception." + invalidMBE <- MC.try $ makeBucket "invalidBucketName" Nothing + case invalidMBE of + Left exn -> liftIO $ exn @?= InvalidBucketName + _ -> return () + + step "getLocation works" + region <- getLocation bucket + liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region) + + step "singlepart putObject works" + fPutObject bucket "lsb-release" "/etc/lsb-release" + + step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception" + fpE <- MC.try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" + case fpE of + Left exn -> liftIO $ exn @?= NoSuchBucket + _ -> return () + + outFile <- mkRandFile 0 + step "simple fGetObject works" + fGetObject bucket "lsb-release" outFile + + step "fGetObject a non-existent object and check for NoSuchKey exception" + resE <- MC.try $ fGetObject bucket "noSuchKey" outFile + case resE of + Left exn -> liftIO $ exn @?= NoSuchKey + _ -> return () + + + step "create new multipart upload works" + uid <- newMultipartUpload bucket "newmpupload" [] + liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") + + step "abort a new multipart upload works" + abortMultipartUpload bucket "newmpupload" uid + + step "delete object works" + deleteObject bucket "lsb-release" + + step "statObject test" + let object = "sample" + step "create an object" + inputFile <- mkRandFile 0 + fPutObject bucket object inputFile + + step "get metadata of the object" + res <- statObject bucket object + liftIO $ (oiSize res) @?= 0 + + step "delete object" + deleteObject bucket object + + , funTestWithBucket "Multipart Tests" $ + \step bucket -> do + -- low-level multipart operation tests. + let object = "newmpupload" + mb15 = 15 * 1024 * 1024 + + step "Prepare for low-level multipart tests." + step "create new multipart upload" + uid <- newMultipartUpload bucket object [] + liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") + + randFile <- mkRandFile mb15 + + step "put object parts 1 of 1" + h <- liftIO $ SIO.openBinaryFile randFile SIO.ReadMode + partInfo <- putObjectPart bucket object uid 1 [] $ PayloadH h 0 mb15 + + step "complete multipart" + void $ completeMultipartUpload bucket object uid [partInfo] + + destFile <- mkRandFile 0 + step $ "Retrieve the created object and check size" + fGetObject bucket object destFile + gotSize <- withNewHandle destFile getFileSize + liftIO $ gotSize == Right (Just mb15) @? + "Wrong file size of put file after getting" + + step $ "Cleanup actions" + removeObject bucket object + + -- putObject test (conduit source, no size specified) + let obj = "mpart" + mb100 = 100 * 1024 * 1024 + + step "Prepare for putObject with from source without providing size." + rFile <- mkRandFile mb100 + + step "Upload multipart file." + putObject bucket obj (CB.sourceFile rFile) Nothing + + step "Retrieve and verify file size" + destFile <- mkRandFile 0 + fGetObject bucket obj destFile + gotSize <- withNewHandle destFile getFileSize + liftIO $ gotSize == Right (Just mb100) @? + "Wrong file size of put file after getting" + + step $ "Cleanup actions" + deleteObject bucket obj + + step "Prepare for putObjectInternal with non-seekable file, with size." + step "Upload multipart file." + void $ putObjectInternal bucket obj $ ODFile "/dev/zero" (Just mb100) + + step "Retrieve and verify file size" + destFile <- mkRandFile 0 + fGetObject bucket obj destFile + gotSize <- withNewHandle destFile getFileSize + liftIO $ gotSize == Right (Just mb100) @? + "Wrong file size of put file after getting" + + step $ "Cleanup actions" + removeObject bucket obj + + step "Prepare for putObjectInternal with large file as source." + step "upload large object" + void $ putObjectInternal bucket "big" (ODFile "/dev/zero" $ + Just $ 1024*1024*100) + + step "cleanup" + removeObject bucket "big" + + + , funTestWithBucket "Listing Test" $ \step bucket -> do + step "listObjects' test" + step "put 10 objects" + forM_ [1..10::Int] $ \s -> + fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release" + + step "Simple list" + res <- listObjects' bucket Nothing Nothing Nothing + let expected = sort $ map (T.concat . + ("lsb-release":) . + (\x -> [x]) . + T.pack . + show) [1..10::Int] + liftIO $ assertEqual "Objects match failed!" expected + (map oiObject $ lorObjects res) + + step "Cleanup actions" + forM_ [1..10::Int] $ \s -> deleteObject bucket (T.concat ["lsb-release", T.pack (show s)]) + + step "listIncompleteUploads' test" + 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 + + step "cleanup" + forM_ (lurUploads incompleteUploads) $ + \(_, uid, _) -> abortMultipartUpload bucket object uid + + step "Basic listIncompleteParts Test" + 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" + inputFile <- mkRandFile mb15 + h <- liftIO $ SIO.openBinaryFile 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 + abortMultipartUpload bucket object uid + + step "High-level listObjects Test" + step "put 3 objects" + let expected = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3"] + forM_ expected $ + \obj -> fPutObject bucket obj "/etc/lsb-release" + + step "High-level listing of objects" + objects <- (listObjects bucket Nothing True) $$ sinkList + + liftIO $ assertEqual "Objects match failed!" (sort expected) + (map oiObject objects) + + step "Cleanup actions" + forM_ expected $ + \obj -> removeObject bucket obj + + step "High-level listIncompleteUploads Test" + 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 "High-level listing of incomplete multipart uploads" + uploads <- (listIncompleteUploads bucket Nothing True) $$ sinkList + liftIO $ (length uploads) @?= 10 + + step "cleanup" + forM_ uploads $ \(UploadInfo _ uid _ _) -> + abortMultipartUpload bucket object uid + + step "High-level listIncompleteParts Test" + 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" + inputFile <- mkRandFile mb15 + h <- liftIO $ SIO.openBinaryFile inputFile SIO.ReadMode + forM_ [1..10] $ \pnum -> + putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb15 + + step "fetch list parts" + incompleteParts <- (listIncompleteParts bucket object uid) $$ sinkList + liftIO $ (length incompleteParts) @?= 10 + + step "cleanup" + abortMultipartUpload bucket object uid + + , funTestWithBucket "copyObject related tests" $ \step bucket -> do + step "copyObjectSingle basic tests" + let object = "xxx" + objCopy = "xxxCopy" + size1 = 100 :: Int64 + + step "create server object to copy" + inputFile <- mkRandFile size1 + fPutObject bucket object inputFile + + step "copy object" + let cps = def { cpSource = format "/{}/{}" [bucket, object] } + (etag, modTime) <- copyObjectSingle bucket objCopy cps [] + + -- retrieve obj info to check + ObjectInfo _ t e s <- headObject bucket objCopy + + let isMTimeDiffOk = abs (diffUTCTime modTime t) < 1.0 + + liftIO $ (s == size1 && e == etag && isMTimeDiffOk) @? + "Copied object did not match expected." + + step "cleanup actions" + removeObject bucket object + removeObject bucket objCopy + + step "copyObjectPart basic tests" + let srcObj = "XXX" + copyObj = "XXXCopy" + + step "Prepare" + let mb15 = 15 * 1024 * 1024 + mb5 = 5 * 1024 * 1024 + randFile <- mkRandFile mb15 + fPutObject bucket srcObj randFile + + step "create new multipart upload" + uid <- newMultipartUpload bucket copyObj [] + liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") + + step "put object parts 1-3" + let cps = def {cpSource = format "/{}/{}" [bucket, srcObj]} + parts <- forM [1..3] $ \p -> do + (etag, _) <- copyObjectPart bucket copyObj cps{ + cpSourceRange = Just ((p-1)*mb5, (p-1)*mb5 + (mb5 - 1)) + } uid (fromIntegral p) [] + return $ (fromIntegral p, etag) + + step "complete multipart" + void $ completeMultipartUpload bucket copyObj uid parts + + step "verify copied object size" + (ObjectInfo _ _ _ s) <- headObject bucket copyObj + + liftIO $ (s == mb15) @? "Size failed to match" + + step $ "Cleanup actions" + removeObject bucket srcObj + removeObject bucket copyObj + + step "copyObject basic tests" + let srcs = ["XXX", "XXXL"] + copyObjs = ["XXXCopy", "XXXLCopy"] + sizes = map (* (1024 * 1024)) [15, 65] + + step "Prepare" + forM_ (zip srcs sizes) $ \(src, size) -> + fPutObject bucket src =<< mkRandFile size + + step "make small and large object copy" + forM_ (zip copyObjs srcs) $ \(cp, src) -> + copyObject bucket cp def{cpSource = format "/{}/{}" [bucket, src]} + + step "verify uploaded objects" + uploadedSizes <- fmap (fmap oiSize) $ forM copyObjs (headObject bucket) + + liftIO $ (sizes == uploadedSizes) @? "Uploaded obj sizes failed to match" + + forM_ (concat [srcs, copyObjs]) (removeObject bucket) + + step "copyObject with offset test " + let src = "XXX" + copyObj = "XXXCopy" + size = 15 * 1024 * 1024 + + step "Prepare" + fPutObject bucket src =<< mkRandFile size + + step "copy last 10MiB of object" + copyObject bucket copyObj def{ + cpSource = format "/{}/{}" [bucket, src] + , cpSourceRange = Just (5 * 1024 * 1024, size - 1) + } + + step "verify uploaded object" + cSize <- oiSize <$> headObject bucket copyObj + + liftIO $ (cSize == 10 * 1024 * 1024) @? "Uploaded obj size mismatched!" + + forM_ [src, copyObj] (removeObject bucket) + ] diff --git a/test/Network/Minio/XmlGenerator/Test.hs b/test/Network/Minio/XmlGenerator/Test.hs --- a/test/Network/Minio/XmlGenerator/Test.hs +++ b/test/Network/Minio/XmlGenerator/Test.hs @@ -1,3 +1,19 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio.XmlGenerator.Test ( xmlGeneratorTests ) where @@ -8,7 +24,6 @@ import Lib.Prelude import Network.Minio.XmlGenerator -import Network.Minio.Data xmlGeneratorTests :: TestTree xmlGeneratorTests = testGroup "XML Generator Tests" @@ -29,7 +44,7 @@ testMkCompleteMultipartUploadRequest :: Assertion testMkCompleteMultipartUploadRequest = assertEqual "completeMultipartUpload xml should match: " expected $ - mkCompleteMultipartUploadRequest [PartInfo 1 "abc"] + mkCompleteMultipartUploadRequest [(1, "abc")] where expected = "\ \\ diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -1,16 +1,33 @@ +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + module Network.Minio.XmlParser.Test ( xmlParserTests ) where import qualified Control.Monad.Catch as MC -import Data.Time (fromGregorian, UTCTime(..)) +import Data.Time (fromGregorian) import Test.Tasty import Test.Tasty.HUnit import Lib.Prelude import Network.Minio.Data +import Network.Minio.Errors import Network.Minio.XmlParser xmlParserTests :: TestTree @@ -21,28 +38,29 @@ , testCase "Test parseListUploadsresponse" testParseListIncompleteUploads , testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse , testCase "Test parseListPartsResponse" testParseListPartsResponse + , testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse ] -tryMError :: (MC.MonadCatch m) => m a -> m (Either MError a) -tryMError act = MC.try act +tryValidationErr :: (MC.MonadCatch m) => m a -> m (Either MErrV a) +tryValidationErr act = MC.try act -assertMError :: MError -> Assertion -assertMError e = assertFailure $ "Failed due to exception => " ++ show e +assertValidtionErr :: MErrV -> Assertion +assertValidtionErr e = assertFailure $ "Failed due to validation error => " ++ show e -eitherMError :: Either MError a -> (a -> Assertion) -> Assertion -eitherMError (Left e) _ = assertMError e -eitherMError (Right a) f = f a +eitherValidationErr :: Either MErrV a -> (a -> Assertion) -> Assertion +eitherValidationErr (Left e) _ = assertValidtionErr e +eitherValidationErr (Right a) f = f a testParseLocation :: Assertion testParseLocation = do -- 1. Test parsing of an invalid location constraint xml. - parseResE <- tryMError $ parseLocation "ClearlyInvalidXml" + parseResE <- tryValidationErr $ parseLocation "ClearlyInvalidXml" when (isRight parseResE) $ assertFailure $ "Parsing should have failed => " ++ show parseResE forM_ cases $ \(xmldata, expectedLocation) -> do - parseLocE <- tryMError $ parseLocation xmldata - either assertMError (@?= expectedLocation) parseLocE + parseLocE <- tryValidationErr $ parseLocation xmldata + either assertValidtionErr (@?= expectedLocation) parseLocE where cases = [ -- 2. Test parsing of a valid location xml. @@ -53,7 +71,7 @@ , -- 3. Test parsing of a valid, empty location xml. ("", - "" + "us-east-1" ) ] @@ -61,8 +79,8 @@ testParseNewMultipartUpload :: Assertion testParseNewMultipartUpload = do forM_ cases $ \(xmldata, expectedUploadId) -> do - parsedUploadIdE <- tryMError $ parseNewMultipartUpload xmldata - eitherMError parsedUploadIdE (@?= expectedUploadId) + parsedUploadIdE <- tryValidationErr $ parseNewMultipartUpload xmldata + eitherValidationErr parsedUploadIdE (@?= expectedUploadId) where cases = [ ("\ @@ -106,8 +124,8 @@ object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 - parsedListObjectsResult <- tryMError $ parseListObjectsResponse xmldata - eitherMError parsedListObjectsResult (@?= expectedListResult) + parsedListObjectsResult <- tryValidationErr $ parseListObjectsResponse xmldata + eitherValidationErr parsedListObjectsResult (@?= expectedListResult) testParseListIncompleteUploads :: Assertion testParseListIncompleteUploads = do @@ -144,12 +162,12 @@ \\ \" expectedListResult = ListUploadsResult False (Just "sample.jpg") (Just "Xgw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1W99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--") uploads prefixes - uploads = [UploadInfo "sample.jpg" "Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--" initTime] + uploads = [("sample.jpg", "Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--", initTime)] initTime = UTCTime (fromGregorian 2010 11 26) 69857 prefixes = ["photos/", "videos/"] - parsedListUploadsResult <- tryMError $ parseListUploadsResponse xmldata - eitherMError parsedListUploadsResult (@?= expectedListResult) + parsedListUploadsResult <- tryValidationErr $ parseListUploadsResponse xmldata + eitherValidationErr parsedListUploadsResult (@?= expectedListResult) testParseCompleteMultipartUploadResponse :: Assertion @@ -165,7 +183,7 @@ expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\"" parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata - eitherMError parsedETagE (@?= expectedETag) + eitherValidationErr parsedETagE (@?= expectedETag) testParseListPartsResponse :: Assertion testParseListPartsResponse = do @@ -203,10 +221,32 @@ \" expectedListResult = ListPartsResult True (Just 3) [part1, part2] - part1 = ListPartInfo 2 "\"7778aef83f66abc1fa1e8477f296d394\"" 10485760 modifiedTime1 + part1 = ObjectPartInfo 2 "\"7778aef83f66abc1fa1e8477f296d394\"" 10485760 modifiedTime1 modifiedTime1 = flip UTCTime 74914 $ fromGregorian 2010 11 10 - part2 = ListPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2 + part2 = ObjectPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2 modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10 parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata - eitherMError parsedListPartsResult (@?= expectedListResult) + eitherValidationErr parsedListPartsResult (@?= expectedListResult) + +testParseCopyObjectResponse :: Assertion +testParseCopyObjectResponse = do + let + cases = [ ("\ +\\ + \2009-10-28T22:32:00.000Z\ + \\"9b2cf535f27731c974343645a3985328\"\ +\", + ("\"9b2cf535f27731c974343645a3985328\"", + UTCTime (fromGregorian 2009 10 28) 81120)) + , ("\ +\\ + \2009-10-28T22:32:00.000Z\ + \\"9b2cf535f27731c974343645a3985328\"\ +\", + ("\"9b2cf535f27731c974343645a3985328\"", + UTCTime (fromGregorian 2009 10 28) 81120))] + + forM_ cases $ \(xmldata, (etag, modTime)) -> do + parseResult <- runExceptT $ parseCopyObjectResponse xmldata + eitherValidationErr parseResult (@?= (etag, modTime)) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,28 +1,27 @@ -import qualified Test.QuickCheck as Q +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + import Test.Tasty -import Test.Tasty.HUnit import Test.Tasty.QuickCheck as QC -import Lib.Prelude - -import System.Directory (getTemporaryDirectory) -import qualified System.IO as SIO - -import qualified Control.Monad.Trans.Resource as R -import qualified Data.ByteString as BS -import Data.Conduit (($$), yield) -import qualified Data.Conduit as C -import qualified Data.Conduit.Binary as CB -import Data.Conduit.Combinators (sinkList) -import Data.Default (Default(..)) -import qualified Data.Text as T import qualified Data.List as L -import Network.Minio -import Network.Minio.Data +import Lib.Prelude + import Network.Minio.PutObject -import Network.Minio.S3API -import Network.Minio.Utils import Network.Minio.XmlGenerator.Test import Network.Minio.XmlParser.Test @@ -30,7 +29,7 @@ main = defaultMain tests tests :: TestTree -tests = testGroup "Tests" [properties, unitTests, liveServerUnitTests] +tests = testGroup "Tests" [properties, unitTests] properties :: TestTree properties = testGroup "Properties" [qcProps] -- [scProps] @@ -48,7 +47,7 @@ qcProps :: TestTree qcProps = testGroup "(checked by QuickCheck)" - [ QC.testProperty "selectPartSizes: simple properties" $ + [ QC.testProperty "selectPartSizes:" $ \n -> let (pns, offs, sizes) = L.unzip3 (selectPartSizes n) -- check that pns increments from 1. @@ -62,284 +61,52 @@ isOffsetsAsc = all (\(a, b) -> a < b) $ consPairs offs -- check sizes sums to n. - isSumSizeOk = n < 0 || (sum sizes == n && all (> 0) sizes) + isSumSizeOk = sum sizes == n -- check sizes are constant except last isSizesConstantExceptLast = - n <= 0 || all (\(a, b) -> a == b) (consPairs $ L.init sizes) - - in isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk && - isSizesConstantExceptLast - - , QC.testProperty "selectPartSizes: part-size is at least 64MiB" $ - \n -> let (_, _, sizes) = L.unzip3 (selectPartSizes n) - mib64 = 64 * 1024 * 1024 - in if | length sizes > 1 -> -- last part can be smaller but > 0 - all (>= mib64) (L.init sizes) && L.last sizes > 0 - | length sizes == 1 -> maybe True (> 0) $ head sizes - | otherwise -> True - ] - - --- conduit that generates random binary stream of given length -randomDataSrc :: MonadIO m => Int64 -> C.Producer m ByteString -randomDataSrc s' = genBS s' - where - oneMiB = 1024*1024 - - concatIt bs n = BS.concat $ replicate (fromIntegral q) bs ++ - [BS.take (fromIntegral r) bs] - where (q, r) = n `divMod` fromIntegral (BS.length bs) - - genBS s = do - w8s <- liftIO $ generate $ Q.vectorOf 64 (Q.choose (0, 255)) - let byteArr64 = BS.pack w8s - if s < oneMiB - then yield $ concatIt byteArr64 s - else do yield $ concatIt byteArr64 oneMiB - genBS (s - oneMiB) - -mkRandFile :: R.MonadResource m => Int64 -> m FilePath -mkRandFile size = do - dir <- liftIO $ getTemporaryDirectory - randomDataSrc size C.$$ CB.sinkTempFile dir "miniohstest.random" - -funTestBucketPrefix :: Text -funTestBucketPrefix = "miniohstest-" - -funTestWithBucket :: TestName - -> (([Char] -> Minio ()) -> Bucket -> Minio ()) -> TestTree -funTestWithBucket t minioTest = testCaseSteps t $ \step -> do - -- generate a random name for the bucket - bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z')) - let b = T.concat [funTestBucketPrefix, T.pack bktSuffix] - liftStep = liftIO . step - ret <- runResourceT $ runMinio def $ do - liftStep $ "Creating bucket for test - " ++ t - makeBucket b def - minioTest liftStep b - deleteBucket b - isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret) - -liveServerUnitTests :: TestTree -liveServerUnitTests = testGroup "Unit tests against a live server" - [ funTestWithBucket "Basic tests" $ \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.") - - step "getLocation works" - region <- getLocation bucket - liftIO $ region == "" @? ("Got unexpected region => " ++ show region) - - step "singlepart putObject works" - fPutObject bucket "lsb-release" "/etc/lsb-release" - - outFile <- mkRandFile 0 - step "simple getObject works" - fGetObject bucket "lsb-release" outFile - - step "create new multipart upload works" - uid <- newMultipartUpload bucket "newmpupload" [] - liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") - - step "abort a new multipart upload works" - abortMultipartUpload bucket "newmpupload" uid - - step "delete object works" - deleteObject bucket "lsb-release" - - , funTestWithBucket "Basic Multipart Test" $ \step bucket -> do - let object = "newmpupload" - - step "create new multipart upload" - uid <- newMultipartUpload bucket object [] - liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") - - let mb15 = 15 * 1024 * 1024 - randFile <- mkRandFile mb15 - - step "put object parts 1 of 1" - h <- liftIO $ SIO.openBinaryFile randFile SIO.ReadMode - partInfo <- putObjectPart bucket object uid 1 [] $ PayloadH h 0 mb15 - - step "complete multipart" - void $ completeMultipartUpload bucket object uid [partInfo] - - destFile <- mkRandFile 0 - step $ "Retrieve the created object and check size" - fGetObject bucket object destFile - gotSize <- withNewHandle destFile getFileSize - liftIO $ gotSize == Right (Just mb15) @? - "Wrong file size of put file after getting" - - step $ "Cleanup actions" - deleteObject bucket object - - , funTestWithBucket "Multipart test with unknown object size" $ - \step bucket -> do - let obj = "mpart" - - step "Prepare" - let mb100 = 100 * 1024 * 1024 - rFile <- mkRandFile mb100 - - step "Upload multipart file." - putObjectFromSource bucket obj (CB.sourceFile rFile) Nothing - - step "Retrieve and verify file size" - destFile <- mkRandFile 0 - fGetObject bucket obj destFile - gotSize <- withNewHandle destFile getFileSize - liftIO $ gotSize == Right (Just mb100) @? - "Wrong file size of put file after getting" - - step $ "Cleanup actions" - deleteObject bucket obj - - , funTestWithBucket "Multipart test with non-seekable file" $ - \step bucket -> do - let obj = "mpart" - mb100 = 100 * 1024 * 1024 - - step "Upload multipart file." - void $ putObject bucket obj $ ODFile "/dev/zero" (Just mb100) - - step "Retrieve and verify file size" - destFile <- mkRandFile 0 - fGetObject bucket obj destFile - gotSize <- withNewHandle destFile getFileSize - liftIO $ gotSize == Right (Just mb100) @? - "Wrong file size of put file after getting" - - step $ "Cleanup actions" - deleteObject bucket obj - - , funTestWithBucket "Basic listObjects Test" $ \step bucket -> do - step "put 10 objects" - forM_ [1..10::Int] $ \s -> - fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release" - - step "Simple list" - res <- listObjects' bucket Nothing Nothing Nothing - let expected = sort $ map (T.concat . - ("lsb-release":) . - (\x -> [x]) . - T.pack . - show) [1..10::Int] - liftIO $ assertEqual "Objects match failed!" expected - (map oiObject $ lorObjects res) - - step "Cleanup actions" - forM_ [1..10::Int] $ \s -> deleteObject bucket (T.concat ["lsb-release", T.pack (show s)]) - - , funTestWithBucket "Basic listMultipartUploads Test" $ \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 - - , funTestWithBucket "multipart" $ \step bucket -> do - - step "upload large object" - void $ putObject bucket "big" (ODFile "/dev/zero" $ Just $ 1024*1024*100) - - step "cleanup" - deleteObject bucket "big" - - , funTestWithBucket "Basic listIncompleteParts Test" $ \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" - inputFile <- mkRandFile mb15 - h <- liftIO $ SIO.openBinaryFile 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 - - , funTestWithBucket "High-level listObjects Test" $ \step bucket -> do - step "put 3 objects" - let expected = [ - "dir/o1" - , "dir/dir1/o2" - , "dir/dir2/o3" - ] - forM_ expected $ - \obj -> fPutObject bucket obj "/etc/lsb-release" - - step "High-level listing of objects" - objects <- (listObjects bucket Nothing True) $$ sinkList - - liftIO $ assertEqual "Objects match failed!" (sort expected) - (map oiObject objects) - - step "Cleanup actions" - forM_ expected $ - \obj -> deleteObject bucket obj - - , funTestWithBucket "High-level listIncompleteUploads Test" $ \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 "High-level listing of incomplete multipart uploads" - uploads <- (listIncompleteUploads bucket Nothing True) $$ sinkList - - liftIO $ (length uploads) @?= 10 - - , funTestWithBucket "High-level listIncompleteParts Test" $ \step bucket -> do - let - object = "newmpupload" - mb15 = 15 * 1024 * 1024 + all (\(a, b) -> a == b) (consPairs $ L.init sizes) - step "create a multipart upload" - uid <- newMultipartUpload bucket object [] - liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") + -- check each part except last is at least minPartSize; + -- last part may be 0 only if it is the only part. + nparts = length sizes + isMinPartSizeOk = + if | nparts > 1 -> -- last part can be smaller but > 0 + all (>= minPartSize) (take (nparts - 1) sizes) && + all (\s -> s > 0) (drop (nparts - 1) sizes) + | nparts == 1 -> -- size may be 0 here. + maybe True (\x -> x >= 0 && x <= minPartSize) $ + headMay sizes + | otherwise -> False - step "put object parts 1..10" - inputFile <- mkRandFile mb15 - h <- liftIO $ SIO.openBinaryFile inputFile SIO.ReadMode - forM_ [1..10] $ \pnum -> - putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb15 + in n < 0 || + (isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk && + isSizesConstantExceptLast && isMinPartSizeOk) - step "fetch list parts" - incompleteParts <- (listIncompleteParts bucket object uid) $$ sinkList - liftIO $ (length incompleteParts) @?= 10 + , QC.testProperty "selectCopyRanges:" $ + \(start, end) -> + let (_, pairs) = L.unzip (selectCopyRanges (start, end)) - , funTestWithBucket "High-level statObject Test" $ \step bucket -> do - let - object = "sample" - zeroByte = 0 + -- is last part's snd offset end? + isLastPartOk = maybe False ((end ==) . snd) $ lastMay pairs + -- is first part's fst offset start + isFirstPartOk = maybe False ((start ==) . fst) $ headMay pairs - step "create an object" - inputFile <- mkRandFile zeroByte - fPutObject bucket object inputFile + -- each pair is >=64MiB except last, and all those parts + -- have same size. + initSizes = maybe [] (map (\(a, b) -> b - a + 1)) $ initMay pairs + isPartSizesOk = all (>= minPartSize) initSizes && + maybe True (\k -> all (== k) initSizes) + (headMay initSizes) - step "get metadata of the object" - res <- statObject bucket object - liftIO $ (oiSize res) @?= 0 + -- returned offsets are contiguous. + fsts = drop 1 $ map fst pairs + snds = take (length pairs - 1) $ map snd pairs + isContParts = length fsts == length snds && + and (map (\(a, b) -> a == b + 1) $ zip fsts snds) - step "delete object" - deleteObject bucket object + in start < 0 || start > end || + (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts) ] unitTests :: TestTree