packages feed

minio-hs 1.6.0 → 1.7.0

raw patch · 27 files changed

+1310/−487 lines, 27 filesdep +time-unitsdep −exceptionsdep ~bytestringdep ~case-insensitivedep ~conduitsetup-changednew-component:exe:AssumeRole

Dependencies added: time-units

Dependencies removed: exceptions

Dependency ranges changed: bytestring, case-insensitive, conduit, conduit-extra, filepath, raw-strings-qq, text, time, unliftio, unordered-containers

Files

CHANGELOG.md view
@@ -1,6 +1,21 @@ Changelog ========== +## Version 1.7.0 -- Unreleased++* Fix data type `EventMessage` to not export partial fields (#179)+* Bump up min bound on time dep and fix deprecation warnings (#181)+* Add `dev` flag to cabal for building with warnings as errors (#182)+* Fix AWS region map (#185)+* Fix XML generator tests (#187)+* Add support for STS Assume Role API (#188)++### Breaking changes in 1.7.0++* `Credentials` type has been removed. Use `CredentialValue` instead.+* `Provider` type has been replaced with `CredentialLoader`.+* `EventMessage` data type is updated.+ ## Version 1.6.0  * HLint fixes - some types were changed to newtype (#173)
README.md view
@@ -1,10 +1,8 @@-# MinIO Client SDK for Haskell [![Build Status](https://travis-ci.org/minio/minio-hs.svg?branch=master)](https://travis-ci.org/minio/minio-hs)[![Hackage](https://img.shields.io/hackage/v/minio-hs.svg)](https://hackage.haskell.org/package/minio-hs)[![Slack](https://slack.min.io/slack?type=svg)](https://slack.min.io)--The MinIO Haskell Client SDK provides simple APIs to access [MinIO](https://min.io) and Amazon S3 compatible object storage server.+# MinIO Haskell Client SDK for Amazon S3 Compatible Cloud Storage [![CI](https://github.com/minio/minio-hs/actions/workflows/ci.yml/badge.svg)](https://github.com/minio/minio-hs/actions/workflows/ci.yml)[![Hackage](https://img.shields.io/hackage/v/minio-hs.svg)](https://hackage.haskell.org/package/minio-hs)[![Slack](https://slack.min.io/slack?type=svg)](https://slack.min.io) -## Minimum Requirements+The MinIO Haskell Client SDK provides simple APIs to access [MinIO](https://min.io) and any Amazon S3 compatible object storage. -- The Haskell [stack](https://docs.haskellstack.org/en/stable/README/)+This guide assumes that you have a working [Haskell development environment](https://www.haskell.org/downloads/).  ## Installation @@ -12,20 +10,35 @@  Simply add `minio-hs` to your project's `.cabal` dependencies section or if you are using hpack, to your `package.yaml` file as usual. -### Try it out directly with `ghci`+### Try it out in a [REPL](https://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop) +#### For a cabal based environment++Download the library source and change to the extracted directory:++``` sh+$ cabal get minio-hs+$ cd minio-hs-1.6.0/ # directory name could be different+```++Then load the `ghci` REPL environment with the library and browse the available APIs:++``` sh+$ cabal repl+ghci> :browse Network.Minio+```++#### For a stack based environment+ From your home folder or any non-haskell project directory, just run:  ```sh- stack install minio-hs- ```  Then start an interpreter session and browse the available APIs with:  ```sh- $ stack ghci > :browse Network.Minio ```@@ -134,44 +147,52 @@  ### Development -To setup:+#### Download the source  ```sh-git clone https://github.com/minio/minio-hs.git--cd minio-hs/+$ git clone https://github.com/minio/minio-hs.git+$ cd minio-hs/+```  -stack install-```+#### Build the package: -Tests can be run with:+With `cabal`:  ```sh+$ # Configure cabal for development enabling all optional flags defined by the package.+$ cabal configure --enable-tests --test-show-details=direct -fexamples -fdev -flive-test+$ cabal build+``` -stack test+With `stack`: +``` sh+$ stack build --test --no-run-tests --flag minio-hs:live-test --flag minio-hs:dev --flag minio-hs:examples ```+#### Running tests: -A section of the tests use the remote MinIO Play server at `https://play.min.io` by default. For library development, using this remote server maybe slow. To run the tests against a locally running MinIO live server at `http://localhost:9000`, just set the environment `MINIO_LOCAL` to any value (and unset it to switch back to Play).+A section of the tests use the remote MinIO Play server at `https://play.min.io` by default. For library development, using this remote server maybe slow. To run the tests against a locally running MinIO live server at `http://localhost:9000` with the credentials `access_key=minio` and `secret_key=minio123`, just set the environment `MINIO_LOCAL` to any value (and unset it to switch back to Play). -To run the live server tests, set a build flag as shown below:+With `cabal`:  ```sh--stack test --flag minio-hs:live-test--# OR against a local MinIO server with:+$ export MINIO_LOCAL=1 # to run live tests against local MinIO server+$ cabal test+``` -MINIO_LOCAL=1 stack test --flag minio-hs:live-test+With `stack`: +``` sh+$ export MINIO_LOCAL=1 # to run live tests against local MinIO server+stack test --flag minio-hs:live-test --flag minio-hs:dev ``` -The configured CI system always runs both test-suites for every change.+This will run all the test suites. -Documentation can be locally built with:+#### Building documentation:  ```sh--stack haddock-+$ cabal haddock+$ # OR+$ stack haddock ```
− Setup.hs 
@@ -1,19 +0,0 @@------ MinIO Haskell SDK, (C) 2017 MinIO, Inc.------ Licensed under the Apache License, Version 2.0 (the "License");--- you may not use this file except in compliance with the License.--- You may obtain a copy of the License at------     http://www.apache.org/licenses/LICENSE-2.0------ Unless required by applicable law or agreed to in writing, software--- distributed under the License is distributed on an "AS IS" BASIS,--- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.--- See the License for the specific language governing permissions and--- limitations under the License.-----import Distribution.Simple--main = defaultMain
+ examples/AssumeRole.hs view
@@ -0,0 +1,47 @@+--+-- MinIO Haskell SDK, (C) 2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad.IO.Class (liftIO)+import Network.Minio+import Prelude++main :: IO ()+main = do+  -- Use play credentials for example.+  let assumeRole =+        STSAssumeRole+          ( CredentialValue+              "Q3AM3UQ867SPQQA43P2F"+              "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"+              Nothing+          )+          $ defaultSTSAssumeRoleOptions+            { saroLocation = Just "us-east-1",+              saroEndpoint = Just "https://play.min.io:9000"+            }++  -- Retrieve temporary credentials and print them.+  cv <- requestSTSCredential assumeRole+  print $ "Temporary credentials" ++ show (credentialValueText $ fst cv)+  print $ "Expiry" ++ show (snd cv)++  -- Configure 'ConnectInfo' to request temporary credentials on demand.+  ci <- setSTSCredential assumeRole "https://play.min.io"+  res <- runMinio ci $ do+    buckets <- listBuckets+    liftIO $ print $ "Top 5 buckets: " ++ show (take 5 buckets)+  print res
minio-hs.cabal view
@@ -1,6 +1,6 @@-cabal-version:       2.2+cabal-version:       2.4 name:                minio-hs-version:             1.6.0+version:             1.7.0 synopsis:            A MinIO Haskell Library for Amazon S3 compatible cloud                      storage. description:         The MinIO Haskell client library provides simple APIs to@@ -14,21 +14,29 @@ category:            Network, AWS, Object Storage build-type:          Simple stability:           Experimental-extra-source-files:+extra-doc-files:                    CHANGELOG.md                    CONTRIBUTING.md                    docs/API.md-                   examples/*.hs                    README.md+extra-source-files:+                   examples/*.hs                    stack.yaml-tested-with:         GHC == 8.8.4+tested-with:         GHC == 8.6.5+                   , GHC == 8.8.4                    , GHC == 8.10.7                    , GHC == 9.0.2+                   , GHC == 9.2.7+                   , GHC == 9.4.5  source-repository head   type:                git   location:            https://github.com/minio/minio-hs.git +Flag dev+  Description: Build package in development mode+  Default: False+  Manual: True  common base-settings   ghc-options:         -Wall@@ -41,16 +49,20 @@     ghc-options:       -Wredundant-constraints   if impl(ghc >= 8.2)     ghc-options:       -fhide-source-paths--  -- Add this when we have time. Fixing partial-fields requires major version-  -- bump at this time.-  -- if impl(ghc >= 8.4)-  --   ghc-options:       -Wpartial-fields-  --                      -Wmissing-export-lists-+  if impl(ghc >= 8.4)+    ghc-options:       -Wpartial-fields+  --                     -Wmissing-export-lists   if impl(ghc >= 8.8)     ghc-options:       -Wmissing-deriving-strategies                        -Werror=missing-deriving-strategies+  -- if impl(ghc >= 8.10)+  --   ghc-options:       -Wunused-packages -- disabled due to bug related to mixin config+  if impl(ghc >= 9.0)+    ghc-options:       -Winvalid-haddock+  if impl(ghc >= 9.2)+    ghc-options:       -Wredundant-bang-patterns+  if flag(dev)+    ghc-options:       -Werror    default-language:    Haskell2010 @@ -65,9 +77,7 @@                      , RankNTypes                      , ScopedTypeVariables                      , TupleSections-                     , TypeFamilies -   other-modules:       Lib.Prelude                      , Network.Minio.API                      , Network.Minio.APICommon@@ -85,7 +95,11 @@                      , Network.Minio.Utils                      , Network.Minio.XmlGenerator                      , Network.Minio.XmlParser+                     , Network.Minio.XmlCommon                      , Network.Minio.JsonParser+                     , Network.Minio.Credentials.Types+                     , Network.Minio.Credentials.AssumeRole+                     , Network.Minio.Credentials    mixins:              base hiding (Prelude)                      , relude (Relude as Prelude)@@ -105,7 +119,6 @@                      , cryptonite-conduit >= 0.2                      , digest >= 0.0.1                      , directory-                     , exceptions                      , filepath >= 1.4                      , http-client >= 0.5                      , http-client-tls@@ -114,11 +127,11 @@                      , ini                      , memory >= 0.14                      , network-uri-                     , raw-strings-qq >= 1                      , resourcet >= 1.2                      , retry                      , text >= 1.2-                     , time >= 1.8+                     , time >= 1.9+                     , time-units ^>= 1.0.0                      , transformers >= 0.5                      , unliftio >= 0.2 && < 0.3                      , unliftio-core >= 0.2 && < 0.3@@ -152,7 +165,9 @@                      , Network.Minio.Utils.Test                      , Network.Minio.XmlGenerator.Test                      , Network.Minio.XmlParser.Test+                     , Network.Minio.Credentials   build-depends:       minio-hs+                     , raw-strings-qq                      , tasty                      , tasty-hunit                      , tasty-quickcheck@@ -167,6 +182,7 @@   hs-source-dirs:      test, src   main-is:             Spec.hs   build-depends:       minio-hs+                     , raw-strings-qq                      , QuickCheck                      , tasty                      , tasty-hunit@@ -183,6 +199,7 @@                      , Network.Minio.Utils.Test                      , Network.Minio.XmlGenerator.Test                      , Network.Minio.XmlParser.Test+                     , Network.Minio.Credentials  Flag examples   Description: Build the examples@@ -328,3 +345,8 @@   import:              examples-settings   scope:               private   main-is:             SetConfig.hs++executable AssumeRole+  import:              examples-settings+  scope:               private+  main-is:             AssumeRole.hs
src/Lib/Prelude.hs view
@@ -42,7 +42,7 @@ both :: (a -> b) -> (a, a) -> (b, b) both f (a, b) = (f a, f b) -showBS :: Show a => a -> ByteString+showBS :: (Show a) => a -> ByteString showBS a = encodeUtf8 (show a :: Text)  toStrictBS :: LByteString -> ByteString
src/Network/Minio.hs view
@@ -1,5 +1,5 @@ ----- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2017-2023 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,7 +16,7 @@  -- | -- Module:      Network.Minio--- Copyright:   (c) 2017-2019 MinIO Dev Team+-- Copyright:   (c) 2017-2023 MinIO Dev Team -- License:     Apache 2.0 -- Maintainer:  MinIO Dev Team <dev@min.io> --@@ -24,13 +24,17 @@ -- storage servers like MinIO. module Network.Minio   ( -- * Credentials-    Credentials (..),+    CredentialValue (..),+    credentialValueText,+    AccessKey (..),+    SecretKey (..),+    SessionToken (..), -    -- ** Credential providers+    -- ** Credential Loaders -    -- | Run actions that retrieve 'Credentials' from the environment or+    -- | Run actions that retrieve 'CredentialValue's from the environment or     -- files or other custom sources.-    Provider,+    CredentialLoader,     fromAWSConfigFile,     fromAWSEnv,     fromMinioEnv,@@ -54,6 +58,15 @@     awsCI,     gcsCI, +    -- ** STS Credential types+    STSAssumeRole (..),+    STSAssumeRoleOptions (..),+    defaultSTSAssumeRoleOptions,+    requestSTSCredential,+    setSTSCredential,+    ExpiryTime (..),+    STSCredentialProvider,+     -- * Minio Monad      ----------------@@ -225,14 +238,15 @@ import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Combinators as CC+import Network.Minio.API import Network.Minio.CopyObject+import Network.Minio.Credentials import Network.Minio.Data import Network.Minio.Errors import Network.Minio.ListOps import Network.Minio.PutObject import Network.Minio.S3API import Network.Minio.SelectAPI-import Network.Minio.Utils  -- | Lists buckets. listBuckets :: Minio [BucketInfo]
src/Network/Minio/API.hs view
@@ -1,5 +1,5 @@ ----- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -26,6 +26,7 @@     checkBucketNameValidity,     isValidObjectName,     checkObjectNameValidity,+    requestSTSCredential,   ) where @@ -41,12 +42,15 @@ import qualified Data.Text as T import qualified Data.Time.Clock as Time import Lib.Prelude+import Network.HTTP.Client (defaultManagerSettings) import qualified Network.HTTP.Client as NClient import Network.HTTP.Conduit (Response) import qualified Network.HTTP.Conduit as NC+import Network.HTTP.Types (simpleQueryToQuery) import qualified Network.HTTP.Types as HT import Network.HTTP.Types.Header (hHost) import Network.Minio.APICommon+import Network.Minio.Credentials import Network.Minio.Data import Network.Minio.Errors import Network.Minio.Sign.V4@@ -143,6 +147,20 @@           else return pathStyle         ) +-- | requestSTSCredential requests temporary credentials using the Security Token+-- Service API. The returned credential will include a populated 'SessionToken'+-- and an 'ExpiryTime'.+requestSTSCredential :: (STSCredentialProvider p) => p -> IO (CredentialValue, ExpiryTime)+requestSTSCredential p = do+  endpoint <- maybe (throwIO $ MErrValidation MErrVSTSEndpointNotFound) return $ getSTSEndpoint p+  let endPt = NC.parseRequest_ $ toString endpoint+      settings+        | NC.secure endPt = NC.tlsManagerSettings+        | otherwise = defaultManagerSettings++  mgr <- NC.newManager settings+  liftIO $ retrieveSTSCredentials p ("", 0, False) mgr+ buildRequest :: S3ReqInfo -> Minio NC.Request buildRequest ri = do   maybe (return ()) checkBucketNameValidity $ riBucket ri@@ -173,10 +191,15 @@    timeStamp <- liftIO Time.getCurrentTime +  mgr <- asks mcConnManager+  cv <- liftIO $ getCredential (connectCreds ci') (getEndpoint ci') mgr+   let sp =         SignParams-          (connectAccessKey ci')-          (connectSecretKey ci')+          (coerce $ cvAccessKey cv)+          (coerce $ cvSecretKey cv)+          (coerce $ cvSessionToken cv)+          ServiceS3           timeStamp           (riRegion ri')           (riPresignExpirySecs ri')@@ -198,8 +221,8 @@       | isJust (riPresignExpirySecs ri') ->           -- case 0 from above.           do-            let signPairs = signV4 sp baseRequest-                qpToAdd = (fmap . fmap) Just signPairs+            let signPairs = signV4QueryParams sp baseRequest+                qpToAdd = simpleQueryToQuery signPairs                 existingQueryParams = HT.parseQuery (NC.queryString baseRequest)                 updatedQueryParams = existingQueryParams ++ qpToAdd             return $ NClient.setQueryString updatedQueryParams baseRequest@@ -229,8 +252,7 @@             return $               baseRequest                 { NC.requestHeaders =-                    NC.requestHeaders baseRequest-                      ++ mkHeaderFromPairs signHeaders,+                    NC.requestHeaders baseRequest ++ signHeaders,                   NC.requestBody = getRequestBody (riPayload ri')                 } @@ -315,7 +337,7 @@     isIPCheck = and labelAsNums && length labelAsNums == 4  -- Throws exception iff bucket name is invalid according to AWS rules.-checkBucketNameValidity :: MonadIO m => Bucket -> m ()+checkBucketNameValidity :: (MonadIO m) => Bucket -> m () checkBucketNameValidity bucket =   unless (isValidBucketName bucket) $     throwIO $@@ -325,7 +347,7 @@ isValidObjectName object =   T.length object > 0 && B.length (encodeUtf8 object) <= 1024 -checkObjectNameValidity :: MonadIO m => Object -> m ()+checkObjectNameValidity :: (MonadIO m) => Object -> m () checkObjectNameValidity object =   unless (isValidObjectName object) $     throwIO $
src/Network/Minio/AdminAPI.hs view
@@ -1,5 +1,5 @@ ----- MinIO Haskell SDK, (C) 2018 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2018-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -80,6 +80,7 @@ import qualified Network.HTTP.Types as HT import Network.HTTP.Types.Header (hHost) import Network.Minio.APICommon+import Network.Minio.Credentials import Network.Minio.Data import Network.Minio.Errors import Network.Minio.Sign.V4@@ -95,9 +96,12 @@ instance FromJSON DriveInfo where   parseJSON = withObject "DriveInfo" $ \v ->     DriveInfo-      <$> v .: "uuid"-      <*> v .: "endpoint"-      <*> v .: "state"+      <$> v+        .: "uuid"+      <*> v+        .: "endpoint"+      <*> v+        .: "state"  data StorageClass = StorageClass   { scParity :: Int,@@ -120,12 +124,16 @@     offlineDisks <- v .: "OfflineDisks"     stdClass <-       StorageClass-        <$> v .: "StandardSCData"-        <*> v .: "StandardSCParity"+        <$> v+          .: "StandardSCData"+        <*> v+          .: "StandardSCParity"     rrClass <-       StorageClass-        <$> v .: "RRSCData"-        <*> v .: "RRSCParity"+        <$> v+          .: "RRSCData"+        <*> v+          .: "RRSCParity"     sets <- v .: "Sets"     return $ ErasureInfo onlineDisks offlineDisks stdClass rrClass sets @@ -151,8 +159,10 @@ instance FromJSON ConnStats where   parseJSON = withObject "ConnStats" $ \v ->     ConnStats-      <$> v .: "transferred"-      <*> v .: "received"+      <$> v+        .: "transferred"+      <*> v+        .: "received"  data ServerProps = ServerProps   { spUptime :: NominalDiffTime,@@ -182,8 +192,10 @@ instance FromJSON StorageInfo where   parseJSON = withObject "StorageInfo" $ \v ->     StorageInfo-      <$> v .: "Used"-      <*> v .: "Backend"+      <$> v+        .: "Used"+      <*> v+        .: "Backend"  data CountNAvgTime = CountNAvgTime   { caCount :: Int64,@@ -194,8 +206,10 @@ instance FromJSON CountNAvgTime where   parseJSON = withObject "CountNAvgTime" $ \v ->     CountNAvgTime-      <$> v .: "count"-      <*> v .: "avgDuration"+      <$> v+        .: "count"+      <*> v+        .: "avgDuration"  data HttpStats = HttpStats   { hsTotalHeads :: CountNAvgTime,@@ -214,16 +228,26 @@ instance FromJSON HttpStats where   parseJSON = withObject "HttpStats" $ \v ->     HttpStats-      <$> v .: "totalHEADs"-      <*> v .: "successHEADs"-      <*> v .: "totalGETs"-      <*> v .: "successGETs"-      <*> v .: "totalPUTs"-      <*> v .: "successPUTs"-      <*> v .: "totalPOSTs"-      <*> v .: "successPOSTs"-      <*> v .: "totalDELETEs"-      <*> v .: "successDELETEs"+      <$> v+        .: "totalHEADs"+      <*> v+        .: "successHEADs"+      <*> v+        .: "totalGETs"+      <*> v+        .: "successGETs"+      <*> v+        .: "totalPUTs"+      <*> v+        .: "successPUTs"+      <*> v+        .: "totalPOSTs"+      <*> v+        .: "successPOSTs"+      <*> v+        .: "totalDELETEs"+      <*> v+        .: "successDELETEs"  data SIData = SIData   { sdStorage :: StorageInfo,@@ -236,10 +260,14 @@ instance FromJSON SIData where   parseJSON = withObject "SIData" $ \v ->     SIData-      <$> v .: "storage"-      <*> v .: "network"-      <*> v .: "http"-      <*> v .: "server"+      <$> v+        .: "storage"+      <*> v+        .: "network"+      <*> v+        .: "http"+      <*> v+        .: "server"  data ServerInfo = ServerInfo   { siError :: Text,@@ -251,9 +279,12 @@ instance FromJSON ServerInfo where   parseJSON = withObject "ServerInfo" $ \v ->     ServerInfo-      <$> v .: "error"-      <*> v .: "addr"-      <*> v .: "data"+      <$> v+        .: "error"+      <*> v+        .: "addr"+      <*> v+        .: "data"  data ServerVersion = ServerVersion   { svVersion :: Text,@@ -264,8 +295,10 @@ instance FromJSON ServerVersion where   parseJSON = withObject "ServerVersion" $ \v ->     ServerVersion-      <$> v .: "version"-      <*> v .: "commitID"+      <$> v+        .: "version"+      <*> v+        .: "commitID"  data ServiceStatus = ServiceStatus   { ssVersion :: ServerVersion,@@ -306,9 +339,12 @@ instance FromJSON HealStartResp where   parseJSON = withObject "HealStartResp" $ \v ->     HealStartResp-      <$> v .: "clientToken"-      <*> v .: "clientAddress"-      <*> v .: "startTime"+      <$> v+        .: "clientToken"+      <*> v+        .: "clientAddress"+      <*> v+        .: "startTime"  data HealOpts = HealOpts   { hoRecursive :: Bool,@@ -325,8 +361,10 @@ instance FromJSON HealOpts where   parseJSON = withObject "HealOpts" $ \v ->     HealOpts-      <$> v .: "recursive"-      <*> v .: "dryRun"+      <$> v+        .: "recursive"+      <*> v+        .: "dryRun"  data HealItemType   = HealItemMetadata@@ -353,9 +391,12 @@ instance FromJSON NodeSummary where   parseJSON = withObject "NodeSummary" $ \v ->     NodeSummary-      <$> v .: "name"-      <*> v .: "errSet"-      <*> v .: "errMsg"+      <$> v+        .: "name"+      <*> v+        .: "errSet"+      <*> v+        .: "errMsg"  data SetConfigResult = SetConfigResult   { scrStatus :: Bool,@@ -366,8 +407,10 @@ instance FromJSON SetConfigResult where   parseJSON = withObject "SetConfigResult" $ \v ->     SetConfigResult-      <$> v .: "status"-      <*> v .: "nodeResults"+      <$> v+        .: "status"+      <*> v+        .: "nodeResults"  data HealResultItem = HealResultItem   { hriResultIdx :: Int,@@ -388,16 +431,26 @@ instance FromJSON HealResultItem where   parseJSON = withObject "HealResultItem" $ \v ->     HealResultItem-      <$> v .: "resultId"-      <*> v .: "type"-      <*> v .: "bucket"-      <*> v .: "object"-      <*> v .: "detail"-      <*> v .:? "parityBlocks"-      <*> v .:? "dataBlocks"-      <*> v .: "diskCount"-      <*> v .: "setCount"-      <*> v .: "objectSize"+      <$> v+        .: "resultId"+      <*> v+        .: "type"+      <*> v+        .: "bucket"+      <*> v+        .: "object"+      <*> v+        .: "detail"+      <*> v+        .:? "parityBlocks"+      <*> v+        .:? "dataBlocks"+      <*> v+        .: "diskCount"+      <*> v+        .: "setCount"+      <*> v+        .: "objectSize"       <*> ( do               before <- v .: "before"               before .: "drives"@@ -420,12 +473,18 @@ instance FromJSON HealStatus where   parseJSON = withObject "HealStatus" $ \v ->     HealStatus-      <$> v .: "Summary"-      <*> v .: "StartTime"-      <*> v .: "Settings"-      <*> v .: "NumDisks"-      <*> v .:? "Detail"-      <*> v .: "Items"+      <$> v+        .: "Summary"+      <*> v+        .: "StartTime"+      <*> v+        .: "Settings"+      <*> v+        .: "NumDisks"+      <*> v+        .:? "Detail"+      <*> v+        .: "Items"  healPath :: Maybe Bucket -> Maybe Text -> ByteString healPath bucket prefix = do@@ -607,6 +666,9 @@    timeStamp <- liftIO getCurrentTime +  mgr <- asks mcConnManager+  cv <- liftIO $ getCredential (connectCreds ci) (getEndpoint ci) mgr+   let hostHeader = (hHost, getHostAddr ci)       newAreq =         areq@@ -619,8 +681,10 @@       signReq = toRequest ci newAreq       sp =         SignParams-          (connectAccessKey ci)-          (connectSecretKey ci)+          (coerce $ cvAccessKey cv)+          (coerce $ cvSecretKey cv)+          (coerce $ cvSessionToken cv)+          ServiceS3           timeStamp           Nothing           Nothing@@ -630,7 +694,7 @@   -- Update signReq with Authorization header containing v4 signature   return     signReq-      { NC.requestHeaders = ariHeaders newAreq ++ mkHeaderFromPairs signHeaders+      { NC.requestHeaders = ariHeaders newAreq ++ signHeaders       }   where     toRequest :: ConnectInfo -> AdminReqInfo -> NC.Request
+ src/Network/Minio/Credentials.hs view
@@ -0,0 +1,77 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.Credentials+  ( CredentialValue (..),+    credentialValueText,+    STSCredentialProvider (..),+    AccessKey (..),+    SecretKey (..),+    SessionToken (..),+    ExpiryTime (..),+    STSCredentialStore,+    initSTSCredential,+    getSTSCredential,+    Creds (..),+    getCredential,+    Endpoint,++    -- * STS Assume Role+    defaultSTSAssumeRoleOptions,+    STSAssumeRole (..),+    STSAssumeRoleOptions (..),+  )+where++import Data.Time (diffUTCTime, getCurrentTime)+import qualified Network.HTTP.Client as NC+import Network.Minio.Credentials.AssumeRole+import Network.Minio.Credentials.Types+import qualified UnliftIO.MVar as M++data STSCredentialStore = STSCredentialStore+  { cachedCredentials :: M.MVar (CredentialValue, ExpiryTime),+    refreshAction :: Endpoint -> NC.Manager -> IO (CredentialValue, ExpiryTime)+  }++initSTSCredential :: (STSCredentialProvider p) => p -> IO STSCredentialStore+initSTSCredential p = do+  let action = retrieveSTSCredentials p+  -- start with dummy credential, so that refresh happens for first request.+  now <- getCurrentTime+  mvar <- M.newMVar (CredentialValue mempty mempty mempty, coerce now)+  return $+    STSCredentialStore+      { cachedCredentials = mvar,+        refreshAction = action+      }++getSTSCredential :: STSCredentialStore -> Endpoint -> NC.Manager -> IO (CredentialValue, Bool)+getSTSCredential store ep mgr = M.modifyMVar (cachedCredentials store) $ \cc@(v, expiry) -> do+  now <- getCurrentTime+  if diffUTCTime now (coerce expiry) > 0+    then do+      res <- refreshAction store ep mgr+      return (res, (fst res, True))+    else return (cc, (v, False))++data Creds+  = CredsStatic CredentialValue+  | CredsSTS STSCredentialStore++getCredential :: Creds -> Endpoint -> NC.Manager -> IO CredentialValue+getCredential (CredsStatic v) _ _ = return v+getCredential (CredsSTS s) ep mgr = fst <$> getSTSCredential s ep mgr
+ src/Network/Minio/Credentials/AssumeRole.hs view
@@ -0,0 +1,266 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.Credentials.AssumeRole where++import qualified Data.ByteArray as BA+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text as T+import qualified Data.Time as Time+import Data.Time.Units (Second)+import Lib.Prelude (UTCTime, throwIO)+import Network.HTTP.Client (RequestBody (RequestBodyBS))+import qualified Network.HTTP.Client as NC+import Network.HTTP.Types (hContentType, methodPost, renderSimpleQuery)+import Network.HTTP.Types.Header (hHost)+import Network.Minio.Credentials.Types+import Network.Minio.Data.Crypto (hashSHA256)+import Network.Minio.Errors (MErrV (..))+import Network.Minio.Sign.V4+import Network.Minio.Utils (getHostHeader, httpLbs)+import Network.Minio.XmlCommon+import Text.XML.Cursor hiding (bool)++stsVersion :: ByteString+stsVersion = "2011-06-15"++defaultDurationSeconds :: Second+defaultDurationSeconds = 3600++-- | Assume Role API argument.+--+-- @since 1.7.0+data STSAssumeRole = STSAssumeRole+  { -- | Credentials to use in the AssumeRole STS API.+    sarCredentials :: CredentialValue,+    -- | Optional settings.+    sarOptions :: STSAssumeRoleOptions+  }++-- | Options for STS Assume Role API.+data STSAssumeRoleOptions = STSAssumeRoleOptions+  { -- | STS endpoint to which the request will be made. For MinIO, this is the+    -- same as the server endpoint. For AWS, this has to be the Security Token+    -- Service endpoint. If using with 'setSTSCredential', this option can be+    -- left as 'Nothing' and the endpoint in 'ConnectInfo' will be used.+    saroEndpoint :: Maybe Text,+    -- | Desired validity for the generated credentials.+    saroDurationSeconds :: Maybe Second,+    -- | IAM policy to apply for the generated credentials.+    saroPolicyJSON :: Maybe ByteString,+    -- | Location is usually required for AWS.+    saroLocation :: Maybe Text,+    saroRoleARN :: Maybe Text,+    saroRoleSessionName :: Maybe Text+  }++-- | Default STS Assume Role options - all options are Nothing, except for+-- duration which is set to 1 hour.+defaultSTSAssumeRoleOptions :: STSAssumeRoleOptions+defaultSTSAssumeRoleOptions =+  STSAssumeRoleOptions+    { saroEndpoint = Nothing,+      saroDurationSeconds = Just 3600,+      saroPolicyJSON = Nothing,+      saroLocation = Nothing,+      saroRoleARN = Nothing,+      saroRoleSessionName = Nothing+    }++data AssumeRoleCredentials = AssumeRoleCredentials+  { arcCredentials :: CredentialValue,+    arcExpiration :: UTCTime+  }+  deriving stock (Show, Eq)++data AssumeRoleResult = AssumeRoleResult+  { arrSourceIdentity :: Text,+    arrAssumedRoleArn :: Text,+    arrAssumedRoleId :: Text,+    arrRoleCredentials :: AssumeRoleCredentials+  }+  deriving stock (Show, Eq)++-- | parseSTSAssumeRoleResult parses an XML response of the following form:+--+-- <AssumeRoleResponse xmlns="https://sts.amazonaws.com/doc/2011-06-15/">+--   <AssumeRoleResult>+--   <SourceIdentity>Alice</SourceIdentity>+--     <AssumedRoleUser>+--       <Arn>arn:aws:sts::123456789012:assumed-role/demo/TestAR</Arn>+--       <AssumedRoleId>ARO123EXAMPLE123:TestAR</AssumedRoleId>+--     </AssumedRoleUser>+--     <Credentials>+--       <AccessKeyId>ASIAIOSFODNN7EXAMPLE</AccessKeyId>+--       <SecretAccessKey>wJalrXUtnFEMI/K7MDENG/bPxRfiCYzEXAMPLEKEY</SecretAccessKey>+--       <SessionToken>+--        AQoDYXdzEPT//////////wEXAMPLEtc764bNrC9SAPBSM22wDOk4x4HIZ8j4FZTwdQW+--        LWsKWHGBuFqwAeMicRXmxfpSPfIeoIYRqTflfKD8YUuwthAx7mSEI/qkPpKPi/kMcGd+--        QrmGdeehM4IC1NtBmUpp2wUE8phUZampKsburEDy0KPkyQDYwT7WZ0wq5VSXDvp75YU+--        9HFvlRd8Tx6q6fE8YQcHNVXAkiY9q6d+xo0rKwT38xVqr7ZD0u0iPPkUL64lIZbqBAz+--        +scqKmlzm8FDrypNC9Yjc8fPOLn9FX9KSYvKTr4rvx3iSIlTJabIQwj2ICCR/oLxBA==+--       </SessionToken>+--       <Expiration>2019-11-09T13:34:41Z</Expiration>+--     </Credentials>+--     <PackedPolicySize>6</PackedPolicySize>+--   </AssumeRoleResult>+--   <ResponseMetadata>+--     <RequestId>c6104cbe-af31-11e0-8154-cbc7ccf896c7</RequestId>+--   </ResponseMetadata>+-- </AssumeRoleResponse>+parseSTSAssumeRoleResult :: (MonadIO m) => ByteString -> Text -> m AssumeRoleResult+parseSTSAssumeRoleResult xmldata namespace = do+  r <- parseRoot $ LB.fromStrict xmldata+  let s3Elem' = s3Elem namespace+      sourceIdentity =+        T.concat $+          r+            $/ s3Elem' "AssumeRoleResult"+            &/ s3Elem' "SourceIdentity"+            &/ content+      roleArn =+        T.concat $+          r+            $/ s3Elem' "AssumeRoleResult"+            &/ s3Elem' "AssumedRoleUser"+            &/ s3Elem' "Arn"+            &/ content+      roleId =+        T.concat $+          r+            $/ s3Elem' "AssumeRoleResult"+            &/ s3Elem' "AssumedRoleUser"+            &/ s3Elem' "AssumedRoleId"+            &/ content++      convSB :: Text -> BA.ScrubbedBytes+      convSB = BA.convert . (encodeUtf8 :: Text -> ByteString)++      credsInfo = do+        cr <-+          maybe (Left $ MErrVXmlParse "No Credentials Element found") Right $+            listToMaybe $+              r $/ s3Elem' "AssumeRoleResult" &/ s3Elem' "Credentials"+        let cur = fromNode $ node cr+        return+          ( CredentialValue+              { cvAccessKey =+                  coerce $+                    T.concat $+                      cur $/ s3Elem' "AccessKeyId" &/ content,+                cvSecretKey =+                  coerce $+                    convSB $+                      T.concat $+                        cur+                          $/ s3Elem' "SecretAccessKey"+                          &/ content,+                cvSessionToken =+                  Just $+                    coerce $+                      convSB $+                        T.concat $+                          cur+                            $/ s3Elem' "SessionToken"+                            &/ content+              },+            T.concat $ cur $/ s3Elem' "Expiration" &/ content+          )+  creds <- either throwIO pure credsInfo+  expiry <- parseS3XMLTime $ snd creds+  let roleCredentials =+        AssumeRoleCredentials+          { arcCredentials = fst creds,+            arcExpiration = expiry+          }+  return+    AssumeRoleResult+      { arrSourceIdentity = sourceIdentity,+        arrAssumedRoleArn = roleArn,+        arrAssumedRoleId = roleId,+        arrRoleCredentials = roleCredentials+      }++instance STSCredentialProvider STSAssumeRole where+  getSTSEndpoint = saroEndpoint . sarOptions+  retrieveSTSCredentials sar (host', port', isSecure') mgr = do+    -- Assemble STS request+    let requiredParams =+          [ ("Action", "AssumeRole"),+            ("Version", stsVersion)+          ]+        opts = sarOptions sar++        durSecs :: Int =+          fromIntegral $+            fromMaybe defaultDurationSeconds $+              saroDurationSeconds opts+        otherParams =+          [ ("RoleArn",) . encodeUtf8 <$> saroRoleARN opts,+            ("RoleSessionName",) . encodeUtf8 <$> saroRoleSessionName opts,+            Just ("DurationSeconds", show durSecs),+            ("Policy",) <$> saroPolicyJSON opts+          ]+        parameters = requiredParams ++ catMaybes otherParams+        (host, port, isSecure) =+          case getSTSEndpoint sar of+            Just ep ->+              let endPt = NC.parseRequest_ $ toString ep+               in (NC.host endPt, NC.port endPt, NC.secure endPt)+            Nothing -> (host', port', isSecure')+        reqBody = renderSimpleQuery False parameters+        req =+          NC.defaultRequest+            { NC.host = host,+              NC.port = port,+              NC.secure = isSecure,+              NC.method = methodPost,+              NC.requestHeaders =+                [ (hHost, getHostHeader (host, port)),+                  (hContentType, "application/x-www-form-urlencoded")+                ],+              NC.requestBody = RequestBodyBS reqBody+            }++    -- Sign the STS request.+    timeStamp <- liftIO Time.getCurrentTime+    let sp =+          SignParams+            { spAccessKey = coerce $ cvAccessKey $ sarCredentials sar,+              spSecretKey = coerce $ cvSecretKey $ sarCredentials sar,+              spSessionToken = coerce $ cvSessionToken $ sarCredentials sar,+              spService = ServiceSTS,+              spTimeStamp = timeStamp,+              spRegion = saroLocation opts,+              spExpirySecs = Nothing,+              spPayloadHash = Just $ hashSHA256 reqBody+            }+        signHeaders = signV4 sp req+        signedReq =+          req+            { NC.requestHeaders = NC.requestHeaders req ++ signHeaders+            }++    -- Make the STS request+    resp <- httpLbs signedReq mgr+    result <-+      parseSTSAssumeRoleResult+        (toStrict $ NC.responseBody resp)+        "https://sts.amazonaws.com/doc/2011-06-15/"+    return+      ( arcCredentials $ arrRoleCredentials result,+        coerce $ arcExpiration $ arrRoleCredentials result+      )
+ src/Network/Minio/Credentials/Types.hs view
@@ -0,0 +1,90 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StrictData #-}++module Network.Minio.Credentials.Types where++import qualified Data.ByteArray as BA+import Lib.Prelude (UTCTime)+import qualified Network.HTTP.Client as NC++-- | Access Key type.+newtype AccessKey = AccessKey {unAccessKey :: Text}+  deriving stock (Show)+  deriving newtype (Eq, IsString, Semigroup, Monoid)++-- | Secret Key type - has a show instance that does not print the value.+newtype SecretKey = SecretKey {unSecretKey :: BA.ScrubbedBytes}+  deriving stock (Show)+  deriving newtype (Eq, IsString, Semigroup, Monoid)++-- | Session Token type - has a show instance that does not print the value.+newtype SessionToken = SessionToken {unSessionToken :: BA.ScrubbedBytes}+  deriving stock (Show)+  deriving newtype (Eq, IsString, Semigroup, Monoid)++-- | Object storage credential data type. It has support for the optional+-- [SessionToken](https://docs.aws.amazon.com/IAM/latest/UserGuide/id_credentials_temp_use-resources.html)+-- for using temporary credentials requested via STS.+--+-- The show instance for this type does not print the value of secrets for+-- security.+--+-- @since 1.7.0+data CredentialValue = CredentialValue+  { cvAccessKey :: AccessKey,+    cvSecretKey :: SecretKey,+    cvSessionToken :: Maybe SessionToken+  }+  deriving stock (Eq, Show)++scrubbedToText :: BA.ScrubbedBytes -> Text+scrubbedToText =+  let b2t :: ByteString -> Text+      b2t = decodeUtf8+      s2b :: BA.ScrubbedBytes -> ByteString+      s2b = BA.convert+   in b2t . s2b++-- | Convert a 'CredentialValue' to a text tuple. Use this to output the+-- credential to files or other programs.+credentialValueText :: CredentialValue -> (Text, Text, Maybe Text)+credentialValueText cv =+  ( coerce $ cvAccessKey cv,+    (scrubbedToText . coerce) $ cvSecretKey cv,+    scrubbedToText . coerce <$> cvSessionToken cv+  )++-- | Endpoint represented by host, port and TLS enabled flag.+type Endpoint = (ByteString, Int, Bool)++-- | Typeclass for STS credential providers.+--+-- @since 1.7.0+class STSCredentialProvider p where+  retrieveSTSCredentials ::+    p ->+    -- | STS Endpoint (host, port, isSecure)+    Endpoint ->+    NC.Manager ->+    IO (CredentialValue, ExpiryTime)+  getSTSEndpoint :: p -> Maybe Text++-- | 'ExpiryTime' represents a time at which a credential expires.+newtype ExpiryTime = ExpiryTime {unExpiryTime :: UTCTime}+  deriving stock (Show)+  deriving newtype (Eq)
src/Network/Minio/Data.hs view
@@ -1,5 +1,5 @@ ----- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2017-2023 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,6 +16,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-}  module Network.Minio.Data where@@ -34,9 +35,9 @@ import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB-import Data.CaseInsensitive (mk) import qualified Data.HashMap.Strict as H import qualified Data.Ini as Ini+import qualified Data.List as List import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Time (defaultTimeLocale, formatTime)@@ -53,6 +54,7 @@     hRange,   ) import qualified Network.HTTP.Types as HT+import Network.Minio.Credentials import Network.Minio.Data.Crypto   ( encodeToBase64,     hashMD5ToBase64,@@ -62,11 +64,12 @@   ( MErrV (MErrVInvalidEncryptionKeyLength, MErrVMissingCredentials),     MinioErr (..),   )+import Network.Minio.Utils import System.Directory (doesFileExist, getHomeDirectory) import qualified System.Environment as Env import System.FilePath.Posix (combine)-import Text.XML (Name (Name)) import qualified UnliftIO as U+import qualified UnliftIO.MVar as UM  -- | max obj size is 5TiB maxObjectSize :: Int64@@ -97,13 +100,29 @@       ("us-west-2", "s3.us-west-2.amazonaws.com"),       ("ca-central-1", "s3.ca-central-1.amazonaws.com"),       ("ap-south-1", "s3.ap-south-1.amazonaws.com"),+      ("ap-south-2", "s3.ap-south-2.amazonaws.com"),       ("ap-northeast-1", "s3.ap-northeast-1.amazonaws.com"),       ("ap-northeast-2", "s3.ap-northeast-2.amazonaws.com"),+      ("ap-northeast-3", "s3.ap-northeast-3.amazonaws.com"),       ("ap-southeast-1", "s3.ap-southeast-1.amazonaws.com"),       ("ap-southeast-2", "s3.ap-southeast-2.amazonaws.com"),+      ("ap-southeast-3", "s3.ap-southeast-3.amazonaws.com"),       ("eu-west-1", "s3.eu-west-1.amazonaws.com"),       ("eu-west-2", "s3.eu-west-2.amazonaws.com"),+      ("eu-west-3", "s3.eu-west-3.amazonaws.com"),       ("eu-central-1", "s3.eu-central-1.amazonaws.com"),+      ("eu-central-2", "s3.eu-central-2.amazonaws.com"),+      ("eu-south-1", "s3.eu-south-1.amazonaws.com"),+      ("eu-south-2", "s3.eu-south-2.amazonaws.com"),+      ("af-south-1", "s3.af-south-1.amazonaws.com"),+      ("ap-east-1", "s3.ap-east-1.amazonaws.com"),+      ("cn-north-1", "s3.cn-north-1.amazonaws.com.cn"),+      ("cn-northwest-1", "s3.cn-northwest-1.amazonaws.com.cn"),+      ("eu-north-1", "s3.eu-north-1.amazonaws.com"),+      ("me-south-1", "s3.me-south-1.amazonaws.com"),+      ("me-central-1", "s3.me-central-1.amazonaws.com"),+      ("us-gov-east-1", "s3.us-gov-east-1.amazonaws.com"),+      ("us-gov-west-1", "s3.us-gov-west-1.amazonaws.com"),       ("sa-east-1", "s3.sa-east-1.amazonaws.com")     ] @@ -115,50 +134,46 @@ data ConnectInfo = ConnectInfo   { connectHost :: Text,     connectPort :: Int,-    connectAccessKey :: Text,-    connectSecretKey :: Text,+    connectCreds :: Creds,     connectIsSecure :: Bool,     connectRegion :: Region,     connectAutoDiscoverRegion :: Bool,     connectDisableTLSCertValidation :: Bool   }-  deriving stock (Eq, Show) +getEndpoint :: ConnectInfo -> Endpoint+getEndpoint ci = (encodeUtf8 $ connectHost ci, connectPort ci, connectIsSecure ci)+ instance IsString ConnectInfo where   fromString str =     let req = NC.parseRequest_ str      in ConnectInfo           { connectHost = TE.decodeUtf8 $ NC.host req,             connectPort = NC.port req,-            connectAccessKey = "",-            connectSecretKey = "",+            connectCreds = CredsStatic $ CredentialValue mempty mempty mempty,             connectIsSecure = NC.secure req,             connectRegion = "",             connectAutoDiscoverRegion = True,             connectDisableTLSCertValidation = False           } --- | Contains access key and secret key to access object storage.-data Credentials = Credentials-  { cAccessKey :: Text,-    cSecretKey :: Text-  }-  deriving stock (Eq, Show)---- | A Provider is an action that may return Credentials. Providers--- may be chained together using 'findFirst'.-type Provider = IO (Maybe Credentials)+-- | A 'CredentialLoader' is an action that may return a 'CredentialValue'.+-- Loaders may be chained together using 'findFirst'.+--+-- @since 1.7.0+type CredentialLoader = IO (Maybe CredentialValue) --- | Combines the given list of providers, by calling each one in--- order until Credentials are found.-findFirst :: [Provider] -> Provider+-- | Combines the given list of loaders, by calling each one in+-- order until a 'CredentialValue' is returned.+findFirst :: [CredentialLoader] -> IO (Maybe CredentialValue) findFirst [] = return Nothing findFirst (f : fs) = do   c <- f   maybe (findFirst fs) (return . Just) c --- | This Provider loads `Credentials` from @~\/.aws\/credentials@-fromAWSConfigFile :: Provider+-- | This action returns a 'CredentialValue' populated from+-- @~\/.aws\/credentials@+fromAWSConfigFile :: CredentialLoader fromAWSConfigFile = do   credsE <- runExceptT $ do     homeDir <- lift getHomeDirectory@@ -174,29 +189,28 @@       ExceptT $         return $           Ini.lookupValue "default" "aws_secret_access_key" ini-    return $ Credentials akey skey+    return $ CredentialValue (coerce akey) (fromString $ T.unpack skey) Nothing   return $ either (const Nothing) Just credsE --- | This Provider loads `Credentials` from @AWS_ACCESS_KEY_ID@ and--- @AWS_SECRET_ACCESS_KEY@ environment variables.-fromAWSEnv :: Provider+-- | This action returns a 'CredentialValue` populated from @AWS_ACCESS_KEY_ID@+-- and @AWS_SECRET_ACCESS_KEY@ environment variables.+fromAWSEnv :: CredentialLoader fromAWSEnv = runMaybeT $ do   akey <- MaybeT $ Env.lookupEnv "AWS_ACCESS_KEY_ID"   skey <- MaybeT $ Env.lookupEnv "AWS_SECRET_ACCESS_KEY"-  return $ Credentials (T.pack akey) (T.pack skey)+  return $ CredentialValue (fromString akey) (fromString skey) Nothing --- | This Provider loads `Credentials` from @MINIO_ACCESS_KEY@ and--- @MINIO_SECRET_KEY@ environment variables.-fromMinioEnv :: Provider+-- | This action returns a 'CredentialValue' populated from @MINIO_ACCESS_KEY@+-- and @MINIO_SECRET_KEY@ environment variables.+fromMinioEnv :: CredentialLoader fromMinioEnv = runMaybeT $ do   akey <- MaybeT $ Env.lookupEnv "MINIO_ACCESS_KEY"   skey <- MaybeT $ Env.lookupEnv "MINIO_SECRET_KEY"-  return $ Credentials (T.pack akey) (T.pack skey)+  return $ CredentialValue (fromString akey) (fromString skey) Nothing --- | setCredsFrom retrieves access credentials from the first--- `Provider` form the given list that succeeds and sets it in the--- `ConnectInfo`.-setCredsFrom :: [Provider] -> ConnectInfo -> IO ConnectInfo+-- | setCredsFrom retrieves access credentials from the first action in the+-- given list that succeeds and sets it in the 'ConnectInfo'.+setCredsFrom :: [CredentialLoader] -> ConnectInfo -> IO ConnectInfo setCredsFrom ps ci = do   pMay <- findFirst ps   maybe@@ -204,14 +218,21 @@     (return . (`setCreds` ci))     pMay --- | setCreds sets the given `Credentials` in the `ConnectInfo`.-setCreds :: Credentials -> ConnectInfo -> ConnectInfo-setCreds (Credentials accessKey secretKey) connInfo =+-- | setCreds sets the given `CredentialValue` in the `ConnectInfo`.+setCreds :: CredentialValue -> ConnectInfo -> ConnectInfo+setCreds cv connInfo =   connInfo-    { connectAccessKey = accessKey,-      connectSecretKey = secretKey+    { connectCreds = CredsStatic cv     } +-- | 'setSTSCredential' configures `ConnectInfo` to retrieve temporary+-- credentials via the STS API on demand. It is automatically refreshed on+-- expiry.+setSTSCredential :: (STSCredentialProvider p) => p -> ConnectInfo -> IO ConnectInfo+setSTSCredential p ci = do+  store <- initSTSCredential p+  return ci {connectCreds = CredsSTS store}+ -- | Set the S3 region parameter in the `ConnectInfo` setRegion :: Region -> ConnectInfo -> ConnectInfo setRegion r connInfo =@@ -233,15 +254,7 @@ disableTLSCertValidation c = c {connectDisableTLSCertValidation = True}  getHostAddr :: ConnectInfo -> ByteString-getHostAddr ci =-  if port == 80 || port == 443-    then encodeUtf8 host-    else-      encodeUtf8 $-        T.concat [host, ":", show port]-  where-    port = connectPort ci-    host = connectHost ci+getHostAddr ci = getHostHeader (encodeUtf8 $ connectHost ci, connectPort ci)  -- | Default Google Compute Storage ConnectInfo. Works only for -- "Simple Migration" use-case with interoperability mode enabled on@@ -264,7 +277,7 @@ -- ConnectInfo. Credentials are already filled in. minioPlayCI :: ConnectInfo minioPlayCI =-  let playCreds = Credentials "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"+  let playCreds = CredentialValue "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG" Nothing    in setCreds playCreds $         setRegion           "us-east-1"@@ -291,7 +304,7 @@  -- | Validates that the given ByteString is 32 bytes long and creates -- an encryption key.-mkSSECKey :: MonadThrow m => ByteString -> m SSECKey+mkSSECKey :: (MonadThrow m) => ByteString -> m SSECKey mkSSECKey keyBytes   | B.length keyBytes /= 32 =       throwM MErrVInvalidEncryptionKeyLength@@ -308,7 +321,7 @@   -- argument is the optional KMS context that must have a   -- `A.ToJSON` instance - please refer to the AWS S3 documentation   -- for detailed information.-  SSEKMS :: A.ToJSON a => Maybe ByteString -> Maybe a -> SSE+  SSEKMS :: (A.ToJSON a) => Maybe ByteString -> Maybe a -> SSE   -- | Specifies server-side encryption with customer provided   -- key. The argument is the encryption key to be used.   SSEC :: SSECKey -> SSE@@ -366,24 +379,6 @@ defaultPutObjectOptions :: PutObjectOptions defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing --- | If the given header name has the @X-Amz-Meta-@ prefix, it is--- stripped and a Just is returned.-userMetadataHeaderNameMaybe :: Text -> Maybe Text-userMetadataHeaderNameMaybe k =-  let prefix = T.toCaseFold "X-Amz-Meta-"-      n = T.length prefix-   in if T.toCaseFold (T.take n k) == prefix-        then Just (T.drop n k)-        else Nothing--addXAmzMetaPrefix :: Text -> Text-addXAmzMetaPrefix s-  | isJust (userMetadataHeaderNameMaybe s) = s-  | otherwise = "X-Amz-Meta-" <> s--mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header]-mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix x, encodeUtf8 y))- pooToHeaders :: PutObjectOptions -> [HT.Header] pooToHeaders poo =   userMetadata@@ -423,6 +418,29 @@ -- | A type alias to represent a part-number for multipart upload type PartNumber = Int16 +-- | Select part sizes - the logic is that the minimum part-size will+-- be 64MiB.+selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]+selectPartSizes size =+  uncurry (List.zip3 [1 ..]) $+    List.unzip $+      loop 0 size+  where+    ceil :: Double -> Int64+    ceil = ceiling+    partSize =+      max+        minPartSize+        ( ceil $+            fromIntegral size+              / fromIntegral maxMultipartParts+        )+    m = partSize+    loop st sz+      | st > sz = []+      | st + m >= sz = [(st, sz - st)]+      | otherwise = (st, m) : loop (st + m) sz+ -- | A type alias to represent an upload-id for multipart upload type UploadId = Text @@ -963,13 +981,14 @@  -- | An EventMessage represents each kind of message received from the server. data EventMessage-  = ProgressEventMessage {emProgress :: Progress}-  | StatsEventMessage {emStats :: Stats}+  = ProgressEventMessage Progress+  | StatsEventMessage Stats   | RequestLevelErrorMessage-      { emErrorCode :: Text,-        emErrorMessage :: Text-      }-  | RecordPayloadEventMessage {emPayloadBytes :: ByteString}+      Text+      -- ^ Error code+      Text+      -- ^ Error message+  | RecordPayloadEventMessage ByteString   deriving stock (Show, Eq)  data MsgHeaderName@@ -1146,9 +1165,22 @@   conn <- liftIO $ connect ci   runMinioResWith conn m -s3Name :: Text -> Text -> Name-s3Name ns s = Name s (Just ns) Nothing- -- | Format as per RFC 1123. formatRFC1123 :: UTCTime -> T.Text formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"++lookupRegionCache :: Bucket -> Minio (Maybe Region)+lookupRegionCache b = do+  rMVar <- asks mcRegionMap+  rMap <- UM.readMVar rMVar+  return $ H.lookup b rMap++addToRegionCache :: Bucket -> Region -> Minio ()+addToRegionCache b region = do+  rMVar <- asks mcRegionMap+  UM.modifyMVar_ rMVar $ return . H.insert b region++deleteFromRegionCache :: Bucket -> Minio ()+deleteFromRegionCache b = do+  rMVar <- asks mcRegionMap+  UM.modifyMVar_ rMVar $ return . H.delete b
src/Network/Minio/Data/Crypto.hs view
@@ -43,26 +43,26 @@ hashSHA256 :: ByteString -> ByteString hashSHA256 = digestToBase16 . hashWith SHA256 -hashSHA256FromSource :: Monad m => C.ConduitM () ByteString m () -> m ByteString+hashSHA256FromSource :: (Monad m) => C.ConduitM () ByteString m () -> m ByteString hashSHA256FromSource src = do   digest <- C.connect src sinkSHA256Hash   return $ digestToBase16 digest   where     -- To help with type inference-    sinkSHA256Hash :: Monad m => C.ConduitM ByteString Void m (Digest SHA256)+    sinkSHA256Hash :: (Monad m) => C.ConduitM ByteString Void m (Digest SHA256)     sinkSHA256Hash = sinkHash  -- Returns MD5 hash hex encoded. hashMD5 :: ByteString -> ByteString hashMD5 = digestToBase16 . hashWith MD5 -hashMD5FromSource :: Monad m => C.ConduitM () ByteString m () -> m ByteString+hashMD5FromSource :: (Monad m) => C.ConduitM () ByteString m () -> m ByteString hashMD5FromSource src = do   digest <- C.connect src sinkMD5Hash   return $ digestToBase16 digest   where     -- To help with type inference-    sinkMD5Hash :: Monad m => C.ConduitM ByteString Void m (Digest MD5)+    sinkMD5Hash :: (Monad m) => C.ConduitM ByteString Void m (Digest MD5)     sinkMD5Hash = sinkHash  hmacSHA256 :: ByteString -> ByteString -> HMAC SHA256@@ -71,15 +71,15 @@ hmacSHA256RawBS :: ByteString -> ByteString -> ByteString hmacSHA256RawBS message key = convert $ hmacSHA256 message key -digestToBS :: ByteArrayAccess a => a -> ByteString+digestToBS :: (ByteArrayAccess a) => a -> ByteString digestToBS = convert -digestToBase16 :: ByteArrayAccess a => a -> ByteString+digestToBase16 :: (ByteArrayAccess a) => a -> ByteString digestToBase16 = convertToBase Base16  -- Returns MD5 hash base 64 encoded.-hashMD5ToBase64 :: ByteArrayAccess a => a -> ByteString+hashMD5ToBase64 :: (ByteArrayAccess a) => a -> ByteString hashMD5ToBase64 = convertToBase Base64 . hashWith MD5 -encodeToBase64 :: ByteArrayAccess a => a -> ByteString+encodeToBase64 :: (ByteArrayAccess a) => a -> ByteString encodeToBase64 = convertToBase Base64
src/Network/Minio/Data/Time.hs view
@@ -27,6 +27,7 @@  import Data.ByteString.Char8 (pack) import qualified Data.Time as Time+import Data.Time.Format.ISO8601 (iso8601Show) import Lib.Prelude  -- | Time to expire for a presigned URL. It interpreted as a number of@@ -49,4 +50,4 @@ awsParseTime = Time.parseTimeM False Time.defaultTimeLocale "%Y%m%dT%H%M%SZ"  iso8601TimeFormat :: UTCTime -> [Char]-iso8601TimeFormat = Time.formatTime Time.defaultTimeLocale (Time.iso8601DateFormat $ Just "%T%QZ")+iso8601TimeFormat = iso8601Show
src/Network/Minio/Errors.hs view
@@ -1,5 +1,5 @@ ----- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -49,6 +49,7 @@   | MErrVInvalidEncryptionKeyLength   | MErrVStreamingBodyUnexpectedEOF   | MErrVUnexpectedPayload+  | MErrVSTSEndpointNotFound   deriving stock (Show, Eq)  instance Exception MErrV
src/Network/Minio/PresignedOperations.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE CPP #-}- ----- MinIO Haskell SDK, (C) 2017 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -15,6 +13,7 @@ -- See the License for the specific language governing permissions and -- limitations under the License. --+{-# LANGUAGE CPP #-}  module Network.Minio.PresignedOperations   ( UrlExpiry,@@ -47,6 +46,7 @@ import qualified Network.HTTP.Client as NClient import qualified Network.HTTP.Types as HT import Network.Minio.API (buildRequest)+import Network.Minio.Credentials import Network.Minio.Data import Network.Minio.Data.Time import Network.Minio.Errors@@ -299,32 +299,36 @@ presignedPostPolicy p = do   ci <- asks mcConnInfo   signTime <- liftIO Time.getCurrentTime+  mgr <- asks mcConnManager+  cv <- liftIO $ getCredential (connectCreds ci) (getEndpoint ci) mgr -  let extraConditions =+  let extraConditions signParams =         [ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime),           PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256",           PPCEquals             "x-amz-credential"             ( T.intercalate                 "/"-                [ connectAccessKey ci,-                  decodeUtf8 $ mkScope signTime region+                [ coerce $ cvAccessKey cv,+                  decodeUtf8 $ credentialScope signParams                 ]             )         ]-      ppWithCreds =+      ppWithCreds signParams =         p-          { conditions = conditions p ++ extraConditions+          { conditions = conditions p ++ extraConditions signParams           }       sp =         SignParams-          (connectAccessKey ci)-          (connectSecretKey ci)+          (coerce $ cvAccessKey cv)+          (coerce $ cvSecretKey cv)+          (coerce $ cvSessionToken cv)+          ServiceS3           signTime           (Just $ connectRegion ci)           Nothing           Nothing-      signData = signV4PostPolicy (showPostPolicy ppWithCreds) sp+      signData = signV4PostPolicy (showPostPolicy $ ppWithCreds sp) sp       -- compute form-data       mkPair (PPCStartsWith k v) = Just (k, v)       mkPair (PPCEquals k v) = Just (k, v)@@ -334,12 +338,11 @@           H.fromList $             mapMaybe               mkPair-              (conditions ppWithCreds)+              (conditions $ ppWithCreds sp)       formData = formFromPolicy `H.union` signData       -- compute POST upload URL       bucket = H.lookupDefault "" "bucket" formData       scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci-      region = connectRegion ci       url =         toStrictBS $           toLazyByteString $
src/Network/Minio/S3API.hs view
@@ -1,5 +1,5 @@ ----- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2017-2023 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,6 +14,14 @@ -- limitations under the License. -- +-- |+-- Module:      Network.Minio.S3API+-- Copyright:   (c) 2017-2023 MinIO Dev Team+-- License:     Apache 2.0+-- Maintainer:  MinIO Dev Team <dev@min.io>+--+-- Lower-level API for S3 compatible object stores. Start with @Network.Minio@+-- and use this only if needed. module Network.Minio.S3API   ( Region,     getLocation,
src/Network/Minio/SelectAPI.hs view
@@ -119,7 +119,7 @@ chunkSize :: Int chunkSize = 32 * 1024 -parseBinary :: Bin.Binary a => ByteString -> IO a+parseBinary :: (Bin.Binary a) => ByteString -> IO a parseBinary b = do   case Bin.decodeOrFail $ LB.fromStrict b of     Left (_, _, msg) -> throwIO $ ESEDecodeFail msg@@ -135,7 +135,7 @@   _ -> throwIO ESEInvalidHeaderType  parseHeaders ::-  MonadUnliftIO m =>+  (MonadUnliftIO m) =>   Word32 ->   C.ConduitM ByteString a m [MessageHeader] parseHeaders 0 = return []@@ -163,7 +163,7 @@  -- readNBytes returns N bytes read from the string and throws an -- exception if N bytes are not present on the stream.-readNBytes :: MonadUnliftIO m => Int -> C.ConduitM ByteString a m ByteString+readNBytes :: (MonadUnliftIO m) => Int -> C.ConduitM ByteString a m ByteString readNBytes n = do   b <- LB.toStrict <$> (C.takeCE n .| C.sinkLazy)   if B.length b /= n@@ -171,7 +171,7 @@     else return b  crcCheck ::-  MonadUnliftIO m =>+  (MonadUnliftIO m) =>   C.ConduitM ByteString ByteString m () crcCheck = do   b <- readNBytes 12@@ -208,7 +208,7 @@         then accumulateYield n' c'         else return c' -handleMessage :: MonadUnliftIO m => C.ConduitT ByteString EventMessage m ()+handleMessage :: (MonadUnliftIO m) => C.ConduitT ByteString EventMessage m () handleMessage = do   b1 <- readNBytes 4   msgLen :: Word32 <- liftIO $ parseBinary b1@@ -254,7 +254,7 @@       passThrough $ n - B.length b  selectProtoConduit ::-  MonadUnliftIO m =>+  (MonadUnliftIO m) =>   C.ConduitT ByteString EventMessage m () selectProtoConduit = crcCheck .| handleMessage @@ -281,7 +281,7 @@   return $ NC.responseBody resp .| selectProtoConduit  -- | A helper conduit that returns only the record payload bytes.-getPayloadBytes :: MonadIO m => C.ConduitT EventMessage ByteString m ()+getPayloadBytes :: (MonadIO m) => C.ConduitT EventMessage ByteString m () getPayloadBytes = do   evM <- C.await   case evM of
src/Network/Minio/Sign/V4.hs view
@@ -1,5 +1,5 @@ ----- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -15,9 +15,19 @@ -- {-# LANGUAGE BangPatterns #-} -module Network.Minio.Sign.V4 where+module Network.Minio.Sign.V4+  ( SignParams (..),+    signV4QueryParams,+    signV4,+    signV4PostPolicy,+    signV4Stream,+    Service (..),+    credentialScope,+  )+where  import qualified Conduit as C+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as B8@@ -26,11 +36,14 @@ import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set+import Data.List (partition)+import qualified Data.List.NonEmpty as NE import qualified Data.Time as Time import Lib.Prelude import qualified Network.HTTP.Conduit as NC-import Network.HTTP.Types (Header, parseQuery)+import Network.HTTP.Types (Header, SimpleQuery, hContentEncoding, parseQuery) import qualified Network.HTTP.Types as H+import Network.HTTP.Types.Header (RequestHeaders) import Network.Minio.Data.ByteString import Network.Minio.Data.Crypto import Network.Minio.Data.Time@@ -49,20 +62,18 @@         H.hUserAgent       ] -data SignV4Data = SignV4Data-  { sv4SignTime :: UTCTime,-    sv4Scope :: ByteString,-    sv4CanonicalRequest :: ByteString,-    sv4HeadersToSign :: [(ByteString, ByteString)],-    sv4Output :: [(ByteString, ByteString)],-    sv4StringToSign :: ByteString,-    sv4SigningKey :: ByteString-  }-  deriving stock (Show)+data Service = ServiceS3 | ServiceSTS+  deriving stock (Eq, Show) +toByteString :: Service -> ByteString+toByteString ServiceS3 = "s3"+toByteString ServiceSTS = "sts"+ data SignParams = SignParams   { spAccessKey :: Text,-    spSecretKey :: Text,+    spSecretKey :: BA.ScrubbedBytes,+    spSessionToken :: Maybe BA.ScrubbedBytes,+    spService :: Service,     spTimeStamp :: UTCTime,     spRegion :: Maybe Text,     spExpirySecs :: Maybe UrlExpiry,@@ -70,23 +81,6 @@   }   deriving stock (Show) -debugPrintSignV4Data :: SignV4Data -> IO ()-debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do-  B8.putStrLn "SignV4Data:"-  B8.putStr "Timestamp: " >> print t-  B8.putStr "Scope: " >> B8.putStrLn s-  B8.putStrLn "Canonical Request:"-  B8.putStrLn cr-  B8.putStr "Headers to Sign: " >> print h2s-  B8.putStr "Output: " >> print o-  B8.putStr "StringToSign: " >> B8.putStrLn sts-  B8.putStr "SigningKey: " >> printBytes sk-  B8.putStrLn "END of SignV4Data ========="-  where-    printBytes b = do-      mapM_ (\x -> B.putStr $ B.singleton x <> " ") $ B.unpack b-      B8.putStrLn ""- mkAuthHeader :: Text -> ByteString -> ByteString -> ByteString -> H.Header mkAuthHeader accessKey scope signedHeaderKeys sign =   let authValue =@@ -102,6 +96,12 @@           ]    in (H.hAuthorization, authValue) +data IsStreaming = IsStreamingLength Int64 | NotStreaming+  deriving stock (Eq, Show)++amzSecurityToken :: ByteString+amzSecurityToken = "X-Amz-Security-Token"+ -- | 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@@ -114,36 +114,23 @@ -- 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 region = fromMaybe "" $ spRegion sp-      ts = spTimeStamp sp-      scope = mkScope ts region-      accessKey = encodeUtf8 $ spAccessKey sp-      secretKey = encodeUtf8 $ spSecretKey sp+signV4QueryParams :: SignParams -> NC.Request -> SimpleQuery+signV4QueryParams !sp !req =+  let scope = credentialScope sp       expiry = spExpirySecs sp-      sha256Hdr =-        ( "x-amz-content-sha256",-          fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp-        )-      -- headers to be added to the request-      datePair = ("X-Amz-Date", awsTimeFormatBS ts)-      computedHeaders =-        NC.requestHeaders req-          ++ if isJust expiry-            then []-            else map (first mk) [datePair, sha256Hdr]-      headersToSign = getHeadersToSign computedHeaders++      headersToSign = getHeadersToSign $ NC.requestHeaders req       signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign       -- query-parameters to be added before signing for presigned URLs       -- (i.e. when `isJust expiry`)       authQP =         [ ("X-Amz-Algorithm", "AWS4-HMAC-SHA256"),-          ("X-Amz-Credential", B.concat [accessKey, "/", scope]),-          datePair,+          ("X-Amz-Credential", B.concat [encodeUtf8 $ spAccessKey sp, "/", scope]),+          ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp),           ("X-Amz-Expires", maybe "" showBS expiry),           ("X-Amz-SignedHeaders", signedHeaderKeys)         ]+          ++ maybeToList ((amzSecurityToken,) . BA.convert <$> spSessionToken sp)       finalQP =         parseQuery (NC.queryString req)           ++ if isJust expiry@@ -156,40 +143,130 @@           sp           (NC.setQueryString finalQP req)           headersToSign+       -- 2. compute string to sign-      stringToSign = mkStringToSign ts scope canonicalRequest+      stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest       -- 3.1 compute signing key-      signingKey = mkSigningKey ts region secretKey+      signingKey = getSigningKey sp       -- 3.2 compute signature       signature = computeSignature stringToSign signingKey+   in ("X-Amz-Signature", signature) : authQP++-- | 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 Authorization header, which+-- includes the signature.+--+-- The output is the list of headers to be added to authenticate the request.+signV4 :: SignParams -> NC.Request -> [Header]+signV4 !sp !req =+  let scope = credentialScope sp++      -- extra headers to be added for signing purposes.+      extraHeaders =+        ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp)+          : ( -- payload hash is only used for S3 (not STS)+              [ ( "x-amz-content-sha256",+                  fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp+                )+                | spService sp == ServiceS3+              ]+            )+          ++ maybeToList ((mk amzSecurityToken,) . BA.convert <$> spSessionToken sp)++      -- 1. compute canonical request+      reqHeaders = NC.requestHeaders req ++ extraHeaders+      (canonicalRequest, signedHeaderKeys) =+        getCanonicalRequestAndSignedHeaders+          NotStreaming+          sp+          req+          reqHeaders++      -- 2. compute string to sign+      stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest+      -- 3.1 compute signing key+      signingKey = getSigningKey sp+      -- 3.2 compute signature+      signature = computeSignature stringToSign signingKey       -- 4. compute auth header       authHeader = mkAuthHeader (spAccessKey sp) scope signedHeaderKeys signature-      -- finally compute output pairs-      output =-        if isJust expiry-          then ("X-Amz-Signature", signature) : authQP-          else-            [ first CI.foldedCase authHeader,-              datePair,-              sha256Hdr-            ]-   in output+   in authHeader : extraHeaders -mkScope :: UTCTime -> Text -> ByteString-mkScope ts region =-  B.intercalate-    "/"-    [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts,-      encodeUtf8 region,-      "s3",-      "aws4_request"-    ]+credentialScope :: SignParams -> ByteString+credentialScope sp =+  let region = fromMaybe "" $ spRegion sp+   in B.intercalate+        "/"+        [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" $ spTimeStamp sp,+          encodeUtf8 region,+          toByteString $ spService sp,+          "aws4_request"+        ] +-- Folds header name, trims whitespace in header values, skips ignored headers+-- and sorts headers. getHeadersToSign :: [Header] -> [(ByteString, ByteString)] getHeadersToSign !h =   filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $     map (bimap CI.foldedCase stripBS) h +-- | Given the list of headers in the request, computes the canonical headers+-- and the signed headers strings.+getCanonicalHeaders :: NonEmpty Header -> (ByteString, ByteString)+getCanonicalHeaders h =+  let -- Folds header name, trims spaces in header values, skips ignored+      -- headers and sorts headers by name (we must not re-order multi-valued+      -- headers).+      headersToSign =+        NE.toList $+          NE.sortBy (\a b -> compare (fst a) (fst b)) $+            NE.fromList $+              NE.filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $+                NE.map (bimap CI.foldedCase stripBS) h++      canonicalHeaders = mconcat $ map (\(a, b) -> a <> ":" <> b <> "\n") headersToSign+      signedHeaderKeys = B.intercalate ";" $ map fst headersToSign+   in (canonicalHeaders, signedHeaderKeys)++getCanonicalRequestAndSignedHeaders ::+  IsStreaming ->+  SignParams ->+  NC.Request ->+  [Header] ->+  (ByteString, ByteString)+getCanonicalRequestAndSignedHeaders isStreaming sp req requestHeaders =+  let httpMethod = NC.method req++      canonicalUri = uriEncode False $ NC.path req++      canonicalQueryString =+        B.intercalate "&" $+          map (\(x, y) -> B.concat [x, "=", y]) $+            sort $+              map+                ( bimap (uriEncode True) (maybe "" (uriEncode True))+                )+                (parseQuery $ NC.queryString req)++      (canonicalHeaders, signedHeaderKeys) = getCanonicalHeaders $ NE.fromList requestHeaders+      payloadHashStr =+        case isStreaming of+          IsStreamingLength _ -> "STREAMING-AWS4-HMAC-SHA256-PAYLOAD"+          NotStreaming -> fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp++      canonicalRequest =+        B.intercalate+          "\n"+          [ httpMethod,+            canonicalUri,+            canonicalQueryString,+            canonicalHeaders,+            signedHeaderKeys,+            payloadHashStr+          ]+   in (canonicalRequest, signedHeaderKeys)+ mkCanonicalRequest ::   Bool ->   SignParams ->@@ -197,10 +274,12 @@   [(ByteString, ByteString)] ->   ByteString mkCanonicalRequest !isStreaming !sp !req !headersForSign =-  let canonicalQueryString =+  let httpMethod = NC.method req+      canonicalUri = uriEncode False $ NC.path req+      canonicalQueryString =         B.intercalate "&" $           map (\(x, y) -> B.concat [x, "=", y]) $-            sort $+            sortBy (\a b -> compare (fst a) (fst b)) $               map                 ( bimap (uriEncode True) (maybe "" (uriEncode True))                 )@@ -216,8 +295,8 @@           else fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp    in B.intercalate         "\n"-        [ NC.method req,-          uriEncode False $ NC.path req,+        [ httpMethod,+          canonicalUri,           canonicalQueryString,           canonicalHeaders,           signedHeaders,@@ -234,13 +313,13 @@       hashSHA256 canonicalRequest     ] -mkSigningKey :: UTCTime -> Text -> ByteString -> ByteString-mkSigningKey ts region !secretKey =+getSigningKey :: SignParams -> ByteString+getSigningKey sp =   hmacSHA256RawBS "aws4_request"-    . hmacSHA256RawBS "s3"-    . hmacSHA256RawBS (encodeUtf8 region)-    . hmacSHA256RawBS (awsDateFormatBS ts)-    $ B.concat ["AWS4", secretKey]+    . hmacSHA256RawBS (toByteString $ spService sp)+    . hmacSHA256RawBS (encodeUtf8 $ fromMaybe "" $ spRegion sp)+    . hmacSHA256RawBS (awsDateFormatBS $ spTimeStamp sp)+    $ B.concat ["AWS4", BA.convert $ spSecretKey sp]  computeSignature :: ByteString -> ByteString -> ByteString computeSignature !toSign !key = digestToBase16 $ hmacSHA256 toSign key@@ -254,20 +333,20 @@   Map.HashMap Text ByteString signV4PostPolicy !postPolicyJSON !sp =   let stringToSign = Base64.encode postPolicyJSON-      region = fromMaybe "" $ spRegion sp-      signingKey = mkSigningKey (spTimeStamp sp) region $ encodeUtf8 $ spSecretKey sp+      signingKey = getSigningKey sp       signature = computeSignature stringToSign signingKey-   in Map.fromList+   in Map.fromList $         [ ("x-amz-signature", signature),           ("policy", stringToSign)         ]+          ++ maybeToList ((decodeUtf8 amzSecurityToken,) . BA.convert <$> spSessionToken sp)  chunkSizeConstant :: Int chunkSizeConstant = 64 * 1024  -- base16Len computes the number of bytes required to represent @n (> 0)@ in -- hexadecimal.-base16Len :: Integral a => a -> Int+base16Len :: (Integral a) => a -> Int base16Len n   | n == 0 = 0   | otherwise = 1 + base16Len (n `div` 16)@@ -284,60 +363,60 @@       finalChunkSize = 1 + 17 + 64 + 2 + 2    in numChunks * fullChunkSize + lastChunkSize + finalChunkSize +-- For streaming S3, we need to update the content-encoding header.+addContentEncoding :: [Header] -> [Header]+addContentEncoding hs =+  -- assume there is at most one content-encoding header.+  let (ceHdrs, others) = partition ((== hContentEncoding) . fst) hs+   in maybe+        (hContentEncoding, "aws-chunked")+        (\(k, v) -> (k, v <> ",aws-chunked"))+        (listToMaybe ceHdrs)+        : others+ 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 = find (\(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++      -- compute the updated list of headers to be added for signing purposes.       signedContentLength = signedStreamLength payloadLength-      streamingHeaders :: [Header]-      streamingHeaders =-        [ ("x-amz-decoded-content-length", showBS payloadLength),+      extraHeaders =+        [ ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp),+          ("x-amz-decoded-content-length", showBS payloadLength),           ("content-length", showBS 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)+          ++ maybeToList ((mk amzSecurityToken,) . BA.convert <$> spSessionToken sp)+      requestHeaders =+        addContentEncoding $+          foldr setHeader (NC.requestHeaders req) extraHeaders+       -- 1. Compute Seed Signature       -- 1.1 Canonical Request-      canonicalReq =-        mkCanonicalRequest-          True+      (canonicalReq, signedHeaderKeys) =+        getCanonicalRequestAndSignedHeaders+          (IsStreamingLength payloadLength)           sp-          (NC.setQueryString finalQP req)-          headersToSign-      region = fromMaybe "" $ spRegion sp-      scope = mkScope ts region+          req+          requestHeaders++      scope = credentialScope sp       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 $ encodeUtf8 secretKey+      signingKey = getSigningKey sp       -- 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)+      finalReqHeaders = authHeader : requestHeaders       -- headersToAdd = authHeader : datePair : streamingHeaders        toHexStr n = B8.pack $ printf "%x" n@@ -407,3 +486,9 @@               NC.requestBodySource signedContentLength $                 src C..| signerConduit numParts lastPSize seedSignature           }++-- "setHeader r hdr" adds the hdr to r, replacing it in r if it already exists.+setHeader :: Header -> RequestHeaders -> RequestHeaders+setHeader hdr r =+  let r' = filter (\(name, _) -> name /= fst hdr) r+   in hdr : r'
src/Network/Minio/Utils.hs view
@@ -1,5 +1,5 @@ ----- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -24,7 +24,6 @@ import Data.CaseInsensitive (mk, original) import qualified Data.Conduit.Binary as CB import qualified Data.HashMap.Strict as H-import qualified Data.List as List import qualified Data.Text as T import Data.Text.Read (decimal) import Data.Time@@ -37,14 +36,12 @@ import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Types.Header as Hdr-import Network.Minio.Data import Network.Minio.Data.ByteString import Network.Minio.JsonParser (parseErrResponseJSON)-import Network.Minio.XmlParser (parseErrResponse)+import Network.Minio.XmlCommon (parseErrResponse) import qualified System.IO as IO import qualified UnliftIO as U import qualified UnliftIO.Async as A-import qualified UnliftIO.MVar as UM  allocateReadFile ::   (MonadUnliftIO m, R.MonadResource m) =>@@ -115,6 +112,16 @@ getMetadata =   map (\(x, y) -> (decodeUtf8Lenient $ original x, decodeUtf8Lenient $ stripBS y)) +-- | If the given header name has the @X-Amz-Meta-@ prefix, it is+-- stripped and a Just is returned.+userMetadataHeaderNameMaybe :: Text -> Maybe Text+userMetadataHeaderNameMaybe k =+  let prefix = T.toCaseFold "X-Amz-Meta-"+      n = T.length prefix+   in if T.toCaseFold (T.take n k) == prefix+        then Just (T.drop n k)+        else Nothing+ toMaybeMetadataHeader :: (Text, Text) -> Maybe (Text, Text) toMaybeMetadataHeader (k, v) =   (,v) <$> userMetadataHeaderNameMaybe k@@ -128,6 +135,14 @@           . fst       ) +addXAmzMetaPrefix :: Text -> Text+addXAmzMetaPrefix s+  | isJust (userMetadataHeaderNameMaybe s) = s+  | otherwise = "X-Amz-Meta-" <> s++mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header]+mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix x, encodeUtf8 y))+ -- | This function collects all headers starting with `x-amz-meta-` -- and strips off this prefix, and returns a map. getUserMetadataMap :: [(Text, Text)] -> H.HashMap Text Text@@ -135,6 +150,12 @@   H.fromList     . mapMaybe toMaybeMetadataHeader +getHostHeader :: (ByteString, Int) -> ByteString+getHostHeader (host_, port_) =+  if port_ == 80 || port_ == 443+    then host_+    else host_ <> ":" <> show port_+ getLastModifiedHeader :: [HT.Header] -> Maybe UTCTime getLastModifiedHeader hs = do   modTimebs <- decodeUtf8Lenient <$> lookupHeader Hdr.hLastModified hs@@ -154,7 +175,7 @@    in (s >= 200 && s < 300)  httpLbs ::-  MonadIO m =>+  (MonadIO m) =>   NC.Request ->   NC.Manager ->   m (NC.Response LByteString)@@ -218,7 +239,7 @@ -- Similar to mapConcurrently but limits the number of threads that -- can run using a quantity semaphore. limitedMapConcurrently ::-  MonadUnliftIO m =>+  (MonadUnliftIO m) =>   Int ->   (t -> m a) ->   [t] ->@@ -262,42 +283,3 @@       | 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.-selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]-selectPartSizes size =-  uncurry (List.zip3 [1 ..]) $-    List.unzip $-      loop 0 size-  where-    ceil :: Double -> Int64-    ceil = ceiling-    partSize =-      max-        minPartSize-        ( ceil $-            fromIntegral size-              / fromIntegral maxMultipartParts-        )-    m = partSize-    loop st sz-      | st > sz = []-      | st + m >= sz = [(st, sz - st)]-      | otherwise = (st, m) : loop (st + m) sz--lookupRegionCache :: Bucket -> Minio (Maybe Region)-lookupRegionCache b = do-  rMVar <- asks mcRegionMap-  rMap <- UM.readMVar rMVar-  return $ H.lookup b rMap--addToRegionCache :: Bucket -> Region -> Minio ()-addToRegionCache b region = do-  rMVar <- asks mcRegionMap-  UM.modifyMVar_ rMVar $ return . H.insert b region--deleteFromRegionCache :: Bucket -> Minio ()-deleteFromRegionCache b = do-  rMVar <- asks mcRegionMap-  UM.modifyMVar_ rMVar $ return . H.delete b
+ src/Network/Minio/XmlCommon.hs view
@@ -0,0 +1,65 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.XmlCommon where++import qualified Data.Text as T+import Data.Text.Read (decimal)+import Data.Time (UTCTime)+import Data.Time.Format.ISO8601 (iso8601ParseM)+import Lib.Prelude (throwIO)+import Network.Minio.Errors+import Text.XML (Name (Name), def, parseLBS)+import Text.XML.Cursor (Axis, Cursor, content, element, fromDocument, laxElement, ($/), (&/))++s3Name :: Text -> Text -> Name+s3Name ns s = Name s (Just ns) Nothing++uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e+uncurry4 f (a, b, c, d) = f a b c d++uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g+uncurry6 f (a, b, c, d, e, g) = f a b c d e g++-- | Parse time strings from XML+parseS3XMLTime :: (MonadIO m) => Text -> m UTCTime+parseS3XMLTime t =+  maybe (throwIO $ MErrVXmlParse $ "timestamp parse failure: " <> t) return $+    iso8601ParseM $+      toString t++parseDecimal :: (MonadIO m, Integral a) => Text -> m a+parseDecimal numStr =+  either (throwIO . MErrVXmlParse . show) return $+    fst <$> decimal numStr++parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a]+parseDecimals numStr = forM numStr parseDecimal++s3Elem :: Text -> Text -> Axis+s3Elem ns = element . s3Name ns++parseRoot :: (MonadIO m) => LByteString -> m Cursor+parseRoot =+  either (throwIO . MErrVXmlParse . show) (return . fromDocument)+    . parseLBS def++parseErrResponse :: (MonadIO m) => LByteString -> m ServiceErr+parseErrResponse xmldata = do+  r <- parseRoot xmldata+  let code = T.concat $ r $/ laxElement "Code" &/ content+      message = T.concat $ r $/ laxElement "Message" &/ content+  return $ toServiceErr code message
src/Network/Minio/XmlGenerator.hs view
@@ -1,5 +1,5 @@ ----- MinIO Haskell SDK, (C) 2017 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2017-2023 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,6 +25,7 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import Network.Minio.Data+import Network.Minio.XmlCommon import Text.XML  -- | Create a bucketConfig request body XML
src/Network/Minio/XmlParser.hs view
@@ -1,5 +1,5 @@ ----- MinIO Haskell SDK, (C) 2017 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -34,48 +34,11 @@ import qualified Data.HashMap.Strict as H import Data.List (zip4, zip6) import qualified Data.Text as T-import Data.Text.Read (decimal) import Data.Time-import Lib.Prelude import Network.Minio.Data-import Network.Minio.Errors-import Text.XML+import Network.Minio.XmlCommon import Text.XML.Cursor hiding (bool) --- | Represent the time format string returned by S3 API calls.-s3TimeFormat :: [Char]-s3TimeFormat = iso8601DateFormat $ Just "%T%QZ"---- | Helper functions.-uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e-uncurry4 f (a, b, c, d) = f a b c d--uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g-uncurry6 f (a, b, c, d, e, g) = f a b c d e g---- | Parse time strings from XML-parseS3XMLTime :: MonadIO m => Text -> m UTCTime-parseS3XMLTime t =-  maybe (throwIO $ MErrVXmlParse $ "timestamp parse failure: " <> t) return $-    parseTimeM True defaultTimeLocale s3TimeFormat $-      T.unpack t--parseDecimal :: (MonadIO m, Integral a) => Text -> m a-parseDecimal numStr =-  either (throwIO . MErrVXmlParse . show) return $-    fst <$> decimal numStr--parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a]-parseDecimals numStr = forM numStr parseDecimal--s3Elem :: Text -> Text -> Axis-s3Elem ns = element . s3Name ns--parseRoot :: (MonadIO m) => LByteString -> m Cursor-parseRoot =-  either (throwIO . MErrVXmlParse . show) (return . fromDocument)-    . parseLBS def- -- | Parse the response XML of a list buckets call. parseListBuckets :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m [BucketInfo] parseListBuckets xmldata = do@@ -220,13 +183,6 @@    return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos -parseErrResponse :: (MonadIO m) => LByteString -> m ServiceErr-parseErrResponse xmldata = do-  r <- parseRoot xmldata-  let code = T.concat $ r $/ element "Code" &/ content-      message = T.concat $ r $/ element "Message" &/ content-  return $ toServiceErr code message- parseNotification :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m Notification parseNotification xmldata = do   r <- parseRoot xmldata@@ -262,7 +218,7 @@           events           (Filter $ FilterKey $ FilterRules rules) -parseSelectProgress :: MonadIO m => ByteString -> m Progress+parseSelectProgress :: (MonadIO m) => ByteString -> m Progress parseSelectProgress xmldata = do   r <- parseRoot $ LB.fromStrict xmldata   let bScanned = T.concat $ r $/ element "BytesScanned" &/ content
test/LiveServer.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE OverloadedStrings #-}- ----- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -32,6 +30,7 @@ import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT import Network.Minio+import Network.Minio.Credentials (Creds (CredsStatic)) import Network.Minio.Data import Network.Minio.Data.Crypto import Network.Minio.S3API@@ -51,7 +50,7 @@ tests = testGroup "Tests" [liveServerUnitTests]  -- conduit that generates random binary stream of given length-randomDataSrc :: MonadIO m => Int64 -> C.ConduitM () ByteString m ()+randomDataSrc :: (MonadIO m) => Int64 -> C.ConduitM () ByteString m () randomDataSrc = genBS   where     concatIt bs n =@@ -69,7 +68,7 @@           yield $ concatIt byteArr64 oneMiB           genBS (s - oneMiB) -mkRandFile :: R.MonadResource m => Int64 -> m FilePath+mkRandFile :: (R.MonadResource m) => Int64 -> m FilePath mkRandFile size = do   dir <- liftIO getTemporaryDirectory   C.runConduit $ randomDataSrc size C..| CB.sinkTempFile dir "miniohstest.random"@@ -77,15 +76,35 @@ funTestBucketPrefix :: Text funTestBucketPrefix = "miniohstest-" -loadTestServer :: IO ConnectInfo-loadTestServer = do+loadTestServerConnInfo :: IO ConnectInfo+loadTestServerConnInfo = do   val <- Env.lookupEnv "MINIO_LOCAL"   isSecure <- Env.lookupEnv "MINIO_SECURE"   return $ case (val, isSecure) of-    (Just _, Just _) -> setCreds (Credentials "minio" "minio123") "https://localhost:9000"-    (Just _, Nothing) -> setCreds (Credentials "minio" "minio123") "http://localhost:9000"+    (Just _, Just _) -> setCreds (CredentialValue "minio" "minio123" mempty) "https://localhost:9000"+    (Just _, Nothing) -> setCreds (CredentialValue "minio" "minio123" mempty) "http://localhost:9000"     (Nothing, _) -> minioPlayCI +loadTestServerConnInfoSTS :: IO ConnectInfo+loadTestServerConnInfoSTS = do+  val <- Env.lookupEnv "MINIO_LOCAL"+  isSecure <- Env.lookupEnv "MINIO_SECURE"+  let cv = CredentialValue "minio" "minio123" mempty+      assumeRole =+        STSAssumeRole+          { sarCredentials = cv,+            sarOptions = defaultSTSAssumeRoleOptions+          }+  case (val, isSecure) of+    (Just _, Just _) -> setSTSCredential assumeRole "https://localhost:9000"+    (Just _, Nothing) -> setSTSCredential assumeRole "http://localhost:9000"+    (Nothing, _) -> do+      cv' <- case connectCreds minioPlayCI of+        CredsStatic c -> return c+        _ -> error "unexpected play creds"+      let assumeRole' = assumeRole {sarCredentials = cv'}+      setSTSCredential assumeRole' minioPlayCI+ funTestWithBucket ::   TestName ->   (([Char] -> Minio ()) -> Bucket -> Minio ()) ->@@ -95,7 +114,7 @@   bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z'))   let b = T.concat [funTestBucketPrefix, T.pack bktSuffix]       liftStep = liftIO . step-  connInfo <- loadTestServer+  connInfo <- loadTestServerConnInfo   ret <- runMinio connInfo $ do     liftStep $ "Creating bucket for test - " ++ t     foundBucket <- bucketExists b@@ -105,6 +124,17 @@     deleteBucket b   isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret) +  connInfoSTS <- loadTestServerConnInfoSTS+  let t' = t ++ " (with AssumeRole Credentials)"+  ret' <- runMinio connInfoSTS $ do+    liftStep $ "Creating bucket for test - " ++ t'+    foundBucket <- bucketExists b+    liftIO $ foundBucket @?= False+    makeBucket b Nothing+    minioTest liftStep b+    deleteBucket b+  isRight ret' @? ("Functional test " ++ t' ++ " failed => " ++ show ret')+ liveServerUnitTests :: TestTree liveServerUnitTests =   testGroup@@ -125,7 +155,8 @@       presignedUrlFunTest,       presignedPostPolicyFunTest,       bucketPolicyFunTest,-      getNPutSSECTest+      getNPutSSECTest,+      assumeRoleRequestTest     ]  basicTests :: TestTree@@ -279,7 +310,8 @@     fGetObject bucket object destFile defaultGetObjectOptions     gotSize <- withNewHandle destFile getFileSize     liftIO $-      gotSize == Right (Just mb15)+      gotSize+        == Right (Just mb15)         @? "Wrong file size of put file after getting"      step "Cleanup actions"@@ -303,7 +335,8 @@     fGetObject bucket obj destFile defaultGetObjectOptions     gotSize <- withNewHandle destFile getFileSize     liftIO $-      gotSize == Right (Just mb1)+      gotSize+        == Right (Just mb1)         @? "Wrong file size of put file after getting"      step "Cleanup actions"@@ -327,7 +360,8 @@     fGetObject bucket obj destFile defaultGetObjectOptions     gotSize <- withNewHandle destFile getFileSize     liftIO $-      gotSize == Right (Just mb70)+      gotSize+        == Right (Just mb70)         @? "Wrong file size of put file after getting"      step "Cleanup actions"@@ -569,6 +603,7 @@         []         [] +    print putUrl     let size1 = 1000 :: Int64     inputFile <- mkRandFile size1 @@ -1176,9 +1211,37 @@          gotSize <- withNewHandle dstFile getFileSize         liftIO $-          gotSize == Right (Just mb1)+          gotSize+            == Right (Just mb1)             @? "Wrong file size of object when getting"          step "Cleanup"         deleteObject bucket obj       else step "Skipping encryption test as server is not using TLS"++assumeRoleRequestTest :: TestTree+assumeRoleRequestTest = testCaseSteps "Assume Role STS API" $ \step -> do+  step "Load credentials"+  val <- Env.lookupEnv "MINIO_LOCAL"+  isSecure <- Env.lookupEnv "MINIO_SECURE"+  let localMinioCred = Just $ CredentialValue "minio" "minio123" mempty+      playCreds =+        case connectCreds minioPlayCI of+          CredsStatic c -> Just c+          _ -> Nothing+      (cvMay, loc) =+        case (val, isSecure) of+          (Just _, Just _) -> (localMinioCred, "https://localhost:9000")+          (Just _, Nothing) -> (localMinioCred, "http://localhost:9000")+          (Nothing, _) -> (playCreds, "https://play.min.io:9000")+  cv <- maybe (assertFailure "bad creds") return cvMay+  let assumeRole =+        STSAssumeRole cv $+          defaultSTSAssumeRoleOptions+            { saroLocation = Just "us-east-1",+              saroEndpoint = Just loc+            }+  step "AssumeRole request"+  res <- requestSTSCredential assumeRole+  let v = credentialValueText $ fst res+  print (v, snd res)
test/Network/Minio/XmlGenerator/Test.hs view
@@ -20,6 +20,7 @@   ) where +import qualified Data.ByteString.Lazy as LBS import Lib.Prelude import Network.Minio.Data import Network.Minio.TestHelpers@@ -28,6 +29,7 @@ import Test.Tasty import Test.Tasty.HUnit import Text.RawString.QQ (r)+import Text.XML (def, parseLBS)  xmlGeneratorTests :: TestTree xmlGeneratorTests =@@ -120,7 +122,13 @@ testMkSelectRequest :: Assertion testMkSelectRequest = mapM_ assertFn cases   where-    assertFn (a, b) = assertEqual "selectRequest XML should match: " b $ mkSelectRequest a+    assertFn (a, b) =+      let generatedReqDoc = parseLBS def $ LBS.fromStrict $ mkSelectRequest a+          expectedReqDoc = parseLBS def $ LBS.fromStrict b+       in case (generatedReqDoc, expectedReqDoc) of+            (Right genDoc, Right expDoc) -> assertEqual "selectRequest XML should match: " expDoc genDoc+            (Left err, _) -> assertFailure $ "Generated selectRequest failed to parse as XML" ++ show err+            (_, Left err) -> assertFailure $ "Expected selectRequest failed to parse as XML" ++ show err     cases =       [ ( SelectRequest             "Select * from S3Object"@@ -143,8 +151,8 @@                   <> quoteEscapeCharacter "\""             )             (Just False),-          [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>GZIP</CompressionType><CSV><FieldDelimiter>,</FieldDelimiter><FileHeaderInfo>IGNORE</FileHeaderInfo><QuoteCharacter>&#34;</QuoteCharacter><QuoteEscapeCharacter>&#34;</QuoteEscapeCharacter><RecordDelimiter>-</RecordDelimiter></CSV></InputSerialization><OutputSerialization><CSV><FieldDelimiter>,</FieldDelimiter><QuoteCharacter>&#34;</QuoteCharacter><QuoteEscapeCharacter>&#34;</QuoteEscapeCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter>+          [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>GZIP</CompressionType><CSV><FieldDelimiter>,</FieldDelimiter><FileHeaderInfo>IGNORE</FileHeaderInfo><QuoteCharacter>"</QuoteCharacter><QuoteEscapeCharacter>"</QuoteEscapeCharacter><RecordDelimiter>+</RecordDelimiter></CSV></InputSerialization><OutputSerialization><CSV><FieldDelimiter>,</FieldDelimiter><QuoteCharacter>"</QuoteCharacter><QuoteEscapeCharacter>"</QuoteEscapeCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter> </RecordDelimiter></CSV></OutputSerialization><RequestProgress><Enabled>FALSE</Enabled></RequestProgress></SelectRequest>|]         ),         ( setRequestProgressEnabled False $@@ -168,7 +176,7 @@                       <> quoteCharacter "\""                       <> quoteEscapeCharacter "\""                 ),-          [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>NONE</CompressionType><Parquet/></InputSerialization><OutputSerialization><CSV><FieldDelimiter>,</FieldDelimiter><QuoteCharacter>&#34;</QuoteCharacter><QuoteEscapeCharacter>&#34;</QuoteEscapeCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter>+          [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>NONE</CompressionType><Parquet/></InputSerialization><OutputSerialization><CSV><FieldDelimiter>,</FieldDelimiter><QuoteCharacter>"</QuoteCharacter><QuoteEscapeCharacter>"</QuoteEscapeCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter> </RecordDelimiter></CSV></OutputSerialization><RequestProgress><Enabled>FALSE</Enabled></RequestProgress></SelectRequest>|]         )       ]
test/Spec.hs view
@@ -1,5 +1,5 @@ ----- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.+-- MinIO Haskell SDK, (C) 2017-2023 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,7 +20,6 @@ import Network.Minio.API.Test import Network.Minio.CopyObject import Network.Minio.Data-import Network.Minio.PutObject import Network.Minio.Utils.Test import Network.Minio.XmlGenerator.Test import Network.Minio.XmlParser.Test