summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMinioDevTeam <>2019-07-10 17:18:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-07-10 17:18:00 (GMT)
commitfcb67ae814096b2b0e7c4aa0886ede0980d15a0f (patch)
treeaf0e02e4236f8288e2c49d7648d84433ac27c0d1
parent9ec1ce2cbea9735bc5dab646002ff69707330fd0 (diff)
version 1.4.0HEAD1.4.0master
-rw-r--r--CHANGELOG.md9
-rw-r--r--minio-hs.cabal20
-rw-r--r--src/Network/Minio.hs76
-rw-r--r--src/Network/Minio/API.hs151
-rw-r--r--src/Network/Minio/APICommon.hs26
-rw-r--r--src/Network/Minio/Data.hs67
-rw-r--r--src/Network/Minio/Errors.hs4
-rw-r--r--src/Network/Minio/ListOps.hs42
-rw-r--r--src/Network/Minio/PutObject.hs16
-rw-r--r--src/Network/Minio/S3API.hs33
-rw-r--r--src/Network/Minio/SelectAPI.hs7
-rw-r--r--src/Network/Minio/Sign/V4.hs213
-rw-r--r--src/Network/Minio/Utils.hs31
-rw-r--r--test/LiveServer.hs56
14 files changed, 515 insertions, 236 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 9e27931..45302b3 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,6 +1,15 @@
Changelog
==========
+## Version 1.4.0
+
+* Expose runMinioRes and runMinioResWith (#129)
+* Improve Haddocks (#127)
+* Fix list objects APIs to return directory prefixes when run with
+ recurse set to False (#126)
+* Use streaming signature for streaming payloads when on an insecure
+ connection (#123)
+
## Version 1.3.1
* Add TLS helpers to check if server uses TLS, and to disable
diff --git a/minio-hs.cabal b/minio-hs.cabal
index c805c5e..8a081f8 100644
--- a/minio-hs.cabal
+++ b/minio-hs.cabal
@@ -1,5 +1,5 @@
name: minio-hs
-version: 1.3.1
+version: 1.4.0
synopsis: A MinIO Haskell Library for Amazon S3 compatible cloud
storage.
description: The MinIO Haskell client library provides simple APIs to
@@ -116,15 +116,18 @@ test-suite minio-hs-live-server-test
, TypeFamilies
other-modules: Lib.Prelude
, Network.Minio
- , Network.Minio.AdminAPI
, Network.Minio.API
+ , Network.Minio.API.Test
, Network.Minio.APICommon
+ , Network.Minio.AdminAPI
, Network.Minio.CopyObject
, Network.Minio.Data
, Network.Minio.Data.ByteString
, Network.Minio.Data.Crypto
, Network.Minio.Data.Time
, Network.Minio.Errors
+ , Network.Minio.JsonParser
+ , Network.Minio.JsonParser.Test
, Network.Minio.ListOps
, Network.Minio.PresignedOperations
, Network.Minio.PutObject
@@ -134,13 +137,10 @@ test-suite minio-hs-live-server-test
, Network.Minio.TestHelpers
, Network.Minio.Utils
, Network.Minio.Utils.Test
- , Network.Minio.API.Test
, Network.Minio.XmlGenerator
, Network.Minio.XmlGenerator.Test
, Network.Minio.XmlParser
, Network.Minio.XmlParser.Test
- , Network.Minio.JsonParser
- , Network.Minio.JsonParser.Test
build-depends: base >= 4.7 && < 5
, minio-hs
, protolude >= 0.1.6
@@ -243,15 +243,18 @@ test-suite minio-hs-test
, TypeFamilies
other-modules: Lib.Prelude
, Network.Minio
- , Network.Minio.AdminAPI
, Network.Minio.API
+ , Network.Minio.API.Test
, Network.Minio.APICommon
+ , Network.Minio.AdminAPI
+ , Network.Minio.CopyObject
, Network.Minio.Data
, Network.Minio.Data.ByteString
, Network.Minio.Data.Crypto
, Network.Minio.Data.Time
- , Network.Minio.CopyObject
, Network.Minio.Errors
+ , Network.Minio.JsonParser
+ , Network.Minio.JsonParser.Test
, Network.Minio.ListOps
, Network.Minio.PresignedOperations
, Network.Minio.PutObject
@@ -261,13 +264,10 @@ test-suite minio-hs-test
, Network.Minio.TestHelpers
, Network.Minio.Utils
, Network.Minio.Utils.Test
- , Network.Minio.API.Test
, Network.Minio.XmlGenerator
, Network.Minio.XmlGenerator.Test
, Network.Minio.XmlParser
, Network.Minio.XmlParser.Test
- , Network.Minio.JsonParser
- , Network.Minio.JsonParser.Test
source-repository head
type: git
diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs
index 635fa84..77627fc 100644
--- a/src/Network/Minio.hs
+++ b/src/Network/Minio.hs
@@ -1,5 +1,5 @@
--
--- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -20,13 +20,17 @@
-- License: Apache 2.0
-- Maintainer: MinIO Dev Team <dev@min.io>
--
--- Types and functions to access S3 compatible object storage servers
--- like MinIO.
+-- Types and functions to conveniently access S3 compatible object
+-- storage servers like MinIO.
module Network.Minio
(
-- * Credentials
Credentials (..)
+
+ -- ** Credential providers
+ -- | Run actions that retrieve 'Credentials' from the environment or
+ -- files or other custom sources.
, Provider
, fromAWSConfigFile
, fromAWSEnv
@@ -34,7 +38,6 @@ module Network.Minio
, findFirst
-- * Connecting to object storage
- ---------------------------------
, ConnectInfo
, setRegion
, setCreds
@@ -45,26 +48,25 @@ module Network.Minio
, mkMinioConn
-- ** Connection helpers
- ------------------------
+ -- | These are helpers to construct 'ConnectInfo' values for common
+ -- cases.
, minioPlayCI
, awsCI
, gcsCI
-
-- * Minio Monad
----------------
-- | The Minio Monad provides connection-reuse, bucket-location
-- caching, resource management and simpler error handling
-- functionality. All actions on object storage are performed within
-- this Monad.
-
, Minio
, runMinioWith
, runMinio
-
+ , runMinioResWith
+ , runMinioRes
-- * Bucket Operations
- ----------------------
-- ** Creation, removal and querying
, Bucket
@@ -74,11 +76,15 @@ module Network.Minio
, Region
, getLocation
- -- ** Listing
+ -- ** Listing buckets
, BucketInfo(..)
, listBuckets
- -- ** Object info type represents object metadata information.
+ -- ** Listing objects
+ , listObjects
+ , listObjectsV1
+ , ListItem(..)
+
, ObjectInfo
, oiObject
, oiModTime
@@ -86,16 +92,17 @@ module Network.Minio
, oiSize
, oiMetadata
- , listObjects
- , listObjectsV1
-
+ -- ** Listing incomplete uploads
+ , listIncompleteUploads
, UploadId
, UploadInfo(..)
- , listIncompleteUploads
- , ObjectPartInfo(..)
, listIncompleteParts
+ , ObjectPartInfo(..)
-- ** Bucket Notifications
+ , getBucketNotification
+ , putBucketNotification
+ , removeAllBucketNotification
, Notification(..)
, defaultNotification
, NotificationConfig(..)
@@ -108,15 +115,11 @@ module Network.Minio
, FilterRules(..)
, defaultFilterRules
, FilterRule(..)
- , getBucketNotification
- , putBucketNotification
- , removeAllBucketNotification
-- * Object Operations
- ----------------------
, Object
- -- ** File operations
+ -- ** File-based operations
, fGetObject
, fPutObject
@@ -144,7 +147,7 @@ module Network.Minio
, gooIfUnmodifiedSince
, gooSSECKey
- -- ** Server-side copying
+ -- ** Server-side object copying
, copyObject
, SourceInfo
, defaultSourceInfo
@@ -160,38 +163,38 @@ module Network.Minio
, dstBucket
, dstObject
- -- ** Querying
+ -- ** Querying object info
, statObject
- -- ** Object removal functions
+ -- ** Object removal operations
, removeObject
, removeIncompleteUpload
-- ** Select Object Content with SQL
, module Network.Minio.SelectAPI
- -- * Server-Size Encryption Helpers
- -----------------------------------
- , SSECKey
+ -- * Server-Side Encryption Helpers
, mkSSECKey
+ , SSECKey
, SSE(..)
-
-- * Presigned Operations
- -------------------------
- , UrlExpiry
, presignedPutObjectUrl
, presignedGetObjectUrl
, presignedHeadObjectUrl
+ , UrlExpiry
- -- ** Utilities for POST (browser) uploads
- , PostPolicy
- , PostPolicyError(..)
+ -- ** POST (browser) upload helpers
+ -- | Please see
+ -- https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-HTTPPOSTConstructPolicy.html
+ -- for detailed information.
, newPostPolicy
, presignedPostPolicy
, showPostPolicy
+ , PostPolicy
+ , PostPolicyError(..)
- -- *** Utilities to specify Post Policy conditions
+ -- *** Post Policy condition helpers
, PostPolicyCondition
, ppCondBucket
, ppCondContentLengthRange
@@ -201,9 +204,8 @@ module Network.Minio
, ppCondSuccessActionStatus
-- * Error handling
- -----------------------
- -- | Data types representing various errors that may occur while working
- -- with an object storage service.
+ -- | Data types representing various errors that may occur while
+ -- working with an object storage service.
, MinioErr(..)
, MErrV(..)
, ServiceErr(..)
diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs
index 0b8578c..3d29354 100644
--- a/src/Network/Minio/API.hs
+++ b/src/Network/Minio/API.hs
@@ -37,7 +37,6 @@ import qualified Data.Conduit as C
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Time.Clock as Time
-
import Network.HTTP.Conduit (Response)
import qualified Network.HTTP.Conduit as NC
import qualified Network.HTTP.Types as HT
@@ -75,73 +74,97 @@ discoverRegion ri = runMaybeT $ do
return l
) return regionMay
+getRegion :: S3ReqInfo -> Minio (Maybe Region)
+getRegion ri = do
+ ci <- asks mcConnInfo
+
+ -- getService/makeBucket/getLocation -- don't need location
+ if | not $ riNeedsLocation ri ->
+ return $ Just $ connectRegion ci
+
+ -- if autodiscovery of location is disabled by user
+ | not $ connectAutoDiscoverRegion ci ->
+ return $ Just $ connectRegion ci
+
+ -- discover the region for the request
+ | otherwise -> discoverRegion ri
+
+getRegionHost :: Region -> Minio Text
+getRegionHost r = do
+ ci <- asks mcConnInfo
+
+ if "amazonaws.com" `T.isSuffixOf` connectHost ci
+ then maybe (throwIO $ MErrVRegionNotSupported r)
+ return (Map.lookup r awsRegionMap)
+ else return $ connectHost ci
buildRequest :: S3ReqInfo -> Minio NC.Request
buildRequest ri = do
- maybe (return ()) checkBucketNameValidity $ riBucket ri
- maybe (return ()) checkObjectNameValidity $ riObject ri
-
- ci <- asks mcConnInfo
-
- -- getService/makeBucket/getLocation -- don't need
- -- location
- region <- if | not $ riNeedsLocation ri ->
- return $ Just $ connectRegion ci
-
- -- if autodiscovery of location is disabled by user
- | not $ connectAutoDiscoverRegion ci ->
- return $ Just $ connectRegion ci
-
- -- discover the region for the request
- | otherwise -> discoverRegion ri
-
- regionHost <- case region of
- Nothing -> return $ connectHost ci
- Just r -> if "amazonaws.com" `T.isSuffixOf` connectHost ci
- then maybe
- (throwIO $ MErrVRegionNotSupported r)
- return
- (Map.lookup r awsRegionMap)
- else return $ connectHost ci
-
- sha256Hash <- if | connectIsSecure ci ->
- -- if secure connection
- return "UNSIGNED-PAYLOAD"
-
- -- otherwise compute sha256
- | otherwise -> getPayloadSHA256Hash (riPayload ri)
-
- timeStamp <- liftIO Time.getCurrentTime
-
- let hostHeader = (hHost, getHostAddr ci)
- newRi = ri { riPayloadHash = Just sha256Hash
- , riHeaders = hostHeader
- : sha256Header sha256Hash
- : riHeaders ri
- , riRegion = region
+ maybe (return ()) checkBucketNameValidity $ riBucket ri
+ maybe (return ()) checkObjectNameValidity $ riObject ri
+
+ ci <- asks mcConnInfo
+
+ regionMay <- getRegion ri
+
+ regionHost <- maybe (return $ connectHost ci) getRegionHost regionMay
+
+ let ri' = ri { riHeaders = hostHeader : riHeaders ri
+ , riRegion = regionMay
}
- newCi = ci { connectHost = regionHost }
- signReq = toRequest newCi newRi
- sp = SignParams (connectAccessKey ci) (connectSecretKey ci)
- timeStamp (riRegion newRi) Nothing (riPayloadHash newRi)
- let signHeaders = signV4 sp signReq
-
- -- Update signReq with Authorization header containing v4 signature
- return signReq {
- NC.requestHeaders = riHeaders newRi ++ mkHeaderFromPairs signHeaders
- }
- where
- toRequest :: ConnectInfo -> S3ReqInfo -> NC.Request
- toRequest ci s3Req = NC.defaultRequest {
- NC.method = riMethod s3Req
- , NC.secure = connectIsSecure ci
- , NC.host = encodeUtf8 $ connectHost ci
- , NC.port = connectPort ci
- , NC.path = getS3Path (riBucket s3Req) (riObject s3Req)
- , NC.requestHeaders = riHeaders s3Req
- , NC.queryString = HT.renderQuery False $ riQueryParams s3Req
- , NC.requestBody = getRequestBody (riPayload s3Req)
- }
+ ci' = ci { connectHost = regionHost }
+ hostHeader = (hHost, getHostAddr ci')
+
+ -- Does not contain body and auth info.
+ baseRequest = NC.defaultRequest
+ { NC.method = riMethod ri'
+ , NC.secure = connectIsSecure ci'
+ , NC.host = encodeUtf8 $ connectHost ci'
+ , NC.port = connectPort ci'
+ , NC.path = getS3Path (riBucket ri') (riObject ri')
+ , NC.requestHeaders = riHeaders ri'
+ , NC.queryString = HT.renderQuery False $ riQueryParams ri'
+ }
+
+ timeStamp <- liftIO Time.getCurrentTime
+
+ let sp = SignParams (connectAccessKey ci') (connectSecretKey ci')
+ timeStamp (riRegion ri') Nothing Nothing
+
+ -- Cases to handle:
+ --
+ -- 1. Connection is secure: use unsigned payload
+ --
+ -- 2. Insecure connection, streaming signature is enabled via use of
+ -- conduit payload: use streaming signature for request.
+ --
+ -- 3. Insecure connection, non-conduit payload: compute payload
+ -- sha256hash, buffer request in memory and perform request.
+
+ -- case 2 from above.
+ if | isStreamingPayload (riPayload ri') &&
+ (not $ connectIsSecure ci') -> do
+ (pLen, pSrc) <- case riPayload ri of
+ PayloadC l src -> return (l, src)
+ _ -> throwIO MErrVUnexpectedPayload
+ let reqFn = signV4Stream pLen sp baseRequest
+ return $ reqFn pSrc
+
+ | otherwise -> do
+ -- case 1 described above.
+ sp' <- if | connectIsSecure ci' -> return sp
+ -- case 3 described above.
+ | otherwise -> do
+ pHash <- getPayloadSHA256Hash $ riPayload ri'
+ return $ sp { spPayloadHash = Just pHash }
+
+ let signHeaders = signV4 sp' baseRequest
+ return $ baseRequest
+ { NC.requestHeaders =
+ NC.requestHeaders baseRequest ++
+ mkHeaderFromPairs signHeaders
+ , NC.requestBody = getRequestBody (riPayload ri')
+ }
retryAPIRequest :: Minio a -> Minio a
diff --git a/src/Network/Minio/APICommon.hs b/src/Network/Minio/APICommon.hs
index e62e651..52293cb 100644
--- a/src/Network/Minio/APICommon.hs
+++ b/src/Network/Minio/APICommon.hs
@@ -16,6 +16,9 @@
module Network.Minio.APICommon where
+import qualified Conduit as C
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LB
import Data.Conduit.Binary (sourceHandleRange)
import qualified Network.HTTP.Conduit as NC
import qualified Network.HTTP.Types as HT
@@ -24,16 +27,20 @@ import Lib.Prelude
import Network.Minio.Data
import Network.Minio.Data.Crypto
+import Network.Minio.Errors
sha256Header :: ByteString -> HT.Header
sha256Header = ("x-amz-content-sha256", )
-getPayloadSHA256Hash :: (MonadIO m) => Payload -> m ByteString
+-- | This function throws an error if the payload is a conduit (as it
+-- will not be possible to re-read the conduit after it is consumed).
+getPayloadSHA256Hash :: Payload -> Minio ByteString
getPayloadSHA256Hash (PayloadBS bs) = return $ hashSHA256 bs
getPayloadSHA256Hash (PayloadH h off size) = hashSHA256FromSource $
sourceHandleRange h
(return . fromIntegral $ off)
(return . fromIntegral $ size)
+getPayloadSHA256Hash (PayloadC _ _) = throwIO MErrVUnexpectedPayload
getRequestBody :: Payload -> NC.RequestBody
getRequestBody (PayloadBS bs) = NC.RequestBodyBS bs
@@ -42,3 +49,20 @@ getRequestBody (PayloadH h off size) =
sourceHandleRange h
(return . fromIntegral $ off)
(return . fromIntegral $ size)
+getRequestBody (PayloadC n src) = NC.requestBodySource n src
+
+mkStreamingPayload :: Payload -> Payload
+mkStreamingPayload payload =
+ case payload of
+ PayloadBS bs ->
+ PayloadC (fromIntegral $ BS.length bs)
+ (C.sourceLazy $ LB.fromStrict bs)
+ PayloadH h off len ->
+ PayloadC len $ sourceHandleRange h
+ (return . fromIntegral $ off)
+ (return . fromIntegral $ len)
+ _ -> payload
+
+isStreamingPayload :: Payload -> Bool
+isStreamingPayload (PayloadC _ _) = True
+isStreamingPayload _ = False
diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs
index 6559492..c50c6d5 100644
--- a/src/Network/Minio/Data.hs
+++ b/src/Network/Minio/Data.hs
@@ -20,6 +20,7 @@
{-# LANGUAGE TypeFamilies #-}
module Network.Minio.Data where
+import qualified Conduit as C
import Control.Concurrent.MVar (MVar)
import qualified Control.Concurrent.MVar as M
import Control.Monad.IO.Unlift (MonadUnliftIO, UnliftIO (..),
@@ -126,7 +127,8 @@ data Credentials = Credentials { cAccessKey :: Text
, cSecretKey :: Text
} deriving (Eq, Show)
--- | A Provider is an action that may return Credentials
+-- | A Provider is an action that may return Credentials. Providers
+-- may be chained together using 'findFirst'.
type Provider = IO (Maybe Credentials)
-- | Combines the given list of providers, by calling each one in
@@ -212,16 +214,18 @@ getHostAddr ci = if | port == 80 || port == 443 -> toS host
host = connectHost ci
--- | Default GCS ConnectInfo. Works only for "Simple Migration"
--- use-case with interoperability mode enabled on GCP console. For
--- more information - https://cloud.google.com/storage/docs/migrating
+-- | Default Google Compute Storage ConnectInfo. Works only for
+-- "Simple Migration" use-case with interoperability mode enabled on
+-- GCP console. For more information -
+-- https://cloud.google.com/storage/docs/migrating
+--
-- Credentials should be supplied before use.
gcsCI :: ConnectInfo
gcsCI = setRegion "us"
"https://storage.googleapis.com"
--- | Default AWS ConnectInfo. Connects to "us-east-1". Credentials
+-- | Default AWS S3 ConnectInfo. Connects to "us-east-1". Credentials
-- should be supplied before use.
awsCI :: ConnectInfo
awsCI = "https://s3.amazonaws.com"
@@ -243,9 +247,7 @@ type Bucket = Text
-- Represents an object name
type Object = Text
--- |
--- Represents a region
--- TODO: This could be a Sum Type with all defined regions for AWS.
+-- | Represents a region
type Region = Text
-- | A type alias to represent an Entity-Tag returned by S3-compatible APIs.
@@ -434,7 +436,7 @@ data ListObjectsV1Result = ListObjectsV1Result {
-- | Represents information about an object.
data ObjectInfo = ObjectInfo
- { oiObject :: Object -- ^ Oject key
+ { oiObject :: Object -- ^ Object key
, oiModTime :: UTCTime -- ^ Mdification time of the object
, oiETag :: ETag -- ^ ETag of the object
, oiSize :: Int64 -- ^ Size of the object in bytes
@@ -883,10 +885,10 @@ type Stats = Progress
-- | Represents different kinds of payload that are used with S3 API
-- requests.
-data Payload = PayloadBS ByteString
- | PayloadH Handle
- Int64 -- offset
- Int64 -- size
+data Payload
+ = PayloadBS ByteString
+ | PayloadH Handle Int64 Int64 -- file handle, offset and length
+ | PayloadC Int64 (C.ConduitT () ByteString (ResourceT IO) ()) -- length and byte source
defaultPayload :: Payload
defaultPayload = PayloadBS ""
@@ -983,18 +985,7 @@ connect ci = do
-- `MinioConn`. This reuses connections, but otherwise it is similar
-- to `runMinio`.
runMinioWith :: MinioConn -> Minio a -> IO (Either MinioErr a)
-runMinioWith conn m = runResourceT . flip runReaderT conn . unMinio $
- fmap Right m `U.catches`
- [ U.Handler handlerServiceErr
- , U.Handler handlerHE
- , U.Handler handlerFE
- , U.Handler handlerValidation
- ]
- where
- handlerServiceErr = return . Left . MErrService
- handlerHE = return . Left . MErrHTTP
- handlerFE = return . Left . MErrIO
- handlerValidation = return . Left . MErrValidation
+runMinioWith conn m = runResourceT $ runMinioResWith conn m
-- | Given `ConnectInfo` and a HTTP connection manager, create a
-- `MinioConn`.
@@ -1007,7 +998,31 @@ mkMinioConn ci mgr = do
runMinio :: ConnectInfo -> Minio a -> IO (Either MinioErr a)
runMinio ci m = do
conn <- connect ci
- runMinioWith conn m
+ runResourceT $ runMinioResWith conn m
+
+-- | Similar to 'runMinioWith'. Allows applications to allocate/release
+-- its resources along side MinIO's internal resources.
+runMinioResWith :: MinioConn -> Minio a -> ResourceT IO (Either MinioErr a)
+runMinioResWith conn m =
+ flip runReaderT conn . unMinio $
+ fmap Right m `U.catches`
+ [ U.Handler handlerServiceErr
+ , U.Handler handlerHE
+ , U.Handler handlerFE
+ , U.Handler handlerValidation
+ ]
+ where
+ handlerServiceErr = return . Left . MErrService
+ handlerHE = return . Left . MErrHTTP
+ handlerFE = return . Left . MErrIO
+ handlerValidation = return . Left . MErrValidation
+
+-- | Similar to 'runMinio'. Allows applications to allocate/release
+-- its resources along side MinIO's internal resources.
+runMinioRes :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a)
+runMinioRes ci m = do
+ conn <- liftIO $ connect ci
+ runMinioResWith conn m
s3Name :: Text -> Text -> Name
s3Name ns s = Name s (Just ns) Nothing
diff --git a/src/Network/Minio/Errors.hs b/src/Network/Minio/Errors.hs
index 9bcb991..22ced6d 100644
--- a/src/Network/Minio/Errors.hs
+++ b/src/Network/Minio/Errors.hs
@@ -1,5 +1,5 @@
--
--- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -42,6 +42,8 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64
| MErrVInvalidHealPath
| MErrVMissingCredentials
| MErrVInvalidEncryptionKeyLength
+ | MErrVStreamingBodyUnexpectedEOF
+ | MErrVUnexpectedPayload
deriving (Show, Eq)
instance Exception MErrV
diff --git a/src/Network/Minio/ListOps.hs b/src/Network/Minio/ListOps.hs
index 30486a9..7f5b7ee 100644
--- a/src/Network/Minio/ListOps.hs
+++ b/src/Network/Minio/ListOps.hs
@@ -1,5 +1,5 @@
--
--- MinIO Haskell SDK, (C) 2017 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -25,34 +25,54 @@ import Lib.Prelude
import Network.Minio.Data
import Network.Minio.S3API
--- | List objects in a bucket matching the given prefix. If recurse is
--- set to True objects matching prefix are recursively listed.
-listObjects :: Bucket -> Maybe Text -> Bool -> C.ConduitM () ObjectInfo Minio ()
+-- | Represents a list output item - either an object or an object
+-- prefix (i.e. a directory).
+data ListItem = ListItemObject ObjectInfo
+ | ListItemPrefix Text
+ deriving (Show, Eq)
+
+-- | @'listObjects' bucket prefix recurse@ lists objects in a bucket
+-- similar to a file system tree traversal.
+--
+-- If @prefix@ is not 'Nothing', only items with the given prefix are
+-- listed, otherwise items under the bucket are returned.
+--
+-- If @recurse@ is set to @True@ all directories under the prefix are
+-- recursively traversed and only objects are returned.
+--
+-- If @recurse@ is set to @False@, objects and directories immediately
+-- under the given prefix are returned (no recursive traversal is
+-- performed).
+listObjects :: Bucket -> Maybe Text -> Bool -> C.ConduitM () ListItem Minio ()
listObjects bucket prefix recurse = loop Nothing
where
- loop :: Maybe Text -> C.ConduitM () ObjectInfo Minio ()
+ loop :: Maybe Text -> C.ConduitM () ListItem Minio ()
loop nextToken = do
let
delimiter = bool (Just "/") Nothing recurse
res <- lift $ listObjects' bucket prefix nextToken delimiter Nothing
- CL.sourceList $ lorObjects res
+ CL.sourceList $ map ListItemObject $ lorObjects res
+ unless recurse $
+ CL.sourceList $ map ListItemPrefix $ lorCPrefixes res
when (lorHasMore res) $
loop (lorNextToken res)
--- | List objects in a bucket matching the given prefix. If recurse is
--- set to True objects matching prefix are recursively listed.
+-- | Lists objects - similar to @listObjects@, however uses the older
+-- V1 AWS S3 API. Prefer @listObjects@ to this.
listObjectsV1 :: Bucket -> Maybe Text -> Bool
- -> C.ConduitM () ObjectInfo Minio ()
+ -> C.ConduitM () ListItem Minio ()
listObjectsV1 bucket prefix recurse = loop Nothing
where
- loop :: Maybe Text -> C.ConduitM () ObjectInfo Minio ()
+ loop :: Maybe Text -> C.ConduitM () ListItem Minio ()
loop nextMarker = do
let
delimiter = bool (Just "/") Nothing recurse
res <- lift $ listObjectsV1' bucket prefix nextMarker delimiter Nothing
- CL.sourceList $ lorObjects' res
+ CL.sourceList $ map ListItemObject $ lorObjects' res
+ unless recurse $
+ CL.sourceList $ map ListItemPrefix $ lorCPrefixes' res
when (lorHasMore' res) $
loop (lorNextMarker res)
diff --git a/src/Network/Minio/PutObject.hs b/src/Network/Minio/PutObject.hs
index 44914e8..8723d25 100644
--- a/src/Network/Minio/PutObject.hs
+++ b/src/Network/Minio/PutObject.hs
@@ -1,5 +1,5 @@
--
--- MinIO Haskell SDK, (C) 2017 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -23,13 +23,14 @@ module Network.Minio.PutObject
import Conduit (takeC)
+import qualified Conduit as C
import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Conduit as C
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.Combinators as CC
import qualified Data.Conduit.List as CL
import qualified Data.List as List
+
import Lib.Prelude
import Network.Minio.Data
@@ -63,8 +64,8 @@ putObjectInternal :: Bucket -> Object -> PutObjectOptions
-> ObjectData Minio -> Minio ETag
putObjectInternal b o opts (ODStream src sizeMay) = do
case sizeMay of
- -- unable to get size, so assume non-seekable file and max-object size
- Nothing -> sequentialMultipartUpload b o opts (Just maxObjectSize) src
+ -- unable to get size, so assume non-seekable file
+ Nothing -> sequentialMultipartUpload b o opts Nothing src
-- got file size, so check for single/multipart upload
Just size ->
@@ -85,9 +86,8 @@ putObjectInternal b o opts (ODFile fp sizeMay) = do
let finalSizeMay = listToMaybe $ catMaybes [sizeMay, handleSizeMay]
case finalSizeMay of
- -- unable to get size, so assume non-seekable file and max-object size
- Nothing -> sequentialMultipartUpload b o opts (Just maxObjectSize) $
- CB.sourceFile fp
+ -- unable to get size, so assume non-seekable file
+ Nothing -> sequentialMultipartUpload b o opts Nothing $ CB.sourceFile fp
-- got file size, so check for single/multipart upload
Just size ->
@@ -138,7 +138,7 @@ sequentialMultipartUpload b o opts sizeMay src = do
(pnums, _, sizes) = List.unzip3 partSizes
uploadedParts <- C.runConduit
$ src
- C..| chunkBSConduit sizes
+ C..| chunkBSConduit (map fromIntegral sizes)
C..| CL.map PayloadBS
C..| uploadPart' uploadId pnums
C..| CC.sinkList
diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs
index 50b08ce..217d80d 100644
--- a/src/Network/Minio/S3API.hs
+++ b/src/Network/Minio/S3API.hs
@@ -42,6 +42,7 @@ module Network.Minio.S3API
---------------------------------
, putBucket
, ETag
+ , maxSinglePutObjectSizeBytes
, putObjectSingle'
, putObjectSingle
, copyObjectSingle
@@ -90,8 +91,8 @@ module Network.Minio.S3API
, removeAllBucketNotification
) where
+import qualified Conduit as C
import qualified Data.ByteString as BS
-import qualified Data.Conduit as C
import qualified Data.Text as T
import qualified Network.HTTP.Conduit as NC
import qualified Network.HTTP.Types as HT
@@ -101,6 +102,7 @@ import UnliftIO (Handler (Handler))
import Lib.Prelude
import Network.Minio.API
+import Network.Minio.APICommon
import Network.Minio.Data
import Network.Minio.Errors
import Network.Minio.PresignedOperations
@@ -156,13 +158,13 @@ putObjectSingle' bucket object headers bs = do
when (size > maxSinglePutObjectSizeBytes) $
throwIO $ MErrVSinglePUTSizeExceeded size
- -- content-length header is automatically set by library.
+ let payload = mkStreamingPayload $ PayloadBS bs
resp <- executeRequest $
defaultS3ReqInfo { riMethod = HT.methodPut
, riBucket = Just bucket
, riObject = Just object
, riHeaders = headers
- , riPayload = PayloadBS bs
+ , riPayload = payload
}
let rheaders = NC.responseHeaders resp
@@ -181,13 +183,14 @@ putObjectSingle bucket object headers h offset size = do
throwIO $ MErrVSinglePUTSizeExceeded size
-- content-length header is automatically set by library.
+ let payload = mkStreamingPayload $ PayloadH h offset size
resp <- executeRequest $
defaultS3ReqInfo { riMethod = HT.methodPut
- , riBucket = Just bucket
- , riObject = Just object
- , riHeaders = headers
- , riPayload = PayloadH h offset size
- }
+ , riBucket = Just bucket
+ , riObject = Just object
+ , riHeaders = headers
+ , riPayload = payload
+ }
let rheaders = NC.responseHeaders resp
etag = getETagHeader rheaders
@@ -264,14 +267,16 @@ newMultipartUpload bucket object headers = do
putObjectPart :: Bucket -> Object -> UploadId -> PartNumber -> [HT.Header]
-> Payload -> Minio PartTuple
putObjectPart bucket object uploadId partNumber headers payload = do
+ -- transform payload to conduit to enable streaming signature
+ let payload' = mkStreamingPayload payload
resp <- executeRequest $
defaultS3ReqInfo { riMethod = HT.methodPut
- , riBucket = Just bucket
- , riObject = Just object
- , riQueryParams = mkOptionalParams params
- , riHeaders = headers
- , riPayload = payload
- }
+ , riBucket = Just bucket
+ , riObject = Just object
+ , riQueryParams = mkOptionalParams params
+ , riHeaders = headers
+ , riPayload = payload'
+ }
let rheaders = NC.responseHeaders resp
etag = getETagHeader rheaders
maybe
diff --git a/src/Network/Minio/SelectAPI.hs b/src/Network/Minio/SelectAPI.hs
index 2843325..11f6cac 100644
--- a/src/Network/Minio/SelectAPI.hs
+++ b/src/Network/Minio/SelectAPI.hs
@@ -29,7 +29,6 @@ module Network.Minio.SelectAPI
, selectRequest
-- *** Input Serialization
- -------------------------
, InputSerialization
, defaultCsvInput
@@ -42,7 +41,7 @@ module Network.Minio.SelectAPI
, setInputCompressionType
-- *** CSV Format details
- ------------------------
+
-- | CSV format options such as delimiters and quote characters are
-- specified using using the functions below. Options are combined
-- monoidally.
@@ -60,7 +59,6 @@ module Network.Minio.SelectAPI
, quoteFields
-- *** Output Serialization
- -------------------------
, OutputSerialization
, defaultCsvOutput
@@ -69,12 +67,11 @@ module Network.Minio.SelectAPI
, outputJSONFromRecordDelimiter
-- *** Progress messages
- ------------------------
, setRequestProgressEnabled
-- *** Interpreting Select output
- --------------------------------------------
+
-- | The conduit returned by `selectObjectContent` returns values of
-- the `EventMessage` data type. This returns the query output
-- messages formatted according to the chosen output serialization,
diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs
index 634b8ec..57f6824 100644
--- a/src/Network/Minio/Sign/V4.hs
+++ b/src/Network/Minio/Sign/V4.hs
@@ -1,5 +1,5 @@
--
--- MinIO Haskell SDK, (C) 2017 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -14,21 +14,9 @@
-- limitations under the License.
--
-module Network.Minio.Sign.V4
- (
- signV4
- , signV4PostPolicy
- , mkScope
- , getHeadersToSign
- , mkCanonicalRequest
- , mkStringToSign
- , mkSigningKey
- , computeSignature
- , SignV4Data(..)
- , SignParams(..)
- , debugPrintSignV4Data
- ) where
+module Network.Minio.Sign.V4 where
+import qualified Conduit as C
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as B8
@@ -39,13 +27,15 @@ import qualified Data.Set as Set
import qualified Data.Time as Time
import qualified Network.HTTP.Conduit as NC
import Network.HTTP.Types (Header, parseQuery)
-import qualified Network.HTTP.Types.Header as H
+import qualified Network.HTTP.Types as H
+import Text.Printf (printf)
import Lib.Prelude
import Network.Minio.Data.ByteString
import Network.Minio.Data.Crypto
import Network.Minio.Data.Time
+import Network.Minio.Errors
-- these headers are not included in the string to sign when signing a
-- request
@@ -53,7 +43,6 @@ ignoredHeaders :: Set ByteString
ignoredHeaders = Set.fromList $ map CI.foldedCase
[ H.hAuthorization
, H.hContentType
- , H.hContentLength
, H.hUserAgent
]
@@ -93,6 +82,20 @@ debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do
mapM_ (\x -> B.putStr $ B.concat [show x, " "]) $ B.unpack b
B8.putStrLn ""
+mkAuthHeader :: Text -> ByteString -> ByteString -> ByteString -> H.Header
+mkAuthHeader accessKey scope signedHeaderKeys sign =
+ let authValue = B.concat
+ [ "AWS4-HMAC-SHA256 Credential="
+ , toS accessKey
+ , "/"
+ , scope
+ , ", SignedHeaders="
+ , signedHeaderKeys
+ , ", Signature="
+ , sign
+ ]
+ in (H.hAuthorization, authValue)
+
-- | Given SignParams and request details, including request method,
-- request path, headers, query params and payload hash, generates an
-- updated set of headers, including the x-amz-date header and the
@@ -105,7 +108,6 @@ debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do
-- is being created. The expiry is interpreted as an integer number of
-- seconds. The output will be the list of query-parameters to add to
-- the request.
-
signV4 :: SignParams -> NC.Request -> [(ByteString, ByteString)]
signV4 !sp !req =
let
@@ -139,7 +141,8 @@ signV4 !sp !req =
else []
-- 1. compute canonical request
- canonicalRequest = mkCanonicalRequest sp (NC.setQueryString finalQP req)
+ canonicalRequest = mkCanonicalRequest False sp
+ (NC.setQueryString finalQP req)
headersToSign
-- 2. compute string to sign
@@ -152,23 +155,15 @@ signV4 !sp !req =
signature = computeSignature stringToSign signingKey
-- 4. compute auth header
- authValue = B.concat
- [ "AWS4-HMAC-SHA256 Credential="
- , accessKey
- , "/"
- , scope
- , ", SignedHeaders="
- , signedHeaderKeys
- , ", Signature="
- , signature
- ]
- authHeader = (H.hAuthorization, authValue)
+ authHeader = mkAuthHeader (spAccessKey sp) scope signedHeaderKeys signature
-- finally compute output pairs
+ sha256Hdr = ("x-amz-content-sha256",
+ fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp)
output = if isJust expiry
then ("X-Amz-Signature", signature) : authQP
else [(\(x, y) -> (CI.foldedCase x, y)) authHeader,
- datePair]
+ datePair, sha256Hdr]
in output
@@ -186,9 +181,9 @@ getHeadersToSign !h =
filter (flip Set.notMember ignoredHeaders . fst) $
map (\(x, y) -> (CI.foldedCase x, stripBS y)) h
-mkCanonicalRequest :: SignParams -> NC.Request -> [(ByteString, ByteString)]
- -> ByteString
-mkCanonicalRequest !sp !req !headersForSign =
+mkCanonicalRequest :: Bool -> SignParams -> NC.Request -> [(ByteString, ByteString)]
+ -> ByteString
+mkCanonicalRequest !isStreaming !sp !req !headersForSign =
let
canonicalQueryString = B.intercalate "&" $
map (\(x, y) -> B.concat [x, "=", y]) $
@@ -203,6 +198,10 @@ mkCanonicalRequest !sp !req !headersForSign =
signedHeaders = B.intercalate ";" $ map fst sortedHeaders
+ payloadHashStr =
+ if isStreaming
+ then "STREAMING-AWS4-HMAC-SHA256-PAYLOAD"
+ else fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp
in
B.intercalate "\n"
[ NC.method req
@@ -210,7 +209,7 @@ mkCanonicalRequest !sp !req !headersForSign =
, canonicalQueryString
, canonicalHeaders
, signedHeaders
- , maybe "UNSIGNED-PAYLOAD" identity $ spPayloadHash sp
+ , payloadHashStr
]
mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString
@@ -246,3 +245,147 @@ signV4PostPolicy !postPolicyJSON !sp =
Map.fromList [ ("x-amz-signature", signature)
, ("policy", stringToSign)
]
+
+chunkSizeConstant :: Int
+chunkSizeConstant = 64 * 1024
+
+-- base16Len computes the number of bytes required to represent @n (> 0)@ in
+-- hexadecimal.
+base16Len :: Integral a => a -> Int
+base16Len n | n == 0 = 0
+ | otherwise = 1 + base16Len (n `div` 16)
+
+signedStreamLength :: Int64 -> Int64
+signedStreamLength dataLen =
+ let
+ chunkSzInt = fromIntegral chunkSizeConstant
+ (numChunks, lastChunkLen) = quotRem dataLen chunkSzInt
+
+
+ -- Structure of a chunk:
+ -- string(IntHexBase(chunk-size)) + ";chunk-signature=" + signature + \r\n + chunk-data + \r\n
+ encodedChunkLen csz = fromIntegral (base16Len csz) + 17 + 64 + 2 + csz + 2
+ fullChunkSize = encodedChunkLen chunkSzInt
+ lastChunkSize = bool 0 (encodedChunkLen lastChunkLen) $ lastChunkLen > 0
+ finalChunkSize = 1 + 17 + 64 + 2 + 2
+ in
+ numChunks * fullChunkSize + lastChunkSize + finalChunkSize
+
+signV4Stream :: Int64 -> SignParams -> NC.Request
+ -> (C.ConduitT () ByteString (C.ResourceT IO) () -> NC.Request)
+ -- -> ([Header], C.ConduitT () ByteString (C.ResourceT IO) () -> NC.RequestBody)
+signV4Stream !payloadLength !sp !req =
+ let
+ ts = spTimeStamp sp
+
+ addContentEncoding hs =
+ let ceMay = headMay $ filter (\(x, _) -> x == "content-encoding") hs
+ in case ceMay of
+ Nothing -> ("content-encoding", "aws-chunked") : hs
+ Just (_, ce) -> ("content-encoding", ce <> ",aws-chunked") :
+ filter (\(x, _) -> x /= "content-encoding") hs
+
+ -- headers to be added to the request
+ datePair = ("X-Amz-Date", awsTimeFormatBS ts)
+ computedHeaders = addContentEncoding $
+ datePair : NC.requestHeaders req
+
+ -- headers specific to streaming signature
+ signedContentLength = signedStreamLength payloadLength
+ streamingHeaders :: [Header]
+ streamingHeaders =
+ [ ("x-amz-decoded-content-length", show payloadLength)
+ , ("content-length", show signedContentLength )
+ , ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD")
+ ]
+ headersToSign = getHeadersToSign $ computedHeaders ++ streamingHeaders
+ signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign
+ finalQP = parseQuery (NC.queryString req)
+
+ -- 1. Compute Seed Signature
+ -- 1.1 Canonical Request
+ canonicalReq = mkCanonicalRequest True sp
+ (NC.setQueryString finalQP req)
+ headersToSign
+
+ region = fromMaybe "" $ spRegion sp
+ scope = mkScope ts region
+ accessKey = spAccessKey sp
+ secretKey = spSecretKey sp
+
+ -- 1.2 String toSign
+ stringToSign = mkStringToSign ts scope canonicalReq
+
+ -- 1.3 Compute signature
+ -- 1.3.1 compute signing key
+ signingKey = mkSigningKey ts region $ toS secretKey
+
+ -- 1.3.2 Compute signature
+ seedSignature = computeSignature stringToSign signingKey
+
+ -- 1.3.3 Compute Auth Header
+ authHeader = mkAuthHeader accessKey scope signedHeaderKeys seedSignature
+
+ -- 1.4 Updated headers for the request
+ finalReqHeaders = authHeader : (computedHeaders ++ streamingHeaders)
+ -- headersToAdd = authHeader : datePair : streamingHeaders
+
+ toHexStr n = B8.pack $ printf "%x" n
+
+ (numParts, lastPSize) = payloadLength `quotRem` fromIntegral chunkSizeConstant
+
+ -- Function to compute string to sign for each chunk.
+ chunkStrToSign prevSign currChunkHash =
+ B.intercalate "\n"
+ [ "AWS4-HMAC-SHA256-PAYLOAD"
+ , awsTimeFormatBS ts
+ , scope
+ , prevSign
+ , hashSHA256 ""
+ , currChunkHash
+ ]
+
+ -- Read n byte from upstream and return a strict bytestring.
+ mustTakeN n = do
+ bs <- toS <$> (C.takeCE n C..| C.sinkLazy)
+ when (B.length bs /= n) $
+ throwIO MErrVStreamingBodyUnexpectedEOF
+ return bs
+
+ signerConduit n lps prevSign =
+ -- First case encodes a full chunk of length
+ -- 'chunkSizeConstant'.
+ if | n > 0 -> do
+ bs <- mustTakeN chunkSizeConstant
+ let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
+ nextSign = computeSignature strToSign signingKey
+ chunkBS = toHexStr chunkSizeConstant
+ <> ";chunk-signature="
+ <> nextSign <> "\r\n" <> bs <> "\r\n"
+ C.yield chunkBS
+ signerConduit (n-1) lps nextSign
+
+ -- Second case encodes the last chunk which is smaller than
+ -- 'chunkSizeConstant'
+ | lps > 0 -> do
+ bs <- mustTakeN $ fromIntegral lps
+ let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
+ nextSign = computeSignature strToSign signingKey
+ chunkBS = toHexStr lps <> ";chunk-signature="
+ <> nextSign <> "\r\n" <> bs <> "\r\n"
+ C.yield chunkBS
+ signerConduit 0 0 nextSign
+
+ -- Last case encodes the final signature chunk that has no
+ -- data.
+ | otherwise -> do
+ let strToSign = chunkStrToSign prevSign (hashSHA256 "")
+ nextSign = computeSignature strToSign signingKey
+ lastChunkBS = "0;chunk-signature=" <> nextSign <> "\r\n\r\n"
+ C.yield lastChunkBS
+ in
+ \src -> req { NC.requestHeaders = finalReqHeaders
+ , NC.requestBody =
+ NC.requestBodySource signedContentLength $
+ src C..| signerConduit numParts lastPSize seedSignature
+ }
diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs
index 7ba9453..8f2d67d 100644
--- a/src/Network/Minio/Utils.hs
+++ b/src/Network/Minio/Utils.hs
@@ -1,5 +1,5 @@
--
--- MinIO Haskell SDK, (C) 2017 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -16,12 +16,12 @@
module Network.Minio.Utils where
+import qualified Conduit as C
import Control.Monad.IO.Unlift (MonadUnliftIO)
import qualified Control.Monad.Trans.Resource as R
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.CaseInsensitive (mk, original)
-import qualified Data.Conduit as C
import qualified Data.Conduit.Binary as CB
import qualified Data.List as List
import qualified Data.Map as Map
@@ -212,22 +212,17 @@ mkQuery k mv = (k,) <$> mv
mkOptionalParams :: [(Text, Maybe Text)] -> HT.Query
mkOptionalParams params = HT.toQuery $ uncurry mkQuery <$> params
-chunkBSConduit :: (Monad m, Integral a)
- => [a] -> C.ConduitM ByteString ByteString m ()
-chunkBSConduit s = loop 0 [] s
- where
- loop _ _ [] = return ()
- loop n readChunks (size:sizes) = do
- bsMay <- C.await
- case bsMay of
- Nothing -> when (n > 0) $ C.yield $ B.concat readChunks
- Just bs -> if n + fromIntegral (B.length bs) >= size
- then do let (a, b) = B.splitAt (fromIntegral $ size - n) bs
- chunkBS = B.concat $ readChunks ++ [a]
- C.yield chunkBS
- loop (fromIntegral $ B.length b) [b] sizes
- else loop (n + fromIntegral (B.length bs))
- (readChunks ++ [bs]) (size:sizes)
+-- | Conduit that rechunks bytestrings into the given chunk
+-- lengths. Stops after given chunk lengths are yielded. Stops if
+-- there are no more chunks to yield or if a shorter chunk is
+-- received. Does not throw any errors.
+chunkBSConduit :: (Monad m) => [Int] -> C.ConduitM ByteString ByteString m ()
+chunkBSConduit [] = return ()
+chunkBSConduit (s:ss) = do
+ bs <- fmap LB.toStrict $ C.takeCE s C..| C.sinkLazy
+ if | B.length bs == s -> C.yield bs >> chunkBSConduit ss
+ | B.length bs > 0 -> C.yield bs
+ | otherwise -> return ()
-- | Select part sizes - the logic is that the minimum part-size will
-- be 64MiB.
diff --git a/test/LiveServer.hs b/test/LiveServer.hs
index 9f5ab85..ea5f40a 100644
--- a/test/LiveServer.hs
+++ b/test/LiveServer.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
--
--- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.
+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
@@ -295,22 +295,66 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
\step bucket -> do
step "High-level listObjects Test"
step "put 3 objects"
- let expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3"]
+ let expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3", "o4"]
+ extractObjectsFromList os =
+ mapM (\t -> case t of
+ ListItemObject o -> Just $ oiObject o
+ _ -> Nothing) os
+ expectedNonRecList = ["o4", "dir/"]
+ extractObjectsAndDirsFromList os =
+ map (\t -> case t of
+ ListItemObject o -> oiObject o
+ ListItemPrefix d -> d) os
+
forM_ expectedObjects $
\obj -> fPutObject bucket obj "/etc/lsb-release" defaultPutObjectOptions
step "High-level listing of objects"
+ items <- C.runConduit $ listObjects bucket Nothing False C..| sinkList
+ liftIO $ assertEqual "Objects/Dirs match failed!" expectedNonRecList $
+ extractObjectsAndDirsFromList items
+
+ step "High-level recursive listing of objects"
objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList
- liftIO $ assertEqual "Objects match failed!" (sort expectedObjects)
- (map oiObject objects)
+ liftIO $ assertEqual "Objects match failed!"
+ (Just $ sort expectedObjects) $
+ extractObjectsFromList objects
step "High-level listing of objects (version 1)"
+ itemsV1 <- C.runConduit $ listObjectsV1 bucket Nothing False C..| sinkList
+ liftIO $ assertEqual "Objects/Dirs match failed!" expectedNonRecList $
+ extractObjectsAndDirsFromList itemsV1
+
+ step "High-level recursive listing of objects (version 1)"
objectsV1 <- C.runConduit $ listObjectsV1 bucket Nothing True C..|
sinkList
- liftIO $ assertEqual "Objects match failed!" (sort expectedObjects)
- (map oiObject objectsV1)
+ liftIO $ assertEqual "Objects match failed!"
+ (Just $ sort expectedObjects) $
+ extractObjectsFromList objectsV1
+
+ let expectedPrefListing = ["dir/o1", "dir/dir1/", "dir/dir2/"]
+ expectedPrefListingRec = Just ["dir/dir1/o2", "dir/dir2/o3", "dir/o1"]
+ step "High-level listing with prefix"
+ prefItems <- C.runConduit $ listObjects bucket (Just "dir/") False C..| sinkList
+ liftIO $ assertEqual "Objects/Dirs under prefix match failed!"
+ expectedPrefListing $ extractObjectsAndDirsFromList prefItems
+
+ step "High-level listing with prefix recursive"
+ prefItemsRec <- C.runConduit $ listObjects bucket (Just "dir/") True C..| sinkList
+ liftIO $ assertEqual "Objects/Dirs under prefix match recursive failed!"
+ expectedPrefListingRec $ extractObjectsFromList prefItemsRec
+
+ step "High-level listing with prefix (version 1)"
+ prefItemsV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") False C..| sinkList
+ liftIO $ assertEqual "Objects/Dirs under prefix match failed!"
+ expectedPrefListing $ extractObjectsAndDirsFromList prefItemsV1
+
+ step "High-level listing with prefix recursive (version 1)"
+ prefItemsRecV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") True C..| sinkList
+ liftIO $ assertEqual "Objects/Dirs under prefix match recursive failed!"
+ expectedPrefListingRec $ extractObjectsFromList prefItemsRecV1
step "Cleanup actions"
forM_ expectedObjects $