Add GHC 9.8.2 to CI (#195)

Tests needing fixing for recent minio

Also:
- set minimum tested version to 8.10
- remove building with cabal 3.6
- update stack.yaml to add crypton-connection

Update live server test env var handling

.github/workflows/ci.yml

@@ -0,0 +1,266 @@
+name: CI
+
+# Trigger the workflow on push or pull request, but only for the master branch
+on:
+  pull_request:
+    branches: [master]
+  push:
+    branches: [master]
+
+# This ensures that previous jobs for the PR are canceled when the PR is
+# updated.
+concurrency:
+  group: ${{ github.workflow }}-${{ github.head_ref }}
+  cancel-in-progress: true
+
+# Env vars for tests
+env:
+  MINIO_ACCESS_KEY: minio
+  MINIO_SECRET_KEY: minio123
+  MINIO_LOCAL: 1
+
+jobs:
+  ormolu:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4
+      - uses: haskell-actions/run-ormolu@v15
+        with:
+          version: "0.5.0.1"
+
+  hlint:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4
+
+      - name: "Set up HLint"
+        uses: haskell-actions/hlint-setup@v2
+        with:
+          version: "3.5"
+
+      - name: "Run HLint"
+        uses: haskell-actions/hlint-run@v2
+        with:
+          path: '["src/", "test/", "examples"]'
+          fail-on: warning
+
+  cabal:
+    name: ${{ matrix.os }} / ghc-${{ matrix.ghc }} / cabal-${{ matrix.cabal }}
+    runs-on: ${{ matrix.os }}
+    needs: ormolu
+    strategy:
+      matrix:
+        os: [ubuntu-latest, windows-latest, macos-latest]
+        cabal: ["3.8", "latest"]
+        ghc:
+          - "9.8"
+          - "9.6"
+          - "9.4"
+          - "9.2"
+          - "9.0"
+          - "8.10"
+        exclude:
+          # macos llvm issue for versions less than 9.2
+          - os: macos-latest
+            ghc: "8.10"
+          - os: macos-latest
+            ghc: "9.0"
+          # Cabal 3.8 supports GHC < 9.6
+          - cabal: "3.8"
+            ghc: "9.6"
+          - cabal: "3.8"
+            ghc: "9.8"
+
+    steps:
+      - uses: actions/checkout@v4
+        if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
+
+      - uses: haskell-actions/setup@v2
+        id: setup
+        name: Setup Haskell
+        with:
+          ghc-version: ${{ matrix.ghc }}
+          cabal-version: ${{ matrix.cabal }}
+          cabal-update: true
+
+      - name: Configure
+        run: |
+          cabal configure --enable-tests --enable-benchmarks             --test-show-details=direct -fexamples -fdev -flive-test
+          cabal build all --dry-run
+        # The last step generates dist-newstyle/cache/plan.json for the cache key.
+
+      - name: Restore cached dependencies
+        uses: actions/cache/restore@v4
+        id: cache
+        env:
+          key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }}
+        with:
+          path: ${{ steps.setup.outputs.cabal-store }}
+          key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }}
+          restore-keys: ${{ env.key }}-
+
+      - name: Install dependencies
+        # If we had an exact cache hit, the dependencies will be up to date.
+        if: steps.cache.outputs.cache-hit != 'true'
+        run: cabal build all --only-dependencies
+
+      # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail.
+      - name: Save cached dependencies
+        uses: actions/cache/save@v4
+        # If we had an exact cache hit, trying to save the cache would error because of key clash.
+        if: steps.cache.outputs.cache-hit != 'true'
+        with:
+          path: ${{ steps.setup.outputs.cabal-store }}
+          key: ${{ steps.cache.outputs.cache-primary-key }}
+
+      - name: Build
+        run: |
+          cabal build all
+
+      - name: Setup TLS certs for MinIO for testing (Linux)
+        if: matrix.os == 'ubuntu-latest'
+        run: |
+          mkdir -p /tmp/minio /tmp/minio-config/certs
+          cp test/cert/* /tmp/minio-config/certs/
+          (cd /tmp/minio; wget -q https://dl.min.io/server/minio/release/linux-amd64/minio; chmod +x ./minio)
+          sudo cp /tmp/minio-config/certs/public.crt /usr/local/share/ca-certificates/
+          sudo update-ca-certificates
+
+      ## Currently disable TLS setup for MacOS due to issues in trusting it on MacOS.
+      - name: Setup TLS certs for MinIO for testing (MacOS)
+        if: matrix.os == 'macos-latest'
+        run: |
+          mkdir -p /tmp/minio /tmp/minio-config/certs
+          cp test/cert/* /tmp/minio-config/certs/
+          (cd /tmp/minio; wget -q https://dl.min.io/server/minio/release/darwin-amd64/minio; chmod +x ./minio)
+          # sudo security add-trusted-cert -d -r trustRoot -k /Library/Keychains/System.keychain /tmp/minio-config/certs/public.crt
+
+      - name: Setup MinIO for testing (Windows)
+        if: matrix.os == 'windows-latest'
+        run: |
+          New-Item -ItemType Directory -Path "$env:temp/minio-config/certs/"
+          Copy-Item -Path test\cert\* -Destination "$env:temp/minio-config/certs/"
+          Invoke-WebRequest -Uri https://dl.minio.io/server/minio/release/windows-amd64/minio.exe -OutFile $HOME/minio.exe
+          Import-Certificate -FilePath "$env:temp/minio-config/certs/public.crt" -CertStoreLocation Cert:\LocalMachine\Root
+
+      - name: Test (Linux)
+        if: matrix.os == 'ubuntu-latest'
+        env:
+          MINIO_SECURE: 1
+        run: |
+          /tmp/minio/minio server --quiet --certs-dir /tmp/minio-config/certs data1 data2 data3 data4 2>&1 > minio.log &
+          ghc --version
+          cabal --version
+          cabal test all
+
+      - name: Test (MacOS)
+        if: matrix.os == 'macos-latest'
+        # # Leave MINIO_SECURE unset to disable TLS in tests.
+        # env:
+        #   MINIO_SECURE: 1
+        run: |
+          /tmp/minio/minio server --quiet data1 data2 data3 data4 2>&1 > minio.log &
+          ghc --version
+          cabal --version
+          cabal test all
+
+      - name: Test (Windows)
+        if: matrix.os == 'windows-latest'
+        env:
+          MINIO_SECURE: 1
+        run: |
+          Start-Process -NoNewWindow -FilePath "$HOME/minio.exe" -ArgumentList "--certs-dir", "$env:temp/minio-config/certs", "server", "$env:temp/data1", "$env:temp/data2", "$env:temp/data3", "$env:temp/data4"
+          ghc --version
+          cabal --version
+          cabal test all
+
+  stack:
+    name: stack / ghc ${{ matrix.ghc }}
+    runs-on: ${{ matrix.os }}
+    env:
+      MINIO_SECURE: 1
+    strategy:
+      matrix:
+        ghc:
+          - "8.10.7"
+          - "9.0.2"
+          - "9.2.8"
+          - "9.4.8"
+          - "9.6.5"
+          - "9.8.2"
+        os: [ubuntu-latest]
+
+    steps:
+      - uses: actions/checkout@v4
+        if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
+
+      - uses: haskell-actions/setup@v2
+        with:
+          ghc-version: ${{ matrix.ghc }}
+          enable-stack: true
+          stack-version: "latest"
+
+      - uses: actions/cache@v4
+        name: Cache ~/.stack
+        with:
+          path: ~/.stack
+          key: ${{ runner.os }}-stack-global-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }}
+          restore-keys: |
+            ${{ runner.os }}-stack-global-
+      - uses: actions/cache@v4
+        name: Cache .stack-work
+        with:
+          path: .stack-work
+          key: ${{ runner.os }}-stack-work-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }}-${{ hashFiles('**/*.hs') }}
+          restore-keys: |
+            ${{ runner.os }}-stack-work-
+
+      - name: Install dependencies
+        run: |
+          stack --version
+          stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies
+
+      - name: Build
+        run: |
+          stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --flag minio-hs:examples --flag minio-hs:live-test --flag minio-hs:dev
+
+      - name: Setup MinIO for testing (Linux)
+        if: matrix.os == 'ubuntu-latest'
+        run: |
+          mkdir -p /tmp/minio /tmp/minio-config/certs
+          cp test/cert/* /tmp/minio-config/certs/
+          (cd /tmp/minio; wget -q https://dl.min.io/server/minio/release/linux-amd64/minio; chmod +x ./minio)
+          sudo cp /tmp/minio-config/certs/public.crt /usr/local/share/ca-certificates/
+          sudo update-ca-certificates
+
+      - name: Setup MinIO for testing (MacOS)
+        if: matrix.os == 'macos-latest'
+        run: |
+          mkdir -p /tmp/minio /tmp/minio-config/certs
+          cp test/cert/* /tmp/minio-config/certs/
+          (cd /tmp/minio; wget -q https://dl.min.io/server/minio/release/darwin-amd64/minio; chmod +x ./minio)
+          sudo security add-trusted-cert -d -r trustRoot -k /Library/Keychains/System.keychain /tmp/minio-config/certs/public.crt
+
+      - name: Setup MinIO for testing (Windows)
+        if: matrix.os == 'windows-latest'
+        run: |
+          New-Item -ItemType Directory -Path "$env:temp/minio-config/certs/"
+          Copy-Item -Path test\cert\* -Destination "$env:temp/minio-config/certs/"
+          Invoke-WebRequest -Uri https://dl.minio.io/server/minio/release/windows-amd64/minio.exe -OutFile $HOME/minio.exe
+          Import-Certificate -FilePath "$env:temp/minio-config/certs/public.crt" -CertStoreLocation Cert:\LocalMachine\Root
+
+      - name: Test (Non-Windows)
+        if: matrix.os != 'windows-latest'
+        run: |
+          /tmp/minio/minio server --quiet --certs-dir /tmp/minio-config/certs data1 data2 data3 data4 2>&1 > minio.log &
+          ghc --version
+          stack --version
+          stack test --system-ghc --flag minio-hs:live-test --flag minio-hs:dev
+
+      - name: Test (Windows)
+        if: matrix.os == 'windows-latest'
+        run: |
+          Start-Process -NoNewWindow -FilePath "$HOME/minio.exe" -ArgumentList "--certs-dir", "$env:temp/minio-config/certs", "server", "$env:temp/data1", "$env:temp/data2", "$env:temp/data3", "$env:temp/data4"
+          ghc --version
+          cabal --version
+          stack test --system-ghc --flag minio-hs:live-test --flag minio-hs:dev

.gitignore

@@ -17,3 +17,4 @@ cabal.sandbox.config
 *.eventlog
 .stack-work/
 cabal.project.local
+*~

.travis.yml

@@ -1,40 +0,0 @@
-# This is the simple Travis configuration, which is intended for use
-# on applications which do not require cross-platform and
-# multiple-GHC-version support. For more information and other
-# options, see:
-#
-# https://docs.haskellstack.org/en/stable/travis_ci/
-#
-# Copy these contents into the root directory of your Github project in a file
-# named .travis.yml
-
-# Use new container infrastructure to enable caching
-sudo: false
-
-# Do not choose a language; we provide our own build tools.
-language: generic
-
-# Caching so the next build will be fast too.
-cache:
-  directories:
-  - $HOME/.stack
-
-# Ensure necessary system libraries are present
-addons:
-  apt:
-    packages:
-      - libgmp-dev
-
-before_install:
-# Download and unpack the stack executable
-- mkdir -p ~/.local/bin
-- export PATH=$HOME/.local/bin:$PATH
-- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
-
-install:
-# Build dependencies
-- stack --no-terminal --install-ghc test --only-dependencies
-
-script:
-# Build the package, its tests, and its docs and run the tests
-- stack --no-terminal test --haddock --no-haddock-deps

CHANGELOG.md

@@ -1,6 +1,162 @@
 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)
+* Fix XML generation test for S3 SELECT (#161)
+* Use region specific endpoints for AWS S3 in presigned Urls (#164)
+* Replace protolude with relude and build with GHC 9.0.2 (#168)
+* Support aeson 2 (#169)
+* CI updates and code formatting changes with ormolu 0.5.0.0
+
+## Version 1.5.3
+
+* Fix windows build
+* Fix support for Yandex Storage (#147)
+* Fix for HEAD requests to S3/Minio (#155)
+* Bump up some dependencies, new code formatting, Github CI, example fixes and other minor improvements.
+
+## Version 1.5.2
+
+* Fix region `us-west-2` for AWS S3 (#139)
+* Build examples in CI
+* Disable live-server tests by default, but run them in CI
+* Drop support for GHC 8.2.x
+
+## Version 1.5.1
+
+* Add support for GHC 8.8
+
+## Version 1.5.0
+
+* Switch to faster map data type - all previous usage of
+  Data.Map.Strict and Data.Set is replaced with Data.HashMap.Strict
+  and Data.HashSet.
+* Add `oiUserMetadata` to parse and return user metadata stored with
+  an object.
+* Add `GetObjectResponse` data type for the value returned by
+  `getObject`. It now contains parsed ObjectInfo along with the
+  conduit of object bytes.
+
+## Version 1.4.0
+
+* Expose runMinioRes and runMinioResWith (#129)
+* Improve Haddocks (#127)
+* Fix list objects APIs to return directory prefixes when run with
+  recurse set to False (#126)
+* Use streaming signature for streaming payloads when on an insecure
+  connection (#123)
+
+## Version 1.3.1
+
+* Add TLS helpers to check if server uses TLS, and to disable
+  certificate validation for easier testing (#121)
+
+## Version 1.3.0
+
+* Retry requests that timeout using full-jitter backoff (#119)
+* Accept GetObjectOptions in statObject (#112)
+* Add encryption options to GetObjectOptions and PutObjectOptions (#111)
+* Add missing Haddock documentation (#110)
+* Add support for S3Select API (#108)
+* New travis with support for multiple GHCs (#106)
+* Fix region setting in presigned url functions (#107)
+
+## Version 1.2.0
+
+* Export Provider and findFirst to look for credentials (#103)
+
+## Version 1.1.0
+
+This version brings the following changes:
+
+* Adds experimental Admin APIs (#88, #91, #93, #94, #95, #100)
+* Adds support for using Google Compute Storage service when S3
+  compatibility mode is enabled (#96, #99)
+
+This version also brings some breaking changes (via #101):
+
+* Adds IsString instance to load server address, and updates
+  initialization API to be more user friendly
+* Drops usage of data-default package and exposes explicit default
+  values for various types used in the library.
+
+## Version 1.0.1
+
+This version brings the following (non-breaking) changes:
+
+* Remove dependency on text-format (#86)
+* Remove direct dependency on exceptions (#87)
+* Adds lower-bounds on dependencies.
+
+## Version 1.0.0
+
+This new release changes the following APIs to add new capabilities:
+
+* Copy Object API now supports more options for source and destination (#73)
+* get/put Object functions now support a wider set of options via a
+  separate settings parameter (#71, #72)
+* getBucketPolicy and setBucketPolicy APIs are added (#82)
+* The library now uses UnliftIO (#83)
+
+## Version 0.3.2
+
+This release brings the following changes:
+
+* Add `removeIncompleteUpload` API (#49)
+* Add presigned operations APIs (#56)
+* Add presigned Post Policy API (#58)
+* Skip SHA256 checksum header for secure connections (#65)
+* Remove resuming capability in PutObject (#67)
+* Add ListObjectsV1 API support (#66)
+* Add Bucket Notification APIs (#59)
+* Reverse #54 - tests fix.
+
+## Version 0.3.1
+
+This is a bug-fix release:
+
+* Fix concurrency bug in `limitedMapConcurrently` (#53)
+* Fix tests related to listing incomplete uploads to accommodate MinIO
+  server's changed behaviour to not list incomplete uploads. Note that
+  running these tests against AWS S3 are expected to fail. (#54)
+
+## Version 0.3.0
+
+This release includes a breaking change:
+
+Users of the library need not call `runResourceT` explicitly after
+calling `runMinio`. This is now done, within the `runMinio` call
+making usage a bit simpler.
+
+Other changes:
+
+* Export ListUploadsResult and ListObjectsResult (#48)
+  * Also take max-keys as an argument for listObjects and max-uploads
+    for listIncompleteUploads.
+* Add bucket and object name validation (#45)
+* Add bucketExists and headBucket APIs (#42)
+
+## Version 0.2.1
+
+* Update dependencies, and switch to Stackage LTS 8.5
+
 ## Version 0.2.0
 
 This is an interim release which brings some new features. However,

CNAME

@@ -0,0 +1 @@
+minio-hs.min.io

README.md

@@ -1,65 +1,94 @@
-# 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://budueba.com/hackage/minio-hs)](https://hackage.haskell.org/package/minio-hs)
+# 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)
 
-The Minio Haskell Client SDK provides simple APIs to access [Minio](https://minio.io) and Amazon S3 compatible object storage server.
+The MinIO Haskell Client SDK provides simple APIs to access [MinIO](https://min.io) and any Amazon S3 compatible object storage.
 
-**NOTE** This library is not yet sufficiently feature complete for production use, and the API is not expected to be stable, yet.
+This guide assumes that you have a working [Haskell development environment](https://www.haskell.org/downloads/).
-
-## Minimum Requirements
-
-- The Haskell [stack](https://docs.haskellstack.org/en/stable/README/)
 
 ## Installation
 
-```sh
+### Add to your project
-git clone https://github.com/minio/minio-hs.git
 
-cd minio-hs/
+Simply add `minio-hs` to your project's `.cabal` dependencies section or if you are using hpack, to your `package.yaml` file as usual.
 
-stack install
+### 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
 ```
 
-Tests can be run with:
+Then load the `ghci` REPL environment with the library and browse the available APIs:
-
-```sh
-
-stack test
 
+``` sh
+$ cabal repl
+ghci> :browse Network.Minio
 ```
 
-A section of the tests use the remote Minio Play server at
+#### For a stack based environment
-`https://play.minio.io:9000` 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).
 
-Documentation can be locally built with:
+From your home folder or any non-haskell project directory, just run:
 
 ```sh
-
+stack install minio-hs
-stack haddock
-
 ```
 
-## Quick-Start Example - File Uploader
+Then start an interpreter session and browse the available APIs with:
+
+```sh
+$ stack ghci
+> :browse Network.Minio
+```
+
+## Examples
+
+The [examples](https://github.com/minio/minio-hs/tree/master/examples) folder contains many examples that you can try out and use to learn and to help with developing your own projects.
+
+### Quick-Start Example - File Uploader
+
+This example program connects to a MinIO object storage server, makes a bucket on the server and then uploads a file to the bucket.
+
+We will use the MinIO server running at https://play.min.io in this example. Feel free to use this service for testing and development. Access credentials are present in the library and are open to the public.
 
 ### FileUploader.hs
 ``` haskell
 #!/usr/bin/env stack
--- stack --resolver lts-6.27 runghc --package minio-hs --package optparse-applicative --package filepath
+-- stack --resolver lts-14.11 runghc --package minio-hs --package optparse-applicative --package filepath
 
-{-# Language OverloadedStrings, ScopedTypeVariables #-}
+--
+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- 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   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 import           Network.Minio
 
-import Control.Monad.Catch (catchIf)
+import           Data.Monoid           ((<>))
-import Control.Monad.IO.Class (liftIO)
-import Options.Applicative
-import Prelude
-import System.FilePath.Posix
 import           Data.Text             (pack)
+import           Options.Applicative
+import           System.FilePath.Posix
+import           UnliftIO              (throwIO, try)
+
+import           Prelude
 
 -- | The following example uses minio's play server at
--- https://play.minio.io:9000.  The endpoint and associated
+-- https://play.min.io.  The endpoint and associated
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
@@ -69,7 +98,7 @@ import Data.Text (pack)
 fileNameArgs :: Parser FilePath
 fileNameArgs = strArgument
                (metavar "FILENAME"
-                <> help "Name of file to upload to AWS S3 or a Minio server")
+                <> help "Name of file to upload to AWS S3 or a MinIO server")
 
 cmdParser = info
             (helper <*> fileNameArgs)
@@ -78,31 +107,34 @@ cmdParser = info
              <> header
              "FileUploader - a simple file-uploader program using minio-hs")
 
-ignoreMinioErr :: ServiceErr -> Minio ()
-ignoreMinioErr = return . const ()
-
-
 main :: IO ()
 main = do
   let bucket = "my-bucket"
 
-  -- Parse command line argument, namely --filename.
+  -- Parse command line argument
   filepath <- execParser cmdParser
   let object = pack $ takeBaseName filepath
 
-  res <- runResourceT $ runMinio minioPlayCI $ do
+  res <- runMinio minioPlayCI $ do
     -- Make a bucket; catch bucket already exists exception if thrown.
-    catchIf (== BucketAlreadyOwnedByYou) (makeBucket bucket Nothing) ignoreMinioErr
+    bErr <- try $ makeBucket bucket Nothing
 
-    -- Upload filepath to bucket; object is derived from filepath.
+    -- If the bucket already exists, we would get a specific
-    fPutObject bucket object filepath
+    -- `ServiceErr` exception thrown.
+    case bErr of
+      Left BucketAlreadyOwnedByYou -> return ()
+      Left e                       -> throwIO e
+      Right _                      -> return ()
+
+    -- Upload filepath to bucket; object name is derived from filepath.
+    fPutObject bucket object filepath defaultPutObjectOptions
 
   case res of
-    Left e -> putStrLn $ "file upload failed due to " ++ (show e)
+    Left e   -> putStrLn $ "file upload failed due to " ++ show e
     Right () -> putStrLn "file upload succeeded."
 ```
 
-### Run fileuploader
+### Run FileUploader
 
 ``` sh
 ./FileUploader.hs "path/to/my/file"
@@ -112,3 +144,55 @@ main = do
 ## Contribute
 
 [Contributors Guide](https://github.com/minio/minio-hs/blob/master/CONTRIBUTING.md)
+
+### Development
+
+#### Download the source
+
+```sh
+$ git clone https://github.com/minio/minio-hs.git
+$ cd minio-hs/
+``` 
+
+#### Build the package:
+
+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
+```
+
+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` 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).
+
+With `cabal`:
+
+```sh
+$ export MINIO_LOCAL=1 # to run live tests against local MinIO server
+$ cabal 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
+```
+
+This will run all the test suites.
+
+#### Building documentation:
+
+```sh
+$ cabal haddock
+$ # OR
+$ stack haddock
+```

examples/AssumeRole.hs

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

examples/BucketExists.hs

@@ -0,0 +1,40 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
+--
+-- MinIO Haskell SDK, (C) 2017, 2018 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
+
+-- | The following example uses minio's play server at
+-- https://play.min.io.  The endpoint and associated
+-- credentials are provided via the libary constant,
+--
+-- > minioPlayCI :: ConnectInfo
+main :: IO ()
+main = do
+  let bucket = "missingbucket"
+
+  res1 <- runMinio minioPlayCI $ do
+    foundBucket <- bucketExists bucket
+    liftIO $ putStrLn $ "Does " ++ show bucket ++ " exist? - " ++ show foundBucket
+
+  case res1 of
+    Left e -> putStrLn $ "bucketExists failed." ++ show e
+    Right () -> return ()

examples/CopyObject.hs

@@ -1,8 +1,8 @@
 #!/usr/bin/env stack
--- stack --resolver lts-6.27 runghc --package minio-hs
+-- stack --resolver lts-14.11 runghc --package minio-hs
 
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017, 2018 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,44 +16,40 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE OverloadedStrings #-}
 
-{-# Language OverloadedStrings #-}
 import Network.Minio
-
+import UnliftIO.Exception (catch, throwIO)
-import           Control.Monad.Catch (catchIf)
-import qualified Data.Text as T
-import           Prelude
 
 -- | The following example uses minio's play server at
--- https://play.minio.io:9000.  The endpoint and associated
+-- https://play.min.io.  The endpoint and associated
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
-ignoreMinioErr :: ServiceErr -> Minio ()
-ignoreMinioErr = return . const ()
-
 main :: IO ()
 main = do
-  let
+  let bucket = "test"
-      bucket = "test"
       object = "obj"
       objectCopy = "obj-copy"
       localFile = "/etc/lsb-release"
 
-  res1 <- runResourceT $ runMinio minioPlayCI $ do
+  res1 <- runMinio minioPlayCI $ do
     -- 1. Make a bucket; Catch BucketAlreadyOwnedByYou exception.
-    catchIf (== BucketAlreadyOwnedByYou) (makeBucket bucket Nothing) ignoreMinioErr
+    catch
+      (makeBucket bucket Nothing)
+      ( \e -> case e of
+          BucketAlreadyOwnedByYou -> return ()
+          _ -> throwIO e
+      )
 
     -- 2. Upload a file to bucket/object.
-    fPutObject bucket object localFile
+    fPutObject bucket object localFile defaultPutObjectOptions
 
     -- 3. Copy bucket/object to bucket/objectCopy.
-    copyObject bucket objectCopy def {
+    copyObject
-      cpSource = T.concat ["/", bucket, "/", object]
+      defaultDestinationInfo {dstBucket = bucket, dstObject = objectCopy}
-      }
+      defaultSourceInfo {srcBucket = bucket, srcObject = object}
 
   case res1 of
-    Left e -> putStrLn $ "copyObject failed." ++ (show e)
+    Left e -> putStrLn $ "copyObject failed." ++ show e
     Right () -> putStrLn "copyObject succeeded."

examples/FileUploader.hs

@@ -1,8 +1,8 @@
 #!/usr/bin/env stack
--- stack --resolver lts-6.27 runghc --package minio-hs --package optparse-applicative --package filepath
+-- stack --resolver lts-14.11 runghc --package minio-hs --package optparse-applicative --package filepath
 
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017, 2018 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,57 +16,59 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
-
-{-# Language OverloadedStrings, ScopedTypeVariables #-}
-import Network.Minio
-
-import Control.Monad.Catch (catchIf)
-import Control.Monad.IO.Class (liftIO)
-import Options.Applicative
-import Prelude
-import System.FilePath.Posix
 import Data.Text (pack)
+import Network.Minio
+import Options.Applicative
+import System.FilePath.Posix
+import UnliftIO (throwIO, try)
+import Prelude
 
 -- | The following example uses minio's play server at
--- https://play.minio.io:9000.  The endpoint and associated
+-- https://play.min.io.  The endpoint and associated
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
 
 -- optparse-applicative package based command-line parsing.
 fileNameArgs :: Parser FilePath
-fileNameArgs = strArgument
+fileNameArgs =
-               (metavar "FILENAME"
+  strArgument
-                <> help "Name of file to upload to AWS S3 or a Minio server")
+    ( metavar "FILENAME"
+        <> help "Name of file to upload to AWS S3 or a MinIO server"
+    )
 
-cmdParser = info
+cmdParser :: ParserInfo FilePath
+cmdParser =
+  info
     (helper <*> fileNameArgs)
-            (fullDesc
+    ( fullDesc
         <> progDesc "FileUploader"
         <> header
-             "FileUploader - a simple file-uploader program using minio-hs")
+          "FileUploader - a simple file-uploader program using minio-hs"
-
+    )
-ignoreMinioErr :: ServiceErr -> Minio ()
-ignoreMinioErr = return . const ()
-
 
 main :: IO ()
 main = do
   let bucket = "my-bucket"
 
-  -- Parse command line argument, namely --filename.
+  -- Parse command line argument
   filepath <- execParser cmdParser
   let object = pack $ takeBaseName filepath
 
-  res <- runResourceT $ runMinio minioPlayCI $ do
+  res <- runMinio minioPlayCI $ do
     -- Make a bucket; catch bucket already exists exception if thrown.
-    catchIf (== BucketAlreadyOwnedByYou) (makeBucket bucket Nothing) ignoreMinioErr
+    bErr <- try $ makeBucket bucket Nothing
+    case bErr of
+      Left BucketAlreadyOwnedByYou -> return ()
+      Left e -> throwIO e
+      Right _ -> return ()
 
     -- Upload filepath to bucket; object is derived from filepath.
-    fPutObject bucket object filepath
+    fPutObject bucket object filepath defaultPutObjectOptions
 
   case res of
-    Left e -> putStrLn $ "file upload failed due to " ++ (show e)
+    Left e -> putStrLn $ "file upload failed due to " ++ show e
     Right () -> putStrLn "file upload succeeded."

examples/GetConfig.hs

@@ -1,5 +1,8 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017, 2018 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,5 +17,14 @@
 -- limitations under the License.
 --
 
-import Distribution.Simple
+import Network.Minio
-main = defaultMain
+import Network.Minio.AdminAPI
+import Prelude
+
+main :: IO ()
+main = do
+  res <-
+    runMinio
+      minioPlayCI
+      getConfig
+  print res

examples/GetObject.hs

@@ -1,8 +1,8 @@
 #!/usr/bin/env stack
--- stack --resolver lts-6.27 runghc --package minio-hs
+-- stack --resolver lts-14.11 runghc --package minio-hs
 
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017, 2018 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,30 +16,26 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE OverloadedStrings #-}
 
-{-# Language OverloadedStrings #-}
+import qualified Data.Conduit as C
+import qualified Data.Conduit.Binary as CB
 import Network.Minio
-
-import Data.Conduit (($$+-))
-import Data.Conduit.Binary (sinkLbs)
 import Prelude
 
 -- | The following example uses minio's play server at
--- https://play.minio.io:9000.  The endpoint and associated
+-- https://play.min.io.  The endpoint and associated
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
 main :: IO ()
 main = do
-  let
+  let bucket = "my-bucket"
-      bucket = "my-bucket"
       object = "my-object"
-  res <- runResourceT $ runMinio minioPlayCI $ do
+  res <- runMinio minioPlayCI $ do
-    src <- getObject bucket object
+    src <- getObject bucket object defaultGetObjectOptions
-    (src $$+- sinkLbs)
+    C.connect (gorObjectStream src) $ CB.sinkFileCautious "/tmp/my-object"
 
   case res of
-    Left e -> putStrLn $ "getObject failed." ++ (show e)
+    Left e -> putStrLn $ "getObject failed." ++ show e
     Right _ -> putStrLn "getObject succeeded."

examples/HeadObject.hs

@@ -1,8 +1,8 @@
 #!/usr/bin/env stack
--- stack --resolver lts-6.27 runghc --package minio-hs
+-- stack --resolver lts-14.11 runghc --package minio-hs
 
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017, 2018 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,28 +16,25 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE OverloadedStrings #-}
 
-{-# Language OverloadedStrings #-}
-import Network.Minio.S3API
 import Network.Minio
-
+import Network.Minio.S3API
 import Prelude
 
 -- | The following example uses minio's play server at
--- https://play.minio.io:9000.  The endpoint and associated
+-- https://play.min.io.  The endpoint and associated
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
 main :: IO ()
 main = do
-  let
+  let bucket = "test"
-      bucket = "test"
       object = "passwd"
-  res <- runResourceT $ runMinio minioPlayCI $ do
+  res <-
-    headObject bucket object
+    runMinio minioPlayCI $
+      headObject bucket object []
 
   case res of
-    Left e -> putStrLn $ "headObject failed." ++ (show e)
+    Left e -> putStrLn $ "headObject failed." ++ show e
-    Right objInfo -> putStrLn $ "headObject succeeded." ++ (show objInfo)
+    Right objInfo -> putStrLn $ "headObject succeeded." ++ show objInfo

examples/Heal.hs

@@ -0,0 +1,37 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
+--
+-- MinIO Haskell SDK, (C) 2017, 2018 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 Network.Minio
+import Network.Minio.AdminAPI
+import Prelude
+
+main :: IO ()
+main = do
+  res <- runMinio minioPlayCI $
+    do
+      hsr <-
+        startHeal
+          Nothing
+          Nothing
+          HealOpts
+            { hoRecursive = True,
+              hoDryRun = False
+            }
+      getHealStatus Nothing Nothing (hsrClientToken hsr)
+  print res

examples/ListBuckets.hs

@@ -1,8 +1,8 @@
 #!/usr/bin/env stack
--- stack --resolver lts-6.27 runghc --package minio-hs
+-- stack --resolver lts-14.11 runghc --package minio-hs
 
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017, 2018 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,26 +16,24 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
+{-# LANGUAGE OverloadedStrings #-}
-{-# Language OverloadedStrings #-}
-import Network.Minio
 
 import Control.Monad.IO.Class (liftIO)
+import Network.Minio
 import Prelude
 
 -- | The following example uses minio's play server at
--- https://play.minio.io:9000.  The endpoint and associated
+-- https://play.min.io.  The endpoint and associated
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
 
 -- This example list buckets that belongs to the user and returns
 -- region of the first bucket returned.
 main :: IO ()
 main = do
-  firstRegionE <- runResourceT $ runMinio minioPlayCI $ do
+  firstRegionE <- runMinio minioPlayCI $ do
     buckets <- listBuckets
-    liftIO $ print $ "Top 5 buckets: " ++ (show $ take 5 buckets)
+    liftIO $ print $ "Top 5 buckets: " ++ show (take 5 buckets)
     getLocation $ biName $ head buckets
   print firstRegionE

examples/ListIncompleteUploads.hs

@@ -1,8 +1,8 @@
 #!/usr/bin/env stack
--- stack --resolver lts-6.27 runghc --package minio-hs
+-- stack --resolver lts-14.11 runghc --package minio-hs
 
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017, 2018 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,34 +16,31 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE OverloadedStrings #-}
 
-{-# Language OverloadedStrings #-}
+import Conduit
 import Network.Minio
-
-import Data.Conduit (($$))
-import Data.Conduit.Combinators (sinkList)
 import Prelude
 
 -- | The following example uses minio's play server at
--- https://play.minio.io:9000.  The endpoint and associated
+-- https://play.min.io.  The endpoint and associated
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
 main :: IO ()
 main = do
-  let
+  let bucket = "test"
-    bucket = "test"
 
   -- Performs a recursive listing of incomplete uploads under bucket "test"
   -- on a local minio server.
-  res <- runResourceT $ runMinio minioPlayCI $ do
+  res <-
-    listIncompleteUploads bucket Nothing True $$ sinkList
+    runMinio minioPlayCI $
+      runConduit $
+        listIncompleteUploads bucket Nothing True .| mapM_C (liftIO . print)
   print res
 
-  {-
+{-
-    Following is the output of the above program on a local Minio server.
+  Following is the output of the above program on a local MinIO server.
 
   Right [UploadInfo { uiKey = "go1.6.2.linux-amd64.tar.gz"
                     , uiUploadId = "063eb592-bdd7-4a0c-be48-34fb3ceb63e2"
@@ -51,4 +48,4 @@ main = do
                     , uiSize = 17731794
                     }
         ]
-  -}
+-}

examples/ListObjects.hs

@@ -1,8 +1,8 @@
 #!/usr/bin/env stack
--- stack --resolver lts-6.27 runghc --package minio-hs
+-- stack --resolver lts-14.11 runghc --package minio-hs
 
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017, 2018 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,35 +16,31 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE OverloadedStrings #-}
 
-{-# Language OverloadedStrings #-}
+import Conduit
 import Network.Minio
-
-import qualified Data.Conduit as C
-import qualified Data.Conduit.Combinators as CC
 import Prelude
 
-
 -- | The following example uses minio's play server at
--- https://play.minio.io:9000.  The endpoint and associated
+-- https://play.min.io.  The endpoint and associated
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
 main :: IO ()
 main = do
-  let
+  let bucket = "test"
-    bucket = "test"
 
   -- Performs a recursive listing of all objects under bucket "test"
-  -- on play.minio.io.
+  -- on play.min.io.
-  res <- runResourceT $ runMinio minioPlayCI $ do
+  res <-
-    listObjects bucket Nothing True C.$$ CC.sinkList
+    runMinio minioPlayCI $
+      runConduit $
+        listObjects bucket Nothing True .| mapM_C (liftIO . print)
   print res
 
-  {-
+{-
-    Following is the output of the above program on a local Minio server.
+  Following is the output of the above program on a local MinIO server.
 
   Right [ObjectInfo {oiObject = "ADVANCED.png", oiModTime = 2017-02-10 05:33:24.816 UTC, oiETag = "\"a69f3af6bbb06fe1d42ac910ec30482f\"", oiSize = 94026},ObjectInfo {oiObject = "obj", oiModTime = 2017-02-10 08:49:26.777 UTC, oiETag = "\"715a872a253a3596652c1490081b4b6a-1\"", oiSize = 15728640}]
-  -}
+-}

examples/MakeBucket.hs

@@ -1,8 +1,8 @@
 #!/usr/bin/env stack
--- stack --resolver lts-6.27 runghc --package minio-hs
+-- stack --resolver lts-14.11 runghc --package minio-hs
 
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017, 2018 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,25 +16,21 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE OverloadedStrings #-}
 
-
-{-# Language OverloadedStrings #-}
 import Network.Minio
-
 import Prelude
 
 -- | The following example uses minio's play server at
--- https://play.minio.io:9000.  The endpoint and associated
+-- https://play.min.io.  The endpoint and associated
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
 main :: IO ()
 main = do
-  let
+  let bucket = "my-bucket"
-      bucket = "my-bucket"
+  res <-
-  res <- runResourceT $ runMinio minioPlayCI $ do
+    runMinio minioPlayCI $
       -- N B the region provided for makeBucket is optional.
       makeBucket bucket (Just "us-east-1")
   print res

examples/PresignedGetObject.hs

@@ -0,0 +1,87 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
+--
+-- MinIO Haskell SDK, (C) 2017, 2018 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 qualified Data.ByteString.Char8 as B
+import Data.CaseInsensitive (original)
+import qualified Data.Conduit.Combinators as CC
+import qualified Data.Text.Encoding as E
+import Network.Minio
+
+-- | The following example uses minio's play server at
+-- https://play.min.io.  The endpoint and associated
+-- credentials are provided via the libary constant,
+--
+-- > minioPlayCI :: ConnectInfo
+main :: IO ()
+main = do
+  let bucket = "my-bucket"
+      object = "my-object"
+      kb15 = 15 * 1024
+      -- Set query parameter to modify content disposition response
+      -- header
+      queryParam =
+        [ ( "response-content-disposition",
+            Just "attachment; filename=\"your-filename.txt\""
+          )
+        ]
+
+  res <- runMinio minioPlayCI $ do
+    liftIO $ B.putStrLn "Upload a file that we will fetch with a presigned URL..."
+    putObject bucket object (CC.repeat "a") (Just kb15) defaultPutObjectOptions
+    liftIO $ putStrLn "Done. Object created at: my-bucket/my-object"
+
+    -- Extract Etag of uploaded object
+    oi <- statObject bucket object defaultGetObjectOptions
+    let etag = oiETag oi
+
+    -- Set header to add an if-match constraint - this makes sure
+    -- the fetching fails if the object is changed on the server
+    let headers = [("If-Match", E.encodeUtf8 etag)]
+
+    -- Generate a URL with 7 days expiry time - note that the headers
+    -- used above must be added to the request with the signed URL
+    -- generated.
+    url <-
+      presignedGetObjectUrl
+        "my-bucket"
+        "my-object"
+        (7 * 24 * 3600)
+        queryParam
+        headers
+
+    return (headers, etag, url)
+
+  case res of
+    Left e -> putStrLn $ "presignedPutObject URL failed." ++ show e
+    Right (headers, _, url) -> do
+      -- We generate a curl command to demonstrate usage of the signed
+      -- URL.
+      let hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"]
+          curlCmd =
+            B.intercalate " " $
+              ["curl --fail"]
+                ++ map hdrOpt headers
+                ++ ["-o /tmp/myfile", B.concat ["'", url, "'"]]
+
+      putStrLn $
+        "The following curl command would use the presigned "
+          ++ "URL to fetch the object and write it to \"/tmp/myfile\":"
+      B.putStrLn curlCmd

examples/PresignedPostPolicy.hs

@@ -0,0 +1,87 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
+--
+-- MinIO Haskell SDK, (C) 2017, 2018 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 qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as Char8
+import qualified Data.HashMap.Strict as H
+import qualified Data.Text.Encoding as Enc
+import qualified Data.Time as Time
+import Network.Minio
+
+-- | The following example uses minio's play server at
+-- https://play.min.io.  The endpoint and associated
+-- credentials are provided via the libary constant,
+--
+-- > minioPlayCI :: ConnectInfo
+main :: IO ()
+main = do
+  now <- Time.getCurrentTime
+  let bucket = "my-bucket"
+      object = "photos/my-object"
+      -- set an expiration time of 10 days
+      expireTime = Time.addUTCTime (3600 * 24 * 10) now
+      -- create a policy with expiration time and conditions - since the
+      -- conditions are validated, newPostPolicy returns an Either value
+      policyE =
+        newPostPolicy
+          expireTime
+          [ -- set the object name condition
+            ppCondKey object,
+            -- set the bucket name condition
+            ppCondBucket bucket,
+            -- set the size range of object as 1B to 10MiB
+            ppCondContentLengthRange 1 (10 * 1024 * 1024),
+            -- set content type as jpg image
+            ppCondContentType "image/jpeg",
+            -- on success set the server response code to 200
+            ppCondSuccessActionStatus 200
+          ]
+
+  case policyE of
+    Left err -> print err
+    Right policy -> do
+      res <- runMinio minioPlayCI $ do
+        (url, formData) <- presignedPostPolicy policy
+
+        -- a curl command is output to demonstrate using the generated
+        -- URL and form-data
+        let formFn (k, v) =
+              B.concat
+                [ "-F ",
+                  Enc.encodeUtf8 k,
+                  "=",
+                  "'",
+                  v,
+                  "'"
+                ]
+            formOptions = B.intercalate " " $ map formFn $ H.toList formData
+
+        return $
+          B.intercalate
+            " "
+            ["curl", formOptions, "-F file=@/tmp/photo.jpg", url]
+
+      case res of
+        Left e -> putStrLn $ "post-policy error: " ++ show e
+        Right cmd -> do
+          putStrLn "Put a photo at /tmp/photo.jpg and run command:\n"
+
+          -- print the generated curl command
+          Char8.putStrLn cmd

examples/PresignedPutObject.hs

@@ -0,0 +1,58 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
+--
+-- MinIO Haskell SDK, (C) 2017, 2018 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 qualified Data.ByteString.Char8 as B
+import Data.CaseInsensitive (original)
+import Network.Minio
+
+-- | The following example uses minio's play server at
+-- https://play.min.io.  The endpoint and associated
+-- credentials are provided via the libary constant,
+--
+-- > minioPlayCI :: ConnectInfo
+main :: IO ()
+main = do
+  let -- Use headers to set user-metadata - note that this header will
+      -- need to be set when the URL is used to make an upload.
+      headers =
+        [ ( "x-amz-meta-url-creator",
+            "minio-hs-presigned-put-example"
+          )
+        ]
+  res <- runMinio minioPlayCI $ do
+    -- generate a URL with 7 days expiry time
+    presignedPutObjectUrl "my-bucket" "my-object" (7 * 24 * 3600) headers
+
+  case res of
+    Left e -> putStrLn $ "presignedPutObject URL failed." ++ show e
+    Right url -> do
+      -- We generate a curl command to demonstrate usage of the signed
+      -- URL.
+      let hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"]
+          curlCmd =
+            B.intercalate " " $
+              ["curl "]
+                ++ map hdrOpt headers
+                ++ ["-T /tmp/myfile", B.concat ["'", url, "'"]]
+
+      putStrLn $
+        "The following curl command would use the presigned "
+          ++ "URL to upload the file at \"/tmp/myfile\":"
+      B.putStrLn curlCmd

examples/PutObject.hs

@@ -1,8 +1,8 @@
 #!/usr/bin/env stack
--- stack --resolver lts-6.27 runghc --package minio-hs
+-- stack --resolver lts-14.11 runghc --package minio-hs
 
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017, 2018 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,39 +16,36 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
+{-# LANGUAGE OverloadedStrings #-}
-{-# Language OverloadedStrings #-}
-import           Network.Minio
 
 import qualified Data.Conduit.Combinators as CC
+import Network.Minio
 import Prelude
 
 -- | The following example uses minio's play server at
--- https://play.minio.io:9000.  The endpoint and associated
+-- https://play.min.io.  The endpoint and associated
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
 main :: IO ()
 main = do
-  let
+  let bucket = "test"
-      bucket = "test"
       object = "obj"
       localFile = "/etc/lsb-release"
       kb15 = 15 * 1024
 
-  -- Eg 1. Upload a stream of repeating "a" using putObject.
+  -- Eg 1. Upload a stream of repeating "a" using putObject with default options.
-  res1 <- runResourceT $ runMinio minioPlayCI $ do
+  res1 <-
-    putObject bucket object (CC.repeat "a") (Just kb15)
+    runMinio minioPlayCI $
+      putObject bucket object (CC.repeat "a") (Just kb15) defaultPutObjectOptions
   case res1 of
-    Left e -> putStrLn $ "putObject failed." ++ (show e)
+    Left e -> putStrLn $ "putObject failed." ++ show e
     Right () -> putStrLn "putObject succeeded."
 
-
+  -- Eg 2. Upload a file using fPutObject with default options.
-  -- Eg 2. Upload a file using fPutObject.
+  res2 <-
-  res2 <- runResourceT $ runMinio minioPlayCI $ do
+    runMinio minioPlayCI $
-    fPutObject bucket object localFile
+      fPutObject bucket object localFile defaultPutObjectOptions
   case res2 of
-    Left e -> putStrLn $ "fPutObject failed." ++ (show e)
+    Left e -> putStrLn $ "fPutObject failed." ++ show e
     Right () -> putStrLn "fPutObject succeeded."

examples/README.md

@@ -0,0 +1,17 @@
+# Examples
+
+The examples in this directory illustrate usage of various APIs provided by this library. Each file is self-contained and can be run like a script directly.
+
+To build the examples, the build flag `examples` needs to be turned on:
+
+```sh
+stack build --flag minio-hs:examples
+```
+
+Now to run and example script [BucketExists.hs](https://github.com/minio/minio-hs/blob/master/examples/BucketExists.hs):
+
+```sh
+stack exec BucketExists
+```
+
+The CI system is configured to build these examples with every change, so they should be current.

examples/RemoveBucket.hs

@@ -1,8 +1,8 @@
 #!/usr/bin/env stack
--- stack --resolver lts-6.27 runghc --package minio-hs
+-- stack --resolver lts-14.11 runghc --package minio-hs
 
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017, 2018 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,24 +16,18 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE OverloadedStrings #-}
 
-
-{-# Language OverloadedStrings #-}
 import Network.Minio
-
 import Prelude
 
 -- | The following example uses minio's play server at
--- https://play.minio.io:9000.  The endpoint and associated
+-- https://play.min.io.  The endpoint and associated
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
 main :: IO ()
 main = do
-  let
+  let bucket = "my-bucket"
-      bucket = "my-bucket"
+  res <- runMinio minioPlayCI $ removeBucket bucket
-  res <- runResourceT $ runMinio minioPlayCI $ do
-    removeBucket bucket
   print res

examples/RemoveIncompleteUpload.hs

@@ -0,0 +1,40 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
+--
+-- MinIO Haskell SDK, (C) 2017, 2018 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 Network.Minio
+import Prelude
+
+-- | The following example uses minio's play server at
+-- https://play.min.io.  The endpoint and associated
+-- credentials are provided via the libary constant,
+--
+-- > minioPlayCI :: ConnectInfo
+main :: IO ()
+main = do
+  let bucket = "mybucket"
+      object = "myobject"
+
+  res <-
+    runMinio minioPlayCI $
+      removeIncompleteUpload bucket object
+
+  case res of
+    Left _ -> putStrLn $ "Failed to remove " ++ show bucket ++ "/" ++ show object
+    Right _ -> putStrLn "Removed incomplete upload successfully"

examples/RemoveObject.hs

@@ -1,8 +1,8 @@
 #!/usr/bin/env stack
--- stack --resolver lts-6.27 runghc --package minio-hs
+-- stack --resolver lts-14.11 runghc --package minio-hs
 
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017, 2018 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,20 +16,20 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
+{-# LANGUAGE OverloadedStrings #-}
-{-# Language OverloadedStrings #-}
 
 import Network.Minio
+import Prelude
 
 main :: IO ()
 main = do
-  let
+  let bucket = "mybucket"
-    bucket = "mybucket"
       object = "myobject"
 
-  res <- runResourceT $ runMinio minioPlayCI $ do
+  res <-
+    runMinio minioPlayCI $
       removeObject bucket object
 
   case res of
-    Left e -> putStrLn $ "Failed to remove " ++ show bucket ++ "/" ++ show object
+    Left _ -> putStrLn $ "Failed to remove " ++ show bucket ++ "/" ++ show object
     Right _ -> putStrLn "Removed object successfully"

examples/SelectObject.hs

@@ -0,0 +1,47 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
+--
+-- MinIO Haskell SDK, (C) 2019 MinIO, Inc.
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- 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 qualified Conduit as C
+import Control.Monad (unless)
+import Network.Minio
+import Prelude
+
+main :: IO ()
+main = do
+  let bucket = "selectbucket"
+      object = "1.csv"
+      content =
+        "Name,Place,Temperature\n"
+          <> "James,San Jose,76\n"
+          <> "Alicia,San Leandro,88\n"
+          <> "Mark,San Carlos,90\n"
+
+  res <- runMinio minioPlayCI $ do
+    exists <- bucketExists bucket
+    unless exists $
+      makeBucket bucket Nothing
+
+    C.liftIO $ putStrLn "Uploading csv object"
+    putObject bucket object (C.sourceLazy content) Nothing defaultPutObjectOptions
+
+    let sr = selectRequest "Select * from s3object" defaultCsvInput defaultCsvOutput
+    res <- selectObjectContent bucket object sr
+    C.runConduit $ res C..| getPayloadBytes C..| C.stdoutC
+  print res

examples/ServerInfo.hs

@@ -0,0 +1,30 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
+--
+-- MinIO Haskell SDK, (C) 2017, 2018 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 Network.Minio
+import Network.Minio.AdminAPI
+import Prelude
+
+main :: IO ()
+main = do
+  res <-
+    runMinio
+      minioPlayCI
+      getServerInfo
+  print res

examples/ServiceSendRestart.hs

@@ -0,0 +1,29 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
+--
+-- MinIO Haskell SDK, (C) 2017, 2018 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 Network.Minio
+import Network.Minio.AdminAPI
+import Prelude
+
+main :: IO ()
+main = do
+  res <-
+    runMinio minioPlayCI $
+      serviceSendAction ServiceActionRestart
+  print res

examples/ServiceSendStop.hs

@@ -0,0 +1,29 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
+--
+-- MinIO Haskell SDK, (C) 2017, 2018 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 Network.Minio
+import Network.Minio.AdminAPI
+import Prelude
+
+main :: IO ()
+main = do
+  res <-
+    runMinio minioPlayCI $
+      serviceSendAction ServiceActionStop
+  print res

examples/ServiceStatus.hs

@@ -0,0 +1,30 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
+--
+-- MinIO Haskell SDK, (C) 2017, 2018 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 Network.Minio
+import Network.Minio.AdminAPI
+import Prelude
+
+main :: IO ()
+main = do
+  res <-
+    runMinio
+      minioPlayCI
+      serviceStatus
+  print res

examples/SetConfig.hs

@@ -0,0 +1,31 @@
+#!/usr/bin/env stack
+-- stack --resolver lts-14.11 runghc --package minio-hs
+
+--
+-- MinIO Haskell SDK, (C) 2017, 2018 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 Network.Minio
+import Network.Minio.AdminAPI
+import Prelude
+
+main :: IO ()
+main = do
+  res <- runMinio minioPlayCI $
+    do
+      let config = "{\"version\":\"25\",\"credential\":{\"accessKey\":\"minio\",\"secretKey\":\"minio123\"},\"region\":\"\",\"browser\":\"on\",\"worm\":\"off\",\"domain\":\"\",\"storageclass\":{\"standard\":\"\",\"rrs\":\"\"},\"cache\":{\"drives\":[],\"expiry\":90,\"exclude\":[]},\"notify\":{\"amqp\":{\"2\":{\"enable\":false,\"url\":\"amqp://guest:guest@localhost:5672/\",\"exchange\":\"minio\",\"routingKey\":\"minio\",\"exchangeType\":\"direct\",\"deliveryMode\":0,\"mandatory\":false,\"immediate\":false,\"durable\":false,\"internal\":false,\"noWait\":false,\"autoDeleted\":false}},\"elasticsearch\":{\"1\":{\"enable\":false,\"format\":\"namespace\",\"url\":\"http://localhost:9200\",\"index\":\"minio_events\"}},\"kafka\":{\"1\":{\"enable\":false,\"brokers\":null,\"topic\":\"\"}},\"mqtt\":{\"1\":{\"enable\":false,\"broker\":\"\",\"topic\":\"\",\"qos\":0,\"clientId\":\"\",\"username\":\"\",\"password\":\"\",\"reconnectInterval\":0,\"keepAliveInterval\":0}},\"mysql\":{\"1\":{\"enable\":false,\"format\":\"namespace\",\"dsnString\":\"\",\"table\":\"\",\"host\":\"\",\"port\":\"\",\"user\":\"\",\"password\":\"\",\"database\":\"\"}},\"nats\":{\"1\":{\"enable\":false,\"address\":\"\",\"subject\":\"\",\"username\":\"\",\"password\":\"\",\"token\":\"\",\"secure\":false,\"pingInterval\":0,\"streaming\":{\"enable\":false,\"clusterID\":\"\",\"clientID\":\"\",\"async\":false,\"maxPubAcksInflight\":0}}},\"postgresql\":{\"1\":{\"enable\":false,\"format\":\"namespace\",\"connectionString\":\"\",\"table\":\"\",\"host\":\"\",\"port\":\"\",\"user\":\"\",\"password\":\"\",\"database\":\"\"}},\"redis\":{\"test1\":{\"enable\":true,\"format\":\"namespace\",\"address\":\"127.0.0.1:6379\",\"password\":\"\",\"key\":\"bucketevents_ns\"},\"test2\":{\"enable\":true,\"format\":\"access\",\"address\":\"127.0.0.1:6379\",\"password\":\"\",\"key\":\"bucketevents_log\"}},\"webhook\":{\"1\":{\"enable\":true,\"endpoint\":\"http://localhost:3000\"},\"2\":{\"enable\":true,\"endpoint\":\"http://localhost:3001\"}}}}"
+      setConfig config
+  print res

minio-hs.cabal

@@ -1,226 +1,352 @@
+cabal-version:       2.4
 name:                minio-hs
-version:             0.2.0
+version:             1.7.0
-synopsis:            A Minio client library, compatible with S3 like services.
+synopsis:            A MinIO Haskell Library for Amazon S3 compatible cloud
-description:         minio-hs provides simple APIs to access Minio and Amazon
+                     storage.
-                     S3 compatible object storage server. For more details,
+description:         The MinIO Haskell client library provides simple APIs to
-                     please see README.md.
+                     access MinIO, Amazon S3 and other API compatible cloud
+                     storage servers.
 homepage:            https://github.com/minio/minio-hs#readme
 license:             Apache-2.0
 license-file:        LICENSE
-author:              Aditya Manthramurthy, Krishnan Parthasarathi
+author:              MinIO Dev Team
-maintainer:          dev@minio.io
+maintainer:          dev@min.io
 category:            Network, AWS, Object Storage
 build-type:          Simple
 stability:           Experimental
--- extra-source-files:
+extra-doc-files:
-cabal-version:       >=1.10
+                   CHANGELOG.md
+                   CONTRIBUTING.md
+                   docs/API.md
+                   README.md
+extra-source-files:
+                   examples/*.hs
+                   stack.yaml
+tested-with:  GHC == 8.10.7
+                   , GHC == 9.0.2
+                   , GHC == 9.2.8
+                   , GHC == 9.4.8
+                   , GHC == 9.6.5
+                   , GHC == 9.8.2
 
-library
+source-repository head
-  hs-source-dirs:      src
+  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
-  exposed-modules:     Network.Minio
+                       -Wcompat
-                     , Network.Minio.S3API
+                       -Widentities
+                       -Wincomplete-uni-patterns
+                       -Wincomplete-record-updates
+                       -haddock
+  if impl(ghc >= 8.0)
+    ghc-options:       -Wredundant-constraints
+  if impl(ghc >= 8.2)
+    ghc-options:       -fhide-source-paths
+  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
+
+  default-extensions:  BangPatterns
+                     , DerivingStrategies
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , LambdaCase
+                     , MultiParamTypeClasses
+                     , MultiWayIf
+                     , OverloadedStrings
+                     , RankNTypes
+                     , ScopedTypeVariables
+                     , TupleSections
+
   other-modules:       Lib.Prelude
                      , Network.Minio.API
+                     , Network.Minio.APICommon
                      , Network.Minio.Data
                      , Network.Minio.Data.ByteString
                      , Network.Minio.Data.Crypto
                      , Network.Minio.Data.Time
+                     , Network.Minio.CopyObject
                      , Network.Minio.Errors
                      , Network.Minio.ListOps
+                     , Network.Minio.PresignedOperations
                      , Network.Minio.PutObject
+                     , Network.Minio.SelectAPI
                      , Network.Minio.Sign.V4
                      , 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)
+                     , relude
+
   build-depends:       base >= 4.7 && < 5
-                     , protolude >= 0.1.6 && < 0.2
+                     , relude >= 0.7 && < 2
-                     , async
+                     , aeson >= 1.2 && < 3
-                     , bytestring
+                     , base64-bytestring >= 1.0
-                     , case-insensitive
+                     , binary >= 0.8.5.0
-                     , conduit
+                     , bytestring >= 0.10
-                     , conduit-combinators
+                     , case-insensitive >= 1.2
-                     , conduit-extra
+                     , conduit >= 1.3
-                     , containers
+                     , conduit-extra >= 1.3
-                     , cryptonite
+                     , crypton-connection
-                     , cryptonite-conduit
+                     , cryptonite >= 0.25
-                     , data-default
+                     , cryptonite-conduit >= 0.2
-                     , exceptions
+                     , digest >= 0.0.1
-                     , filepath
+                     , directory
-                     , http-client
+                     , filepath >= 1.4
-                     , http-conduit
+                     , http-client >= 0.5
-                     , http-types
+                     , http-client-tls
-                     , lifted-async
+                     , http-conduit >= 2.3
-                     , lifted-base
+                     , http-types >= 0.12
-                     , memory
+                     , ini
-                     , monad-control
+                     , memory >= 0.14
-                     , resourcet
+                     , network-uri
-                     , text
+                     , resourcet >= 1.2
-                     , text-format
+                     , retry
-                     , time
+                     , text >= 1.2
-                     , transformers
+                     , time >= 1.9
-                     , transformers-base
+                     , time-units ^>= 1.0.0
-                     , xml-conduit
+                     , transformers >= 0.5
-  default-language:    Haskell2010
+                     , unliftio >= 0.2 && < 0.3
-  default-extensions:  FlexibleContexts
+                     , unliftio-core >= 0.2 && < 0.3
-                     , FlexibleInstances
+                     , unordered-containers >= 0.2
-                     , MultiParamTypeClasses
+                     , xml-conduit >= 1.8
-                     , MultiWayIf
+
-                     , NoImplicitPrelude
+library
-                     , OverloadedStrings
+  import:              base-settings
-                     , RankNTypes
+  hs-source-dirs:      src
-                     , ScopedTypeVariables
+  exposed-modules:     Network.Minio
-                     , TypeFamilies
+                     , Network.Minio.AdminAPI
-                     , TupleSections
+                     , Network.Minio.S3API
 
 Flag live-test
-  Default: True
+  Description: Build the test suite that runs against a live MinIO server
+  Default: False
   Manual: True
 
 test-suite minio-hs-live-server-test
+  import:              base-settings
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test, src
   main-is:             LiveServer.hs
   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N
-  default-language:    Haskell2010
+  other-modules:       Network.Minio
-  default-extensions:  FlexibleContexts
-                     , FlexibleInstances
-                     , OverloadedStrings
-                     , NoImplicitPrelude
-                     , MultiParamTypeClasses
-                     , MultiWayIf
-                     , ScopedTypeVariables
-                     , RankNTypes
-                     , TupleSections
-                     , TypeFamilies
-  other-modules:       Lib.Prelude
-                     , Network.Minio
-                     , Network.Minio.API
-                     , Network.Minio.Data
-                     , Network.Minio.Data.ByteString
-                     , Network.Minio.Data.Crypto
-                     , Network.Minio.Data.Time
-                     , Network.Minio.Errors
-                     , Network.Minio.ListOps
-                     , Network.Minio.PutObject
                      , Network.Minio.S3API
-                     , Network.Minio.Sign.V4
+                     , Network.Minio.AdminAPI
-                     , Network.Minio.Utils
+                     , Network.Minio.API.Test
-                     , Network.Minio.XmlGenerator
+                     , Network.Minio.JsonParser.Test
+                     , Network.Minio.TestHelpers
+                     , Network.Minio.Utils.Test
                      , Network.Minio.XmlGenerator.Test
-                     , Network.Minio.XmlParser
                      , Network.Minio.XmlParser.Test
-  build-depends:       base
+                     , Network.Minio.Credentials
-                     , minio-hs
+  build-depends:       minio-hs
-                     , protolude >= 0.1.6 && < 0.2
+                     , raw-strings-qq
-                     , async
-                     , bytestring
-                     , case-insensitive
-                     , conduit
-                     , conduit-combinators
-                     , conduit-extra
-                     , containers
-                     , cryptonite
-                     , cryptonite-conduit
-                     , data-default
-                     , directory
-                     , exceptions
-                     , filepath
-                     , http-client
-                     , http-conduit
-                     , http-types
-                     , lifted-async
-                     , lifted-base
-                     , memory
-                     , monad-control
-                     , QuickCheck
-                     , resourcet
                      , tasty
                      , tasty-hunit
                      , tasty-quickcheck
                      , tasty-smallcheck
-                     , temporary
+                     , QuickCheck
-                     , text
-                     , text-format
-                     , time
-                     , transformers
-                     , transformers-base
-                     , xml-conduit
   if !flag(live-test)
     buildable: False
 
 test-suite minio-hs-test
+  import:              base-settings
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test, src
   main-is:             Spec.hs
-  build-depends:       base
+  build-depends:       minio-hs
-                     , minio-hs
+                     , raw-strings-qq
-                     , protolude >= 0.1.6 && < 0.2
-                     , async
-                     , bytestring
-                     , case-insensitive
-                     , conduit
-                     , conduit-combinators
-                     , conduit-extra
-                     , containers
-                     , cryptonite
-                     , cryptonite-conduit
-                     , data-default
-                     , directory
-                     , exceptions
-                     , filepath
-                     , http-client
-                     , http-conduit
-                     , http-types
-                     , lifted-async
-                     , lifted-base
-                     , memory
-                     , monad-control
                      , QuickCheck
-                     , resourcet
                      , tasty
                      , tasty-hunit
                      , tasty-quickcheck
                      , tasty-smallcheck
-                     , temporary
-                     , text
-                     , text-format
-                     , time
-                     , transformers
-                     , transformers-base
-                     , xml-conduit
   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N
-  -- ghc-options:         -Wall
-  default-language:    Haskell2010
-  default-extensions:  FlexibleContexts
-                     , FlexibleInstances
-                     , OverloadedStrings
-                     , NoImplicitPrelude
-                     , MultiParamTypeClasses
-                     , MultiWayIf
-                     , ScopedTypeVariables
-                     , RankNTypes
-                     , TupleSections
-                     , TypeFamilies
   other-modules:       Lib.Prelude
                      , Network.Minio
-                     , Network.Minio.API
-                     , Network.Minio.Data
-                     , Network.Minio.Data.ByteString
-                     , Network.Minio.Data.Crypto
-                     , Network.Minio.Data.Time
-                     , Network.Minio.Errors
-                     , Network.Minio.ListOps
-                     , Network.Minio.PutObject
                      , Network.Minio.S3API
-                     , Network.Minio.Sign.V4
+                     , Network.Minio.AdminAPI
-                     , Network.Minio.Utils
+                     , Network.Minio.TestHelpers
-                     , Network.Minio.XmlGenerator
+                     , Network.Minio.API.Test
+                     , Network.Minio.JsonParser.Test
+                     , Network.Minio.Utils.Test
                      , Network.Minio.XmlGenerator.Test
-                     , Network.Minio.XmlParser
                      , Network.Minio.XmlParser.Test
+                     , Network.Minio.Credentials
 
+Flag examples
+  Description: Build the examples
+  Default: False
+  Manual: True
 
-source-repository head
+common examples-settings
-  type:     git
+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N
-  location: https://github.com/minio/minio-hs
+  default-language:    Haskell2010
+  default-extensions:  OverloadedStrings
+  build-depends:       base >= 4.7 && < 5
+                     , bytestring
+                     , case-insensitive
+                     , conduit
+                     , conduit-extra
+                     , filepath
+                     , minio-hs
+                     , optparse-applicative
+                     , text
+                     , time
+                     , unliftio
+                     , unordered-containers
+  hs-source-dirs:      examples
+  if !flag(examples)
+    buildable: False
+
+executable BucketExists
+  import:              examples-settings
+  scope:               private
+  main-is:             BucketExists.hs
+
+executable CopyObject
+  import:              examples-settings
+  scope:               private
+  main-is:             CopyObject.hs
+
+executable FileUploader
+  import:              examples-settings
+  scope:               private
+  main-is:             FileUploader.hs
+
+executable GetConfig
+  import:              examples-settings
+  scope:               private
+  main-is:             GetConfig.hs
+
+executable GetObject
+  import:              examples-settings
+  scope:               private
+  main-is:             GetObject.hs
+
+executable HeadObject
+  import:              examples-settings
+  scope:               private
+  main-is:             HeadObject.hs
+
+executable Heal
+  import:              examples-settings
+  scope:               private
+  main-is:             Heal.hs
+
+executable ListBuckets
+  import:              examples-settings
+  scope:               private
+  main-is:             ListBuckets.hs
+
+executable ListIncompleteUploads
+  import:              examples-settings
+  scope:               private
+  main-is:             ListIncompleteUploads.hs
+
+executable ListObjects
+  import:              examples-settings
+  scope:               private
+  main-is:             ListObjects.hs
+
+executable MakeBucket
+  import:              examples-settings
+  scope:               private
+  main-is:             MakeBucket.hs
+
+executable PresignedGetObject
+  import:              examples-settings
+  scope:               private
+  main-is:             PresignedGetObject.hs
+
+executable PresignedPostPolicy
+  import:              examples-settings
+  scope:               private
+  main-is:             PresignedPostPolicy.hs
+
+executable PresignedPutObject
+  import:              examples-settings
+  scope:               private
+  main-is:             PresignedPutObject.hs
+
+executable PutObject
+  import:              examples-settings
+  scope:               private
+  main-is:             PutObject.hs
+
+executable RemoveBucket
+  import:              examples-settings
+  scope:               private
+  main-is:             RemoveBucket.hs
+
+executable RemoveIncompleteUpload
+  import:              examples-settings
+  scope:               private
+  main-is:             RemoveIncompleteUpload.hs
+
+executable RemoveObject
+  import:              examples-settings
+  scope:               private
+  main-is:             RemoveObject.hs
+
+executable SelectObject
+  import:              examples-settings
+  scope:               private
+  main-is:             SelectObject.hs
+
+executable ServerInfo
+  import:              examples-settings
+  scope:               private
+  main-is:             ServerInfo.hs
+
+executable ServiceSendRestart
+  import:              examples-settings
+  scope:               private
+  main-is:             ServiceSendRestart.hs
+
+executable ServiceSendStop
+  import:              examples-settings
+  scope:               private
+  main-is:             ServiceSendStop.hs
+
+executable ServiceStatus
+  import:              examples-settings
+  scope:               private
+  main-is:             ServiceStatus.hs
+
+executable SetConfig
+  import:              examples-settings
+  scope:               private
+  main-is:             SetConfig.hs
+
+executable AssumeRole
+  import:              examples-settings
+  scope:               private
+  main-is:             AssumeRole.hs

src/Lib/Prelude.hs

@@ -1,5 +1,5 @@
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- 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.
@@ -14,36 +14,42 @@
 -- limitations under the License.
 --
 
-{-
-Welcome to your custom Prelude
-Export here everything that should always be in your library scope
-For more info on what is exported by Protolude check:
-https://github.com/sdiehl/protolude/blob/master/Symbols.md
--}
 module Lib.Prelude
-    ( module Exports
+  ( module Exports,
-    , both
+    both,
+    showBS,
+    toStrictBS,
+    fromStrictBS,
+    lastMay,
+  )
+where
 
-    , format
+import Control.Monad.Trans.Maybe as Exports (MaybeT (..), runMaybeT)
-    ) where
+import qualified Data.ByteString.Lazy as LB
-
+import Data.Time as Exports
-import           Protolude as Exports
+  ( UTCTime (..),
-
+    diffUTCTime,
-import           Data.Time as Exports (UTCTime(..), diffUTCTime)
+  )
-import           Control.Monad.Trans.Maybe as Exports (runMaybeT, MaybeT(..))
+import UnliftIO as Exports
-
+  ( Handler,
-import           Control.Monad.Catch as Exports (throwM, MonadThrow, MonadCatch)
+    catch,
-
+    catches,
-import           Data.Text.Format as Exports (Shown(..))
+    throwIO,
-import qualified Data.Text.Format as TF
+    try,
-import           Data.Text.Format.Params (Params)
+  )
-import qualified Data.Text.Lazy as LT
-
-format :: Params ps => TF.Format -> ps -> Text
-format f args = LT.toStrict $ TF.format f args
-
--- import Data.Tuple as Exports (uncurry)
 
 -- | Apply a function on both elements of a pair
 both :: (a -> b) -> (a, a) -> (b, b)
 both f (a, b) = (f a, f b)
+
+showBS :: (Show a) => a -> ByteString
+showBS a = encodeUtf8 (show a :: Text)
+
+toStrictBS :: LByteString -> ByteString
+toStrictBS = LB.toStrict
+
+fromStrictBS :: ByteString -> LByteString
+fromStrictBS = LB.fromStrict
+
+lastMay :: [a] -> Maybe a
+lastMay a = last <$> nonEmpty a

src/Network/Minio.hs

@@ -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.
@@ -14,81 +14,239 @@
 -- limitations under the License.
 --
 
+-- |
+-- Module:      Network.Minio
+-- Copyright:   (c) 2017-2023 MinIO Dev Team
+-- License:     Apache 2.0
+-- Maintainer:  MinIO Dev Team <dev@min.io>
+--
+-- Types and functions to conveniently access S3 compatible object
+-- storage servers like MinIO.
 module Network.Minio
-  (
+  ( -- * Credentials
+    CredentialValue (..),
+    credentialValueText,
+    AccessKey (..),
+    SecretKey (..),
+    SessionToken (..),
 
-    ConnectInfo(..)
+    -- ** Credential Loaders
-  , awsCI
-  , awsWithRegionCI
-  , minioPlayCI
-  , minioCI
 
-  , Minio
+    -- | Run actions that retrieve 'CredentialValue's from the environment or
-  , runMinio
+    -- files or other custom sources.
-  , runResourceT
+    CredentialLoader,
-  , def
+    fromAWSConfigFile,
+    fromAWSEnv,
+    fromMinioEnv,
+    findFirst,
 
-  -- * Error handling
+    -- * Connecting to object storage
-  -----------------------
+    ConnectInfo,
-  -- | Data types representing various errors that may occur while working
+    setRegion,
-  -- with an object storage service.
+    setCreds,
-  , MinioErr(..)
+    setCredsFrom,
-  , MErrV(..)
+    isConnectInfoSecure,
-  , ServiceErr(..)
+    disableTLSCertValidation,
+    MinioConn,
+    mkMinioConn,
+
+    -- ** Connection helpers
+
+    -- | These are helpers to construct 'ConnectInfo' values for common
+    -- cases.
+    minioPlayCI,
+    awsCI,
+    gcsCI,
+
+    -- ** STS Credential types
+    STSAssumeRole (..),
+    STSAssumeRoleOptions (..),
+    defaultSTSAssumeRoleOptions,
+    requestSTSCredential,
+    setSTSCredential,
+    ExpiryTime (..),
+    STSCredentialProvider,
+
+    -- * Minio Monad
 
-  -- * Data Types
     ----------------
-  -- | Data types representing various object store concepts.
+
-  , Bucket
+    -- | The Minio Monad provides connection-reuse, bucket-location
-  , Object
+    -- caching, resource management and simpler error handling
-  , BucketInfo(..)
+    -- functionality. All actions on object storage are performed within
-  , ObjectInfo(..)
+    -- this Monad.
-  , UploadInfo(..)
+    Minio,
-  , ObjectPartInfo(..)
+    runMinioWith,
-  , UploadId
+    runMinio,
-  , ObjectData(..)
+    runMinioResWith,
-  , CopyPartSource(..)
+    runMinioRes,
 
     -- * Bucket Operations
-  ----------------------
-  , listBuckets
-  , getLocation
-  , makeBucket
-  , removeBucket
 
-  , listObjects
+    -- ** Creation, removal and querying
-  , listIncompleteUploads
+    Bucket,
+    makeBucket,
+    removeBucket,
+    bucketExists,
+    Region,
+    getLocation,
+
+    -- ** Listing buckets
+    BucketInfo (..),
+    listBuckets,
+
+    -- ** Listing objects
+    listObjects,
+    listObjectsV1,
+    ListItem (..),
+    ObjectInfo,
+    oiObject,
+    oiModTime,
+    oiETag,
+    oiSize,
+    oiUserMetadata,
+    oiMetadata,
+
+    -- ** Listing incomplete uploads
+    listIncompleteUploads,
+    UploadId,
+    UploadInfo (..),
+    listIncompleteParts,
+    ObjectPartInfo (..),
+
+    -- ** Bucket Notifications
+    getBucketNotification,
+    putBucketNotification,
+    removeAllBucketNotification,
+    Notification (..),
+    defaultNotification,
+    NotificationConfig (..),
+    Arn,
+    Event (..),
+    Filter (..),
+    defaultFilter,
+    FilterKey (..),
+    defaultFilterKey,
+    FilterRules (..),
+    defaultFilterRules,
+    FilterRule (..),
 
     -- * Object Operations
-  ----------------------
+    Object,
-  , fGetObject
-  , fPutObject
-  , putObject
-  , copyObject
-  , removeObject
 
-  , getObject
+    -- ** File-based operations
-  , statObject
+    fGetObject,
+    fPutObject,
 
-  ) where
+    -- ** Conduit-based streaming operations
+    putObject,
+    PutObjectOptions,
+    defaultPutObjectOptions,
+    pooContentType,
+    pooContentEncoding,
+    pooContentDisposition,
+    pooContentLanguage,
+    pooCacheControl,
+    pooStorageClass,
+    pooUserMetadata,
+    pooNumThreads,
+    pooSSE,
+    getObject,
+    GetObjectOptions,
+    defaultGetObjectOptions,
+    gooRange,
+    gooIfMatch,
+    gooIfNoneMatch,
+    gooIfModifiedSince,
+    gooIfUnmodifiedSince,
+    gooSSECKey,
+    GetObjectResponse,
+    gorObjectInfo,
+    gorObjectStream,
+
+    -- ** Server-side object copying
+    copyObject,
+    SourceInfo,
+    defaultSourceInfo,
+    srcBucket,
+    srcObject,
+    srcRange,
+    srcIfMatch,
+    srcIfNoneMatch,
+    srcIfModifiedSince,
+    srcIfUnmodifiedSince,
+    DestinationInfo,
+    defaultDestinationInfo,
+    dstBucket,
+    dstObject,
+
+    -- ** Querying object info
+    statObject,
+
+    -- ** Object removal operations
+    removeObject,
+    removeIncompleteUpload,
+
+    -- ** Select Object Content with SQL
+    module Network.Minio.SelectAPI,
+
+    -- * Server-Side Encryption Helpers
+    mkSSECKey,
+    SSECKey,
+    SSE (..),
+
+    -- * Presigned Operations
+    presignedPutObjectUrl,
+    presignedGetObjectUrl,
+    presignedHeadObjectUrl,
+    UrlExpiry,
+
+    -- ** POST (browser) upload helpers
+
+    -- | Please see
+    -- https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-HTTPPOSTConstructPolicy.html
+    -- for detailed information.
+    newPostPolicy,
+    presignedPostPolicy,
+    showPostPolicy,
+    PostPolicy,
+    PostPolicyError (..),
+
+    -- *** Post Policy condition helpers
+    PostPolicyCondition,
+    ppCondBucket,
+    ppCondContentLengthRange,
+    ppCondContentType,
+    ppCondKey,
+    ppCondKeyStartsWith,
+    ppCondSuccessActionStatus,
+
+    -- * Error handling
+
+    -- | Data types representing various errors that may occur while
+    -- working with an object storage service.
+    MinioErr (..),
+    MErrV (..),
+    ServiceErr (..),
+  )
+where
 
 {-
-This module exports the high-level Minio API for object storage.
+This module exports the high-level MinIO API for object storage.
 -}
 
-import           Control.Monad.Trans.Resource (runResourceT)
 import qualified Data.Conduit as C
 import qualified Data.Conduit.Binary as CB
-import           Data.Default (def)
+import qualified Data.Conduit.Combinators as CC
-import qualified Data.Map as Map
+import Network.Minio.API
-
+import Network.Minio.CopyObject
-import           Lib.Prelude
+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
 
 -- | Lists buckets.
 listBuckets :: Minio [BucketInfo]
@@ -97,55 +255,91 @@ listBuckets = getService
 -- | Fetch the object and write it to the given file safely. The
 -- object is first written to a temporary file in the same directory
 -- and then moved to the given path.
-fGetObject :: Bucket -> Object -> FilePath -> Minio ()
+fGetObject :: Bucket -> Object -> FilePath -> GetObjectOptions -> Minio ()
-fGetObject bucket object fp = do
+fGetObject bucket object fp opts = do
-  src <- getObject bucket object
+  src <- getObject bucket object opts
-  src C.$$+- CB.sinkFileCautious fp
+  C.connect (gorObjectStream src) $ CB.sinkFileCautious fp
 
 -- | Upload the given file to the given object.
-fPutObject :: Bucket -> Object -> FilePath -> Minio ()
+fPutObject ::
-fPutObject bucket object f = void $ putObjectInternal bucket object $
+  Bucket ->
-                             ODFile f Nothing
+  Object ->
+  FilePath ->
+  PutObjectOptions ->
+  Minio ()
+fPutObject bucket object f opts =
+  void $ putObjectInternal bucket object opts $ ODFile f Nothing
 
 -- | Put an object from a conduit source. The size can be provided if
 -- known; this helps the library select optimal part sizes to perform
 -- a multipart upload. If not specified, it is assumed that the object
 -- can be potentially 5TiB and selects multipart sizes appropriately.
-putObject :: Bucket -> Object -> C.Producer Minio ByteString
+putObject ::
-          -> Maybe Int64 -> Minio ()
+  Bucket ->
-putObject bucket object src sizeMay =
+  Object ->
-  void $ putObjectInternal bucket object $ ODStream src sizeMay
+  C.ConduitM () ByteString Minio () ->
+  Maybe Int64 ->
+  PutObjectOptions ->
+  Minio ()
+putObject bucket object src sizeMay opts =
+  void $ putObjectInternal bucket object opts $ ODStream src sizeMay
 
--- | Perform a server-side copy operation to create an object with the
+-- | Perform a server-side copy operation to create an object based on
--- given bucket and object name from the source specification in
+-- the destination specification in DestinationInfo from the source
--- CopyPartSource. This function performs a multipart copy operation
+-- specification in SourceInfo. This function performs a multipart
--- if the new object is to be greater than 5GiB in size.
+-- copy operation if the new object is to be greater than 5GiB in
-copyObject :: Bucket -> Object -> CopyPartSource -> Minio ()
+-- size.
-copyObject bucket object cps = void $ copyObjectInternal bucket object cps
+copyObject :: DestinationInfo -> SourceInfo -> Minio ()
+copyObject dstInfo srcInfo =
+  void $
+    copyObjectInternal
+      (dstBucket dstInfo)
+      (dstObject dstInfo)
+      srcInfo
 
 -- | Remove an object from the object store.
 removeObject :: Bucket -> Object -> Minio ()
 removeObject = deleteObject
 
--- | Get an object from the object store as a resumable source (conduit).
+-- | Get an object from the object store.
-getObject :: Bucket -> Object -> Minio (C.ResumableSource Minio ByteString)
+getObject ::
-getObject bucket object = snd <$> getObject' bucket object [] []
+  Bucket ->
+  Object ->
+  GetObjectOptions ->
+  Minio GetObjectResponse
+getObject bucket object opts =
+  getObject' bucket object [] $ gooToHeaders opts
 
--- | Get an object's metadata from the object store.
+-- | Get an object's metadata from the object store. It accepts the
-statObject :: Bucket -> Object -> Minio ObjectInfo
+-- same options as GetObject.
-statObject bucket object = headObject bucket object
+statObject :: Bucket -> Object -> GetObjectOptions -> Minio ObjectInfo
+statObject b o opts = headObject b o $ gooToHeaders opts
 
 -- | Creates a new bucket in the object store. The Region can be
 -- optionally specified. If not specified, it will use the region
 -- configured in ConnectInfo, which is by default, the US Standard
 -- Region.
 makeBucket :: Bucket -> Maybe Region -> Minio ()
-makeBucket bucket regionMay= do
+makeBucket bucket regionMay = do
   region <- maybe (asks $ connectRegion . mcConnInfo) return regionMay
   putBucket bucket region
-  modify (Map.insert bucket region)
+  addToRegionCache bucket region
 
+-- | Removes a bucket from the object store.
 removeBucket :: Bucket -> Minio ()
 removeBucket bucket = do
   deleteBucket bucket
-  modify (Map.delete bucket)
+  deleteFromRegionCache bucket
+
+-- | Query the object store if a given bucket is present.
+bucketExists :: Bucket -> Minio Bool
+bucketExists = headBucket
+
+-- | Removes an ongoing multipart upload of an object.
+removeIncompleteUpload :: Bucket -> Object -> Minio ()
+removeIncompleteUpload bucket object = do
+  uploads <-
+    C.runConduit $
+      listIncompleteUploads bucket (Just object) False
+        C..| CC.sinkList
+  mapM_ (abortMultipartUpload bucket object) (uiUploadId <$> uploads)

src/Network/Minio/API.hs

@@ -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.
@@ -15,137 +15,340 @@
 --
 
 module Network.Minio.API
-  (
+  ( connect,
-    connect
+    S3ReqInfo (..),
-  , RequestInfo(..)
+    runMinio,
-  , runMinio
+    executeRequest,
-  , executeRequest
+    buildRequest,
-  , mkStreamRequest
+    mkStreamRequest,
-  , getLocation
+    getLocation,
-  ) where
+    isValidBucketName,
+    checkBucketNameValidity,
+    isValidObjectName,
+    checkObjectNameValidity,
+    requestSTSCredential,
+  )
+where
 
+import Control.Retry
+  ( fullJitterBackoff,
+    limitRetriesByCumulativeDelay,
+    retrying,
+  )
+import qualified Data.ByteString as B
+import qualified Data.Char as C
 import qualified Data.Conduit as C
-import           Data.Conduit.Binary (sourceHandleRange)
+import qualified Data.HashMap.Strict as H
-import           Data.Default (def)
-import qualified Data.Map as Map
 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           Lib.Prelude
+import Network.Minio.APICommon
-
+import Network.Minio.Credentials
 import Network.Minio.Data
-import           Network.Minio.Data.Crypto
 import Network.Minio.Errors
 import Network.Minio.Sign.V4
 import Network.Minio.Utils
 import Network.Minio.XmlParser
 
-sha256Header :: ByteString -> HT.Header
-sha256Header = ("x-amz-content-sha256", )
-
-getPayloadSHA256Hash :: (MonadIO m) => Payload -> m ByteString
-getPayloadSHA256Hash (PayloadBS bs) = return $ hashSHA256 bs
-getPayloadSHA256Hash (PayloadH h off size) = hashSHA256FromSource $
-  sourceHandleRange h
-    (return . fromIntegral $ off)
-    (return . fromIntegral $ size)
-
-getRequestBody :: Payload -> NC.RequestBody
-getRequestBody (PayloadBS bs) = NC.RequestBodyBS bs
-getRequestBody (PayloadH h off size) =
-  NC.requestBodySource (fromIntegral size) $
-    sourceHandleRange h
-      (return . fromIntegral $ off)
-      (return . fromIntegral $ size)
-
-
 -- | Fetch bucket location (region)
 getLocation :: Bucket -> Minio Region
 getLocation bucket = do
-  resp <- executeRequest $ def {
+  resp <-
-      riBucket = Just bucket
+    executeRequest $
-    , riQueryParams = [("location", Nothing)]
+      defaultS3ReqInfo
-    , riNeedsLocation = False
+        { riBucket = Just bucket,
+          riQueryParams = [("location", Nothing)],
+          riNeedsLocation = False
         }
   parseLocation $ NC.responseBody resp
 
-
 -- | Looks for region in RegionMap and updates it using getLocation if
 -- absent.
-discoverRegion :: RequestInfo -> Minio (Maybe Region)
+discoverRegion :: S3ReqInfo -> Minio (Maybe Region)
 discoverRegion ri = runMaybeT $ do
   bucket <- MaybeT $ return $ riBucket ri
-  regionMay <- gets (Map.lookup bucket)
+  regionMay <- lift $ lookupRegionCache bucket
-  maybe (do
+  maybe
+    ( do
         l <- lift $ getLocation bucket
-            modify $ Map.insert bucket l
+        lift $ addToRegionCache bucket l
         return l
-        ) return regionMay
+    )
+    return
+    regionMay
 
-
+-- | Returns the region to be used for the request.
-buildRequest :: RequestInfo -> Minio NC.Request
+getRegion :: S3ReqInfo -> Minio (Maybe Region)
-buildRequest ri = do
+getRegion ri = do
-  {-
-    If ListBuckets/MakeBucket/GetLocation then use connectRegion ci
-    Else If discovery off use connectRegion ci
-    Else {
-
-    // Here discovery is on
-    Lookup region in regionMap
-    If present use that
-    Else getLocation
-    }
-  -}
   ci <- asks mcConnInfo
-  region <- if | not $ riNeedsLocation ri -> -- getService/makeBucket/getLocation
+
-                                             -- don't need location
+  -- getService/makeBucket/getLocation -- don't need location
+  if
+      | not $ riNeedsLocation ri ->
           return $ Just $ connectRegion ci
-               | not $ connectAutoDiscoverRegion ci -> -- if autodiscovery of location is disabled by user
+      -- if autodiscovery of location is disabled by user
+      | not $ connectAutoDiscoverRegion ci ->
           return $ Just $ connectRegion ci
+      -- discover the region for the request
       | otherwise -> discoverRegion ri
 
-  regionHost <- case region of
+getRegionHost :: Region -> Minio Text
-    Nothing ->  return $ connectHost ci
+getRegionHost r = do
-    Just r -> if "amazonaws.com" `T.isSuffixOf` (connectHost ci)
+  ci <- asks mcConnInfo
-              then maybe
+
-                   (throwM $ MErrVRegionNotSupported r)
+  if "amazonaws.com" `T.isSuffixOf` connectHost ci
+    then
+      maybe
+        (throwIO $ MErrVRegionNotSupported r)
         return
-                   (Map.lookup r awsRegionMap)
+        (H.lookup r awsRegionMap)
     else return $ connectHost ci
 
+-- | Computes the appropriate host, path and region for the request.
+--
+-- For AWS, always use virtual bucket style, unless bucket has periods. For
+-- MinIO and other non-AWS, default to path style.
+getHostPathRegion :: S3ReqInfo -> Minio (Text, ByteString, Maybe Region)
+getHostPathRegion ri = do
+  ci <- asks mcConnInfo
+  regionMay <- getRegion ri
+  case riBucket ri of
+    Nothing ->
+      -- Implies a ListBuckets request.
+      return (connectHost ci, "/", regionMay)
+    Just bucket -> do
+      regionHost <- case regionMay of
+        Nothing -> return $ connectHost ci
+        Just "" -> return $ connectHost ci
+        Just r -> getRegionHost r
+      let pathStyle =
+            ( regionHost,
+              getS3Path (riBucket ri) (riObject ri),
+              regionMay
+            )
+          virtualStyle =
+            ( bucket <> "." <> regionHost,
+              encodeUtf8 $ "/" <> fromMaybe "" (riObject ri),
+              regionMay
+            )
+      ( if isAWSConnectInfo ci
+          then
+            return $
+              if bucketHasPeriods bucket
+                then pathStyle
+                else virtualStyle
+          else return pathStyle
+        )
 
-  sha256Hash <- getPayloadSHA256Hash (riPayload ri)
+-- | requestSTSCredential requests temporary credentials using the Security Token
-  let newRi = ri { riPayloadHash = sha256Hash
+-- Service API. The returned credential will include a populated 'SessionToken'
-                 , riHeaders = sha256Header sha256Hash : (riHeaders ri)
+-- and an 'ExpiryTime'.
-                 , riRegion = region
+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
+  maybe (return ()) checkObjectNameValidity $ riObject ri
+
+  ci <- asks mcConnInfo
+
+  (host, path, regionMay) <- getHostPathRegion ri
+
+  let ci' = ci {connectHost = host}
+      hostHeader = (hHost, getHostAddr ci')
+      ri' =
+        ri
+          { riHeaders = hostHeader : riHeaders ri,
+            riRegion = regionMay
           }
-      newCi = ci { connectHost = regionHost }
+      -- Does not contain body and auth info.
-
+      baseRequest =
-  reqHeaders <- liftIO $ signV4 newCi newRi
+        NC.defaultRequest
-
+          { NC.method = riMethod ri',
-  return NC.defaultRequest {
+            NC.secure = connectIsSecure ci',
-      NC.method = riMethod newRi
+            NC.host = encodeUtf8 $ connectHost ci',
-    , NC.secure = connectIsSecure newCi
+            NC.port = connectPort ci',
-    , NC.host = encodeUtf8 $ connectHost newCi
+            NC.path = path,
-    , NC.port = connectPort newCi
+            NC.requestHeaders = riHeaders ri',
-    , NC.path = getPathFromRI newRi
+            NC.queryString = HT.renderQuery False $ riQueryParams ri'
-    , NC.queryString = HT.renderQuery False $ riQueryParams newRi
-    , NC.requestHeaders = reqHeaders
-    , NC.requestBody = getRequestBody (riPayload newRi)
           }
 
-executeRequest :: RequestInfo -> Minio (Response LByteString)
+  timeStamp <- liftIO Time.getCurrentTime
+
+  mgr <- asks mcConnManager
+  cv <- liftIO $ getCredential (connectCreds ci') (getEndpoint ci') mgr
+
+  let sp =
+        SignParams
+          (coerce $ cvAccessKey cv)
+          (coerce $ cvSecretKey cv)
+          (coerce $ cvSessionToken cv)
+          ServiceS3
+          timeStamp
+          (riRegion ri')
+          (riPresignExpirySecs ri')
+          Nothing
+
+  -- Cases to handle:
+  --
+  -- 0. Handle presign URL case.
+  --
+  -- 1. Connection is secure: use unsigned payload
+  --
+  -- 2. Insecure connection, streaming signature is enabled via use of
+  --    conduit payload: use streaming signature for request.
+  --
+  -- 3. Insecure connection, non-conduit payload: compute payload
+  -- sha256hash, buffer request in memory and perform request.
+
+  if
+      | isJust (riPresignExpirySecs ri') ->
+          -- case 0 from above.
+          do
+            let signPairs = signV4QueryParams sp baseRequest
+                qpToAdd = simpleQueryToQuery signPairs
+                existingQueryParams = HT.parseQuery (NC.queryString baseRequest)
+                updatedQueryParams = existingQueryParams ++ qpToAdd
+            return $ NClient.setQueryString updatedQueryParams baseRequest
+      | isStreamingPayload (riPayload ri') && not (connectIsSecure ci') ->
+          -- case 2 from above.
+          do
+            (pLen, pSrc) <- case riPayload ri of
+              PayloadC l src -> return (l, src)
+              _ -> throwIO MErrVUnexpectedPayload
+            let reqFn = signV4Stream pLen sp baseRequest
+            return $ reqFn pSrc
+      | otherwise ->
+          do
+            sp' <-
+              ( if connectIsSecure ci'
+                  then -- case 1 described above.
+                    return sp
+                  else
+                    ( -- case 3 described above.
+                      do
+                        pHash <- getPayloadSHA256Hash $ riPayload ri'
+                        return $ sp {spPayloadHash = Just pHash}
+                    )
+                )
+
+            let signHeaders = signV4 sp' baseRequest
+            return $
+              baseRequest
+                { NC.requestHeaders =
+                    NC.requestHeaders baseRequest ++ signHeaders,
+                  NC.requestBody = getRequestBody (riPayload ri')
+                }
+
+retryAPIRequest :: Minio a -> Minio a
+retryAPIRequest apiCall = do
+  resE <-
+    retrying retryPolicy (const shouldRetry) $
+      const $
+        try apiCall
+  either throwIO return resE
+  where
+    -- Retry using the full-jitter backoff method for up to 10 mins
+    -- total
+    retryPolicy =
+      limitRetriesByCumulativeDelay tenMins $
+        fullJitterBackoff oneMilliSecond
+    oneMilliSecond = 1000 -- in microseconds
+    tenMins = 10 * 60 * 1000000 -- in microseconds
+    -- retry on connection related failure
+    shouldRetry :: Either NC.HttpException a -> Minio Bool
+    shouldRetry resE =
+      case resE of
+        -- API request returned successfully
+        Right _ -> return False
+        -- API request failed with a retryable exception
+        Left httpExn@(NC.HttpExceptionRequest _ exn) ->
+          case (exn :: NC.HttpExceptionContent) of
+            NC.ResponseTimeout -> return True
+            NC.ConnectionTimeout -> return True
+            NC.ConnectionFailure _ -> return True
+            -- We received an unexpected exception
+            _ -> throwIO httpExn
+        -- We received an unexpected exception
+        Left someOtherExn -> throwIO someOtherExn
+
+executeRequest :: S3ReqInfo -> Minio (Response LByteString)
 executeRequest ri = do
   req <- buildRequest ri
   mgr <- asks mcConnManager
-  httpLbs req mgr
+  retryAPIRequest $ httpLbs req mgr
 
-
+mkStreamRequest ::
-mkStreamRequest :: RequestInfo
+  S3ReqInfo ->
-                -> Minio (Response (C.ResumableSource Minio ByteString))
+  Minio (Response (C.ConduitM () ByteString Minio ()))
 mkStreamRequest ri = do
   req <- buildRequest ri
   mgr <- asks mcConnManager
-  http req mgr
+  retryAPIRequest $ http req mgr
+
+-- Bucket name validity check according to AWS rules.
+isValidBucketName :: Bucket -> Bool
+isValidBucketName bucket =
+  not
+    ( or
+        [ len < 3 || len > 63,
+          any labelCheck labels,
+          any labelCharsCheck labels,
+          isIPCheck
+        ]
+    )
+  where
+    len = T.length bucket
+    labels = T.splitOn "." bucket
+    -- does label `l` fail basic checks of length and start/end?
+    labelCheck l = T.length l == 0 || T.head l == '-' || T.last l == '-'
+    -- does label `l` have non-allowed characters?
+    labelCharsCheck l =
+      isJust $
+        T.find
+          ( \x ->
+              not
+                ( C.isAsciiLower x
+                    || x == '-'
+                    || C.isDigit x
+                )
+          )
+          l
+    -- does label `l` have non-digit characters?
+    labelNonDigits l = isJust $ T.find (not . C.isDigit) l
+    labelAsNums = map (not . labelNonDigits) labels
+    -- check if bucket name looks like an IP
+    isIPCheck = and labelAsNums && length labelAsNums == 4
+
+-- Throws exception iff bucket name is invalid according to AWS rules.
+checkBucketNameValidity :: (MonadIO m) => Bucket -> m ()
+checkBucketNameValidity bucket =
+  unless (isValidBucketName bucket) $
+    throwIO $
+      MErrVInvalidBucketName bucket
+
+isValidObjectName :: Object -> Bool
+isValidObjectName object =
+  T.length object > 0 && B.length (encodeUtf8 object) <= 1024
+
+checkObjectNameValidity :: (MonadIO m) => Object -> m ()
+checkObjectNameValidity object =
+  unless (isValidObjectName object) $
+    throwIO $
+      MErrVInvalidObjectName object

src/Network/Minio/APICommon.hs

@@ -0,0 +1,80 @@
+--
+-- MinIO Haskell SDK, (C) 2018 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.APICommon where
+
+import qualified Conduit as C
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LB
+import Data.Conduit.Binary (sourceHandleRange)
+import qualified Data.Text as T
+import Lib.Prelude
+import qualified Network.HTTP.Conduit as NC
+import qualified Network.HTTP.Types as HT
+import Network.Minio.Data
+import Network.Minio.Data.Crypto
+import Network.Minio.Errors
+
+sha256Header :: ByteString -> HT.Header
+sha256Header = ("x-amz-content-sha256",)
+
+-- | This function throws an error if the payload is a conduit (as it
+-- will not be possible to re-read the conduit after it is consumed).
+getPayloadSHA256Hash :: Payload -> Minio ByteString
+getPayloadSHA256Hash (PayloadBS bs) = return $ hashSHA256 bs
+getPayloadSHA256Hash (PayloadH h off size) =
+  hashSHA256FromSource $
+    sourceHandleRange
+      h
+      (return . fromIntegral $ off)
+      (return . fromIntegral $ size)
+getPayloadSHA256Hash (PayloadC _ _) = throwIO MErrVUnexpectedPayload
+
+getRequestBody :: Payload -> NC.RequestBody
+getRequestBody (PayloadBS bs) = NC.RequestBodyBS bs
+getRequestBody (PayloadH h off size) =
+  NC.requestBodySource size $
+    sourceHandleRange
+      h
+      (return . fromIntegral $ off)
+      (return . fromIntegral $ size)
+getRequestBody (PayloadC n src) = NC.requestBodySource n src
+
+mkStreamingPayload :: Payload -> Payload
+mkStreamingPayload payload =
+  case payload of
+    PayloadBS bs ->
+      PayloadC
+        (fromIntegral $ BS.length bs)
+        (C.sourceLazy $ LB.fromStrict bs)
+    PayloadH h off len ->
+      PayloadC len $
+        sourceHandleRange
+          h
+          (return . fromIntegral $ off)
+          (return . fromIntegral $ len)
+    _ -> payload
+
+isStreamingPayload :: Payload -> Bool
+isStreamingPayload (PayloadC _ _) = True
+isStreamingPayload _ = False
+
+-- | Checks if the connect info is for Amazon S3.
+isAWSConnectInfo :: ConnectInfo -> Bool
+isAWSConnectInfo ci = ".amazonaws.com" `T.isSuffixOf` connectHost ci
+
+bucketHasPeriods :: Bucket -> Bool
+bucketHasPeriods b = isJust $ T.find (== '.') b

src/Network/Minio/AdminAPI.hs

@@ -0,0 +1,711 @@
+--
+-- 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.
+-- 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.AdminAPI
+  ( -- * MinIO Admin API
+
+    --------------------
+
+    -- | Provides MinIO admin API and related types. It is in
+    -- experimental state.
+    DriveInfo (..),
+    ErasureInfo (..),
+    Backend (..),
+    ConnStats (..),
+    HttpStats (..),
+    ServerProps (..),
+    CountNAvgTime (..),
+    StorageClass (..),
+    StorageInfo (..),
+    SIData (..),
+    ServerInfo (..),
+    getServerInfo,
+    HealOpts (..),
+    HealResultItem (..),
+    HealStatus (..),
+    HealStartResp (..),
+    startHeal,
+    forceStartHeal,
+    getHealStatus,
+    SetConfigResult (..),
+    NodeSummary (..),
+    setConfig,
+    getConfig,
+    ServerVersion (..),
+    ServiceStatus (..),
+    serviceStatus,
+    ServiceAction (..),
+    serviceSendAction,
+  )
+where
+
+import Data.Aeson
+  ( FromJSON,
+    ToJSON,
+    Value (Object),
+    eitherDecode,
+    object,
+    pairs,
+    parseJSON,
+    toEncoding,
+    toJSON,
+    withObject,
+    withText,
+    (.:),
+    (.:?),
+    (.=),
+  )
+import qualified Data.Aeson as A
+import Data.Aeson.Types (typeMismatch)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text as T
+import Data.Time (NominalDiffTime, getCurrentTime)
+import Lib.Prelude
+import Network.HTTP.Conduit (Response)
+import qualified Network.HTTP.Conduit as NC
+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
+import Network.Minio.Utils
+
+data DriveInfo = DriveInfo
+  { diUuid :: Text,
+    diEndpoint :: Text,
+    diState :: Text
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON DriveInfo where
+  parseJSON = withObject "DriveInfo" $ \v ->
+    DriveInfo
+      <$> v
+        .: "uuid"
+      <*> v
+        .: "endpoint"
+      <*> v
+        .: "state"
+
+data StorageClass = StorageClass
+  { scParity :: Int,
+    scData :: Int
+  }
+  deriving stock (Show, Eq)
+
+data ErasureInfo = ErasureInfo
+  { eiOnlineDisks :: Int,
+    eiOfflineDisks :: Int,
+    eiStandard :: StorageClass,
+    eiReducedRedundancy :: StorageClass,
+    eiSets :: [[DriveInfo]]
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON ErasureInfo where
+  parseJSON = withObject "ErasureInfo" $ \v -> do
+    onlineDisks <- v .: "OnlineDisks"
+    offlineDisks <- v .: "OfflineDisks"
+    stdClass <-
+      StorageClass
+        <$> v
+          .: "StandardSCData"
+        <*> v
+          .: "StandardSCParity"
+    rrClass <-
+      StorageClass
+        <$> v
+          .: "RRSCData"
+        <*> v
+          .: "RRSCParity"
+    sets <- v .: "Sets"
+    return $ ErasureInfo onlineDisks offlineDisks stdClass rrClass sets
+
+data Backend
+  = BackendFS
+  | BackendErasure ErasureInfo
+  deriving stock (Show, Eq)
+
+instance FromJSON Backend where
+  parseJSON = withObject "Backend" $ \v -> do
+    typ <- v .: "Type"
+    case typ :: Int of
+      1 -> return BackendFS
+      2 -> BackendErasure <$> parseJSON (Object v)
+      _ -> typeMismatch "BackendType" (Object v)
+
+data ConnStats = ConnStats
+  { csTransferred :: Int64,
+    csReceived :: Int64
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON ConnStats where
+  parseJSON = withObject "ConnStats" $ \v ->
+    ConnStats
+      <$> v
+        .: "transferred"
+      <*> v
+        .: "received"
+
+data ServerProps = ServerProps
+  { spUptime :: NominalDiffTime,
+    spVersion :: Text,
+    spCommitId :: Text,
+    spRegion :: Text,
+    spSqsArns :: [Text]
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON ServerProps where
+  parseJSON = withObject "SIServer" $ \v -> do
+    uptimeNs <- v .: "uptime"
+    let uptime = uptimeNs / 1e9
+    ver <- v .: "version"
+    commitId <- v .: "commitID"
+    region <- v .: "region"
+    arn <- v .: "sqsARN"
+    return $ ServerProps uptime ver commitId region arn
+
+data StorageInfo = StorageInfo
+  { siUsed :: Int64,
+    siBackend :: Backend
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON StorageInfo where
+  parseJSON = withObject "StorageInfo" $ \v ->
+    StorageInfo
+      <$> v
+        .: "Used"
+      <*> v
+        .: "Backend"
+
+data CountNAvgTime = CountNAvgTime
+  { caCount :: Int64,
+    caAvgDuration :: Text
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON CountNAvgTime where
+  parseJSON = withObject "CountNAvgTime" $ \v ->
+    CountNAvgTime
+      <$> v
+        .: "count"
+      <*> v
+        .: "avgDuration"
+
+data HttpStats = HttpStats
+  { hsTotalHeads :: CountNAvgTime,
+    hsSuccessHeads :: CountNAvgTime,
+    hsTotalGets :: CountNAvgTime,
+    hsSuccessGets :: CountNAvgTime,
+    hsTotalPuts :: CountNAvgTime,
+    hsSuccessPuts :: CountNAvgTime,
+    hsTotalPosts :: CountNAvgTime,
+    hsSuccessPosts :: CountNAvgTime,
+    hsTotalDeletes :: CountNAvgTime,
+    hsSuccessDeletes :: CountNAvgTime
+  }
+  deriving stock (Show, Eq)
+
+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"
+
+data SIData = SIData
+  { sdStorage :: StorageInfo,
+    sdConnStats :: ConnStats,
+    sdHttpStats :: HttpStats,
+    sdProps :: ServerProps
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON SIData where
+  parseJSON = withObject "SIData" $ \v ->
+    SIData
+      <$> v
+        .: "storage"
+      <*> v
+        .: "network"
+      <*> v
+        .: "http"
+      <*> v
+        .: "server"
+
+data ServerInfo = ServerInfo
+  { siError :: Text,
+    siAddr :: Text,
+    siData :: SIData
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON ServerInfo where
+  parseJSON = withObject "ServerInfo" $ \v ->
+    ServerInfo
+      <$> v
+        .: "error"
+      <*> v
+        .: "addr"
+      <*> v
+        .: "data"
+
+data ServerVersion = ServerVersion
+  { svVersion :: Text,
+    svCommitId :: Text
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON ServerVersion where
+  parseJSON = withObject "ServerVersion" $ \v ->
+    ServerVersion
+      <$> v
+        .: "version"
+      <*> v
+        .: "commitID"
+
+data ServiceStatus = ServiceStatus
+  { ssVersion :: ServerVersion,
+    ssUptime :: NominalDiffTime
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON ServiceStatus where
+  parseJSON = withObject "ServiceStatus" $ \v -> do
+    serverVersion <- v .: "serverVersion"
+    uptimeNs <- v .: "uptime"
+    let uptime = uptimeNs / 1e9
+    return $ ServiceStatus serverVersion uptime
+
+data ServiceAction
+  = ServiceActionRestart
+  | ServiceActionStop
+  deriving stock (Show, Eq)
+
+instance ToJSON ServiceAction where
+  toJSON a = object ["action" .= serviceActionToText a]
+
+serviceActionToText :: ServiceAction -> Text
+serviceActionToText a = case a of
+  ServiceActionRestart -> "restart"
+  ServiceActionStop -> "stop"
+
+adminPath :: ByteString
+adminPath = "/minio/admin"
+
+data HealStartResp = HealStartResp
+  { hsrClientToken :: Text,
+    hsrClientAddr :: Text,
+    hsrStartTime :: UTCTime
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON HealStartResp where
+  parseJSON = withObject "HealStartResp" $ \v ->
+    HealStartResp
+      <$> v
+        .: "clientToken"
+      <*> v
+        .: "clientAddress"
+      <*> v
+        .: "startTime"
+
+data HealOpts = HealOpts
+  { hoRecursive :: Bool,
+    hoDryRun :: Bool
+  }
+  deriving stock (Show, Eq)
+
+instance ToJSON HealOpts where
+  toJSON (HealOpts r d) =
+    object ["recursive" .= r, "dryRun" .= d]
+  toEncoding (HealOpts r d) =
+    pairs ("recursive" .= r <> "dryRun" .= d)
+
+instance FromJSON HealOpts where
+  parseJSON = withObject "HealOpts" $ \v ->
+    HealOpts
+      <$> v
+        .: "recursive"
+      <*> v
+        .: "dryRun"
+
+data HealItemType
+  = HealItemMetadata
+  | HealItemBucket
+  | HealItemBucketMetadata
+  | HealItemObject
+  deriving stock (Show, Eq)
+
+instance FromJSON HealItemType where
+  parseJSON = withText "HealItemType" $ \v -> case v of
+    "metadata" -> return HealItemMetadata
+    "bucket" -> return HealItemBucket
+    "object" -> return HealItemObject
+    "bucket-metadata" -> return HealItemBucketMetadata
+    _ -> typeMismatch "HealItemType" (A.String v)
+
+data NodeSummary = NodeSummary
+  { nsName :: Text,
+    nsErrSet :: Bool,
+    nsErrMessage :: Text
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON NodeSummary where
+  parseJSON = withObject "NodeSummary" $ \v ->
+    NodeSummary
+      <$> v
+        .: "name"
+      <*> v
+        .: "errSet"
+      <*> v
+        .: "errMsg"
+
+data SetConfigResult = SetConfigResult
+  { scrStatus :: Bool,
+    scrNodeSummary :: [NodeSummary]
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON SetConfigResult where
+  parseJSON = withObject "SetConfigResult" $ \v ->
+    SetConfigResult
+      <$> v
+        .: "status"
+      <*> v
+        .: "nodeResults"
+
+data HealResultItem = HealResultItem
+  { hriResultIdx :: Int,
+    hriType :: HealItemType,
+    hriBucket :: Bucket,
+    hriObject :: Object,
+    hriDetail :: Text,
+    hriParityBlocks :: Maybe Int,
+    hriDataBlocks :: Maybe Int,
+    hriDiskCount :: Int,
+    hriSetCount :: Int,
+    hriObjectSize :: Int,
+    hriBefore :: [DriveInfo],
+    hriAfter :: [DriveInfo]
+  }
+  deriving stock (Show, Eq)
+
+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"
+      <*> ( do
+              before <- v .: "before"
+              before .: "drives"
+          )
+      <*> ( do
+              after <- v .: "after"
+              after .: "drives"
+          )
+
+data HealStatus = HealStatus
+  { hsSummary :: Text,
+    hsStartTime :: UTCTime,
+    hsSettings :: HealOpts,
+    hsNumDisks :: Int,
+    hsFailureDetail :: Maybe Text,
+    hsItems :: Maybe [HealResultItem]
+  }
+  deriving stock (Show, Eq)
+
+instance FromJSON HealStatus where
+  parseJSON = withObject "HealStatus" $ \v ->
+    HealStatus
+      <$> v
+        .: "Summary"
+      <*> v
+        .: "StartTime"
+      <*> v
+        .: "Settings"
+      <*> v
+        .: "NumDisks"
+      <*> v
+        .:? "Detail"
+      <*> v
+        .: "Items"
+
+healPath :: Maybe Bucket -> Maybe Text -> ByteString
+healPath bucket prefix = do
+  if isJust bucket
+    then
+      encodeUtf8 $
+        "v1/heal/"
+          <> fromMaybe "" bucket
+          <> "/"
+          <> fromMaybe "" prefix
+    else encodeUtf8 ("v1/heal/" :: Text)
+
+-- | Get server version and uptime.
+serviceStatus :: Minio ServiceStatus
+serviceStatus = do
+  rsp <-
+    executeAdminRequest
+      AdminReqInfo
+        { ariMethod = HT.methodGet,
+          ariPayload = PayloadBS B.empty,
+          ariPayloadHash = Nothing,
+          ariPath = "v1/service",
+          ariHeaders = [],
+          ariQueryParams = []
+        }
+
+  let rspBS = NC.responseBody rsp
+  case eitherDecode rspBS of
+    Right ss -> return ss
+    Left err -> throwIO $ MErrVJsonParse $ T.pack err
+
+-- | Send service restart or stop action to MinIO server.
+serviceSendAction :: ServiceAction -> Minio ()
+serviceSendAction action = do
+  let payload = PayloadBS $ LBS.toStrict $ A.encode action
+  void $
+    executeAdminRequest
+      AdminReqInfo
+        { ariMethod = HT.methodPost,
+          ariPayload = payload,
+          ariPayloadHash = Nothing,
+          ariPath = "v1/service",
+          ariHeaders = [],
+          ariQueryParams = []
+        }
+
+-- | Get the current config file from server.
+getConfig :: Minio ByteString
+getConfig = do
+  rsp <-
+    executeAdminRequest
+      AdminReqInfo
+        { ariMethod = HT.methodGet,
+          ariPayload = PayloadBS B.empty,
+          ariPayloadHash = Nothing,
+          ariPath = "v1/config",
+          ariHeaders = [],
+          ariQueryParams = []
+        }
+  return $ LBS.toStrict $ NC.responseBody rsp
+
+-- | Set a new config to the server.
+setConfig :: ByteString -> Minio SetConfigResult
+setConfig config = do
+  rsp <-
+    executeAdminRequest
+      AdminReqInfo
+        { ariMethod = HT.methodPut,
+          ariPayload = PayloadBS config,
+          ariPayloadHash = Nothing,
+          ariPath = "v1/config",
+          ariHeaders = [],
+          ariQueryParams = []
+        }
+
+  let rspBS = NC.responseBody rsp
+  case eitherDecode rspBS of
+    Right scr -> return scr
+    Left err -> throwIO $ MErrVJsonParse $ T.pack err
+
+-- | Get the progress of currently running heal task, this API should be
+-- invoked right after `startHeal`. `token` is obtained after `startHeal`
+-- which should be used to get the heal status.
+getHealStatus :: Maybe Bucket -> Maybe Text -> Text -> Minio HealStatus
+getHealStatus bucket prefix token = do
+  when (isNothing bucket && isJust prefix) $ throwIO MErrVInvalidHealPath
+  let qparams = HT.queryTextToQuery [("clientToken", Just token)]
+  rsp <-
+    executeAdminRequest
+      AdminReqInfo
+        { ariMethod = HT.methodPost,
+          ariPayload = PayloadBS B.empty,
+          ariPayloadHash = Nothing,
+          ariPath = healPath bucket prefix,
+          ariHeaders = [],
+          ariQueryParams = qparams
+        }
+  let rspBS = NC.responseBody rsp
+  case eitherDecode rspBS of
+    Right hs -> return hs
+    Left err -> throwIO $ MErrVJsonParse $ T.pack err
+
+doHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Bool -> Minio HealStartResp
+doHeal bucket prefix opts forceStart = do
+  when (isNothing bucket && isJust prefix) $ throwIO MErrVInvalidHealPath
+  let payload = PayloadBS $ LBS.toStrict $ A.encode opts
+  let qparams =
+        bool
+          []
+          (HT.queryTextToQuery [("forceStart", Just "true")])
+          forceStart
+
+  rsp <-
+    executeAdminRequest
+      AdminReqInfo
+        { ariMethod = HT.methodPost,
+          ariPayload = payload,
+          ariPayloadHash = Nothing,
+          ariPath = healPath bucket prefix,
+          ariHeaders = [],
+          ariQueryParams = qparams
+        }
+
+  let rspBS = NC.responseBody rsp
+  case eitherDecode rspBS of
+    Right hsr -> return hsr
+    Left err -> throwIO $ MErrVJsonParse $ T.pack err
+
+-- | Start a heal sequence that scans data under given (possible empty)
+-- `bucket` and `prefix`. The `recursive` bool turns on recursive
+-- traversal under the given path. `dryRun` does not mutate on-disk data,
+-- but performs data validation. Two heal sequences on overlapping paths
+-- may not be initiated. The progress of a heal should be followed using
+-- the `HealStatus` API. The server accumulates results of the heal
+-- traversal and waits for the client to receive and acknowledge
+-- them using the status API
+startHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Minio HealStartResp
+startHeal bucket prefix opts = doHeal bucket prefix opts False
+
+-- | Similar to start a heal sequence, but force start a new heal sequence
+-- even if an active heal is under progress.
+forceStartHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Minio HealStartResp
+forceStartHeal bucket prefix opts = doHeal bucket prefix opts True
+
+-- | Fetches information for all cluster nodes, such as server
+-- properties, storage information, network statistics, etc.
+getServerInfo :: Minio [ServerInfo]
+getServerInfo = do
+  rsp <-
+    executeAdminRequest
+      AdminReqInfo
+        { ariMethod = HT.methodGet,
+          ariPayload = PayloadBS B.empty,
+          ariPayloadHash = Nothing,
+          ariPath = "v1/info",
+          ariHeaders = [],
+          ariQueryParams = []
+        }
+  let rspBS = NC.responseBody rsp
+  case eitherDecode rspBS of
+    Right si -> return si
+    Left err -> throwIO $ MErrVJsonParse $ T.pack err
+
+executeAdminRequest :: AdminReqInfo -> Minio (Response LByteString)
+executeAdminRequest ari = do
+  req <- buildAdminRequest ari
+  mgr <- asks mcConnManager
+  httpLbs req mgr
+
+buildAdminRequest :: AdminReqInfo -> Minio NC.Request
+buildAdminRequest areq = do
+  ci <- asks mcConnInfo
+  sha256Hash <-
+    if connectIsSecure ci
+      then -- if secure connection
+        return "UNSIGNED-PAYLOAD"
+      else -- otherwise compute sha256
+        getPayloadSHA256Hash (ariPayload areq)
+
+  timeStamp <- liftIO getCurrentTime
+
+  mgr <- asks mcConnManager
+  cv <- liftIO $ getCredential (connectCreds ci) (getEndpoint ci) mgr
+
+  let hostHeader = (hHost, getHostAddr ci)
+      newAreq =
+        areq
+          { ariPayloadHash = Just sha256Hash,
+            ariHeaders =
+              hostHeader
+                : sha256Header sha256Hash
+                : ariHeaders areq
+          }
+      signReq = toRequest ci newAreq
+      sp =
+        SignParams
+          (coerce $ cvAccessKey cv)
+          (coerce $ cvSecretKey cv)
+          (coerce $ cvSessionToken cv)
+          ServiceS3
+          timeStamp
+          Nothing
+          Nothing
+          (ariPayloadHash newAreq)
+      signHeaders = signV4 sp signReq
+
+  -- Update signReq with Authorization header containing v4 signature
+  return
+    signReq
+      { NC.requestHeaders = ariHeaders newAreq ++ signHeaders
+      }
+  where
+    toRequest :: ConnectInfo -> AdminReqInfo -> NC.Request
+    toRequest ci aReq =
+      NC.defaultRequest
+        { NC.method = ariMethod aReq,
+          NC.secure = connectIsSecure ci,
+          NC.host = encodeUtf8 $ connectHost ci,
+          NC.port = connectPort ci,
+          NC.path = B.intercalate "/" [adminPath, ariPath aReq],
+          NC.requestHeaders = ariHeaders aReq,
+          NC.queryString = HT.renderQuery False $ ariQueryParams aReq,
+          NC.requestBody = getRequestBody (ariPayload aReq)
+        }

src/Network/Minio/CopyObject.hs

@@ -0,0 +1,106 @@
+--
+-- MinIO Haskell SDK, (C) 2017 MinIO, Inc.
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- You may obtain a copy of the License at
+--
+--     http://www.apache.org/licenses/LICENSE-2.0
+--
+-- Unless required by applicable law or agreed to in writing, software
+-- distributed under the License is distributed on an "AS IS" BASIS,
+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+-- See the License for the specific language governing permissions and
+-- limitations under the License.
+--
+
+module Network.Minio.CopyObject where
+
+import qualified Data.List as List
+import Lib.Prelude
+import Network.Minio.Data
+import Network.Minio.Errors
+import Network.Minio.S3API
+import Network.Minio.Utils
+
+-- | Copy an object using single or multipart copy strategy.
+copyObjectInternal ::
+  Bucket ->
+  Object ->
+  SourceInfo ->
+  Minio ETag
+copyObjectInternal b' o srcInfo = do
+  let sBucket = srcBucket srcInfo
+      sObject = srcObject srcInfo
+
+  -- get source object size with a head request
+  oi <- headObject sBucket sObject []
+  let srcSize = oiSize oi
+
+  -- check that byte offsets are valid if specified in cps
+  let rangeMay = srcRange srcInfo
+      range = maybe (0, srcSize) identity rangeMay
+      startOffset = fst range
+      endOffset = snd range
+
+  when
+    ( isJust rangeMay
+        && ( (startOffset < 0)
+               || (endOffset < startOffset)
+               || (endOffset >= srcSize)
+           )
+    )
+    $ throwIO
+    $ MErrVInvalidSrcObjByteRange range
+
+  -- 1. If sz > 64MiB (minPartSize) use multipart copy, OR
+  -- 2. If startOffset /= 0 use multipart copy
+  let destSize =
+        (\(a, b) -> b - a + 1) $
+          maybe (0, srcSize - 1) identity rangeMay
+
+  if destSize > minPartSize || (endOffset - startOffset + 1 /= srcSize)
+    then multiPartCopyObject b' o srcInfo srcSize
+    else fst <$> copyObjectSingle b' o srcInfo {srcRange = Nothing} []
+
+-- | Given the input byte range of the source object, compute the
+-- splits for a multipart copy object procedure. Minimum part size
+-- used is minPartSize.
+selectCopyRanges :: (Int64, Int64) -> [(PartNumber, (Int64, Int64))]
+selectCopyRanges (st, end) =
+  zip pns $
+    zipWith (\x y -> (st + x, st + x + y - 1)) startOffsets partSizes
+  where
+    size = end - st + 1
+    (pns, startOffsets, partSizes) = List.unzip3 $ selectPartSizes size
+
+-- | Perform a multipart copy object action. Since we cannot verify
+-- existing parts based on the source object, there is no resuming
+-- copy action support.
+multiPartCopyObject ::
+  Bucket ->
+  Object ->
+  SourceInfo ->
+  Int64 ->
+  Minio ETag
+multiPartCopyObject b o cps srcSize = do
+  uid <- newMultipartUpload b o []
+
+  let byteRange = maybe (0, srcSize - 1) identity $ srcRange cps
+      partRanges = selectCopyRanges byteRange
+      partSources =
+        map
+          (\(x, (start, end)) -> (x, cps {srcRange = Just (start, end)}))
+          partRanges
+      dstInfo = defaultDestinationInfo {dstBucket = b, dstObject = o}
+
+  copiedParts <-
+    limitedMapConcurrently
+      10
+      ( \(pn, cps') -> do
+          (etag, _) <- copyObjectPart dstInfo cps' uid pn []
+          return (pn, etag)
+      )
+      partSources
+
+  completeMultipartUpload b o uid copiedParts

src/Network/Minio/Credentials.hs

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

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

@@ -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/ByteString.hs

@@ -1,5 +1,5 @@
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- 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.
@@ -13,24 +13,22 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE FlexibleInstances #-}
+
 module Network.Minio.Data.ByteString
-  (
+  ( stripBS,
-    stripBS
+    UriEncodable (..),
-  , UriEncodable(..)
+  )
-  ) where
+where
 
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Builder as BB
 import qualified Data.ByteString.Char8 as BC8
 import qualified Data.ByteString.Lazy as LB
-import           Data.Char (isSpace, toUpper)
+import Data.Char (isAsciiLower, isAsciiUpper, isDigit, isSpace, toUpper)
 import qualified Data.Text as T
 import Numeric (showHex)
 
-import           Lib.Prelude
-
 stripBS :: ByteString -> ByteString
 stripBS = BC8.dropWhile isSpace . fst . BC8.spanEnd isSpace
 
@@ -39,8 +37,10 @@ class UriEncodable s where
 
 instance UriEncodable [Char] where
   uriEncode encodeSlash payload =
-    LB.toStrict $ BB.toLazyByteString $ mconcat $
+    LB.toStrict $
-    map (flip uriEncodeChar encodeSlash) payload
+      BB.toLazyByteString $
+        mconcat $
+          map (`uriEncodeChar` encodeSlash) payload
 
 instance UriEncodable ByteString where
   -- assumes that uriEncode is passed ASCII encoded strings.
@@ -58,17 +58,18 @@ uriEncodeChar :: Char -> Bool -> BB.Builder
 uriEncodeChar '/' True = BB.byteString "%2F"
 uriEncodeChar '/' False = BB.char7 '/'
 uriEncodeChar ch _
-  | (ch >= 'A' && ch <= 'Z')
+  | isAsciiUpper ch
-    || (ch >= 'a' && ch <= 'z')
+      || isAsciiLower ch
-    || (ch >= '0' && ch <= '9')
+      || isDigit ch
       || (ch == '_')
       || (ch == '-')
       || (ch == '.')
-    || (ch == '~') = BB.char7 ch
+      || (ch == '~') =
+      BB.char7 ch
   | otherwise = mconcat $ map f $ B.unpack $ encodeUtf8 $ T.singleton ch
   where
     f :: Word8 -> BB.Builder
     f n = BB.char7 '%' <> BB.string7 hexStr
       where
         hexStr = map toUpper $ showHex q $ showHex r ""
-        (q, r) = divMod (fromIntegral n) (16::Word8)
+        (q, r) = divMod n (16 :: Word8)

src/Network/Minio/Data/Crypto.hs

@@ -1,5 +1,5 @@
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- 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.
@@ -15,50 +15,54 @@
 --
 
 module Network.Minio.Data.Crypto
-  (
+  ( hashSHA256,
-    hashSHA256
+    hashSHA256FromSource,
-  , hashSHA256FromSource
+    hashMD5,
+    hashMD5ToBase64,
+    hashMD5FromSource,
+    hmacSHA256,
+    hmacSHA256RawBS,
+    digestToBS,
+    digestToBase16,
+    encodeToBase64,
+  )
+where
 
-  , hashMD5
+import Crypto.Hash
-  , hashMD5FromSource
+  ( Digest,
-
+    MD5 (..),
-  , hmacSHA256
+    SHA256 (..),
-  , hmacSHA256RawBS
+    hashWith,
-  , digestToBS
+  )
-  , digestToBase16
-  ) where
-
-import           Crypto.Hash (SHA256(..), MD5(..), hashWith, Digest)
 import Crypto.Hash.Conduit (sinkHash)
-import           Crypto.MAC.HMAC (hmac, HMAC)
+import Crypto.MAC.HMAC (HMAC, hmac)
 import Data.ByteArray (ByteArrayAccess, convert)
-import           Data.ByteArray.Encoding (convertToBase, Base(Base16))
+import Data.ByteArray.Encoding (Base (Base16, Base64), convertToBase)
 import qualified Data.Conduit as C
 
-import           Lib.Prelude
-
 hashSHA256 :: ByteString -> ByteString
 hashSHA256 = digestToBase16 . hashWith SHA256
 
-hashSHA256FromSource :: Monad m => C.Producer m ByteString -> m ByteString
+hashSHA256FromSource :: (Monad m) => C.ConduitM () ByteString m () -> m ByteString
 hashSHA256FromSource src = do
-  digest <- src C.$$ sinkSHA256Hash
+  digest <- C.connect src sinkSHA256Hash
   return $ digestToBase16 digest
   where
     -- To help with type inference
-    sinkSHA256Hash :: Monad m => C.Consumer ByteString 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.Producer m ByteString -> m ByteString
+hashMD5FromSource :: (Monad m) => C.ConduitM () ByteString m () -> m ByteString
 hashMD5FromSource src = do
-  digest <- src C.$$ sinkMD5Hash
+  digest <- C.connect src sinkMD5Hash
   return $ digestToBase16 digest
   where
     -- To help with type inference
-    sinkMD5Hash :: Monad m => C.Consumer ByteString m (Digest MD5)
+    sinkMD5Hash :: (Monad m) => C.ConduitM ByteString Void m (Digest MD5)
     sinkMD5Hash = sinkHash
 
 hmacSHA256 :: ByteString -> ByteString -> HMAC SHA256
@@ -67,8 +71,15 @@ hmacSHA256 message key = hmac key message
 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 = convertToBase Base64 . hashWith MD5
+
+encodeToBase64 :: (ByteArrayAccess a) => a -> ByteString
+encodeToBase64 = convertToBase Base64

src/Network/Minio/Data/Time.hs

@@ -1,5 +1,5 @@
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- 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.
@@ -15,20 +15,25 @@
 --
 
 module Network.Minio.Data.Time
-  (
+  ( awsTimeFormat,
-    awsTimeFormat
+    awsTimeFormatBS,
-  , awsTimeFormatBS
+    awsDateFormat,
-  , awsDateFormat
+    awsDateFormatBS,
-  , awsDateFormatBS
+    awsParseTime,
-  , awsParseTime
+    iso8601TimeFormat,
-  ) where
+    UrlExpiry,
-
+  )
+where
 
 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
+-- seconds. The maximum duration that can be specified is 7 days.
+type UrlExpiry = Int
+
 awsTimeFormat :: UTCTime -> [Char]
 awsTimeFormat = Time.formatTime Time.defaultTimeLocale "%Y%m%dT%H%M%SZ"
 
@@ -43,3 +48,6 @@ awsDateFormatBS = pack . awsDateFormat
 
 awsParseTime :: [Char] -> Maybe UTCTime
 awsParseTime = Time.parseTimeM False Time.defaultTimeLocale "%Y%m%dT%H%M%SZ"
+
+iso8601TimeFormat :: UTCTime -> [Char]
+iso8601TimeFormat = iso8601Show

src/Network/Minio/Errors.hs

@@ -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.
@@ -14,19 +14,24 @@
 -- limitations under the License.
 --
 
-module Network.Minio.Errors where
+module Network.Minio.Errors
+  ( MErrV (..),
+    ServiceErr (..),
+    MinioErr (..),
+    toServiceErr,
+  )
+where
 
-import           Control.Exception
+import Control.Exception (IOException)
 import qualified Network.HTTP.Conduit as NC
 
-import           Lib.Prelude
-
-
 ---------------------------------
 -- Errors
 ---------------------------------
+
 -- | Various validation errors
-data MErrV = MErrVSinglePUTSizeExceeded Int64
+data MErrV
+  = MErrVSinglePUTSizeExceeded Int64
   | MErrVPutSizeExceeded Int64
   | MErrVETagHeaderNotFound
   | MErrVInvalidObjectInfoResponse
@@ -34,19 +39,31 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64
   | MErrVInvalidSrcObjByteRange (Int64, Int64)
   | MErrVCopyObjSingleNoRangeAccepted
   | MErrVRegionNotSupported Text
-           | MErrXmlParse Text
+  | MErrVXmlParse Text
-  deriving (Show, Eq)
+  | MErrVInvalidBucketName Text
+  | MErrVInvalidObjectName Text
+  | MErrVInvalidUrlExpiry Int
+  | MErrVJsonParse Text
+  | MErrVInvalidHealPath
+  | MErrVMissingCredentials
+  | MErrVInvalidEncryptionKeyLength
+  | MErrVStreamingBodyUnexpectedEOF
+  | MErrVUnexpectedPayload
+  | MErrVSTSEndpointNotFound
+  deriving stock (Show, Eq)
 
 instance Exception MErrV
 
 -- | Errors returned by S3 compatible service
-data ServiceErr = BucketAlreadyExists
+data ServiceErr
+  = BucketAlreadyExists
   | BucketAlreadyOwnedByYou
   | NoSuchBucket
   | InvalidBucketName
   | NoSuchKey
+  | SelectErr Text Text
   | ServiceErr Text Text
-  deriving (Show, Eq)
+  deriving stock (Show, Eq)
 
 instance Exception ServiceErr
 
@@ -58,13 +75,13 @@ toServiceErr "BucketAlreadyOwnedByYou" _ = BucketAlreadyOwnedByYou
 toServiceErr "BucketAlreadyExists" _ = BucketAlreadyExists
 toServiceErr code message = ServiceErr code message
 
-
 -- | Errors thrown by the library
-data MinioErr = MErrHTTP NC.HttpException
+data MinioErr
+  = MErrHTTP NC.HttpException
   | MErrIO IOException
   | MErrService ServiceErr
   | MErrValidation MErrV
-  deriving (Show)
+  deriving stock (Show)
 
 instance Eq MinioErr where
   MErrHTTP _ == MErrHTTP _ = True

src/Network/Minio/JsonParser.hs

@@ -0,0 +1,49 @@
+--
+-- MinIO Haskell SDK, (C) 2018 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.JsonParser
+  ( parseErrResponseJSON,
+  )
+where
+
+import Data.Aeson
+  ( FromJSON,
+    eitherDecode,
+    parseJSON,
+    withObject,
+    (.:),
+  )
+import qualified Data.Text as T
+import Lib.Prelude
+import Network.Minio.Errors
+
+data AdminErrJSON = AdminErrJSON
+  { aeCode :: Text,
+    aeMessage :: Text
+  }
+  deriving stock (Eq, Show)
+
+instance FromJSON AdminErrJSON where
+  parseJSON = withObject "AdminErrJSON" $ \v ->
+    AdminErrJSON
+      <$> v .: "Code"
+      <*> v .: "Message"
+
+parseErrResponseJSON :: (MonadIO m) => LByteString -> m ServiceErr
+parseErrResponseJSON jsondata =
+  case eitherDecode jsondata of
+    Right aErr -> return $ toServiceErr (aeCode aErr) (aeMessage aErr)
+    Left err -> throwIO $ MErrVJsonParse $ T.pack err

src/Network/Minio/ListOps.hs

@@ -1,5 +1,5 @@
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -19,65 +19,161 @@ module Network.Minio.ListOps where
 import qualified Data.Conduit as C
 import qualified Data.Conduit.Combinators as CC
 import qualified Data.Conduit.List as CL
-
-import           Lib.Prelude
-
 import Network.Minio.Data
+  ( Bucket,
+    ListObjectsResult
+      ( lorCPrefixes,
+        lorHasMore,
+        lorNextToken,
+        lorObjects
+      ),
+    ListObjectsV1Result
+      ( lorCPrefixes',
+        lorHasMore',
+        lorNextMarker,
+        lorObjects'
+      ),
+    ListPartsResult (lprHasMore, lprNextPart, lprParts),
+    ListUploadsResult
+      ( lurHasMore,
+        lurNextKey,
+        lurNextUpload,
+        lurUploads
+      ),
+    Minio,
+    Object,
+    ObjectInfo,
+    ObjectPartInfo (opiSize),
+    UploadId,
+    UploadInfo (UploadInfo),
+  )
 import Network.Minio.S3API
+  ( listIncompleteParts',
+    listIncompleteUploads',
+    listObjects',
+    listObjectsV1',
+  )
 
--- | List objects in a bucket matching the given prefix. If recurse is
+-- | Represents a list output item - either an object or an object
--- set to True objects matching prefix are recursively listed.
+-- prefix (i.e. a directory).
-listObjects :: Bucket -> Maybe Text -> Bool -> C.Producer Minio ObjectInfo
+data ListItem
+  = ListItemObject ObjectInfo
+  | ListItemPrefix Text
+  deriving stock (Show, Eq)
+
+-- | @'listObjects' bucket prefix recurse@ lists objects in a bucket
+-- similar to a file system tree traversal.
+--
+-- If @prefix@ is not 'Nothing', only items with the given prefix are
+-- listed, otherwise items under the bucket are returned.
+--
+-- If @recurse@ is set to @True@ all directories under the prefix are
+-- recursively traversed and only objects are returned.
+--
+-- If @recurse@ is set to @False@, objects and directories immediately
+-- under the given prefix are returned (no recursive traversal is
+-- performed).
+listObjects :: Bucket -> Maybe Text -> Bool -> C.ConduitM () ListItem Minio ()
 listObjects bucket prefix recurse = loop Nothing
   where
-    loop :: Maybe Text -> C.Producer Minio ObjectInfo
+    loop :: Maybe Text -> C.ConduitM () ListItem Minio ()
     loop nextToken = do
-      let
+      let delimiter = bool (Just "/") Nothing recurse
-        delimiter = bool (Just "/") Nothing recurse
 
-      res <- lift $ listObjects' bucket prefix nextToken delimiter
+      res <- lift $ listObjects' bucket prefix nextToken delimiter Nothing
-      CL.sourceList $ lorObjects res
+      CL.sourceList $ map ListItemObject $ lorObjects res
+      unless recurse $
+        CL.sourceList $
+          map ListItemPrefix $
+            lorCPrefixes res
       when (lorHasMore res) $
         loop (lorNextToken res)
 
+-- | Lists objects - similar to @listObjects@, however uses the older
+-- V1 AWS S3 API. Prefer @listObjects@ to this.
+listObjectsV1 ::
+  Bucket ->
+  Maybe Text ->
+  Bool ->
+  C.ConduitM () ListItem Minio ()
+listObjectsV1 bucket prefix recurse = loop Nothing
+  where
+    loop :: Maybe Text -> C.ConduitM () ListItem Minio ()
+    loop nextMarker = do
+      let delimiter = bool (Just "/") Nothing recurse
+
+      res <- lift $ listObjectsV1' bucket prefix nextMarker delimiter Nothing
+      CL.sourceList $ map ListItemObject $ lorObjects' res
+      unless recurse $
+        CL.sourceList $
+          map ListItemPrefix $
+            lorCPrefixes' res
+      when (lorHasMore' res) $
+        loop (lorNextMarker res)
+
 -- | List incomplete uploads in a bucket matching the given prefix. If
 -- recurse is set to True incomplete uploads for the given prefix are
 -- recursively listed.
-listIncompleteUploads :: Bucket -> Maybe Text -> Bool
+listIncompleteUploads ::
-                      -> C.Producer Minio UploadInfo
+  Bucket ->
+  Maybe Text ->
+  Bool ->
+  C.ConduitM () UploadInfo Minio ()
 listIncompleteUploads bucket prefix recurse = loop Nothing Nothing
   where
-    loop :: Maybe Text -> Maybe Text -> C.Producer Minio UploadInfo
+    loop :: Maybe Text -> Maybe Text -> C.ConduitM () UploadInfo Minio ()
     loop nextKeyMarker nextUploadIdMarker = do
-      let
+      let delimiter = bool (Just "/") Nothing recurse
-        delimiter = bool (Just "/") Nothing recurse
 
-      res <- lift $ listIncompleteUploads' bucket prefix delimiter
+      res <-
-             nextKeyMarker nextUploadIdMarker
+        lift $
+          listIncompleteUploads'
+            bucket
+            prefix
+            delimiter
+            nextKeyMarker
+            nextUploadIdMarker
+            Nothing
 
-      aggrSizes <- lift $ forM (lurUploads res) $ \((uKey, uId, _)) -> do
+      aggrSizes <- lift $
-            partInfos <- listIncompleteParts bucket uKey uId C.$$ CC.sinkList
+        forM (lurUploads res) $ \(uKey, uId, _) -> do
-            return $ foldl (\sizeSofar p -> opiSize p + sizeSofar) 0
+          partInfos <-
-              $ partInfos
+            C.runConduit $
+              listIncompleteParts bucket uKey uId
+                C..| CC.sinkList
+          return $ foldl' (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos
 
       CL.sourceList $
-        map (\((uKey, uId, uInitTime), size) ->
+        zipWith
+          ( curry
+              ( \((uKey, uId, uInitTime), size) ->
                   UploadInfo uKey uId uInitTime size
-            ) $ zip (lurUploads res) aggrSizes
+              )
+          )
+          (lurUploads res)
+          aggrSizes
 
       when (lurHasMore res) $
         loop (lurNextKey res) (lurNextUpload res)
 
-
 -- | List object parts of an ongoing multipart upload for given
 -- bucket, object and uploadId.
-listIncompleteParts :: Bucket -> Object -> UploadId
+listIncompleteParts ::
-                    -> C.Producer Minio ObjectPartInfo
+  Bucket ->
+  Object ->
+  UploadId ->
+  C.ConduitM () ObjectPartInfo Minio ()
 listIncompleteParts bucket object uploadId = loop Nothing
   where
-    loop :: Maybe Text -> C.Producer Minio ObjectPartInfo
+    loop :: Maybe Text -> C.ConduitM () ObjectPartInfo Minio ()
     loop nextPartMarker = do
-      res <- lift $ listIncompleteParts' bucket object uploadId Nothing
+      res <-
+        lift $
+          listIncompleteParts'
+            bucket
+            object
+            uploadId
+            Nothing
             nextPartMarker
       CL.sourceList $ lprParts res
       when (lprHasMore res) $

src/Network/Minio/PresignedOperations.hs

@@ -0,0 +1,355 @@
+--
+-- 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 CPP #-}
+
+module Network.Minio.PresignedOperations
+  ( UrlExpiry,
+    makePresignedUrl,
+    presignedPutObjectUrl,
+    presignedGetObjectUrl,
+    presignedHeadObjectUrl,
+    PostPolicyCondition (..),
+    ppCondBucket,
+    ppCondContentLengthRange,
+    ppCondContentType,
+    ppCondKey,
+    ppCondKeyStartsWith,
+    ppCondSuccessActionStatus,
+    PostPolicy (..),
+    PostPolicyError (..),
+    newPostPolicy,
+    showPostPolicy,
+    presignedPostPolicy,
+  )
+where
+
+import Data.Aeson ((.=))
+import qualified Data.Aeson as Json
+import Data.ByteString.Builder (byteString, toLazyByteString)
+import qualified Data.HashMap.Strict as H
+import qualified Data.Text as T
+import qualified Data.Time as Time
+import Lib.Prelude
+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
+import Network.Minio.Sign.V4
+import Network.URI (uriToString)
+
+{- ORMOLU_DISABLE -}
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.Key as A
+#endif
+{- ORMOLU_ENABLE -}
+
+-- | Generate a presigned URL. This function allows for advanced usage
+-- - for simple cases prefer the `presigned*Url` functions.
+--
+-- If region is Nothing, it is picked up from the connection
+-- information (no check of bucket existence is performed).
+--
+-- All extra query parameters or headers are signed, and therefore are
+-- required to be sent when the generated URL is actually used.
+makePresignedUrl ::
+  UrlExpiry ->
+  HT.Method ->
+  Maybe Bucket ->
+  Maybe Object ->
+  Maybe Region ->
+  HT.Query ->
+  HT.RequestHeaders ->
+  Minio ByteString
+makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do
+  when (expiry > 7 * 24 * 3600 || expiry < 0) $
+    throwIO $
+      MErrVInvalidUrlExpiry expiry
+
+  let s3ri =
+        defaultS3ReqInfo
+          { riPresignExpirySecs = Just expiry,
+            riMethod = method,
+            riBucket = bucket,
+            riObject = object,
+            riRegion = region,
+            riQueryParams = extraQuery,
+            riHeaders = extraHeaders
+          }
+
+  req <- buildRequest s3ri
+  let uri = NClient.getUri req
+      uriString = uriToString identity uri ""
+
+  return $ encodeUtf8 uriString
+
+-- | Generate a URL with authentication signature to PUT (upload) an
+-- object. Any extra headers if passed, are signed, and so they are
+-- required when the URL is used to upload data. This could be used,
+-- for example, to set user-metadata on the object.
+--
+-- For a list of possible headers to pass, please refer to the PUT
+-- object REST API AWS S3 documentation.
+presignedPutObjectUrl ::
+  Bucket ->
+  Object ->
+  UrlExpiry ->
+  HT.RequestHeaders ->
+  Minio ByteString
+presignedPutObjectUrl bucket object expirySeconds extraHeaders = do
+  region <- asks (Just . connectRegion . mcConnInfo)
+  makePresignedUrl
+    expirySeconds
+    HT.methodPut
+    (Just bucket)
+    (Just object)
+    region
+    []
+    extraHeaders
+
+-- | Generate a URL with authentication signature to GET (download) an
+-- object. All extra query parameters and headers passed here will be
+-- signed and are required when the generated URL is used. Query
+-- parameters could be used to change the response headers sent by the
+-- server. Headers can be used to set Etag match conditions among
+-- others.
+--
+-- For a list of possible request parameters and headers, please refer
+-- to the GET object REST API AWS S3 documentation.
+presignedGetObjectUrl ::
+  Bucket ->
+  Object ->
+  UrlExpiry ->
+  HT.Query ->
+  HT.RequestHeaders ->
+  Minio ByteString
+presignedGetObjectUrl bucket object expirySeconds extraQuery extraHeaders = do
+  region <- asks (Just . connectRegion . mcConnInfo)
+  makePresignedUrl
+    expirySeconds
+    HT.methodGet
+    (Just bucket)
+    (Just object)
+    region
+    extraQuery
+    extraHeaders
+
+-- | Generate a URL with authentication signature to make a HEAD
+-- request on an object. This is used to fetch metadata about an
+-- object. All extra headers passed here will be signed and are
+-- required when the generated URL is used.
+--
+-- For a list of possible headers to pass, please refer to the HEAD
+-- object REST API AWS S3 documentation.
+presignedHeadObjectUrl ::
+  Bucket ->
+  Object ->
+  UrlExpiry ->
+  HT.RequestHeaders ->
+  Minio ByteString
+presignedHeadObjectUrl bucket object expirySeconds extraHeaders = do
+  region <- asks (Just . connectRegion . mcConnInfo)
+  makePresignedUrl
+    expirySeconds
+    HT.methodHead
+    (Just bucket)
+    (Just object)
+    region
+    []
+    extraHeaders
+
+-- | Represents individual conditions in a Post Policy document.
+data PostPolicyCondition
+  = PPCStartsWith Text Text
+  | PPCEquals Text Text
+  | PPCRange Text Int64 Int64
+  deriving stock (Show, Eq)
+
+{- ORMOLU_DISABLE -}
+instance Json.ToJSON PostPolicyCondition where
+  toJSON (PPCStartsWith k v) = Json.toJSON ["starts-with", k, v]
+#if MIN_VERSION_aeson(2,0,0)
+  toJSON (PPCEquals k v) = Json.object [(A.fromText k) .= v]
+#else
+  toJSON (PPCEquals k v) = Json.object [k .= v]
+#endif
+  toJSON (PPCRange k minVal maxVal) =
+    Json.toJSON [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal]
+
+  toEncoding (PPCStartsWith k v) = Json.foldable ["starts-with", k, v]
+#if MIN_VERSION_aeson(2,0,0)
+  toEncoding (PPCEquals k v) = Json.pairs ((A.fromText k) .= v)
+#else
+  toEncoding (PPCEquals k v) = Json.pairs (k .= v)
+#endif
+  toEncoding (PPCRange k minVal maxVal) =
+    Json.foldable [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal]
+{- ORMOLU_ENABLE -}
+
+-- | A PostPolicy is required to perform uploads via browser forms.
+data PostPolicy = PostPolicy
+  { expiration :: UTCTime,
+    conditions :: [PostPolicyCondition]
+  }
+  deriving stock (Show, Eq)
+
+instance Json.ToJSON PostPolicy where
+  toJSON (PostPolicy e c) =
+    Json.object
+      [ "expiration" .= iso8601TimeFormat e,
+        "conditions" .= c
+      ]
+  toEncoding (PostPolicy e c) =
+    Json.pairs ("expiration" .= iso8601TimeFormat e <> "conditions" .= c)
+
+-- | Possible validation errors when creating a PostPolicy.
+data PostPolicyError
+  = PPEKeyNotSpecified
+  | PPEBucketNotSpecified
+  | PPEConditionKeyEmpty
+  | PPERangeInvalid
+  deriving stock (Show, Eq)
+
+-- | Set the bucket name that the upload should use.
+ppCondBucket :: Bucket -> PostPolicyCondition
+ppCondBucket = PPCEquals "bucket"
+
+-- | Set the content length range constraint with minimum and maximum
+-- byte count values.
+ppCondContentLengthRange ::
+  Int64 ->
+  Int64 ->
+  PostPolicyCondition
+ppCondContentLengthRange = PPCRange "content-length-range"
+
+-- | Set the content-type header for the upload.
+ppCondContentType :: Text -> PostPolicyCondition
+ppCondContentType = PPCEquals "Content-Type"
+
+-- | Set the object name constraint for the upload.
+ppCondKey :: Object -> PostPolicyCondition
+ppCondKey = PPCEquals "key"
+
+-- | Set the object name prefix constraint for the upload.
+ppCondKeyStartsWith :: Object -> PostPolicyCondition
+ppCondKeyStartsWith = PPCStartsWith "key"
+
+-- | Status code that the S3-server should send on a successful POST
+-- upload
+ppCondSuccessActionStatus :: Int -> PostPolicyCondition
+ppCondSuccessActionStatus n =
+  PPCEquals "success_action_status" (show n)
+
+-- | This function creates a PostPolicy after validating its
+-- arguments.
+newPostPolicy ::
+  UTCTime ->
+  [PostPolicyCondition] ->
+  Either PostPolicyError PostPolicy
+newPostPolicy expirationTime conds
+  -- object name condition must be present
+  | not $ any (keyEquals "key") conds =
+      Left PPEKeyNotSpecified
+  -- bucket name condition must be present
+  | not $ any (keyEquals "bucket") conds =
+      Left PPEBucketNotSpecified
+  -- a condition with an empty key is invalid
+  | any (keyEquals "") conds || any isEmptyRangeKey conds =
+      Left PPEConditionKeyEmpty
+  -- invalid range check
+  | any isInvalidRange conds =
+      Left PPERangeInvalid
+  -- all good!
+  | otherwise =
+      return $ PostPolicy expirationTime conds
+  where
+    keyEquals k' (PPCStartsWith k _) = k == k'
+    keyEquals k' (PPCEquals k _) = k == k'
+    keyEquals _ _ = False
+    isEmptyRangeKey (PPCRange k _ _) = k == ""
+    isEmptyRangeKey _ = False
+    isInvalidRange (PPCRange _ mi ma) = mi < 0 || mi > ma
+    isInvalidRange _ = False
+
+-- | Convert Post Policy to a string (e.g. for printing).
+showPostPolicy :: PostPolicy -> ByteString
+showPostPolicy = toStrictBS . Json.encode
+
+-- | Generate a presigned URL and POST policy to upload files via a
+-- browser. On success, this function returns a URL and POST
+-- form-data.
+presignedPostPolicy ::
+  PostPolicy ->
+  Minio (ByteString, H.HashMap Text ByteString)
+presignedPostPolicy p = do
+  ci <- asks mcConnInfo
+  signTime <- liftIO Time.getCurrentTime
+  mgr <- asks mcConnManager
+  cv <- liftIO $ getCredential (connectCreds ci) (getEndpoint ci) mgr
+
+  let extraConditions signParams =
+        [ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime),
+          PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256",
+          PPCEquals
+            "x-amz-credential"
+            ( T.intercalate
+                "/"
+                [ coerce $ cvAccessKey cv,
+                  decodeUtf8 $ credentialScope signParams
+                ]
+            )
+        ]
+      ppWithCreds signParams =
+        p
+          { conditions = conditions p ++ extraConditions signParams
+          }
+      sp =
+        SignParams
+          (coerce $ cvAccessKey cv)
+          (coerce $ cvSecretKey cv)
+          (coerce $ cvSessionToken cv)
+          ServiceS3
+          signTime
+          (Just $ connectRegion ci)
+          Nothing
+          Nothing
+      signData = signV4PostPolicy (showPostPolicy $ ppWithCreds sp) sp
+      -- compute form-data
+      mkPair (PPCStartsWith k v) = Just (k, v)
+      mkPair (PPCEquals k v) = Just (k, v)
+      mkPair _ = Nothing
+      formFromPolicy =
+        H.map encodeUtf8 $
+          H.fromList $
+            mapMaybe
+              mkPair
+              (conditions $ ppWithCreds sp)
+      formData = formFromPolicy `H.union` signData
+      -- compute POST upload URL
+      bucket = H.lookupDefault "" "bucket" formData
+      scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
+      url =
+        toStrictBS $
+          toLazyByteString $
+            scheme
+              <> byteString (getHostAddr ci)
+              <> byteString "/"
+              <> byteString bucket
+              <> byteString "/"
+
+  return (url, formData)

src/Network/Minio/PutObject.hs

@@ -1,5 +1,5 @@
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
 --
 -- Licensed under the Apache License, Version 2.0 (the "License");
 -- you may not use this file except in compliance with the License.
@@ -15,49 +15,25 @@
 --
 
 module Network.Minio.PutObject
-  (
+  ( putObjectInternal,
-    putObjectInternal
+    ObjectData (..),
-  , ObjectData(..)
+    selectPartSizes,
-  , selectPartSizes
+  )
-  , copyObjectInternal
+where
-  , selectCopyRanges
-  , minPartSize
-  ) where
 
-
+import Conduit (takeC)
-import qualified Data.ByteString as B
+import qualified Conduit as C
-import qualified Data.Conduit as C
+import qualified Data.ByteString.Lazy as LBS
-import           Data.Conduit.Binary (sourceHandleRange)
 import qualified Data.Conduit.Binary as CB
 import qualified Data.Conduit.Combinators as CC
 import qualified Data.Conduit.List as CL
 import qualified Data.List as List
-import qualified Data.Map.Strict as Map
-
 import Lib.Prelude
-
 import Network.Minio.Data
-import           Network.Minio.Data.Crypto
 import Network.Minio.Errors
-import           Network.Minio.ListOps
 import Network.Minio.S3API
 import Network.Minio.Utils
 
-
--- | max obj size is 5TiB
-maxObjectSize :: Int64
-maxObjectSize = 5 * 1024 * 1024 * oneMiB
-
--- | minimum size of parts used in multipart operations.
-minPartSize :: Int64
-minPartSize = 64 * oneMiB
-
-oneMiB :: Int64
-oneMiB = 1024 * 1024
-
-maxMultipartParts :: Int64
-maxMultipartParts = 10000
-
 -- | A data-type to represent the source data for an object. A
 -- file-path or a producer-conduit may be provided.
 --
@@ -67,207 +43,131 @@ maxMultipartParts = 10000
 --
 -- For streams also, a size may be provided. This is useful to limit
 -- the input - if it is not provided, upload will continue until the
--- stream ends or the object reaches `maxObjectsize` size.
+-- stream ends or the object reaches `maxObjectSize` size.
-data ObjectData m =
+data ObjectData m
-  ODFile FilePath (Maybe Int64) -- ^ Takes filepath and optional size.
+  = -- | Takes filepath and optional
-  | ODStream (C.Producer m ByteString) (Maybe Int64) -- ^ Pass size in bytes as maybe if known.
+    -- size.
+    ODFile FilePath (Maybe Int64)
+  | -- | Pass
+    -- size
+    -- (bytes)
+    -- if
+    -- known.
+    ODStream (C.ConduitM () ByteString m ()) (Maybe Int64)
 
 -- | Put an object from ObjectData. This high-level API handles
 -- objects of all sizes, and even if the object size is unknown.
-putObjectInternal :: Bucket -> Object -> ObjectData Minio -> Minio ETag
+putObjectInternal ::
-putObjectInternal b o (ODStream src sizeMay) = sequentialMultipartUpload b o sizeMay src
+  Bucket ->
-putObjectInternal b o (ODFile fp sizeMay) = do
+  Object ->
+  PutObjectOptions ->
+  ObjectData Minio ->
+  Minio ETag
+putObjectInternal b o opts (ODStream src sizeMay) = do
+  case sizeMay of
+    -- unable to get size, so assume non-seekable file
+    Nothing -> sequentialMultipartUpload b o opts Nothing src
+    -- got file size, so check for single/multipart upload
+    Just size ->
+      if
+          | size <= 64 * oneMiB -> do
+              bs <- C.runConduit $ src C..| takeC (fromIntegral size) C..| CB.sinkLbs
+              putObjectSingle' b o (pooToHeaders opts) $ LBS.toStrict bs
+          | size > maxObjectSize -> throwIO $ MErrVPutSizeExceeded size
+          | otherwise -> sequentialMultipartUpload b o opts (Just size) src
+putObjectInternal b o opts (ODFile fp sizeMay) = do
   hResE <- withNewHandle fp $ \h ->
-    liftM2 (,) (isHandleSeekable h) (getFileSize h)
+    liftA2 (,) (isHandleSeekable h) (getFileSize h)
 
-  (isSeekable, handleSizeMay) <- either (const $ return (False, Nothing)) return
+  (isSeekable, handleSizeMay) <-
+    either
+      (const $ return (False, Nothing))
+      return
       hResE
 
   -- prefer given size to queried size.
   let finalSizeMay = listToMaybe $ catMaybes [sizeMay, handleSizeMay]
 
   case finalSizeMay of
-    -- unable to get size, so assume non-seekable file and max-object size
+    -- unable to get size, so assume non-seekable file
-    Nothing -> sequentialMultipartUpload b o (Just maxObjectSize) $
+    Nothing -> sequentialMultipartUpload b o opts Nothing $ CB.sourceFile fp
-               CB.sourceFile fp
-
     -- got file size, so check for single/multipart upload
     Just size ->
-      if | size <= 64 * oneMiB -> either throwM return =<<
+      if
-           withNewHandle fp (\h -> putObjectSingle b o [] h 0 size)
+          | size <= 64 * oneMiB ->
-         | size > maxObjectSize -> throwM $ MErrVPutSizeExceeded size
+              either throwIO return
-         | isSeekable -> parallelMultipartUpload b o fp size
+                =<< withNewHandle fp (\h -> putObjectSingle b o (pooToHeaders opts) h 0 size)
-         | otherwise -> sequentialMultipartUpload b o (Just size) $
+          | size > maxObjectSize -> throwIO $ MErrVPutSizeExceeded size
+          | isSeekable -> parallelMultipartUpload b o opts fp size
+          | otherwise ->
+              sequentialMultipartUpload b o opts (Just size) $
                 CB.sourceFile fp
 
--- | Select part sizes - the logic is that the minimum part-size will
+parallelMultipartUpload ::
--- be 64MiB.
+  Bucket ->
-selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]
+  Object ->
-selectPartSizes size = uncurry (List.zip3 [1..]) $
+  PutObjectOptions ->
-                       List.unzip $ loop 0 size
+  FilePath ->
-  where
+  Int64 ->
-    ceil :: Double -> Int64
+  Minio ETag
-    ceil = ceiling
+parallelMultipartUpload b o opts filePath size = do
-    partSize = max minPartSize (ceil $ fromIntegral size /
+  -- get a new upload id.
-                               fromIntegral maxMultipartParts)
+  uploadId <- newMultipartUpload b o (pooToHeaders opts)
-
-    m = fromIntegral partSize
-    loop st sz
-      | st > sz = []
-      | st + m >= sz = [(st, sz - st)]
-      | otherwise = (st, m) : loop (st + m) sz
-
--- returns partinfo if part is already uploaded.
-checkUploadNeeded :: Payload -> PartNumber
-                  -> Map.Map PartNumber ObjectPartInfo
-                  -> Minio (Maybe PartTuple)
-checkUploadNeeded payload n pmap = do
-  (md5hash, pSize) <- case payload of
-    PayloadBS bs -> return (hashMD5 bs, fromIntegral $ B.length bs)
-    PayloadH h off size -> liftM (, size) $
-      hashMD5FromSource $ sourceHandleRange h (Just $ fromIntegral off)
-      (Just $ fromIntegral size)
-  case Map.lookup n pmap of
-    Nothing -> return Nothing
-    Just (ObjectPartInfo _ etag size _) -> return $
-      bool Nothing (Just (n, etag)) $
-      md5hash == encodeUtf8 etag && size == pSize
-
-parallelMultipartUpload :: Bucket -> Object -> FilePath -> Int64
-                        -> Minio ETag
-parallelMultipartUpload b o filePath size = do
-  (uidMay, pmap) <- getExistingUpload b o
-
-  -- get a new upload id if needed.
-  uploadId <- maybe (newMultipartUpload b o []) return uidMay
 
   let partSizeInfo = selectPartSizes size
 
-  -- perform upload with 10 threads
+  let threads = fromMaybe 10 $ pooNumThreads opts
-  uploadedPartsE <- limitedMapConcurrently 10
+
-                    (uploadPart pmap uploadId) partSizeInfo
+  -- perform upload with 'threads' threads
+  uploadedPartsE <-
+    limitedMapConcurrently
+      (fromIntegral threads)
+      (uploadPart uploadId)
+      partSizeInfo
 
   -- if there were any errors, rethrow exception.
-  mapM_ throwM $ lefts uploadedPartsE
+  mapM_ throwIO $ lefts uploadedPartsE
 
   -- if we get here, all parts were successfully uploaded.
   completeMultipartUpload b o uploadId $ rights uploadedPartsE
   where
-    uploadPart pmap uploadId (partNum, offset, sz) =
+    uploadPart uploadId (partNum, offset, sz) =
       withNewHandle filePath $ \h -> do
         let payload = PayloadH h offset sz
-        pInfoMay <- checkUploadNeeded payload partNum pmap
+        putObjectPart b o uploadId partNum [] payload
-        maybe
-          (putObjectPart b o uploadId partNum [] payload)
-          return pInfoMay
 
 -- | Upload multipart object from conduit source sequentially
-sequentialMultipartUpload :: Bucket -> Object -> Maybe Int64
+sequentialMultipartUpload ::
-                          -> C.Producer Minio ByteString -> Minio ETag
+  Bucket ->
-sequentialMultipartUpload b o sizeMay src = do
+  Object ->
-  (uidMay, pmap) <- getExistingUpload b o
+  PutObjectOptions ->
-
+  Maybe Int64 ->
-  -- get a new upload id if needed.
+  C.ConduitM () ByteString Minio () ->
-  uploadId <- maybe (newMultipartUpload b o []) return uidMay
+  Minio ETag
+sequentialMultipartUpload b o opts sizeMay src = do
+  -- get a new upload id.
+  uploadId <- newMultipartUpload b o (pooToHeaders opts)
 
   -- upload parts in loop
   let partSizes = selectPartSizes $ maybe maxObjectSize identity sizeMay
       (pnums, _, sizes) = List.unzip3 partSizes
-  uploadedParts <- src
+  uploadedParts <-
-              C..| chunkBSConduit sizes
+    C.runConduit $
+      src
+        C..| chunkBSConduit (map fromIntegral sizes)
         C..| CL.map PayloadBS
-              C..| checkAndUpload uploadId pmap pnums
+        C..| uploadPart' uploadId pnums
-              C.$$ CC.sinkList
+        C..| CC.sinkList
 
   -- complete multipart upload
   completeMultipartUpload b o uploadId uploadedParts
-
   where
-    checkAndUpload _ _ [] = return ()
+    uploadPart' _ [] = return ()
-    checkAndUpload uid pmap (pn:pns) = do
+    uploadPart' uid (pn : pns) = do
       payloadMay <- C.await
       case payloadMay of
         Nothing -> return ()
-        Just payload -> do partMay <- lift $ checkUploadNeeded payload pn pmap
+        Just payload -> do
-                           pinfo <- maybe
+          pinfo <- lift $ putObjectPart b o uid pn [] payload
-                                    (lift $ putObjectPart b o uid pn [] payload)
-                                    return partMay
           C.yield pinfo
-                           checkAndUpload uid pmap pns
+          uploadPart' uid pns
-
--- | Looks for incomplete uploads for an object. Returns the first one
--- if there are many.
-getExistingUpload :: Bucket -> Object
-                  -> Minio (Maybe UploadId, Map.Map PartNumber ObjectPartInfo)
-getExistingUpload b o = do
-  uidMay <- (fmap . fmap) uiUploadId $
-            listIncompleteUploads b (Just o) False C.$$ CC.head
-  parts <- maybe (return [])
-    (\uid -> listIncompleteParts b o uid C.$$ CC.sinkList) uidMay
-  return (uidMay, Map.fromList $ map (\p -> (opiNumber p, p)) parts)
-
--- | Copy an object using single or multipart copy strategy.
-copyObjectInternal :: Bucket -> Object -> CopyPartSource
-                   -> Minio ETag
-copyObjectInternal b' o cps = do
-  -- validate and extract the src bucket and object
-  (srcBucket, srcObject) <- maybe
-    (throwM $ MErrVInvalidSrcObjSpec $ cpSource cps)
-    return $ cpsToObject cps
-
-  -- get source object size with a head request
-  (ObjectInfo _ _ _ srcSize) <- headObject srcBucket srcObject
-
-  -- check that byte offsets are valid if specified in cps
-  when (isJust (cpSourceRange cps) &&
-        or [fst range < 0, snd range < fst range,
-            snd range >= fromIntegral srcSize]) $
-    throwM $ MErrVInvalidSrcObjByteRange range
-
-  -- 1. If sz > 64MiB (minPartSize) use multipart copy, OR
-  -- 2. If startOffset /= 0 use multipart copy
-  let destSize = (\(a, b) -> b - a + 1 ) $
-                 maybe (0, srcSize - 1) identity $ cpSourceRange cps
-      startOffset = maybe 0 fst $ cpSourceRange cps
-      endOffset = maybe (srcSize - 1) snd $ cpSourceRange cps
-
-  if destSize > minPartSize || (endOffset - startOffset + 1 /= srcSize)
-    then multiPartCopyObject b' o cps srcSize
-
-    else fst <$> copyObjectSingle b' o cps{cpSourceRange = Nothing} []
-
-  where
-    range = maybe (0, 0) identity $ cpSourceRange cps
-
--- | Given the input byte range of the source object, compute the
--- splits for a multipart copy object procedure. Minimum part size
--- used is minPartSize.
-selectCopyRanges :: (Int64, Int64) -> [(PartNumber, (Int64, Int64))]
-selectCopyRanges (st, end) = zip pns $
-  map (\(x, y) -> (st + x, st + x + y - 1)) $ zip startOffsets partSizes
-  where
-    size = end - st + 1
-    (pns, startOffsets, partSizes) = List.unzip3 $ selectPartSizes size
-
--- | Perform a multipart copy object action. Since we cannot verify
--- existing parts based on the source object, there is no resuming
--- copy action support.
-multiPartCopyObject :: Bucket -> Object -> CopyPartSource -> Int64
-                    -> Minio ETag
-multiPartCopyObject b o cps srcSize = do
-  uid <- newMultipartUpload b o []
-
-  let byteRange = maybe (0, fromIntegral $ srcSize - 1) identity $
-                  cpSourceRange cps
-      partRanges = selectCopyRanges byteRange
-      partSources = map (\(x, y) -> (x, cps {cpSourceRange = Just y}))
-                    partRanges
-
-  copiedParts <- limitedMapConcurrently 10
-                 (\(pn, cps') -> do
-                     (etag, _) <- copyObjectPart b o cps' uid pn []
-                     return $ (pn, etag)
-                 )
-                 partSources
-
-  completeMultipartUpload b o uid copiedParts

src/Network/Minio/S3API.hs

@@ -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.
@@ -14,101 +14,185 @@
 -- 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,
-    Region
+    getLocation,
-  , getLocation
 
     -- * Listing buckets
+
     --------------------
-  , getService
+    getService,
 
     -- * Listing objects
+
     --------------------
-  , ListObjectsResult
+    ListObjectsResult (..),
-  , listObjects'
+    ListObjectsV1Result (..),
+    listObjects',
+    listObjectsV1',
+
+    -- * Retrieving buckets
+    headBucket,
 
     -- * Retrieving objects
+
     -----------------------
-  , getObject'
+    getObject',
-  , headObject
+    headObject,
 
     -- * Creating buckets and objects
+
     ---------------------------------
-  , putBucket
+    putBucket,
-  , ETag
+    ETag,
-  , putObjectSingle
+    maxSinglePutObjectSizeBytes,
-  , copyObjectSingle
+    putObjectSingle',
+    putObjectSingle,
+    copyObjectSingle,
 
     -- * Multipart Upload APIs
+
     --------------------------
-  , UploadId
+    UploadId,
-  , PartTuple
+    PartTuple,
-  , Payload(..)
+    Payload (..),
-  , PartNumber
+    PartNumber,
-  , CopyPartSource(..)
+    newMultipartUpload,
-  , newMultipartUpload
+    putObjectPart,
-  , putObjectPart
+    copyObjectPart,
-  , copyObjectPart
+    completeMultipartUpload,
-  , completeMultipartUpload
+    abortMultipartUpload,
-  , abortMultipartUpload
+    ListUploadsResult (..),
-  , ListUploadsResult
+    listIncompleteUploads',
-  , listIncompleteUploads'
+    ListPartsResult (..),
-  , ListPartsResult(..)
+    listIncompleteParts',
-  , listIncompleteParts'
 
     -- * Deletion APIs
+
     --------------------------
-  , deleteBucket
+    deleteBucket,
-  , deleteObject
+    deleteObject,
 
-  ) where
+    -- * Presigned Operations
 
-import qualified Data.Conduit as C
+    -----------------------------
-import           Data.Default (def)
+    module Network.Minio.PresignedOperations,
+
+    -- ** Bucket Policies
+    getBucketPolicy,
+    setBucketPolicy,
+
+    -- * Bucket Notifications
+
+    -------------------------
+    Notification (..),
+    NotificationConfig (..),
+    Arn,
+    Event (..),
+    Filter (..),
+    FilterKey (..),
+    FilterRules (..),
+    FilterRule (..),
+    getBucketNotification,
+    putBucketNotification,
+    removeAllBucketNotification,
+  )
+where
+
+import qualified Data.ByteString as BS
+import qualified Data.Text as T
+import Lib.Prelude
 import qualified Network.HTTP.Conduit as NC
 import qualified Network.HTTP.Types as HT
-
+import Network.HTTP.Types.Status (status404)
-import           Lib.Prelude
-
 import Network.Minio.API
+import Network.Minio.APICommon
 import Network.Minio.Data
 import Network.Minio.Errors
+import Network.Minio.PresignedOperations
 import Network.Minio.Utils
 import Network.Minio.XmlGenerator
 import Network.Minio.XmlParser
-
+import UnliftIO (Handler (Handler))
 
 -- | Fetch all buckets from the service.
 getService :: Minio [BucketInfo]
 getService = do
-  resp <- executeRequest $ def {
+  resp <-
-      riNeedsLocation = False
+    executeRequest $
+      defaultS3ReqInfo
+        { riNeedsLocation = False
         }
   parseListBuckets $ NC.responseBody resp
 
--- | GET an object from the service and return the response headers
+-- Parse headers from getObject and headObject calls.
--- and a conduit source for the object content
+parseGetObjectHeaders :: Object -> [HT.Header] -> Maybe ObjectInfo
-getObject' :: Bucket -> Object -> HT.Query -> [HT.Header]
+parseGetObjectHeaders object headers =
-           -> Minio ([HT.Header], C.ResumableSource Minio ByteString)
+  let metadataPairs = getMetadata headers
+      userMetadata = getUserMetadataMap metadataPairs
+      metadata = getNonUserMetadataMap metadataPairs
+   in ObjectInfo
+        <$> Just object
+        <*> getLastModifiedHeader headers
+        <*> getETagHeader headers
+        <*> getContentLength headers
+        <*> Just userMetadata
+        <*> Just metadata
+
+-- | GET an object from the service and return parsed ObjectInfo and a
+-- conduit source for the object content
+getObject' ::
+  Bucket ->
+  Object ->
+  HT.Query ->
+  [HT.Header] ->
+  Minio GetObjectResponse
 getObject' bucket object queryParams headers = do
   resp <- mkStreamRequest reqInfo
-  return $ (NC.responseHeaders resp, NC.responseBody resp)
+  let objInfoMaybe = parseGetObjectHeaders object $ NC.responseHeaders resp
+  objInfo <-
+    maybe
+      (throwIO MErrVInvalidObjectInfoResponse)
+      return
+      objInfoMaybe
+  return $
+    GetObjectResponse
+      { gorObjectInfo = objInfo,
+        gorObjectStream = NC.responseBody resp
+      }
   where
-    reqInfo = def { riBucket = Just bucket
+    reqInfo =
-                  , riObject = Just object
+      defaultS3ReqInfo
-                  , riQueryParams = queryParams
+        { riBucket = Just bucket,
-                  , riHeaders = headers
+          riObject = Just object,
+          riQueryParams = queryParams,
+          riHeaders =
+            headers
+              -- This header is required for safety as otherwise http-client,
+              -- sends Accept-Encoding: gzip, and the server may actually gzip
+              -- body. In that case Content-Length header will be missing.
+              <> [("Accept-Encoding", "identity")]
         }
 
 -- | Creates a bucket via a PUT bucket call.
 putBucket :: Bucket -> Region -> Minio ()
 putBucket bucket location = do
-  void $ executeRequest $
+  ns <- asks getSvcNamespace
-    def { riMethod = HT.methodPut
+  void $
-        , riBucket = Just bucket
+    executeRequest $
-        , riPayload = PayloadBS $ mkCreateBucketConfig location
+      defaultS3ReqInfo
-        , riNeedsLocation = False
+        { riMethod = HT.methodPut,
+          riBucket = Just bucket,
+          riPayload = PayloadBS $ mkCreateBucketConfig ns location,
+          riNeedsLocation = False
         }
 
 -- | Single PUT object size.
@@ -116,145 +200,292 @@ maxSinglePutObjectSizeBytes :: Int64
 maxSinglePutObjectSizeBytes = 5 * 1024 * 1024 * 1024
 
 -- | PUT an object into the service. This function performs a single
--- PUT object call, and so can only transfer objects upto 5GiB.
+-- PUT object call and uses a strict ByteString as the object
-putObjectSingle :: Bucket -> Object -> [HT.Header] -> Handle -> Int64
+-- data. `putObjectSingle` is preferable as the object data will not
-                -> Int64 -> Minio ETag
+-- be resident in memory.
-putObjectSingle bucket object headers h offset size = do
+putObjectSingle' :: Bucket -> Object -> [HT.Header] -> ByteString -> Minio ETag
+putObjectSingle' bucket object headers bs = do
+  let size = fromIntegral (BS.length bs)
   -- check length is within single PUT object size.
   when (size > maxSinglePutObjectSizeBytes) $
-    throwM $ MErrVSinglePUTSizeExceeded size
+    throwIO $
+      MErrVSinglePUTSizeExceeded size
 
-  -- content-length header is automatically set by library.
+  let payload = mkStreamingPayload $ PayloadBS bs
-  resp <- executeRequest $
+  resp <-
-          def { riMethod = HT.methodPut
+    executeRequest $
-              , riBucket = Just bucket
+      defaultS3ReqInfo
-              , riObject = Just object
+        { riMethod = HT.methodPut,
-              , riHeaders = headers
+          riBucket = Just bucket,
-              , riPayload = PayloadH h offset size
+          riObject = Just object,
+          riHeaders = headers,
+          riPayload = payload
         }
 
   let rheaders = NC.responseHeaders resp
       etag = getETagHeader rheaders
   maybe
-    (throwM MErrVETagHeaderNotFound)
+    (throwIO MErrVETagHeaderNotFound)
-    return etag
+    return
+    etag
+
+-- | PUT an object into the service. This function performs a single
+-- PUT object call, and so can only transfer objects upto 5GiB.
+putObjectSingle ::
+  Bucket ->
+  Object ->
+  [HT.Header] ->
+  Handle ->
+  Int64 ->
+  Int64 ->
+  Minio ETag
+putObjectSingle bucket object headers h offset size = do
+  -- check length is within single PUT object size.
+  when (size > maxSinglePutObjectSizeBytes) $
+    throwIO $
+      MErrVSinglePUTSizeExceeded size
+
+  -- content-length header is automatically set by library.
+  let payload = mkStreamingPayload $ PayloadH h offset size
+  resp <-
+    executeRequest $
+      defaultS3ReqInfo
+        { riMethod = HT.methodPut,
+          riBucket = Just bucket,
+          riObject = Just object,
+          riHeaders = headers,
+          riPayload = payload
+        }
+
+  let rheaders = NC.responseHeaders resp
+      etag = getETagHeader rheaders
+  maybe
+    (throwIO MErrVETagHeaderNotFound)
+    return
+    etag
+
+-- | List objects in a bucket matching prefix up to delimiter,
+-- starting from nextMarker.
+listObjectsV1' ::
+  Bucket ->
+  Maybe Text ->
+  Maybe Text ->
+  Maybe Text ->
+  Maybe Int ->
+  Minio ListObjectsV1Result
+listObjectsV1' bucket prefix nextMarker delimiter maxKeys = do
+  resp <-
+    executeRequest $
+      defaultS3ReqInfo
+        { riMethod = HT.methodGet,
+          riBucket = Just bucket,
+          riQueryParams = mkOptionalParams params
+        }
+  parseListObjectsV1Response $ NC.responseBody resp
+  where
+    params =
+      [ ("marker", nextMarker),
+        ("prefix", prefix),
+        ("delimiter", delimiter),
+        ("max-keys", show <$> maxKeys)
+      ]
 
 -- | List objects in a bucket matching prefix up to delimiter,
 -- starting from nextToken.
-listObjects' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text
+listObjects' ::
-            -> Minio ListObjectsResult
+  Bucket ->
-listObjects' bucket prefix nextToken delimiter = do
+  Maybe Text ->
-  resp <- executeRequest $ def { riMethod = HT.methodGet
+  Maybe Text ->
-                               , riBucket = Just bucket
+  Maybe Text ->
-                               , riQueryParams = mkOptionalParams params
+  Maybe Int ->
+  Minio ListObjectsResult
+listObjects' bucket prefix nextToken delimiter maxKeys = do
+  resp <-
+    executeRequest $
+      defaultS3ReqInfo
+        { riMethod = HT.methodGet,
+          riBucket = Just bucket,
+          riQueryParams = mkOptionalParams params
         }
   parseListObjectsResponse $ NC.responseBody resp
   where
-    params = [
+    params =
-        ("list-type", Just "2")
+      [ ("list-type", Just "2"),
-      , ("continuation_token", nextToken)
+        ("continuation_token", nextToken),
-      , ("prefix", prefix)
+        ("prefix", prefix),
-      , ("delimiter", delimiter)
+        ("delimiter", delimiter),
+        ("max-keys", show <$> maxKeys)
       ]
 
 -- | DELETE a bucket from the service.
 deleteBucket :: Bucket -> Minio ()
-deleteBucket bucket = do
+deleteBucket bucket =
-  void $ executeRequest $
+  void $
-    def { riMethod = HT.methodDelete
+    executeRequest $
-        , riBucket = Just bucket
+      defaultS3ReqInfo
+        { riMethod = HT.methodDelete,
+          riBucket = Just bucket
         }
 
 -- | DELETE an object from the service.
 deleteObject :: Bucket -> Object -> Minio ()
-deleteObject bucket object = do
+deleteObject bucket object =
-  void $ executeRequest $
+  void $
-    def { riMethod = HT.methodDelete
+    executeRequest $
-        , riBucket = Just bucket
+      defaultS3ReqInfo
-        , riObject = Just object
+        { riMethod = HT.methodDelete,
+          riBucket = Just bucket,
+          riObject = Just object
         }
 
 -- | Create a new multipart upload.
 newMultipartUpload :: Bucket -> Object -> [HT.Header] -> Minio UploadId
 newMultipartUpload bucket object headers = do
-  resp <- executeRequest $ def { riMethod = HT.methodPost
+  resp <-
-                               , riBucket = Just bucket
+    executeRequest $
-                               , riObject = Just object
+      defaultS3ReqInfo
-                               , riQueryParams = [("uploads", Nothing)]
+        { riMethod = HT.methodPost,
-                               , riHeaders = headers
+          riBucket = Just bucket,
+          riObject = Just object,
+          riQueryParams = [("uploads", Nothing)],
+          riHeaders = headers
         }
   parseNewMultipartUpload $ NC.responseBody resp
 
 -- | PUT a part of an object as part of a multipart upload.
-putObjectPart :: Bucket -> Object -> UploadId -> PartNumber -> [HT.Header]
+putObjectPart ::
-              -> Payload -> Minio PartTuple
+  Bucket ->
+  Object ->
+  UploadId ->
+  PartNumber ->
+  [HT.Header] ->
+  Payload ->
+  Minio PartTuple
 putObjectPart bucket object uploadId partNumber headers payload = do
-  resp <- executeRequest $
+  -- transform payload to conduit to enable streaming signature
-          def { riMethod = HT.methodPut
+  let payload' = mkStreamingPayload payload
-              , riBucket = Just bucket
+  resp <-
-              , riObject = Just object
+    executeRequest $
-              , riQueryParams = mkOptionalParams params
+      defaultS3ReqInfo
-              , riHeaders = headers
+        { riMethod = HT.methodPut,
-              , riPayload = payload
+          riBucket = Just bucket,
+          riObject = Just object,
+          riQueryParams = mkOptionalParams params,
+          riHeaders = headers,
+          riPayload = payload'
         }
   let rheaders = NC.responseHeaders resp
       etag = getETagHeader rheaders
   maybe
-    (throwM MErrVETagHeaderNotFound)
+    (throwIO MErrVETagHeaderNotFound)
-    (return . (partNumber, )) etag
+    (return . (partNumber,))
+    etag
   where
-    params = [
+    params =
-        ("uploadId", Just uploadId)
+      [ ("uploadId", Just uploadId),
-      , ("partNumber", Just $ show partNumber)
+        ("partNumber", Just $ show partNumber)
       ]
 
+srcInfoToHeaders :: SourceInfo -> [HT.Header]
+srcInfoToHeaders srcInfo =
+  ( "x-amz-copy-source",
+    encodeUtf8 $
+      T.concat
+        [ "/",
+          srcBucket srcInfo,
+          "/",
+          srcObject srcInfo
+        ]
+  )
+    : rangeHdr
+    ++ zip names values
+  where
+    names =
+      [ "x-amz-copy-source-if-match",
+        "x-amz-copy-source-if-none-match",
+        "x-amz-copy-source-if-unmodified-since",
+        "x-amz-copy-source-if-modified-since"
+      ]
+    values =
+      mapMaybe
+        (fmap encodeUtf8 . (srcInfo &))
+        [ srcIfMatch,
+          srcIfNoneMatch,
+          fmap formatRFC1123 . srcIfUnmodifiedSince,
+          fmap formatRFC1123 . srcIfModifiedSince
+        ]
+    rangeHdr =
+      maybe [] ((\a -> [("x-amz-copy-source-range", HT.renderByteRanges [a])]) . toByteRange) (srcRange srcInfo)
+    toByteRange :: (Int64, Int64) -> HT.ByteRange
+    toByteRange (x, y) = HT.ByteRangeFromTo (fromIntegral x) (fromIntegral y)
+
 -- | Performs server-side copy of an object or part of an object as an
 -- upload part of an ongoing multi-part upload.
-copyObjectPart :: Bucket -> Object -> CopyPartSource -> UploadId
+copyObjectPart ::
-               -> PartNumber -> [HT.Header] -> Minio (ETag, UTCTime)
+  DestinationInfo ->
-copyObjectPart bucket object cps uploadId partNumber headers = do
+  SourceInfo ->
-  resp <- executeRequest $
+  UploadId ->
-          def { riMethod = HT.methodPut
+  PartNumber ->
-              , riBucket = Just bucket
+  [HT.Header] ->
-              , riObject = Just object
+  Minio (ETag, UTCTime)
-              , riQueryParams = mkOptionalParams params
+copyObjectPart dstInfo srcInfo uploadId partNumber headers = do
-              , riHeaders = headers ++ cpsToHeaders cps
+  resp <-
+    executeRequest $
+      defaultS3ReqInfo
+        { riMethod = HT.methodPut,
+          riBucket = Just $ dstBucket dstInfo,
+          riObject = Just $ dstObject dstInfo,
+          riQueryParams = mkOptionalParams params,
+          riHeaders = headers ++ srcInfoToHeaders srcInfo
         }
 
   parseCopyObjectResponse $ NC.responseBody resp
   where
-    params = [
+    params =
-        ("uploadId", Just uploadId)
+      [ ("uploadId", Just uploadId),
-      , ("partNumber", Just $ show partNumber)
+        ("partNumber", Just $ show partNumber)
       ]
 
 -- | Performs server-side copy of an object that is upto 5GiB in
 -- size. If the object is greater than 5GiB, this function throws the
 -- error returned by the server.
-copyObjectSingle :: Bucket -> Object -> CopyPartSource -> [HT.Header]
+copyObjectSingle ::
-                 -> Minio (ETag, UTCTime)
+  Bucket ->
-copyObjectSingle bucket object cps headers = do
+  Object ->
-  -- validate that cpSourceRange is Nothing for this API.
+  SourceInfo ->
-  when (isJust $ cpSourceRange cps) $
+  [HT.Header] ->
-    throwM MErrVCopyObjSingleNoRangeAccepted
+  Minio (ETag, UTCTime)
-  resp <- executeRequest $
+copyObjectSingle bucket object srcInfo headers = do
-          def { riMethod = HT.methodPut
+  -- validate that srcRange is Nothing for this API.
-              , riBucket = Just bucket
+  when (isJust $ srcRange srcInfo) $
-              , riObject = Just object
+    throwIO MErrVCopyObjSingleNoRangeAccepted
-              , riHeaders = headers ++ cpsToHeaders cps
+  resp <-
+    executeRequest $
+      defaultS3ReqInfo
+        { riMethod = HT.methodPut,
+          riBucket = Just bucket,
+          riObject = Just object,
+          riHeaders = headers ++ srcInfoToHeaders srcInfo
         }
   parseCopyObjectResponse $ NC.responseBody resp
 
 -- | Complete a multipart upload.
-completeMultipartUpload :: Bucket -> Object -> UploadId -> [PartTuple]
+completeMultipartUpload ::
-                        -> Minio ETag
+  Bucket ->
+  Object ->
+  UploadId ->
+  [PartTuple] ->
+  Minio ETag
 completeMultipartUpload bucket object uploadId partTuple = do
-  resp <- executeRequest $
+  resp <-
-          def { riMethod = HT.methodPost
+    executeRequest $
-              , riBucket = Just bucket
+      defaultS3ReqInfo
-              , riObject = Just object
+        { riMethod = HT.methodPost,
-              , riQueryParams = mkOptionalParams params
+          riBucket = Just bucket,
-              , riPayload = PayloadBS $
+          riObject = Just object,
+          riQueryParams = mkOptionalParams params,
+          riPayload =
+            PayloadBS $
               mkCompleteMultipartUploadRequest partTuple
         }
   parseCompleteMultipartUploadResponse $ NC.responseBody resp
@@ -263,65 +494,192 @@ completeMultipartUpload bucket object uploadId partTuple = do
 
 -- | Abort a multipart upload.
 abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio ()
-abortMultipartUpload bucket object uploadId = do
+abortMultipartUpload bucket object uploadId =
-  void $ executeRequest $ def { riMethod = HT.methodDelete
+  void $
-                              , riBucket = Just bucket
+    executeRequest $
-                              , riObject = Just object
+      defaultS3ReqInfo
-                              , riQueryParams = mkOptionalParams params
+        { riMethod = HT.methodDelete,
+          riBucket = Just bucket,
+          riObject = Just object,
+          riQueryParams = mkOptionalParams params
         }
   where
     params = [("uploadId", Just uploadId)]
 
 -- | List incomplete multipart uploads.
-listIncompleteUploads' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text
+listIncompleteUploads' ::
-                       -> Maybe Text -> Minio ListUploadsResult
+  Bucket ->
-listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker = do
+  Maybe Text ->
-  resp <- executeRequest $ def { riMethod = HT.methodGet
+  Maybe Text ->
-                               , riBucket = Just bucket
+  Maybe Text ->
-                               , riQueryParams = params
+  Maybe Text ->
+  Maybe Int ->
+  Minio ListUploadsResult
+listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker maxKeys = do
+  resp <-
+    executeRequest $
+      defaultS3ReqInfo
+        { riMethod = HT.methodGet,
+          riBucket = Just bucket,
+          riQueryParams = params
         }
   parseListUploadsResponse $ NC.responseBody resp
   where
     -- build query params
-    params = ("uploads", Nothing) : mkOptionalParams
+    params =
-             [ ("prefix", prefix)
+      ("uploads", Nothing)
-             , ("delimiter", delimiter)
+        : mkOptionalParams
-             , ("key-marker", keyMarker)
+          [ ("prefix", prefix),
-             , ("upload-id-marker", uploadIdMarker)
+            ("delimiter", delimiter),
+            ("key-marker", keyMarker),
+            ("upload-id-marker", uploadIdMarker),
+            ("max-uploads", show <$> maxKeys)
           ]
 
-
 -- | List parts of an ongoing multipart upload.
-listIncompleteParts' :: Bucket -> Object -> UploadId -> Maybe Text
+listIncompleteParts' ::
-                     -> Maybe Text -> Minio ListPartsResult
+  Bucket ->
+  Object ->
+  UploadId ->
+  Maybe Text ->
+  Maybe Text ->
+  Minio ListPartsResult
 listIncompleteParts' bucket object uploadId maxParts partNumMarker = do
-  resp <- executeRequest $ def { riMethod = HT.methodGet
+  resp <-
-                               , riBucket = Just bucket
+    executeRequest $
-                               , riObject = Just object
+      defaultS3ReqInfo
-                               , riQueryParams = mkOptionalParams params
+        { riMethod = HT.methodGet,
+          riBucket = Just bucket,
+          riObject = Just object,
+          riQueryParams = mkOptionalParams params
         }
   parseListPartsResponse $ NC.responseBody resp
   where
     -- build optional query params
-    params = [
+    params =
-        ("uploadId", Just uploadId)
+      [ ("uploadId", Just uploadId),
-      , ("part-number-marker", partNumMarker)
+        ("part-number-marker", partNumMarker),
-      , ("max-parts", maxParts)
+        ("max-parts", maxParts)
       ]
 
 -- | Get metadata of an object.
-headObject :: Bucket -> Object -> Minio ObjectInfo
+headObject :: Bucket -> Object -> [HT.Header] -> Minio ObjectInfo
-headObject bucket object = do
+headObject bucket object reqHeaders = do
-  resp <- executeRequest $ def { riMethod = HT.methodHead
+  resp <-
-                               , riBucket = Just bucket
+    executeRequest $
-                               , riObject = Just object
+      defaultS3ReqInfo
+        { riMethod = HT.methodHead,
+          riBucket = Just bucket,
+          riObject = Just object,
+          riHeaders =
+            reqHeaders
+              -- This header is required for safety as otherwise http-client,
+              -- sends Accept-Encoding: gzip, and the server may actually gzip
+              -- body. In that case Content-Length header will be missing.
+              <> [("Accept-Encoding", "identity")]
+        }
+  maybe (throwIO MErrVInvalidObjectInfoResponse) return $
+    parseGetObjectHeaders object $
+      NC.responseHeaders resp
+
+-- | Query the object store if a given bucket exists.
+headBucket :: Bucket -> Minio Bool
+headBucket bucket =
+  headBucketEx
+    `catches` [ Handler handleNoSuchBucket,
+                Handler handleStatus404
+              ]
+  where
+    handleNoSuchBucket :: ServiceErr -> Minio Bool
+    handleNoSuchBucket e
+      | e == NoSuchBucket = return False
+      | otherwise = throwIO e
+    handleStatus404 :: NC.HttpException -> Minio Bool
+    handleStatus404 e@(NC.HttpExceptionRequest _ (NC.StatusCodeException res _)) =
+      if NC.responseStatus res == status404
+        then return False
+        else throwIO e
+    handleStatus404 e = throwIO e
+    headBucketEx = do
+      resp <-
+        executeRequest $
+          defaultS3ReqInfo
+            { riMethod = HT.methodHead,
+              riBucket = Just bucket
+            }
+      return $ NC.responseStatus resp == HT.ok200
+
+-- | Set the notification configuration on a bucket.
+putBucketNotification :: Bucket -> Notification -> Minio ()
+putBucketNotification bucket ncfg = do
+  ns <- asks getSvcNamespace
+  void $
+    executeRequest $
+      defaultS3ReqInfo
+        { riMethod = HT.methodPut,
+          riBucket = Just bucket,
+          riQueryParams = [("notification", Nothing)],
+          riPayload =
+            PayloadBS $
+              mkPutNotificationRequest ns ncfg
         }
 
-  let
+-- | Retrieve the notification configuration on a bucket.
-    headers = NC.responseHeaders resp
+getBucketNotification :: Bucket -> Minio Notification
-    modTime = getLastModifiedHeader headers
+getBucketNotification bucket = do
-    etag = getETagHeader headers
+  resp <-
-    size = getContentLength headers
+    executeRequest $
+      defaultS3ReqInfo
+        { riMethod = HT.methodGet,
+          riBucket = Just bucket,
+          riQueryParams = [("notification", Nothing)]
+        }
+  parseNotification $ NC.responseBody resp
 
-  maybe (throwM MErrVInvalidObjectInfoResponse) return $
+-- | Remove all notifications configured on a bucket.
-    ObjectInfo <$> Just object <*> modTime <*> etag <*> size
+removeAllBucketNotification :: Bucket -> Minio ()
+removeAllBucketNotification = flip putBucketNotification defaultNotification
+
+-- | Fetch the policy if any on a bucket.
+getBucketPolicy :: Bucket -> Minio Text
+getBucketPolicy bucket = do
+  resp <-
+    executeRequest $
+      defaultS3ReqInfo
+        { riMethod = HT.methodGet,
+          riBucket = Just bucket,
+          riQueryParams = [("policy", Nothing)]
+        }
+  return $ decodeUtf8Lenient $ toStrictBS $ NC.responseBody resp
+
+-- | Set a new policy on a bucket.
+-- As a special condition if the policy is empty
+-- then we treat it as policy DELETE operation.
+setBucketPolicy :: Bucket -> Text -> Minio ()
+setBucketPolicy bucket policy = do
+  if T.null policy
+    then deleteBucketPolicy bucket
+    else putBucketPolicy bucket policy
+
+-- | Save a new policy on a bucket.
+putBucketPolicy :: Bucket -> Text -> Minio ()
+putBucketPolicy bucket policy = do
+  void $
+    executeRequest $
+      defaultS3ReqInfo
+        { riMethod = HT.methodPut,
+          riBucket = Just bucket,
+          riQueryParams = [("policy", Nothing)],
+          riPayload = PayloadBS $ encodeUtf8 policy
+        }
+
+-- | Delete any policy set on a bucket.
+deleteBucketPolicy :: Bucket -> Minio ()
+deleteBucketPolicy bucket = do
+  void $
+    executeRequest $
+      defaultS3ReqInfo
+        { riMethod = HT.methodDelete,
+          riBucket = Just bucket,
+          riQueryParams = [("policy", Nothing)]
+        }

src/Network/Minio/SelectAPI.hs

@@ -0,0 +1,294 @@
+--
+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- 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.SelectAPI
+  ( -- | The `selectObjectContent` allows querying CSV, JSON or Parquet
+    -- format objects in AWS S3 and in MinIO using SQL Select
+    -- statements. This allows significant reduction of data transfer
+    -- from object storage for computation-intensive tasks, as relevant
+    -- data is filtered close to the storage.
+    selectObjectContent,
+    SelectRequest,
+    selectRequest,
+
+    -- *** Input Serialization
+    InputSerialization,
+    defaultCsvInput,
+    linesJsonInput,
+    documentJsonInput,
+    defaultParquetInput,
+    setInputCSVProps,
+    CompressionType (..),
+    setInputCompressionType,
+
+    -- *** CSV Format details
+
+    -- | CSV format options such as delimiters and quote characters are
+    -- specified using using the functions below. Options are combined
+    -- monoidally.
+    CSVProp,
+    recordDelimiter,
+    fieldDelimiter,
+    quoteCharacter,
+    quoteEscapeCharacter,
+    commentCharacter,
+    allowQuotedRecordDelimiter,
+    FileHeaderInfo (..),
+    fileHeaderInfo,
+    QuoteFields (..),
+    quoteFields,
+
+    -- *** Output Serialization
+    OutputSerialization,
+    defaultCsvOutput,
+    defaultJsonOutput,
+    outputCSVFromProps,
+    outputJSONFromRecordDelimiter,
+
+    -- *** Progress messages
+    setRequestProgressEnabled,
+
+    -- *** Interpreting Select output
+
+    -- | The conduit returned by `selectObjectContent` returns values of
+    -- the `EventMessage` data type. This returns the query output
+    -- messages formatted according to the chosen output serialization,
+    -- interleaved with progress messages (if enabled by
+    -- `setRequestProgressEnabled`), and at the end a statistics
+    -- message.
+    --
+    -- If the application is interested in only the payload, then
+    -- `getPayloadBytes` can be used. For example to simply print the
+    -- payload to stdout:
+    --
+    -- > resultConduit <- selectObjectContent bucket object mySelectRequest
+    -- > runConduit $ resultConduit .| getPayloadBytes .| stdoutC
+    --
+    -- Note that runConduit, the connect operator (.|) and stdoutC are
+    -- all from the "conduit" package.
+    getPayloadBytes,
+    EventMessage (..),
+    Progress (..),
+    Stats,
+  )
+where
+
+import Conduit ((.|))
+import qualified Conduit as C
+import qualified Data.Binary as Bin
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
+import Data.Digest.CRC32 (crc32, crc32Update)
+import Lib.Prelude
+import qualified Network.HTTP.Conduit as NC
+import qualified Network.HTTP.Types as HT
+import Network.Minio.API
+import Network.Minio.Data
+import Network.Minio.Errors
+import Network.Minio.Utils
+import Network.Minio.XmlGenerator
+import Network.Minio.XmlParser
+import UnliftIO (MonadUnliftIO)
+
+data EventStreamException
+  = ESEPreludeCRCFailed
+  | ESEMessageCRCFailed
+  | ESEUnexpectedEndOfStream
+  | ESEDecodeFail [Char]
+  | ESEInvalidHeaderType
+  | ESEInvalidHeaderValueType
+  | ESEInvalidMessageType
+  deriving stock (Eq, Show)
+
+instance Exception EventStreamException
+
+-- chunkSize in bytes is 32KiB
+chunkSize :: Int
+chunkSize = 32 * 1024
+
+parseBinary :: (Bin.Binary a) => ByteString -> IO a
+parseBinary b = do
+  case Bin.decodeOrFail $ LB.fromStrict b of
+    Left (_, _, msg) -> throwIO $ ESEDecodeFail msg
+    Right (_, _, r) -> return r
+
+bytesToHeaderName :: Text -> IO MsgHeaderName
+bytesToHeaderName t = case t of
+  ":message-type" -> return MessageType
+  ":event-type" -> return EventType
+  ":content-type" -> return ContentType
+  ":error-code" -> return ErrorCode
+  ":error-message" -> return ErrorMessage
+  _ -> throwIO ESEInvalidHeaderType
+
+parseHeaders ::
+  (MonadUnliftIO m) =>
+  Word32 ->
+  C.ConduitM ByteString a m [MessageHeader]
+parseHeaders 0 = return []
+parseHeaders hdrLen = do
+  bs1 <- readNBytes 1
+  n :: Word8 <- liftIO $ parseBinary bs1
+
+  headerKeyBytes <- readNBytes $ fromIntegral n
+  let headerKey = decodeUtf8Lenient headerKeyBytes
+  headerName <- liftIO $ bytesToHeaderName headerKey
+
+  bs2 <- readNBytes 1
+  headerValueType :: Word8 <- liftIO $ parseBinary bs2
+  when (headerValueType /= 7) $ throwIO ESEInvalidHeaderValueType
+
+  bs3 <- readNBytes 2
+  vLen :: Word16 <- liftIO $ parseBinary bs3
+  headerValueBytes <- readNBytes $ fromIntegral vLen
+  let headerValue = decodeUtf8Lenient headerValueBytes
+      m = (headerName, headerValue)
+      k = 1 + fromIntegral n + 1 + 2 + fromIntegral vLen
+
+  ms <- parseHeaders (hdrLen - k)
+  return (m : ms)
+
+-- 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 n = do
+  b <- LB.toStrict <$> (C.takeCE n .| C.sinkLazy)
+  if B.length b /= n
+    then throwIO ESEUnexpectedEndOfStream
+    else return b
+
+crcCheck ::
+  (MonadUnliftIO m) =>
+  C.ConduitM ByteString ByteString m ()
+crcCheck = do
+  b <- readNBytes 12
+  n :: Word32 <- liftIO $ parseBinary $ B.take 4 b
+  preludeCRC :: Word32 <- liftIO $ parseBinary $ B.drop 8 b
+  when (crc32 (B.take 8 b) /= preludeCRC) $
+    throwIO ESEPreludeCRCFailed
+
+  -- we do not yield the checksum
+  C.yield $ B.take 8 b
+
+  -- 12 bytes have been read off the current message. Now read the
+  -- next (n-12)-4 bytes and accumulate the checksum, and yield it.
+  let startCrc = crc32 b
+  finalCrc <- accumulateYield (fromIntegral n - 16) startCrc
+
+  bs <- readNBytes 4
+  expectedCrc :: Word32 <- liftIO $ parseBinary bs
+
+  when (finalCrc /= expectedCrc) $
+    throwIO ESEMessageCRCFailed
+
+  -- we unconditionally recurse - downstream figures out when to
+  -- quit reading the stream
+  crcCheck
+  where
+    accumulateYield n checkSum = do
+      let toRead = min n chunkSize
+      b <- readNBytes toRead
+      let c' = crc32Update checkSum b
+          n' = n - B.length b
+      C.yield b
+      if n' > 0
+        then accumulateYield n' c'
+        else return c'
+
+handleMessage :: (MonadUnliftIO m) => C.ConduitT ByteString EventMessage m ()
+handleMessage = do
+  b1 <- readNBytes 4
+  msgLen :: Word32 <- liftIO $ parseBinary b1
+
+  b2 <- readNBytes 4
+  hdrLen :: Word32 <- liftIO $ parseBinary b2
+
+  hs <- parseHeaders hdrLen
+
+  let payloadLen = msgLen - hdrLen - 16
+      getHdrVal h = fmap snd . find ((h ==) . fst)
+      eventHdrValue = getHdrVal EventType hs
+      msgHdrValue = getHdrVal MessageType hs
+      errCode = getHdrVal ErrorCode hs
+      errMsg = getHdrVal ErrorMessage hs
+
+  case msgHdrValue of
+    Just "event" -> do
+      case eventHdrValue of
+        Just "Records" -> passThrough $ fromIntegral payloadLen
+        Just "Cont" -> return ()
+        Just "Progress" -> do
+          bs <- readNBytes $ fromIntegral payloadLen
+          progress <- parseSelectProgress bs
+          C.yield $ ProgressEventMessage progress
+        Just "Stats" -> do
+          bs <- readNBytes $ fromIntegral payloadLen
+          stats <- parseSelectProgress bs
+          C.yield $ StatsEventMessage stats
+        Just "End" -> return ()
+        _ -> throwIO ESEInvalidMessageType
+      when (eventHdrValue /= Just "End") handleMessage
+    Just "error" -> do
+      let reqMsgMay = RequestLevelErrorMessage <$> errCode <*> errMsg
+      maybe (throwIO ESEInvalidMessageType) C.yield reqMsgMay
+    _ -> throwIO ESEInvalidMessageType
+  where
+    passThrough 0 = return ()
+    passThrough n = do
+      let c = min n chunkSize
+      b <- readNBytes c
+      C.yield $ RecordPayloadEventMessage b
+      passThrough $ n - B.length b
+
+selectProtoConduit ::
+  (MonadUnliftIO m) =>
+  C.ConduitT ByteString EventMessage m ()
+selectProtoConduit = crcCheck .| handleMessage
+
+-- | selectObjectContent calls the SelectRequest on the given
+-- object. It returns a Conduit of event messages that can be consumed
+-- by the client.
+selectObjectContent ::
+  Bucket ->
+  Object ->
+  SelectRequest ->
+  Minio (C.ConduitT () EventMessage Minio ())
+selectObjectContent b o r = do
+  let reqInfo =
+        defaultS3ReqInfo
+          { riMethod = HT.methodPost,
+            riBucket = Just b,
+            riObject = Just o,
+            riPayload = PayloadBS $ mkSelectRequest r,
+            riNeedsLocation = False,
+            riQueryParams = [("select", Nothing), ("select-type", Just "2")]
+          }
+  -- print $ mkSelectRequest r
+  resp <- mkStreamRequest reqInfo
+  return $ NC.responseBody resp .| selectProtoConduit
+
+-- | A helper conduit that returns only the record payload bytes.
+getPayloadBytes :: (MonadIO m) => C.ConduitT EventMessage ByteString m ()
+getPayloadBytes = do
+  evM <- C.await
+  case evM of
+    Just v -> do
+      case v of
+        RecordPayloadEventMessage b -> C.yield b
+        RequestLevelErrorMessage c m -> liftIO $ throwIO $ SelectErr c m
+        _ -> return ()
+      getPayloadBytes
+    Nothing -> return ()

src/Network/Minio/Sign/V4.hs

@@ -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.
@@ -13,164 +13,482 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE BangPatterns #-}
 
 module Network.Minio.Sign.V4
-  (
+  ( SignParams (..),
-    signV4
+    signV4QueryParams,
-  , signV4AtTime
+    signV4,
-  , getScope
+    signV4PostPolicy,
-  , getHeadersToSign
+    signV4Stream,
-  , getCanonicalRequest
+    Service (..),
-  , SignV4Data(..)
+    credentialScope,
-  , debugPrintSignV4Data
+  )
-  ) where
+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
-import           Data.ByteString.Char8 (pack)
+import qualified Data.ByteString.Lazy as LB
 import Data.CaseInsensitive (mk)
 import qualified Data.CaseInsensitive as CI
-import qualified Data.Set as Set
+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           Network.HTTP.Types (Header)
-
 import Lib.Prelude
-import           Network.Minio.Data
+import qualified Network.HTTP.Conduit as NC
+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
+import Network.Minio.Errors
+import Text.Printf (printf)
 
-ignoredHeaders :: Set ByteString
+-- these headers are not included in the string to sign when signing a
-ignoredHeaders = Set.fromList $ map CI.foldedCase [
+-- request
-  mk "Authorization",
+ignoredHeaders :: Set.HashSet ByteString
-  mk "Content-Type",
+ignoredHeaders =
-  mk "Content-Length",
+  Set.fromList $
-  mk "User-Agent"
+    map
+      CI.foldedCase
+      [ H.hAuthorization,
+        H.hContentType,
+        H.hUserAgent
       ]
 
-data SignV4Data = SignV4Data {
+data Service = ServiceS3 | ServiceSTS
-    sv4SignTime :: UTCTime
+  deriving stock (Eq, Show)
-  , sv4Scope :: ByteString
-  , sv4CanonicalRequest :: ByteString
-  , sv4HeadersToSign :: [(ByteString, ByteString)]
-  , sv4InputHeaders :: [Header]
-  , sv4OutputHeaders :: [Header]
-  , sv4StringToSign :: ByteString
-  , sv4SigningKey :: ByteString
-  } deriving (Show)
 
-debugPrintSignV4Data :: SignV4Data -> IO ()
+toByteString :: Service -> ByteString
-debugPrintSignV4Data (SignV4Data t s cr h2s ih oh sts sk) = do
+toByteString ServiceS3 = "s3"
-  B8.putStrLn "SignV4Data:"
+toByteString ServiceSTS = "sts"
-  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 "Input headers: " >> print ih
-  B8.putStr "Output headers: " >> print oh
-  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.concat [show x,  " "]) $ B.unpack b
-      B8.putStrLn ""
 
--- | Given MinioClient and request details, including request method,
+data SignParams = SignParams
+  { spAccessKey :: Text,
+    spSecretKey :: BA.ScrubbedBytes,
+    spSessionToken :: Maybe BA.ScrubbedBytes,
+    spService :: Service,
+    spTimeStamp :: UTCTime,
+    spRegion :: Maybe Text,
+    spExpirySecs :: Maybe UrlExpiry,
+    spPayloadHash :: Maybe ByteString
+  }
+  deriving stock (Show)
+
+mkAuthHeader :: Text -> ByteString -> ByteString -> ByteString -> H.Header
+mkAuthHeader accessKey scope signedHeaderKeys sign =
+  let authValue =
+        B.concat
+          [ "AWS4-HMAC-SHA256 Credential=",
+            encodeUtf8 accessKey,
+            "/",
+            scope,
+            ", SignedHeaders=",
+            signedHeaderKeys,
+            ", Signature=",
+            sign
+          ]
+   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
 -- Authorization header, which includes the signature.
-signV4 :: ConnectInfo -> RequestInfo
+--
-       -> IO [Header]
+-- For normal requests (i.e. without an expiry time), the output is
-signV4 ci ri = do
+-- the list of headers to add to authenticate the request.
-  timestamp <- Time.getCurrentTime
+--
-  let signData = signV4AtTime timestamp ci ri
+-- If `expiry` is not Nothing, it is assumed that a presigned request
-  -- debugPrintSignV4Data signData
+-- is being created. The expiry is interpreted as an integer number of
-  return $ sv4OutputHeaders signData
+-- seconds. The output will be the list of query-parameters to add to
+-- the request.
+signV4QueryParams :: SignParams -> NC.Request -> SimpleQuery
+signV4QueryParams !sp !req =
+  let scope = credentialScope sp
+      expiry = spExpirySecs sp
 
--- | Takes a timestamp, server params and request params and generates
+      headersToSign = getHeadersToSign $ NC.requestHeaders req
--- an updated list of headers.
+      signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign
-signV4AtTime :: UTCTime -> ConnectInfo -> RequestInfo -> SignV4Data
+      -- query-parameters to be added before signing for presigned URLs
-signV4AtTime ts ci ri =
+      -- (i.e. when `isJust expiry`)
-  SignV4Data ts scope canonicalRequest headersToSign (riHeaders ri) outHeaders stringToSign signingKey
+      authQP =
-  where
+        [ ("X-Amz-Algorithm", "AWS4-HMAC-SHA256"),
-    outHeaders = authHeader : headersWithDate
+          ("X-Amz-Credential", B.concat [encodeUtf8 $ spAccessKey sp, "/", scope]),
-    timeBS = awsTimeFormatBS ts
+          ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp),
-    dateHeader = (mk "X-Amz-Date", timeBS)
+          ("X-Amz-Expires", maybe "" showBS expiry),
-    hostHeader = (mk "host", encodeUtf8 $ format "{}:{}" $
+          ("X-Amz-SignedHeaders", signedHeaderKeys)
-                   [connectHost ci, show $ connectPort ci])
+        ]
+          ++ maybeToList ((amzSecurityToken,) . BA.convert <$> spSessionToken sp)
+      finalQP =
+        parseQuery (NC.queryString req)
+          ++ if isJust expiry
+            then (fmap . fmap) Just authQP
+            else []
+      -- 1. compute canonical request
+      canonicalRequest =
+        mkCanonicalRequest
+          False
+          sp
+          (NC.setQueryString finalQP req)
+          headersToSign
 
-    headersWithDate = dateHeader : hostHeader : (riHeaders ri)
+      -- 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
+   in ("X-Amz-Signature", signature) : authQP
 
-    authHeader = (mk "Authorization", authHeaderValue)
+-- | 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
 
-    region = maybe (connectRegion ci) identity $ riRegion ri
+      -- 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)
 
-    scope = getScope ts region
+      -- 1. compute canonical request
+      reqHeaders = NC.requestHeaders req ++ extraHeaders
+      (canonicalRequest, signedHeaderKeys) =
+        getCanonicalRequestAndSignedHeaders
+          NotStreaming
+          sp
+          req
+          reqHeaders
 
-    authHeaderValue = B.concat [
+      -- 2. compute string to sign
-      "AWS4-HMAC-SHA256 Credential=",
+      stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest
-      encodeUtf8 (connectAccessKey ci), "/", scope,
+      -- 3.1 compute signing key
-      ", SignedHeaders=", signedHeaders,
+      signingKey = getSigningKey sp
-      ", Signature=", signature
+      -- 3.2 compute signature
-      ]
+      signature = computeSignature stringToSign signingKey
-
+      -- 4. compute auth header
-    headersToSign = getHeadersToSign headersWithDate
+      authHeader = mkAuthHeader (spAccessKey sp) scope signedHeaderKeys signature
-
+   in authHeader : extraHeaders
-    signedHeaders = B.intercalate ";" $ map fst headersToSign
+
-
+credentialScope :: SignParams -> ByteString
-    signature = digestToBase16 $ hmacSHA256 stringToSign signingKey
+credentialScope sp =
-
+  let region = fromMaybe "" $ spRegion sp
-    signingKey = hmacSHA256RawBS "aws4_request"
+   in B.intercalate
-               . hmacSHA256RawBS "s3"
+        "/"
-               . hmacSHA256RawBS (encodeUtf8 region)
+        [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" $ spTimeStamp sp,
-               . hmacSHA256RawBS (awsDateFormatBS ts)
+          encodeUtf8 region,
-               $ (B.concat ["AWS4", encodeUtf8 $ connectSecretKey ci])
+          toByteString $ spService sp,
-
+          "aws4_request"
-    stringToSign  = B.intercalate "\n" $
-      ["AWS4-HMAC-SHA256",
-       timeBS,
-       scope,
-       hashSHA256 $ canonicalRequest
-      ]
-
-    canonicalRequest = getCanonicalRequest ri headersToSign
-
-
-getScope :: UTCTime -> Region -> ByteString
-getScope ts region = B.intercalate "/" $ [
-  pack $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts,
-  encodeUtf8 region, "s3", "aws4_request"
         ]
 
+-- Folds header name, trims whitespace in header values, skips ignored headers
+-- and sorts headers.
 getHeadersToSign :: [Header] -> [(ByteString, ByteString)]
-getHeadersToSign h =
+getHeadersToSign !h =
-  sort $
+  filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $
-  filter (flip Set.notMember ignoredHeaders . fst) $
+    map (bimap CI.foldedCase stripBS) h
-  map (\(x, y) -> (CI.foldedCase x, stripBS y)) $
-  h
 
-getCanonicalRequest :: RequestInfo -> [(ByteString, ByteString)] -> ByteString
+-- | Given the list of headers in the request, computes the canonical headers
-getCanonicalRequest ri headersForSign = B.intercalate "\n" $ [
+-- and the signed headers strings.
-  riMethod ri,
+getCanonicalHeaders :: NonEmpty Header -> (ByteString, ByteString)
-  uriEncode False path,
+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 ->
+  NC.Request ->
+  [(ByteString, ByteString)] ->
+  ByteString
+mkCanonicalRequest !isStreaming !sp !req !headersForSign =
+  let httpMethod = NC.method req
+      canonicalUri = uriEncode False $ NC.path req
+      canonicalQueryString =
+        B.intercalate "&" $
+          map (\(x, y) -> B.concat [x, "=", y]) $
+            sortBy (\a b -> compare (fst a) (fst b)) $
+              map
+                ( bimap (uriEncode True) (maybe "" (uriEncode True))
+                )
+                (parseQuery $ NC.queryString req)
+      sortedHeaders = sort headersForSign
+      canonicalHeaders =
+        B.concat $
+          map (\(x, y) -> B.concat [x, ":", y, "\n"]) sortedHeaders
+      signedHeaders = B.intercalate ";" $ map fst sortedHeaders
+      payloadHashStr =
+        if isStreaming
+          then "STREAMING-AWS4-HMAC-SHA256-PAYLOAD"
+          else fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp
+   in B.intercalate
+        "\n"
+        [ httpMethod,
+          canonicalUri,
           canonicalQueryString,
           canonicalHeaders,
           signedHeaders,
-  riPayloadHash ri
+          payloadHashStr
         ]
-  where
-    path = getPathFromRI ri
 
-    canonicalQueryString = B.intercalate "&" $
+mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString
-      map (\(x, y) -> B.concat [x, "=", y]) $
+mkStringToSign ts !scope !canonicalRequest =
-      sort $ map (\(x, y) ->
+  B.intercalate
-                    (uriEncode True x, maybe "" (uriEncode True) y)) $
+    "\n"
-      riQueryParams ri
+    [ "AWS4-HMAC-SHA256",
+      awsTimeFormatBS ts,
+      scope,
+      hashSHA256 canonicalRequest
+    ]
 
-    canonicalHeaders = B.concat $
+getSigningKey :: SignParams -> ByteString
-      map (\(x, y) -> B.concat [x, ":", y, "\n"]) $
+getSigningKey sp =
-      headersForSign
+  hmacSHA256RawBS "aws4_request"
+    . hmacSHA256RawBS (toByteString $ spService sp)
+    . hmacSHA256RawBS (encodeUtf8 $ fromMaybe "" $ spRegion sp)
+    . hmacSHA256RawBS (awsDateFormatBS $ spTimeStamp sp)
+    $ B.concat ["AWS4", BA.convert $ spSecretKey sp]
 
-    signedHeaders = B.intercalate ";" $ map fst headersForSign
+computeSignature :: ByteString -> ByteString -> ByteString
+computeSignature !toSign !key = digestToBase16 $ hmacSHA256 toSign key
+
+-- | Takes a validated Post Policy JSON bytestring, the signing time,
+-- and ConnInfo and returns form-data for the POST upload containing
+-- just the signature and the encoded post-policy.
+signV4PostPolicy ::
+  ByteString ->
+  SignParams ->
+  Map.HashMap Text ByteString
+signV4PostPolicy !postPolicyJSON !sp =
+  let stringToSign = Base64.encode postPolicyJSON
+      signingKey = getSigningKey sp
+      signature = computeSignature stringToSign signingKey
+   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 n
+  | n == 0 = 0
+  | otherwise = 1 + base16Len (n `div` 16)
+
+signedStreamLength :: Int64 -> Int64
+signedStreamLength dataLen =
+  let chunkSzInt = fromIntegral chunkSizeConstant
+      (numChunks, lastChunkLen) = quotRem dataLen chunkSzInt
+      -- Structure of a chunk:
+      --   string(IntHexBase(chunk-size)) + ";chunk-signature=" + signature + \r\n + chunk-data + \r\n
+      encodedChunkLen csz = fromIntegral (base16Len csz) + 17 + 64 + 2 + csz + 2
+      fullChunkSize = encodedChunkLen chunkSzInt
+      lastChunkSize = bool 0 (encodedChunkLen lastChunkLen) $ lastChunkLen > 0
+      finalChunkSize = 1 + 17 + 64 + 2 + 2
+   in numChunks * fullChunkSize + lastChunkSize + finalChunkSize
+
+-- 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)
+signV4Stream !payloadLength !sp !req =
+  let ts = spTimeStamp sp
+
+      -- compute the updated list of headers to be added for signing purposes.
+      signedContentLength = signedStreamLength 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")
+        ]
+          ++ maybeToList ((mk amzSecurityToken,) . BA.convert <$> spSessionToken sp)
+      requestHeaders =
+        addContentEncoding $
+          foldr setHeader (NC.requestHeaders req) extraHeaders
+
+      -- 1. Compute Seed Signature
+      -- 1.1 Canonical Request
+      (canonicalReq, signedHeaderKeys) =
+        getCanonicalRequestAndSignedHeaders
+          (IsStreamingLength payloadLength)
+          sp
+          req
+          requestHeaders
+
+      scope = credentialScope sp
+      accessKey = spAccessKey sp
+      -- 1.2 String toSign
+      stringToSign = mkStringToSign ts scope canonicalReq
+      -- 1.3 Compute signature
+      -- 1.3.1 compute signing key
+      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 : requestHeaders
+      -- headersToAdd = authHeader : datePair : streamingHeaders
+
+      toHexStr n = B8.pack $ printf "%x" n
+      (numParts, lastPSize) = payloadLength `quotRem` fromIntegral chunkSizeConstant
+      -- Function to compute string to sign for each chunk.
+      chunkStrToSign prevSign currChunkHash =
+        B.intercalate
+          "\n"
+          [ "AWS4-HMAC-SHA256-PAYLOAD",
+            awsTimeFormatBS ts,
+            scope,
+            prevSign,
+            hashSHA256 "",
+            currChunkHash
+          ]
+      -- Read n byte from upstream and return a strict bytestring.
+      mustTakeN n = do
+        bs <- LB.toStrict <$> (C.takeCE n C..| C.sinkLazy)
+        when (B.length bs /= n) $
+          throwIO MErrVStreamingBodyUnexpectedEOF
+        return bs
+      signerConduit n lps prevSign =
+        -- First case encodes a full chunk of length
+        -- 'chunkSizeConstant'.
+        if
+            | n > 0 -> do
+                bs <- mustTakeN chunkSizeConstant
+                let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
+                    nextSign = computeSignature strToSign signingKey
+                    chunkBS =
+                      toHexStr chunkSizeConstant
+                        <> ";chunk-signature="
+                        <> nextSign
+                        <> "\r\n"
+                        <> bs
+                        <> "\r\n"
+                C.yield chunkBS
+                signerConduit (n - 1) lps nextSign
+
+            -- Second case encodes the last chunk which is smaller than
+            -- 'chunkSizeConstant'
+            | lps > 0 -> do
+                bs <- mustTakeN $ fromIntegral lps
+                let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
+                    nextSign = computeSignature strToSign signingKey
+                    chunkBS =
+                      toHexStr lps
+                        <> ";chunk-signature="
+                        <> nextSign
+                        <> "\r\n"
+                        <> bs
+                        <> "\r\n"
+                C.yield chunkBS
+                signerConduit 0 0 nextSign
+
+            -- Last case encodes the final signature chunk that has no
+            -- data.
+            | otherwise -> do
+                let strToSign = chunkStrToSign prevSign (hashSHA256 "")
+                    nextSign = computeSignature strToSign signingKey
+                    lastChunkBS = "0;chunk-signature=" <> nextSign <> "\r\n\r\n"
+                C.yield lastChunkBS
+   in \src ->
+        req
+          { NC.requestHeaders = finalReqHeaders,
+            NC.requestBody =
+              NC.requestBodySource signedContentLength $
+                src C..| signerConduit numParts lastPSize seedSignature
+          }
+
+-- "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

@@ -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.
@@ -16,87 +16,146 @@
 
 module Network.Minio.Utils where
 
-import qualified Control.Concurrent.Async.Lifted as A
+import qualified Conduit as C
-import qualified Control.Concurrent.QSem as Q
+import Control.Monad.IO.Unlift (MonadUnliftIO)
-import qualified Control.Exception.Lifted as ExL
-import qualified Control.Monad.Catch as MC
-import           Control.Monad.Trans.Control (liftBaseOp_, StM)
 import qualified Control.Monad.Trans.Resource as R
-
 import qualified Data.ByteString as B
-import qualified Data.Conduit as C
+import qualified Data.ByteString.Lazy as LB
+import Data.CaseInsensitive (mk, original)
 import qualified Data.Conduit.Binary as CB
-import           Data.Default (Default(..))
+import qualified Data.HashMap.Strict as H
 import qualified Data.Text as T
-import           Data.Text.Encoding.Error (lenientDecode)
 import Data.Text.Read (decimal)
 import Data.Time
-import qualified Network.HTTP.Client as NClient
+  ( defaultTimeLocale,
+    parseTimeM,
+    rfc822DateFormat,
+  )
+import Lib.Prelude
 import Network.HTTP.Conduit (Response)
 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.ByteString
+import Network.Minio.JsonParser (parseErrResponseJSON)
+import Network.Minio.XmlCommon (parseErrResponse)
 import qualified System.IO as IO
+import qualified UnliftIO as U
+import qualified UnliftIO.Async as A
 
-import           Lib.Prelude
+allocateReadFile ::
-
+  (MonadUnliftIO m, R.MonadResource m) =>
-import           Network.Minio.Errors
+  FilePath ->
-import           Network.Minio.XmlParser (parseErrResponse)
+  m (R.ReleaseKey, Handle)
-
-allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m, MonadCatch m)
-                 => FilePath -> m (R.ReleaseKey, Handle)
 allocateReadFile fp = do
   (rk, hdlE) <- R.allocate (openReadFile fp) cleanup
-  either (\(e :: IOException) -> throwM e) (return . (rk,)) hdlE
+  either (\(e :: U.IOException) -> throwIO e) (return . (rk,)) hdlE
   where
-    openReadFile f = ExL.try $ IO.openBinaryFile f IO.ReadMode
+    openReadFile f = U.try $ IO.openBinaryFile f IO.ReadMode
     cleanup = either (const $ return ()) IO.hClose
 
 -- | Queries the file size from the handle. Catches any file operation
 -- exceptions and returns Nothing instead.
-getFileSize :: (R.MonadResourceBase m, R.MonadResource m)
+getFileSize ::
-            => Handle -> m (Maybe Int64)
+  (MonadUnliftIO m) =>
+  Handle ->
+  m (Maybe Int64)
 getFileSize h = do
   resE <- liftIO $ try $ fromIntegral <$> IO.hFileSize h
   case resE of
-    Left (_ :: IOException) -> return Nothing
+    Left (_ :: U.IOException) -> return Nothing
     Right s -> return $ Just s
 
 -- | Queries if handle is seekable. Catches any file operation
 -- exceptions and return False instead.
-isHandleSeekable :: (R.MonadResource m, R.MonadResourceBase m)
+isHandleSeekable ::
-               => Handle -> m Bool
+  (R.MonadResource m) =>
+  Handle ->
+  m Bool
 isHandleSeekable h = do
   resE <- liftIO $ try $ IO.hIsSeekable h
   case resE of
-    Left (_ :: IOException) -> return False
+    Left (_ :: U.IOException) -> return False
     Right v -> return v
 
 -- | Helper function that opens a handle to the filepath and performs
 -- the given action on it. Exceptions of type MError are caught and
 -- returned - both during file handle allocation and when the action
 -- is run.
-withNewHandle :: (R.MonadResourceBase m, R.MonadResource m, MonadCatch m)
+withNewHandle ::
-              => FilePath -> (Handle -> m a) -> m (Either IOException a)
+  (MonadUnliftIO m, R.MonadResource m) =>
+  FilePath ->
+  (Handle -> m a) ->
+  m (Either U.IOException a)
 withNewHandle fp fileAction = do
   -- opening a handle can throw MError exception.
-  handleE <- MC.try $ allocateReadFile fp
+  handleE <- try $ allocateReadFile fp
   either (return . Left) doAction handleE
   where
     doAction (rkey, h) = do
       -- fileAction may also throw MError exception, so we catch and
       -- return it.
-      resE <- MC.try $ fileAction h
+      resE <- try $ fileAction h
       R.release rkey
       return resE
 
+mkHeaderFromPairs :: [(ByteString, ByteString)] -> [HT.Header]
+mkHeaderFromPairs = map (first mk)
 
 lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString
-lookupHeader hdr = headMay . map snd . filter (\(h, _) -> h == hdr)
+lookupHeader hdr = listToMaybe . map snd . filter (\(h, _) -> h == hdr)
 
 getETagHeader :: [HT.Header] -> Maybe Text
 getETagHeader hs = decodeUtf8Lenient <$> lookupHeader Hdr.hETag hs
 
+getMetadata :: [HT.Header] -> [(Text, Text)]
+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
+
+getNonUserMetadataMap :: [(Text, Text)] -> H.HashMap Text Text
+getNonUserMetadataMap =
+  H.fromList
+    . filter
+      ( isNothing
+          . userMetadataHeaderNameMaybe
+          . 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
+getUserMetadataMap =
+  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
@@ -105,78 +164,103 @@ getLastModifiedHeader hs = do
 getContentLength :: [HT.Header] -> Maybe Int64
 getContentLength hs = do
   nbs <- decodeUtf8Lenient <$> lookupHeader Hdr.hContentLength hs
-  fst <$> hush (decimal nbs)
+  fst <$> either (const Nothing) Just (decimal nbs)
-
 
 decodeUtf8Lenient :: ByteString -> Text
 decodeUtf8Lenient = decodeUtf8With lenientDecode
 
 isSuccessStatus :: HT.Status -> Bool
-isSuccessStatus sts = let s = HT.statusCode sts
+isSuccessStatus sts =
+  let s = HT.statusCode sts
    in (s >= 200 && s < 300)
 
-httpLbs :: (R.MonadThrow m, MonadIO m)
+httpLbs ::
-        => NC.Request -> NC.Manager
+  (MonadIO m) =>
-        -> m (NC.Response LByteString)
+  NC.Request ->
+  NC.Manager ->
+  m (NC.Response LByteString)
 httpLbs req mgr = do
-  respE <- liftIO $ tryHttpEx $ (NClient.httpLbs req mgr)
+  respE <- liftIO $ tryHttpEx $ NC.httpLbs req mgr
-  resp <- either throwM return respE
+  resp <- either throwIO return respE
   unless (isSuccessStatus $ NC.responseStatus resp) $
     case contentTypeMay resp of
       Just "application/xml" -> do
         sErr <- parseErrResponse $ NC.responseBody resp
-        throwM sErr
+        throwIO sErr
-
+      Just "application/json" -> do
-      _ -> throwM $ NC.StatusCodeException (NC.responseStatus resp) [] def
+        sErr <- parseErrResponseJSON $ NC.responseBody resp
+        throwIO sErr
+      _ ->
+        throwIO $
+          NC.HttpExceptionRequest req $
+            NC.StatusCodeException (void resp) (showBS resp)
 
   return resp
   where
-    tryHttpEx :: (IO (NC.Response LByteString))
+    tryHttpEx ::
-              -> IO (Either NC.HttpException (NC.Response LByteString))
+      IO (NC.Response LByteString) ->
+      IO (Either NC.HttpException (NC.Response LByteString))
     tryHttpEx = try
-    contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp
+    contentTypeMay resp =
+      lookupHeader Hdr.hContentType $
+        NC.responseHeaders resp
 
-http :: (R.MonadResourceBase m, R.MonadResource m)
+http ::
-     => NC.Request -> NC.Manager
+  (MonadUnliftIO m, R.MonadResource m) =>
-     -> m (Response (C.ResumableSource m ByteString))
+  NC.Request ->
+  NC.Manager ->
+  m (Response (C.ConduitT () ByteString m ()))
 http req mgr = do
   respE <- tryHttpEx $ NC.http req mgr
-  resp <- either throwM return respE
+  resp <- either throwIO return respE
   unless (isSuccessStatus $ NC.responseStatus resp) $
     case contentTypeMay resp of
       Just "application/xml" -> do
-        respBody <- NC.responseBody resp C.$$+- CB.sinkLbs
+        respBody <- C.connect (NC.responseBody resp) CB.sinkLbs
-        sErr <- parseErrResponse $ respBody
+        sErr <- parseErrResponse respBody
-        throwM sErr
+        throwIO sErr
-
+      _ -> do
-      _ -> throwM $ NC.StatusCodeException (NC.responseStatus resp) [] def
+        content <- LB.toStrict . NC.responseBody <$> NC.lbsResponse resp
+        throwIO $
+          NC.HttpExceptionRequest req $
+            NC.StatusCodeException (void resp) content
 
   return resp
   where
-    tryHttpEx :: (R.MonadResourceBase m) => (m a)
+    tryHttpEx ::
-              -> m (Either MinioErr a)
+      (MonadUnliftIO m) =>
-    tryHttpEx = ExL.try
+      m a ->
-    contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp
+      m (Either NC.HttpException a)
+    tryHttpEx = try
+    contentTypeMay resp =
+      lookupHeader Hdr.hContentType $
+        NC.responseHeaders resp
 
--- like mapConcurrently but with a limited number of concurrent
+-- Similar to mapConcurrently but limits the number of threads that
--- threads.
+-- can run using a quantity semaphore.
-limitedMapConcurrently :: forall t a (m :: * -> *) b.
+limitedMapConcurrently ::
-                          (MonadIO m, R.MonadBaseControl IO m,
+  (MonadUnliftIO m) =>
-                           StM m a ~ StM m b)
+  Int ->
-                       => Int -> (t -> m a) -> [t] -> m [b]
+  (t -> m a) ->
+  [t] ->
+  m [a]
+limitedMapConcurrently 0 _ _ = return []
 limitedMapConcurrently count act args = do
-  qSem <- liftIO $ Q.newQSem count
+  t' <- U.newTVarIO count
-  threads <- workOn qSem args
+  threads <- mapM (A.async . wThread t') args
   mapM A.wait threads
   where
-    workOn _ [] = return []
+    wThread t arg =
-    workOn qs (a:as) = liftBaseOp_
+      U.bracket_ (waitSem t) (signalSem t) $ act arg
-      (bracket_ (Q.waitQSem qs) (Q.signalQSem qs)) $
+    -- quantity semaphore implementation using TVar
-      do
+    waitSem t = U.atomically $ do
-        thread <- A.async $ act a
+      v <- U.readTVar t
-        others <- workOn qs as
+      if v > 0
-        return (thread : others)
+        then U.writeTVar t (v - 1)
-
+        else U.retrySTM
+    signalSem t = U.atomically $ do
+      v <- U.readTVar t
+      U.writeTVar t (v + 1)
 
 -- helper function to 'drop' empty optional parameter.
 mkQuery :: Text -> Maybe Text -> Maybe (Text, Text)
@@ -185,23 +269,17 @@ mkQuery k mv = (k,) <$> mv
 -- helper function to build query parameters that are optional.
 -- don't use it with mandatory query params with empty value.
 mkOptionalParams :: [(Text, Maybe Text)] -> HT.Query
-mkOptionalParams params = HT.toQuery $ (uncurry  mkQuery) <$> params
+mkOptionalParams params = HT.toQuery $ uncurry mkQuery <$> params
 
-chunkBSConduit :: (Monad m, Integral a)
+-- | Conduit that rechunks bytestrings into the given chunk
-               => [a] -> C.Conduit ByteString m ByteString
+-- lengths. Stops after given chunk lengths are yielded. Stops if
-chunkBSConduit s = loop 0 [] s
+-- there are no more chunks to yield or if a shorter chunk is
-  where
+-- received. Does not throw any errors.
-    loop _ _ [] = return ()
+chunkBSConduit :: (Monad m) => [Int] -> C.ConduitM ByteString ByteString m ()
-    loop n readChunks (size:sizes) = do
+chunkBSConduit [] = return ()
-      bsMay <- C.await
+chunkBSConduit (s : ss) = do
-      case bsMay of
+  bs <- fmap LB.toStrict $ C.takeCE s C..| C.sinkLazy
-        Nothing -> if n > 0
+  if
-                   then C.yield $ B.concat readChunks
+      | B.length bs == s -> C.yield bs >> chunkBSConduit ss
-                   else return ()
+      | B.length bs > 0 -> C.yield bs
-        Just bs -> if n + fromIntegral (B.length bs) >= size
+      | otherwise -> return ()
-                   then do let (a, b) = B.splitAt (fromIntegral $ size - n) bs
-                               chunkBS = B.concat $ readChunks ++ [a]
-                           C.yield chunkBS
-                           loop (fromIntegral $ B.length b) [b] sizes
-                   else loop (n + fromIntegral (B.length bs))
-                        (readChunks ++ [bs]) (size:sizes)

src/Network/Minio/XmlCommon.hs

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

@@ -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.
@@ -15,29 +15,31 @@
 --
 
 module Network.Minio.XmlGenerator
-  ( mkCreateBucketConfig
+  ( mkCreateBucketConfig,
-  , mkCompleteMultipartUploadRequest
+    mkCompleteMultipartUploadRequest,
-  ) where
+    mkPutNotificationRequest,
-
+    mkSelectRequest,
+  )
+where
 
 import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Map as M
 import qualified Data.Text as T
+import Network.Minio.Data
+import Network.Minio.XmlCommon
 import Text.XML
 
-import           Lib.Prelude
-
-import           Network.Minio.Data
-
-
 -- | Create a bucketConfig request body XML
-mkCreateBucketConfig :: Region -> ByteString
+mkCreateBucketConfig :: Text -> Region -> ByteString
-mkCreateBucketConfig location = LBS.toStrict $ renderLBS def bucketConfig
+mkCreateBucketConfig ns location = LBS.toStrict $ renderLBS def bucketConfig
   where
-      s3Element n = Element (s3Name n) M.empty
+    s3Element n = Element (s3Name ns n) mempty
-      root = s3Element "CreateBucketConfiguration"
+    root =
-        [ NodeElement $ s3Element "LocationConstraint"
+      s3Element
-          [ NodeContent location]
+        "CreateBucketConfiguration"
+        [ NodeElement $
+            s3Element
+              "LocationConstraint"
+              [NodeContent location]
         ]
     bucketConfig = Document (Prologue [] Nothing []) root []
 
@@ -46,12 +48,184 @@ mkCompleteMultipartUploadRequest :: [PartTuple] -> ByteString
 mkCompleteMultipartUploadRequest partInfo =
   LBS.toStrict $ renderLBS def cmur
   where
-    root = Element "CompleteMultipartUpload" M.empty $
+    root =
+      Element "CompleteMultipartUpload" mempty $
         map (NodeElement . mkPart) partInfo
-    mkPart (n, etag) = Element "Part" M.empty
+    mkPart (n, etag) =
-                               [ NodeElement $ Element "PartNumber" M.empty
+      Element
-                                 [NodeContent $ T.pack $ show n]
+        "Part"
-                               , NodeElement $ Element "ETag" M.empty
+        mempty
+        [ NodeElement $
+            Element
+              "PartNumber"
+              mempty
+              [NodeContent $ T.pack $ show n],
+          NodeElement $
+            Element
+              "ETag"
+              mempty
               [NodeContent etag]
         ]
     cmur = Document (Prologue [] Nothing []) root []
+
+-- Simplified XML representation without element attributes.
+data XNode
+  = XNode Text [XNode]
+  | XLeaf Text Text
+  deriving stock (Eq, Show)
+
+toXML :: Text -> XNode -> ByteString
+toXML ns node =
+  LBS.toStrict $
+    renderLBS def $
+      Document (Prologue [] Nothing []) (xmlNode node) []
+  where
+    xmlNode :: XNode -> Element
+    xmlNode (XNode name nodes) =
+      Element (s3Name ns name) mempty $
+        map (NodeElement . xmlNode) nodes
+    xmlNode (XLeaf name content) =
+      Element
+        (s3Name ns name)
+        mempty
+        [NodeContent content]
+
+class ToXNode a where
+  toXNode :: a -> XNode
+
+instance ToXNode Event where
+  toXNode = XLeaf "Event" . toText
+
+instance ToXNode Notification where
+  toXNode (Notification qc tc lc) =
+    XNode "NotificationConfiguration" $
+      map (toXNodesWithArnName "QueueConfiguration" "Queue") qc
+        ++ map (toXNodesWithArnName "TopicConfiguration" "Topic") tc
+        ++ map (toXNodesWithArnName "CloudFunctionConfiguration" "CloudFunction") lc
+
+toXNodesWithArnName :: Text -> Text -> NotificationConfig -> XNode
+toXNodesWithArnName eltName arnName (NotificationConfig itemId arn events fRule) =
+  XNode eltName $
+    [XLeaf "Id" itemId, XLeaf arnName arn]
+      ++ map toXNode events
+      ++ [toXNode fRule]
+
+instance ToXNode Filter where
+  toXNode (Filter (FilterKey (FilterRules rules))) =
+    XNode "Filter" [XNode "S3Key" (map getFRXNode rules)]
+
+getFRXNode :: FilterRule -> XNode
+getFRXNode (FilterRule n v) =
+  XNode
+    "FilterRule"
+    [ XLeaf "Name" n,
+      XLeaf "Value" v
+    ]
+
+mkPutNotificationRequest :: Text -> Notification -> ByteString
+mkPutNotificationRequest ns = toXML ns . toXNode
+
+mkSelectRequest :: SelectRequest -> ByteString
+mkSelectRequest r = LBS.toStrict $ renderLBS def sr
+  where
+    sr = Document (Prologue [] Nothing []) root []
+    root =
+      Element "SelectRequest" mempty $
+        [ NodeElement
+            ( Element
+                "Expression"
+                mempty
+                [NodeContent $ srExpression r]
+            ),
+          NodeElement
+            ( Element
+                "ExpressionType"
+                mempty
+                [NodeContent $ show $ srExpressionType r]
+            ),
+          NodeElement
+            ( Element "InputSerialization" mempty $
+                inputSerializationNodes $
+                  srInputSerialization r
+            ),
+          NodeElement
+            ( Element "OutputSerialization" mempty $
+                outputSerializationNodes $
+                  srOutputSerialization r
+            )
+        ]
+          ++ maybe [] reqProgElem (srRequestProgressEnabled r)
+    reqProgElem enabled =
+      [ NodeElement
+          ( Element
+              "RequestProgress"
+              mempty
+              [ NodeElement
+                  ( Element
+                      "Enabled"
+                      mempty
+                      [ NodeContent
+                          (if enabled then "TRUE" else "FALSE")
+                      ]
+                  )
+              ]
+          )
+      ]
+    inputSerializationNodes is =
+      comprTypeNode (isCompressionType is)
+        ++ [NodeElement $ formatNode (isFormatInfo is)]
+    comprTypeNode (Just c) =
+      [ NodeElement $
+          Element
+            "CompressionType"
+            mempty
+            [ NodeContent $ case c of
+                CompressionTypeNone -> "NONE"
+                CompressionTypeGzip -> "GZIP"
+                CompressionTypeBzip2 -> "BZIP2"
+            ]
+      ]
+    comprTypeNode Nothing = []
+    kvElement (k, v) = Element (Name k Nothing Nothing) mempty [NodeContent v]
+    formatNode (InputFormatCSV c) =
+      Element
+        "CSV"
+        mempty
+        (map (NodeElement . kvElement) (csvPropsList c))
+    formatNode (InputFormatJSON p) =
+      Element
+        "JSON"
+        mempty
+        [ NodeElement
+            ( Element
+                "Type"
+                mempty
+                [ NodeContent $ case jsonipType p of
+                    JSONTypeDocument -> "DOCUMENT"
+                    JSONTypeLines -> "LINES"
+                ]
+            )
+        ]
+    formatNode InputFormatParquet = Element "Parquet" mempty []
+    outputSerializationNodes (OutputSerializationJSON j) =
+      [ NodeElement
+          ( Element "JSON" mempty $
+              rdElem $
+                jsonopRecordDelimiter j
+          )
+      ]
+    outputSerializationNodes (OutputSerializationCSV c) =
+      [ NodeElement $
+          Element
+            "CSV"
+            mempty
+            (map (NodeElement . kvElement) (csvPropsList c))
+      ]
+    rdElem Nothing = []
+    rdElem (Just t) =
+      [ NodeElement $
+          Element
+            "RecordDelimiter"
+            mempty
+            [NodeContent t]
+      ]

src/Network/Minio/XmlParser.hs

@@ -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.
@@ -15,177 +15,216 @@
 --
 
 module Network.Minio.XmlParser
-  ( parseListBuckets
+  ( parseListBuckets,
-  , parseLocation
+    parseLocation,
-  , parseNewMultipartUpload
+    parseNewMultipartUpload,
-  , parseCompleteMultipartUploadResponse
+    parseCompleteMultipartUploadResponse,
-  , parseCopyObjectResponse
+    parseCopyObjectResponse,
-  , parseListObjectsResponse
+    parseListObjectsResponse,
-  , parseListUploadsResponse
+    parseListObjectsV1Response,
-  , parseListPartsResponse
+    parseListUploadsResponse,
-  , parseErrResponse
+    parseListPartsResponse,
-  ) where
+    parseErrResponse,
+    parseNotification,
+    parseSelectProgress,
+  )
+where
 
-import           Control.Monad.Trans.Resource
+import qualified Data.ByteString.Lazy as LB
-import           Data.List (zip3, zip4)
+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           Text.XML
+import Network.Minio.Data
+import Network.Minio.XmlCommon
 import Text.XML.Cursor hiding (bool)
 
-import           Lib.Prelude
-
-import           Network.Minio.Data
-import           Network.Minio.Errors
-
-
--- | Represent the time format string returned by S3 API calls.
-s3TimeFormat :: [Char]
-s3TimeFormat = iso8601DateFormat $ Just "%T%QZ"
-
--- | Helper functions.
-uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
-uncurry4 f (a, b, c, d) = f a b c d
-
--- | Parse time strings from XML
-parseS3XMLTime :: (MonadThrow m) => Text -> m UTCTime
-parseS3XMLTime = either (throwM . MErrXmlParse) return
-               . parseTimeM True defaultTimeLocale s3TimeFormat
-               . T.unpack
-
-parseDecimal :: (MonadThrow m, Integral a) => Text -> m a
-parseDecimal numStr = either (throwM . MErrXmlParse . show) return $ fst <$> decimal numStr
-
-parseDecimals :: (MonadThrow m, Integral a) => [Text] -> m [a]
-parseDecimals numStr = forM numStr parseDecimal
-
-s3Elem :: Text -> Axis
-s3Elem = element . s3Name
-
-parseRoot :: (MonadThrow m) => LByteString -> m Cursor
-parseRoot = either (throwM . MErrXmlParse . show) (return . fromDocument)
-          . parseLBS def
-
 -- | Parse the response XML of a list buckets call.
-parseListBuckets :: (MonadThrow m) => LByteString -> m [BucketInfo]
+parseListBuckets :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m [BucketInfo]
 parseListBuckets xmldata = do
   r <- parseRoot xmldata
-  let
+  ns <- asks getSvcNamespace
-    names = r $// s3Elem "Bucket" &// s3Elem "Name" &/ content
+  let s3Elem' = s3Elem ns
-    timeStrings = r $// s3Elem "Bucket" &// s3Elem "CreationDate" &/ content
+      names = r $// s3Elem' "Bucket" &// s3Elem' "Name" &/ content
+      timeStrings = r $// s3Elem' "Bucket" &// s3Elem' "CreationDate" &/ content
 
   times <- mapM parseS3XMLTime timeStrings
-  return $ map (\(n, t) -> BucketInfo n t) $ zip names times
+  return $ zipWith BucketInfo names times
 
 -- | Parse the response XML of a location request.
-parseLocation :: (MonadThrow m) => LByteString -> m Region
+parseLocation :: (MonadIO m) => LByteString -> m Region
 parseLocation xmldata = do
   r <- parseRoot xmldata
   let region = T.concat $ r $/ content
   return $ bool "us-east-1" region $ region /= ""
 
 -- | Parse the response XML of an newMultipartUpload call.
-parseNewMultipartUpload :: (MonadThrow m)
+parseNewMultipartUpload :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m UploadId
-                        => LByteString -> m UploadId
 parseNewMultipartUpload xmldata = do
   r <- parseRoot xmldata
-  return $ T.concat $ r $// s3Elem "UploadId" &/ content
+  ns <- asks getSvcNamespace
+  let s3Elem' = s3Elem ns
+  return $ T.concat $ r $// s3Elem' "UploadId" &/ content
 
 -- | Parse the response XML of completeMultipartUpload call.
-parseCompleteMultipartUploadResponse :: (MonadThrow m)
+parseCompleteMultipartUploadResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ETag
-                                     => LByteString -> m ETag
 parseCompleteMultipartUploadResponse xmldata = do
   r <- parseRoot xmldata
-  return $ T.concat $ r $// s3Elem "ETag" &/ content
+  ns <- asks getSvcNamespace
+  let s3Elem' = s3Elem ns
+  return $ T.concat $ r $// s3Elem' "ETag" &/ content
 
 -- | Parse the response XML of copyObject and copyObjectPart
-parseCopyObjectResponse :: (MonadThrow m) => LByteString -> m (ETag, UTCTime)
+parseCopyObjectResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m (ETag, UTCTime)
 parseCopyObjectResponse xmldata = do
   r <- parseRoot xmldata
-  let
+  ns <- asks getSvcNamespace
-    mtimeStr = T.concat $ r $// s3Elem "LastModified" &/ content
+  let s3Elem' = s3Elem ns
+      mtimeStr = T.concat $ r $// s3Elem' "LastModified" &/ content
 
   mtime <- parseS3XMLTime mtimeStr
-  return $ (T.concat $ r $// s3Elem "ETag" &/ content, mtime)
+  return (T.concat $ r $// s3Elem' "ETag" &/ content, mtime)
 
--- | Parse the response XML of a list objects call.
+-- | Parse the response XML of a list objects v1 call.
-parseListObjectsResponse :: (MonadThrow m)
+parseListObjectsV1Response ::
-                         => LByteString -> m ListObjectsResult
+  (MonadReader env m, HasSvcNamespace env, MonadIO m) =>
-parseListObjectsResponse xmldata = do
+  LByteString ->
+  m ListObjectsV1Result
+parseListObjectsV1Response xmldata = do
   r <- parseRoot xmldata
-  let
+  ns <- asks getSvcNamespace
-    hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content)
+  let s3Elem' = s3Elem ns
-
+      hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
-    nextToken = headMay $ r $/ s3Elem "NextContinuationToken" &/ content
+      nextMarker = listToMaybe $ r $/ s3Elem' "NextMarker" &/ content
-
+      prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content
-    prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content
+      keys = r $/ s3Elem' "Contents" &/ s3Elem' "Key" &/ content
-
+      modTimeStr = r $/ s3Elem' "Contents" &/ s3Elem' "LastModified" &/ content
-    keys = r $/ s3Elem "Contents" &/ s3Elem "Key" &/ content
+      etagsList = r $/ s3Elem' "Contents" &/ s3Elem' "ETag" &/ content
-    modTimeStr = r $/ s3Elem "Contents" &/ s3Elem "LastModified" &/ content
-    etagsList = r $/ s3Elem "Contents" &/ s3Elem "ETag" &/ content
       -- if response xml contains empty etag response fill them with as
       -- many empty Text for the zip4 below to work as intended.
       etags = etagsList ++ repeat ""
-    sizeStr = r $/ s3Elem "Contents" &/ s3Elem "Size" &/ content
+      sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content
 
   modTimes <- mapM parseS3XMLTime modTimeStr
   sizes <- parseDecimals sizeStr
 
-  let
+  let objects =
-    objects = map (uncurry4 ObjectInfo) $ zip4 keys modTimes etags sizes
+        map (uncurry6 ObjectInfo) $
+          zip6 keys modTimes etags sizes (repeat H.empty) (repeat H.empty)
+
+  return $ ListObjectsV1Result hasMore nextMarker objects prefixes
+
+-- | Parse the response XML of a list objects call.
+parseListObjectsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListObjectsResult
+parseListObjectsResponse xmldata = do
+  r <- parseRoot xmldata
+  ns <- asks getSvcNamespace
+  let s3Elem' = s3Elem ns
+      hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
+      nextToken = listToMaybe $ r $/ s3Elem' "NextContinuationToken" &/ content
+      prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content
+      keys = r $/ s3Elem' "Contents" &/ s3Elem' "Key" &/ content
+      modTimeStr = r $/ s3Elem' "Contents" &/ s3Elem' "LastModified" &/ content
+      etagsList = r $/ s3Elem' "Contents" &/ s3Elem' "ETag" &/ content
+      -- if response xml contains empty etag response fill them with as
+      -- many empty Text for the zip4 below to work as intended.
+      etags = etagsList ++ repeat ""
+      sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content
+
+  modTimes <- mapM parseS3XMLTime modTimeStr
+  sizes <- parseDecimals sizeStr
+
+  let objects =
+        map (uncurry6 ObjectInfo) $
+          zip6 keys modTimes etags sizes (repeat H.empty) (repeat H.empty)
 
   return $ ListObjectsResult hasMore nextToken objects prefixes
 
 -- | Parse the response XML of a list incomplete multipart upload call.
-parseListUploadsResponse :: (MonadThrow m)
+parseListUploadsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListUploadsResult
-                         => LByteString -> m ListUploadsResult
 parseListUploadsResponse xmldata = do
   r <- parseRoot xmldata
-  let
+  ns <- asks getSvcNamespace
-    hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content)
+  let s3Elem' = s3Elem ns
-    prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content
+      hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
-    nextKey = headMay $ r $/ s3Elem "NextKeyMarker" &/ content
+      prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content
-    nextUpload = headMay $ r $/ s3Elem "NextUploadIdMarker" &/ content
+      nextKey = listToMaybe $ r $/ s3Elem' "NextKeyMarker" &/ content
-    uploadKeys = r $/ s3Elem "Upload" &/ s3Elem "Key" &/ content
+      nextUpload = listToMaybe $ r $/ s3Elem' "NextUploadIdMarker" &/ content
-    uploadIds = r $/ s3Elem "Upload" &/ s3Elem "UploadId" &/ content
+      uploadKeys = r $/ s3Elem' "Upload" &/ s3Elem' "Key" &/ content
-    uploadInitTimeStr = r $/ s3Elem "Upload" &/ s3Elem "Initiated" &/ content
+      uploadIds = r $/ s3Elem' "Upload" &/ s3Elem' "UploadId" &/ content
+      uploadInitTimeStr = r $/ s3Elem' "Upload" &/ s3Elem' "Initiated" &/ content
 
   uploadInitTimes <- mapM parseS3XMLTime uploadInitTimeStr
 
-  let
+  let uploads = zip3 uploadKeys uploadIds uploadInitTimes
-    uploads = zip3 uploadKeys uploadIds uploadInitTimes
 
   return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes
 
-parseListPartsResponse :: (MonadThrow m)
+parseListPartsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListPartsResult
-                       => LByteString -> m ListPartsResult
 parseListPartsResponse xmldata = do
   r <- parseRoot xmldata
-  let
+  ns <- asks getSvcNamespace
-    hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content)
+  let s3Elem' = s3Elem ns
-    nextPartNumStr = headMay $ r $/ s3Elem "NextPartNumberMarker" &/ content
+      hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
-    partNumberStr = r $/ s3Elem "Part" &/ s3Elem "PartNumber" &/ content
+      nextPartNumStr = listToMaybe $ r $/ s3Elem' "NextPartNumberMarker" &/ content
-    partModTimeStr = r $/ s3Elem "Part" &/ s3Elem "LastModified" &/ content
+      partNumberStr = r $/ s3Elem' "Part" &/ s3Elem' "PartNumber" &/ content
-    partETags = r $/ s3Elem "Part" &/ s3Elem "ETag" &/ content
+      partModTimeStr = r $/ s3Elem' "Part" &/ s3Elem' "LastModified" &/ content
-    partSizeStr = r $/ s3Elem "Part" &/ s3Elem "Size" &/ content
+      partETags = r $/ s3Elem' "Part" &/ s3Elem' "ETag" &/ content
+      partSizeStr = r $/ s3Elem' "Part" &/ s3Elem' "Size" &/ content
 
   partModTimes <- mapM parseS3XMLTime partModTimeStr
   partSizes <- parseDecimals partSizeStr
   partNumbers <- parseDecimals partNumberStr
   nextPartNum <- parseDecimals $ maybeToList nextPartNumStr
 
-  let
+  let partInfos =
-    partInfos = map (uncurry4 ObjectPartInfo) $
+        map (uncurry4 ObjectPartInfo) $
           zip4 partNumbers partETags partSizes partModTimes
 
   return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos
 
-
+parseNotification :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m Notification
-parseErrResponse :: (MonadThrow m)
+parseNotification xmldata = do
-                 => LByteString -> m ServiceErr
-parseErrResponse xmldata = do
   r <- parseRoot xmldata
-  let code = T.concat $ r $/ element "Code" &/ content
+  ns <- asks getSvcNamespace
-      message = T.concat $ r $/ element "Message" &/ content
+  let s3Elem' = s3Elem ns
-  return $ toServiceErr code message
+      qcfg = map node $ r $/ s3Elem' "QueueConfiguration"
+      tcfg = map node $ r $/ s3Elem' "TopicConfiguration"
+      lcfg = map node $ r $/ s3Elem' "CloudFunctionConfiguration"
+  Notification
+    <$> mapM (parseNode ns "Queue") qcfg
+    <*> mapM (parseNode ns "Topic") tcfg
+    <*> mapM (parseNode ns "CloudFunction") lcfg
+  where
+    getFilterRule ns c =
+      let name = T.concat $ c $/ s3Elem ns "Name" &/ content
+          value = T.concat $ c $/ s3Elem ns "Value" &/ content
+       in FilterRule name value
+    parseNode ns arnName nodeData = do
+      let c = fromNode nodeData
+          itemId = T.concat $ c $/ s3Elem ns "Id" &/ content
+          arn = T.concat $ c $/ s3Elem ns arnName &/ content
+          events = mapMaybe textToEvent (c $/ s3Elem ns "Event" &/ content)
+          rules =
+            c
+              $/ s3Elem ns "Filter"
+              &/ s3Elem ns "S3Key"
+              &/ s3Elem ns "FilterRule"
+              &| getFilterRule ns
+      return $
+        NotificationConfig
+          itemId
+          arn
+          events
+          (Filter $ FilterKey $ FilterRules rules)
+
+parseSelectProgress :: (MonadIO m) => ByteString -> m Progress
+parseSelectProgress xmldata = do
+  r <- parseRoot $ LB.fromStrict xmldata
+  let bScanned = T.concat $ r $/ element "BytesScanned" &/ content
+      bProcessed = T.concat $ r $/ element "BytesProcessed" &/ content
+      bReturned = T.concat $ r $/ element "BytesReturned" &/ content
+  Progress
+    <$> parseDecimal bScanned
+    <*> parseDecimal bProcessed
+    <*> parseDecimal bReturned

stack-ghc-8.0.1.yaml

@@ -1,66 +0,0 @@
-# This file was automatically generated by 'stack init'
-#
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# http://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-# resolver: ghcjs-0.1.0_ghc-7.10.2
-# resolver:
-#  name: custom-snapshot
-#  location: "./custom-snapshot.yaml"
-resolver: lts-7.16
-
-# User packages to be built.
-# Various formats can be used as shown in the example below.
-#
-# packages:
-# - some-directory
-# - https://example.com/foo/bar/baz-0.0.2.tar.gz
-# - location:
-#    git: https://github.com/commercialhaskell/stack.git
-#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-#   extra-dep: true
-#  subdirs:
-#  - auto-update
-#  - wai
-#
-# A package marked 'extra-dep: true' will only be built if demanded by a
-# non-dependency (i.e. a user package), and its test suites and benchmarks
-# will not be run. This is useful for tweaking upstream packages.
-packages:
-- '.'
-# Dependency packages to be pulled from upstream that are not in the resolver
-# (e.g., acme-missiles-0.3)
-extra-deps: []
-
-# Override default flag values for local packages and extra-deps
-flags: {}
-
-# Extra package databases containing global packages
-extra-package-dbs: []
-
-# Control whether we use the GHC we find on the path
-# system-ghc: true
-#
-# Require a specific version of stack, using version ranges
-# require-stack-version: -any # Default
-# require-stack-version: ">=1.1"
-#
-# Override the architecture used by stack, especially useful on Windows
-# arch: i386
-# arch: x86_64
-#
-# Extra directories used by stack for building
-# extra-include-dirs: [/path/to/dir]
-# extra-lib-dirs: [/path/to/dir]
-#
-# Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor

stack.yaml

@@ -15,7 +15,7 @@
 # resolver:
 #  name: custom-snapshot
 #  location: "./custom-snapshot.yaml"
-resolver: lts-6.27
+resolver: lts-22.19
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -36,17 +36,17 @@ resolver: lts-6.27
 # non-dependency (i.e. a user package), and its test suites and benchmarks
 # will not be run. This is useful for tweaking upstream packages.
 packages:
-- '.'
+  - "."
 # Dependency packages to be pulled from upstream that are not in the resolver
 # (e.g., acme-missiles-0.3)
-extra-deps: []
+extra-deps:
+  - crypton-connection-0.3.2
 
 # Override default flag values for local packages and extra-deps
 flags: {}
 
 # Extra package databases containing global packages
 extra-package-dbs: []
-
 # Control whether we use the GHC we find on the path
 # system-ghc: true
 #

stack.yaml.lock

@@ -0,0 +1,19 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    hackage: crypton-connection-0.3.2@sha256:c7937edc25ab022bcf167703f2ec5ab73b62908e545bb587d2aa42b33cd6f6cc,1581
+    pantry-tree:
+      sha256: f986ad29b008cbe5732606e9cde1897191c486a2f1f169a4cb75fd915bce397c
+      size: 394
+  original:
+    hackage: crypton-connection-0.3.2
+snapshots:
+- completed:
+    sha256: e5cac927cf7ccbd52aa41476baa68b88c564ee6ddc3bc573dbf4210069287fe7
+    size: 713340
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/19.yaml
+  original: lts-22.19

test/Network/Minio/API/Test.hs

@@ -0,0 +1,116 @@
+--
+-- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc.
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- You may obtain a copy of the License at
+--
+--     http://www.apache.org/licenses/LICENSE-2.0
+--
+-- Unless required by applicable law or agreed to in writing, software
+-- distributed under the License is distributed on an "AS IS" BASIS,
+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+-- See the License for the specific language governing permissions and
+-- limitations under the License.
+--
+
+module Network.Minio.API.Test
+  ( bucketNameValidityTests,
+    objectNameValidityTests,
+    parseServerInfoJSONTest,
+    parseHealStatusTest,
+    parseHealStartRespTest,
+  )
+where
+
+import Data.Aeson (eitherDecode)
+import Network.Minio.API
+import Network.Minio.AdminAPI
+import Test.Tasty
+import Test.Tasty.HUnit
+
+assertBool' :: Bool -> Assertion
+assertBool' = assertBool "Test failed!"
+
+bucketNameValidityTests :: TestTree
+bucketNameValidityTests =
+  testGroup
+    "Bucket Name Validity Tests"
+    [ testCase "Too short 1" $ assertBool' $ not $ isValidBucketName "",
+      testCase "Too short 2" $ assertBool' $ not $ isValidBucketName "ab",
+      testCase "Too long 1" $ assertBool' $ not $ isValidBucketName "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
+      testCase "Has upper case" $ assertBool' $ not $ isValidBucketName "ABCD",
+      testCase "Has punctuation" $ assertBool' $ not $ isValidBucketName "abc,2",
+      testCase "Has hyphen at end" $ assertBool' $ not $ isValidBucketName "abc-",
+      testCase "Has consecutive dot" $ assertBool' $ not $ isValidBucketName "abck..eedg",
+      testCase "Looks like IP" $ assertBool' $ not $ isValidBucketName "10.0.0.1",
+      testCase "Valid bucket name 1" $ assertBool' $ isValidBucketName "abcd.pqeq.rea",
+      testCase "Valid bucket name 2" $ assertBool' $ isValidBucketName "abcdedgh1d",
+      testCase "Valid bucket name 3" $ assertBool' $ isValidBucketName "abc-de-dg-h1d"
+    ]
+
+objectNameValidityTests :: TestTree
+objectNameValidityTests =
+  testGroup
+    "Object Name Validity Tests"
+    [ testCase "Empty name" $ assertBool' $ not $ isValidObjectName "",
+      testCase "Has unicode characters" $ assertBool' $ isValidObjectName "日本国"
+    ]
+
+parseServerInfoJSONTest :: TestTree
+parseServerInfoJSONTest =
+  testGroup "Parse MinIO Admin API ServerInfo JSON test" $
+    map
+      ( \(tName, tDesc, tfn, tVal) ->
+          testCase tName $
+            assertBool tDesc $
+              tfn (eitherDecode tVal :: Either [Char] [ServerInfo])
+      )
+      testCases
+  where
+    testCases =
+      [ ("FSBackend", "Verify server info json parsing for FS backend", isRight, fsJSON),
+        ("Erasure Backend", "Verify server info json parsing for Erasure backend", isRight, erasureJSON),
+        ("Unknown Backend", "Verify server info json parsing for invalid backend", isLeft, invalidJSON)
+      ]
+    fsJSON = "[{\"error\":\"\",\"addr\":\"192.168.1.218:9000\",\"data\":{\"storage\":{\"Used\":20530,\"Backend\":{\"Type\":1,\"OnlineDisks\":0,\"OfflineDisks\":0,\"StandardSCData\":0,\"StandardSCParity\":0,\"RRSCData\":0,\"RRSCParity\":0,\"Sets\":null}},\"network\":{\"transferred\":808,\"received\":1160},\"http\":{\"totalHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalGETs\":{\"count\":1,\"avgDuration\":\"0s\"},\"successGETs\":{\"count\":1,\"avgDuration\":\"0s\"},\"totalPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"}},\"server\":{\"uptime\":5992503019270,\"version\":\"DEVELOPMENT.GOGET\",\"commitID\":\"DEVELOPMENT.GOGET\",\"region\":\"\",\"sqsARN\":[]}}}]"
+    erasureJSON = "[{\"error\":\"\",\"addr\":\"192.168.1.218:9000\",\"data\":{\"storage\":{\"Used\":83084,\"Backend\":{\"Type\":2,\"OnlineDisks\":4,\"OfflineDisks\":0,\"StandardSCData\":2,\"StandardSCParity\":2,\"RRSCData\":2,\"RRSCParity\":2,\"Sets\":[[{\"uuid\":\"16ec6f2c-9197-4787-904a-36bb2c2683f8\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"4052e086-ef99-4aa5-ae2b-8e27559432f6\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"d0639950-ddd3-45b0-93ca-fd86f5d79f72\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"30ec68c0-37e1-4592-82c1-26b143c0ac10\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]]}},\"network\":{\"transferred\":404,\"received\":0},\"http\":{\"totalHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalGETs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successGETs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"}},\"server\":{\"uptime\":2738903073,\"version\":\"DEVELOPMENT.GOGET\",\"commitID\":\"DEVELOPMENT.GOGET\",\"region\":\"\",\"sqsARN\":[]}}}]"
+    invalidJSON = "[{\"error\":\"\",\"addr\":\"192.168.1.218:9000\",\"data\":{\"storage\":{\"Used\":83084,\"Backend\":{\"Type\":42,\"OnlineDisks\":4,\"OfflineDisks\":0,\"StandardSCData\":2,\"StandardSCParity\":2,\"RRSCData\":2,\"RRSCParity\":2,\"Sets\":[[{\"uuid\":\"16ec6f2c-9197-4787-904a-36bb2c2683f8\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"4052e086-ef99-4aa5-ae2b-8e27559432f6\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"d0639950-ddd3-45b0-93ca-fd86f5d79f72\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"30ec68c0-37e1-4592-82c1-26b143c0ac10\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]]}},\"network\":{\"transferred\":404,\"received\":0},\"http\":{\"totalHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalGETs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successGETs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"}},\"server\":{\"uptime\":2738903073,\"version\":\"DEVELOPMENT.GOGET\",\"commitID\":\"DEVELOPMENT.GOGET\",\"region\":\"\",\"sqsARN\":[]}}}]"
+
+parseHealStatusTest :: TestTree
+parseHealStatusTest =
+  testGroup "Parse MinIO Admin API HealStatus JSON test" $
+    map
+      ( \(tName, tDesc, tfn, tVal) ->
+          testCase tName $
+            assertBool tDesc $
+              tfn (eitherDecode tVal :: Either [Char] HealStatus)
+      )
+      testCases
+  where
+    testCases =
+      [ ("Good", "Verify heal result item for erasure backend", isRight, erasureJSON'),
+        ("Corrupted", "Verify heal result item for erasure backend", isLeft, invalidJSON'),
+        ("Incorrect Value", "Verify heal result item for erasure backend", isLeft, invalidItemType)
+      ]
+    erasureJSON' = "{\"Summary\":\"finished\",\"StartTime\":\"2018-06-05T08:09:47.644465513Z\",\"NumDisks\":4,\"Settings\":{\"recursive\":false,\"dryRun\":false},\"Items\":[{\"resultId\":1,\"type\":\"metadata\",\"bucket\":\"\",\"object\":\"\",\"detail\":\"disk-format\",\"diskCount\":4,\"setCount\":1,\"before\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"after\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"objectSize\":0}]}"
+    invalidJSON' = "{\"Summary\":\"finished\",\"StartTime\":\"2018-06-05T08:09:47.644465513Z\",\"NumDisks\":4,\"Settings\":{\"recursive\":false,\"dryRun\":false},\"Items\":[{\"resultId\":1,\"type\":\"metadata\",\"bucket\":\"\",\"object\":\"\",\"detail\":\"disk-format\",\"diskCount\":4,\"setCount\":1,\"before\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"after\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"objectSize\":0}]"
+    invalidItemType = "{\"Summary\":\"finished\",\"StartTime\":\"2018-06-05T08:09:47.644465513Z\",\"NumDisks\":4,\"Settings\":{\"recursive\":false,\"dryRun\":false},\"Items\":[{\"resultId\":1,\"type\":\"hello\",\"bucket\":\"\",\"object\":\"\",\"detail\":\"disk-format\",\"diskCount\":4,\"setCount\":1,\"before\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"after\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"objectSize\":0}]}"
+
+parseHealStartRespTest :: TestTree
+parseHealStartRespTest =
+  testGroup "Parse MinIO Admin API HealStartResp JSON test" $
+    map
+      ( \(tName, tDesc, tfn, tVal) ->
+          testCase tName $
+            assertBool tDesc $
+              tfn (eitherDecode tVal :: Either [Char] HealStartResp)
+      )
+      testCases
+  where
+    testCases =
+      [ ("Good", "Verify heal start response for erasure backend", isRight, hsrJSON),
+        ("Missing Token", "Verify heal start response for erasure backend", isLeft, missingTokenJSON)
+      ]
+    hsrJSON = "{\"clientToken\":\"3a3aca49-77dd-4b78-bba7-0978f119b23e\",\"clientAddress\":\"127.0.0.1\",\"startTime\":\"2018-06-05T08:09:47.644394493Z\"}"
+    missingTokenJSON = "{\"clientAddress\":\"127.0.0.1\",\"startTime\":\"2018-06-05T08:09:47.644394493Z\"}"

test/Network/Minio/JsonParser/Test.hs

@@ -0,0 +1,63 @@
+--
+-- MinIO Haskell SDK, (C) 2018 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.JsonParser.Test
+  ( jsonParserTests,
+  )
+where
+
+import Lib.Prelude
+import Network.Minio.Errors
+import Network.Minio.JsonParser
+import Test.Tasty
+import Test.Tasty.HUnit
+import UnliftIO (MonadUnliftIO)
+
+jsonParserTests :: TestTree
+jsonParserTests =
+  testGroup
+    "JSON Parser Tests"
+    [ testCase "Test parseErrResponseJSON" testParseErrResponseJSON
+    ]
+
+tryValidationErr :: (MonadUnliftIO m) => m a -> m (Either MErrV a)
+tryValidationErr = try
+
+assertValidationErr :: MErrV -> Assertion
+assertValidationErr e = assertFailure $ "Failed due to validation error => " ++ show e
+
+testParseErrResponseJSON :: Assertion
+testParseErrResponseJSON = do
+  -- 1. Test parsing of an invalid error json.
+  parseResE <- tryValidationErr $ parseErrResponseJSON "ClearlyInvalidJSON"
+  when (isRight parseResE) $
+    assertFailure $
+      "Parsing should have failed => " ++ show parseResE
+
+  forM_ cases $ \(jsondata, sErr) -> do
+    parseErr <- tryValidationErr $ parseErrResponseJSON jsondata
+    either assertValidationErr (@?= sErr) parseErr
+  where
+    cases =
+      [ -- 2. Test parsing of a valid error json.
+        ( "{\"Code\":\"InvalidAccessKeyId\",\"Message\":\"The access key ID you provided does not exist in our records.\",\"Key\":\"\",\"BucketName\":\"\",\"Resource\":\"/minio/admin/v1/info\",\"RequestId\":\"3L137\",\"HostId\":\"3L137\"}",
+          ServiceErr "InvalidAccessKeyId" "The access key ID you provided does not exist in our records."
+        ),
+        -- 3. Test parsing of a valid, empty Resource.
+        ( "{\"Code\":\"SignatureDoesNotMatch\",\"Message\":\"The request signature we calculated does not match the signature you provided. Check your key and signing method.\",\"Key\":\"\",\"BucketName\":\"\",\"Resource\":\"/minio/admin/v1/info\",\"RequestId\":\"3L137\",\"HostId\":\"3L137\"}",
+          ServiceErr "SignatureDoesNotMatch" "The request signature we calculated does not match the signature you provided. Check your key and signing method."
+        )
+      ]

test/Network/Minio/TestHelpers.hs

@@ -0,0 +1,32 @@
+--
+-- MinIO Haskell SDK, (C) 2018 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.TestHelpers
+  ( runTestNS,
+  )
+where
+
+import Network.Minio.Data
+
+newtype TestNS = TestNS {testNamespace :: Text}
+
+instance HasSvcNamespace TestNS where
+  getSvcNamespace = testNamespace
+
+runTestNS :: ReaderT TestNS m a -> m a
+runTestNS =
+  flip runReaderT $
+    TestNS "http://s3.amazonaws.com/doc/2006-03-01/"

test/Network/Minio/Utils/Test.hs

@@ -0,0 +1,45 @@
+--
+-- MinIO Haskell SDK, (C) 2017 MinIO, Inc.
+--
+-- Licensed under the Apache License, Version 2.0 (the "License");
+-- you may not use this file except in compliance with the License.
+-- You may obtain a copy of the License at
+--
+--     http://www.apache.org/licenses/LICENSE-2.0
+--
+-- Unless required by applicable law or agreed to in writing, software
+-- distributed under the License is distributed on an "AS IS" BASIS,
+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+-- See the License for the specific language governing permissions and
+-- limitations under the License.
+--
+
+module Network.Minio.Utils.Test
+  ( limitedMapConcurrentlyTests,
+  )
+where
+
+import Network.Minio.Utils
+import Test.Tasty
+import Test.Tasty.HUnit
+
+limitedMapConcurrentlyTests :: TestTree
+limitedMapConcurrentlyTests =
+  testGroup
+    "limitedMapConcurrently Tests"
+    [ testCase "Test with various thread counts" testLMC
+    ]
+
+testLMC :: Assertion
+testLMC = do
+  let maxNum = 50
+  -- test with thread count of 1 to 2*maxNum
+  forM_ [1 .. (2 * maxNum)] $ \threads -> do
+    res <- limitedMapConcurrently threads compute [1 .. maxNum]
+    sum res @?= overallResultCheck maxNum
+  where
+    -- simple function to run in each thread
+    compute :: Int -> IO Int
+    compute n = return $ sum [1 .. n]
+    -- function to check overall result
+    overallResultCheck n = sum $ map (\t -> (t * (t + 1)) `div` 2) [1 .. n]

test/Network/Minio/XmlGenerator/Test.hs

@@ -1,5 +1,5 @@
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- 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.
@@ -13,30 +13,42 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE QuasiQuotes #-}
 
 module Network.Minio.XmlGenerator.Test
-  ( xmlGeneratorTests
+  ( xmlGeneratorTests,
-  ) where
+  )
+where
 
+import qualified Data.ByteString.Lazy as LBS
+import Lib.Prelude
+import Network.Minio.Data
+import Network.Minio.TestHelpers
+import Network.Minio.XmlGenerator
+import Network.Minio.XmlParser (parseNotification)
 import Test.Tasty
 import Test.Tasty.HUnit
-
+import Text.RawString.QQ (r)
-import Lib.Prelude
+import Text.XML (def, parseLBS)
-
-import Network.Minio.XmlGenerator
 
 xmlGeneratorTests :: TestTree
-xmlGeneratorTests = testGroup "XML Generator Tests"
+xmlGeneratorTests =
-  [ testCase "Test mkCreateBucketConfig" testMkCreateBucketConfig
+  testGroup
-  , testCase "Test mkCompleteMultipartUploadRequest" testMkCompleteMultipartUploadRequest
+    "XML Generator Tests"
+    [ testCase "Test mkCreateBucketConfig" testMkCreateBucketConfig,
+      testCase "Test mkCompleteMultipartUploadRequest" testMkCompleteMultipartUploadRequest,
+      testCase "Test mkPutNotificationRequest" testMkPutNotificationRequest,
+      testCase "Test mkSelectRequest" testMkSelectRequest
     ]
 
 testMkCreateBucketConfig :: Assertion
 testMkCreateBucketConfig = do
+  let ns = "http://s3.amazonaws.com/doc/2006-03-01/"
   assertEqual "CreateBucketConfiguration xml should match: " expected $
-    mkCreateBucketConfig "EU"
+    mkCreateBucketConfig ns "EU"
   where
-    expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+    expected =
+      "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
       \<CreateBucketConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
       \<LocationConstraint>EU</LocationConstraint>\
       \</CreateBucketConfiguration>"
@@ -46,9 +58,125 @@ testMkCompleteMultipartUploadRequest =
   assertEqual "completeMultipartUpload xml should match: " expected $
     mkCompleteMultipartUploadRequest [(1, "abc")]
   where
-    expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+    expected =
+      "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
       \<CompleteMultipartUpload>\
       \<Part>\
       \<PartNumber>1</PartNumber><ETag>abc</ETag>\
       \</Part>\
       \</CompleteMultipartUpload>"
+
+testMkPutNotificationRequest :: Assertion
+testMkPutNotificationRequest =
+  forM_ cases $ \val -> do
+    let ns = "http://s3.amazonaws.com/doc/2006-03-01/"
+        result = fromStrictBS $ mkPutNotificationRequest ns val
+    ntf <- runExceptT $ runTestNS $ parseNotification result
+    either
+      (\_ -> assertFailure "XML Parse Error!")
+      (@?= val)
+      ntf
+  where
+    cases =
+      [ Notification
+          []
+          [ NotificationConfig
+              "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4"
+              "arn:aws:sns:us-east-1:account-id:s3notificationtopic2"
+              [ReducedRedundancyLostObject, ObjectCreated]
+              defaultFilter
+          ]
+          [],
+        Notification
+          [ NotificationConfig
+              "1"
+              "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"
+              [ObjectCreatedPut]
+              ( Filter $
+                  FilterKey $
+                    FilterRules
+                      [ FilterRule "prefix" "images/",
+                        FilterRule "suffix" ".jpg"
+                      ]
+              ),
+            NotificationConfig
+              ""
+              "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"
+              [ObjectCreated]
+              defaultFilter
+          ]
+          [ NotificationConfig
+              ""
+              "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"
+              [ReducedRedundancyLostObject]
+              defaultFilter
+          ]
+          [ NotificationConfig
+              "ObjectCreatedEvents"
+              "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"
+              [ObjectCreated]
+              defaultFilter
+          ]
+      ]
+
+testMkSelectRequest :: Assertion
+testMkSelectRequest = mapM_ assertFn cases
+  where
+    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"
+            SQL
+            ( InputSerialization
+                (Just CompressionTypeGzip)
+                ( InputFormatCSV $
+                    fileHeaderInfo FileHeaderIgnore
+                      <> recordDelimiter "\n"
+                      <> fieldDelimiter ","
+                      <> quoteCharacter "\""
+                      <> quoteEscapeCharacter "\""
+                )
+            )
+            ( OutputSerializationCSV $
+                quoteFields QuoteFieldsAsNeeded
+                  <> recordDelimiter "\n"
+                  <> fieldDelimiter ","
+                  <> quoteCharacter "\""
+                  <> 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>"</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 $
+            setInputCompressionType CompressionTypeGzip $
+              selectRequest
+                "Select * from S3Object"
+                documentJsonInput
+                (outputJSONFromRecordDelimiter "\n"),
+          [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>GZIP</CompressionType><JSON><Type>DOCUMENT</Type></JSON></InputSerialization><OutputSerialization><JSON><RecordDelimiter>
+</RecordDelimiter></JSON></OutputSerialization><RequestProgress><Enabled>FALSE</Enabled></RequestProgress></SelectRequest>|]
+        ),
+        ( setRequestProgressEnabled False $
+            setInputCompressionType CompressionTypeNone $
+              selectRequest
+                "Select * from S3Object"
+                defaultParquetInput
+                ( outputCSVFromProps $
+                    quoteFields QuoteFieldsAsNeeded
+                      <> recordDelimiter "\n"
+                      <> fieldDelimiter ","
+                      <> 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>"</QuoteCharacter><QuoteEscapeCharacter>"</QuoteEscapeCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter>
+</RecordDelimiter></CSV></OutputSerialization><RequestProgress><Enabled>FALSE</Enabled></RequestProgress></SelectRequest>|]
+        )
+      ]

test/Network/Minio/XmlParser/Test.hs

@@ -1,5 +1,5 @@
 --
--- Minio Haskell SDK, (C) 2017 Minio, Inc.
+-- 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.
@@ -13,36 +13,43 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE QuasiQuotes #-}
 
 module Network.Minio.XmlParser.Test
-  (
+  ( xmlParserTests,
-    xmlParserTests
+  )
-  ) where
+where
 
-import qualified Control.Monad.Catch as MC
+import qualified Data.HashMap.Strict as H
 import Data.Time (fromGregorian)
-import           Test.Tasty
-import           Test.Tasty.HUnit
-
 import Lib.Prelude
-
 import Network.Minio.Data
 import Network.Minio.Errors
+import Network.Minio.TestHelpers
 import Network.Minio.XmlParser
+import Test.Tasty
+import Test.Tasty.HUnit
+import Text.RawString.QQ (r)
+import UnliftIO (MonadUnliftIO)
 
 xmlParserTests :: TestTree
-xmlParserTests = testGroup "XML Parser Tests"
+xmlParserTests =
-  [ testCase "Test parseLocation" testParseLocation
+  testGroup
-  , testCase "Test parseNewMultipartUpload" testParseNewMultipartUpload
+    "XML Parser Tests"
-  , testCase "Test parseListObjectsResponse" testParseListObjectsResult
+    [ testCase "Test parseLocation" testParseLocation,
-  , testCase "Test parseListUploadsresponse" testParseListIncompleteUploads
+      testCase "Test parseNewMultipartUpload" testParseNewMultipartUpload,
-  , testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse
+      testCase "Test parseListObjectsResponse" testParseListObjectsResult,
-  , testCase "Test parseListPartsResponse" testParseListPartsResponse
+      testCase "Test parseListObjectsV1Response" testParseListObjectsV1Result,
-  , testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse
+      testCase "Test parseListUploadsresponse" testParseListIncompleteUploads,
+      testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse,
+      testCase "Test parseListPartsResponse" testParseListPartsResponse,
+      testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse,
+      testCase "Test parseNotification" testParseNotification,
+      testCase "Test parseSelectProgress" testParseSelectProgress
     ]
 
-tryValidationErr :: (MC.MonadCatch m) => m a -> m (Either MErrV a)
+tryValidationErr :: (MonadUnliftIO m) => m a -> m (Either MErrV a)
-tryValidationErr act = MC.try act
+tryValidationErr = try
 
 assertValidtionErr :: MErrV -> Assertion
 assertValidtionErr e = assertFailure $ "Failed due to validation error => " ++ show e
@@ -56,34 +63,33 @@ testParseLocation = do
   -- 1. Test parsing of an invalid location constraint xml.
   parseResE <- tryValidationErr $ parseLocation "ClearlyInvalidXml"
   when (isRight parseResE) $
-    assertFailure $ "Parsing should have failed => " ++ show parseResE
+    assertFailure $
+      "Parsing should have failed => " ++ show parseResE
 
   forM_ cases $ \(xmldata, expectedLocation) -> do
     parseLocE <- tryValidationErr $ parseLocation xmldata
     either assertValidtionErr (@?= expectedLocation) parseLocE
   where
-    cases =  [
+    cases =
-      -- 2. Test parsing of a valid location xml.
+      [ -- 2. Test parsing of a valid location xml.
-      ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+        ( "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
           \<LocationConstraint xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">EU</LocationConstraint>",
           "EU"
-      )
+        ),
-      ,
         -- 3. Test parsing of a valid, empty location xml.
-      ("<LocationConstraint xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"/>",
+        ( "<LocationConstraint xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"/>",
           "us-east-1"
         )
       ]
 
-
 testParseNewMultipartUpload :: Assertion
 testParseNewMultipartUpload = do
   forM_ cases $ \(xmldata, expectedUploadId) -> do
-    parsedUploadIdE <- tryValidationErr $ parseNewMultipartUpload xmldata
+    parsedUploadIdE <- tryValidationErr $ runTestNS $ parseNewMultipartUpload xmldata
     eitherValidationErr parsedUploadIdE (@?= expectedUploadId)
   where
-    cases = [
+    cases =
-      ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+      [ ( "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
           \<InitiateMultipartUploadResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
           \  <Bucket>example-bucket</Bucket>\
           \  <Key>example-object</Key>\
@@ -91,7 +97,7 @@ testParseNewMultipartUpload = do
           \</InitiateMultipartUploadResult>",
           "VXBsb2FkIElEIGZvciA2aWWpbmcncyBteS1tb3ZpZS5tMnRzIHVwbG9hZA"
         ),
-      ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+        ( "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
           \<InitiateMultipartUploadResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
           \  <Bucket>example-bucket</Bucket>\
           \  <Key>example-object</Key>\
@@ -103,14 +109,15 @@ testParseNewMultipartUpload = do
 
 testParseListObjectsResult :: Assertion
 testParseListObjectsResult = do
-  let
+  let xmldata =
-    xmldata = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+        "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
         \<ListBucketResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
         \<Name>bucket</Name>\
         \<Prefix/>\
-              \<KeyCount>205</KeyCount>\
+        \<NextContinuationToken>opaque</NextContinuationToken>\
+        \<KeyCount>1000</KeyCount>\
         \<MaxKeys>1000</MaxKeys>\
-              \<IsTruncated>false</IsTruncated>\
+        \<IsTruncated>true</IsTruncated>\
         \<Contents>\
         \<Key>my-image.jpg</Key>\
         \<LastModified>2009-10-12T17:50:30.000Z</LastModified>\
@@ -119,18 +126,43 @@ testParseListObjectsResult = do
         \<StorageClass>STANDARD</StorageClass>\
         \</Contents>\
         \</ListBucketResult>"
-
+      expectedListResult = ListObjectsResult True (Just "opaque") [object1] []
-    expectedListResult = ListObjectsResult False Nothing [object1] []
+      object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 H.empty H.empty
-    object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234
       modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12
 
-  parsedListObjectsResult <- tryValidationErr $ parseListObjectsResponse xmldata
+  parsedListObjectsResult <- tryValidationErr $ runTestNS $ parseListObjectsResponse xmldata
   eitherValidationErr parsedListObjectsResult (@?= expectedListResult)
 
+testParseListObjectsV1Result :: Assertion
+testParseListObjectsV1Result = do
+  let xmldata =
+        "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+        \<ListBucketResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+        \<Name>bucket</Name>\
+        \<Prefix/>\
+        \<NextMarker>my-image1.jpg</NextMarker>\
+        \<KeyCount>1000</KeyCount>\
+        \<MaxKeys>1000</MaxKeys>\
+        \<IsTruncated>true</IsTruncated>\
+        \<Contents>\
+        \<Key>my-image.jpg</Key>\
+        \<LastModified>2009-10-12T17:50:30.000Z</LastModified>\
+        \<ETag>&quot;fba9dede5f27731c9771645a39863328&quot;</ETag>\
+        \<Size>434234</Size>\
+        \<StorageClass>STANDARD</StorageClass>\
+        \</Contents>\
+        \</ListBucketResult>"
+      expectedListResult = ListObjectsV1Result True (Just "my-image1.jpg") [object1] []
+      object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 H.empty H.empty
+      modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12
+
+  parsedListObjectsV1Result <- tryValidationErr $ runTestNS $ parseListObjectsV1Response xmldata
+  eitherValidationErr parsedListObjectsV1Result (@?= expectedListResult)
+
 testParseListIncompleteUploads :: Assertion
 testParseListIncompleteUploads = do
-  let
+  let xmldata =
-    xmldata = "<ListMultipartUploadsResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+        "<ListMultipartUploadsResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
         \<Bucket>example-bucket</Bucket>\
         \<KeyMarker/>\
         \<UploadIdMarker/>\
@@ -166,30 +198,29 @@ testParseListIncompleteUploads = do
       initTime = UTCTime (fromGregorian 2010 11 26) 69857
       prefixes = ["photos/", "videos/"]
 
-  parsedListUploadsResult <- tryValidationErr $ parseListUploadsResponse xmldata
+  parsedListUploadsResult <- tryValidationErr $ runTestNS $ parseListUploadsResponse xmldata
   eitherValidationErr parsedListUploadsResult (@?= expectedListResult)
 
-
 testParseCompleteMultipartUploadResponse :: Assertion
 testParseCompleteMultipartUploadResponse = do
-  let
+  let xmldata =
-    xmldata = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+        "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
-\<CompleteMultipartUploadResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+        \<CompleteMultipartUploadResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
         \<Location>http://Example-Bucket.s3.amazonaws.com/Example-Object</Location>\
         \<Bucket>Example-Bucket</Bucket>\
         \<Key>Example-Object</Key>\
         \<ETag>\"3858f62230ac3c915f300c664312c11f-9\"</ETag>\
-\</CompleteMultipartUploadResult>"
+        \</CompleteMultipartUploadResult>"
       expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\""
 
-  parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata
+  parsedETagE <- runExceptT $ runTestNS $ parseCompleteMultipartUploadResponse xmldata
   eitherValidationErr parsedETagE (@?= expectedETag)
 
 testParseListPartsResponse :: Assertion
 testParseListPartsResponse = do
-  let
+  let xmldata =
-    xmldata = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+        "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
-\<ListPartsResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+        \<ListPartsResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
         \<Bucket>example-bucket</Bucket>\
         \<Key>example-object</Key>\
         \<UploadId>XXBsb2FkIElEIGZvciBlbHZpbmcncyVcdS1tb3ZpZS5tMnRzEEEwbG9hZA</UploadId>\
@@ -218,35 +249,155 @@ testParseListPartsResponse = do
         \<ETag>\"aaaa18db4cc2f85cedef654fccc4a4x8\"</ETag>\
         \<Size>10485760</Size>\
         \</Part>\
-\</ListPartsResult>"
+        \</ListPartsResult>"
-
       expectedListResult = ListPartsResult True (Just 3) [part1, part2]
       part1 = ObjectPartInfo 2 "\"7778aef83f66abc1fa1e8477f296d394\"" 10485760 modifiedTime1
       modifiedTime1 = flip UTCTime 74914 $ fromGregorian 2010 11 10
       part2 = ObjectPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2
       modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10
 
-  parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata
+  parsedListPartsResult <- runExceptT $ runTestNS $ parseListPartsResponse xmldata
   eitherValidationErr parsedListPartsResult (@?= expectedListResult)
 
 testParseCopyObjectResponse :: Assertion
 testParseCopyObjectResponse = do
-  let
+  let cases =
-    cases = [ ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+        [ ( "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
-\<CopyObjectResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+            \<CopyObjectResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
             \<LastModified>2009-10-28T22:32:00.000Z</LastModified>\
             \<ETag>\"9b2cf535f27731c974343645a3985328\"</ETag>\
-\</CopyObjectResult>",
+            \</CopyObjectResult>",
-              ("\"9b2cf535f27731c974343645a3985328\"",
+            ( "\"9b2cf535f27731c974343645a3985328\"",
-               UTCTime (fromGregorian 2009 10 28) 81120))
+              UTCTime (fromGregorian 2009 10 28) 81120
-            , ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+            )
-\<CopyPartResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+          ),
+          ( "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+            \<CopyPartResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
             \<LastModified>2009-10-28T22:32:00.000Z</LastModified>\
             \<ETag>\"9b2cf535f27731c974343645a3985328\"</ETag>\
-\</CopyPartResult>",
+            \</CopyPartResult>",
-              ("\"9b2cf535f27731c974343645a3985328\"",
+            ( "\"9b2cf535f27731c974343645a3985328\"",
-              UTCTime (fromGregorian 2009 10 28) 81120))]
+              UTCTime (fromGregorian 2009 10 28) 81120
+            )
+          )
+        ]
 
   forM_ cases $ \(xmldata, (etag, modTime)) -> do
-    parseResult <- runExceptT $ parseCopyObjectResponse xmldata
+    parseResult <- runExceptT $ runTestNS $ parseCopyObjectResponse xmldata
     eitherValidationErr parseResult (@?= (etag, modTime))
+
+testParseNotification :: Assertion
+testParseNotification = do
+  let cases =
+        [ ( "<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+            \  <TopicConfiguration>\
+            \    <Id>YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4</Id>\
+            \    <Topic>arn:aws:sns:us-east-1:account-id:s3notificationtopic2</Topic>\
+            \    <Event>s3:ReducedRedundancyLostObject</Event>\
+            \    <Event>s3:ObjectCreated:*</Event>\
+            \  </TopicConfiguration>\
+            \</NotificationConfiguration>",
+            Notification
+              []
+              [ NotificationConfig
+                  "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4"
+                  "arn:aws:sns:us-east-1:account-id:s3notificationtopic2"
+                  [ReducedRedundancyLostObject, ObjectCreated]
+                  defaultFilter
+              ]
+              []
+          ),
+          ( "<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+            \  <CloudFunctionConfiguration>\
+            \    <Id>ObjectCreatedEvents</Id>\
+            \    <CloudFunction>arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail</CloudFunction>\
+            \    <Event>s3:ObjectCreated:*</Event>\
+            \  </CloudFunctionConfiguration>\
+            \  <QueueConfiguration>\
+            \      <Id>1</Id>\
+            \      <Filter>\
+            \          <S3Key>\
+            \              <FilterRule>\
+            \                  <Name>prefix</Name>\
+            \                  <Value>images/</Value>\
+            \              </FilterRule>\
+            \              <FilterRule>\
+            \                  <Name>suffix</Name>\
+            \                  <Value>.jpg</Value>\
+            \              </FilterRule>\
+            \          </S3Key>\
+            \     </Filter>\
+            \     <Queue>arn:aws:sqs:us-west-2:444455556666:s3notificationqueue</Queue>\
+            \     <Event>s3:ObjectCreated:Put</Event>\
+            \  </QueueConfiguration>\
+            \  <TopicConfiguration>\
+            \    <Topic>arn:aws:sns:us-east-1:356671443308:s3notificationtopic2</Topic>\
+            \    <Event>s3:ReducedRedundancyLostObject</Event>\
+            \  </TopicConfiguration>\
+            \  <QueueConfiguration>\
+            \    <Queue>arn:aws:sqs:us-east-1:356671443308:s3notificationqueue</Queue>\
+            \    <Event>s3:ObjectCreated:*</Event>\
+            \  </QueueConfiguration>)\
+            \</NotificationConfiguration>",
+            Notification
+              [ NotificationConfig
+                  "1"
+                  "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"
+                  [ObjectCreatedPut]
+                  ( Filter $
+                      FilterKey $
+                        FilterRules
+                          [ FilterRule "prefix" "images/",
+                            FilterRule "suffix" ".jpg"
+                          ]
+                  ),
+                NotificationConfig
+                  ""
+                  "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"
+                  [ObjectCreated]
+                  defaultFilter
+              ]
+              [ NotificationConfig
+                  ""
+                  "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"
+                  [ReducedRedundancyLostObject]
+                  defaultFilter
+              ]
+              [ NotificationConfig
+                  "ObjectCreatedEvents"
+                  "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"
+                  [ObjectCreated]
+                  defaultFilter
+              ]
+          )
+        ]
+
+  forM_ cases $ \(xmldata, val) -> do
+    result <- runExceptT $ runTestNS $ parseNotification xmldata
+    eitherValidationErr result (@?= val)
+
+-- | Tests parsing of both progress and stats
+testParseSelectProgress :: Assertion
+testParseSelectProgress = do
+  let cases =
+        [ ( [r|<?xml version="1.0" encoding="UTF-8"?>
+<Progress>
+     <BytesScanned>512</BytesScanned>
+     <BytesProcessed>1024</BytesProcessed>
+     <BytesReturned>1024</BytesReturned>
+</Progress>|],
+            Progress 512 1024 1024
+          ),
+          ( [r|<?xml version="1.0" encoding="UTF-8"?>
+<Stats>
+     <BytesScanned>512</BytesScanned>
+     <BytesProcessed>1024</BytesProcessed>
+     <BytesReturned>1024</BytesReturned>
+</Stats>|],
+            Progress 512 1024 1024
+          )
+        ]
+
+  forM_ cases $ \(xmldata, progress) -> do
+    result <- runExceptT $ parseSelectProgress xmldata
+    eitherValidationErr result (@?= progress)

test/Spec.hs

@@ -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.
@@ -14,16 +14,17 @@
 -- limitations under the License.
 --
 
-import           Test.Tasty
+import qualified Data.ByteString as B
-import           Test.Tasty.QuickCheck as QC
-
 import qualified Data.List as L
-
 import Lib.Prelude
-
+import Network.Minio.API.Test
-import           Network.Minio.PutObject
+import Network.Minio.CopyObject
+import Network.Minio.Data
+import Network.Minio.Utils.Test
 import Network.Minio.XmlGenerator.Test
 import Network.Minio.XmlParser.Test
+import Test.Tasty
+import Test.Tasty.QuickCheck as QC
 
 main :: IO ()
 main = defaultMain tests
@@ -46,68 +47,87 @@ properties = testGroup "Properties" [qcProps] -- [scProps]
 --   ]
 
 qcProps :: TestTree
-qcProps = testGroup "(checked by QuickCheck)"
+qcProps =
+  testGroup
+    "(checked by QuickCheck)"
     [ QC.testProperty "selectPartSizes:" $
-    \n -> let (pns, offs, sizes) = L.unzip3 (selectPartSizes n)
+        \n ->
-
+          let (pns, offs, sizes) = L.unzip3 (selectPartSizes n)
               -- check that pns increments from 1.
-              isPNumsAscendingFrom1 = all (\(a, b) -> a == b) $ zip pns [1..]
+              isPNumsAscendingFrom1 = all (uncurry (==)) $ zip pns [1 ..]
-
               consPairs [] = []
               consPairs [_] = []
-              consPairs (a:(b:c)) = (a, b):(consPairs (b:c))
+              consPairs (a : (b : c)) = (a, b) : consPairs (b : c)
-
               -- check `offs` is monotonically increasing.
-              isOffsetsAsc = all (\(a, b) -> a < b) $ consPairs offs
+              isOffsetsAsc = all (uncurry (<)) $ consPairs offs
-
               -- check sizes sums to n.
               isSumSizeOk = sum sizes == n
-
               -- check sizes are constant except last
               isSizesConstantExceptLast =
-                all (\(a, b) -> a == b) (consPairs $ L.init sizes)
+                all (uncurry (==)) (consPairs $ L.init sizes)
-
               -- check each part except last is at least minPartSize;
               -- last part may be 0 only if it is the only part.
               nparts = length sizes
               isMinPartSizeOk =
-                if | nparts > 1 -> -- last part can be smaller but > 0
+                if
-                     all (>= minPartSize) (take (nparts - 1) sizes) &&
+                    | nparts > 1 -> -- last part can be smaller but > 0
-                     all (\s -> s > 0) (drop (nparts - 1) sizes)
+                        all (>= minPartSize) (take (nparts - 1) sizes)
+                          && all (> 0) (drop (nparts - 1) sizes)
                     | nparts == 1 -> -- size may be 0 here.
                         maybe True (\x -> x >= 0 && x <= minPartSize) $
-                       headMay sizes
+                          listToMaybe sizes
                     | otherwise -> False
-
+           in n < 0
-          in n < 0 ||
+                || ( isPNumsAscendingFrom1
-             (isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk &&
+                       && isOffsetsAsc
-              isSizesConstantExceptLast && isMinPartSizeOk)
+                       && isSumSizeOk
-
+                       && isSizesConstantExceptLast
-  , QC.testProperty "selectCopyRanges:" $
+                       && isMinPartSizeOk
+                   ),
+      QC.testProperty "selectCopyRanges:" $
         \(start, end) ->
           let (_, pairs) = L.unzip (selectCopyRanges (start, end))
-
               -- is last part's snd offset end?
               isLastPartOk = maybe False ((end ==) . snd) $ lastMay pairs
               -- is first part's fst offset start
-          isFirstPartOk = maybe False ((start ==) . fst) $ headMay pairs
+              isFirstPartOk = maybe False ((start ==) . fst) $ listToMaybe pairs
-
               -- each pair is >=64MiB except last, and all those parts
               -- have same size.
-          initSizes = maybe [] (map (\(a, b) -> b - a + 1)) $ initMay pairs
+              initSizes = maybe [] (map (\(a, b) -> b - a + 1) . init) (nonEmpty pairs)
-          isPartSizesOk = all (>= minPartSize) initSizes &&
+              isPartSizesOk =
-                          maybe True (\k -> all (== k) initSizes)
+                all (>= minPartSize) initSizes
-                          (headMay initSizes)
+                  && maybe
-
+                    True
+                    (\k -> all (== k) initSizes)
+                    (listToMaybe initSizes)
               -- returned offsets are contiguous.
               fsts = drop 1 $ map fst pairs
               snds = take (length pairs - 1) $ map snd pairs
-          isContParts = length fsts == length snds &&
+              isContParts =
-                        and (map (\(a, b) -> a == b + 1) $ zip fsts snds)
+                length fsts == length snds
-
+                  && all (\(a, b) -> a == b + 1) (zip fsts snds)
-      in start < 0 || start > end ||
+           in start < 0
-         (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts)
+                || start > end
+                || (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts),
+      QC.testProperty "mkSSECKey:" $
+        \w8s ->
+          let bs = B.pack w8s
+              r = mkSSECKey bs
+           in case r of
+                Just _ -> B.length bs == 32
+                Nothing -> B.length bs /= 32
     ]
 
 unitTests :: TestTree
-unitTests = testGroup "Unit tests" [xmlGeneratorTests, xmlParserTests]
+unitTests =
+  testGroup
+    "Unit tests"
+    [ xmlGeneratorTests,
+      xmlParserTests,
+      bucketNameValidityTests,
+      objectNameValidityTests,
+      parseServerInfoJSONTest,
+      parseHealStatusTest,
+      parseHealStartRespTest,
+      limitedMapConcurrentlyTests
+    ]

test/cert/private.key

@@ -0,0 +1,28 @@
+-----BEGIN PRIVATE KEY-----
+MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQC3G9IiC+adjf0p
+i/2KYc+4dizeuzUFN7wraSdhiOMdQgCnu9Dc3t2YEsQhNdrARjOTyXd36KeM3TwI
+rPJ61dRGQSuN12l+mzngFJQjE0sysZHUJOLQC3rVvIrHSQ57utPg8ifxt/SunlPY
+fhcUcq03onMGq44yOfE6mIhoe0Y9wcPQ3RjjNNS44bgmXiXwa+Do0h2hEn6/essq
+5KjHL8WW2vGg7G9edpYdxINA/A2fdLtr8BwPNrZhOx84eee2XcUNdBuTtUUxE+0L
+9yRqItqddriRxJFwOXb5OPW8xx2WGaV2a0wbE4gB2PTwwDvfo72mo9HXHZUHM1A8
+4TD/RXMbAgMBAAECggEBAJ7r1oUWLyGvinn0tijUm6RNbMQjVvEgXoCO008jr3pF
+PqxVpgEMrOa/4tmwFBus0jcCNF4t3r2zhddBw3I5A/O1vEdvHnBz6NdDBQ8sP6fP
+1fF50iEe1Y2MBibQkXFxxVMG2QRB1Gt5nuvXA9ELdqtCovK3EsMk5ukkWb/UvjH5
+8hcmQsaSqvzFEF4wJSY2mkeGSGIJTphPhhuA22xbhaBMInQyhZu8EHsn0h6s/Wgy
+C4Cp2+4qZTKaaf6x3/ZjJ8CuKiSX+ZsJKjOEv8sqx7j/Y7QFOmJPewInKDhwazr/
+xIK+N0KXPbUzeSEz6ZvExNDTxtR5ZlQP2UrRDg28yQECgYEA4Is1O2BvKVzNFOkj
+bTVz25a/bb0Xrcfgi0Y9rdfLzlNdItFjAkxLTVRSW2Hv9ICl0RDDAG+wTlktXRdh
+rfvDjwG2CvLQo1VEdMWTTkKVg03SwMEy2hFiWV69lENFGSaY8Y6unZDbia5HQinA
+EgSS4sCojS+a2jtzG5FVVHJDKlkCgYEA0MKhMhD4SUhr2y1idPBrmLxuW5mVozuW
+8bYaBeSzmfS0BRsN4fP9JGODPBPDdNbfGfGC9ezWLgD/lmCgjIEyBOq8EmqWSsiS
+Kihds1+Z7hXtbzGsFGAFJJTIh7blBCsK5QFuyuih2UG0fL9z6K/dy+UUJkzrYqph
+vSfKixyM8pMCgYEAmUPLsNyw4325aeV8TeWnUCJERaZFDFQa21W1cfyS2yEhuEtN
+llr3JzBACqn9vFk3VU1onNqfb8sE4L696KCpKeqUFEMK0AG6eS4Gzus53Gb5TKJS
+kHA/PhshsZp9Bp7G1FJ8s4YVo5N2hh2zQVkn3Wh9Y+kzfHQJrK51nO9lEvkCgYBi
+BuKWle1gzAcJdnhDHRoJMIJJtQbVDYhFnBMALXJAmu1lcFzGe0GlMq1PKqCfXr6I
+eiXawQmZtJJP1LPPBmOsd2U06KQGHcS00xucvQmVCOrjSdnZ/3SqxsqbH8DOgj+t
+ZUzXLwHA+N99rJEK9Hob4kfh7ECjpgobPnIXfKKazQKBgQChAuiXHtf/Qq18hY3u
+x48zFWjGgfd6GpOBZYkXOwGdCJgnYjZbE26LZEnYbwPh8ZUA2vp7mgHRJkD5e3Fj
+ERuJLCw86WqyYZmLEuBciYGjCZqR5nbavfwsziWD00jeNruds2ZwKxRfFm4V7o2S
+WLd/RUatd2Uu9f3B2J78OUdnxg==
+-----END PRIVATE KEY-----

test/cert/public.crt

@@ -0,0 +1,19 @@
+-----BEGIN CERTIFICATE-----
+MIIDCzCCAfOgAwIBAgIUaIUOMI78LCu+r1zl0mmFHK8n5/AwDQYJKoZIhvcNAQEL
+BQAwFDESMBAGA1UEAwwJbG9jYWxob3N0MCAXDTE5MTAyNDE5NTMxOVoYDzIxMTkw
+OTMwMTk1MzE5WjAUMRIwEAYDVQQDDAlsb2NhbGhvc3QwggEiMA0GCSqGSIb3DQEB
+AQUAA4IBDwAwggEKAoIBAQC3G9IiC+adjf0pi/2KYc+4dizeuzUFN7wraSdhiOMd
+QgCnu9Dc3t2YEsQhNdrARjOTyXd36KeM3TwIrPJ61dRGQSuN12l+mzngFJQjE0sy
+sZHUJOLQC3rVvIrHSQ57utPg8ifxt/SunlPYfhcUcq03onMGq44yOfE6mIhoe0Y9
+wcPQ3RjjNNS44bgmXiXwa+Do0h2hEn6/essq5KjHL8WW2vGg7G9edpYdxINA/A2f
+dLtr8BwPNrZhOx84eee2XcUNdBuTtUUxE+0L9yRqItqddriRxJFwOXb5OPW8xx2W
+GaV2a0wbE4gB2PTwwDvfo72mo9HXHZUHM1A84TD/RXMbAgMBAAGjUzBRMB0GA1Ud
+DgQWBBSEWXQ2JRD+OK7/KTmlD+OW16pGmzAfBgNVHSMEGDAWgBSEWXQ2JRD+OK7/
+KTmlD+OW16pGmzAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQCF
+0zYRaabB3X0jzGI9/Lr3Phrb90GvoL1DFLRuiOuTlDkz0vrm/HrZskwHCgMNrkCj
+OTD9Vpas4D1QZBbQbRzfnf3OOoG4bgmcCwLFZl3dy27yIDAhrmbUP++g9l1Jmy4v
+vBR/M4lt2scQ8LcZYEPqhEaE5EzFQEjtaxDcKdWDNKY9W1NUzSIABhF9eHiAUNdH
+AFNJlYeBlCHxcWIeqgon184Dqp/CsvKtz3z3Ni+rlwPM/zuJCFHh1VF+z++0LJjG
+roBCV0Tro4XyiEz9yp7Cb5kQYMaj1KL9TqBG0tZx0pmv7y+lXc4TT6DEllXz6USy
+rbIba9/uUet3BqeIMTqj
+-----END CERTIFICATE-----