minio-hs 1.3.1 → 1.4.0

raw patch · 14 files changed

+506/−227 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• minio-hs.cabal +10/−10
• src/Network/Minio.hs +39/−37
• src/Network/Minio/API.hs +78/−55
• src/Network/Minio/APICommon.hs +25/−1
• src/Network/Minio/Data.hs +41/−26
• src/Network/Minio/Errors.hs +3/−1
• src/Network/Minio/ListOps.hs +31/−11
• src/Network/Minio/PutObject.hs +8/−8
• src/Network/Minio/S3API.hs +19/−14
• src/Network/Minio/SelectAPI.hs +2/−5
• src/Network/Minio/Sign/V4.hs +178/−35
• src/Network/Minio/Utils.hs +13/−18
• test/LiveServer.hs +50/−6

@@ -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

@@ -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 @@                      , 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 @@                      , 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 @@                      , 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 @@                      , 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

@@ -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 @@   , findFirst    -- * Connecting to object storage-  ---------------------------------   , ConnectInfo   , setRegion   , setCreds@@ -45,26 +48,25 @@   , 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 @@   , 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 @@   , 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 @@   , FilterRules(..)   , defaultFilterRules   , FilterRule(..)-  , getBucketNotification-  , putBucketNotification-  , removeAllBucketNotification    -- * Object Operations-  ----------------------   , Object -  -- ** File operations+  -- ** File-based operations   , fGetObject   , fPutObject @@ -144,7 +147,7 @@   , gooIfUnmodifiedSince   , gooSSECKey -  -- ** Server-side copying+  -- ** Server-side object copying   , copyObject   , SourceInfo   , defaultSourceInfo@@ -160,38 +163,38 @@   , 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 @@   , 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(..)

@@ -37,7 +37,6 @@ 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 @@             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+    maybe (return ()) checkBucketNameValidity $ riBucket ri+    maybe (return ()) checkObjectNameValidity $ riObject ri -  ci <- asks mcConnInfo+    ci <- asks mcConnInfo -               -- getService/makeBucket/getLocation -- don't need-               -- location-  region <- if | not $ riNeedsLocation ri ->-                   return $ Just $ connectRegion ci+    regionMay <- getRegion ri -               -- if autodiscovery of location is disabled by user-               | not $ connectAutoDiscoverRegion ci ->-                   return $ Just $ connectRegion ci+    regionHost <- maybe (return $ connectHost ci) getRegionHost regionMay -               -- discover the region for the request-               | otherwise -> discoverRegion ri+    let ri' = ri { riHeaders = hostHeader : riHeaders ri+                 , riRegion = regionMay+                 }+        ci' = ci { connectHost = regionHost }+        hostHeader = (hHost, getHostAddr ci') -  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+        -- 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'+                      } -  sha256Hash <- if | connectIsSecure ci ->-                       -- if secure connection-                       return "UNSIGNED-PAYLOAD"+    timeStamp <- liftIO Time.getCurrentTime -                   -- otherwise compute sha256-                   | otherwise -> getPayloadSHA256Hash (riPayload ri)+    let sp = SignParams (connectAccessKey ci') (connectSecretKey ci')+             timeStamp (riRegion ri') Nothing Nothing -  timeStamp <- liftIO Time.getCurrentTime+    -- 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. -  let hostHeader = (hHost, getHostAddr ci)-      newRi = ri { riPayloadHash = Just sha256Hash-                 , riHeaders = hostHeader-                             : sha256Header sha256Hash-                             : riHeaders ri-                 , riRegion = region-                 }-      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+         -- 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 -  -- 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)-        }+       | 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

@@ -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           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 @@     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

@@ -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 @@                                , 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 @@     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 @@ -- 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 @@  -- | 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 @@  -- | 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 @@ -- `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 @@ 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

@@ -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 @@            | MErrVInvalidHealPath            | MErrVMissingCredentials            | MErrVInvalidEncryptionKeyLength+           | MErrVStreamingBodyUnexpectedEOF+           | MErrVUnexpectedPayload   deriving (Show, Eq)  instance Exception MErrV

@@ -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           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) 

@@ -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 @@   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 @@                   -> 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 @@   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 @@       (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

@@ -42,6 +42,7 @@   ---------------------------------   , putBucket   , ETag+  , maxSinglePutObjectSizeBytes   , putObjectSingle'   , putObjectSingle   , copyObjectSingle@@ -90,8 +91,8 @@   , 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           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 @@   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 @@     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 @@ 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

@@ -29,7 +29,6 @@   , selectRequest    -- *** Input Serialization-  -------------------------    , InputSerialization   , defaultCsvInput@@ -42,7 +41,7 @@   , 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 @@   , quoteFields    -- *** Output Serialization-  -------------------------    , OutputSerialization   , defaultCsvOutput@@ -69,12 +67,11 @@   , 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,

@@ -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.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.fromList $ map CI.foldedCase                  [ H.hAuthorization                  , H.hContentType-                 , H.hContentLength                  , H.hUserAgent                  ] @@ -93,6 +82,20 @@       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 @@ -- 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 @@               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 @@     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 @@   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 @@      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 @@     , canonicalQueryString     , canonicalHeaders     , signedHeaders-    , maybe "UNSIGNED-PAYLOAD" identity $ spPayloadHash sp+    , payloadHashStr     ]  mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString@@ -246,3 +245,147 @@     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+                }

@@ -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 @@ 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.

@@ -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 @@   \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 $