Update code formatting and update dependencies (unliftio, protolude) (#152)

* Format code with ormolu

* Use latest unliftio-core

* Use latest protolude

.github/workflows/haskell.yml

@@ -47,7 +47,7 @@ jobs:
     - name: Install dependencies
       run: |
         cabal v2-update
-        cabal v2-build --only-dependencies --enable-tests --enable-benchmarks --verbose=2
+        cabal v2-build --only-dependencies --enable-tests --enable-benchmarks
     - name: Build
       run: cabal v2-build --enable-tests --enable-benchmarks all
     - name: Run tests

Setup.hs

@@ -15,4 +15,5 @@
 --
 
 import Distribution.Simple
+
 main = defaultMain

examples/BucketExists.hs

@@ -16,11 +16,10 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# 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
@@ -28,8 +27,6 @@ import           Prelude
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
 main :: IO ()
 main = do
   let bucket = "missingbucket"

examples/CopyObject.hs

@@ -16,10 +16,9 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE OverloadedStrings #-}
-import           Network.Minio
 
+import Network.Minio
 import UnliftIO.Exception (catch, throwIO)
 
 -- | The following example uses minio's play server at
@@ -27,20 +26,18 @@ import           UnliftIO.Exception (catch, throwIO)
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
 main :: IO ()
 main = do
-  let
+  let bucket = "test"
-      bucket = "test"
       object = "obj"
       objectCopy = "obj-copy"
       localFile = "/etc/lsb-release"
 
   res1 <- runMinio minioPlayCI $ do
     -- 1. Make a bucket; Catch BucketAlreadyOwnedByYou exception.
-    catch (makeBucket bucket Nothing) (
+    catch
-      \e -> case e of
+      (makeBucket bucket Nothing)
+      ( \e -> case e of
           BucketAlreadyOwnedByYou -> return ()
           _ -> throwIO e
       )
@@ -49,7 +46,8 @@ main = do
     fPutObject bucket object localFile defaultPutObjectOptions
 
     -- 3. Copy bucket/object to bucket/objectCopy.
-    copyObject defaultDestinationInfo {dstBucket = bucket, dstObject = objectCopy}
+    copyObject
+      defaultDestinationInfo {dstBucket = bucket, dstObject = objectCopy}
       defaultSourceInfo {srcBucket = bucket, srcObject = object}
 
   case res1 of

examples/FileUploader.hs

@@ -16,18 +16,15 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
-
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-import           Network.Minio
 
 import Data.Monoid ((<>))
 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
@@ -35,21 +32,24 @@ import           Prelude
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
 
 -- optparse-applicative package based command-line parsing.
 fileNameArgs :: Parser FilePath
-fileNameArgs = strArgument
+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 :: ParserInfo FilePath
-cmdParser = info
+cmdParser =
+  info
     (helper <*> fileNameArgs)
     ( fullDesc
         <> progDesc "FileUploader"
         <> header
-             "FileUploader - a simple file-uploader program using minio-hs")
+          "FileUploader - a simple file-uploader program using minio-hs"
+    )
 
 main :: IO ()
 main = do

examples/GetConfig.hs

@@ -16,15 +16,15 @@
 -- 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 $
+  res <-
+    runMinio minioPlayCI $
       getConfig
   print res

examples/GetObject.hs

@@ -16,13 +16,11 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE OverloadedStrings #-}
-import           Network.Minio
 
 import qualified Data.Conduit as C
 import qualified Data.Conduit.Binary as CB
-
+import Network.Minio
 import Prelude
 
 -- | The following example uses minio's play server at
@@ -30,12 +28,9 @@ import           Prelude
 -- 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 <- runMinio minioPlayCI $ do
     src <- getObject bucket object defaultGetObjectOptions

examples/HeadObject.hs

@@ -16,11 +16,10 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE OverloadedStrings #-}
+
 import Network.Minio
 import Network.Minio.S3API
-
 import Prelude
 
 -- | The following example uses minio's play server at
@@ -28,14 +27,12 @@ import           Prelude
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
 main :: IO ()
 main = do
-  let
+  let bucket = "test"
-      bucket = "test"
       object = "passwd"
-  res <- runMinio minioPlayCI $
+  res <-
+    runMinio minioPlayCI $
       headObject bucket object []
 
   case res of

examples/Heal.hs

@@ -16,19 +16,23 @@
 -- 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
-      hsr <- startHeal Nothing Nothing HealOpts { hoRecursive = True
+      hsr <-
-                                                , hoDryRun = False
+        startHeal
+          Nothing
+          Nothing
+          HealOpts
+            { hoRecursive = True,
+              hoDryRun = False
             }
       getHealStatus Nothing Nothing (hsrClientToken hsr)
   print res

examples/ListBuckets.hs

@@ -16,11 +16,10 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# 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
@@ -28,7 +27,6 @@ import           Prelude
 -- 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.

examples/ListIncompleteUploads.hs

@@ -16,11 +16,10 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE OverloadedStrings #-}
-import           Network.Minio
 
 import Conduit
+import Network.Minio
 import Prelude
 
 -- | The following example uses minio's play server at
@@ -28,17 +27,16 @@ import           Prelude
 -- 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 <- runMinio minioPlayCI $
+  res <-
-    runConduit $ listIncompleteUploads bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))
+    runMinio minioPlayCI
+      $ runConduit
+      $ listIncompleteUploads bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))
   print res
 
 {-

examples/ListObjects.hs

@@ -16,31 +16,29 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE OverloadedStrings #-}
-import           Network.Minio
 
 import Conduit
+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
+  let bucket = "test"
-    bucket = "test"
 
   -- Performs a recursive listing of all objects under bucket "test"
   -- on play.min.io.
-  res <- runMinio minioPlayCI $
+  res <-
-    runConduit $ listObjects bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))
+    runMinio minioPlayCI
+      $ runConduit
+      $ listObjects bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))
   print res
+
 {-
   Following is the output of the above program on a local MinIO server.
 

examples/MakeBucket.hs

@@ -16,11 +16,9 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
-
 {-# LANGUAGE OverloadedStrings #-}
-import           Network.Minio
 
+import Network.Minio
 import Prelude
 
 -- | The following example uses minio's play server at
@@ -28,12 +26,11 @@ import           Prelude
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
 main :: IO ()
 main = do
   let bucket = "my-bucket"
-  res <- runMinio minioPlayCI $
+  res <-
+    runMinio minioPlayCI $
       -- N B the region provided for makeBucket is optional.
       makeBucket bucket (Just "us-east-1")
   print res

examples/PresignedGetObject.hs

@@ -16,34 +16,32 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE OverloadedStrings #-}
-import           Network.Minio
 
 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
+  let bucket = "my-bucket"
-    bucket = "my-bucket"
       object = "my-object"
       kb15 = 15 * 1024
-
       -- Set query parameter to modify content disposition response
       -- header
-    queryParam = [("response-content-disposition",
+      queryParam =
-                   Just "attachment; filename=\"your-filename.txt\"")]
+        [ ( "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..."
@@ -61,23 +59,28 @@ main = do
     -- 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)
+    url <-
-           queryParam headers
+      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
+      let hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"]
-        hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"]
+          curlCmd =
-        curlCmd = B.intercalate " " $
+            B.intercalate " " $
-                  ["curl --fail"] ++ map hdrOpt headers ++
+              ["curl --fail"] ++ map hdrOpt headers
-                  ["-o /tmp/myfile", B.concat ["'", url, "'"]]
+                ++ ["-o /tmp/myfile", B.concat ["'", url, "'"]]
 
-      putStrLn $ "The following curl command would use the presigned " ++
+      putStrLn $
-        "URL to fetch the object and write it to \"/tmp/myfile\":"
+        "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

@@ -16,46 +16,42 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE OverloadedStrings #-}
-import           Network.Minio
 
 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
+  let bucket = "my-bucket"
-    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
+      policyE =
+        newPostPolicy
+          expireTime
           [ -- set the object name condition
-                ppCondKey object
+            ppCondKey object,
             -- set the bucket name condition
-              , ppCondBucket bucket
+            ppCondBucket bucket,
             -- set the size range of object as 1B to 10MiB
-              , ppCondContentLengthRange 1 (10*1024*1024)
+            ppCondContentLengthRange 1 (10 * 1024 * 1024),
             -- set content type as jpg image
-              , ppCondContentType "image/jpeg"
+            ppCondContentType "image/jpeg",
             -- on success set the server response code to 200
-              , ppCondSuccessActionStatus 200
+            ppCondSuccessActionStatus 200
           ]
 
   case policyE of
@@ -66,12 +62,17 @@ main = do
 
         -- a curl command is output to demonstrate using the generated
         -- URL and form-data
-        let
+        let formFn (k, v) =
-          formFn (k, v) = B.concat ["-F ", Enc.encodeUtf8 k, "=",
+              B.concat
-                                    "'", v, "'"]
+                [ "-F ",
+                  Enc.encodeUtf8 k,
+                  "=",
+                  "'",
+                  v,
+                  "'"
+                ]
             formOptions = B.intercalate " " $ map formFn $ H.toList formData
 
-
         return $ B.intercalate " " $
           ["curl", formOptions, "-F file=@/tmp/photo.jpg", url]
 

examples/PresignedPutObject.hs

@@ -16,44 +16,42 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE OverloadedStrings #-}
-import           Network.Minio
 
 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
+  let -- Use headers to set user-metadata - note that this header will
-    -- 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",
+      headers =
-                "minio-hs-presigned-put-example")]
+        [ ( "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
+      let hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"]
-        hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"]
+          curlCmd =
-        curlCmd = B.intercalate " " $
+            B.intercalate " " $
-                  ["curl "] ++ map hdrOpt headers ++
+              ["curl "] ++ map hdrOpt headers
-                  ["-T /tmp/myfile", B.concat ["'", url, "'"]]
+                ++ ["-T /tmp/myfile", B.concat ["'", url, "'"]]
 
-      putStrLn $ "The following curl command would use the presigned " ++
+      putStrLn $
-        "URL to upload the file at \"/tmp/myfile\":"
+        "The following curl command would use the presigned "
+          ++ "URL to upload the file at \"/tmp/myfile\":"
       B.putStrLn curlCmd

examples/PutObject.hs

@@ -16,12 +16,10 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# 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
@@ -29,25 +27,24 @@ import           Prelude
 -- 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 with default options.
-  res1 <- runMinio minioPlayCI $
+  res1 <-
+    runMinio minioPlayCI $
       putObject bucket object (CC.repeat "a") (Just kb15) defaultPutObjectOptions
   case res1 of
     Left e -> putStrLn $ "putObject failed." ++ show e
     Right () -> putStrLn "putObject succeeded."
 
   -- Eg 2. Upload a file using fPutObject with default options.
-  res2 <- runMinio minioPlayCI $
+  res2 <-
+    runMinio minioPlayCI $
       fPutObject bucket object localFile defaultPutObjectOptions
   case res2 of
     Left e -> putStrLn $ "fPutObject failed." ++ show e

examples/RemoveBucket.hs

@@ -16,11 +16,9 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
-
 {-# LANGUAGE OverloadedStrings #-}
-import           Network.Minio
 
+import Network.Minio
 import Prelude
 
 -- | The following example uses minio's play server at
@@ -28,11 +26,8 @@ import           Prelude
 -- 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
   print res

examples/RemoveIncompleteUpload.hs

@@ -16,10 +16,9 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE OverloadedStrings #-}
-import           Network.Minio
 
+import Network.Minio
 import Prelude
 
 -- | The following example uses minio's play server at
@@ -27,15 +26,13 @@ import           Prelude
 -- credentials are provided via the libary constant,
 --
 -- > minioPlayCI :: ConnectInfo
---
-
 main :: IO ()
 main = do
-  let
+  let bucket = "mybucket"
-    bucket = "mybucket"
       object = "myobject"
 
-  res <- runMinio minioPlayCI $
+  res <-
+    runMinio minioPlayCI $
       removeIncompleteUpload bucket object
 
   case res of

examples/RemoveObject.hs

@@ -16,7 +16,6 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE OverloadedStrings #-}
 
 import Network.Minio
@@ -24,11 +23,11 @@ import           Prelude
 
 main :: IO ()
 main = do
-  let
+  let bucket = "mybucket"
-    bucket = "mybucket"
       object = "myobject"
 
-  res <- runMinio minioPlayCI $
+  res <-
+    runMinio minioPlayCI $
       removeObject bucket object
 
   case res of

examples/SelectObject.hs

@@ -16,26 +16,24 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE OverloadedStrings #-}
-import           Network.Minio
 
 import qualified Conduit as C
 import Control.Monad (when)
-
+import Network.Minio
 import Prelude
 
 main :: IO ()
 main = do
   let bucket = "selectbucket"
       object = "1.csv"
-        content = "Name,Place,Temperature\n"
+      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
     when (not exists) $
       makeBucket bucket Nothing

examples/ServerInfo.hs

@@ -16,15 +16,15 @@
 -- 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 $
+  res <-
+    runMinio minioPlayCI $
       getServerInfo
   print res

examples/ServiceSendRestart.hs

@@ -16,15 +16,15 @@
 -- 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 $
+  res <-
+    runMinio minioPlayCI $
       serviceSendAction ServiceActionRestart
   print res

examples/ServiceSendStop.hs

@@ -16,15 +16,15 @@
 -- 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 $
+  res <-
+    runMinio minioPlayCI $
       serviceSendAction ServiceActionStop
   print res

examples/ServiceStatus.hs

@@ -16,15 +16,15 @@
 -- 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 $
+  res <-
+    runMinio minioPlayCI $
       serviceStatus
   print res

examples/SetConfig.hs

@@ -16,11 +16,10 @@
 -- 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 ()

minio-hs.cabal

@@ -56,7 +56,7 @@ common base-settings
                      , Network.Minio.XmlParser
                      , Network.Minio.JsonParser
   build-depends:       base >= 4.7 && < 5
-                     , protolude >= 0.2 && < 0.3
+                     , protolude >= 0.3 && < 0.4
                      , aeson >= 1.2
                      , base64-bytestring >= 1.0
                      , binary >= 0.8.5.0
@@ -83,8 +83,8 @@ common base-settings
                      , text >= 1.2
                      , time >= 1.8
                      , transformers >= 0.5
-                     , unliftio >= 0.2
+                     , unliftio >= 0.2 && < 0.3
-                     , unliftio-core >= 0.1 && < 0.2
+                     , unliftio-core >= 0.2 && < 0.3
                      , unordered-containers >= 0.2
                      , xml-conduit >= 1.8
 

src/Lib/Prelude.hs

@@ -15,19 +15,45 @@
 --
 
 module Lib.Prelude
-    ( module Exports
+  ( module Exports,
-    , both
+    both,
-    ) where
+    showBS,
-
+    toStrictBS,
-import           Protolude                 as Exports hiding (catch, catches,
+    fromStrictBS,
-                                                       throwIO, try)
+  )
+where
 
 import Control.Monad.Trans.Maybe as Exports (MaybeT (..), runMaybeT)
-import           Data.Time                 as Exports (UTCTime (..),
+import qualified Data.ByteString.Lazy as LB
-                                                       diffUTCTime)
+import Data.Time as Exports
-import           UnliftIO                  as Exports (catch, catches, throwIO,
+  ( UTCTime (..),
-                                                       try)
+    diffUTCTime,
+  )
+import Protolude as Exports hiding
+  ( Handler,
+    catch,
+    catches,
+    throwIO,
+    try,
+    yield,
+  )
+import UnliftIO as Exports
+  ( Handler,
+    catch,
+    catches,
+    throwIO,
+    try,
+  )
 
 -- | 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 = toUtf8 (show a :: Text)
+
+toStrictBS :: LByteString -> ByteString
+toStrictBS = LB.toStrict
+
+fromStrictBS :: ByteString -> LByteString
+fromStrictBS = LB.fromStrict

src/Network/Minio.hs

@@ -22,199 +22,200 @@
 --
 -- Types and functions to conveniently access S3 compatible object
 -- storage servers like MinIO.
-
 module Network.Minio
-  (
+  ( -- * Credentials
-  -- * Credentials
+    Credentials (..),
-    Credentials (..)
 
     -- ** Credential providers
+
     -- | Run actions that retrieve 'Credentials' from the environment or
     -- files or other custom sources.
-  , Provider
+    Provider,
-  , fromAWSConfigFile
+    fromAWSConfigFile,
-  , fromAWSEnv
+    fromAWSEnv,
-  , fromMinioEnv
+    fromMinioEnv,
-  , findFirst
+    findFirst,
 
     -- * Connecting to object storage
-  , ConnectInfo
+    ConnectInfo,
-  , setRegion
+    setRegion,
-  , setCreds
+    setCreds,
-  , setCredsFrom
+    setCredsFrom,
-  , isConnectInfoSecure
+    isConnectInfoSecure,
-  , disableTLSCertValidation
+    disableTLSCertValidation,
-  , MinioConn
+    MinioConn,
-  , mkMinioConn
+    mkMinioConn,
 
     -- ** Connection helpers
+
     -- | These are helpers to construct 'ConnectInfo' values for common
     -- cases.
-  , minioPlayCI
+    minioPlayCI,
-  , awsCI
+    awsCI,
-  , gcsCI
+    gcsCI,
 
     -- * Minio Monad
     ----------------
+
     -- | The Minio Monad provides connection-reuse, bucket-location
     -- caching, resource management and simpler error handling
     -- functionality. All actions on object storage are performed within
     -- this Monad.
-  , Minio
+    Minio,
-  , runMinioWith
+    runMinioWith,
-  , runMinio
+    runMinio,
-  , runMinioResWith
+    runMinioResWith,
-  , runMinioRes
+    runMinioRes,
 
     -- * Bucket Operations
 
     -- ** Creation, removal and querying
-  , Bucket
+    Bucket,
-  , makeBucket
+    makeBucket,
-  , removeBucket
+    removeBucket,
-  , bucketExists
+    bucketExists,
-  , Region
+    Region,
-  , getLocation
+    getLocation,
 
     -- ** Listing buckets
-  , BucketInfo(..)
+    BucketInfo (..),
-  , listBuckets
+    listBuckets,
 
     -- ** Listing objects
-  , listObjects
+    listObjects,
-  , listObjectsV1
+    listObjectsV1,
-  , ListItem(..)
+    ListItem (..),
-
+    ObjectInfo,
-  , ObjectInfo
+    oiObject,
-  , oiObject
+    oiModTime,
-  , oiModTime
+    oiETag,
-  , oiETag
+    oiSize,
-  , oiSize
+    oiUserMetadata,
-  , oiUserMetadata
+    oiMetadata,
-  , oiMetadata
 
     -- ** Listing incomplete uploads
-  , listIncompleteUploads
+    listIncompleteUploads,
-  , UploadId
+    UploadId,
-  , UploadInfo(..)
+    UploadInfo (..),
-  , listIncompleteParts
+    listIncompleteParts,
-  , ObjectPartInfo(..)
+    ObjectPartInfo (..),
 
     -- ** Bucket Notifications
-  , getBucketNotification
+    getBucketNotification,
-  , putBucketNotification
+    putBucketNotification,
-  , removeAllBucketNotification
+    removeAllBucketNotification,
-  , Notification(..)
+    Notification (..),
-  , defaultNotification
+    defaultNotification,
-  , NotificationConfig(..)
+    NotificationConfig (..),
-  , Arn
+    Arn,
-  , Event(..)
+    Event (..),
-  , Filter(..)
+    Filter (..),
-  , defaultFilter
+    defaultFilter,
-  , FilterKey(..)
+    FilterKey (..),
-  , defaultFilterKey
+    defaultFilterKey,
-  , FilterRules(..)
+    FilterRules (..),
-  , defaultFilterRules
+    defaultFilterRules,
-  , FilterRule(..)
+    FilterRule (..),
 
     -- * Object Operations
-  , Object
+    Object,
 
     -- ** File-based operations
-  , fGetObject
+    fGetObject,
-  , fPutObject
+    fPutObject,
 
     -- ** Conduit-based streaming operations
-  , putObject
+    putObject,
-  , PutObjectOptions
+    PutObjectOptions,
-  , defaultPutObjectOptions
+    defaultPutObjectOptions,
-  , pooContentType
+    pooContentType,
-  , pooContentEncoding
+    pooContentEncoding,
-  , pooContentDisposition
+    pooContentDisposition,
-  , pooContentLanguage
+    pooContentLanguage,
-  , pooCacheControl
+    pooCacheControl,
-  , pooStorageClass
+    pooStorageClass,
-  , pooUserMetadata
+    pooUserMetadata,
-  , pooNumThreads
+    pooNumThreads,
-  , pooSSE
+    pooSSE,
-
+    getObject,
-  , getObject
+    GetObjectOptions,
-  , GetObjectOptions
+    defaultGetObjectOptions,
-  , defaultGetObjectOptions
+    gooRange,
-  , gooRange
+    gooIfMatch,
-  , gooIfMatch
+    gooIfNoneMatch,
-  , gooIfNoneMatch
+    gooIfModifiedSince,
-  , gooIfModifiedSince
+    gooIfUnmodifiedSince,
-  , gooIfUnmodifiedSince
+    gooSSECKey,
-  , gooSSECKey
+    GetObjectResponse,
-  , GetObjectResponse
+    gorObjectInfo,
-  , gorObjectInfo
+    gorObjectStream,
-  , gorObjectStream
 
     -- ** Server-side object copying
-  , copyObject
+    copyObject,
-  , SourceInfo
+    SourceInfo,
-  , defaultSourceInfo
+    defaultSourceInfo,
-  , srcBucket
+    srcBucket,
-  , srcObject
+    srcObject,
-  , srcRange
+    srcRange,
-  , srcIfMatch
+    srcIfMatch,
-  , srcIfNoneMatch
+    srcIfNoneMatch,
-  , srcIfModifiedSince
+    srcIfModifiedSince,
-  , srcIfUnmodifiedSince
+    srcIfUnmodifiedSince,
-  , DestinationInfo
+    DestinationInfo,
-  , defaultDestinationInfo
+    defaultDestinationInfo,
-  , dstBucket
+    dstBucket,
-  , dstObject
+    dstObject,
 
     -- ** Querying object info
-  , statObject
+    statObject,
 
     -- ** Object removal operations
-  , removeObject
+    removeObject,
-  , removeIncompleteUpload
+    removeIncompleteUpload,
 
     -- ** Select Object Content with SQL
-  , module Network.Minio.SelectAPI
+    module Network.Minio.SelectAPI,
 
     -- * Server-Side Encryption Helpers
-  , mkSSECKey
+    mkSSECKey,
-  , SSECKey
+    SSECKey,
-  , SSE(..)
+    SSE (..),
 
     -- * Presigned Operations
-  , presignedPutObjectUrl
+    presignedPutObjectUrl,
-  , presignedGetObjectUrl
+    presignedGetObjectUrl,
-  , presignedHeadObjectUrl
+    presignedHeadObjectUrl,
-  , UrlExpiry
+    UrlExpiry,
 
     -- ** POST (browser) upload helpers
+
     -- | Please see
     -- https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-HTTPPOSTConstructPolicy.html
     -- for detailed information.
-  , newPostPolicy
+    newPostPolicy,
-  , presignedPostPolicy
+    presignedPostPolicy,
-  , showPostPolicy
+    showPostPolicy,
-  , PostPolicy
+    PostPolicy,
-  , PostPolicyError(..)
+    PostPolicyError (..),
 
     -- *** Post Policy condition helpers
-  , PostPolicyCondition
+    PostPolicyCondition,
-  , ppCondBucket
+    ppCondBucket,
-  , ppCondContentLengthRange
+    ppCondContentLengthRange,
-  , ppCondContentType
+    ppCondContentType,
-  , ppCondKey
+    ppCondKey,
-  , ppCondKeyStartsWith
+    ppCondKeyStartsWith,
-  , ppCondSuccessActionStatus
+    ppCondSuccessActionStatus,
 
     -- * Error handling
+
     -- | Data types representing various errors that may occur while
     -- working with an object storage service.
-  , MinioErr(..)
+    MinioErr (..),
-  , MErrV(..)
+    MErrV (..),
-  , ServiceErr(..)
+    ServiceErr (..),
-
+  )
-) where
+where
 
 {-
 This module exports the high-level MinIO API for object storage.
@@ -223,9 +224,7 @@ This module exports the high-level MinIO API for object storage.
 import qualified Data.Conduit as C
 import qualified Data.Conduit.Binary as CB
 import qualified Data.Conduit.Combinators as CC
-
 import Lib.Prelude
-
 import Network.Minio.CopyObject
 import Network.Minio.Data
 import Network.Minio.Errors
@@ -248,8 +247,12 @@ fGetObject bucket object fp opts = do
   C.connect (gorObjectStream src) $ CB.sinkFileCautious fp
 
 -- | Upload the given file to the given object.
-fPutObject :: Bucket -> Object -> FilePath
+fPutObject ::
-           -> PutObjectOptions -> Minio ()
+  Bucket ->
+  Object ->
+  FilePath ->
+  PutObjectOptions ->
+  Minio ()
 fPutObject bucket object f opts =
   void $ putObjectInternal bucket object opts $ ODFile f Nothing
 
@@ -257,8 +260,13 @@ fPutObject bucket object f opts =
 -- 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.ConduitM () ByteString Minio ()
+putObject ::
-          -> Maybe Int64 -> PutObjectOptions -> Minio ()
+  Bucket ->
+  Object ->
+  C.ConduitM () ByteString Minio () ->
+  Maybe Int64 ->
+  PutObjectOptions ->
+  Minio ()
 putObject bucket object src sizeMay opts =
   void $ putObjectInternal bucket object opts $ ODStream src sizeMay
 
@@ -268,16 +276,23 @@ putObject bucket object src sizeMay opts =
 -- copy operation if the new object is to be greater than 5GiB in
 -- size.
 copyObject :: DestinationInfo -> SourceInfo -> Minio ()
-copyObject dstInfo srcInfo = void $ copyObjectInternal (dstBucket dstInfo)
+copyObject dstInfo srcInfo =
-                             (dstObject 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.
-getObject :: Bucket -> Object -> GetObjectOptions
+getObject ::
-          -> Minio GetObjectResponse
+  Bucket ->
+  Object ->
+  GetObjectOptions ->
+  Minio GetObjectResponse
 getObject bucket object opts =
   getObject' bucket object [] $ gooToHeaders opts
 
@@ -309,6 +324,8 @@ 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
+  uploads <-
+    C.runConduit $
+      listIncompleteUploads bucket (Just object) False
         C..| CC.sinkList
   mapM_ (abortMultipartUpload bucket object) (uiUploadId <$> uploads)

src/Network/Minio/API.hs

@@ -15,35 +15,35 @@
 --
 
 module Network.Minio.API
-  ( connect
+  ( connect,
-  , S3ReqInfo(..)
+    S3ReqInfo (..),
-  , runMinio
+    runMinio,
-  , executeRequest
+    executeRequest,
-  , mkStreamRequest
+    mkStreamRequest,
-  , getLocation
+    getLocation,
+    isValidBucketName,
+    checkBucketNameValidity,
+    isValidObjectName,
+    checkObjectNameValidity,
+  )
+where
 
-  , isValidBucketName
+import Control.Retry
-  , checkBucketNameValidity
+  ( fullJitterBackoff,
-  , isValidObjectName
-  , checkObjectNameValidity
-  ) where
-
-import           Control.Retry             (fullJitterBackoff,
     limitRetriesByCumulativeDelay,
-                                            retrying)
+    retrying,
+  )
 import qualified Data.ByteString as B
 import qualified Data.Char as C
 import qualified Data.Conduit as C
 import qualified Data.HashMap.Strict as H
 import qualified Data.Text as T
 import qualified Data.Time.Clock as Time
+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           Lib.Prelude
-
 import Network.Minio.APICommon
 import Network.Minio.Data
 import Network.Minio.Errors
@@ -54,38 +54,41 @@ import           Network.Minio.XmlParser
 -- | Fetch bucket location (region)
 getLocation :: Bucket -> Minio Region
 getLocation bucket = do
-  resp <- executeRequest $ defaultS3ReqInfo {
+  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 :: S3ReqInfo -> Minio (Maybe Region)
 discoverRegion ri = runMaybeT $ do
   bucket <- MaybeT $ return $ riBucket ri
   regionMay <- lift $ lookupRegionCache bucket
-  maybe (do
+  maybe
+    ( do
         l <- lift $ getLocation bucket
         lift $ addToRegionCache bucket l
         return l
-        ) return regionMay
+    )
+    return
+    regionMay
 
 getRegion :: S3ReqInfo -> Minio (Maybe Region)
 getRegion ri = do
   ci <- asks mcConnInfo
 
   -- getService/makeBucket/getLocation -- don't need location
-    if | not $ riNeedsLocation ri ->
+  if
+      | not $ riNeedsLocation ri ->
         return $ Just $ connectRegion ci
-
       -- if autodiscovery of location is disabled by user
       | not $ connectAutoDiscoverRegion ci ->
         return $ Just $ connectRegion ci
-
       -- discover the region for the request
       | otherwise -> discoverRegion ri
 
@@ -94,8 +97,11 @@ getRegionHost r = do
   ci <- asks mcConnInfo
 
   if "amazonaws.com" `T.isSuffixOf` connectHost ci
-    then maybe (throwIO $ MErrVRegionNotSupported r)
+    then
-         return (H.lookup r awsRegionMap)
+      maybe
+        (throwIO $ MErrVRegionNotSupported r)
+        return
+        (H.lookup r awsRegionMap)
     else return $ connectHost ci
 
 buildRequest :: S3ReqInfo -> Minio NC.Request
@@ -109,27 +115,35 @@ buildRequest ri = do
 
   regionHost <- maybe (return $ connectHost ci) getRegionHost regionMay
 
-    let ri' = ri { riHeaders = hostHeader : riHeaders ri
+  let ri' =
-                 , riRegion = regionMay
+        ri
+          { riHeaders = hostHeader : riHeaders ri,
+            riRegion = regionMay
           }
       ci' = ci {connectHost = regionHost}
       hostHeader = (hHost, getHostAddr ci')
-
       -- Does not contain body and auth info.
-        baseRequest = NC.defaultRequest
+      baseRequest =
-                      { NC.method = riMethod ri'
+        NC.defaultRequest
-                      , NC.secure = connectIsSecure ci'
+          { NC.method = riMethod ri',
-                      , NC.host = encodeUtf8 $ connectHost ci'
+            NC.secure = connectIsSecure ci',
-                      , NC.port = connectPort ci'
+            NC.host = encodeUtf8 $ connectHost ci',
-                      , NC.path = getS3Path (riBucket ri') (riObject ri')
+            NC.port = connectPort ci',
-                      , NC.requestHeaders = riHeaders ri'
+            NC.path = getS3Path (riBucket ri') (riObject ri'),
-                      , NC.queryString = HT.renderQuery False $ riQueryParams ri'
+            NC.requestHeaders = riHeaders ri',
+            NC.queryString = HT.renderQuery False $ riQueryParams ri'
           }
 
   timeStamp <- liftIO Time.getCurrentTime
 
-    let sp = SignParams (connectAccessKey ci') (connectSecretKey ci')
+  let sp =
-             timeStamp (riRegion ri') Nothing Nothing
+        SignParams
+          (connectAccessKey ci')
+          (connectSecretKey ci')
+          timeStamp
+          (riRegion ri')
+          Nothing
+          Nothing
 
   -- Cases to handle:
   --
@@ -142,42 +156,46 @@ buildRequest ri = do
   -- sha256hash, buffer request in memory and perform request.
 
   -- case 2 from above.
-    if | isStreamingPayload (riPayload ri') &&
+  if
-         (not $ connectIsSecure ci') -> do
+      | isStreamingPayload (riPayload ri')
+          && (not $ connectIsSecure ci') -> do
         (pLen, pSrc) <- case riPayload ri of
           PayloadC l src -> return (l, src)
           _ -> throwIO MErrVUnexpectedPayload
         let reqFn = signV4Stream pLen sp baseRequest
         return $ reqFn pSrc
-
       | otherwise -> do
         -- case 1 described above.
-             sp' <- if | connectIsSecure ci' -> return sp
+        sp' <-
+          if
+              | connectIsSecure ci' -> return sp
               -- case 3 described above.
               | otherwise -> do
                 pHash <- getPayloadSHA256Hash $ riPayload ri'
                 return $ sp {spPayloadHash = Just pHash}
 
         let signHeaders = signV4 sp' baseRequest
-             return $ baseRequest
+        return $
+          baseRequest
             { NC.requestHeaders =
-                            NC.requestHeaders baseRequest ++
+                NC.requestHeaders baseRequest
-                            mkHeaderFromPairs signHeaders
+                  ++ mkHeaderFromPairs signHeaders,
-                      , NC.requestBody = getRequestBody (riPayload ri')
+              NC.requestBody = getRequestBody (riPayload ri')
             }
 
-
 retryAPIRequest :: Minio a -> Minio a
 retryAPIRequest apiCall = do
-  resE <- retrying retryPolicy (const shouldRetry) $
+  resE <-
-          const $ try apiCall
+    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
+    retryPolicy =
-                  $ fullJitterBackoff oneMilliSecond
+      limitRetriesByCumulativeDelay tenMins $
-
+        fullJitterBackoff oneMilliSecond
     oneMilliSecond = 1000 -- in microseconds
     tenMins = 10 * 60 * 1000000 -- in microseconds
     -- retry on connection related failure
@@ -197,15 +215,15 @@ retryAPIRequest apiCall = do
         -- We received an unexpected exception
         Left someOtherExn -> throwIO someOtherExn
 
-
 executeRequest :: S3ReqInfo -> Minio (Response LByteString)
 executeRequest ri = do
   req <- buildRequest ri
   mgr <- asks mcConnManager
   retryAPIRequest $ httpLbs req mgr
 
-mkStreamRequest :: S3ReqInfo
+mkStreamRequest ::
-                -> Minio (Response (C.ConduitM () ByteString Minio ()))
+  S3ReqInfo ->
+  Minio (Response (C.ConduitM () ByteString Minio ()))
 mkStreamRequest ri = do
   req <- buildRequest ri
   mgr <- asks mcConnManager
@@ -214,35 +232,43 @@ mkStreamRequest ri = do
 -- Bucket name validity check according to AWS rules.
 isValidBucketName :: Bucket -> Bool
 isValidBucketName bucket =
-  not (or [ len < 3 || len > 63
+  not
-          , or (map labelCheck labels)
+    ( or
-          , or (map labelCharsCheck labels)
+        [ len < 3 || len > 63,
-          , isIPCheck
+          or (map labelCheck labels),
-          ])
+          or (map 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 ||
+    labelCharsCheck l =
-                                                    x == '-' ||
+      isJust $
-                                                    C.isDigit x)) l
+        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 =
-  when (not $ isValidBucketName bucket) $
+  when (not $ isValidBucketName bucket)
-  throwIO $ MErrVInvalidBucketName bucket
+    $ throwIO
+    $ MErrVInvalidBucketName bucket
 
 isValidObjectName :: Object -> Bool
 isValidObjectName object =
@@ -250,5 +276,6 @@ isValidObjectName object =
 
 checkObjectNameValidity :: MonadIO m => Object -> m ()
 checkObjectNameValidity object =
-  when (not $ isValidObjectName object) $
+  when (not $ isValidObjectName object)
-  throwIO $ MErrVInvalidObjectName object
+    $ throwIO
+    $ MErrVInvalidObjectName object

src/Network/Minio/APICommon.hs

@@ -20,11 +20,9 @@ import qualified Conduit                   as C
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LB
 import Data.Conduit.Binary (sourceHandleRange)
+import Lib.Prelude
 import qualified Network.HTTP.Conduit as NC
 import qualified Network.HTTP.Types as HT
-
-import           Lib.Prelude
-
 import Network.Minio.Data
 import Network.Minio.Data.Crypto
 import Network.Minio.Errors
@@ -36,8 +34,10 @@ sha256Header = ("x-amz-content-sha256", )
 -- 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 $
+getPayloadSHA256Hash (PayloadH h off size) =
-  sourceHandleRange h
+  hashSHA256FromSource $
+    sourceHandleRange
+      h
       (return . fromIntegral $ off)
       (return . fromIntegral $ size)
 getPayloadSHA256Hash (PayloadC _ _) = throwIO MErrVUnexpectedPayload
@@ -46,7 +46,8 @@ getRequestBody :: Payload -> NC.RequestBody
 getRequestBody (PayloadBS bs) = NC.RequestBodyBS bs
 getRequestBody (PayloadH h off size) =
   NC.requestBodySource (fromIntegral size) $
-    sourceHandleRange h
+    sourceHandleRange
+      h
       (return . fromIntegral $ off)
       (return . fromIntegral $ size)
 getRequestBody (PayloadC n src) = NC.requestBodySource n src
@@ -55,10 +56,13 @@ mkStreamingPayload :: Payload -> Payload
 mkStreamingPayload payload =
   case payload of
     PayloadBS bs ->
-        PayloadC (fromIntegral $ BS.length bs)
+      PayloadC
+        (fromIntegral $ BS.length bs)
         (C.sourceLazy $ LB.fromStrict bs)
     PayloadH h off len ->
-        PayloadC len $ sourceHandleRange h
+      PayloadC len $
+        sourceHandleRange
+          h
           (return . fromIntegral $ off)
           (return . fromIntegral $ len)
     _ -> payload

src/Network/Minio/AdminAPI.hs

@@ -17,60 +17,67 @@
 module Network.Minio.AdminAPI
   ( -- * MinIO Admin API
   --------------------
+
     -- | Provides MinIO admin API and related types. It is in
     -- experimental state.
-    DriveInfo(..)
+    DriveInfo (..),
-  , ErasureInfo(..)
+    ErasureInfo (..),
-  , Backend(..)
+    Backend (..),
-  , ConnStats(..)
+    ConnStats (..),
-  , HttpStats(..)
+    HttpStats (..),
-  , ServerProps(..)
+    ServerProps (..),
-  , CountNAvgTime(..)
+    CountNAvgTime (..),
-  , StorageClass(..)
+    StorageClass (..),
-  , StorageInfo(..)
+    StorageInfo (..),
-  , SIData(..)
+    SIData (..),
-  , ServerInfo(..)
+    ServerInfo (..),
-  , getServerInfo
+    getServerInfo,
+    HealOpts (..),
+    HealResultItem (..),
+    HealStatus (..),
+    HealStartResp (..),
+    startHeal,
+    forceStartHeal,
+    getHealStatus,
+    SetConfigResult (..),
+    NodeSummary (..),
+    setConfig,
+    getConfig,
+    ServerVersion (..),
+    ServiceStatus (..),
+    serviceStatus,
+    ServiceAction (..),
+    serviceSendAction,
+  )
+where
 
-  , HealOpts(..)
+import Data.Aeson
-  , HealResultItem(..)
+  ( (.:),
-  , HealStatus(..)
+    (.:?),
-  , HealStartResp(..)
+    (.=),
-  , startHeal
+    FromJSON,
-  , forceStartHeal
+    ToJSON,
-  , getHealStatus
+    Value (Object),
-
+    eitherDecode,
-  , SetConfigResult(..)
+    object,
-  , NodeSummary(..)
+    pairs,
-  , setConfig
+    parseJSON,
-  , getConfig
+    toEncoding,
-
+    toJSON,
-  , ServerVersion(..)
+    withObject,
-  , ServiceStatus(..)
+    withText,
-  , 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           Lib.Prelude
-
 import Network.Minio.APICommon
 import Network.Minio.Data
 import Network.Minio.Errors
@@ -78,44 +85,51 @@ import           Network.Minio.Sign.V4
 import Network.Minio.Utils
 
 data DriveInfo = DriveInfo
-                 { diUuid     :: Text
+  { diUuid :: Text,
-                 , diEndpoint :: Text
+    diEndpoint :: Text,
-                 , diState    :: Text
+    diState :: Text
-                 } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON DriveInfo where
-    parseJSON = withObject "DriveInfo" $ \v -> DriveInfo
+  parseJSON = withObject "DriveInfo" $ \v ->
+    DriveInfo
       <$> v .: "uuid"
       <*> v .: "endpoint"
       <*> v .: "state"
 
 data StorageClass = StorageClass
-                    { scParity :: Int
+  { scParity :: Int,
-                    , scData   :: Int
+    scData :: Int
-                    } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 data ErasureInfo = ErasureInfo
-                   { eiOnlineDisks       :: Int
+  { eiOnlineDisks :: Int,
-                   , eiOfflineDisks      :: Int
+    eiOfflineDisks :: Int,
-                   , eiStandard          :: StorageClass
+    eiStandard :: StorageClass,
-                   , eiReducedRedundancy :: StorageClass
+    eiReducedRedundancy :: StorageClass,
-                   , eiSets              :: [[DriveInfo]]
+    eiSets :: [[DriveInfo]]
-                   } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON ErasureInfo where
   parseJSON = withObject "ErasureInfo" $ \v -> do
     onlineDisks <- v .: "OnlineDisks"
     offlineDisks <- v .: "OfflineDisks"
-        stdClass <- StorageClass
+    stdClass <-
+      StorageClass
         <$> v .: "StandardSCData"
         <*> v .: "StandardSCParity"
-        rrClass <- StorageClass
+    rrClass <-
+      StorageClass
         <$> v .: "RRSCData"
         <*> v .: "RRSCParity"
     sets <- v .: "Sets"
     return $ ErasureInfo onlineDisks offlineDisks stdClass rrClass sets
 
-data Backend = BackendFS
+data Backend
+  = BackendFS
   | BackendErasure ErasureInfo
   deriving (Eq, Show)
 
@@ -128,22 +142,25 @@ instance FromJSON Backend where
       _ -> typeMismatch "BackendType" (Object v)
 
 data ConnStats = ConnStats
-    { csTransferred :: Int64
+  { csTransferred :: Int64,
-    , csReceived    :: Int64
+    csReceived :: Int64
-    } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON ConnStats where
-    parseJSON = withObject "ConnStats" $ \v -> ConnStats
+  parseJSON = withObject "ConnStats" $ \v ->
+    ConnStats
       <$> v .: "transferred"
       <*> v .: "received"
 
 data ServerProps = ServerProps
-    { spUptime   :: NominalDiffTime
+  { spUptime :: NominalDiffTime,
-    , spVersion  :: Text
+    spVersion :: Text,
-    , spCommitId :: Text
+    spCommitId :: Text,
-    , spRegion   :: Text
+    spRegion :: Text,
-    , spSqsArns  :: [Text]
+    spSqsArns :: [Text]
-    } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON ServerProps where
   parseJSON = withObject "SIServer" $ \v -> do
@@ -156,40 +173,46 @@ instance FromJSON ServerProps where
     return $ ServerProps uptime ver commitId region arn
 
 data StorageInfo = StorageInfo
-    { siUsed    :: Int64
+  { siUsed :: Int64,
-    , siBackend :: Backend
+    siBackend :: Backend
-    } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON StorageInfo where
-    parseJSON = withObject "StorageInfo" $ \v -> StorageInfo
+  parseJSON = withObject "StorageInfo" $ \v ->
+    StorageInfo
       <$> v .: "Used"
       <*> v .: "Backend"
 
 data CountNAvgTime = CountNAvgTime
-    {  caCount       :: Int64
+  { caCount :: Int64,
-    ,  caAvgDuration :: Text
+    caAvgDuration :: Text
-    } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON CountNAvgTime where
-    parseJSON = withObject "CountNAvgTime" $ \v -> CountNAvgTime
+  parseJSON = withObject "CountNAvgTime" $ \v ->
+    CountNAvgTime
       <$> v .: "count"
       <*> v .: "avgDuration"
 
 data HttpStats = HttpStats
-    { hsTotalHeads     :: CountNAvgTime
+  { hsTotalHeads :: CountNAvgTime,
-    , hsSuccessHeads   :: CountNAvgTime
+    hsSuccessHeads :: CountNAvgTime,
-    , hsTotalGets      :: CountNAvgTime
+    hsTotalGets :: CountNAvgTime,
-    , hsSuccessGets    :: CountNAvgTime
+    hsSuccessGets :: CountNAvgTime,
-    , hsTotalPuts      :: CountNAvgTime
+    hsTotalPuts :: CountNAvgTime,
-    , hsSuccessPuts    :: CountNAvgTime
+    hsSuccessPuts :: CountNAvgTime,
-    , hsTotalPosts     :: CountNAvgTime
+    hsTotalPosts :: CountNAvgTime,
-    , hsSuccessPosts   :: CountNAvgTime
+    hsSuccessPosts :: CountNAvgTime,
-    , hsTotalDeletes   :: CountNAvgTime
+    hsTotalDeletes :: CountNAvgTime,
-    , hsSuccessDeletes :: CountNAvgTime
+    hsSuccessDeletes :: CountNAvgTime
-    } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON HttpStats where
-    parseJSON  = withObject "HttpStats" $ \v -> HttpStats
+  parseJSON = withObject "HttpStats" $ \v ->
+    HttpStats
       <$> v .: "totalHEADs"
       <*> v .: "successHEADs"
       <*> v .: "totalGETs"
@@ -202,45 +225,52 @@ instance FromJSON HttpStats where
       <*> v .: "successDELETEs"
 
 data SIData = SIData
-    { sdStorage   :: StorageInfo
+  { sdStorage :: StorageInfo,
-    , sdConnStats :: ConnStats
+    sdConnStats :: ConnStats,
-    , sdHttpStats :: HttpStats
+    sdHttpStats :: HttpStats,
-    , sdProps     :: ServerProps
+    sdProps :: ServerProps
-    } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON SIData where
-    parseJSON = withObject "SIData" $ \v -> SIData
+  parseJSON = withObject "SIData" $ \v ->
+    SIData
       <$> v .: "storage"
       <*> v .: "network"
       <*> v .: "http"
       <*> v .: "server"
 
 data ServerInfo = ServerInfo
-    { siError :: Text
+  { siError :: Text,
-    , siAddr  :: Text
+    siAddr :: Text,
-    , siData  :: SIData
+    siData :: SIData
-    } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON ServerInfo where
-    parseJSON = withObject "ServerInfo" $ \v -> ServerInfo
+  parseJSON = withObject "ServerInfo" $ \v ->
+    ServerInfo
       <$> v .: "error"
       <*> v .: "addr"
       <*> v .: "data"
 
 data ServerVersion = ServerVersion
-  { svVersion  :: Text
+  { svVersion :: Text,
-  , svCommitId :: Text
+    svCommitId :: Text
-  } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON ServerVersion where
-    parseJSON = withObject "ServerVersion" $ \v -> ServerVersion
+  parseJSON = withObject "ServerVersion" $ \v ->
+    ServerVersion
       <$> v .: "version"
       <*> v .: "commitID"
 
 data ServiceStatus = ServiceStatus
-  { ssVersion :: ServerVersion
+  { ssVersion :: ServerVersion,
-  , ssUptime  :: NominalDiffTime
+    ssUptime :: NominalDiffTime
-  } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON ServiceStatus where
   parseJSON = withObject "ServiceStatus" $ \v -> do
@@ -249,7 +279,8 @@ instance FromJSON ServiceStatus where
     let uptime = uptimeNs / 1e9
     return $ ServiceStatus serverVersion uptime
 
-data ServiceAction = ServiceActionRestart
+data ServiceAction
+  = ServiceActionRestart
   | ServiceActionStop
   deriving (Eq, Show)
 
@@ -265,21 +296,24 @@ adminPath :: ByteString
 adminPath = "/minio/admin"
 
 data HealStartResp = HealStartResp
-  { hsrClientToken :: Text
+  { hsrClientToken :: Text,
-  , hsrClientAddr  :: Text
+    hsrClientAddr :: Text,
-  , hsrStartTime   :: UTCTime
+    hsrStartTime :: UTCTime
-  } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON HealStartResp where
-    parseJSON = withObject "HealStartResp" $ \v -> HealStartResp
+  parseJSON = withObject "HealStartResp" $ \v ->
+    HealStartResp
       <$> v .: "clientToken"
       <*> v .: "clientAddress"
       <*> v .: "startTime"
 
 data HealOpts = HealOpts
-  { hoRecursive :: Bool
+  { hoRecursive :: Bool,
-  , hoDryRun    :: Bool
+    hoDryRun :: Bool
-  } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance ToJSON HealOpts where
   toJSON (HealOpts r d) =
@@ -288,11 +322,13 @@ instance ToJSON HealOpts where
     pairs ("recursive" .= r <> "dryRun" .= d)
 
 instance FromJSON HealOpts where
-    parseJSON = withObject "HealOpts" $ \v -> HealOpts
+  parseJSON = withObject "HealOpts" $ \v ->
+    HealOpts
       <$> v .: "recursive"
       <*> v .: "dryRun"
 
-data HealItemType = HealItemMetadata
+data HealItemType
+  = HealItemMetadata
   | HealItemBucket
   | HealItemBucketMetadata
   | HealItemObject
@@ -307,44 +343,50 @@ instance FromJSON HealItemType where
     _ -> typeMismatch "HealItemType" (A.String v)
 
 data NodeSummary = NodeSummary
-  { nsName       :: Text
+  { nsName :: Text,
-  , nsErrSet     :: Bool
+    nsErrSet :: Bool,
-  , nsErrMessage :: Text
+    nsErrMessage :: Text
-  } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON NodeSummary where
-  parseJSON = withObject "NodeSummary" $ \v -> NodeSummary
+  parseJSON = withObject "NodeSummary" $ \v ->
+    NodeSummary
       <$> v .: "name"
       <*> v .: "errSet"
       <*> v .: "errMsg"
 
 data SetConfigResult = SetConfigResult
-  { scrStatus      :: Bool
+  { scrStatus :: Bool,
-  , scrNodeSummary :: [NodeSummary]
+    scrNodeSummary :: [NodeSummary]
-  } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON SetConfigResult where
-  parseJSON = withObject "SetConfigResult" $ \v -> SetConfigResult
+  parseJSON = withObject "SetConfigResult" $ \v ->
+    SetConfigResult
       <$> v .: "status"
       <*> v .: "nodeResults"
 
 data HealResultItem = HealResultItem
-  { hriResultIdx    :: Int
+  { hriResultIdx :: Int,
-  , hriType         :: HealItemType
+    hriType :: HealItemType,
-  , hriBucket       :: Bucket
+    hriBucket :: Bucket,
-  , hriObject       :: Object
+    hriObject :: Object,
-  , hriDetail       :: Text
+    hriDetail :: Text,
-  , hriParityBlocks :: Maybe Int
+    hriParityBlocks :: Maybe Int,
-  , hriDataBlocks   :: Maybe Int
+    hriDataBlocks :: Maybe Int,
-  , hriDiskCount    :: Int
+    hriDiskCount :: Int,
-  , hriSetCount     :: Int
+    hriSetCount :: Int,
-  , hriObjectSize   :: Int
+    hriObjectSize :: Int,
-  , hriBefore       :: [DriveInfo]
+    hriBefore :: [DriveInfo],
-  , hriAfter        :: [DriveInfo]
+    hriAfter :: [DriveInfo]
-  } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON HealResultItem where
-  parseJSON = withObject "HealResultItem" $ \v -> HealResultItem
+  parseJSON = withObject "HealResultItem" $ \v ->
+    HealResultItem
       <$> v .: "resultId"
       <*> v .: "type"
       <*> v .: "bucket"
@@ -355,22 +397,28 @@ instance FromJSON HealResultItem where
       <*> v .: "diskCount"
       <*> v .: "setCount"
       <*> v .: "objectSize"
-    <*> (do before <- v .: "before"
+      <*> ( do
-            before .: "drives")
+              before <- v .: "before"
-    <*> (do after <- v .: "after"
+              before .: "drives"
-            after .: "drives")
+          )
+      <*> ( do
+              after <- v .: "after"
+              after .: "drives"
+          )
 
 data HealStatus = HealStatus
-  { hsSummary       :: Text
+  { hsSummary :: Text,
-  , hsStartTime     :: UTCTime
+    hsStartTime :: UTCTime,
-  , hsSettings      :: HealOpts
+    hsSettings :: HealOpts,
-  , hsNumDisks      :: Int
+    hsNumDisks :: Int,
-  , hsFailureDetail :: Maybe Text
+    hsFailureDetail :: Maybe Text,
-  , hsItems         :: Maybe [HealResultItem]
+    hsItems :: Maybe [HealResultItem]
-  } deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 instance FromJSON HealStatus where
-  parseJSON = withObject "HealStatus" $ \v -> HealStatus
+  parseJSON = withObject "HealStatus" $ \v ->
+    HealStatus
       <$> v .: "Summary"
       <*> v .: "StartTime"
       <*> v .: "Settings"
@@ -381,19 +429,24 @@ instance FromJSON HealStatus where
 healPath :: Maybe Bucket -> Maybe Text -> ByteString
 healPath bucket prefix = do
   if (isJust bucket)
-    then encodeUtf8 $ "v1/heal/" <> fromMaybe "" bucket <> "/"
+    then
+      encodeUtf8 $
+        "v1/heal/" <> fromMaybe "" bucket <> "/"
           <> fromMaybe "" prefix
     else encodeUtf8 $ "v1/heal/"
 
 -- | Get server version and uptime.
 serviceStatus :: Minio ServiceStatus
 serviceStatus = do
-    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodGet
+  rsp <-
-                                            , ariPayload = PayloadBS B.empty
+    executeAdminRequest
-                                            , ariPayloadHash = Nothing
+      AdminReqInfo
-                                            , ariPath = "v1/service"
+        { ariMethod = HT.methodGet,
-                                            , ariHeaders = []
+          ariPayload = PayloadBS B.empty,
-                                            , ariQueryParams = []
+          ariPayloadHash = Nothing,
+          ariPath = "v1/service",
+          ariHeaders = [],
+          ariQueryParams = []
         }
 
   let rspBS = NC.responseBody rsp
@@ -405,35 +458,44 @@ serviceStatus = do
 serviceSendAction :: ServiceAction -> Minio ()
 serviceSendAction action = do
   let payload = PayloadBS $ LBS.toStrict $ A.encode action
-    void $ executeAdminRequest AdminReqInfo { ariMethod = HT.methodPost
+  void $
-                                            , ariPayload = payload
+    executeAdminRequest
-                                            , ariPayloadHash = Nothing
+      AdminReqInfo
-                                            , ariPath = "v1/service"
+        { ariMethod = HT.methodPost,
-                                            , ariHeaders = []
+          ariPayload = payload,
-                                            , ariQueryParams = []
+          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
+  rsp <-
-                                            , ariPayload = PayloadBS B.empty
+    executeAdminRequest
-                                            , ariPayloadHash = Nothing
+      AdminReqInfo
-                                            , ariPath = "v1/config"
+        { ariMethod = HT.methodGet,
-                                            , ariHeaders = []
+          ariPayload = PayloadBS B.empty,
-                                            , ariQueryParams = []
+          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
+  rsp <-
-                                            , ariPayload = PayloadBS config
+    executeAdminRequest
-                                            , ariPayloadHash = Nothing
+      AdminReqInfo
-                                            , ariPath = "v1/config"
+        { ariMethod = HT.methodPut,
-                                            , ariHeaders = []
+          ariPayload = PayloadBS config,
-                                            , ariQueryParams = []
+          ariPayloadHash = Nothing,
+          ariPath = "v1/config",
+          ariHeaders = [],
+          ariQueryParams = []
         }
 
   let rspBS = NC.responseBody rsp
@@ -448,12 +510,15 @@ 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
+  rsp <-
-                                            , ariPayload = PayloadBS B.empty
+    executeAdminRequest
-                                            , ariPayloadHash = Nothing
+      AdminReqInfo
-                                            , ariPath = healPath bucket prefix
+        { ariMethod = HT.methodPost,
-                                            , ariHeaders = []
+          ariPayload = PayloadBS B.empty,
-                                            , ariQueryParams = qparams
+          ariPayloadHash = Nothing,
+          ariPath = healPath bucket prefix,
+          ariHeaders = [],
+          ariQueryParams = qparams
         }
   let rspBS = NC.responseBody rsp
   case eitherDecode rspBS of
@@ -464,15 +529,21 @@ 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")])
+  let qparams =
+        bool
+          []
+          (HT.queryTextToQuery [("forceStart", Just "true")])
           forceStart
 
-    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodPost
+  rsp <-
-                                            , ariPayload = payload
+    executeAdminRequest
-                                            , ariPayloadHash = Nothing
+      AdminReqInfo
-                                            , ariPath = healPath bucket prefix
+        { ariMethod = HT.methodPost,
-                                            , ariHeaders = []
+          ariPayload = payload,
-                                            , ariQueryParams = qparams
+          ariPayloadHash = Nothing,
+          ariPath = healPath bucket prefix,
+          ariHeaders = [],
+          ariQueryParams = qparams
         }
 
   let rspBS = NC.responseBody rsp
@@ -500,12 +571,15 @@ forceStartHeal bucket prefix opts = doHeal bucket prefix opts True
 -- properties, storage information, network statistics, etc.
 getServerInfo :: Minio [ServerInfo]
 getServerInfo = do
-    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodGet
+  rsp <-
-                                            , ariPayload = PayloadBS B.empty
+    executeAdminRequest
-                                            , ariPayloadHash = Nothing
+      AdminReqInfo
-                                            , ariPath = "v1/info"
+        { ariMethod = HT.methodGet,
-                                            , ariHeaders = []
+          ariPayload = PayloadBS B.empty,
-                                            , ariQueryParams = []
+          ariPayloadHash = Nothing,
+          ariPath = "v1/info",
+          ariHeaders = [],
+          ariQueryParams = []
         }
   let rspBS = NC.responseBody rsp
   case eitherDecode rspBS of
@@ -521,39 +595,51 @@ executeAdminRequest ari = do
 buildAdminRequest :: AdminReqInfo -> Minio NC.Request
 buildAdminRequest areq = do
   ci <- asks mcConnInfo
-    sha256Hash <- if | connectIsSecure ci ->
+  sha256Hash <-
+    if
+        | connectIsSecure ci ->
           -- if secure connection
           return "UNSIGNED-PAYLOAD"
-
         -- otherwise compute sha256
         | otherwise -> getPayloadSHA256Hash (ariPayload areq)
 
   timeStamp <- liftIO getCurrentTime
 
   let hostHeader = (hHost, getHostAddr ci)
-        newAreq = areq { ariPayloadHash = Just sha256Hash
+      newAreq =
-                       , ariHeaders = hostHeader
+        areq
+          { ariPayloadHash = Just sha256Hash,
+            ariHeaders =
+              hostHeader
                 : sha256Header sha256Hash
                 : ariHeaders areq
           }
       signReq = toRequest ci newAreq
-        sp = SignParams (connectAccessKey ci) (connectSecretKey ci)
+      sp =
-             timeStamp Nothing Nothing (ariPayloadHash newAreq)
+        SignParams
+          (connectAccessKey ci)
+          (connectSecretKey ci)
+          timeStamp
+          Nothing
+          Nothing
+          (ariPayloadHash newAreq)
       signHeaders = signV4 sp signReq
 
   -- Update signReq with Authorization header containing v4 signature
-    return signReq {
+  return
-        NC.requestHeaders = ariHeaders newAreq ++ mkHeaderFromPairs signHeaders
+    signReq
+      { NC.requestHeaders = ariHeaders newAreq ++ mkHeaderFromPairs signHeaders
       }
   where
     toRequest :: ConnectInfo -> AdminReqInfo -> NC.Request
-    toRequest ci aReq = NC.defaultRequest
+    toRequest ci aReq =
-        { NC.method = ariMethod aReq
+      NC.defaultRequest
-        , NC.secure = connectIsSecure ci
+        { NC.method = ariMethod aReq,
-        , NC.host = encodeUtf8 $ connectHost ci
+          NC.secure = connectIsSecure ci,
-        , NC.port = connectPort ci
+          NC.host = encodeUtf8 $ connectHost ci,
-        , NC.path = B.intercalate "/" [adminPath, ariPath aReq]
+          NC.port = connectPort ci,
-        , NC.requestHeaders = ariHeaders aReq
+          NC.path = B.intercalate "/" [adminPath, ariPath aReq],
-        , NC.queryString = HT.renderQuery False $ ariQueryParams aReq
+          NC.requestHeaders = ariHeaders aReq,
-        , NC.requestBody = getRequestBody (ariPayload aReq)
+          NC.queryString = HT.renderQuery False $ ariQueryParams aReq,
+          NC.requestBody = getRequestBody (ariPayload aReq)
         }

src/Network/Minio/CopyObject.hs

@@ -17,18 +17,18 @@
 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
+copyObjectInternal ::
-                   -> Minio ETag
+  Bucket ->
+  Object ->
+  SourceInfo ->
+  Minio ETag
 copyObjectInternal b' o srcInfo = do
   let sBucket = srcBucket srcInfo
       sObject = srcObject srcInfo
@@ -43,27 +43,35 @@ copyObjectInternal b' o srcInfo = do
       startOffset = fst range
       endOffset = snd range
 
-  when (isJust rangeMay &&
+  when
-        or [startOffset < 0, endOffset < startOffset,
+    ( isJust rangeMay
-            endOffset >= fromIntegral srcSize]) $
+        && or
-    throwIO $ MErrVInvalidSrcObjByteRange range
+          [ startOffset < 0,
+            endOffset < startOffset,
+            endOffset >= fromIntegral 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 ) $
+  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 $
+selectCopyRanges (st, end) =
-  map (\(x, y) -> (st + x, st + x + y - 1)) $ zip startOffsets partSizes
+  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
@@ -71,18 +79,26 @@ selectCopyRanges (st, end) = zip pns $
 -- | 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
+multiPartCopyObject ::
-                    -> Minio ETag
+  Bucket ->
+  Object ->
+  SourceInfo ->
+  Int64 ->
+  Minio ETag
 multiPartCopyObject b o cps srcSize = do
   uid <- newMultipartUpload b o []
 
   let byteRange = maybe (0, fromIntegral $ srcSize - 1) identity $ srcRange cps
       partRanges = selectCopyRanges byteRange
-      partSources = map (\(x, (start, end)) -> (x, cps {srcRange = Just (start, end) }))
+      partSources =
+        map
+          (\(x, (start, end)) -> (x, cps {srcRange = Just (start, end)}))
           partRanges
       dstInfo = defaultDestinationInfo {dstBucket = b, dstObject = o}
 
-  copiedParts <- limitedMapConcurrently 10
+  copiedParts <-
+    limitedMapConcurrently
+      10
       ( \(pn, cps') -> do
           (etag, _) <- copyObjectPart dstInfo cps' uid pn []
           return (pn, etag)

src/Network/Minio/Data/ByteString.hs

@@ -13,23 +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, isAsciiUpper, isAsciiLower, isDigit)
+import Data.Char (isAsciiLower, isAsciiUpper)
 import qualified Data.Text as T
-import           Numeric (showHex)
-
 import Lib.Prelude
+import Numeric (showHex)
 
 stripBS :: ByteString -> ByteString
 stripBS = BC8.dropWhile isSpace . fst . BC8.spanEnd isSpace
@@ -64,7 +63,8 @@ uriEncodeChar 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

src/Network/Minio/Data/Crypto.hs

@@ -15,30 +15,30 @@
 --
 
 module Network.Minio.Data.Crypto
-  (
+  ( hashSHA256,
-    hashSHA256
+    hashSHA256FromSource,
-  , hashSHA256FromSource
+    hashMD5,
+    hashMD5ToBase64,
+    hashMD5FromSource,
+    hmacSHA256,
+    hmacSHA256RawBS,
+    digestToBS,
+    digestToBase16,
+    encodeToBase64,
+  )
+where
 
-  , hashMD5
+import Crypto.Hash
-  , hashMD5ToBase64
+  ( Digest,
-  , hashMD5FromSource
+    MD5 (..),
-
+    SHA256 (..),
-  , hmacSHA256
+    hashWith,
-  , hmacSHA256RawBS
+  )
-  , digestToBS
-  , digestToBase16
-
-  , encodeToBase64
-  ) where
-
-import           Crypto.Hash             (Digest, MD5 (..), SHA256 (..),
-                                          hashWith)
 import Crypto.Hash.Conduit (sinkHash)
 import Crypto.MAC.HMAC (HMAC, hmac)
 import Data.ByteArray (ByteArrayAccess, convert)
 import Data.ByteArray.Encoding (Base (Base16, Base64), convertToBase)
 import qualified Data.Conduit as C
-
 import Lib.Prelude
 
 hashSHA256 :: ByteString -> ByteString

src/Network/Minio/Data/Time.hs

@@ -15,19 +15,17 @@
 --
 
 module Network.Minio.Data.Time
-  (
+  ( awsTimeFormat,
-    awsTimeFormat
+    awsTimeFormatBS,
-  , awsTimeFormatBS
+    awsDateFormat,
-  , awsDateFormat
+    awsDateFormatBS,
-  , awsDateFormatBS
+    awsParseTime,
-  , awsParseTime
+    iso8601TimeFormat,
-  , iso8601TimeFormat
+  )
-  ) where
+where
-
 
 import Data.ByteString.Char8 (pack)
 import qualified Data.Time as Time
-
 import Lib.Prelude
 
 awsTimeFormat :: UTCTime -> [Char]

src/Network/Minio/Errors.hs

@@ -17,16 +17,16 @@
 module Network.Minio.Errors where
 
 import Control.Exception
-import qualified Network.HTTP.Conduit as NC
-
 import Lib.Prelude
-
+import qualified Network.HTTP.Conduit as NC
 
 ---------------------------------
 -- Errors
 ---------------------------------
+
 -- | Various validation errors
-data MErrV = MErrVSinglePUTSizeExceeded Int64
+data MErrV
+  = MErrVSinglePUTSizeExceeded Int64
   | MErrVPutSizeExceeded Int64
   | MErrVETagHeaderNotFound
   | MErrVInvalidObjectInfoResponse
@@ -49,7 +49,8 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64
 instance Exception MErrV
 
 -- | Errors returned by S3 compatible service
-data ServiceErr = BucketAlreadyExists
+data ServiceErr
+  = BucketAlreadyExists
   | BucketAlreadyOwnedByYou
   | NoSuchBucket
   | InvalidBucketName
@@ -68,9 +69,9 @@ 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

src/Network/Minio/JsonParser.hs

@@ -15,23 +15,30 @@
 --
 
 module Network.Minio.JsonParser
-  (
+  ( parseErrResponseJSON,
-    parseErrResponseJSON
+  )
-  ) where
+where
 
-import           Data.Aeson           (FromJSON, eitherDecode, parseJSON,
+import Data.Aeson
-                                       withObject, (.:))
+  ( (.:),
+    FromJSON,
+    eitherDecode,
+    parseJSON,
+    withObject,
+  )
 import qualified Data.Text as T
-
 import Lib.Prelude
-
 import Network.Minio.Errors
 
-data AdminErrJSON = AdminErrJSON { aeCode    :: Text
+data AdminErrJSON = AdminErrJSON
-                                 , aeMessage :: Text
+  { aeCode :: Text,
-                                 } deriving (Eq, Show)
+    aeMessage :: Text
+  }
+  deriving (Eq, Show)
+
 instance FromJSON AdminErrJSON where
-  parseJSON = withObject "AdminErrJSON" $ \v -> AdminErrJSON
+  parseJSON = withObject "AdminErrJSON" $ \v ->
+    AdminErrJSON
       <$> v .: "Code"
       <*> v .: "Message"
 

src/Network/Minio/ListOps.hs

@@ -19,15 +19,14 @@ 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
 import Network.Minio.S3API
 
 -- | Represents a list output item - either an object or an object
 -- prefix (i.e. a directory).
-data ListItem = ListItemObject ObjectInfo
+data ListItem
+  = ListItemObject ObjectInfo
   | ListItemPrefix Text
   deriving (Show, Eq)
 
@@ -48,72 +47,98 @@ listObjects bucket prefix recurse = loop Nothing
   where
     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 Nothing
       CL.sourceList $ map ListItemObject $ lorObjects res
-      unless recurse $
+      unless recurse
-        CL.sourceList $ map ListItemPrefix $ lorCPrefixes res
+        $ 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
+listObjectsV1 ::
-              -> C.ConduitM () ListItem Minio ()
+  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
+      let delimiter = bool (Just "/") Nothing recurse
-        delimiter = bool (Just "/") Nothing recurse
 
       res <- lift $ listObjectsV1' bucket prefix nextMarker delimiter Nothing
       CL.sourceList $ map ListItemObject $ lorObjects' res
-      unless recurse $
+      unless recurse
-        CL.sourceList $ map ListItemPrefix $ lorCPrefixes' res
+        $ 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.ConduitM () UploadInfo Minio ()
+  Bucket ->
+  Maybe Text ->
+  Bool ->
+  C.ConduitM () UploadInfo Minio ()
 listIncompleteUploads bucket prefix recurse = loop Nothing Nothing
   where
     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 Nothing
+        lift $
+          listIncompleteUploads'
+            bucket
+            prefix
+            delimiter
+            nextKeyMarker
+            nextUploadIdMarker
+            Nothing
 
       aggrSizes <- lift $ forM (lurUploads res) $ \(uKey, uId, _) -> do
-            partInfos <- C.runConduit $ listIncompleteParts bucket uKey uId
+        partInfos <-
+          C.runConduit $
+            listIncompleteParts bucket uKey uId
               C..| CC.sinkList
         return $ foldl (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos
 
-      CL.sourceList $
+      CL.sourceList
-        map (\((uKey, uId, uInitTime), size) ->
+        $ map
+          ( \((uKey, uId, uInitTime), size) ->
               UploadInfo uKey uId uInitTime size
-            ) $ zip (lurUploads res) aggrSizes
+          )
+        $ zip (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.ConduitM () ObjectPartInfo Minio ()
+  Bucket ->
+  Object ->
+  UploadId ->
+  C.ConduitM () ObjectPartInfo Minio ()
 listIncompleteParts bucket object uploadId = loop Nothing
   where
     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

@@ -15,26 +15,25 @@
 --
 
 module Network.Minio.PresignedOperations
-  ( UrlExpiry
+  ( UrlExpiry,
-  , makePresignedUrl
+    makePresignedUrl,
-  , presignedPutObjectUrl
+    presignedPutObjectUrl,
-  , presignedGetObjectUrl
+    presignedGetObjectUrl,
-  , presignedHeadObjectUrl
+    presignedHeadObjectUrl,
-
+    PostPolicyCondition (..),
-  , PostPolicyCondition(..)
+    ppCondBucket,
-  , ppCondBucket
+    ppCondContentLengthRange,
-  , ppCondContentLengthRange
+    ppCondContentType,
-  , ppCondContentType
+    ppCondKey,
-  , ppCondKey
+    ppCondKeyStartsWith,
-  , ppCondKeyStartsWith
+    ppCondSuccessActionStatus,
-  , ppCondSuccessActionStatus
+    PostPolicy (..),
-
+    PostPolicyError (..),
-  , PostPolicy(..)
+    newPostPolicy,
-  , PostPolicyError(..)
+    showPostPolicy,
-  , newPostPolicy
+    presignedPostPolicy,
-  , showPostPolicy
+  )
-  , presignedPostPolicy
+where
-  ) where
 
 import Data.Aeson ((.=))
 import qualified Data.Aeson as Json
@@ -42,12 +41,10 @@ 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.Conduit as NC
 import qualified Network.HTTP.Types as HT
 import Network.HTTP.Types.Header (hHost)
-
-import           Lib.Prelude
-
 import Network.Minio.Data
 import Network.Minio.Data.Time
 import Network.Minio.Errors
@@ -61,39 +58,53 @@ import           Network.Minio.Sign.V4
 --
 -- 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
+makePresignedUrl ::
-                 -> Maybe Region -> HT.Query -> HT.RequestHeaders
+  UrlExpiry ->
-                 -> Minio ByteString
+  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) $
+  when (expiry > 7 * 24 * 3600 || expiry < 0)
-    throwIO $ MErrVInvalidUrlExpiry expiry
+    $ throwIO
+    $ MErrVInvalidUrlExpiry expiry
 
   ci <- asks mcConnInfo
 
-  let
+  let hostHeader = (hHost, getHostAddr ci)
-    hostHeader = (hHost, getHostAddr ci)
+      req =
-    req = NC.defaultRequest {
+        NC.defaultRequest
-          NC.method = method
+          { NC.method = method,
-        , NC.secure = connectIsSecure ci
+            NC.secure = connectIsSecure ci,
-        , NC.host = encodeUtf8 $ connectHost ci
+            NC.host = encodeUtf8 $ connectHost ci,
-        , NC.port = connectPort ci
+            NC.port = connectPort ci,
-        , NC.path = getS3Path bucket object
+            NC.path = getS3Path bucket object,
-        , NC.requestHeaders = hostHeader : extraHeaders
+            NC.requestHeaders = hostHeader : extraHeaders,
-        , NC.queryString = HT.renderQuery True extraQuery
+            NC.queryString = HT.renderQuery True extraQuery
           }
   ts <- liftIO Time.getCurrentTime
 
-  let sp = SignParams (connectAccessKey ci) (connectSecretKey ci)
+  let sp =
-           ts region (Just expiry) Nothing
+        SignParams
-
+          (connectAccessKey ci)
+          (connectSecretKey ci)
+          ts
+          region
+          (Just expiry)
+          Nothing
       signPairs = signV4 sp req
-
       qpToAdd = (fmap . fmap) Just signPairs
-      queryStr = HT.renderQueryBuilder True
+      queryStr =
+        HT.renderQueryBuilder
+          True
           ((HT.parseQuery $ NC.queryString req) ++ qpToAdd)
       scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
 
-  return $ toS $ toLazyByteString $ scheme
+  return $ toStrictBS $ toLazyByteString $
+    scheme
       <> byteString (getHostAddr ci)
       <> byteString (getS3Path bucket object)
       <> queryStr
@@ -105,12 +116,22 @@ makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do
 --
 -- 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
+presignedPutObjectUrl ::
-                      -> Minio ByteString
+  Bucket ->
+  Object ->
+  UrlExpiry ->
+  HT.RequestHeaders ->
+  Minio ByteString
 presignedPutObjectUrl bucket object expirySeconds extraHeaders = do
   region <- asks (Just . connectRegion . mcConnInfo)
-  makePresignedUrl expirySeconds HT.methodPut
+  makePresignedUrl
-      (Just bucket) (Just object) region [] extraHeaders
+    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
@@ -121,12 +142,23 @@ presignedPutObjectUrl bucket object expirySeconds extraHeaders = do
 --
 -- 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
+presignedGetObjectUrl ::
-                      -> HT.RequestHeaders -> Minio ByteString
+  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
+  makePresignedUrl
-      (Just bucket) (Just object) region extraQuery extraHeaders
+    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
@@ -135,15 +167,26 @@ presignedGetObjectUrl bucket object expirySeconds extraQuery extraHeaders = do
 --
 -- For a list of possible headers to pass, please refer to the HEAD
 -- object REST API AWS S3 documentation.
-presignedHeadObjectUrl :: Bucket -> Object -> UrlExpiry
+presignedHeadObjectUrl ::
-                       -> HT.RequestHeaders -> Minio ByteString
+  Bucket ->
+  Object ->
+  UrlExpiry ->
+  HT.RequestHeaders ->
+  Minio ByteString
 presignedHeadObjectUrl bucket object expirySeconds extraHeaders = do
   region <- asks (Just . connectRegion . mcConnInfo)
-  makePresignedUrl expirySeconds HT.methodHead
+  makePresignedUrl
-      (Just bucket) (Just object) region [] extraHeaders
+    expirySeconds
+    HT.methodHead
+    (Just bucket)
+    (Just object)
+    region
+    []
+    extraHeaders
 
 -- | Represents individual conditions in a Post Policy document.
-data PostPolicyCondition = PPCStartsWith Text Text
+data PostPolicyCondition
+  = PPCStartsWith Text Text
   | PPCEquals Text Text
   | PPCRange Text Int64 Int64
   deriving (Show, Eq)
@@ -160,21 +203,24 @@ instance Json.ToJSON PostPolicyCondition where
     Json.foldable [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal]
 
 -- | A PostPolicy is required to perform uploads via browser forms.
-data PostPolicy = PostPolicy {
+data PostPolicy = PostPolicy
-    expiration :: UTCTime
+  { expiration :: UTCTime,
-  , conditions :: [PostPolicyCondition]
+    conditions :: [PostPolicyCondition]
-  } deriving (Show, Eq)
+  }
+  deriving (Show, Eq)
 
 instance Json.ToJSON PostPolicy where
   toJSON (PostPolicy e c) =
-    Json.object $ [ "expiration" .= iso8601TimeFormat e
+    Json.object $
-                  , "conditions" .= c
+      [ "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
+data PostPolicyError
+  = PPEKeyNotSpecified
   | PPEBucketNotSpecified
   | PPEConditionKeyEmpty
   | PPERangeInvalid
@@ -186,8 +232,10 @@ ppCondBucket = PPCEquals "bucket"
 
 -- | Set the content length range constraint with minimum and maximum
 -- byte count values.
-ppCondContentLengthRange :: Int64 -> Int64
+ppCondContentLengthRange ::
-                         -> PostPolicyCondition
+  Int64 ->
+  Int64 ->
+  PostPolicyCondition
 ppCondContentLengthRange = PPCRange "content-length-range"
 
 -- | Set the content-type header for the upload.
@@ -210,83 +258,91 @@ ppCondSuccessActionStatus n =
 
 -- | This function creates a PostPolicy after validating its
 -- arguments.
-newPostPolicy :: UTCTime -> [PostPolicyCondition]
+newPostPolicy ::
-              -> Either PostPolicyError PostPolicy
+  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 = toS . Json.encode
+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
+presignedPostPolicy ::
-                    -> Minio (ByteString, H.HashMap Text ByteString)
+  PostPolicy ->
+  Minio (ByteString, H.HashMap Text ByteString)
 presignedPostPolicy p = do
   ci <- asks mcConnInfo
   signTime <- liftIO $ Time.getCurrentTime
 
-  let
+  let extraConditions =
-    extraConditions =
+        [ PPCEquals "x-amz-date" (toS $ awsTimeFormat signTime),
-      [ PPCEquals "x-amz-date" (toS $ awsTimeFormat signTime)
+          PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256",
-      , PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256"
+          PPCEquals
-      , PPCEquals "x-amz-credential"
+            "x-amz-credential"
-        (T.intercalate "/" [connectAccessKey ci,
+            ( T.intercalate
-                            decodeUtf8 $ mkScope signTime region])
+                "/"
+                [ connectAccessKey ci,
+                  decodeUtf8 $ mkScope signTime region
                 ]
-    ppWithCreds = p {
+            )
-      conditions = conditions p ++ extraConditions
+        ]
+      ppWithCreds =
+        p
+          { conditions = conditions p ++ extraConditions
           }
-    sp = SignParams (connectAccessKey ci) (connectSecretKey ci)
+      sp =
-         signTime (Just $ connectRegion ci) Nothing Nothing
+        SignParams
+          (connectAccessKey ci)
+          (connectSecretKey ci)
+          signTime
+          (Just $ connectRegion ci)
+          Nothing
+          Nothing
       signData = signV4PostPolicy (showPostPolicy ppWithCreds) sp
-
-
       -- compute form-data
       mkPair (PPCStartsWith k v) = Just (k, v)
       mkPair (PPCEquals k v) = Just (k, v)
       mkPair _ = Nothing
-    formFromPolicy = H.map toS $ H.fromList $ catMaybes $
+      formFromPolicy =
+        H.map toUtf8 $ H.fromList $ catMaybes $
           mkPair <$> conditions ppWithCreds
       formData = formFromPolicy `H.union` signData
-
       -- compute POST upload URL
       bucket = H.lookupDefault "" "bucket" formData
       scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci
       region = connectRegion ci
-
+      url =
-    url = toS $ toLazyByteString $ scheme <> byteString (getHostAddr ci) <>
+        toStrictBS $ toLazyByteString $
-          byteString "/" <> byteString (toS bucket) <> byteString "/"
+          scheme <> byteString (getHostAddr ci)
+            <> byteString "/"
+            <> byteString bucket
+            <> byteString "/"
 
   return (url, formData)

src/Network/Minio/PutObject.hs

@@ -15,12 +15,11 @@
 --
 
 module Network.Minio.PutObject
-  (
+  ( putObjectInternal,
-    putObjectInternal
+    ObjectData (..),
-  , ObjectData(..)
+    selectPartSizes,
-  , selectPartSizes
+  )
-  ) where
+where
-
 
 import Conduit (takeC)
 import qualified Conduit as C
@@ -29,16 +28,12 @@ import qualified Data.Conduit.Binary      as CB
 import qualified Data.Conduit.Combinators as CC
 import qualified Data.Conduit.List as CL
 import qualified Data.List as List
-
-
 import Lib.Prelude
-
 import Network.Minio.Data
 import Network.Minio.Errors
 import Network.Minio.S3API
 import Network.Minio.Utils
 
-
 -- | A data-type to represent the source data for an object. A
 -- file-path or a producer-conduit may be provided.
 --
@@ -50,36 +45,44 @@ import           Network.Minio.Utils
 -- the input - if it is not provided, upload will continue until the
 -- stream ends or the object reaches `maxObjectSize` size.
 data ObjectData m
-  = ODFile FilePath (Maybe Int64) -- ^ Takes filepath and optional
+  = -- | Takes filepath and optional
     -- size.
-  | ODStream (C.ConduitM () ByteString m ()) (Maybe Int64) -- ^ Pass
+    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 -> PutObjectOptions
+putObjectInternal ::
-                  -> ObjectData Minio -> Minio ETag
+  Bucket ->
+  Object ->
+  PutObjectOptions ->
+  ObjectData Minio ->
+  Minio ETag
 putObjectInternal b o opts (ODStream src sizeMay) = do
   case sizeMay of
     -- unable to get size, so assume non-seekable file
     Nothing -> sequentialMultipartUpload b o opts Nothing src
-
     -- got file size, so check for single/multipart upload
     Just size ->
-      if | size <= 64 * oneMiB -> do
+      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)
 
-  (isSeekable, handleSizeMay) <- either (const $ return (False, Nothing)) return
+  (isSeekable, handleSizeMay) <-
+    either
+      (const $ return (False, Nothing))
+      return
       hResE
 
   -- prefer given size to queried size.
@@ -88,18 +91,25 @@ putObjectInternal b o opts (ODFile fp sizeMay) = do
   case finalSizeMay of
     -- unable to get size, so assume non-seekable file
     Nothing -> sequentialMultipartUpload b o opts Nothing $ CB.sourceFile fp
-
     -- got file size, so check for single/multipart upload
     Just size ->
-      if | size <= 64 * oneMiB -> either throwIO return =<<
+      if
-           withNewHandle fp (\h -> putObjectSingle b o (pooToHeaders opts) h 0 size)
+          | size <= 64 * oneMiB ->
+            either throwIO return
+              =<< withNewHandle fp (\h -> putObjectSingle b o (pooToHeaders opts) h 0 size)
           | size > maxObjectSize -> throwIO $ MErrVPutSizeExceeded size
           | isSeekable -> parallelMultipartUpload b o opts fp size
-         | otherwise -> sequentialMultipartUpload b o opts (Just size) $
+          | otherwise ->
+            sequentialMultipartUpload b o opts (Just size) $
               CB.sourceFile fp
 
-parallelMultipartUpload :: Bucket -> Object -> PutObjectOptions
+parallelMultipartUpload ::
-                        -> FilePath -> Int64 -> Minio ETag
+  Bucket ->
+  Object ->
+  PutObjectOptions ->
+  FilePath ->
+  Int64 ->
+  Minio ETag
 parallelMultipartUpload b o opts filePath size = do
   -- get a new upload id.
   uploadId <- newMultipartUpload b o (pooToHeaders opts)
@@ -109,15 +119,17 @@ parallelMultipartUpload b o opts filePath size = do
   let threads = fromMaybe 10 $ pooNumThreads opts
 
   -- perform upload with 'threads' threads
-  uploadedPartsE <- limitedMapConcurrently (fromIntegral threads)
+  uploadedPartsE <-
-                    (uploadPart uploadId) partSizeInfo
+    limitedMapConcurrently
+      (fromIntegral threads)
+      (uploadPart uploadId)
+      partSizeInfo
 
   -- if there were any errors, rethrow exception.
   mapM_ throwIO $ lefts uploadedPartsE
 
   -- if we get here, all parts were successfully uploaded.
   completeMultipartUpload b o uploadId $ rights uploadedPartsE
-
   where
     uploadPart uploadId (partNum, offset, sz) =
       withNewHandle filePath $ \h -> do
@@ -125,10 +137,13 @@ parallelMultipartUpload b o opts filePath size = do
         putObjectPart b o uploadId partNum [] payload
 
 -- | Upload multipart object from conduit source sequentially
-sequentialMultipartUpload :: Bucket -> Object -> PutObjectOptions
+sequentialMultipartUpload ::
-                          -> Maybe Int64
+  Bucket ->
-                          -> C.ConduitM () ByteString Minio ()
+  Object ->
-                          -> Minio ETag
+  PutObjectOptions ->
+  Maybe Int64 ->
+  C.ConduitM () ByteString Minio () ->
+  Minio ETag
 sequentialMultipartUpload b o opts sizeMay src = do
   -- get a new upload id.
   uploadId <- newMultipartUpload b o (pooToHeaders opts)
@@ -136,8 +151,9 @@ sequentialMultipartUpload b o opts sizeMay src = do
   -- upload parts in loop
   let partSizes = selectPartSizes $ maybe maxObjectSize identity sizeMay
       (pnums, _, sizes) = List.unzip3 partSizes
-  uploadedParts <- C.runConduit
+  uploadedParts <-
-                 $ src
+    C.runConduit $
+      src
         C..| chunkBSConduit (map fromIntegral sizes)
         C..| CL.map PayloadBS
         C..| uploadPart' uploadId pnums
@@ -145,13 +161,13 @@ sequentialMultipartUpload b o opts sizeMay src = do
 
   -- complete multipart upload
   completeMultipartUpload b o uploadId uploadedParts
-
   where
     uploadPart' _ [] = return ()
     uploadPart' uid (pn : pns) = do
       payloadMay <- C.await
       case payloadMay of
         Nothing -> return ()
-        Just payload -> do pinfo <- lift $ putObjectPart b o uid pn [] payload
+        Just payload -> do
+          pinfo <- lift $ putObjectPart b o uid pn [] payload
           C.yield pinfo
           uploadPart' uid pns

src/Network/Minio/S3API.hs

@@ -15,91 +15,88 @@
 --
 
 module Network.Minio.S3API
-  (
+  ( Region,
-    Region
+    getLocation,
-  , getLocation
 
     -- * Listing buckets
     --------------------
-  , getService
+    getService,
 
     -- * Listing objects
     --------------------
-  , ListObjectsResult(..)
+    ListObjectsResult (..),
-  , ListObjectsV1Result(..)
+    ListObjectsV1Result (..),
-  , listObjects'
+    listObjects',
-  , listObjectsV1'
+    listObjectsV1',
 
     -- * Retrieving buckets
-  , headBucket
+    headBucket,
 
     -- * Retrieving objects
     -----------------------
-  , getObject'
+    getObject',
-  , headObject
+    headObject,
 
     -- * Creating buckets and objects
     ---------------------------------
-  , putBucket
+    putBucket,
-  , ETag
+    ETag,
-  , maxSinglePutObjectSizeBytes
+    maxSinglePutObjectSizeBytes,
-  , putObjectSingle'
+    putObjectSingle',
-  , putObjectSingle
+    putObjectSingle,
-  , copyObjectSingle
+    copyObjectSingle,
 
     -- * Multipart Upload APIs
     --------------------------
-  , UploadId
+    UploadId,
-  , PartTuple
+    PartTuple,
-  , Payload(..)
+    Payload (..),
-  , PartNumber
+    PartNumber,
-  , newMultipartUpload
+    newMultipartUpload,
-  , putObjectPart
+    putObjectPart,
-  , copyObjectPart
+    copyObjectPart,
-  , completeMultipartUpload
+    completeMultipartUpload,
-  , abortMultipartUpload
+    abortMultipartUpload,
-  , ListUploadsResult(..)
+    ListUploadsResult (..),
-  , listIncompleteUploads'
+    listIncompleteUploads',
-  , ListPartsResult(..)
+    ListPartsResult (..),
-  , listIncompleteParts'
+    listIncompleteParts',
 
     -- * Deletion APIs
     --------------------------
-  , deleteBucket
+    deleteBucket,
-  , deleteObject
+    deleteObject,
 
     -- * Presigned Operations
     -----------------------------
-  , module Network.Minio.PresignedOperations
+    module Network.Minio.PresignedOperations,
 
     -- ** Bucket Policies
-  , getBucketPolicy
+    getBucketPolicy,
-  , setBucketPolicy
+    setBucketPolicy,
 
     -- * Bucket Notifications
     -------------------------
-  , Notification(..)
+    Notification (..),
-  , NotificationConfig(..)
+    NotificationConfig (..),
-  , Arn
+    Arn,
-  , Event(..)
+    Event (..),
-  , Filter(..)
+    Filter (..),
-  , FilterKey(..)
+    FilterKey (..),
-  , FilterRules(..)
+    FilterRules (..),
-  , FilterRule(..)
+    FilterRule (..),
-  , getBucketNotification
+    getBucketNotification,
-  , putBucketNotification
+    putBucketNotification,
-  , removeAllBucketNotification
+    removeAllBucketNotification,
-  ) where
+  )
+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           UnliftIO                          (Handler (Handler))
-
-import           Lib.Prelude
-
 import Network.Minio.API
 import Network.Minio.APICommon
 import Network.Minio.Data
@@ -108,12 +105,15 @@ 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 $ defaultS3ReqInfo {
+  resp <-
-      riNeedsLocation = False
+    executeRequest $
+      defaultS3ReqInfo
+        { riNeedsLocation = False
         }
   parseListBuckets $ NC.responseBody resp
 
@@ -132,21 +132,32 @@ parseGetObjectHeaders object headers =
 
 -- | 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]
+getObject' ::
-           -> Minio GetObjectResponse
+  Bucket ->
+  Object ->
+  HT.Query ->
+  [HT.Header] ->
+  Minio GetObjectResponse
 getObject' bucket object queryParams headers = do
   resp <- mkStreamRequest reqInfo
   let objInfoMaybe = parseGetObjectHeaders object $ NC.responseHeaders resp
-    objInfo <- maybe (throwIO MErrVInvalidObjectInfoResponse) return
+  objInfo <-
+    maybe
+      (throwIO MErrVInvalidObjectInfoResponse)
+      return
       objInfoMaybe
-    return $ GetObjectResponse { gorObjectInfo = objInfo
+  return $
-                               , gorObjectStream = NC.responseBody resp
+    GetObjectResponse
+      { gorObjectInfo = objInfo,
+        gorObjectStream = NC.responseBody resp
       }
   where
-    reqInfo = defaultS3ReqInfo { riBucket = Just bucket
+    reqInfo =
-                               , riObject = Just object
+      defaultS3ReqInfo
-                               , riQueryParams = queryParams
+        { riBucket = Just bucket,
-                               , riHeaders = headers
+          riObject = Just object,
+          riQueryParams = queryParams,
+          riHeaders = headers
         }
 
 -- | Creates a bucket via a PUT bucket call.
@@ -154,10 +165,11 @@ putBucket :: Bucket -> Region -> Minio ()
 putBucket bucket location = do
   ns <- asks getSvcNamespace
   void $ executeRequest $
-    defaultS3ReqInfo { riMethod = HT.methodPut
+    defaultS3ReqInfo
-        , riBucket = Just bucket
+      { riMethod = HT.methodPut,
-        , riPayload = PayloadBS $ mkCreateBucketConfig ns location
+        riBucket = Just bucket,
-        , riNeedsLocation = False
+        riPayload = PayloadBS $ mkCreateBucketConfig ns location,
+        riNeedsLocation = False
       }
 
 -- | Single PUT object size.
@@ -172,204 +184,286 @@ 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) $
+  when (size > maxSinglePutObjectSizeBytes)
-    throwIO $ MErrVSinglePUTSizeExceeded size
+    $ throwIO
+    $ MErrVSinglePUTSizeExceeded size
 
   let payload = mkStreamingPayload $ PayloadBS bs
-  resp <- executeRequest $
+  resp <-
-          defaultS3ReqInfo { riMethod = HT.methodPut
+    executeRequest $
-              , riBucket = Just bucket
+      defaultS3ReqInfo
-              , riObject = Just object
+        { riMethod = HT.methodPut,
-              , riHeaders = headers
+          riBucket = Just bucket,
-              , riPayload = payload
+          riObject = Just object,
+          riHeaders = headers,
+          riPayload = payload
         }
 
   let rheaders = NC.responseHeaders resp
       etag = getETagHeader rheaders
   maybe
     (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
+putObjectSingle ::
-                -> Int64 -> Minio ETag
+  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) $
+  when (size > maxSinglePutObjectSizeBytes)
-    throwIO $ MErrVSinglePUTSizeExceeded size
+    $ throwIO
+    $ MErrVSinglePUTSizeExceeded size
 
   -- content-length header is automatically set by library.
   let payload = mkStreamingPayload $ PayloadH h offset size
-  resp <- executeRequest $
+  resp <-
-          defaultS3ReqInfo { riMethod = HT.methodPut
+    executeRequest $
-                           , riBucket = Just bucket
+      defaultS3ReqInfo
-                           , riObject = Just object
+        { riMethod = HT.methodPut,
-                           , riHeaders = headers
+          riBucket = Just bucket,
-                           , riPayload = payload
+          riObject = Just object,
+          riHeaders = headers,
+          riPayload = payload
         }
 
   let rheaders = NC.responseHeaders resp
       etag = getETagHeader rheaders
   maybe
     (throwIO MErrVETagHeaderNotFound)
-    return etag
+    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
+listObjectsV1' ::
-            -> Minio ListObjectsV1Result
+  Bucket ->
+  Maybe Text ->
+  Maybe Text ->
+  Maybe Text ->
+  Maybe Int ->
+  Minio ListObjectsV1Result
 listObjectsV1' bucket prefix nextMarker delimiter maxKeys = do
-  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet
+  resp <-
-                               , riBucket = Just bucket
+    executeRequest $
-                               , riQueryParams = mkOptionalParams params
+      defaultS3ReqInfo
+        { riMethod = HT.methodGet,
+          riBucket = Just bucket,
+          riQueryParams = mkOptionalParams params
         }
   parseListObjectsV1Response $ NC.responseBody resp
   where
-    params = [
+    params =
-        ("marker", nextMarker)
+      [ ("marker", nextMarker),
-      , ("prefix", prefix)
+        ("prefix", prefix),
-      , ("delimiter", delimiter)
+        ("delimiter", delimiter),
-      , ("max-keys", show <$> maxKeys)
+        ("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 -> Maybe Int
+listObjects' ::
-            -> Minio ListObjectsResult
+  Bucket ->
+  Maybe Text ->
+  Maybe Text ->
+  Maybe Text ->
+  Maybe Int ->
+  Minio ListObjectsResult
 listObjects' bucket prefix nextToken delimiter maxKeys = do
-  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet
+  resp <-
-                               , riBucket = Just bucket
+    executeRequest $
-                               , riQueryParams = mkOptionalParams params
+      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)
+        ("max-keys", show <$> maxKeys)
       ]
 
 -- | DELETE a bucket from the service.
 deleteBucket :: Bucket -> Minio ()
-deleteBucket bucket = void $
+deleteBucket bucket =
-  executeRequest $
+  void
-    defaultS3ReqInfo { 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 = void $
+deleteObject bucket object =
-  executeRequest $
+  void
-    defaultS3ReqInfo { 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 $ defaultS3ReqInfo { 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
   -- transform payload to conduit to enable streaming signature
   let payload' = mkStreamingPayload payload
-  resp <- executeRequest $
+  resp <-
-          defaultS3ReqInfo { riMethod = HT.methodPut
+    executeRequest $
-                           , riBucket = Just bucket
+      defaultS3ReqInfo
-                           , riObject = Just object
+        { riMethod = HT.methodPut,
-                           , riQueryParams = mkOptionalParams params
+          riBucket = Just bucket,
-                           , riHeaders = headers
+          riObject = Just object,
-                           , riPayload = payload'
+          riQueryParams = mkOptionalParams params,
+          riHeaders = headers,
+          riPayload = payload'
         }
   let rheaders = NC.responseHeaders resp
       etag = getETagHeader rheaders
   maybe
     (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",
+srcInfoToHeaders srcInfo =
-                            toS $ T.concat ["/", srcBucket srcInfo,
+  ( "x-amz-copy-source",
-                                            "/", srcObject srcInfo]
+    toUtf8 $
-                           ) : rangeHdr ++ zip names values
+      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",
+    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"]
+        "x-amz-copy-source-if-modified-since"
-    values = mapMaybe (fmap encodeUtf8 . (srcInfo &))
+      ]
-             [srcIfMatch, srcIfNoneMatch,
+    values =
+      mapMaybe
+        (fmap encodeUtf8 . (srcInfo &))
+        [ srcIfMatch,
+          srcIfNoneMatch,
           fmap formatRFC1123 . srcIfUnmodifiedSince,
-              fmap formatRFC1123 . srcIfModifiedSince]
+          fmap formatRFC1123 . srcIfModifiedSince
-    rangeHdr = maybe [] (\a -> [("x-amz-copy-source-range", HT.renderByteRanges [a])])
+        ]
-               $ toByteRange <$> srcRange srcInfo
+    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 :: DestinationInfo -> SourceInfo -> UploadId
+copyObjectPart ::
-               -> PartNumber -> [HT.Header] -> Minio (ETag, UTCTime)
+  DestinationInfo ->
+  SourceInfo ->
+  UploadId ->
+  PartNumber ->
+  [HT.Header] ->
+  Minio (ETag, UTCTime)
 copyObjectPart dstInfo srcInfo uploadId partNumber headers = do
-  resp <- executeRequest $
+  resp <-
-          defaultS3ReqInfo { riMethod = HT.methodPut
+    executeRequest $
-              , riBucket = Just $ dstBucket dstInfo
+      defaultS3ReqInfo
-              , riObject = Just $ dstObject dstInfo
+        { riMethod = HT.methodPut,
-              , riQueryParams = mkOptionalParams params
+          riBucket = Just $ dstBucket dstInfo,
-              , riHeaders = headers ++ srcInfoToHeaders srcInfo
+          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 -> SourceInfo -> [HT.Header]
+copyObjectSingle ::
-                 -> Minio (ETag, UTCTime)
+  Bucket ->
+  Object ->
+  SourceInfo ->
+  [HT.Header] ->
+  Minio (ETag, UTCTime)
 copyObjectSingle bucket object srcInfo headers = do
   -- validate that srcRange is Nothing for this API.
   when (isJust $ srcRange srcInfo) $
     throwIO MErrVCopyObjSingleNoRangeAccepted
-  resp <- executeRequest $
+  resp <-
-          defaultS3ReqInfo { riMethod = HT.methodPut
+    executeRequest $
-              , riBucket = Just bucket
+      defaultS3ReqInfo
-              , riObject = Just object
+        { riMethod = HT.methodPut,
-              , riHeaders = headers ++ srcInfoToHeaders srcInfo
+          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 <-
-          defaultS3ReqInfo { 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
@@ -378,88 +472,114 @@ completeMultipartUpload bucket object uploadId partTuple = do
 
 -- | Abort a multipart upload.
 abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio ()
-abortMultipartUpload bucket object uploadId = void $
+abortMultipartUpload bucket object uploadId =
-  executeRequest $ defaultS3ReqInfo { 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 -> Maybe Int -> Minio ListUploadsResult
+  Bucket ->
+  Maybe Text ->
+  Maybe Text ->
+  Maybe Text ->
+  Maybe Text ->
+  Maybe Int ->
+  Minio ListUploadsResult
 listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker maxKeys = do
-  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet
+  resp <-
-                               , riBucket = Just bucket
+    executeRequest $
-                               , riQueryParams = params
+      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),
-             , ("max-uploads", show <$> maxKeys)
+            ("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 $ defaultS3ReqInfo { 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 -> [HT.Header] -> Minio ObjectInfo
 headObject bucket object reqHeaders = do
-  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodHead
+  resp <-
-                                            , riBucket = Just bucket
+    executeRequest $
-                                            , riObject = Just object
+      defaultS3ReqInfo
-                                            , riHeaders = reqHeaders
+        { riMethod = HT.methodHead,
+          riBucket = Just bucket,
+          riObject = Just object,
+          riHeaders = reqHeaders
         }
 
-  maybe (throwIO MErrVInvalidObjectInfoResponse) return $
+  maybe (throwIO MErrVInvalidObjectInfoResponse) return
-    parseGetObjectHeaders object $ NC.responseHeaders resp
+    $ parseGetObjectHeaders object
-
+    $ NC.responseHeaders resp
 
 -- | Query the object store if a given bucket exists.
 headBucket :: Bucket -> Minio Bool
-headBucket bucket = headBucketEx `catches`
+headBucket bucket =
-                    [ Handler handleNoSuchBucket
+  headBucketEx
-                    , Handler handleStatus404
+    `catches` [ Handler handleNoSuchBucket,
+                Handler handleStatus404
               ]
-
   where
     handleNoSuchBucket :: ServiceErr -> Minio Bool
-    handleNoSuchBucket e | e == NoSuchBucket = return False
+    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
+      resp <-
-                                   , riBucket = Just bucket
+        executeRequest $
+          defaultS3ReqInfo
+            { riMethod = HT.methodHead,
+              riBucket = Just bucket
             }
       return $ NC.responseStatus resp == HT.ok200
 
@@ -467,19 +587,25 @@ headBucket bucket = headBucketEx `catches`
 putBucketNotification :: Bucket -> Notification -> Minio ()
 putBucketNotification bucket ncfg = do
   ns <- asks getSvcNamespace
-  void $ executeRequest $ defaultS3ReqInfo { riMethod = HT.methodPut
+  void $ executeRequest $
-                              , riBucket = Just bucket
+    defaultS3ReqInfo
-                              , riQueryParams = [("notification", Nothing)]
+      { riMethod = HT.methodPut,
-                              , riPayload = PayloadBS $
+        riBucket = Just bucket,
+        riQueryParams = [("notification", Nothing)],
+        riPayload =
+          PayloadBS $
             mkPutNotificationRequest ns ncfg
       }
 
 -- | Retrieve the notification configuration on a bucket.
 getBucketNotification :: Bucket -> Minio Notification
 getBucketNotification bucket = do
-  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet
+  resp <-
-                               , riBucket = Just bucket
+    executeRequest $
-                               , riQueryParams = [("notification", Nothing)]
+      defaultS3ReqInfo
+        { riMethod = HT.methodGet,
+          riBucket = Just bucket,
+          riQueryParams = [("notification", Nothing)]
         }
   parseNotification $ NC.responseBody resp
 
@@ -490,11 +616,14 @@ 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
+  resp <-
-                               , riBucket = Just bucket
+    executeRequest $
-                               , riQueryParams = [("policy", Nothing)]
+      defaultS3ReqInfo
+        { riMethod = HT.methodGet,
+          riBucket = Just bucket,
+          riQueryParams = [("policy", Nothing)]
         }
-  return $ toS $ NC.responseBody resp
+  return $ decodeUtf8Lenient $ toStrictBS $ NC.responseBody resp
 
 -- | Set a new policy on a bucket.
 -- As a special condition if the policy is empty
@@ -508,16 +637,20 @@ setBucketPolicy bucket policy = do
 -- | Save a new policy on a bucket.
 putBucketPolicy :: Bucket -> Text -> Minio ()
 putBucketPolicy bucket policy = do
-  void $ executeRequest $ defaultS3ReqInfo { riMethod = HT.methodPut
+  void $ executeRequest $
-                              , riBucket = Just bucket
+    defaultS3ReqInfo
-                              , riQueryParams = [("policy", Nothing)]
+      { riMethod = HT.methodPut,
-                              , riPayload = PayloadBS $ encodeUtf8 policy
+        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
+  void $ executeRequest $
-                              , riBucket = Just bucket
+    defaultS3ReqInfo
-                              , riQueryParams = [("policy", Nothing)]
+      { riMethod = HT.methodDelete,
+        riBucket = Just bucket,
+        riQueryParams = [("policy", Nothing)]
       }

src/Network/Minio/SelectAPI.hs

@@ -15,60 +15,51 @@
 --
 
 module Network.Minio.SelectAPI
-  (
+  ( -- | The `selectObjectContent` allows querying CSV, JSON or Parquet
-
-  -- | 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,
-    selectObjectContent
+    SelectRequest,
-
+    selectRequest,
-  , SelectRequest
-  , selectRequest
 
     -- *** Input Serialization
-
+    InputSerialization,
-  , InputSerialization
+    defaultCsvInput,
-  , defaultCsvInput
+    linesJsonInput,
-  , linesJsonInput
+    documentJsonInput,
-  , documentJsonInput
+    defaultParquetInput,
-  , defaultParquetInput
+    setInputCSVProps,
-  , setInputCSVProps
+    CompressionType (..),
-
+    setInputCompressionType,
-  , 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,
-  , CSVProp
+    recordDelimiter,
-  , recordDelimiter
+    fieldDelimiter,
-  , fieldDelimiter
+    quoteCharacter,
-  , quoteCharacter
+    quoteEscapeCharacter,
-  , quoteEscapeCharacter
+    commentCharacter,
-  , commentCharacter
+    allowQuotedRecordDelimiter,
-  , allowQuotedRecordDelimiter
+    FileHeaderInfo (..),
-  , FileHeaderInfo(..)
+    fileHeaderInfo,
-  , fileHeaderInfo
+    QuoteFields (..),
-  , QuoteFields(..)
+    quoteFields,
-  , quoteFields
 
     -- *** Output Serialization
-
+    OutputSerialization,
-  , OutputSerialization
+    defaultCsvOutput,
-  , defaultCsvOutput
+    defaultJsonOutput,
-  , defaultJsonOutput
+    outputCSVFromProps,
-  , outputCSVFromProps
+    outputJSONFromRecordDelimiter,
-  , outputJSONFromRecordDelimiter
 
     -- *** Progress messages
-
+    setRequestProgressEnabled,
-  , setRequestProgressEnabled
 
     -- *** Interpreting Select output
 
@@ -88,12 +79,12 @@ module Network.Minio.SelectAPI
     --
     -- Note that runConduit, the connect operator (.|) and stdoutC are
     -- all from the "conduit" package.
-
+    getPayloadBytes,
-  , getPayloadBytes
+    EventMessage (..),
-  , EventMessage(..)
+    Progress (..),
-  , Progress(..)
+    Stats,
-  , Stats
+  )
-  ) where
+where
 
 import Conduit ((.|))
 import qualified Conduit as C
@@ -101,20 +92,19 @@ 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           UnliftIO                   (MonadUnliftIO)
-
-import           Lib.Prelude
-
 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
+data EventStreamException
+  = ESEPreludeCRCFailed
   | ESEMessageCRCFailed
   | ESEUnexpectedEndOfStream
   | ESEDecodeFail [Char]
@@ -144,8 +134,10 @@ bytesToHeaderName t = case t of
   ":error-message" -> return ErrorMessage
   _ -> throwIO ESEInvalidHeaderType
 
-parseHeaders :: MonadUnliftIO m
+parseHeaders ::
-             => Word32 -> C.ConduitM ByteString a m [MessageHeader]
+  MonadUnliftIO m =>
+  Word32 ->
+  C.ConduitM ByteString a m [MessageHeader]
 parseHeaders 0 = return []
 parseHeaders hdrLen = do
   bs1 <- readNBytes 1
@@ -178,8 +170,9 @@ readNBytes n = do
     then throwIO ESEUnexpectedEndOfStream
     else return b
 
-crcCheck :: MonadUnliftIO m
+crcCheck ::
-         => C.ConduitM ByteString ByteString m ()
+  MonadUnliftIO m =>
+  C.ConduitM ByteString ByteString m ()
 crcCheck = do
   b <- readNBytes 12
   n :: Word32 <- liftIO $ parseBinary $ B.take 4 b
@@ -248,13 +241,10 @@ handleMessage = do
         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
@@ -263,23 +253,28 @@ handleMessage = do
       C.yield $ RecordPayloadEventMessage b
       passThrough $ n - B.length b
 
-
+selectProtoConduit ::
-selectProtoConduit :: MonadUnliftIO m
+  MonadUnliftIO m =>
-                   => C.ConduitT ByteString EventMessage 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
+selectObjectContent ::
-                    -> Minio (C.ConduitT () EventMessage Minio ())
+  Bucket ->
+  Object ->
+  SelectRequest ->
+  Minio (C.ConduitT () EventMessage Minio ())
 selectObjectContent b o r = do
-    let reqInfo = defaultS3ReqInfo { riMethod = HT.methodPost
+  let reqInfo =
-                                   , riBucket = Just b
+        defaultS3ReqInfo
-                                   , riObject = Just o
+          { riMethod = HT.methodPost,
-                                   , riPayload = PayloadBS $ mkSelectRequest r
+            riBucket = Just b,
-                                   , riNeedsLocation = False
+            riObject = Just o,
-                                   , riQueryParams = [("select", Nothing), ("select-type", Just "2")]
+            riPayload = PayloadBS $ mkSelectRequest r,
+            riNeedsLocation = False,
+            riQueryParams = [("select", Nothing), ("select-type", Just "2")]
           }
   --print $ mkSelectRequest r
   resp <- mkStreamRequest reqInfo

src/Network/Minio/Sign/V4.hs

@@ -13,6 +13,7 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
+{-# LANGUAGE BangPatterns #-}
 
 module Network.Minio.Sign.V4 where
 
@@ -20,50 +21,54 @@ import qualified Conduit                       as C
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Lazy as LB
 import Data.CaseInsensitive (mk)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.HashMap.Strict as Map
 import qualified Data.HashSet as Set
 import qualified Data.Time as Time
+import Lib.Prelude
 import qualified Network.HTTP.Conduit as NC
 import Network.HTTP.Types (Header, parseQuery)
 import qualified Network.HTTP.Types as H
-import           Text.Printf                   (printf)
-
-import           Lib.Prelude
-
 import Network.Minio.Data.ByteString
 import Network.Minio.Data.Crypto
 import Network.Minio.Data.Time
 import Network.Minio.Errors
+import Text.Printf (printf)
 
 -- these headers are not included in the string to sign when signing a
 -- request
 ignoredHeaders :: Set.HashSet ByteString
-ignoredHeaders = Set.fromList $ map CI.foldedCase
+ignoredHeaders =
-                 [ H.hAuthorization
+  Set.fromList $
-                 , H.hContentType
+    map
-                 , H.hUserAgent
+      CI.foldedCase
+      [ H.hAuthorization,
+        H.hContentType,
+        H.hUserAgent
       ]
 
-data SignV4Data = SignV4Data {
+data SignV4Data = SignV4Data
-      sv4SignTime         :: UTCTime
+  { sv4SignTime :: UTCTime,
-    , sv4Scope            :: ByteString
+    sv4Scope :: ByteString,
-    , sv4CanonicalRequest :: ByteString
+    sv4CanonicalRequest :: ByteString,
-    , sv4HeadersToSign    :: [(ByteString, ByteString)]
+    sv4HeadersToSign :: [(ByteString, ByteString)],
-    , sv4Output           :: [(ByteString, ByteString)]
+    sv4Output :: [(ByteString, ByteString)],
-    , sv4StringToSign     :: ByteString
+    sv4StringToSign :: ByteString,
-    , sv4SigningKey       :: ByteString
+    sv4SigningKey :: ByteString
-    } deriving (Show)
+  }
+  deriving (Show)
 
-data SignParams = SignParams {
+data SignParams = SignParams
-      spAccessKey   :: Text
+  { spAccessKey :: Text,
-    , spSecretKey   :: Text
+    spSecretKey :: Text,
-    , spTimeStamp   :: UTCTime
+    spTimeStamp :: UTCTime,
-    , spRegion      :: Maybe Text
+    spRegion :: Maybe Text,
-    , spExpirySecs  :: Maybe Int
+    spExpirySecs :: Maybe Int,
-    , spPayloadHash :: Maybe ByteString
+    spPayloadHash :: Maybe ByteString
-    } deriving (Show)
+  }
+  deriving (Show)
 
 debugPrintSignV4Data :: SignV4Data -> IO ()
 debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do
@@ -79,20 +84,21 @@ debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do
   B8.putStrLn "END of SignV4Data ========="
   where
     printBytes b = do
-      mapM_ (\x -> B.putStr $ B.concat [show x,  " "]) $ B.unpack b
+      mapM_ (\x -> B.putStr $ B.singleton x <> " ") $ B.unpack b
       B8.putStrLn ""
 
 mkAuthHeader :: Text -> ByteString -> ByteString -> ByteString -> H.Header
 mkAuthHeader accessKey scope signedHeaderKeys sign =
-    let authValue = B.concat
+  let authValue =
-                    [ "AWS4-HMAC-SHA256 Credential="
+        B.concat
-                    , toS accessKey
+          [ "AWS4-HMAC-SHA256 Credential=",
-                    , "/"
+            toUtf8 accessKey,
-                    , scope
+            "/",
-                    , ", SignedHeaders="
+            scope,
-                    , signedHeaderKeys
+            ", SignedHeaders=",
-                    , ", Signature="
+            signedHeaderKeys,
-                    , sign
+            ", Signature=",
+            sign
           ]
    in (H.hAuthorization, authValue)
 
@@ -110,70 +116,73 @@ mkAuthHeader accessKey scope signedHeaderKeys sign =
 -- the request.
 signV4 :: SignParams -> NC.Request -> [(ByteString, ByteString)]
 signV4 !sp !req =
-  let
+  let region = fromMaybe "" $ spRegion sp
-    region = fromMaybe "" $ spRegion sp
       ts = spTimeStamp sp
       scope = mkScope ts region
-    accessKey = toS $ spAccessKey sp
+      accessKey = toUtf8 $ spAccessKey sp
-    secretKey = toS $ spSecretKey sp
+      secretKey = toUtf8 $ spSecretKey sp
       expiry = spExpirySecs sp
-    sha256Hdr = ("x-amz-content-sha256",
+      sha256Hdr =
-                 fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp)
+        ( "x-amz-content-sha256",
-
+          fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp
+        )
       -- headers to be added to the request
       datePair = ("X-Amz-Date", awsTimeFormatBS ts)
-    computedHeaders = NC.requestHeaders req ++
+      computedHeaders =
-                      if isJust $ expiry
+        NC.requestHeaders req
+          ++ if isJust $ expiry
             then []
             else map (\(x, y) -> (mk x, y)) [datePair, sha256Hdr]
       headersToSign = getHeadersToSign computedHeaders
       signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign
-
       -- query-parameters to be added before signing for presigned URLs
       -- (i.e. when `isJust expiry`)
-    authQP = [ ("X-Amz-Algorithm", "AWS4-HMAC-SHA256")
+      authQP =
-             , ("X-Amz-Credential", B.concat [accessKey, "/", scope])
+        [ ("X-Amz-Algorithm", "AWS4-HMAC-SHA256"),
-             , datePair
+          ("X-Amz-Credential", B.concat [accessKey, "/", scope]),
-             , ("X-Amz-Expires", maybe "" show expiry)
+          datePair,
-             , ("X-Amz-SignedHeaders", signedHeaderKeys)
+          ("X-Amz-Expires", maybe "" showBS expiry),
+          ("X-Amz-SignedHeaders", signedHeaderKeys)
         ]
-    finalQP = parseQuery (NC.queryString req)  ++
+      finalQP =
-              if isJust expiry
+        parseQuery (NC.queryString req)
+          ++ if isJust expiry
             then (fmap . fmap) Just authQP
             else []
-
       -- 1. compute canonical request
-    canonicalRequest = mkCanonicalRequest False sp
+      canonicalRequest =
+        mkCanonicalRequest
+          False
+          sp
           (NC.setQueryString finalQP req)
           headersToSign
-
       -- 2. compute string to sign
       stringToSign = mkStringToSign ts scope canonicalRequest
-
       -- 3.1 compute signing key
       signingKey = mkSigningKey ts region secretKey
-
       -- 3.2 compute signature
       signature = computeSignature stringToSign signingKey
-
       -- 4. compute auth header
       authHeader = mkAuthHeader (spAccessKey sp) scope signedHeaderKeys signature
-
       -- finally compute output pairs
-    output = if isJust expiry
+      output =
+        if isJust expiry
           then ("X-Amz-Signature", signature) : authQP
-             else [(\(x, y) -> (CI.foldedCase x, y)) authHeader,
+          else
-                   datePair, sha256Hdr]
+            [ (\(x, y) -> (CI.foldedCase x, y)) authHeader,
-
+              datePair,
+              sha256Hdr
+            ]
    in output
 
-
 mkScope :: UTCTime -> Text -> ByteString
-mkScope ts region = B.intercalate "/"
+mkScope ts region =
-  [ toS $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts
+  B.intercalate
-  , toS region
+    "/"
-  , "s3"
+    [ toUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts,
-  , "aws4_request"
+      toUtf8 region,
+      "s3",
+      "aws4_request"
     ]
 
 getHeadersToSign :: [Header] -> [(ByteString, ByteString)]
@@ -181,49 +190,56 @@ getHeadersToSign !h =
   filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $
     map (\(x, y) -> (CI.foldedCase x, stripBS y)) h
 
-mkCanonicalRequest :: Bool -> SignParams -> NC.Request -> [(ByteString, ByteString)]
+mkCanonicalRequest ::
-                   -> ByteString
+  Bool ->
+  SignParams ->
+  NC.Request ->
+  [(ByteString, ByteString)] ->
+  ByteString
 mkCanonicalRequest !isStreaming !sp !req !headersForSign =
-  let
+  let canonicalQueryString =
-    canonicalQueryString = B.intercalate "&" $
+        B.intercalate "&"
-      map (\(x, y) -> B.concat [x, "=", y]) $
+          $ map (\(x, y) -> B.concat [x, "=", y])
-      sort $ map (\(x, y) ->
+          $ sort
-                    (uriEncode True x, maybe "" (uriEncode True) y)) $
+          $ map
-      (parseQuery $ NC.queryString req)
+            ( \(x, y) ->
-
+                (uriEncode True x, maybe "" (uriEncode True) y)
+            )
+          $ (parseQuery $ NC.queryString req)
       sortedHeaders = sort headersForSign
-
+      canonicalHeaders =
-    canonicalHeaders = B.concat $
+        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
+   in B.intercalate
-    B.intercalate "\n"
+        "\n"
-    [ NC.method req
+        [ NC.method req,
-    , uriEncode False $ NC.path req
+          uriEncode False $ NC.path req,
-    , canonicalQueryString
+          canonicalQueryString,
-    , canonicalHeaders
+          canonicalHeaders,
-    , signedHeaders
+          signedHeaders,
-    , payloadHashStr
+          payloadHashStr
         ]
 
 mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString
-mkStringToSign ts !scope !canonicalRequest = B.intercalate "\n"
+mkStringToSign ts !scope !canonicalRequest =
-                                             [ "AWS4-HMAC-SHA256"
+  B.intercalate
-                                             , awsTimeFormatBS ts
+    "\n"
-                                             , scope
+    [ "AWS4-HMAC-SHA256",
-                                             , hashSHA256 canonicalRequest
+      awsTimeFormatBS ts,
+      scope,
+      hashSHA256 canonicalRequest
     ]
 
 mkSigningKey :: UTCTime -> Text -> ByteString -> ByteString
-mkSigningKey ts region !secretKey = hmacSHA256RawBS "aws4_request"
+mkSigningKey ts region !secretKey =
+  hmacSHA256RawBS "aws4_request"
     . hmacSHA256RawBS "s3"
-                                  . hmacSHA256RawBS (toS region)
+    . hmacSHA256RawBS (toUtf8 region)
     . hmacSHA256RawBS (awsDateFormatBS ts)
     $ B.concat ["AWS4", secretKey]
 
@@ -233,17 +249,18 @@ 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
+signV4PostPolicy ::
-                 -> Map.HashMap Text ByteString
+  ByteString ->
+  SignParams ->
+  Map.HashMap Text ByteString
 signV4PostPolicy !postPolicyJSON !sp =
-  let
+  let stringToSign = Base64.encode postPolicyJSON
-    stringToSign = Base64.encode postPolicyJSON
       region = fromMaybe "" $ spRegion sp
-    signingKey = mkSigningKey (spTimeStamp sp) region $ toS $ spSecretKey sp
+      signingKey = mkSigningKey (spTimeStamp sp) region $ toUtf8 $ spSecretKey sp
       signature = computeSignature stringToSign signingKey
-  in
+   in Map.fromList
-    Map.fromList [ ("x-amz-signature", signature)
+        [ ("x-amz-signature", signature),
-                 , ("policy", stringToSign)
+          ("policy", stringToSign)
         ]
 
 chunkSizeConstant :: Int
@@ -252,116 +269,112 @@ 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
+base16Len n
+  | n == 0 = 0
   | otherwise = 1 + base16Len (n `div` 16)
 
 signedStreamLength :: Int64 -> Int64
 signedStreamLength dataLen =
-  let
+  let chunkSzInt = fromIntegral chunkSizeConstant
-    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
+   in numChunks * fullChunkSize + lastChunkSize + finalChunkSize
-    numChunks * fullChunkSize + lastChunkSize + finalChunkSize
 
-signV4Stream :: Int64 -> SignParams -> NC.Request
+signV4Stream ::
-             -> (C.ConduitT () ByteString (C.ResourceT IO) () -> NC.Request)
+  Int64 ->
+  SignParams ->
+  NC.Request ->
+  (C.ConduitT () ByteString (C.ResourceT IO) () -> NC.Request)
 -- -> ([Header], C.ConduitT () ByteString (C.ResourceT IO) () -> NC.RequestBody)
 signV4Stream !payloadLength !sp !req =
-  let
+  let ts = spTimeStamp sp
-    ts = spTimeStamp sp
-
       addContentEncoding hs =
         let ceMay = headMay $ filter (\(x, _) -> x == "content-encoding") hs
          in case ceMay of
               Nothing -> ("content-encoding", "aws-chunked") : hs
-             Just (_, ce) -> ("content-encoding", ce <> ",aws-chunked") :
+              Just (_, ce) ->
-                             filter (\(x, _) -> x /= "content-encoding") hs
+                ("content-encoding", ce <> ",aws-chunked")
-
+                  : filter (\(x, _) -> x /= "content-encoding") hs
       -- headers to be added to the request
       datePair = ("X-Amz-Date", awsTimeFormatBS ts)
-    computedHeaders = addContentEncoding $
+      computedHeaders =
+        addContentEncoding $
           datePair : NC.requestHeaders req
-
       -- headers specific to streaming signature
       signedContentLength = signedStreamLength payloadLength
       streamingHeaders :: [Header]
       streamingHeaders =
-        [ ("x-amz-decoded-content-length", show payloadLength)
+        [ ("x-amz-decoded-content-length", showBS payloadLength),
-        , ("content-length", show signedContentLength )
+          ("content-length", showBS signedContentLength),
-        , ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD")
+          ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD")
         ]
       headersToSign = getHeadersToSign $ computedHeaders ++ streamingHeaders
       signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign
       finalQP = parseQuery (NC.queryString req)
-
       -- 1. Compute Seed Signature
       -- 1.1 Canonical Request
-    canonicalReq = mkCanonicalRequest True sp
+      canonicalReq =
+        mkCanonicalRequest
+          True
+          sp
           (NC.setQueryString finalQP req)
           headersToSign
-
       region = fromMaybe "" $ spRegion sp
       scope = mkScope ts region
       accessKey = spAccessKey sp
       secretKey = spSecretKey sp
-
       -- 1.2 String toSign
       stringToSign = mkStringToSign ts scope canonicalReq
-
       -- 1.3 Compute signature
       -- 1.3.1 compute signing key
-    signingKey = mkSigningKey ts region $ toS secretKey
+      signingKey = mkSigningKey ts region $ toUtf8 secretKey
-
       -- 1.3.2 Compute signature
       seedSignature = computeSignature stringToSign signingKey
-
       -- 1.3.3 Compute Auth Header
       authHeader = mkAuthHeader accessKey scope signedHeaderKeys seedSignature
-
       -- 1.4 Updated headers for the request
       finalReqHeaders = authHeader : (computedHeaders ++ streamingHeaders)
       -- headersToAdd = authHeader : datePair : streamingHeaders
 
       toHexStr n = B8.pack $ printf "%x" n
-
       (numParts, lastPSize) = payloadLength `quotRem` fromIntegral chunkSizeConstant
-
       -- Function to compute string to sign for each chunk.
       chunkStrToSign prevSign currChunkHash =
-        B.intercalate "\n"
+        B.intercalate
-        [ "AWS4-HMAC-SHA256-PAYLOAD"
+          "\n"
-        , awsTimeFormatBS ts
+          [ "AWS4-HMAC-SHA256-PAYLOAD",
-        , scope
+            awsTimeFormatBS ts,
-        , prevSign
+            scope,
-        , hashSHA256 ""
+            prevSign,
-        , currChunkHash
+            hashSHA256 "",
+            currChunkHash
           ]
-
       -- Read n byte from upstream and return a strict bytestring.
       mustTakeN n = do
-        bs <- toS <$> (C.takeCE n C..| C.sinkLazy)
+        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
+        if
+            | n > 0 -> do
               bs <- mustTakeN chunkSizeConstant
               let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
                   nextSign = computeSignature strToSign signingKey
-                   chunkBS = toHexStr chunkSizeConstant
+                  chunkBS =
+                    toHexStr chunkSizeConstant
                       <> ";chunk-signature="
-                          <> nextSign <> "\r\n" <> bs <> "\r\n"
+                      <> nextSign
+                      <> "\r\n"
+                      <> bs
+                      <> "\r\n"
               C.yield chunkBS
               signerConduit (n -1) lps nextSign
 
@@ -371,8 +384,12 @@ signV4Stream !payloadLength !sp !req =
               bs <- mustTakeN $ fromIntegral lps
               let strToSign = chunkStrToSign prevSign (hashSHA256 bs)
                   nextSign = computeSignature strToSign signingKey
-                   chunkBS = toHexStr lps <> ";chunk-signature="
+                  chunkBS =
-                          <> nextSign <> "\r\n" <> bs <> "\r\n"
+                    toHexStr lps <> ";chunk-signature="
+                      <> nextSign
+                      <> "\r\n"
+                      <> bs
+                      <> "\r\n"
               C.yield chunkBS
               signerConduit 0 0 nextSign
 
@@ -383,9 +400,10 @@ signV4Stream !payloadLength !sp !req =
                   nextSign = computeSignature strToSign signingKey
                   lastChunkBS = "0;chunk-signature=" <> nextSign <> "\r\n\r\n"
               C.yield lastChunkBS
-  in
+   in \src ->
-    \src -> req { NC.requestHeaders = finalReqHeaders
+        req
-                , NC.requestBody =
+          { NC.requestHeaders = finalReqHeaders,
+            NC.requestBody =
               NC.requestBodySource signedContentLength $
                 src C..| signerConduit numParts lastPSize seedSignature
           }

src/Network/Minio/Utils.hs

@@ -27,26 +27,29 @@ import qualified Data.HashMap.Strict           as H
 import qualified Data.List as List
 import qualified Data.Text as T
 import Data.Text.Read (decimal)
-import           Data.Time                     (defaultTimeLocale, parseTimeM,
+import Data.Time
-                                                rfc822DateFormat)
+  ( 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
+import Network.Minio.Data.ByteString
+import Network.Minio.JsonParser (parseErrResponseJSON)
+import Network.Minio.XmlParser (parseErrResponse)
 import qualified System.IO as IO
 import qualified UnliftIO as U
 import qualified UnliftIO.Async as A
 import qualified UnliftIO.MVar as UM
 
-import           Lib.Prelude
+allocateReadFile ::
-
+  (MonadUnliftIO m, R.MonadResource m) =>
-import           Network.Minio.Data
+  FilePath ->
-import           Network.Minio.Data.ByteString
+  m (R.ReleaseKey, Handle)
-import           Network.Minio.JsonParser      (parseErrResponseJSON)
-import           Network.Minio.XmlParser       (parseErrResponse)
-
-allocateReadFile :: (MonadUnliftIO m, R.MonadResource m)
-                 => FilePath -> m (R.ReleaseKey, Handle)
 allocateReadFile fp = do
   (rk, hdlE) <- R.allocate (openReadFile fp) cleanup
   either (\(e :: IOException) -> throwIO e) (return . (rk,)) hdlE
@@ -56,8 +59,10 @@ allocateReadFile fp = do
 
 -- | Queries the file size from the handle. Catches any file operation
 -- exceptions and returns Nothing instead.
-getFileSize :: (MonadUnliftIO m, R.MonadResource m)
+getFileSize ::
-            => Handle -> m (Maybe Int64)
+  (MonadUnliftIO m, R.MonadResource m) =>
+  Handle ->
+  m (Maybe Int64)
 getFileSize h = do
   resE <- liftIO $ try $ fromIntegral <$> IO.hFileSize h
   case resE of
@@ -66,8 +71,10 @@ getFileSize h = do
 
 -- | Queries if handle is seekable. Catches any file operation
 -- exceptions and return False instead.
-isHandleSeekable :: (R.MonadResource m, MonadUnliftIO m)
+isHandleSeekable ::
-               => Handle -> m Bool
+  (R.MonadResource m, MonadUnliftIO m) =>
+  Handle ->
+  m Bool
 isHandleSeekable h = do
   resE <- liftIO $ try $ IO.hIsSeekable h
   case resE of
@@ -78,8 +85,11 @@ isHandleSeekable h = do
 -- 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 :: (MonadUnliftIO m, R.MonadResource m)
+withNewHandle ::
-              => FilePath -> (Handle -> m a) -> m (Either IOException a)
+  (MonadUnliftIO m, R.MonadResource m) =>
+  FilePath ->
+  (Handle -> m a) ->
+  m (Either IOException a)
 withNewHandle fp fileAction = do
   -- opening a handle can throw MError exception.
   handleE <- try $ allocateReadFile fp
@@ -110,8 +120,10 @@ toMaybeMetadataHeader (k, v) =
   (,v) <$> userMetadataHeaderNameMaybe k
 
 getNonUserMetadataMap :: [(Text, Text)] -> H.HashMap Text Text
-getNonUserMetadataMap = H.fromList
+getNonUserMetadataMap =
-                      . filter ( isNothing
+  H.fromList
+    . filter
+      ( isNothing
           . userMetadataHeaderNameMaybe
           . fst
       )
@@ -119,7 +131,8 @@ getNonUserMetadataMap = H.fromList
 -- | 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
+getUserMetadataMap =
+  H.fromList
     . mapMaybe toMaybeMetadataHeader
 
 getLastModifiedHeader :: [HT.Header] -> Maybe UTCTime
@@ -132,17 +145,19 @@ getContentLength hs = do
   nbs <- decodeUtf8Lenient <$> lookupHeader Hdr.hContentLength hs
   fst <$> hush (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 :: 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 $ NC.httpLbs req mgr
   resp <- either throwIO return respE
@@ -154,21 +169,25 @@ httpLbs req mgr = do
       Just "application/json" -> do
         sErr <- parseErrResponseJSON $ NC.responseBody resp
         throwIO sErr
-
+      _ ->
-      _ -> throwIO $ NC.HttpExceptionRequest req $
+        throwIO $ NC.HttpExceptionRequest req $
-        NC.StatusCodeException (void resp) (show resp)
+          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 $
+    contentTypeMay resp =
+      lookupHeader Hdr.hContentType $
         NC.responseHeaders resp
 
-http :: (MonadUnliftIO m, R.MonadResource m)
+http ::
-     => NC.Request -> NC.Manager
+  (MonadUnliftIO m, R.MonadResource m) =>
-     -> m (Response (C.ConduitT () ByteString m ()))
+  NC.Request ->
+  NC.Manager ->
+  m (Response (C.ConduitT () ByteString m ()))
 http req mgr = do
   respE <- tryHttpEx $ NC.http req mgr
   resp <- either throwIO return respE
@@ -178,25 +197,30 @@ http req mgr = do
         respBody <- C.connect (NC.responseBody resp) CB.sinkLbs
         sErr <- parseErrResponse respBody
         throwIO sErr
-
       _ -> do
         content <- LB.toStrict . NC.responseBody <$> NC.lbsResponse resp
         throwIO $ NC.HttpExceptionRequest req $
           NC.StatusCodeException (void resp) content
 
-
   return resp
   where
-    tryHttpEx :: (MonadUnliftIO m) => m a
+    tryHttpEx ::
-              -> m (Either NC.HttpException a)
+      (MonadUnliftIO m) =>
+      m a ->
+      m (Either NC.HttpException a)
     tryHttpEx = try
-    contentTypeMay resp = lookupHeader Hdr.hContentType $
+    contentTypeMay resp =
+      lookupHeader Hdr.hContentType $
         NC.responseHeaders resp
 
 -- Similar to mapConcurrently but limits the number of threads that
 -- can run using a quantity semaphore.
-limitedMapConcurrently :: MonadUnliftIO m
+limitedMapConcurrently ::
-                       => Int -> (t -> m a) -> [t] -> m [a]
+  MonadUnliftIO m =>
+  Int ->
+  (t -> m a) ->
+  [t] ->
+  m [a]
 limitedMapConcurrently 0 _ _ = return []
 limitedMapConcurrently count act args = do
   t' <- U.newTVarIO count
@@ -205,14 +229,12 @@ limitedMapConcurrently count act args = do
   where
     wThread t arg =
       U.bracket_ (waitSem t) (signalSem t) $ act arg
-
     -- quantity semaphore implementation using TVar
     waitSem t = U.atomically $ do
       v <- U.readTVar t
       if v > 0
         then U.writeTVar t (v -1)
         else U.retrySTM
-
     signalSem t = U.atomically $ do
       v <- U.readTVar t
       U.writeTVar t (v + 1)
@@ -234,21 +256,28 @@ chunkBSConduit :: (Monad m) => [Int] -> C.ConduitM ByteString ByteString m ()
 chunkBSConduit [] = return ()
 chunkBSConduit (s : ss) = do
   bs <- fmap LB.toStrict $ C.takeCE s C..| C.sinkLazy
-    if | B.length bs == s -> C.yield bs >> chunkBSConduit ss
+  if
+      | B.length bs == s -> C.yield bs >> chunkBSConduit ss
       | B.length bs > 0 -> C.yield bs
       | otherwise -> return ()
 
 -- | Select part sizes - the logic is that the minimum part-size will
 -- be 64MiB.
 selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]
-selectPartSizes size = uncurry (List.zip3 [1..]) $
+selectPartSizes size =
-                       List.unzip $ loop 0 size
+  uncurry (List.zip3 [1 ..])
+    $ List.unzip
+    $ loop 0 size
   where
     ceil :: Double -> Int64
     ceil = ceiling
-    partSize = max minPartSize (ceil $ fromIntegral size /
+    partSize =
-                               fromIntegral maxMultipartParts)
+      max
-
+        minPartSize
+        ( ceil $
+            fromIntegral size
+              / fromIntegral maxMultipartParts
+        )
     m = fromIntegral partSize
     loop st sz
       | st > sz = []

src/Network/Minio/XmlGenerator.hs

@@ -15,30 +15,31 @@
 --
 
 module Network.Minio.XmlGenerator
-  ( mkCreateBucketConfig
+  ( mkCreateBucketConfig,
-  , mkCompleteMultipartUploadRequest
+    mkCompleteMultipartUploadRequest,
-  , mkPutNotificationRequest
+    mkPutNotificationRequest,
-  , mkSelectRequest
+    mkSelectRequest,
-  ) where
+  )
-
+where
 
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.HashMap.Strict as H
 import qualified Data.Text as T
-import           Text.XML
-
 import Lib.Prelude
-
 import Network.Minio.Data
-
+import Text.XML
 
 -- | Create a bucketConfig request body XML
 mkCreateBucketConfig :: Text -> Region -> ByteString
 mkCreateBucketConfig ns location = LBS.toStrict $ renderLBS def bucketConfig
   where
     s3Element n = Element (s3Name ns n) mempty
-      root = s3Element "CreateBucketConfiguration"
+    root =
-        [ NodeElement $ s3Element "LocationConstraint"
+      s3Element
+        "CreateBucketConfiguration"
+        [ NodeElement $
+            s3Element
+              "LocationConstraint"
               [NodeContent location]
         ]
     bucketConfig = Document (Prologue [] Nothing []) root []
@@ -48,29 +49,45 @@ mkCompleteMultipartUploadRequest :: [PartTuple] -> ByteString
 mkCompleteMultipartUploadRequest partInfo =
   LBS.toStrict $ renderLBS def cmur
   where
-    root = Element "CompleteMultipartUpload" mempty $
+    root =
+      Element "CompleteMultipartUpload" mempty $
         map (NodeElement . mkPart) partInfo
-    mkPart (n, etag) = Element "Part" mempty
+    mkPart (n, etag) =
-                               [ NodeElement $ Element "PartNumber" mempty
+      Element
-                                 [NodeContent $ T.pack $ show n]
+        "Part"
-                               , NodeElement $ Element "ETag" mempty
+        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]
+data XNode
+  = XNode Text [XNode]
   | XLeaf Text Text
   deriving (Eq, Show)
 
 toXML :: Text -> XNode -> ByteString
-toXML ns node = LBS.toStrict $ renderLBS def $
+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 $
+    xmlNode (XNode name nodes) =
+      Element (s3Name ns name) mempty $
         map (NodeElement . xmlNode) nodes
-    xmlNode (XLeaf name content) = Element (s3Name ns name) mempty
+    xmlNode (XLeaf name content) =
+      Element
+        (s3Name ns name)
+        mempty
         [NodeContent content]
 
 class ToXNode a where
@@ -80,23 +97,28 @@ instance ToXNode Event where
   toXNode = XLeaf "Event" . show
 
 instance ToXNode Notification where
-  toXNode (Notification qc tc lc) = XNode "NotificationConfiguration" $
+  toXNode (Notification qc tc lc) =
-    map (toXNodesWithArnName "QueueConfiguration" "Queue") qc ++
+    XNode "NotificationConfiguration" $
-    map (toXNodesWithArnName "TopicConfiguration" "Topic") tc ++
+      map (toXNodesWithArnName "QueueConfiguration" "Queue") qc
-    map (toXNodesWithArnName "CloudFunctionConfiguration" "CloudFunction") lc
+        ++ map (toXNodesWithArnName "TopicConfiguration" "Topic") tc
+        ++ map (toXNodesWithArnName "CloudFunctionConfiguration" "CloudFunction") lc
 
 toXNodesWithArnName :: Text -> Text -> NotificationConfig -> XNode
 toXNodesWithArnName eltName arnName (NotificationConfig id arn events fRule) =
-  XNode eltName $ [XLeaf "Id" id, XLeaf arnName arn] ++ map toXNode events ++
+  XNode eltName $
-  [toXNode fRule]
+    [XLeaf "Id" id, 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
+getFRXNode (FilterRule n v) =
-                                                 , XLeaf "Value" v
+  XNode
+    "FilterRule"
+    [ XLeaf "Name" n,
+      XLeaf "Value" v
     ]
 
 mkPutNotificationRequest :: Text -> Notification -> ByteString
@@ -106,29 +128,56 @@ mkSelectRequest :: SelectRequest -> ByteString
 mkSelectRequest r = LBS.toStrict $ renderLBS def sr
   where
     sr = Document (Prologue [] Nothing []) root []
-    root = Element "SelectRequest" mempty $
+    root =
-           [ NodeElement (Element "Expression" mempty
+      Element "SelectRequest" 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
+            ( 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")]
+                          (if enabled then "TRUE" else "FALSE")
+                      ]
                   )
               ]
           )
       ]
-    inputSerializationNodes is = comprTypeNode (isCompressionType is) ++
+    inputSerializationNodes is =
-                                 [NodeElement $ formatNode (isFormatInfo is)]
+      comprTypeNode (isCompressionType is)
-    comprTypeNode (Just c) = [NodeElement $ Element "CompressionType" mempty
+        ++ [NodeElement $ formatNode (isFormatInfo is)]
+    comprTypeNode (Just c) =
+      [ NodeElement $
+          Element
+            "CompressionType"
+            mempty
             [ NodeContent $ case c of
                 CompressionTypeNone -> "NONE"
                 CompressionTypeGzip -> "GZIP"
@@ -136,15 +185,20 @@ mkSelectRequest r = LBS.toStrict $ renderLBS def sr
             ]
       ]
     comprTypeNode Nothing = []
-
     kvElement (k, v) = Element (Name k Nothing Nothing) mempty [NodeContent v]
     formatNode (InputFormatCSV (CSVProp h)) =
-      Element "CSV" mempty
+      Element
+        "CSV"
+        mempty
         (map NodeElement $ map kvElement $ H.toList h)
     formatNode (InputFormatJSON p) =
-      Element "JSON" mempty
+      Element
+        "JSON"
+        mempty
         [ NodeElement
-        (Element "Type" mempty
+            ( Element
+                "Type"
+                mempty
                 [ NodeContent $ case jsonipType p of
                     JSONTypeDocument -> "DOCUMENT"
                     JSONTypeLines -> "LINES"
@@ -152,14 +206,25 @@ mkSelectRequest r = LBS.toStrict $ renderLBS def sr
             )
         ]
     formatNode InputFormatParquet = Element "Parquet" mempty []
-
     outputSerializationNodes (OutputSerializationJSON j) =
-      [NodeElement (Element "JSON" mempty $
+      [ NodeElement
-                     rdElem $ jsonopRecordDelimiter j)]
+          ( Element "JSON" mempty
+              $ rdElem
+              $ jsonopRecordDelimiter j
+          )
+      ]
     outputSerializationNodes (OutputSerializationCSV (CSVProp h)) =
-      [NodeElement $ Element "CSV" mempty
+      [ NodeElement $
-       (map NodeElement $ map kvElement $ H.toList h)]
+          Element
-
+            "CSV"
+            mempty
+            (map NodeElement $ map kvElement $ H.toList h)
+      ]
     rdElem Nothing = []
-    rdElem (Just t) = [NodeElement $ Element "RecordDelimiter" mempty
+    rdElem (Just t) =
-                        [NodeContent t]]
+      [ NodeElement $
+          Element
+            "RecordDelimiter"
+            mempty
+            [NodeContent t]
+      ]

src/Network/Minio/XmlParser.hs

@@ -15,19 +15,20 @@
 --
 
 module Network.Minio.XmlParser
-  ( parseListBuckets
+  ( parseListBuckets,
-  , parseLocation
+    parseLocation,
-  , parseNewMultipartUpload
+    parseNewMultipartUpload,
-  , parseCompleteMultipartUploadResponse
+    parseCompleteMultipartUploadResponse,
-  , parseCopyObjectResponse
+    parseCopyObjectResponse,
-  , parseListObjectsResponse
+    parseListObjectsResponse,
-  , parseListObjectsV1Response
+    parseListObjectsV1Response,
-  , parseListUploadsResponse
+    parseListUploadsResponse,
-  , parseListPartsResponse
+    parseListPartsResponse,
-  , parseErrResponse
+    parseErrResponse,
-  , parseNotification
+    parseNotification,
-  , parseSelectProgress
+    parseSelectProgress,
-  ) where
+  )
+where
 
 import qualified Data.ByteString.Lazy as LB
 import qualified Data.HashMap.Strict as H
@@ -35,14 +36,11 @@ import           Data.List            (zip3, zip4, zip6)
 import qualified Data.Text as T
 import Data.Text.Read (decimal)
 import Data.Time
-import           Text.XML
-import           Text.XML.Cursor      hiding (bool)
-
 import Lib.Prelude
-
 import Network.Minio.Data
 import Network.Minio.Errors
-
+import Text.XML
+import Text.XML.Cursor hiding (bool)
 
 -- | Represent the time format string returned by S3 API calls.
 s3TimeFormat :: [Char]
@@ -58,11 +56,13 @@ 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 $
+  maybe (throwIO $ MErrVXmlParse $ "timestamp parse failure: " <> t) return
-    parseTimeM True defaultTimeLocale s3TimeFormat $ T.unpack t
+    $ parseTimeM True defaultTimeLocale s3TimeFormat
+    $ T.unpack t
 
 parseDecimal :: (MonadIO m, Integral a) => Text -> m a
-parseDecimal numStr = either (throwIO . MErrVXmlParse . show) return $
+parseDecimal numStr =
+  either (throwIO . MErrVXmlParse . show) return $
     fst <$> decimal numStr
 
 parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a]
@@ -72,7 +72,8 @@ s3Elem :: Text -> Text -> Axis
 s3Elem ns = element . s3Name ns
 
 parseRoot :: (MonadIO m) => LByteString -> m Cursor
-parseRoot = either (throwIO . MErrVXmlParse . show) (return . fromDocument)
+parseRoot =
+  either (throwIO . MErrVXmlParse . show) (return . fromDocument)
     . parseLBS def
 
 -- | Parse the response XML of a list buckets call.
@@ -80,8 +81,7 @@ parseListBuckets :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByte
 parseListBuckets xmldata = do
   r <- parseRoot xmldata
   ns <- asks getSvcNamespace
-  let
+  let s3Elem' = s3Elem ns
-    s3Elem' = s3Elem ns
       names = r $// s3Elem' "Bucket" &// s3Elem' "Name" &/ content
       timeStrings = r $// s3Elem' "Bucket" &// s3Elem' "CreationDate" &/ content
 
@@ -116,27 +116,24 @@ parseCopyObjectResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) =
 parseCopyObjectResponse xmldata = do
   r <- parseRoot xmldata
   ns <- asks getSvcNamespace
-  let
+  let s3Elem' = s3Elem ns
-    s3Elem' = s3Elem ns
       mtimeStr = T.concat $ r $// s3Elem' "LastModified" &/ content
 
   mtime <- parseS3XMLTime mtimeStr
   return (T.concat $ r $// s3Elem' "ETag" &/ content, mtime)
 
 -- | Parse the response XML of a list objects v1 call.
-parseListObjectsV1Response :: (MonadReader env m, HasSvcNamespace env, MonadIO m)
+parseListObjectsV1Response ::
-                         => LByteString -> m ListObjectsV1Result
+  (MonadReader env m, HasSvcNamespace env, MonadIO m) =>
+  LByteString ->
+  m ListObjectsV1Result
 parseListObjectsV1Response xmldata = do
   r <- parseRoot xmldata
   ns <- asks getSvcNamespace
-  let
+  let s3Elem' = s3Elem ns
-    s3Elem' = s3Elem ns
       hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
-
       nextMarker = headMay $ r $/ s3Elem' "NextMarker" &/ 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
@@ -148,8 +145,8 @@ parseListObjectsV1Response xmldata = do
   modTimes <- mapM parseS3XMLTime modTimeStr
   sizes <- parseDecimals sizeStr
 
-  let
+  let objects =
-    objects = map (uncurry6 ObjectInfo) $
+        map (uncurry6 ObjectInfo) $
           zip6 keys modTimes etags sizes (repeat H.empty) (repeat H.empty)
 
   return $ ListObjectsV1Result hasMore nextMarker objects prefixes
@@ -159,14 +156,10 @@ parseListObjectsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m)
 parseListObjectsResponse xmldata = do
   r <- parseRoot xmldata
   ns <- asks getSvcNamespace
-  let
+  let s3Elem' = s3Elem ns
-    s3Elem' = s3Elem ns
       hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
-
       nextToken = headMay $ 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
@@ -178,8 +171,8 @@ parseListObjectsResponse xmldata = do
   modTimes <- mapM parseS3XMLTime modTimeStr
   sizes <- parseDecimals sizeStr
 
-  let
+  let objects =
-    objects = map (uncurry6 ObjectInfo) $
+        map (uncurry6 ObjectInfo) $
           zip6 keys modTimes etags sizes (repeat H.empty) (repeat H.empty)
 
   return $ ListObjectsResult hasMore nextToken objects prefixes
@@ -189,8 +182,7 @@ parseListUploadsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m)
 parseListUploadsResponse xmldata = do
   r <- parseRoot xmldata
   ns <- asks getSvcNamespace
-  let
+  let s3Elem' = s3Elem ns
-    s3Elem' = s3Elem ns
       hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
       prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content
       nextKey = headMay $ r $/ s3Elem' "NextKeyMarker" &/ content
@@ -201,8 +193,7 @@ parseListUploadsResponse xmldata = do
 
   uploadInitTimes <- mapM parseS3XMLTime uploadInitTimeStr
 
-  let
+  let uploads = zip3 uploadKeys uploadIds uploadInitTimes
-    uploads = zip3 uploadKeys uploadIds uploadInitTimes
 
   return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes
 
@@ -210,8 +201,7 @@ parseListPartsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) =>
 parseListPartsResponse xmldata = do
   r <- parseRoot xmldata
   ns <- asks getSvcNamespace
-  let
+  let s3Elem' = s3Elem ns
-    s3Elem' = s3Elem ns
       hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)
       nextPartNumStr = headMay $ r $/ s3Elem' "NextPartNumberMarker" &/ content
       partNumberStr = r $/ s3Elem' "Part" &/ s3Elem' "PartNumber" &/ content
@@ -224,13 +214,12 @@ parseListPartsResponse xmldata = do
   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
 
-
 parseErrResponse :: (MonadIO m) => LByteString -> m ServiceErr
 parseErrResponse xmldata = do
   r <- parseRoot xmldata
@@ -250,20 +239,23 @@ parseNotification xmldata = do
     <*> (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
           id = T.concat $ c $/ s3Elem ns "Id" &/ content
           arn = T.concat $ c $/ s3Elem ns arnName &/ content
           events = catMaybes $ map textToEvent $ c $/ s3Elem ns "Event" &/ content
-          rules = c $/ s3Elem ns "Filter" &/ s3Elem ns "S3Key" &/
+          rules =
-                  s3Elem ns "FilterRule" &| getFilterRule ns
+            c $/ s3Elem ns "Filter" &/ s3Elem ns "S3Key"
-      return $ NotificationConfig id arn events
+              &/ s3Elem ns "FilterRule" &| getFilterRule ns
+      return $
+        NotificationConfig
+          id
+          arn
+          events
           (Filter $ FilterKey $ FilterRules rules)
 
 parseSelectProgress :: MonadIO m => ByteString -> m Progress

stack.yaml

@@ -15,7 +15,7 @@
 # resolver:
 #  name: custom-snapshot
 #  location: "./custom-snapshot.yaml"
-resolver: lts-14.6
+resolver: lts-16.0
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -39,7 +39,9 @@ packages:
 - '.'
 # Dependency packages to be pulled from upstream that are not in the resolver
 # (e.g., acme-missiles-0.3)
-extra-deps: []
+extra-deps:
+- unliftio-core-0.2.0.1
+- protolude-0.3.0
 
 # Override default flag values for local packages and extra-deps
 flags: {}

stack.yaml.lock

@@ -3,10 +3,24 @@
 # For more information, please see the documentation at:
 #   https://docs.haskellstack.org/en/stable/lock_files
 
-packages: []
+packages:
+- completed:
+    hackage: unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082
+    pantry-tree:
+      size: 328
+      sha256: e81c5a1e82ec2cd68cbbbec9cd60567363abe02257fa1370a906f6754b6818b8
+  original:
+    hackage: unliftio-core-0.2.0.1
+- completed:
+    hackage: protolude-0.3.0@sha256:8361b811b420585b122a7ba715aa5923834db6e8c36309bf267df2dbf66b95ef,2693
+    pantry-tree:
+      size: 1644
+      sha256: babf32b414f25f790b7a4ce6bae5c960bc51a11a289e7c47335b222e6762560c
+  original:
+    hackage: protolude-0.3.0
 snapshots:
 - completed:
-    size: 524127
+    size: 531237
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/6.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/0.yaml
-    sha256: dc70dfb45e2c32f54719819bd055f46855dd4b3bd2e58b9f3f38729a2d553fbb
+    sha256: 210e15b7043e2783115afe16b0d54914b1611cdaa73f3ca3ca7f8e0847ff54e5
-  original: lts-14.6
+  original: lts-16.0

test/LiveServer.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+
 --
 -- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.
 --
@@ -15,11 +16,6 @@
 -- limitations under the License.
 --
 
-import qualified Test.QuickCheck                       as Q
-import           Test.Tasty
-import           Test.Tasty.HUnit
-import           Test.Tasty.QuickCheck                 as QC
-
 import Conduit (replicateC)
 import qualified Conduit as C
 import qualified Control.Monad.Trans.Resource as R
@@ -31,21 +27,23 @@ import qualified Data.HashMap.Strict                   as H
 import qualified Data.Text as T
 import Data.Time (fromGregorian)
 import qualified Data.Time as Time
+import Lib.Prelude
 import qualified Network.HTTP.Client.MultipartFormData as Form
 import qualified Network.HTTP.Conduit as NC
 import qualified Network.HTTP.Types as HT
-import           System.Directory                      (getTemporaryDirectory)
-import           System.Environment                    (lookupEnv)
-import qualified System.IO                             as SIO
-
-import           Lib.Prelude
-
 import Network.Minio
 import Network.Minio.Data
 import Network.Minio.Data.Crypto
 import Network.Minio.PutObject
 import Network.Minio.S3API
 import Network.Minio.Utils
+import System.Directory (getTemporaryDirectory)
+import System.Environment (lookupEnv)
+import qualified System.IO as SIO
+import qualified Test.QuickCheck as Q
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck as QC
 
 main :: IO ()
 main = defaultMain tests
@@ -57,16 +55,19 @@ tests = testGroup "Tests" [liveServerUnitTests]
 randomDataSrc :: MonadIO m => Int64 -> C.ConduitM () ByteString m ()
 randomDataSrc s' = genBS s'
   where
-    concatIt bs n = BS.concat $ replicate (fromIntegral q) bs ++
+    concatIt bs n =
-                    [BS.take (fromIntegral r) bs]
+      BS.concat $
-      where (q, r) = n `divMod` fromIntegral (BS.length bs)
+        replicate (fromIntegral q) bs
-
+          ++ [BS.take (fromIntegral r) bs]
+      where
+        (q, r) = n `divMod` fromIntegral (BS.length bs)
     genBS s = do
       w8s <- liftIO $ generate $ Q.vectorOf 64 (Q.choose (0, 255))
       let byteArr64 = BS.pack w8s
       if s < oneMiB
         then yield $ concatIt byteArr64 s
-        else do yield $ concatIt byteArr64 oneMiB
+        else do
+          yield $ concatIt byteArr64 oneMiB
           genBS (s - oneMiB)
 
 mkRandFile :: R.MonadResource m => Int64 -> m FilePath
@@ -86,8 +87,10 @@ loadTestServer = do
     (Just _, Nothing) -> setCreds (Credentials "minio" "minio123") "http://localhost:9000"
     (Nothing, _) -> minioPlayCI
 
-funTestWithBucket :: TestName
+funTestWithBucket ::
-                  -> (([Char] -> Minio ()) -> Bucket -> Minio ()) -> TestTree
+  TestName ->
+  (([Char] -> Minio ()) -> Bucket -> Minio ()) ->
+  TestTree
 funTestWithBucket t minioTest = testCaseSteps t $ \step -> do
   -- generate a random name for the bucket
   bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z'))
@@ -104,24 +107,26 @@ funTestWithBucket t minioTest = testCaseSteps t $ \step -> do
   isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)
 
 liveServerUnitTests :: TestTree
-liveServerUnitTests = testGroup "Unit tests against a live server"
+liveServerUnitTests =
-  [ basicTests
+  testGroup
-  , listingTest
+    "Unit tests against a live server"
-  , highLevelListingTest
+    [ basicTests,
-  , lowLevelMultipartTest
+      listingTest,
-  , putObjectSizeTest
+      highLevelListingTest,
-  , putObjectNoSizeTest
+      lowLevelMultipartTest,
-  , multipartTest
+      putObjectSizeTest,
-  , putObjectContentTypeTest
+      putObjectNoSizeTest,
-  , putObjectContentLanguageTest
+      multipartTest,
-  , putObjectStorageClassTest
+      putObjectContentTypeTest,
-  , putObjectUserMetadataTest
+      putObjectContentLanguageTest,
-  , getObjectTest
+      putObjectStorageClassTest,
-  , copyObjectTests
+      putObjectUserMetadataTest,
-  , presignedUrlFunTest
+      getObjectTest,
-  , presignedPostPolicyFunTest
+      copyObjectTests,
-  , bucketPolicyFunTest
+      presignedUrlFunTest,
-  , getNPutSSECTest
+      presignedPostPolicyFunTest,
+      bucketPolicyFunTest,
+      getNPutSSECTest
     ]
 
 basicTests :: TestTree
@@ -129,10 +134,12 @@ basicTests = funTestWithBucket "Basic tests" $
   \step bucket -> do
     step "getService works and contains the test bucket."
     buckets <- getService
-    unless (length (filter (== bucket) $ map biName buckets) == 1) $
+    unless (length (filter (== bucket) $ map biName buckets) == 1)
-      liftIO $
+      $ liftIO
-      assertFailure ("The bucket " ++ show bucket ++
+      $ assertFailure
-                     " was expected to exist.")
+        ( "The bucket " ++ show bucket
+            ++ " was expected to exist."
+        )
 
     step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised."
     mbE <- try $ makeBucket bucket Nothing
@@ -165,32 +172,54 @@ basicTests = funTestWithBucket "Basic tests" $
 
     let unmodifiedTime = UTCTime (fromGregorian 2010 11 26) 69857
     step "fGetObject an object which is modified now but requesting as un-modified in past, check for exception"
-    resE <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {
+    resE <-
-      gooIfUnmodifiedSince = (Just unmodifiedTime)
+      try $
+        fGetObject
+          bucket
+          "lsb-release"
+          outFile
+          defaultGetObjectOptions
+            { gooIfUnmodifiedSince = (Just unmodifiedTime)
             }
     case resE of
       Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold"
       _ -> return ()
 
     step "fGetObject an object with no matching etag, check for exception"
-    resE1 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {
+    resE1 <-
-      gooIfMatch = (Just "invalid-etag")
+      try $
+        fGetObject
+          bucket
+          "lsb-release"
+          outFile
+          defaultGetObjectOptions
+            { gooIfMatch = (Just "invalid-etag")
             }
     case resE1 of
       Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold"
       _ -> return ()
 
     step "fGetObject an object with no valid range, check for exception"
-    resE2 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {
+    resE2 <-
-      gooRange = (Just $ HT.ByteRangeFromTo 100 200)
+      try $
+        fGetObject
+          bucket
+          "lsb-release"
+          outFile
+          defaultGetObjectOptions
+            { gooRange = (Just $ HT.ByteRangeFromTo 100 200)
             }
     case resE2 of
       Left exn -> liftIO $ exn @?= ServiceErr "InvalidRange" "The requested range is not satisfiable"
       _ -> return ()
 
     step "fGetObject on object with a valid range"
-    fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {
+    fGetObject
-      gooRange = (Just $ HT.ByteRangeFrom 1)
+      bucket
+      "lsb-release"
+      outFile
+      defaultGetObjectOptions
+        { gooRange = (Just $ HT.ByteRangeFrom 1)
         }
 
     step "fGetObject a non-existent object and check for NoSuchKey exception"
@@ -247,8 +276,9 @@ lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $
     step "Retrieve the created object and check size"
     fGetObject bucket object destFile defaultGetObjectOptions
     gotSize <- withNewHandle destFile getFileSize
-      liftIO $ gotSize == Right (Just mb15) @?
+    liftIO $
-        "Wrong file size of put file after getting"
+      gotSize == Right (Just mb15)
+        @? "Wrong file size of put file after getting"
 
     step "Cleanup actions"
     removeObject bucket object
@@ -270,8 +300,9 @@ putObjectSizeTest = funTestWithBucket "PutObject of conduit source with size" $
     destFile <- mkRandFile 0
     fGetObject bucket obj destFile defaultGetObjectOptions
     gotSize <- withNewHandle destFile getFileSize
-      liftIO $ gotSize == Right (Just mb1) @?
+    liftIO $
-        "Wrong file size of put file after getting"
+      gotSize == Right (Just mb1)
+        @? "Wrong file size of put file after getting"
 
     step "Cleanup actions"
     deleteObject bucket obj
@@ -293,8 +324,9 @@ putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no siz
     destFile <- mkRandFile 0
     fGetObject bucket obj destFile defaultGetObjectOptions
     gotSize <- withNewHandle destFile getFileSize
-      liftIO $ gotSize == Right (Just mb70) @?
+    liftIO $
-        "Wrong file size of put file after getting"
+      gotSize == Right (Just mb70)
+        @? "Wrong file size of put file after getting"
 
     step "Cleanup actions"
     deleteObject bucket obj
@@ -306,14 +338,20 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
     step "put 3 objects"
     let expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3", "o4"]
         extractObjectsFromList os =
-              mapM (\t -> case t of
+          mapM
+            ( \t -> case t of
                 ListItemObject o -> Just $ oiObject o
-                       _                -> Nothing) os
+                _ -> Nothing
+            )
+            os
         expectedNonRecList = ["o4", "dir/"]
         extractObjectsAndDirsFromList os =
-              map (\t -> case t of
+          map
+            ( \t -> case t of
                 ListItemObject o -> oiObject o
-                      ListItemPrefix d -> d) os
+                ListItemPrefix d -> d
+            )
+            os
 
     forM_ expectedObjects $
       \obj -> fPutObject bucket obj "/etc/lsb-release" defaultPutObjectOptions
@@ -326,9 +364,11 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
     step "High-level recursive listing of objects"
     objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList
 
-      liftIO $ assertEqual "Objects match failed!"
+    liftIO
-        (Just $ sort expectedObjects) $
+      $ assertEqual
-        extractObjectsFromList objects
+        "Objects match failed!"
+        (Just $ sort expectedObjects)
+      $ extractObjectsFromList objects
 
     step "High-level listing of objects (version 1)"
     itemsV1 <- C.runConduit $ listObjectsV1 bucket Nothing False C..| sinkList
@@ -336,34 +376,50 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
       extractObjectsAndDirsFromList itemsV1
 
     step "High-level recursive listing of objects (version 1)"
-      objectsV1 <- C.runConduit $ listObjectsV1 bucket Nothing True C..|
+    objectsV1 <-
-                   sinkList
+      C.runConduit $
+        listObjectsV1 bucket Nothing True
+          C..| sinkList
 
-      liftIO $ assertEqual "Objects match failed!"
+    liftIO
-        (Just $ sort expectedObjects) $
+      $ assertEqual
-        extractObjectsFromList objectsV1
+        "Objects match failed!"
+        (Just $ sort expectedObjects)
+      $ extractObjectsFromList objectsV1
 
     let expectedPrefListing = ["dir/o1", "dir/dir1/", "dir/dir2/"]
         expectedPrefListingRec = Just ["dir/dir1/o2", "dir/dir2/o3", "dir/o1"]
     step "High-level listing with prefix"
     prefItems <- C.runConduit $ listObjects bucket (Just "dir/") False C..| sinkList
-      liftIO $ assertEqual "Objects/Dirs under prefix match failed!"
+    liftIO
-        expectedPrefListing $ extractObjectsAndDirsFromList prefItems
+      $ assertEqual
+        "Objects/Dirs under prefix match failed!"
+        expectedPrefListing
+      $ extractObjectsAndDirsFromList prefItems
 
     step "High-level listing with prefix recursive"
     prefItemsRec <- C.runConduit $ listObjects bucket (Just "dir/") True C..| sinkList
-      liftIO $ assertEqual "Objects/Dirs under prefix match recursive failed!"
+    liftIO
-        expectedPrefListingRec $ extractObjectsFromList prefItemsRec
+      $ assertEqual
+        "Objects/Dirs under prefix match recursive failed!"
+        expectedPrefListingRec
+      $ extractObjectsFromList prefItemsRec
 
     step "High-level listing with prefix (version 1)"
     prefItemsV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") False C..| sinkList
-      liftIO $ assertEqual "Objects/Dirs under prefix match failed!"
+    liftIO
-        expectedPrefListing $ extractObjectsAndDirsFromList prefItemsV1
+      $ assertEqual
+        "Objects/Dirs under prefix match failed!"
+        expectedPrefListing
+      $ extractObjectsAndDirsFromList prefItemsV1
 
     step "High-level listing with prefix recursive (version 1)"
     prefItemsRecV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") True C..| sinkList
-      liftIO $ assertEqual "Objects/Dirs under prefix match recursive failed!"
+    liftIO
-        expectedPrefListingRec $ extractObjectsFromList prefItemsRecV1
+      $ assertEqual
+        "Objects/Dirs under prefix match recursive failed!"
+        expectedPrefListingRec
+      $ extractObjectsFromList prefItemsRecV1
 
     step "Cleanup actions"
     forM_ expectedObjects $
@@ -377,9 +433,10 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
       liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
 
     step "High-level listing of incomplete multipart uploads"
-      uploads <- C.runConduit $
+    uploads <-
-                 listIncompleteUploads bucket (Just "newmpupload") True C..|
+      C.runConduit $
-                 sinkList
+        listIncompleteUploads bucket (Just "newmpupload") True
+          C..| sinkList
     liftIO $ length uploads @?= 10
 
     step "cleanup"
@@ -400,7 +457,9 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $
       putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5
 
     step "fetch list parts"
-      incompleteParts <- C.runConduit $ listIncompleteParts bucket object uid
+    incompleteParts <-
+      C.runConduit $
+        listIncompleteParts bucket object uid
           C..| sinkList
     liftIO $ length incompleteParts @?= 10
 
@@ -419,17 +478,28 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do
   step "Simple list"
   res <- listObjects' bucket Nothing Nothing Nothing Nothing
   let expectedObjects = sort objects
-      liftIO $ assertEqual "Objects match failed!" expectedObjects
+  liftIO $
+    assertEqual
+      "Objects match failed!"
+      expectedObjects
       (map oiObject $ lorObjects res)
 
   step "Simple list version 1"
   resV1 <- listObjectsV1' bucket Nothing Nothing Nothing Nothing
-      let expected = sort $ map (T.concat .
+  let expected =
-                          ("lsb-release":) .
+        sort $
-                          (\x -> [x]) .
+          map
-                          T.pack .
+            ( T.concat
-                          show) [1..10::Int]
+                . ("lsb-release" :)
-      liftIO $ assertEqual "Objects match failed!" expected
+                . (\x -> [x])
+                . T.pack
+                . show
+            )
+            [1 .. 10 :: Int]
+  liftIO $
+    assertEqual
+      "Objects match failed!"
+      expected
       (map oiObject $ lorObjects' resV1)
 
   step "Cleanup actions"
@@ -443,8 +513,14 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do
     liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")
 
   step "list incomplete multipart uploads"
-      incompleteUploads <- listIncompleteUploads' bucket (Just "newmpupload") Nothing
+  incompleteUploads <-
-                           Nothing Nothing Nothing
+    listIncompleteUploads'
+      bucket
+      (Just "newmpupload")
+      Nothing
+      Nothing
+      Nothing
+      Nothing
   liftIO $ (length $ lurUploads incompleteUploads) @?= 10
 
   step "cleanup"
@@ -479,29 +555,46 @@ presignedUrlFunTest = funTestWithBucket "presigned Url tests" $
     mgr <- liftIO $ NC.newManager NC.tlsManagerSettings
 
     step "PUT object presigned URL - makePresignedUrl"
-    putUrl <- makePresignedUrl 3600 HT.methodPut (Just bucket)
+    putUrl <-
-           (Just obj) (Just "us-east-1") [] []
+      makePresignedUrl
+        3600
+        HT.methodPut
+        (Just bucket)
+        (Just obj)
+        (Just "us-east-1")
+        []
+        []
 
     let size1 = 1000 :: Int64
     inputFile <- mkRandFile size1
 
     -- attempt to upload using the presigned URL
     putResp <- putR size1 inputFile mgr putUrl
-    liftIO $ (NC.responseStatus putResp == HT.status200) @?
+    liftIO $
-      "presigned PUT failed"
+      (NC.responseStatus putResp == HT.status200)
+        @? "presigned PUT failed"
 
     step "GET object presigned URL - makePresignedUrl"
-    getUrl <- makePresignedUrl 3600 HT.methodGet (Just bucket)
+    getUrl <-
-           (Just obj) (Just "us-east-1") [] []
+      makePresignedUrl
+        3600
+        HT.methodGet
+        (Just bucket)
+        (Just obj)
+        (Just "us-east-1")
+        []
+        []
 
     getResp <- getR mgr getUrl
-    liftIO $ (NC.responseStatus getResp == HT.status200) @?
+    liftIO $
-      "presigned GET failed"
+      (NC.responseStatus getResp == HT.status200)
+        @? "presigned GET failed"
 
     -- read content from file to compare with response above
     bs <- C.runConduit $ CB.sourceFile inputFile C..| CB.sinkLbs
-    liftIO $ (bs == NC.responseBody getResp) @?
+    liftIO $
-      "presigned put and get got mismatched data"
+      (bs == NC.responseBody getResp)
+        @? "presigned put and get got mismatched data"
 
     step "PUT object presigned - presignedPutObjectURL"
     putUrl2 <- presignedPutObjectUrl bucket obj2 604800 []
@@ -510,66 +603,71 @@ presignedUrlFunTest = funTestWithBucket "presigned Url tests" $
     testFile <- mkRandFile size2
 
     putResp2 <- putR size2 testFile mgr putUrl2
-    liftIO $ (NC.responseStatus putResp2 == HT.status200) @?
+    liftIO $
-      "presigned PUT failed (presignedPutObjectUrl)"
+      (NC.responseStatus putResp2 == HT.status200)
+        @? "presigned PUT failed (presignedPutObjectUrl)"
 
     step "HEAD object presigned URL - presignedHeadObjectUrl"
     headUrl <- presignedHeadObjectUrl bucket obj2 3600 []
 
-    headResp <- do let req = NC.parseRequest_ $ toS headUrl
+    headResp <- do
+      let req = NC.parseRequest_ $ toS $ decodeUtf8 headUrl
       NC.httpLbs (req {NC.method = HT.methodHead}) mgr
-    liftIO $ (NC.responseStatus headResp == HT.status200) @?
+    liftIO $
-      "presigned HEAD failed (presignedHeadObjectUrl)"
+      (NC.responseStatus headResp == HT.status200)
+        @? "presigned HEAD failed (presignedHeadObjectUrl)"
 
     -- check that header info is accurate
     let h = H.fromList $ NC.responseHeaders headResp
         cLen = H.lookupDefault "0" HT.hContentLength h
-    liftIO $ (cLen == show size2) @? "Head req returned bad content length"
+    liftIO $ (cLen == showBS size2) @? "Head req returned bad content length"
 
     step "GET object presigned URL - presignedGetObjectUrl"
     getUrl2 <- presignedGetObjectUrl bucket obj2 3600 [] []
 
     getResp2 <- getR mgr getUrl2
-    liftIO $ (NC.responseStatus getResp2 == HT.status200) @?
+    liftIO $
-      "presigned GET failed (presignedGetObjectUrl)"
+      (NC.responseStatus getResp2 == HT.status200)
+        @? "presigned GET failed (presignedGetObjectUrl)"
 
     -- read content from file to compare with response above
     bs2 <- C.runConduit $ CB.sourceFile testFile C..| CB.sinkLbs
-    liftIO $ (bs2 == NC.responseBody getResp2) @?
+    liftIO $
-      "presigned put and get got mismatched data (presigned*Url)"
+      (bs2 == NC.responseBody getResp2)
-
+        @? "presigned put and get got mismatched data (presigned*Url)"
 
     mapM_ (removeObject bucket) [obj, obj2]
   where
     putR size filePath mgr url = do
-      let req = NC.parseRequest_ $ toS url
+      let req = NC.parseRequest_ $ toS $ decodeUtf8 url
-      let req' = req { NC.method = HT.methodPut
+      let req' =
-                     , NC.requestBody = NC.requestBodySource size $
+            req
-                                        CB.sourceFile filePath}
+              { NC.method = HT.methodPut,
+                NC.requestBody =
+                  NC.requestBodySource size $
+                    CB.sourceFile filePath
+              }
       NC.httpLbs req' mgr
-
     getR mgr url = do
-      let req = NC.parseRequest_ $ toS url
+      let req = NC.parseRequest_ $ toS $ decodeUtf8 url
       NC.httpLbs req mgr
 
 presignedPostPolicyFunTest :: TestTree
 presignedPostPolicyFunTest = funTestWithBucket "Presigned Post Policy tests" $
   \step bucket -> do
-
     step "presignedPostPolicy basic test"
     now <- liftIO $ Time.getCurrentTime
 
     let key = "presignedPostPolicyTest/myfile"
-        policyConds = [ ppCondBucket bucket
+        policyConds =
-                      , ppCondKey key
+          [ ppCondBucket bucket,
-                      , ppCondContentLengthRange 1 1000
+            ppCondKey key,
-                      , ppCondContentType "application/octet-stream"
+            ppCondContentLengthRange 1 1000,
-                      , ppCondSuccessActionStatus 200
+            ppCondContentType "application/octet-stream",
+            ppCondSuccessActionStatus 200
           ]
-
         expirationTime = Time.addUTCTime 3600 now
         postPolicyE = newPostPolicy expirationTime policyConds
-
         size = 1000 :: Int64
 
     inputFile <- mkRandFile size
@@ -580,15 +678,16 @@ presignedPostPolicyFunTest = funTestWithBucket "Presigned Post Policy tests" $
         (url, formData) <- presignedPostPolicy postPolicy
         -- liftIO (print url) >> liftIO (print formData)
         result <- liftIO $ postForm url formData inputFile
-        liftIO $ (NC.responseStatus result == HT.status200) @?
+        liftIO $
-          "presigned POST failed"
+          (NC.responseStatus result == HT.status200)
+            @? "presigned POST failed"
 
     mapM_ (removeObject bucket) [key]
   where
-
     postForm url formData inputFile = do
-        req <- NC.parseRequest $ toS url
+      req <- NC.parseRequest $ toS $ decodeUtf8 url
-        let parts = map (\(x, y) -> Form.partBS x y) $
+      let parts =
+            map (\(x, y) -> Form.partBS x y) $
               H.toList formData
           parts' = parts ++ [Form.partFile "file" inputFile]
       req' <- Form.formDataBody parts' req
@@ -598,7 +697,6 @@ presignedPostPolicyFunTest = funTestWithBucket "Presigned Post Policy tests" $
 bucketPolicyFunTest :: TestTree
 bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $
   \step bucket -> do
-
     step "bucketPolicy basic test - no policy exception"
     resE <- try $ getBucketPolicy bucket
     case resE of
@@ -631,10 +729,19 @@ bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $
     step "verify bucket policy: (2) get `myobject` anonymously"
     connInfo <- asks mcConnInfo
     let proto = bool "http://" "https://" $ connectIsSecure connInfo
-        url = BS.concat [proto, getHostAddr connInfo, "/", toS bucket,
+        url =
-                         "/", toS obj]
+          BS.concat
-    respE <- liftIO $ (fmap (Right . toS) $ NC.simpleHttp $ toS url) `catch`
+            [ proto,
-               (\(e :: NC.HttpException) -> return $ Left (show e :: Text))
+              getHostAddr connInfo,
+              "/",
+              toUtf8 bucket,
+              "/",
+              toUtf8 obj
+            ]
+    respE <-
+      liftIO $
+        (fmap (Right . toStrictBS) $ NC.simpleHttp $ toS $ decodeUtf8 url)
+          `catch` (\(e :: NC.HttpException) -> return $ Left (show e :: Text))
     case respE of
       Left err -> liftIO $ assertFailure $ show err
       Right s -> liftIO $ s @?= (BS.concat $ replicate 100 "c")
@@ -658,8 +765,9 @@ multipartTest = funTestWithBucket "Multipart Tests" $
     destFile <- mkRandFile 0
     fGetObject bucket obj destFile defaultGetObjectOptions
     gotSize <- withNewHandle destFile getFileSize
-    liftIO $ gotSize == Right (Just mb80) @?
+    liftIO $
-      "Wrong file size of put file after getting"
+      gotSize == Right (Just mb80)
+        @? "Wrong file size of put file after getting"
 
     step "Cleanup actions"
     removeObject bucket obj
@@ -685,7 +793,9 @@ multipartTest = funTestWithBucket "Multipart Tests" $
 
     step "remove ongoing upload"
     removeIncompleteUpload bucket object
-    uploads <- C.runConduit $ listIncompleteUploads bucket (Just object) False
+    uploads <-
+      C.runConduit $
+        listIncompleteUploads bucket (Just object) False
           C..| sinkList
     liftIO $ (null uploads) @? "removeIncompleteUploads didn't complete successfully"
 
@@ -698,8 +808,12 @@ putObjectContentTypeTest = funTestWithBucket "putObject contentType tests" $
 
     step "create server object with content-type"
     inputFile <- mkRandFile size1
-    fPutObject bucket object inputFile defaultPutObjectOptions {
+    fPutObject
-      pooContentType = Just "application/javascript"
+      bucket
+      object
+      inputFile
+      defaultPutObjectOptions
+        { pooContentType = Just "application/javascript"
         }
 
     -- retrieve obj info to check
@@ -710,15 +824,22 @@ putObjectContentTypeTest = funTestWithBucket "putObject contentType tests" $
     liftIO $ assertEqual "Content-Type did not match" (Just "application/javascript") (H.lookup "Content-Type" m)
 
     step "upload object with content-encoding set to identity"
-    fPutObject bucket object inputFile defaultPutObjectOptions {
+    fPutObject
-      pooContentEncoding = Just "identity"
+      bucket
+      object
+      inputFile
+      defaultPutObjectOptions
+        { pooContentEncoding = Just "identity"
         }
 
     oiCE <- headObject bucket object []
     let m' = oiMetadata oiCE
 
     step "Validate content-encoding"
-    liftIO $ assertEqual "Content-Encoding did not match" (Just "identity")
+    liftIO $
+      assertEqual
+        "Content-Encoding did not match"
+        (Just "identity")
         (H.lookup "Content-Encoding" m')
 
     step "Cleanup actions"
@@ -734,8 +855,12 @@ putObjectContentLanguageTest = funTestWithBucket "putObject contentLanguage test
 
     step "create server object with content-language"
     inputFile <- mkRandFile size1
-    fPutObject bucket object inputFile defaultPutObjectOptions {
+    fPutObject
-      pooContentLanguage = Just "en-US"
+      bucket
+      object
+      inputFile
+      defaultPutObjectOptions
+        { pooContentLanguage = Just "en-US"
         }
 
     -- retrieve obj info to check
@@ -743,7 +868,10 @@ putObjectContentLanguageTest = funTestWithBucket "putObject contentLanguage test
     let m = oiMetadata oi
 
     step "Validate content-language"
-    liftIO $ assertEqual "content-language did not match" (Just "en-US")
+    liftIO $
+      assertEqual
+        "content-language did not match"
+        (Just "en-US")
         (H.lookup "Content-Language" m)
     step "Cleanup actions"
 
@@ -759,9 +887,14 @@ putObjectUserMetadataTest = funTestWithBucket "putObject user-metadata test" $
     step "create server object with usermetdata"
     inputFile <- mkRandFile size1
 
-    fPutObject bucket object inputFile defaultPutObjectOptions {
+    fPutObject
-      pooUserMetadata = [ ("x-Amz-meta-mykey1", "myval1")
+      bucket
-                        , ("mykey2", "myval2")
+      object
+      inputFile
+      defaultPutObjectOptions
+        { pooUserMetadata =
+            [ ("x-Amz-meta-mykey1", "myval1"),
+              ("mykey2", "myval2")
             ]
         }
 
@@ -770,7 +903,8 @@ putObjectUserMetadataTest = funTestWithBucket "putObject user-metadata test" $
     oi <- headObject bucket object []
     let m = oiUserMetadata oi
         -- need to do a case-insensitive comparison
-        sortedMeta = sort $ map (\(k, v) -> (T.toLower k, T.toLower v)) $
+        sortedMeta =
+          sort $ map (\(k, v) -> (T.toLower k, T.toLower v)) $
             H.toList m
         ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]
 
@@ -787,9 +921,14 @@ getObjectTest = funTestWithBucket "getObject test" $
         size1 = 100 :: Int64
 
     inputFile <- mkRandFile size1
-    fPutObject bucket object inputFile defaultPutObjectOptions {
+    fPutObject
-      pooUserMetadata = [ ("x-Amz-meta-mykey1", "myval1")
+      bucket
-                        , ("mykey2", "myval2")
+      object
+      inputFile
+      defaultPutObjectOptions
+        { pooUserMetadata =
+            [ ("x-Amz-meta-mykey1", "myval1"),
+              ("mykey2", "myval2")
             ]
         }
 
@@ -798,7 +937,8 @@ getObjectTest = funTestWithBucket "getObject test" $
     gor <- getObject bucket object defaultGetObjectOptions
     let m = oiUserMetadata $ gorObjectInfo gor
         -- need to do a case-insensitive comparison
-        sortedMeta = sort $ map (\(k, v) -> (T.toLower k, T.toLower v)) $
+        sortedMeta =
+          sort $ map (\(k, v) -> (T.toLower k, T.toLower v)) $
             H.toList m
         ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]
 
@@ -827,12 +967,20 @@ putObjectStorageClassTest = funTestWithBucket "putObject storageClass tests" $
     inputFile' <- mkRandFile size1
     inputFile'' <- mkRandFile size0
 
-    fPutObject bucket object inputFile defaultPutObjectOptions {
+    fPutObject
-      pooStorageClass = Just "STANDARD"
+      bucket
+      object
+      inputFile
+      defaultPutObjectOptions
+        { pooStorageClass = Just "STANDARD"
         }
 
-    fPutObject bucket object' inputFile' defaultPutObjectOptions {
+    fPutObject
-      pooStorageClass = Just "REDUCED_REDUNDANCY"
+      bucket
+      object'
+      inputFile'
+      defaultPutObjectOptions
+        { pooStorageClass = Just "REDUCED_REDUNDANCY"
         }
 
     removeObject bucket object
@@ -842,11 +990,20 @@ putObjectStorageClassTest = funTestWithBucket "putObject storageClass tests" $
     let m' = oiMetadata oi'
 
     step "Validate x-amz-storage-class rrs"
-    liftIO $ assertEqual "storageClass did not match" (Just "REDUCED_REDUNDANCY")
+    liftIO $
+      assertEqual
+        "storageClass did not match"
+        (Just "REDUCED_REDUNDANCY")
         (H.lookup "X-Amz-Storage-Class" m')
 
-    fpE <- try $ fPutObject bucket object'' inputFile'' defaultPutObjectOptions {
+    fpE <-
-      pooStorageClass = Just "INVALID_STORAGE_CLASS"
+      try $
+        fPutObject
+          bucket
+          object''
+          inputFile''
+          defaultPutObjectOptions
+            { pooStorageClass = Just "INVALID_STORAGE_CLASS"
             }
     case fpE of
       Left exn -> liftIO $ exn @?= ServiceErr "InvalidStorageClass" "Invalid storage class."
@@ -880,8 +1037,9 @@ copyObjectTests = funTestWithBucket "copyObject related tests" $
 
     let isMTimeDiffOk = abs (diffUTCTime modTime t) < 1.0
 
-    liftIO $ (s == size1 && e == etag && isMTimeDiffOk) @?
+    liftIO $
-      "Copied object did not match expected."
+      (s == size1 && e == etag && isMTimeDiffOk)
+        @? "Copied object did not match expected."
 
     step "cleanup actions"
     removeObject bucket object
@@ -905,9 +1063,15 @@ copyObjectTests = funTestWithBucket "copyObject related tests" $
     let srcInfo' = defaultSourceInfo {srcBucket = bucket, srcObject = srcObj}
         dstInfo' = defaultDestinationInfo {dstBucket = bucket, dstObject = copyObj}
     parts <- forM [1 .. 3] $ \p -> do
-      (etag', _) <- copyObjectPart dstInfo' srcInfo'{
+      (etag', _) <-
-        srcRange = Just $ (,) ((p-1)*mb5) ((p-1)*mb5 + (mb5 - 1))
+        copyObjectPart
-        } uid (fromIntegral p) []
+          dstInfo'
+          srcInfo'
+            { srcRange = Just $ (,) ((p -1) * mb5) ((p -1) * mb5 + (mb5 - 1))
+            }
+          uid
+          (fromIntegral p)
+          []
       return (fromIntegral p, etag')
 
     step "complete multipart"
@@ -953,10 +1117,12 @@ copyObjectTests = funTestWithBucket "copyObject related tests" $
     fPutObject bucket src inputFile' defaultPutObjectOptions
 
     step "copy last 10MiB of object"
-    copyObject defaultDestinationInfo { dstBucket = bucket, dstObject = copyObj } defaultSourceInfo {
+    copyObject
-        srcBucket = bucket
+      defaultDestinationInfo {dstBucket = bucket, dstObject = copyObj}
-      , srcObject = src
+      defaultSourceInfo
-      , srcRange = Just $ (,) (5 * 1024 * 1024) (size - 1)
+        { srcBucket = bucket,
+          srcObject = src,
+          srcRange = Just $ (,) (5 * 1024 * 1024) (size - 1)
         }
 
     step "verify uploaded object"
@@ -973,7 +1139,8 @@ getNPutSSECTest =
     -- disabled anyway.
     isTLSConn <- asks (connectIsSecure . mcConnInfo)
     if isTLSConn
-           then do step "Make an encryption key"
+      then do
+        step "Make an encryption key"
         key <- case mkSSECKey $ BS.pack [0 .. 31] of
           Nothing -> liftIO $ assertFailure "This should not happen"
           Just k -> return k
@@ -1000,10 +1167,10 @@ getNPutSSECTest =
         fGetObject bucket obj dstFile getOpts
 
         gotSize <- withNewHandle dstFile getFileSize
-                   liftIO $ gotSize == Right (Just mb1) @?
+        liftIO $
-                       "Wrong file size of object when getting"
+          gotSize == Right (Just mb1)
+            @? "Wrong file size of object when getting"
 
         step "Cleanup"
         deleteObject bucket obj
-
       else step "Skipping encryption test as server is not using TLS"

test/Network/Minio/API/Test.hs

@@ -15,88 +15,100 @@
 --
 
 module Network.Minio.API.Test
-  ( bucketNameValidityTests
+  ( bucketNameValidityTests,
-  , objectNameValidityTests
+    objectNameValidityTests,
-  , parseServerInfoJSONTest
+    parseServerInfoJSONTest,
-  , parseHealStatusTest
+    parseHealStatusTest,
-  , parseHealStartRespTest
+    parseHealStartRespTest,
-  ) where
+  )
+where
 
 import Data.Aeson (eitherDecode)
+import Lib.Prelude
+import Network.Minio.API
+import Network.Minio.AdminAPI
 import Test.Tasty
 import Test.Tasty.HUnit
 
-import           Lib.Prelude
-
-import           Network.Minio.AdminAPI
-import           Network.Minio.API
-
 assertBool' :: Bool -> Assertion
 assertBool' = assertBool "Test failed!"
 
 bucketNameValidityTests :: TestTree
-bucketNameValidityTests = testGroup "Bucket Name Validity Tests"
+bucketNameValidityTests =
-  [ testCase "Too short 1" $ assertBool' $ not $ isValidBucketName ""
+  testGroup
-  , testCase "Too short 2" $ assertBool' $ not $ isValidBucketName "ab"
+    "Bucket Name Validity Tests"
-  , testCase "Too long 1" $ assertBool' $ not $ isValidBucketName "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+    [ testCase "Too short 1" $ assertBool' $ not $ isValidBucketName "",
-  , testCase "Has upper case" $ assertBool' $ not $ isValidBucketName "ABCD"
+      testCase "Too short 2" $ assertBool' $ not $ isValidBucketName "ab",
-  , testCase "Has punctuation" $ assertBool' $ not $ isValidBucketName "abc,2"
+      testCase "Too long 1" $ assertBool' $ not $ isValidBucketName "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
-  , testCase "Has hyphen at end" $ assertBool' $ not $ isValidBucketName "abc-"
+      testCase "Has upper case" $ assertBool' $ not $ isValidBucketName "ABCD",
-  , testCase "Has consecutive dot" $ assertBool' $ not $ isValidBucketName "abck..eedg"
+      testCase "Has punctuation" $ assertBool' $ not $ isValidBucketName "abc,2",
-  , testCase "Looks like IP" $  assertBool' $ not $ isValidBucketName "10.0.0.1"
+      testCase "Has hyphen at end" $ assertBool' $ not $ isValidBucketName "abc-",
-  , testCase "Valid bucket name 1" $ assertBool' $ isValidBucketName "abcd.pqeq.rea"
+      testCase "Has consecutive dot" $ assertBool' $ not $ isValidBucketName "abck..eedg",
-  , testCase "Valid bucket name 2" $ assertBool' $ isValidBucketName "abcdedgh1d"
+      testCase "Looks like IP" $ assertBool' $ not $ isValidBucketName "10.0.0.1",
-  , testCase "Valid bucket name 3" $ assertBool' $ isValidBucketName "abc-de-dg-h1d"
+      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"
+objectNameValidityTests =
-  [ testCase "Empty name" $ assertBool' $ not $ isValidObjectName ""
+  testGroup
-  , testCase "Has unicode characters" $ assertBool' $ isValidObjectName "日本国"
+    "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" $
+parseServerInfoJSONTest =
-  map (\(tName, tDesc, tfn, tVal) -> testCase tName $ assertBool tDesc $
+  testGroup "Parse MinIO Admin API ServerInfo JSON test" $
-        tfn (eitherDecode tVal :: Either [Char] [ServerInfo])) testCases
+    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)
+    testCases =
-                , ("Erasure Backend", "Verify server info json parsing for Erasure backend", isRight, erasureJSON)
+      [ ("FSBackend", "Verify server info json parsing for FS backend", isRight, fsJSON),
-                , ("Unknown Backend", "Verify server info json parsing for invalid backend", isLeft, invalidJSON)
+        ("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" $
+parseHealStatusTest =
-  map (\(tName, tDesc, tfn, tVal) -> testCase tName $ assertBool tDesc $
+  testGroup "Parse MinIO Admin API HealStatus JSON test" $
-        tfn (eitherDecode tVal :: Either [Char] HealStatus)) testCases
+    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')
+    testCases =
-                , ("Corrupted", "Verify heal result item for erasure backend", isLeft, invalidJSON')
+      [ ("Good", "Verify heal result item for erasure backend", isRight, erasureJSON'),
-                , ("Incorrect Value", "Verify heal result item for erasure backend", isLeft, invalidItemType)
+        ("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" $
+parseHealStartRespTest =
-  map (\(tName, tDesc, tfn, tVal) -> testCase tName $ assertBool tDesc $
+  testGroup "Parse MinIO Admin API HealStartResp JSON test" $
-        tfn (eitherDecode tVal :: Either [Char] HealStartResp)) testCases
+    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)
+    testCases =
-                , ("Missing Token", "Verify heal start response for erasure backend", isLeft, missingTokenJSON)
+      [ ("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

@@ -15,21 +15,21 @@
 --
 
 module Network.Minio.JsonParser.Test
-  (
+  ( jsonParserTests,
-    jsonParserTests
+  )
-  ) where
+where
 
+import Lib.Prelude
+import Network.Minio.Errors
+import Network.Minio.JsonParser
 import Test.Tasty
 import Test.Tasty.HUnit
 import UnliftIO (MonadUnliftIO)
 
-import           Lib.Prelude
-
-import           Network.Minio.Errors
-import           Network.Minio.JsonParser
-
 jsonParserTests :: TestTree
-jsonParserTests = testGroup "JSON Parser Tests"
+jsonParserTests =
+  testGroup
+    "JSON Parser Tests"
     [ testCase "Test parseErrResponseJSON" testParseErrResponseJSON
     ]
 
@@ -43,20 +43,19 @@ testParseErrResponseJSON :: Assertion
 testParseErrResponseJSON = do
   -- 1. Test parsing of an invalid error json.
   parseResE <- tryValidationErr $ parseErrResponseJSON "ClearlyInvalidJSON"
-  when (isRight parseResE) $
+  when (isRight parseResE)
-    assertFailure $ "Parsing should have failed => " ++ show parseResE
+    $ assertFailure
+    $ "Parsing should have failed => " ++ show parseResE
 
   forM_ cases $ \(jsondata, sErr) -> do
     parseErr <- tryValidationErr $ parseErrResponseJSON jsondata
     either assertValidationErr (@?= sErr) parseErr
-
   where
-    cases =  [
+    cases =
-      -- 2. Test parsing of a valid error json.
+      [ -- 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

@@ -15,12 +15,12 @@
 --
 
 module Network.Minio.TestHelpers
-  ( runTestNS
+  ( runTestNS,
-  ) where
+  )
-
+where
-import           Network.Minio.Data
 
 import Lib.Prelude
+import Network.Minio.Data
 
 newtype TestNS = TestNS {testNamespace :: Text}
 
@@ -28,5 +28,6 @@ instance HasSvcNamespace TestNS where
   getSvcNamespace = testNamespace
 
 runTestNS :: ReaderT TestNS m a -> m a
-runTestNS = flip runReaderT $
+runTestNS =
+  flip runReaderT $
     TestNS "http://s3.amazonaws.com/doc/2006-03-01/"

test/Network/Minio/Utils/Test.hs

@@ -15,19 +15,19 @@
 --
 
 module Network.Minio.Utils.Test
-  (
+  ( limitedMapConcurrentlyTests,
-    limitedMapConcurrentlyTests
+  )
-  ) where
+where
 
+import Lib.Prelude
+import Network.Minio.Utils
 import Test.Tasty
 import Test.Tasty.HUnit
 
-import           Lib.Prelude
-
-import           Network.Minio.Utils
-
 limitedMapConcurrentlyTests :: TestTree
-limitedMapConcurrentlyTests = testGroup "limitedMapConcurrently Tests"
+limitedMapConcurrentlyTests =
+  testGroup
+    "limitedMapConcurrently Tests"
     [ testCase "Test with various thread counts" testLMC
     ]
 
@@ -42,6 +42,5 @@ testLMC = do
     -- 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

@@ -13,29 +13,30 @@
 -- See the License for the specific language governing permissions and
 -- limitations under the License.
 --
-
 {-# LANGUAGE QuasiQuotes #-}
-module Network.Minio.XmlGenerator.Test
-  ( xmlGeneratorTests
-  ) where
 
-import           Test.Tasty
+module Network.Minio.XmlGenerator.Test
-import           Test.Tasty.HUnit
+  ( xmlGeneratorTests,
-import           Text.RawString.QQ          (r)
+  )
+where
 
 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)
 
 xmlGeneratorTests :: TestTree
-xmlGeneratorTests = testGroup "XML Generator Tests"
+xmlGeneratorTests =
-  [ testCase "Test mkCreateBucketConfig" testMkCreateBucketConfig
+  testGroup
-  , testCase "Test mkCompleteMultipartUploadRequest" testMkCompleteMultipartUploadRequest
+    "XML Generator Tests"
-  , testCase "Test mkPutNotificationRequest" testMkPutNotificationRequest
+    [ testCase "Test mkCreateBucketConfig" testMkCreateBucketConfig,
-  , testCase "Test mkSelectRequest" testMkSelectRequest
+      testCase "Test mkCompleteMultipartUploadRequest" testMkCompleteMultipartUploadRequest,
+      testCase "Test mkPutNotificationRequest" testMkPutNotificationRequest,
+      testCase "Test mkSelectRequest" testMkSelectRequest
     ]
 
 testMkCreateBucketConfig :: Assertion
@@ -44,7 +45,8 @@ testMkCreateBucketConfig = do
   assertEqual "CreateBucketConfiguration xml should match: " expected $
     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>"
@@ -54,48 +56,63 @@ 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 = toS $ mkPutNotificationRequest ns val
+        result = fromStrictBS $ mkPutNotificationRequest ns val
     ntf <- runExceptT $ runTestNS $ parseNotification result
-    either (\_ -> assertFailure "XML Parse Error!")
+    either
-      (@?= val) ntf
+      (\_ -> assertFailure "XML Parse Error!")
+      (@?= val)
+      ntf
   where
-    cases = [ Notification []
+    cases =
+      [ Notification
+          []
           [ NotificationConfig
               "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4"
               "arn:aws:sns:us-east-1:account-id:s3notificationtopic2"
-                [ReducedRedundancyLostObject, ObjectCreated] defaultFilter
+              [ReducedRedundancyLostObject, ObjectCreated]
+              defaultFilter
           ]
-              []
+          [],
-            , Notification
+        Notification
           [ NotificationConfig
-                "1" "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"
+              "1"
+              "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"
               [ObjectCreatedPut]
-                (Filter $ FilterKey $ FilterRules
+              ( Filter $ FilterKey $
-                  [ FilterRule "prefix" "images/"
+                  FilterRules
-                  , FilterRule "suffix" ".jpg"])
+                    [ FilterRule "prefix" "images/",
-              , NotificationConfig
+                      FilterRule "suffix" ".jpg"
-                "" "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"
+                    ]
-                [ObjectCreated] defaultFilter
+              ),
+            NotificationConfig
+              ""
+              "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"
+              [ObjectCreated]
+              defaultFilter
           ]
           [ NotificationConfig
-                "" "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"
+              ""
-                [ReducedRedundancyLostObject] defaultFilter
+              "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"
+              [ReducedRedundancyLostObject]
+              defaultFilter
           ]
           [ NotificationConfig
-                "ObjectCreatedEvents" "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"
+              "ObjectCreatedEvents"
-                [ObjectCreated] defaultFilter
+              "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"
+              [ObjectCreated]
+              defaultFilter
           ]
       ]
 
@@ -103,41 +120,54 @@ testMkSelectRequest :: Assertion
 testMkSelectRequest = mapM_ assertFn cases
   where
     assertFn (a, b) = assertEqual "selectRequest XML should match: " b $ mkSelectRequest a
-    cases = [ ( SelectRequest "Select * from S3Object" SQL
+    cases =
-                (InputSerialization (Just CompressionTypeGzip)
+      [ ( SelectRequest
-                 (InputFormatCSV $ fileHeaderInfo FileHeaderIgnore
+            "Select * from S3Object"
-                                <> recordDelimiter "\n"
+            SQL
-                                <> fieldDelimiter ","
+            ( InputSerialization
-                                <> quoteCharacter "\""
+                (Just CompressionTypeGzip)
-                                <> quoteEscapeCharacter "\""
+                ( InputFormatCSV $
-                 ))
+                    fileHeaderInfo FileHeaderIgnore
-                (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><QuoteCharacter>&#34;</QuoteCharacter><RecordDelimiter>
+            ( 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><QuoteCharacter>&#34;</QuoteCharacter><RecordDelimiter>
 </RecordDelimiter><FileHeaderInfo>IGNORE</FileHeaderInfo><QuoteEscapeCharacter>&#34;</QuoteEscapeCharacter><FieldDelimiter>,</FieldDelimiter></CSV></InputSerialization><OutputSerialization><CSV><QuoteCharacter>&#34;</QuoteCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter>
 </RecordDelimiter><QuoteEscapeCharacter>&#34;</QuoteEscapeCharacter><FieldDelimiter>,</FieldDelimiter></CSV></OutputSerialization><RequestProgress><Enabled>FALSE</Enabled></RequestProgress></SelectRequest>|]
-              )
+        ),
-            , ( setRequestProgressEnabled False $
+        ( setRequestProgressEnabled False
-                setInputCompressionType CompressionTypeGzip $
+            $ setInputCompressionType CompressionTypeGzip
-                selectRequest "Select * from S3Object" documentJsonInput
+            $ selectRequest
-                (outputJSONFromRecordDelimiter "\n")
+              "Select * from S3Object"
-              , [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>
+              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 $
+        ( setRequestProgressEnabled False
-                setInputCompressionType CompressionTypeNone $
+            $ setInputCompressionType CompressionTypeNone
-                selectRequest "Select * from S3Object" defaultParquetInput
+            $ selectRequest
-                (outputCSVFromProps $ quoteFields QuoteFieldsAsNeeded
+              "Select * from S3Object"
+              defaultParquetInput
+              ( outputCSVFromProps $
+                  quoteFields QuoteFieldsAsNeeded
                     <> recordDelimiter "\n"
                     <> fieldDelimiter ","
                     <> quoteCharacter "\""
-                                   <> quoteEscapeCharacter "\"")
+                    <> 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><QuoteCharacter>&#34;</QuoteCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter>
+              ),
+          [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>NONE</CompressionType><Parquet/></InputSerialization><OutputSerialization><CSV><QuoteCharacter>&#34;</QuoteCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter>
 </RecordDelimiter><QuoteEscapeCharacter>&#34;</QuoteEscapeCharacter><FieldDelimiter>,</FieldDelimiter></CSV></OutputSerialization><RequestProgress><Enabled>FALSE</Enabled></RequestProgress></SelectRequest>|]
         )
       ]

test/Network/Minio/XmlParser/Test.hs

@@ -13,38 +13,39 @@
 -- 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 Data.HashMap.Strict as H
 import Data.Time (fromGregorian)
+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)
 
-import           Lib.Prelude
-
-import           Network.Minio.Data
-import           Network.Minio.Errors
-import           Network.Minio.TestHelpers
-import           Network.Minio.XmlParser
-
 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 parseListObjectsV1Response" testParseListObjectsV1Result
+      testCase "Test parseNewMultipartUpload" testParseNewMultipartUpload,
-  , testCase "Test parseListUploadsresponse" testParseListIncompleteUploads
+      testCase "Test parseListObjectsResponse" testParseListObjectsResult,
-  , testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse
+      testCase "Test parseListObjectsV1Response" testParseListObjectsV1Result,
-  , testCase "Test parseListPartsResponse" testParseListPartsResponse
+      testCase "Test parseListUploadsresponse" testParseListIncompleteUploads,
-  , testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse
+      testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse,
-  , testCase "Test parseNotification" testParseNotification
+      testCase "Test parseListPartsResponse" testParseListPartsResponse,
-  , testCase "Test parseSelectProgress" testParseSelectProgress
+      testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse,
+      testCase "Test parseNotification" testParseNotification,
+      testCase "Test parseSelectProgress" testParseSelectProgress
     ]
 
 tryValidationErr :: (MonadUnliftIO m) => m a -> m (Either MErrV a)
@@ -61,35 +62,34 @@ testParseLocation :: Assertion
 testParseLocation = do
   -- 1. Test parsing of an invalid location constraint xml.
   parseResE <- tryValidationErr $ parseLocation "ClearlyInvalidXml"
-  when (isRight parseResE) $
+  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\"?>\
           \<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/\"/>",
           "us-east-1"
         )
       ]
 
-
 testParseNewMultipartUpload :: Assertion
 testParseNewMultipartUpload = do
   forM_ cases $ \(xmldata, expectedUploadId) -> do
     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>\
@@ -109,8 +109,8 @@ 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/>\
@@ -126,7 +126,6 @@ testParseListObjectsResult = do
         \<StorageClass>STANDARD</StorageClass>\
         \</Contents>\
         \</ListBucketResult>"
-
       expectedListResult = ListObjectsResult True (Just "opaque") [object1] []
       object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 H.empty H.empty
       modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12
@@ -136,8 +135,8 @@ testParseListObjectsResult = do
 
 testParseListObjectsV1Result :: Assertion
 testParseListObjectsV1Result = 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/>\
@@ -153,7 +152,6 @@ testParseListObjectsV1Result = do
         \<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
@@ -163,8 +161,8 @@ testParseListObjectsV1Result = do
 
 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/>\
@@ -203,11 +201,10 @@ testParseListIncompleteUploads = do
   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/\">\
         \<Location>http://Example-Bucket.s3.amazonaws.com/Example-Object</Location>\
         \<Bucket>Example-Bucket</Bucket>\
@@ -221,8 +218,8 @@ testParseCompleteMultipartUploadResponse = do
 
 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/\">\
         \<Bucket>example-bucket</Bucket>\
         \<Key>example-object</Key>\
@@ -253,7 +250,6 @@ testParseListPartsResponse = do
         \<Size>10485760</Size>\
         \</Part>\
         \</ListPartsResult>"
-
       expectedListResult = ListPartsResult True (Just 3) [part1, part2]
       part1 = ObjectPartInfo 2 "\"7778aef83f66abc1fa1e8477f296d394\"" 10485760 modifiedTime1
       modifiedTime1 = flip UTCTime 74914 $ fromGregorian 2010 11 10
@@ -265,21 +261,26 @@ testParseListPartsResponse = do
 
 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/\">\
             \<LastModified>2009-10-28T22:32:00.000Z</LastModified>\
             \<ETag>\"9b2cf535f27731c974343645a3985328\"</ETag>\
             \</CopyObjectResult>",
             ( "\"9b2cf535f27731c974343645a3985328\"",
-               UTCTime (fromGregorian 2009 10 28) 81120))
+              UTCTime (fromGregorian 2009 10 28) 81120
-            , ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
+            )
+          ),
+          ( "<?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>",
             ( "\"9b2cf535f27731c974343645a3985328\"",
-              UTCTime (fromGregorian 2009 10 28) 81120))]
+              UTCTime (fromGregorian 2009 10 28) 81120
+            )
+          )
+        ]
 
   forM_ cases $ \(xmldata, (etag, modTime)) -> do
     parseResult <- runExceptT $ runTestNS $ parseCopyObjectResponse xmldata
@@ -287,8 +288,8 @@ testParseCopyObjectResponse = do
 
 testParseNotification :: Assertion
 testParseNotification = do
-  let
+  let cases =
-    cases = [ ("<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+        [ ( "<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>\
@@ -296,14 +297,17 @@ testParseNotification = do
             \    <Event>s3:ObjectCreated:*</Event>\
             \  </TopicConfiguration>\
             \</NotificationConfiguration>",
-               Notification []
+            Notification
+              []
               [ NotificationConfig
                   "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4"
                   "arn:aws:sns:us-east-1:account-id:s3notificationtopic2"
-                  [ReducedRedundancyLostObject, ObjectCreated] defaultFilter
+                  [ReducedRedundancyLostObject, ObjectCreated]
+                  defaultFilter
               ]
-                [])
+              []
-            , ("<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\
+          ),
+          ( "<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>\
@@ -335,24 +339,36 @@ testParseNotification = do
             \    <Event>s3:ObjectCreated:*</Event>\
             \  </QueueConfiguration>)\
             \</NotificationConfiguration>",
-               Notification [ NotificationConfig
+            Notification
-                              "1" "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"
+              [ NotificationConfig
+                  "1"
+                  "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"
                   [ObjectCreatedPut]
-                              (Filter $ FilterKey $ FilterRules
+                  ( Filter $ FilterKey $
+                      FilterRules
                         [ FilterRule "prefix" "images/",
-                                FilterRule "suffix" ".jpg"])
+                          FilterRule "suffix" ".jpg"
-                            , NotificationConfig
+                        ]
-                              "" "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"
+                  ),
-                              [ObjectCreated] defaultFilter
+                NotificationConfig
+                  ""
+                  "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"
+                  [ObjectCreated]
+                  defaultFilter
               ]
               [ NotificationConfig
-                              "" "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"
+                  ""
-                              [ReducedRedundancyLostObject] defaultFilter
+                  "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"
+                  [ReducedRedundancyLostObject]
+                  defaultFilter
               ]
               [ NotificationConfig
-                              "ObjectCreatedEvents" "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"
+                  "ObjectCreatedEvents"
-                              [ObjectCreated] defaultFilter
+                  "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"
-                            ])
+                  [ObjectCreated]
+                  defaultFilter
+              ]
+          )
         ]
 
   forM_ cases $ \(xmldata, val) -> do
@@ -362,18 +378,23 @@ testParseNotification = do
 -- | Tests parsing of both progress and stats
 testParseSelectProgress :: Assertion
 testParseSelectProgress = do
-    let cases = [ ([r|<?xml version="1.0" encoding="UTF-8"?>
+  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)
+</Progress>|],
-                , ([r|<?xml version="1.0" encoding="UTF-8"?>
+            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)
+</Stats>|],
+            Progress 512 1024 1024
+          )
         ]
 
   forM_ cases $ \(xmldata, progress) -> do

test/Spec.hs

@@ -14,14 +14,9 @@
 -- limitations under the License.
 --
 
-import           Test.Tasty
-import           Test.Tasty.QuickCheck           as QC
-
 import qualified Data.ByteString as B
 import qualified Data.List as L
-
 import Lib.Prelude
-
 import Network.Minio.API.Test
 import Network.Minio.CopyObject
 import Network.Minio.Data
@@ -29,6 +24,8 @@ import           Network.Minio.PutObject
 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
@@ -51,70 +48,68 @@ 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 ..]
-
               consPairs [] = []
               consPairs [_] = []
               consPairs (a : (b : c)) = (a, b) : (consPairs (b : c))
-
               -- check `offs` is monotonically increasing.
               isOffsetsAsc = all (\(a, b) -> a < b) $ 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)
-
               -- 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 (\s -> s > 0) (drop (nparts - 1) sizes)
                     | nparts == 1 -> -- size may be 0 here.
                       maybe True (\x -> x >= 0 && x <= minPartSize) $
                         headMay sizes
                     | otherwise -> False
-
+           in n < 0
-          in n < 0 ||
+                || ( isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk
-             (isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk &&
+                       && isSizesConstantExceptLast
-              isSizesConstantExceptLast && isMinPartSizeOk)
+                       && isMinPartSizeOk
-
+                   ),
-  , QC.testProperty "selectCopyRanges:" $
+      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
-
               -- each pair is >=64MiB except last, and all those parts
               -- have same size.
               initSizes = maybe [] (map (\(a, b) -> b - a + 1)) $ initMay pairs
-          isPartSizesOk = all (>= minPartSize) initSizes &&
+              isPartSizesOk =
-                          maybe True (\k -> all (== k) initSizes)
+                all (>= minPartSize) initSizes
+                  && maybe
+                    True
+                    (\k -> all (== k) initSizes)
                     (headMay 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
-
+                  && and (map (\(a, b) -> a == b + 1) $ zip fsts snds)
-      in start < 0 || start > end ||
+           in start < 0 || start > end
-         (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts)
+                || (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts),
-
+      QC.testProperty "mkSSECKey:" $
-  , QC.testProperty "mkSSECKey:" $
+        \w8s ->
-    \w8s -> let bs = B.pack w8s
+          let bs = B.pack w8s
               r = mkSSECKey bs
            in case r of
                 Just _ -> B.length bs == 32
@@ -122,11 +117,15 @@ qcProps = testGroup "(checked by QuickCheck)"
     ]
 
 unitTests :: TestTree
-unitTests = testGroup "Unit tests" [ xmlGeneratorTests, xmlParserTests
+unitTests =
-                                   , bucketNameValidityTests
+  testGroup
-                                   , objectNameValidityTests
+    "Unit tests"
-                                   , parseServerInfoJSONTest
+    [ xmlGeneratorTests,
-                                   , parseHealStatusTest
+      xmlParserTests,
-                                   , parseHealStartRespTest
+      bucketNameValidityTests,
-                                   , limitedMapConcurrentlyTests
+      objectNameValidityTests,
+      parseServerInfoJSONTest,
+      parseHealStatusTest,
+      parseHealStartRespTest,
+      limitedMapConcurrentlyTests
     ]