packages feed

minio-hs 1.5.2 → 1.5.3

raw patch · 57 files changed

+5977/−5155 lines, 57 filesdep ~protoludedep ~unliftiodep ~unliftio-coresetup-changed

Dependency ranges changed: protolude, unliftio, unliftio-core

Files

CHANGELOG.md view
@@ -1,6 +1,13 @@ Changelog ========== +## Version 1.5.3++* Fix windows build+* Fix support for Yandex Storage (#147)+* Fix for HEAD requests to S3/Minio (#155)+* Bump up some dependencies, new code formatting, Github CI, example fixes and other minor improvements.+ ## Version 1.5.2  * Fix region `us-west-2` for AWS S3 (#139)
Setup.hs view
@@ -15,4 +15,5 @@ --  import Distribution.Simple+ main = defaultMain
examples/BucketExists.hs view
@@ -16,20 +16,17 @@ -- 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           Prelude+import Control.Monad.IO.Class (liftIO)+import Network.Minio+import Prelude  -- | The following example uses minio's play server at -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---- main :: IO () main = do   let bucket = "missingbucket"@@ -39,5 +36,5 @@     liftIO $ putStrLn $ "Does " ++ show bucket ++ " exist? - " ++ show foundBucket    case res1 of-    Left e   -> putStrLn $ "bucketExists failed." ++ show e+    Left e -> putStrLn $ "bucketExists failed." ++ show e     Right () -> return ()
examples/CopyObject.hs view
@@ -16,42 +16,40 @@ -- See the License for the specific language governing permissions and -- limitations under the License. --- {-# LANGUAGE OverloadedStrings #-}-import           Network.Minio -import           UnliftIO.Exception (catch, throwIO)+import Network.Minio+import UnliftIO.Exception (catch, throwIO)  -- | The following example uses minio's play server at -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---- main :: IO () main = do-  let-      bucket = "test"+  let 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) (-      \e -> case e of-              BucketAlreadyOwnedByYou -> return ()-              _ -> throwIO e+    catch+      (makeBucket bucket Nothing)+      ( \e -> case e of+          BucketAlreadyOwnedByYou -> return ()+          _ -> throwIO e       )      -- 2. Upload a file to bucket/object.     fPutObject bucket object localFile defaultPutObjectOptions      -- 3. Copy bucket/object to bucket/objectCopy.-    copyObject defaultDestinationInfo {dstBucket = bucket, dstObject = objectCopy}-               defaultSourceInfo { srcBucket = bucket , srcObject = object }+    copyObject+      defaultDestinationInfo {dstBucket = bucket, dstObject = objectCopy}+      defaultSourceInfo {srcBucket = bucket, srcObject = object}    case res1 of-    Left e   -> putStrLn $ "copyObject failed." ++ show e+    Left e -> putStrLn $ "copyObject failed." ++ show e     Right () -> putStrLn "copyObject succeeded."
examples/FileUploader.hs view
@@ -16,40 +16,40 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -----{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-import           Network.Minio -import           Data.Monoid           ((<>))-import           Data.Text             (pack)-import           Options.Applicative-import           System.FilePath.Posix-import           UnliftIO              (throwIO, try)--import           Prelude+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 -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---  -- optparse-applicative package based command-line parsing. fileNameArgs :: Parser FilePath-fileNameArgs = strArgument-               (metavar "FILENAME"-                <> help "Name of file to upload to AWS S3 or a MinIO server")+fileNameArgs =+  strArgument+    ( metavar "FILENAME"+        <> help "Name of file to upload to AWS S3 or a MinIO server"+    )  cmdParser :: ParserInfo FilePath-cmdParser = info-            (helper <*> fileNameArgs)-            (fullDesc-             <> progDesc "FileUploader"-             <> header-             "FileUploader - a simple file-uploader program using minio-hs")+cmdParser =+  info+    (helper <*> fileNameArgs)+    ( fullDesc+        <> progDesc "FileUploader"+        <> header+          "FileUploader - a simple file-uploader program using minio-hs"+    )  main :: IO () main = do@@ -64,12 +64,12 @@     bErr <- try $ makeBucket bucket Nothing     case bErr of       Left BucketAlreadyOwnedByYou -> return ()-      Left e                       -> throwIO e-      Right _                      -> return ()+      Left e -> throwIO e+      Right _ -> return ()      -- Upload filepath to bucket; object is derived from filepath.     fPutObject bucket object filepath defaultPutObjectOptions    case res of-    Left e   -> putStrLn $ "file upload failed due to " ++ (show e)+    Left e -> putStrLn $ "file upload failed due to " ++ (show e)     Right () -> putStrLn "file upload succeeded."
examples/GetConfig.hs view
@@ -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+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 view
@@ -16,31 +16,26 @@ -- 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 as C import qualified Data.Conduit.Binary as CB--import           Prelude+import Network.Minio+import Prelude  -- | The following example uses minio's play server at -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---- main :: IO () main = do-  let-      bucket = "my-bucket"+  let bucket = "my-bucket"       object = "my-object"   res <- runMinio minioPlayCI $ do     src <- getObject bucket object defaultGetObjectOptions     C.connect (gorObjectStream src) $ CB.sinkFileCautious "/tmp/my-object"    case res of-    Left e  -> putStrLn $ "getObject failed." ++ (show e)+    Left e -> putStrLn $ "getObject failed." ++ (show e)     Right _ -> putStrLn "getObject succeeded."
examples/HeadObject.hs view
@@ -16,28 +16,25 @@ -- 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+import Network.Minio+import Network.Minio.S3API+import Prelude  -- | The following example uses minio's play server at -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---- main :: IO () main = do-  let-      bucket = "test"+  let bucket = "test"       object = "passwd"-  res <- runMinio minioPlayCI $-    headObject bucket object []+  res <-+    runMinio minioPlayCI $+      headObject bucket object []    case res of-    Left e        -> putStrLn $ "headObject failed." ++ show e+    Left e -> putStrLn $ "headObject failed." ++ show e     Right objInfo -> putStrLn $ "headObject succeeded." ++ show objInfo
examples/Heal.hs view
@@ -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+import Network.Minio+import Network.Minio.AdminAPI+import Prelude  main :: IO () main = do   res <- runMinio minioPlayCI $     do-      hsr <- startHeal Nothing Nothing HealOpts { hoRecursive = True-                                                , hoDryRun = False-                                                }+      hsr <-+        startHeal+          Nothing+          Nothing+          HealOpts+            { hoRecursive = True,+              hoDryRun = False+            }       getHealStatus Nothing Nothing (hsrClientToken hsr)   print res
examples/ListBuckets.hs view
@@ -16,19 +16,17 @@ -- 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           Prelude+import Control.Monad.IO.Class (liftIO)+import Network.Minio+import Prelude  -- | The following example uses minio's play server at -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---  -- This example list buckets that belongs to the user and returns -- region of the first bucket returned.
examples/ListIncompleteUploads.hs view
@@ -16,38 +16,36 @@ -- See the License for the specific language governing permissions and -- limitations under the License. --- {-# LANGUAGE OverloadedStrings #-}-import           Network.Minio -import           Conduit-import           Prelude+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-    bucket = "test"+  let bucket = "test"    -- Performs a recursive listing of incomplete uploads under bucket "test"   -- on a local minio server.-  res <- runMinio minioPlayCI $-    runConduit $ listIncompleteUploads bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))+  res <-+    runMinio minioPlayCI+      $ runConduit+      $ listIncompleteUploads bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))   print res -  {--    Following is the output of the above program on a local MinIO server.+{-+  Following is the output of the above program on a local MinIO server. -    Right [UploadInfo { uiKey = "go1.6.2.linux-amd64.tar.gz"-                      , uiUploadId = "063eb592-bdd7-4a0c-be48-34fb3ceb63e2"-                      , uiInitTime = 2017-03-01 10:16:25.698 UTC-                      , uiSize = 17731794-                      }-          ]-  -}+  Right [UploadInfo { uiKey = "go1.6.2.linux-amd64.tar.gz"+                    , uiUploadId = "063eb592-bdd7-4a0c-be48-34fb3ceb63e2"+                    , uiInitTime = 2017-03-01 10:16:25.698 UTC+                    , uiSize = 17731794+                    }+        ]+-}
examples/ListObjects.hs view
@@ -16,33 +16,31 @@ -- See the License for the specific language governing permissions and -- limitations under the License. --- {-# LANGUAGE OverloadedStrings #-}-import           Network.Minio -import           Conduit-import           Prelude-+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-    bucket = "test"+  let bucket = "test"    -- Performs a recursive listing of all objects under bucket "test"   -- on play.min.io.-  res <- runMinio minioPlayCI $-    runConduit $ listObjects bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))+  res <-+    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. -    Right [ObjectInfo {oiObject = "ADVANCED.png", oiModTime = 2017-02-10 05:33:24.816 UTC, oiETag = "\"a69f3af6bbb06fe1d42ac910ec30482f\"", oiSize = 94026},ObjectInfo {oiObject = "obj", oiModTime = 2017-02-10 08:49:26.777 UTC, oiETag = "\"715a872a253a3596652c1490081b4b6a-1\"", oiSize = 15728640}]-  -}+{-+  Following is the output of the above program on a local MinIO server.++  Right [ObjectInfo {oiObject = "ADVANCED.png", oiModTime = 2017-02-10 05:33:24.816 UTC, oiETag = "\"a69f3af6bbb06fe1d42ac910ec30482f\"", oiSize = 94026},ObjectInfo {oiObject = "obj", oiModTime = 2017-02-10 08:49:26.777 UTC, oiETag = "\"715a872a253a3596652c1490081b4b6a-1\"", oiSize = 15728640}]+-}
examples/MakeBucket.hs view
@@ -16,24 +16,21 @@ -- See the License for the specific language governing permissions and -- limitations under the License. ---- {-# LANGUAGE OverloadedStrings #-}-import           Network.Minio -import           Prelude+import Network.Minio+import Prelude  -- | The following example uses minio's play server at -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---- main :: IO () main = do   let bucket = "my-bucket"-  res <- runMinio minioPlayCI $-    -- N B the region provided for makeBucket is optional.-    makeBucket bucket (Just "us-east-1")+  res <-+    runMinio minioPlayCI $+      -- N B the region provided for makeBucket is optional.+      makeBucket bucket (Just "us-east-1")   print res
examples/PresignedGetObject.hs view
@@ -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 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 qualified Data.Text.Encoding as E+import Network.Minio  -- | The following example uses minio's play server at -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---- main :: IO () main = do-  let-    bucket = "my-bucket"-    object = "my-object"-    kb15 = 15*1024--    -- Set query parameter to modify content disposition response-    -- header-    queryParam = [("response-content-disposition",-                   Just "attachment; filename=\"your-filename.txt\"")]+  let bucket = "my-bucket"+      object = "my-object"+      kb15 = 15 * 1024+      -- Set query parameter to modify content disposition response+      -- header+      queryParam =+        [ ( "response-content-disposition",+            Just "attachment; filename=\"your-filename.txt\""+          )+        ]    res <- runMinio minioPlayCI $ do     liftIO $ B.putStrLn "Upload a file that we will fetch with a presigned URL..."@@ -61,23 +59,28 @@     -- Generate a URL with 7 days expiry time - note that the headers     -- used above must be added to the request with the signed URL     -- generated.-    url <- presignedGetObjectUrl "my-bucket" "my-object" (7*24*3600)-           queryParam headers+    url <-+      presignedGetObjectUrl+        "my-bucket"+        "my-object"+        (7 * 24 * 3600)+        queryParam+        headers      return (headers, etag, url)    case res of     Left e -> putStrLn $ "presignedPutObject URL failed." ++ show e     Right (headers, _, url) -> do-       -- We generate a curl command to demonstrate usage of the signed       -- URL.-      let-        hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"]-        curlCmd = B.intercalate " " $-                  ["curl --fail"] ++ map hdrOpt headers ++-                  ["-o /tmp/myfile", B.concat ["'", url, "'"]]+      let hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"]+          curlCmd =+            B.intercalate " " $+              ["curl --fail"] ++ map hdrOpt headers+                ++ ["-o /tmp/myfile", B.concat ["'", url, "'"]] -      putStrLn $ "The following curl command would use the presigned " ++-        "URL to fetch the object and write it to \"/tmp/myfile\":"+      putStrLn $+        "The following curl command would use the presigned "+          ++ "URL to fetch the object and write it to \"/tmp/myfile\":"       B.putStrLn curlCmd
examples/PresignedPostPolicy.hs view
@@ -16,47 +16,43 @@ -- 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 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 qualified Data.HashMap.Strict as H+import qualified Data.Text.Encoding as Enc+import qualified Data.Time as Time+import Network.Minio  -- | The following example uses minio's play server at -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---- main :: IO () main = do   now <- Time.getCurrentTime-  let-    bucket = "my-bucket"-    object = "photos/my-object"--    -- set an expiration time of 10 days-    expireTime = Time.addUTCTime (3600 * 24 * 10) now--    -- create a policy with expiration time and conditions - since the-    -- conditions are validated, newPostPolicy returns an Either value-    policyE = newPostPolicy expireTime-              [ -- set the object name condition-                ppCondKey object-                -- set the bucket name condition-              , ppCondBucket bucket-                -- set the size range of object as 1B to 10MiB-              , ppCondContentLengthRange 1 (10*1024*1024)-                -- set content type as jpg image-              , ppCondContentType "image/jpeg"-                -- on success set the server response code to 200-              , ppCondSuccessActionStatus 200-              ]+  let bucket = "my-bucket"+      object = "photos/my-object"+      -- set an expiration time of 10 days+      expireTime = Time.addUTCTime (3600 * 24 * 10) now+      -- create a policy with expiration time and conditions - since the+      -- conditions are validated, newPostPolicy returns an Either value+      policyE =+        newPostPolicy+          expireTime+          [ -- set the object name condition+            ppCondKey object,+            -- set the bucket name condition+            ppCondBucket bucket,+            -- set the size range of object as 1B to 10MiB+            ppCondContentLengthRange 1 (10 * 1024 * 1024),+            -- set content type as jpg image+            ppCondContentType "image/jpeg",+            -- on success set the server response code to 200+            ppCondSuccessActionStatus 200+          ]    case policyE of     Left err -> putStrLn $ show err@@ -66,11 +62,16 @@          -- a curl command is output to demonstrate using the generated         -- URL and form-data-        let-          formFn (k, v) = B.concat ["-F ", Enc.encodeUtf8 k, "=",-                                    "'", v, "'"]-          formOptions = B.intercalate " " $ map formFn $ H.toList formData-+        let formFn (k, v) =+              B.concat+                [ "-F ",+                  Enc.encodeUtf8 k,+                  "=",+                  "'",+                  v,+                  "'"+                ]+            formOptions = B.intercalate " " $ map formFn $ H.toList formData          return $ B.intercalate " " $           ["curl", formOptions, "-F file=@/tmp/photo.jpg", url]
examples/PresignedPutObject.hs view
@@ -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 Data.CaseInsensitive (original)+import Network.Minio  -- | The following example uses minio's play server at -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---- main :: IO () main = do-  let-    -- Use headers to set user-metadata - note that this header will-    -- need to be set when the URL is used to make an upload.-    headers = [("x-amz-meta-url-creator",-                "minio-hs-presigned-put-example")]+  let -- Use headers to set user-metadata - note that this header will+      -- need to be set when the URL is used to make an upload.+      headers =+        [ ( "x-amz-meta-url-creator",+            "minio-hs-presigned-put-example"+          )+        ]   res <- runMinio minioPlayCI $ do-     -- generate a URL with 7 days expiry time-    presignedPutObjectUrl "my-bucket" "my-object" (7*24*3600) headers+    presignedPutObjectUrl "my-bucket" "my-object" (7 * 24 * 3600) headers    case res of     Left e -> putStrLn $ "presignedPutObject URL failed." ++ show e     Right url -> do-       -- We generate a curl command to demonstrate usage of the signed       -- URL.-      let-        hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"]-        curlCmd = B.intercalate " " $-                  ["curl "] ++ map hdrOpt headers ++-                  ["-T /tmp/myfile", B.concat ["'", url, "'"]]+      let hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"]+          curlCmd =+            B.intercalate " " $+              ["curl "] ++ map hdrOpt headers+                ++ ["-T /tmp/myfile", B.concat ["'", url, "'"]] -      putStrLn $ "The following curl command would use the presigned " ++-        "URL to upload the file at \"/tmp/myfile\":"+      putStrLn $+        "The following curl command would use the presigned "+          ++ "URL to upload the file at \"/tmp/myfile\":"       B.putStrLn curlCmd
examples/PutObject.hs view
@@ -16,39 +16,36 @@ -- 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           Prelude+import Network.Minio+import Prelude  -- | The following example uses minio's play server at -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---- main :: IO () main = do-  let-      bucket = "test"+  let 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 $-    putObject bucket object (CC.repeat "a") (Just kb15) defaultPutObjectOptions+  res1 <-+    runMinio minioPlayCI $+      putObject bucket object (CC.repeat "a") (Just kb15) defaultPutObjectOptions   case res1 of-    Left e   -> putStrLn $ "putObject failed." ++ show e+    Left e -> putStrLn $ "putObject failed." ++ show e     Right () -> putStrLn "putObject succeeded."    -- Eg 2. Upload a file using fPutObject with default options.-  res2 <- runMinio minioPlayCI $-    fPutObject bucket object localFile defaultPutObjectOptions+  res2 <-+    runMinio minioPlayCI $+      fPutObject bucket object localFile defaultPutObjectOptions   case res2 of-    Left e   -> putStrLn $ "fPutObject failed." ++ show e+    Left e -> putStrLn $ "fPutObject failed." ++ show e     Right () -> putStrLn "fPutObject succeeded."
examples/RemoveBucket.hs view
@@ -16,23 +16,18 @@ -- See the License for the specific language governing permissions and -- limitations under the License. ---- {-# LANGUAGE OverloadedStrings #-}-import           Network.Minio -import           Prelude+import Network.Minio+import Prelude  -- | The following example uses minio's play server at -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---- main :: IO () main = do-  let-      bucket = "my-bucket"+  let bucket = "my-bucket"   res <- runMinio minioPlayCI $ removeBucket bucket   print res
examples/RemoveIncompleteUpload.hs view
@@ -16,27 +16,24 @@ -- See the License for the specific language governing permissions and -- limitations under the License. --- {-# LANGUAGE OverloadedStrings #-}-import           Network.Minio -import           Prelude+import Network.Minio+import Prelude  -- | The following example uses minio's play server at -- https://play.min.io.  The endpoint and associated -- credentials are provided via the libary constant, -- -- > minioPlayCI :: ConnectInfo---- main :: IO () main = do-  let-    bucket = "mybucket"-    object = "myobject"+  let bucket = "mybucket"+      object = "myobject" -  res <- runMinio minioPlayCI $-           removeIncompleteUpload bucket object+  res <-+    runMinio minioPlayCI $+      removeIncompleteUpload bucket object    case res of     Left _ -> putStrLn $ "Failed to remove " ++ show bucket ++ "/" ++ show object
examples/RemoveObject.hs view
@@ -16,20 +16,19 @@ -- See the License for the specific language governing permissions and -- limitations under the License. --- {-# LANGUAGE OverloadedStrings #-} -import           Network.Minio-import           Prelude+import Network.Minio+import Prelude  main :: IO () main = do-  let-    bucket = "mybucket"-    object = "myobject"+  let bucket = "mybucket"+      object = "myobject" -  res <- runMinio minioPlayCI $-           removeObject bucket object+  res <-+    runMinio minioPlayCI $+      removeObject bucket object    case res of     Left _ -> putStrLn $ "Failed to remove " ++ show bucket ++ "/" ++ show object
examples/SelectObject.hs view
@@ -16,34 +16,32 @@ -- 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           Prelude+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"-               <> "James,San Jose,76\n"-               <> "Alicia,San Leandro,88\n"-               <> "Mark,San Carlos,90\n"--    res <- runMinio minioPlayCI $ do+  let bucket = "selectbucket"+      object = "1.csv"+      content =+        "Name,Place,Temperature\n"+          <> "James,San Jose,76\n"+          <> "Alicia,San Leandro,88\n"+          <> "Mark,San Carlos,90\n" -        exists <- bucketExists bucket-        when (not exists) $-            makeBucket bucket Nothing+  res <- runMinio minioPlayCI $ do+    exists <- bucketExists bucket+    when (not exists) $+      makeBucket bucket Nothing -        C.liftIO $ putStrLn "Uploading csv object"-        putObject bucket object (C.sourceLazy content) Nothing defaultPutObjectOptions+    C.liftIO $ putStrLn "Uploading csv object"+    putObject bucket object (C.sourceLazy content) Nothing defaultPutObjectOptions -        let sr = selectRequest "Select * from s3object" defaultCsvInput defaultCsvOutput-        res <- selectObjectContent bucket object sr-        C.runConduit $ res C..| getPayloadBytes C..| C.stdoutC-    print res+    let sr = selectRequest "Select * from s3object" defaultCsvInput defaultCsvOutput+    res <- selectObjectContent bucket object sr+    C.runConduit $ res C..| getPayloadBytes C..| C.stdoutC+  print res
examples/ServerInfo.hs view
@@ -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+import Network.Minio+import Network.Minio.AdminAPI+import Prelude  main :: IO () main = do-  res <- runMinio minioPlayCI $-    getServerInfo+  res <-+    runMinio minioPlayCI $+      getServerInfo   print res
examples/ServiceSendRestart.hs view
@@ -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+import Network.Minio+import Network.Minio.AdminAPI+import Prelude  main :: IO () main = do-  res <- runMinio minioPlayCI $-    serviceSendAction ServiceActionRestart+  res <-+    runMinio minioPlayCI $+      serviceSendAction ServiceActionRestart   print res
examples/ServiceSendStop.hs view
@@ -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+import Network.Minio+import Network.Minio.AdminAPI+import Prelude  main :: IO () main = do-  res <- runMinio minioPlayCI $-    serviceSendAction ServiceActionStop+  res <-+    runMinio minioPlayCI $+      serviceSendAction ServiceActionStop   print res
examples/ServiceStatus.hs view
@@ -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+import Network.Minio+import Network.Minio.AdminAPI+import Prelude  main :: IO () main = do-  res <- runMinio minioPlayCI $-    serviceStatus+  res <-+    runMinio minioPlayCI $+      serviceStatus   print res
examples/SetConfig.hs view
@@ -16,12 +16,11 @@ -- 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+import Network.Minio+import Network.Minio.AdminAPI+import Prelude  main :: IO () main = do
minio-hs.cabal view
@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                minio-hs-version:             1.5.2+version:             1.5.3 synopsis:            A MinIO Haskell Library for Amazon S3 compatible cloud                      storage. description:         The MinIO Haskell client library provides simple APIs to@@ -56,7 +56,7 @@                      , 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 @@                      , text >= 1.2                      , time >= 1.8                      , transformers >= 0.5-                     , unliftio >= 0.2-                     , unliftio-core >= 0.1+                     , unliftio >= 0.2 && < 0.3+                     , unliftio-core >= 0.2 && < 0.3                      , unordered-containers >= 0.2                      , xml-conduit >= 1.8
src/Lib/Prelude.hs view
@@ -15,19 +15,45 @@ --  module Lib.Prelude-    ( module Exports-    , both-    ) where--import           Protolude                 as Exports hiding (catch, catches,-                                                       throwIO, try)+  ( module Exports,+    both,+    showBS,+    toStrictBS,+    fromStrictBS,+  )+where -import           Control.Monad.Trans.Maybe as Exports (MaybeT (..), runMaybeT)-import           Data.Time                 as Exports (UTCTime (..),-                                                       diffUTCTime)-import           UnliftIO                  as Exports (catch, catches, throwIO,-                                                       try)+import Control.Monad.Trans.Maybe as Exports (MaybeT (..), runMaybeT)+import qualified Data.ByteString.Lazy as LB+import Data.Time as Exports+  ( UTCTime (..),+    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 view
@@ -22,218 +22,217 @@ -- -- 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-  , fromAWSConfigFile-  , fromAWSEnv-  , fromMinioEnv-  , findFirst+    -- ** Credential providers -  -- * Connecting to object storage-  , ConnectInfo-  , setRegion-  , setCreds-  , setCredsFrom-  , isConnectInfoSecure-  , disableTLSCertValidation-  , MinioConn-  , mkMinioConn+    -- | Run actions that retrieve 'Credentials' from the environment or+    -- files or other custom sources.+    Provider,+    fromAWSConfigFile,+    fromAWSEnv,+    fromMinioEnv,+    findFirst, -  -- ** Connection helpers-  -- | These are helpers to construct 'ConnectInfo' values for common-  -- cases.-  , minioPlayCI-  , awsCI-  , gcsCI+    -- * Connecting to object storage+    ConnectInfo,+    setRegion,+    setCreds,+    setCredsFrom,+    isConnectInfoSecure,+    disableTLSCertValidation,+    MinioConn,+    mkMinioConn, -  -- * Minio Monad-  -----------------  -- | The Minio Monad provides connection-reuse, bucket-location-  -- caching, resource management and simpler error handling-  -- functionality. All actions on object storage are performed within-  -- this Monad.-  , Minio-  , runMinioWith-  , runMinio-  , runMinioResWith-  , runMinioRes+    -- ** Connection helpers -  -- * Bucket Operations+    -- | These are helpers to construct 'ConnectInfo' values for common+    -- cases.+    minioPlayCI,+    awsCI,+    gcsCI, -  -- ** Creation, removal and querying-  , Bucket-  , makeBucket-  , removeBucket-  , bucketExists-  , Region-  , getLocation+    -- * Minio Monad+    ---------------- -  -- ** Listing buckets-  , BucketInfo(..)-  , listBuckets+    -- | The Minio Monad provides connection-reuse, bucket-location+    -- caching, resource management and simpler error handling+    -- functionality. All actions on object storage are performed within+    -- this Monad.+    Minio,+    runMinioWith,+    runMinio,+    runMinioResWith,+    runMinioRes, -  -- ** Listing objects-  , listObjects-  , listObjectsV1-  , ListItem(..)+    -- * Bucket Operations -  , ObjectInfo-  , oiObject-  , oiModTime-  , oiETag-  , oiSize-  , oiUserMetadata-  , oiMetadata+    -- ** Creation, removal and querying+    Bucket,+    makeBucket,+    removeBucket,+    bucketExists,+    Region,+    getLocation, -  -- ** Listing incomplete uploads-  , listIncompleteUploads-  , UploadId-  , UploadInfo(..)-  , listIncompleteParts-  , ObjectPartInfo(..)+    -- ** Listing buckets+    BucketInfo (..),+    listBuckets, -  -- ** Bucket Notifications-  , getBucketNotification-  , putBucketNotification-  , removeAllBucketNotification-  , Notification(..)-  , defaultNotification-  , NotificationConfig(..)-  , Arn-  , Event(..)-  , Filter(..)-  , defaultFilter-  , FilterKey(..)-  , defaultFilterKey-  , FilterRules(..)-  , defaultFilterRules-  , FilterRule(..)+    -- ** Listing objects+    listObjects,+    listObjectsV1,+    ListItem (..),+    ObjectInfo,+    oiObject,+    oiModTime,+    oiETag,+    oiSize,+    oiUserMetadata,+    oiMetadata, -  -- * Object Operations-  , Object+    -- ** Listing incomplete uploads+    listIncompleteUploads,+    UploadId,+    UploadInfo (..),+    listIncompleteParts,+    ObjectPartInfo (..), -  -- ** File-based operations-  , fGetObject-  , fPutObject+    -- ** Bucket Notifications+    getBucketNotification,+    putBucketNotification,+    removeAllBucketNotification,+    Notification (..),+    defaultNotification,+    NotificationConfig (..),+    Arn,+    Event (..),+    Filter (..),+    defaultFilter,+    FilterKey (..),+    defaultFilterKey,+    FilterRules (..),+    defaultFilterRules,+    FilterRule (..), -  -- ** Conduit-based streaming operations-  , putObject-  , PutObjectOptions-  , defaultPutObjectOptions-  , pooContentType-  , pooContentEncoding-  , pooContentDisposition-  , pooContentLanguage-  , pooCacheControl-  , pooStorageClass-  , pooUserMetadata-  , pooNumThreads-  , pooSSE+    -- * Object Operations+    Object, -  , getObject-  , GetObjectOptions-  , defaultGetObjectOptions-  , gooRange-  , gooIfMatch-  , gooIfNoneMatch-  , gooIfModifiedSince-  , gooIfUnmodifiedSince-  , gooSSECKey-  , GetObjectResponse-  , gorObjectInfo-  , gorObjectStream+    -- ** File-based operations+    fGetObject,+    fPutObject, -  -- ** Server-side object copying-  , copyObject-  , SourceInfo-  , defaultSourceInfo-  , srcBucket-  , srcObject-  , srcRange-  , srcIfMatch-  , srcIfNoneMatch-  , srcIfModifiedSince-  , srcIfUnmodifiedSince-  , DestinationInfo-  , defaultDestinationInfo-  , dstBucket-  , dstObject+    -- ** Conduit-based streaming operations+    putObject,+    PutObjectOptions,+    defaultPutObjectOptions,+    pooContentType,+    pooContentEncoding,+    pooContentDisposition,+    pooContentLanguage,+    pooCacheControl,+    pooStorageClass,+    pooUserMetadata,+    pooNumThreads,+    pooSSE,+    getObject,+    GetObjectOptions,+    defaultGetObjectOptions,+    gooRange,+    gooIfMatch,+    gooIfNoneMatch,+    gooIfModifiedSince,+    gooIfUnmodifiedSince,+    gooSSECKey,+    GetObjectResponse,+    gorObjectInfo,+    gorObjectStream, -  -- ** Querying object info-  , statObject+    -- ** Server-side object copying+    copyObject,+    SourceInfo,+    defaultSourceInfo,+    srcBucket,+    srcObject,+    srcRange,+    srcIfMatch,+    srcIfNoneMatch,+    srcIfModifiedSince,+    srcIfUnmodifiedSince,+    DestinationInfo,+    defaultDestinationInfo,+    dstBucket,+    dstObject, -  -- ** Object removal operations-  , removeObject-  , removeIncompleteUpload+    -- ** Querying object info+    statObject, -  -- ** Select Object Content with SQL-  , module Network.Minio.SelectAPI+    -- ** Object removal operations+    removeObject,+    removeIncompleteUpload, -  -- * Server-Side Encryption Helpers-  , mkSSECKey-  , SSECKey-  , SSE(..)+    -- ** Select Object Content with SQL+    module Network.Minio.SelectAPI, -  -- * Presigned Operations-  , presignedPutObjectUrl-  , presignedGetObjectUrl-  , presignedHeadObjectUrl-  , UrlExpiry+    -- * Server-Side Encryption Helpers+    mkSSECKey,+    SSECKey,+    SSE (..), -  -- ** POST (browser) upload helpers-  -- | Please see-  -- https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-HTTPPOSTConstructPolicy.html-  -- for detailed information.-  , newPostPolicy-  , presignedPostPolicy-  , showPostPolicy-  , PostPolicy-  , PostPolicyError(..)+    -- * Presigned Operations+    presignedPutObjectUrl,+    presignedGetObjectUrl,+    presignedHeadObjectUrl,+    UrlExpiry, -  -- *** Post Policy condition helpers-  , PostPolicyCondition-  , ppCondBucket-  , ppCondContentLengthRange-  , ppCondContentType-  , ppCondKey-  , ppCondKeyStartsWith-  , ppCondSuccessActionStatus+    -- ** POST (browser) upload helpers -  -- * Error handling-  -- | Data types representing various errors that may occur while-  -- working with an object storage service.-  , MinioErr(..)-  , MErrV(..)-  , ServiceErr(..)+    -- | Please see+    -- https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-HTTPPOSTConstructPolicy.html+    -- for detailed information.+    newPostPolicy,+    presignedPostPolicy,+    showPostPolicy,+    PostPolicy,+    PostPolicyError (..), -) where+    -- *** Post Policy condition helpers+    PostPolicyCondition,+    ppCondBucket,+    ppCondContentLengthRange,+    ppCondContentType,+    ppCondKey,+    ppCondKeyStartsWith,+    ppCondSuccessActionStatus, +    -- * Error handling++    -- | Data types representing various errors that may occur while+    -- working with an object storage service.+    MinioErr (..),+    MErrV (..),+    ServiceErr (..),+  )+where+ {- This module exports the high-level MinIO API for object storage. -} -import qualified Data.Conduit             as C-import qualified Data.Conduit.Binary      as CB+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-import           Network.Minio.ListOps-import           Network.Minio.PutObject-import           Network.Minio.S3API-import           Network.Minio.SelectAPI-import           Network.Minio.Utils+import Lib.Prelude+import Network.Minio.CopyObject+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.ListOps+import Network.Minio.PutObject+import Network.Minio.S3API+import Network.Minio.SelectAPI+import Network.Minio.Utils  -- | Lists buckets. listBuckets :: Minio [BucketInfo]@@ -248,8 +247,12 @@   C.connect (gorObjectStream src) $ CB.sinkFileCautious fp  -- | Upload the given file to the given object.-fPutObject :: Bucket -> Object -> FilePath-           -> PutObjectOptions -> Minio ()+fPutObject ::+  Bucket ->+  Object ->+  FilePath ->+  PutObjectOptions ->+  Minio () fPutObject bucket object f opts =   void $ putObjectInternal bucket object opts $ ODFile f Nothing @@ -257,8 +260,13 @@ -- 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 ()-          -> Maybe Int64 -> PutObjectOptions -> Minio ()+putObject ::+  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,18 +276,25 @@ -- 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)-                             (dstObject dstInfo) srcInfo+copyObject dstInfo srcInfo =+  void $+    copyObjectInternal+      (dstBucket dstInfo)+      (dstObject dstInfo)+      srcInfo  -- | Remove an object from the object store. removeObject :: Bucket -> Object -> Minio () removeObject = deleteObject  -- | Get an object from the object store.-getObject :: Bucket -> Object -> GetObjectOptions-          -> Minio GetObjectResponse+getObject ::+  Bucket ->+  Object ->+  GetObjectOptions ->+  Minio GetObjectResponse getObject bucket object opts =-    getObject' bucket object [] $ gooToHeaders opts+  getObject' bucket object [] $ gooToHeaders opts  -- | Get an object's metadata from the object store. It accepts the -- same options as GetObject.@@ -309,6 +324,8 @@ -- | Removes an ongoing multipart upload of an object. removeIncompleteUpload :: Bucket -> Object -> Minio () removeIncompleteUpload bucket object = do-  uploads <- C.runConduit $ listIncompleteUploads bucket (Just object) False-             C..| CC.sinkList+  uploads <-+    C.runConduit $+      listIncompleteUploads bucket (Just object) False+        C..| CC.sinkList   mapM_ (abortMultipartUpload bucket object) (uiUploadId <$> uploads)
src/Network/Minio/API.hs view
@@ -15,169 +15,187 @@ --  module Network.Minio.API-  ( connect-  , S3ReqInfo(..)-  , runMinio-  , executeRequest-  , mkStreamRequest-  , getLocation--  , isValidBucketName-  , checkBucketNameValidity-  , isValidObjectName-  , checkObjectNameValidity-  ) where--import           Control.Retry             (fullJitterBackoff,-                                            limitRetriesByCumulativeDelay,-                                            retrying)-import qualified Data.ByteString           as B-import qualified Data.Char                 as C-import qualified Data.Conduit              as C-import qualified Data.HashMap.Strict       as H-import qualified Data.Text                 as T-import qualified Data.Time.Clock           as Time-import           Network.HTTP.Conduit      (Response)-import qualified Network.HTTP.Conduit      as NC-import qualified Network.HTTP.Types        as HT-import           Network.HTTP.Types.Header (hHost)--import           Lib.Prelude+  ( connect,+    S3ReqInfo (..),+    runMinio,+    executeRequest,+    mkStreamRequest,+    getLocation,+    isValidBucketName,+    checkBucketNameValidity,+    isValidObjectName,+    checkObjectNameValidity,+  )+where -import           Network.Minio.APICommon-import           Network.Minio.Data-import           Network.Minio.Errors-import           Network.Minio.Sign.V4-import           Network.Minio.Utils-import           Network.Minio.XmlParser+import Control.Retry+  ( fullJitterBackoff,+    limitRetriesByCumulativeDelay,+    retrying,+  )+import qualified Data.ByteString as B+import qualified Data.Char as C+import qualified Data.Conduit as C+import 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 Network.Minio.APICommon+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.Sign.V4+import Network.Minio.Utils+import Network.Minio.XmlParser  -- | Fetch bucket location (region) getLocation :: Bucket -> Minio Region getLocation bucket = do-  resp <- executeRequest $ defaultS3ReqInfo {-      riBucket = Just bucket-    , riQueryParams = [("location", Nothing)]-    , riNeedsLocation = False-    }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { 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-            l <- lift $ getLocation bucket-            lift $ addToRegionCache bucket l-            return l-        ) return regionMay+  maybe+    ( do+        l <- lift $ getLocation bucket+        lift $ addToRegionCache bucket l+        return l+    )+    return+    regionMay  getRegion :: S3ReqInfo -> Minio (Maybe Region) getRegion ri = do-    ci <- asks mcConnInfo--         -- getService/makeBucket/getLocation -- don't need location-    if | not $ riNeedsLocation ri ->-             return $ Just $ connectRegion ci--         -- if autodiscovery of location is disabled by user-       | not $ connectAutoDiscoverRegion ci ->-                     return $ Just $ connectRegion ci+  ci <- asks mcConnInfo -         -- discover the region for the request-       | otherwise -> discoverRegion ri+  -- getService/makeBucket/getLocation -- don't need location+  if+      | not $ riNeedsLocation ri ->+        return $ Just $ connectRegion ci+      -- if autodiscovery of location is disabled by user+      | not $ connectAutoDiscoverRegion ci ->+        return $ Just $ connectRegion ci+      -- discover the region for the request+      | otherwise -> discoverRegion ri  getRegionHost :: Region -> Minio Text getRegionHost r = do-    ci <- asks mcConnInfo+  ci <- asks mcConnInfo -    if "amazonaws.com" `T.isSuffixOf` connectHost ci-    then maybe (throwIO $ MErrVRegionNotSupported r)-         return (H.lookup r awsRegionMap)+  if "amazonaws.com" `T.isSuffixOf` connectHost ci+    then+      maybe+        (throwIO $ MErrVRegionNotSupported r)+        return+        (H.lookup r awsRegionMap)     else return $ connectHost ci  buildRequest :: S3ReqInfo -> Minio NC.Request buildRequest ri = do-    maybe (return ()) checkBucketNameValidity $ riBucket ri-    maybe (return ()) checkObjectNameValidity $ riObject ri--    ci <- asks mcConnInfo--    regionMay <- getRegion ri--    regionHost <- maybe (return $ connectHost ci) getRegionHost regionMay+  maybe (return ()) checkBucketNameValidity $ riBucket ri+  maybe (return ()) checkObjectNameValidity $ riObject ri -    let ri' = ri { riHeaders = hostHeader : riHeaders ri-                 , riRegion = regionMay-                 }-        ci' = ci { connectHost = regionHost }-        hostHeader = (hHost, getHostAddr ci')+  ci <- asks mcConnInfo -        -- Does not contain body and auth info.-        baseRequest = NC.defaultRequest-                      { NC.method = riMethod ri'-                      , NC.secure = connectIsSecure ci'-                      , NC.host = encodeUtf8 $ connectHost ci'-                      , NC.port = connectPort ci'-                      , NC.path = getS3Path (riBucket ri') (riObject ri')-                      , NC.requestHeaders = riHeaders ri'-                      , NC.queryString = HT.renderQuery False $ riQueryParams ri'-                      }+  regionMay <- getRegion ri -    timeStamp <- liftIO Time.getCurrentTime+  regionHost <- maybe (return $ connectHost ci) getRegionHost regionMay -    let sp = SignParams (connectAccessKey ci') (connectSecretKey ci')-             timeStamp (riRegion ri') Nothing Nothing+  let ri' =+        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+          { NC.method = riMethod ri',+            NC.secure = connectIsSecure ci',+            NC.host = encodeUtf8 $ connectHost ci',+            NC.port = connectPort ci',+            NC.path = getS3Path (riBucket ri') (riObject ri'),+            NC.requestHeaders = riHeaders ri',+            NC.queryString = HT.renderQuery False $ riQueryParams ri'+          } -    -- Cases to handle:-    ---    -- 1. Connection is secure: use unsigned payload-    ---    -- 2. Insecure connection, streaming signature is enabled via use of-    --    conduit payload: use streaming signature for request.-    ---    -- 3. Insecure connection, non-conduit payload: compute payload-    -- sha256hash, buffer request in memory and perform request.+  timeStamp <- liftIO Time.getCurrentTime -         -- case 2 from above.-    if | isStreamingPayload (riPayload ri') &&-         (not $ connectIsSecure ci') -> do-             (pLen, pSrc) <- case riPayload ri of-                               PayloadC l src -> return (l, src)-                               _              -> throwIO MErrVUnexpectedPayload-             let reqFn = signV4Stream pLen sp baseRequest-             return $ reqFn pSrc+  let sp =+        SignParams+          (connectAccessKey ci')+          (connectSecretKey ci')+          timeStamp+          (riRegion ri')+          Nothing+          Nothing -       | otherwise -> do-                         -- case 1 described above.-             sp' <- if | connectIsSecure ci' -> return sp-                         -- case 3 described above.-                       | otherwise -> do-                             pHash <- getPayloadSHA256Hash $ riPayload ri'-                             return $ sp { spPayloadHash = Just pHash }+  -- Cases to handle:+  --+  -- 1. Connection is secure: use unsigned payload+  --+  -- 2. Insecure connection, streaming signature is enabled via use of+  --    conduit payload: use streaming signature for request.+  --+  -- 3. Insecure connection, non-conduit payload: compute payload+  -- sha256hash, buffer request in memory and perform request. -             let signHeaders = signV4 sp' baseRequest-             return $ baseRequest-                      { NC.requestHeaders =-                            NC.requestHeaders baseRequest ++-                            mkHeaderFromPairs signHeaders-                      , NC.requestBody = getRequestBody (riPayload ri')-                      }+  -- case 2 from above.+  if+      | isStreamingPayload (riPayload ri')+          && (not $ connectIsSecure ci') -> do+        (pLen, pSrc) <- case riPayload ri of+          PayloadC l src -> return (l, src)+          _ -> throwIO MErrVUnexpectedPayload+        let reqFn = signV4Stream pLen sp baseRequest+        return $ reqFn pSrc+      | otherwise -> do+        -- case 1 described above.+        sp' <-+          if+              | connectIsSecure ci' -> return sp+              -- case 3 described above.+              | otherwise -> do+                pHash <- getPayloadSHA256Hash $ riPayload ri'+                return $ sp {spPayloadHash = Just pHash} +        let signHeaders = signV4 sp' baseRequest+        return $+          baseRequest+            { NC.requestHeaders =+                NC.requestHeaders baseRequest+                  ++ mkHeaderFromPairs signHeaders,+              NC.requestBody = getRequestBody (riPayload ri')+            }  retryAPIRequest :: Minio a -> Minio a retryAPIRequest apiCall = do-  resE <- retrying retryPolicy (const shouldRetry) $-          const $ try apiCall+  resE <-+    retrying retryPolicy (const shouldRetry)+      $ const+      $ try apiCall   either throwIO return resE   where     -- Retry using the full-jitter backoff method for up to 10 mins     -- total-    retryPolicy = limitRetriesByCumulativeDelay tenMins-                  $ fullJitterBackoff oneMilliSecond-+    retryPolicy =+      limitRetriesByCumulativeDelay tenMins $+        fullJitterBackoff oneMilliSecond     oneMilliSecond = 1000 -- in microseconds     tenMins = 10 * 60 * 1000000 -- in microseconds     -- retry on connection related failure@@ -189,23 +207,23 @@         -- API request failed with a retryable exception         Left httpExn@(NC.HttpExceptionRequest _ exn) ->           case (exn :: NC.HttpExceptionContent) of-            NC.ResponseTimeout     -> return True-            NC.ConnectionTimeout   -> return True+            NC.ResponseTimeout -> return True+            NC.ConnectionTimeout -> return True             NC.ConnectionFailure _ -> return True             -- We received an unexpected exception-            _                      -> throwIO httpExn+            _ -> throwIO httpExn         -- We received an unexpected exception         Left someOtherExn -> throwIO someOtherExn - executeRequest :: S3ReqInfo -> Minio (Response LByteString) executeRequest ri = do   req <- buildRequest ri   mgr <- asks mcConnManager   retryAPIRequest $ httpLbs req mgr -mkStreamRequest :: S3ReqInfo-                -> Minio (Response (C.ConduitM () ByteString Minio ()))+mkStreamRequest ::+  S3ReqInfo ->+  Minio (Response (C.ConduitM () ByteString Minio ())) mkStreamRequest ri = do   req <- buildRequest ri   mgr <- asks mcConnManager@@ -214,35 +232,43 @@ -- Bucket name validity check according to AWS rules. isValidBucketName :: Bucket -> Bool isValidBucketName bucket =-  not (or [ len < 3 || len > 63-          , or (map labelCheck labels)-          , or (map labelCharsCheck labels)-          , isIPCheck-          ])+  not+    ( or+        [ len < 3 || len > 63,+          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 ||-                                                    x == '-' ||-                                                    C.isDigit x)) l-+    labelCharsCheck l =+      isJust $+        T.find+          ( \x ->+              not+                ( C.isAsciiLower x+                    || x == '-'+                    || C.isDigit x+                )+          )+          l     -- does label `l` have non-digit characters?     labelNonDigits l = isJust $ T.find (not . C.isDigit) l     labelAsNums = map (not . labelNonDigits) labels-     -- check if bucket name looks like an IP     isIPCheck = and labelAsNums && length labelAsNums == 4  -- Throws exception iff bucket name is invalid according to AWS rules. checkBucketNameValidity :: MonadIO m => Bucket -> m () checkBucketNameValidity bucket =-  when (not $ isValidBucketName bucket) $-  throwIO $ MErrVInvalidBucketName bucket+  when (not $ isValidBucketName bucket)+    $ throwIO+    $ MErrVInvalidBucketName bucket  isValidObjectName :: Object -> Bool isValidObjectName object =@@ -250,5 +276,6 @@  checkObjectNameValidity :: MonadIO m => Object -> m () checkObjectNameValidity object =-  when (not $ isValidObjectName object) $-  throwIO $ MErrVInvalidObjectName object+  when (not $ isValidObjectName object)+    $ throwIO+    $ MErrVInvalidObjectName object
src/Network/Minio/APICommon.hs view
@@ -16,37 +16,38 @@  module Network.Minio.APICommon where -import qualified Conduit                   as C-import qualified Data.ByteString           as BS-import qualified Data.ByteString.Lazy      as LB-import           Data.Conduit.Binary       (sourceHandleRange)-import qualified Network.HTTP.Conduit      as NC-import qualified Network.HTTP.Types        as HT--import           Lib.Prelude--import           Network.Minio.Data-import           Network.Minio.Data.Crypto-import           Network.Minio.Errors+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 Network.Minio.Data+import Network.Minio.Data.Crypto+import Network.Minio.Errors  sha256Header :: ByteString -> HT.Header-sha256Header = ("x-amz-content-sha256", )+sha256Header = ("x-amz-content-sha256",)  -- | This function throws an error if the payload is a conduit (as it -- will not be possible to re-read the conduit after it is consumed). getPayloadSHA256Hash :: Payload -> Minio ByteString getPayloadSHA256Hash (PayloadBS bs) = return $ hashSHA256 bs-getPayloadSHA256Hash (PayloadH h off size) = hashSHA256FromSource $-  sourceHandleRange h-    (return . fromIntegral $ off)-    (return . fromIntegral $ size)+getPayloadSHA256Hash (PayloadH h off size) =+  hashSHA256FromSource $+    sourceHandleRange+      h+      (return . fromIntegral $ off)+      (return . fromIntegral $ size) getPayloadSHA256Hash (PayloadC _ _) = throwIO MErrVUnexpectedPayload  getRequestBody :: Payload -> NC.RequestBody getRequestBody (PayloadBS bs) = NC.RequestBodyBS bs getRequestBody (PayloadH h off size) =   NC.requestBodySource (fromIntegral size) $-    sourceHandleRange h+    sourceHandleRange+      h       (return . fromIntegral $ off)       (return . fromIntegral $ size) getRequestBody (PayloadC n src) = NC.requestBodySource n src@@ -55,14 +56,17 @@ 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-        (return . fromIntegral $ off)-        (return . fromIntegral $ len)+      PayloadC len $+        sourceHandleRange+          h+          (return . fromIntegral $ off)+          (return . fromIntegral $ len)     _ -> payload  isStreamingPayload :: Payload -> Bool isStreamingPayload (PayloadC _ _) = True-isStreamingPayload _              = False+isStreamingPayload _ = False
src/Network/Minio/AdminAPI.hs view
@@ -16,270 +16,304 @@  module Network.Minio.AdminAPI   ( -- * MinIO Admin API-    --------------------+  --------------------+     -- | Provides MinIO admin API and related types. It is in     -- experimental state.-    DriveInfo(..)-  , ErasureInfo(..)-  , Backend(..)-  , ConnStats(..)-  , HttpStats(..)-  , ServerProps(..)-  , CountNAvgTime(..)-  , StorageClass(..)-  , StorageInfo(..)-  , SIData(..)-  , ServerInfo(..)-  , getServerInfo--  , HealOpts(..)-  , HealResultItem(..)-  , HealStatus(..)-  , HealStartResp(..)-  , startHeal-  , forceStartHeal-  , getHealStatus--  , SetConfigResult(..)-  , NodeSummary(..)-  , setConfig-  , getConfig--  , ServerVersion(..)-  , ServiceStatus(..)-  , serviceStatus--  , ServiceAction(..)-  , serviceSendAction-  ) where--import           Data.Aeson                (FromJSON, ToJSON, Value (Object),-                                            eitherDecode, object, pairs,-                                            parseJSON, toEncoding, toJSON,-                                            withObject, withText, (.:), (.:?),-                                            (.=))-import qualified Data.Aeson                as A-import           Data.Aeson.Types          (typeMismatch)-import qualified Data.ByteString           as B-import qualified Data.ByteString.Lazy      as LBS-import qualified Data.Text                 as T-import           Data.Time                 (NominalDiffTime, getCurrentTime)-import           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+    DriveInfo (..),+    ErasureInfo (..),+    Backend (..),+    ConnStats (..),+    HttpStats (..),+    ServerProps (..),+    CountNAvgTime (..),+    StorageClass (..),+    StorageInfo (..),+    SIData (..),+    ServerInfo (..),+    getServerInfo,+    HealOpts (..),+    HealResultItem (..),+    HealStatus (..),+    HealStartResp (..),+    startHeal,+    forceStartHeal,+    getHealStatus,+    SetConfigResult (..),+    NodeSummary (..),+    setConfig,+    getConfig,+    ServerVersion (..),+    ServiceStatus (..),+    serviceStatus,+    ServiceAction (..),+    serviceSendAction,+  )+where -import           Network.Minio.APICommon-import           Network.Minio.Data-import           Network.Minio.Errors-import           Network.Minio.Sign.V4-import           Network.Minio.Utils+import Data.Aeson+  ( (.:),+    (.:?),+    (.=),+    FromJSON,+    ToJSON,+    Value (Object),+    eitherDecode,+    object,+    pairs,+    parseJSON,+    toEncoding,+    toJSON,+    withObject,+    withText,+  )+import qualified Data.Aeson as A+import Data.Aeson.Types (typeMismatch)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import Data.Time (NominalDiffTime, getCurrentTime)+import Lib.Prelude+import Network.HTTP.Conduit (Response)+import qualified Network.HTTP.Conduit as NC+import qualified Network.HTTP.Types as HT+import Network.HTTP.Types.Header (hHost)+import Network.Minio.APICommon+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.Sign.V4+import Network.Minio.Utils  data DriveInfo = DriveInfo-                 { diUuid     :: Text-                 , diEndpoint :: Text-                 , diState    :: Text-                 } deriving (Eq, Show)+  { diUuid :: Text,+    diEndpoint :: Text,+    diState :: Text+  }+  deriving (Eq, Show)  instance FromJSON DriveInfo where-    parseJSON = withObject "DriveInfo" $ \v -> DriveInfo-        <$> v .: "uuid"-        <*> v .: "endpoint"-        <*> v .: "state"+  parseJSON = withObject "DriveInfo" $ \v ->+    DriveInfo+      <$> v .: "uuid"+      <*> v .: "endpoint"+      <*> v .: "state"  data StorageClass = StorageClass-                    { scParity :: Int-                    , scData   :: Int-                    } deriving (Eq, Show)+  { scParity :: Int,+    scData :: Int+  }+  deriving (Eq, Show)  data ErasureInfo = ErasureInfo-                   { eiOnlineDisks       :: Int-                   , eiOfflineDisks      :: Int-                   , eiStandard          :: StorageClass-                   , eiReducedRedundancy :: StorageClass-                   , eiSets              :: [[DriveInfo]]-                   } deriving (Eq, Show)+  { eiOnlineDisks :: Int,+    eiOfflineDisks :: Int,+    eiStandard :: StorageClass,+    eiReducedRedundancy :: StorageClass,+    eiSets :: [[DriveInfo]]+  }+  deriving (Eq, Show)  instance FromJSON ErasureInfo where-    parseJSON = withObject "ErasureInfo" $ \v -> do-        onlineDisks <- v .: "OnlineDisks"-        offlineDisks <- v .: "OfflineDisks"-        stdClass <- StorageClass-                    <$> v .: "StandardSCData"-                    <*> v .: "StandardSCParity"-        rrClass <- StorageClass-                   <$>  v .: "RRSCData"-                   <*>  v .: "RRSCParity"-        sets <- v .: "Sets"-        return $ ErasureInfo onlineDisks offlineDisks stdClass rrClass sets+  parseJSON = withObject "ErasureInfo" $ \v -> do+    onlineDisks <- v .: "OnlineDisks"+    offlineDisks <- v .: "OfflineDisks"+    stdClass <-+      StorageClass+        <$> v .: "StandardSCData"+        <*> v .: "StandardSCParity"+    rrClass <-+      StorageClass+        <$> v .: "RRSCData"+        <*> v .: "RRSCParity"+    sets <- v .: "Sets"+    return $ ErasureInfo onlineDisks offlineDisks stdClass rrClass sets -data Backend = BackendFS-             | BackendErasure ErasureInfo-             deriving (Eq, Show)+data Backend+  = BackendFS+  | BackendErasure ErasureInfo+  deriving (Eq, Show)  instance FromJSON Backend where-    parseJSON = withObject "Backend" $ \v -> do-        typ <- v .: "Type"-        case typ :: Int of-            1 -> return BackendFS-            2 -> BackendErasure <$> parseJSON (Object v)-            _ -> typeMismatch "BackendType" (Object v)+  parseJSON = withObject "Backend" $ \v -> do+    typ <- v .: "Type"+    case typ :: Int of+      1 -> return BackendFS+      2 -> BackendErasure <$> parseJSON (Object v)+      _ -> typeMismatch "BackendType" (Object v)  data ConnStats = ConnStats-    { csTransferred :: Int64-    , csReceived    :: Int64-    } deriving (Eq, Show)+  { csTransferred :: Int64,+    csReceived :: Int64+  }+  deriving (Eq, Show)  instance FromJSON ConnStats where-    parseJSON = withObject "ConnStats" $ \v -> ConnStats-        <$> v .: "transferred"-        <*> v .: "received"+  parseJSON = withObject "ConnStats" $ \v ->+    ConnStats+      <$> v .: "transferred"+      <*> v .: "received"  data ServerProps = ServerProps-    { spUptime   :: NominalDiffTime-    , spVersion  :: Text-    , spCommitId :: Text-    , spRegion   :: Text-    , spSqsArns  :: [Text]-    } deriving (Eq, Show)+  { spUptime :: NominalDiffTime,+    spVersion :: Text,+    spCommitId :: Text,+    spRegion :: Text,+    spSqsArns :: [Text]+  }+  deriving (Eq, Show)  instance FromJSON ServerProps where-    parseJSON = withObject "SIServer" $ \v -> do-        uptimeNs <- v .: "uptime"-        let uptime = uptimeNs / 1e9-        ver <- v .: "version"-        commitId <- v .: "commitID"-        region <- v .: "region"-        arn <- v .: "sqsARN"-        return $ ServerProps uptime ver commitId region arn+  parseJSON = withObject "SIServer" $ \v -> do+    uptimeNs <- v .: "uptime"+    let uptime = uptimeNs / 1e9+    ver <- v .: "version"+    commitId <- v .: "commitID"+    region <- v .: "region"+    arn <- v .: "sqsARN"+    return $ ServerProps uptime ver commitId region arn  data StorageInfo = StorageInfo-    { siUsed    :: Int64-    , siBackend :: Backend-    } deriving (Eq, Show)+  { siUsed :: Int64,+    siBackend :: Backend+  }+  deriving (Eq, Show)  instance FromJSON StorageInfo where-    parseJSON = withObject "StorageInfo" $ \v -> StorageInfo-        <$> v .: "Used"-        <*> v .: "Backend"+  parseJSON = withObject "StorageInfo" $ \v ->+    StorageInfo+      <$> v .: "Used"+      <*> v .: "Backend"  data CountNAvgTime = CountNAvgTime-    {  caCount       :: Int64-    ,  caAvgDuration :: Text-    } deriving (Eq, Show)+  { caCount :: Int64,+    caAvgDuration :: Text+  }+  deriving (Eq, Show)  instance FromJSON CountNAvgTime where-    parseJSON = withObject "CountNAvgTime" $ \v -> CountNAvgTime-        <$> v .: "count"-        <*> v .: "avgDuration"+  parseJSON = withObject "CountNAvgTime" $ \v ->+    CountNAvgTime+      <$> v .: "count"+      <*> v .: "avgDuration"  data HttpStats = HttpStats-    { hsTotalHeads     :: CountNAvgTime-    , hsSuccessHeads   :: CountNAvgTime-    , hsTotalGets      :: CountNAvgTime-    , hsSuccessGets    :: CountNAvgTime-    , hsTotalPuts      :: CountNAvgTime-    , hsSuccessPuts    :: CountNAvgTime-    , hsTotalPosts     :: CountNAvgTime-    , hsSuccessPosts   :: CountNAvgTime-    , hsTotalDeletes   :: CountNAvgTime-    , hsSuccessDeletes :: CountNAvgTime-    } deriving (Eq, Show)+  { hsTotalHeads :: CountNAvgTime,+    hsSuccessHeads :: CountNAvgTime,+    hsTotalGets :: CountNAvgTime,+    hsSuccessGets :: CountNAvgTime,+    hsTotalPuts :: CountNAvgTime,+    hsSuccessPuts :: CountNAvgTime,+    hsTotalPosts :: CountNAvgTime,+    hsSuccessPosts :: CountNAvgTime,+    hsTotalDeletes :: CountNAvgTime,+    hsSuccessDeletes :: CountNAvgTime+  }+  deriving (Eq, Show)  instance FromJSON HttpStats where-    parseJSON  = withObject "HttpStats" $ \v -> HttpStats-        <$> v .: "totalHEADs"-        <*> v .: "successHEADs"-        <*> v .: "totalGETs"-        <*> v .: "successGETs"-        <*> v .: "totalPUTs"-        <*> v .: "successPUTs"-        <*> v .: "totalPOSTs"-        <*> v .: "successPOSTs"-        <*> v .: "totalDELETEs"-        <*> v .: "successDELETEs"+  parseJSON = withObject "HttpStats" $ \v ->+    HttpStats+      <$> v .: "totalHEADs"+      <*> v .: "successHEADs"+      <*> v .: "totalGETs"+      <*> v .: "successGETs"+      <*> v .: "totalPUTs"+      <*> v .: "successPUTs"+      <*> v .: "totalPOSTs"+      <*> v .: "successPOSTs"+      <*> v .: "totalDELETEs"+      <*> v .: "successDELETEs"  data SIData = SIData-    { sdStorage   :: StorageInfo-    , sdConnStats :: ConnStats-    , sdHttpStats :: HttpStats-    , sdProps     :: ServerProps-    } deriving (Eq, Show)+  { sdStorage :: StorageInfo,+    sdConnStats :: ConnStats,+    sdHttpStats :: HttpStats,+    sdProps :: ServerProps+  }+  deriving (Eq, Show)  instance FromJSON SIData where-    parseJSON = withObject "SIData" $ \v -> SIData-        <$> v .: "storage"-        <*> v .: "network"-        <*> v .: "http"-        <*> v .: "server"+  parseJSON = withObject "SIData" $ \v ->+    SIData+      <$> v .: "storage"+      <*> v .: "network"+      <*> v .: "http"+      <*> v .: "server"  data ServerInfo = ServerInfo-    { siError :: Text-    , siAddr  :: Text-    , siData  :: SIData-    } deriving (Eq, Show)+  { siError :: Text,+    siAddr :: Text,+    siData :: SIData+  }+  deriving (Eq, Show)  instance FromJSON ServerInfo where-    parseJSON = withObject "ServerInfo" $ \v -> ServerInfo-        <$> v .: "error"-        <*> v .: "addr"-        <*> v .: "data"+  parseJSON = withObject "ServerInfo" $ \v ->+    ServerInfo+      <$> v .: "error"+      <*> v .: "addr"+      <*> v .: "data"  data ServerVersion = ServerVersion-  { svVersion  :: Text-  , svCommitId :: Text-  } deriving (Eq, Show)+  { svVersion :: Text,+    svCommitId :: Text+  }+  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-  , ssUptime  :: NominalDiffTime-  } deriving (Eq, Show)+  { ssVersion :: ServerVersion,+    ssUptime :: NominalDiffTime+  }+  deriving (Eq, Show)  instance FromJSON ServiceStatus where-    parseJSON = withObject "ServiceStatus" $ \v -> do-      serverVersion <- v .: "serverVersion"-      uptimeNs <- v .: "uptime"-      let uptime = uptimeNs / 1e9-      return $ ServiceStatus serverVersion uptime+  parseJSON = withObject "ServiceStatus" $ \v -> do+    serverVersion <- v .: "serverVersion"+    uptimeNs <- v .: "uptime"+    let uptime = uptimeNs / 1e9+    return $ ServiceStatus serverVersion uptime -data ServiceAction = ServiceActionRestart-                   | ServiceActionStop-                   deriving (Eq, Show)+data ServiceAction+  = ServiceActionRestart+  | ServiceActionStop+  deriving (Eq, Show)  instance ToJSON ServiceAction where-    toJSON a = object [ "action" .= serviceActionToText a ]+  toJSON a = object ["action" .= serviceActionToText a]  serviceActionToText :: ServiceAction -> Text serviceActionToText a = case a of   ServiceActionRestart -> "restart"-  ServiceActionStop    -> "stop"+  ServiceActionStop -> "stop"  adminPath :: ByteString adminPath = "/minio/admin"  data HealStartResp = HealStartResp-  { hsrClientToken :: Text-  , hsrClientAddr  :: Text-  , hsrStartTime   :: UTCTime-  } deriving (Eq, Show)+  { hsrClientToken :: Text,+    hsrClientAddr :: Text,+    hsrStartTime :: UTCTime+  }+  deriving (Eq, Show)  instance FromJSON HealStartResp where-    parseJSON = withObject "HealStartResp" $ \v -> HealStartResp-        <$> v .: "clientToken"-        <*> v .: "clientAddress"-        <*> v .: "startTime"+  parseJSON = withObject "HealStartResp" $ \v ->+    HealStartResp+      <$> v .: "clientToken"+      <*> v .: "clientAddress"+      <*> v .: "startTime"  data HealOpts = HealOpts-  { hoRecursive :: Bool-  , hoDryRun    :: Bool-  } deriving (Eq, Show)+  { hoRecursive :: Bool,+    hoDryRun :: Bool+  }+  deriving (Eq, Show)  instance ToJSON HealOpts where   toJSON (HealOpts r d) =@@ -288,197 +322,234 @@     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-                  | HealItemBucket-                  | HealItemBucketMetadata-                  | HealItemObject-                  deriving (Eq, Show)+data HealItemType+  = HealItemMetadata+  | HealItemBucket+  | HealItemBucketMetadata+  | HealItemObject+  deriving (Eq, Show)  instance FromJSON HealItemType where-    parseJSON = withText "HealItemType" $ \v -> case v of-      "metadata"        -> return HealItemMetadata-      "bucket"          -> return HealItemBucket-      "object"          -> return HealItemObject-      "bucket-metadata" -> return HealItemBucketMetadata-      _                 -> typeMismatch "HealItemType" (A.String v)+  parseJSON = withText "HealItemType" $ \v -> case v of+    "metadata" -> return HealItemMetadata+    "bucket" -> return HealItemBucket+    "object" -> return HealItemObject+    "bucket-metadata" -> return HealItemBucketMetadata+    _ -> typeMismatch "HealItemType" (A.String v)  data NodeSummary = NodeSummary-  { nsName       :: Text-  , nsErrSet     :: Bool-  , nsErrMessage :: Text-  } deriving (Eq, Show)+  { nsName :: Text,+    nsErrSet :: Bool,+    nsErrMessage :: Text+  }+  deriving (Eq, Show)  instance FromJSON NodeSummary where-  parseJSON = withObject "NodeSummary" $ \v -> NodeSummary-    <$> v .: "name"-    <*> v .: "errSet"-    <*> v .: "errMsg"+  parseJSON = withObject "NodeSummary" $ \v ->+    NodeSummary+      <$> v .: "name"+      <*> v .: "errSet"+      <*> v .: "errMsg"  data SetConfigResult = SetConfigResult-  { scrStatus      :: Bool-  , scrNodeSummary :: [NodeSummary]-  } deriving (Eq, Show)+  { scrStatus :: Bool,+    scrNodeSummary :: [NodeSummary]+  }+  deriving (Eq, Show)  instance FromJSON SetConfigResult where-  parseJSON = withObject "SetConfigResult" $ \v -> SetConfigResult-    <$> v .: "status"-    <*> v .: "nodeResults"+  parseJSON = withObject "SetConfigResult" $ \v ->+    SetConfigResult+      <$> v .: "status"+      <*> v .: "nodeResults"  data HealResultItem = HealResultItem-  { hriResultIdx    :: Int-  , hriType         :: HealItemType-  , hriBucket       :: Bucket-  , hriObject       :: Object-  , hriDetail       :: Text-  , hriParityBlocks :: Maybe Int-  , hriDataBlocks   :: Maybe Int-  , hriDiskCount    :: Int-  , hriSetCount     :: Int-  , hriObjectSize   :: Int-  , hriBefore       :: [DriveInfo]-  , hriAfter        :: [DriveInfo]-  } deriving (Eq, Show)+  { hriResultIdx :: Int,+    hriType :: HealItemType,+    hriBucket :: Bucket,+    hriObject :: Object,+    hriDetail :: Text,+    hriParityBlocks :: Maybe Int,+    hriDataBlocks :: Maybe Int,+    hriDiskCount :: Int,+    hriSetCount :: Int,+    hriObjectSize :: Int,+    hriBefore :: [DriveInfo],+    hriAfter :: [DriveInfo]+  }+  deriving (Eq, Show)  instance FromJSON HealResultItem where-  parseJSON = withObject "HealResultItem" $ \v -> HealResultItem-    <$> v .: "resultId"-    <*> v .: "type"-    <*> v .: "bucket"-    <*> v .: "object"-    <*> v .: "detail"-    <*> v .:? "parityBlocks"-    <*> v .:? "dataBlocks"-    <*> v .: "diskCount"-    <*> v .: "setCount"-    <*> v .: "objectSize"-    <*> (do before <- v .: "before"-            before .: "drives")-    <*> (do after <- v .: "after"-            after .: "drives")+  parseJSON = withObject "HealResultItem" $ \v ->+    HealResultItem+      <$> v .: "resultId"+      <*> v .: "type"+      <*> v .: "bucket"+      <*> v .: "object"+      <*> v .: "detail"+      <*> v .:? "parityBlocks"+      <*> v .:? "dataBlocks"+      <*> v .: "diskCount"+      <*> v .: "setCount"+      <*> v .: "objectSize"+      <*> ( do+              before <- v .: "before"+              before .: "drives"+          )+      <*> ( do+              after <- v .: "after"+              after .: "drives"+          )  data HealStatus = HealStatus-  { hsSummary       :: Text-  , hsStartTime     :: UTCTime-  , hsSettings      :: HealOpts-  , hsNumDisks      :: Int-  , hsFailureDetail :: Maybe Text-  , hsItems         :: Maybe [HealResultItem]-  } deriving (Eq, Show)+  { hsSummary :: Text,+    hsStartTime :: UTCTime,+    hsSettings :: HealOpts,+    hsNumDisks :: Int,+    hsFailureDetail :: Maybe Text,+    hsItems :: Maybe [HealResultItem]+  }+  deriving (Eq, Show)  instance FromJSON HealStatus where-  parseJSON = withObject "HealStatus" $ \v -> HealStatus-    <$> v .: "Summary"-    <*> v .: "StartTime"-    <*> v .: "Settings"-    <*> v .: "NumDisks"-    <*> v .:? "Detail"-    <*> v .: "Items"+  parseJSON = withObject "HealStatus" $ \v ->+    HealStatus+      <$> v .: "Summary"+      <*> v .: "StartTime"+      <*> v .: "Settings"+      <*> v .: "NumDisks"+      <*> v .:? "Detail"+      <*> v .: "Items"  healPath :: Maybe Bucket -> Maybe Text -> ByteString healPath bucket prefix = do   if (isJust bucket)-    then encodeUtf8 $ "v1/heal/" <> fromMaybe "" bucket <> "/"-         <> fromMaybe "" prefix+    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-                                            , ariPayload = PayloadBS B.empty-                                            , ariPayloadHash = Nothing-                                            , ariPath = "v1/service"-                                            , ariHeaders = []-                                            , ariQueryParams = []-                                            }+  rsp <-+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodGet,+          ariPayload = PayloadBS B.empty,+          ariPayloadHash = Nothing,+          ariPath = "v1/service",+          ariHeaders = [],+          ariQueryParams = []+        } -    let rspBS = NC.responseBody rsp-    case eitherDecode rspBS of-        Right ss -> return ss-        Left err -> throwIO $ MErrVJsonParse $ T.pack err+  let rspBS = NC.responseBody rsp+  case eitherDecode rspBS of+    Right ss -> return ss+    Left err -> throwIO $ MErrVJsonParse $ T.pack err  -- | Send service restart or stop action to MinIO server. serviceSendAction :: ServiceAction -> Minio () serviceSendAction action = do-    let payload = PayloadBS $ LBS.toStrict $ A.encode action-    void $ executeAdminRequest AdminReqInfo { ariMethod = HT.methodPost-                                            , ariPayload = payload-                                            , ariPayloadHash = Nothing-                                            , ariPath = "v1/service"-                                            , ariHeaders = []-                                            , ariQueryParams = []-                                            }+  let payload = PayloadBS $ LBS.toStrict $ A.encode action+  void $+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodPost,+          ariPayload = payload,+          ariPayloadHash = Nothing,+          ariPath = "v1/service",+          ariHeaders = [],+          ariQueryParams = []+        }  -- | Get the current config file from server. getConfig :: Minio ByteString getConfig = do-    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodGet-                                            , ariPayload = PayloadBS B.empty-                                            , ariPayloadHash = Nothing-                                            , ariPath = "v1/config"-                                            , ariHeaders = []-                                            , ariQueryParams = []-                                            }-    return $ LBS.toStrict $ NC.responseBody rsp+  rsp <-+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodGet,+          ariPayload = PayloadBS B.empty,+          ariPayloadHash = Nothing,+          ariPath = "v1/config",+          ariHeaders = [],+          ariQueryParams = []+        }+  return $ LBS.toStrict $ NC.responseBody rsp  -- | Set a new config to the server. setConfig :: ByteString -> Minio SetConfigResult setConfig config = do-    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodPut-                                            , ariPayload = PayloadBS config-                                            , ariPayloadHash = Nothing-                                            , ariPath = "v1/config"-                                            , ariHeaders = []-                                            , ariQueryParams = []-                                            }+  rsp <-+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodPut,+          ariPayload = PayloadBS config,+          ariPayloadHash = Nothing,+          ariPath = "v1/config",+          ariHeaders = [],+          ariQueryParams = []+        } -    let rspBS = NC.responseBody rsp-    case eitherDecode rspBS of-        Right scr -> return scr-        Left err  -> throwIO $ MErrVJsonParse $ T.pack err+  let rspBS = NC.responseBody rsp+  case eitherDecode rspBS of+    Right scr -> return scr+    Left err -> throwIO $ MErrVJsonParse $ T.pack err  -- | Get the progress of currently running heal task, this API should be -- invoked right after `startHeal`. `token` is obtained after `startHeal` -- which should be used to get the heal status. getHealStatus :: Maybe Bucket -> Maybe Text -> Text -> Minio HealStatus getHealStatus bucket prefix token = do-    when (isNothing bucket && isJust prefix) $ throwIO MErrVInvalidHealPath-    let qparams = HT.queryTextToQuery [("clientToken", Just token)]-    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodPost-                                            , ariPayload = PayloadBS B.empty-                                            , ariPayloadHash = Nothing-                                            , ariPath = healPath bucket prefix-                                            , ariHeaders = []-                                            , ariQueryParams = qparams-                                            }-    let rspBS = NC.responseBody rsp-    case eitherDecode rspBS of-        Right hs -> return hs-        Left err -> throwIO $ MErrVJsonParse $ T.pack err+  when (isNothing bucket && isJust prefix) $ throwIO MErrVInvalidHealPath+  let qparams = HT.queryTextToQuery [("clientToken", Just token)]+  rsp <-+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodPost,+          ariPayload = PayloadBS B.empty,+          ariPayloadHash = Nothing,+          ariPath = healPath bucket prefix,+          ariHeaders = [],+          ariQueryParams = qparams+        }+  let rspBS = NC.responseBody rsp+  case eitherDecode rspBS of+    Right hs -> return hs+    Left err -> throwIO $ MErrVJsonParse $ T.pack err  doHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Bool -> Minio HealStartResp doHeal bucket prefix opts forceStart = do-    when (isNothing bucket && isJust prefix) $ throwIO MErrVInvalidHealPath-    let payload = PayloadBS $ LBS.toStrict $ A.encode opts-    let qparams = bool [] (HT.queryTextToQuery [("forceStart", Just "true")])-                  forceStart+  when (isNothing bucket && isJust prefix) $ throwIO MErrVInvalidHealPath+  let payload = PayloadBS $ LBS.toStrict $ A.encode opts+  let qparams =+        bool+          []+          (HT.queryTextToQuery [("forceStart", Just "true")])+          forceStart -    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodPost-                                            , ariPayload = payload-                                            , ariPayloadHash = Nothing-                                            , ariPath = healPath bucket prefix-                                            , ariHeaders = []-                                            , ariQueryParams = qparams-                                            }+  rsp <-+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodPost,+          ariPayload = payload,+          ariPayloadHash = Nothing,+          ariPath = healPath bucket prefix,+          ariHeaders = [],+          ariQueryParams = qparams+        } -    let rspBS = NC.responseBody rsp-    case eitherDecode rspBS of-        Right hsr -> return hsr-        Left err  -> throwIO $ MErrVJsonParse $ T.pack err+  let rspBS = NC.responseBody rsp+  case eitherDecode rspBS of+    Right hsr -> return hsr+    Left err -> throwIO $ MErrVJsonParse $ T.pack err  -- | Start a heal sequence that scans data under given (possible empty) -- `bucket` and `prefix`. The `recursive` bool turns on recursive@@ -500,60 +571,75 @@ -- properties, storage information, network statistics, etc. getServerInfo :: Minio [ServerInfo] getServerInfo = do-    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodGet-                                            , ariPayload = PayloadBS B.empty-                                            , ariPayloadHash = Nothing-                                            , ariPath = "v1/info"-                                            , ariHeaders = []-                                            , ariQueryParams = []-                                            }-    let rspBS = NC.responseBody rsp-    case eitherDecode rspBS of-        Right si -> return si-        Left err -> throwIO $ MErrVJsonParse $ T.pack err+  rsp <-+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodGet,+          ariPayload = PayloadBS B.empty,+          ariPayloadHash = Nothing,+          ariPath = "v1/info",+          ariHeaders = [],+          ariQueryParams = []+        }+  let rspBS = NC.responseBody rsp+  case eitherDecode rspBS of+    Right si -> return si+    Left err -> throwIO $ MErrVJsonParse $ T.pack err  executeAdminRequest :: AdminReqInfo -> Minio (Response LByteString) executeAdminRequest ari = do-    req <- buildAdminRequest ari-    mgr <- asks mcConnManager-    httpLbs req mgr+  req <- buildAdminRequest ari+  mgr <- asks mcConnManager+  httpLbs req mgr  buildAdminRequest :: AdminReqInfo -> Minio NC.Request buildAdminRequest areq = do-    ci <- asks mcConnInfo-    sha256Hash <- if | connectIsSecure ci ->-                       -- if secure connection-                       return "UNSIGNED-PAYLOAD"--                       -- otherwise compute sha256-                     | otherwise -> getPayloadSHA256Hash (ariPayload areq)+  ci <- asks mcConnInfo+  sha256Hash <-+    if+        | connectIsSecure ci ->+          -- if secure connection+          return "UNSIGNED-PAYLOAD"+        -- otherwise compute sha256+        | otherwise -> getPayloadSHA256Hash (ariPayload areq) -    timeStamp <- liftIO getCurrentTime+  timeStamp <- liftIO getCurrentTime -    let hostHeader = (hHost, getHostAddr ci)-        newAreq = areq { ariPayloadHash = Just sha256Hash-                       , ariHeaders = hostHeader-                                    : sha256Header sha256Hash-                                    : ariHeaders areq-                       }-        signReq = toRequest ci newAreq-        sp = SignParams (connectAccessKey ci) (connectSecretKey ci)-             timeStamp Nothing Nothing (ariPayloadHash newAreq)-        signHeaders = signV4 sp signReq+  let hostHeader = (hHost, getHostAddr ci)+      newAreq =+        areq+          { ariPayloadHash = Just sha256Hash,+            ariHeaders =+              hostHeader+                : sha256Header sha256Hash+                : ariHeaders areq+          }+      signReq = toRequest ci newAreq+      sp =+        SignParams+          (connectAccessKey ci)+          (connectSecretKey ci)+          timeStamp+          Nothing+          Nothing+          (ariPayloadHash newAreq)+      signHeaders = signV4 sp signReq -    -- Update signReq with Authorization header containing v4 signature-    return signReq {-        NC.requestHeaders = ariHeaders newAreq ++ mkHeaderFromPairs signHeaders-        }+  -- Update signReq with Authorization header containing v4 signature+  return+    signReq+      { NC.requestHeaders = ariHeaders newAreq ++ mkHeaderFromPairs signHeaders+      }   where     toRequest :: ConnectInfo -> AdminReqInfo -> NC.Request-    toRequest ci aReq = NC.defaultRequest-        { NC.method = ariMethod aReq-        , NC.secure = connectIsSecure ci-        , NC.host = encodeUtf8 $ connectHost ci-        , NC.port = connectPort ci-        , NC.path = B.intercalate "/" [adminPath, ariPath aReq]-        , NC.requestHeaders = ariHeaders aReq-        , NC.queryString = HT.renderQuery False $ ariQueryParams aReq-        , NC.requestBody = getRequestBody (ariPayload aReq)+    toRequest ci aReq =+      NC.defaultRequest+        { NC.method = ariMethod aReq,+          NC.secure = connectIsSecure ci,+          NC.host = encodeUtf8 $ connectHost ci,+          NC.port = connectPort ci,+          NC.path = B.intercalate "/" [adminPath, ariPath aReq],+          NC.requestHeaders = ariHeaders aReq,+          NC.queryString = HT.renderQuery False $ ariQueryParams aReq,+          NC.requestBody = getRequestBody (ariPayload aReq)         }
src/Network/Minio/CopyObject.hs view
@@ -16,19 +16,19 @@  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-+import qualified Data.List as List+import Lib.Prelude+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.S3API+import Network.Minio.Utils  -- | Copy an object using single or multipart copy strategy.-copyObjectInternal :: Bucket -> Object -> SourceInfo-                   -> Minio ETag+copyObjectInternal ::+  Bucket ->+  Object ->+  SourceInfo ->+  Minio ETag copyObjectInternal b' o srcInfo = do   let sBucket = srcBucket srcInfo       sObject = srcObject srcInfo@@ -43,27 +43,35 @@       startOffset = fst range       endOffset = snd range -  when (isJust rangeMay &&-        or [startOffset < 0, endOffset < startOffset,-            endOffset >= fromIntegral srcSize]) $-    throwIO $ MErrVInvalidSrcObjByteRange range+  when+    ( isJust rangeMay+        && or+          [ 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 ) $-                 maybe (0, srcSize - 1) identity rangeMay+  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} []+    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 $-  map (\(x, y) -> (st + x, st + x + y - 1)) $ zip startOffsets partSizes+selectCopyRanges (st, end) =+  zip pns+    $ map (\(x, y) -> (st + x, st + x + y - 1))+    $ zip startOffsets partSizes   where     size = end - st + 1     (pns, startOffsets, partSizes) = List.unzip3 $ selectPartSizes size@@ -71,22 +79,30 @@ -- | Perform a multipart copy object action. Since we cannot verify -- existing parts based on the source object, there is no resuming -- copy action support.-multiPartCopyObject :: Bucket -> Object -> SourceInfo -> Int64-                    -> Minio ETag+multiPartCopyObject ::+  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) }))-                    partRanges-      dstInfo = defaultDestinationInfo { dstBucket = b, dstObject = o}+      partSources =+        map+          (\(x, (start, end)) -> (x, cps {srcRange = Just (start, end)}))+          partRanges+      dstInfo = defaultDestinationInfo {dstBucket = b, dstObject = o} -  copiedParts <- limitedMapConcurrently 10-                 (\(pn, cps') -> do-                     (etag, _) <- copyObjectPart dstInfo cps' uid pn []-                     return (pn, etag)-                 )-                 partSources+  copiedParts <-+    limitedMapConcurrently+      10+      ( \(pn, cps') -> do+          (etag, _) <- copyObjectPart dstInfo cps' uid pn []+          return (pn, etag)+      )+      partSources    completeMultipartUpload b o uid copiedParts
src/Network/Minio/Data.hs view
@@ -13,1025 +13,1116 @@ -- See the License for the specific language governing permissions and -- limitations under the License. ----{-# LANGUAGE CPP                        #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies               #-}-module Network.Minio.Data where--import qualified Conduit                      as C-import qualified Control.Concurrent.MVar      as M-import           Control.Monad.IO.Unlift      (UnliftIO (..), askUnliftIO,-                                               withUnliftIO)-import           Control.Monad.Trans.Resource-import qualified Data.Aeson                   as A-import qualified Data.ByteArray               as BA-import qualified Data.ByteString              as B-import           Data.CaseInsensitive         (mk)-import qualified Data.HashMap.Strict          as H-import qualified Data.Ini                     as Ini-import           Data.String                  (IsString (..))-import qualified Data.Text                    as T-import qualified Data.Text.Encoding           as TE-import           Data.Time                    (defaultTimeLocale, formatTime)-import           GHC.Show                     (Show (show))-import qualified Network.Connection           as Conn-import           Network.HTTP.Client          (defaultManagerSettings)-import qualified Network.HTTP.Client.TLS      as TLS-import qualified Network.HTTP.Conduit         as NC-import           Network.HTTP.Types           (ByteRange, Header, Method, Query,-                                               hRange)-import qualified Network.HTTP.Types           as HT-import           Network.Minio.Errors-import           System.Directory             (doesFileExist, getHomeDirectory)-import qualified System.Environment           as Env-import           System.FilePath.Posix        (combine)-import           Text.XML-import qualified UnliftIO                     as U--import           Lib.Prelude-import           Network.Minio.Data.Crypto---- | max obj size is 5TiB-maxObjectSize :: Int64-maxObjectSize = 5 * 1024 * 1024 * oneMiB---- | minimum size of parts used in multipart operations.-minPartSize :: Int64-minPartSize = 64 * oneMiB--oneMiB :: Int64-oneMiB = 1024 * 1024---- | maximum number of parts that can be uploaded for a single object.-maxMultipartParts :: Int64-maxMultipartParts = 10000---- TODO: Add a type which provides typed constants for region.  this--- type should have a IsString instance to infer the appropriate--- constant.--- | awsRegionMap - library constant-awsRegionMap :: H.HashMap Text Text-awsRegionMap = H.fromList [-      ("us-east-1", "s3.amazonaws.com")-    , ("us-east-2", "s3-us-east-2.amazonaws.com")-    , ("us-west-1", "s3-us-west-1.amazonaws.com")-    , ("us-west-2", "s3-us-west-2.amazonaws.com")-    , ("ca-central-1", "s3-ca-central-1.amazonaws.com")-    , ("ap-south-1", "s3-ap-south-1.amazonaws.com")-    , ("ap-northeast-1", "s3-ap-northeast-1.amazonaws.com")-    , ("ap-northeast-2", "s3-ap-northeast-2.amazonaws.com")-    , ("ap-southeast-1", "s3-ap-southeast-1.amazonaws.com")-    , ("ap-southeast-2", "s3-ap-southeast-2.amazonaws.com")-    , ("eu-west-1", "s3-eu-west-1.amazonaws.com")-    , ("eu-west-2", "s3-eu-west-2.amazonaws.com")-    , ("eu-central-1", "s3-eu-central-1.amazonaws.com")-    , ("sa-east-1", "s3-sa-east-1.amazonaws.com")-  ]---- | Connection Info data type. To create a 'ConnectInfo' value,--- enable the @OverloadedStrings@ language extension and use the--- `IsString` instance to provide a URL, for example:------ > let c :: ConnectInfo = "https://play.min.io"-data ConnectInfo =-    ConnectInfo { connectHost                     :: Text-                , connectPort                     :: Int-                , connectAccessKey                :: Text-                , connectSecretKey                :: Text-                , connectIsSecure                 :: Bool-                , connectRegion                   :: Region-                , connectAutoDiscoverRegion       :: Bool-                , connectDisableTLSCertValidation :: Bool-                } deriving (Eq, Show)--instance IsString ConnectInfo where-    fromString str =-        let req = NC.parseRequest_ str-        in ConnectInfo-           { connectHost = TE.decodeUtf8 $ NC.host req-           , connectPort = NC.port req-           , connectAccessKey = ""-           , connectSecretKey = ""-           , connectIsSecure = NC.secure req-           , connectRegion = ""-           , connectAutoDiscoverRegion = True-           , connectDisableTLSCertValidation = False-           }---- | Contains access key and secret key to access object storage.-data Credentials = Credentials { cAccessKey :: Text-                               , cSecretKey :: Text-                               } deriving (Eq, Show)---- | A Provider is an action that may return Credentials. Providers--- may be chained together using 'findFirst'.-type Provider = IO (Maybe Credentials)---- | Combines the given list of providers, by calling each one in--- order until Credentials are found.-findFirst :: [Provider] -> Provider-findFirst [] = return Nothing-findFirst (f:fs) = do c <- f-                      maybe (findFirst fs) (return . Just) c---- | This Provider loads `Credentials` from @~\/.aws\/credentials@-fromAWSConfigFile :: Provider-fromAWSConfigFile = do-    credsE <- runExceptT $ do-        homeDir <- lift $ getHomeDirectory-        let awsCredsFile =  homeDir `combine` ".aws" `combine` "credentials"-        fileExists <- lift $ doesFileExist awsCredsFile-        bool (throwE "FileNotFound") (return ()) fileExists-        ini <- ExceptT $ Ini.readIniFile awsCredsFile-        akey <- ExceptT $ return-                $ Ini.lookupValue "default" "aws_access_key_id" ini-        skey <- ExceptT $ return-                $ Ini.lookupValue "default" "aws_secret_access_key" ini-        return $ Credentials akey skey-    return $ hush credsE---- | This Provider loads `Credentials` from @AWS_ACCESS_KEY_ID@ and--- @AWS_SECRET_ACCESS_KEY@ environment variables.-fromAWSEnv :: Provider-fromAWSEnv = runMaybeT $ do-        akey <- MaybeT $ Env.lookupEnv "AWS_ACCESS_KEY_ID"-        skey <- MaybeT $ Env.lookupEnv "AWS_SECRET_ACCESS_KEY"-        return $ Credentials (T.pack akey) (T.pack skey)---- | This Provider loads `Credentials` from @MINIO_ACCESS_KEY@ and--- @MINIO_SECRET_KEY@ environment variables.-fromMinioEnv :: Provider-fromMinioEnv = runMaybeT $ do-    akey <- MaybeT $ Env.lookupEnv "MINIO_ACCESS_KEY"-    skey <- MaybeT $ Env.lookupEnv "MINIO_SECRET_KEY"-    return $ Credentials (T.pack akey) (T.pack skey)---- | setCredsFrom retrieves access credentials from the first--- `Provider` form the given list that succeeds and sets it in the--- `ConnectInfo`.-setCredsFrom :: [Provider] -> ConnectInfo -> IO ConnectInfo-setCredsFrom ps ci = do pMay <- findFirst ps-                        maybe-                          (throwIO MErrVMissingCredentials)-                          (return . (flip setCreds ci))-                          pMay---- | setCreds sets the given `Credentials` in the `ConnectInfo`.-setCreds :: Credentials -> ConnectInfo -> ConnectInfo-setCreds (Credentials accessKey secretKey) connInfo =-    connInfo { connectAccessKey = accessKey-             , connectSecretKey = secretKey-             }---- | Set the S3 region parameter in the `ConnectInfo`-setRegion :: Region -> ConnectInfo -> ConnectInfo-setRegion r connInfo = connInfo { connectRegion = r-                                , connectAutoDiscoverRegion = False-                                }---- | Check if the connection to object storage server is secure--- (i.e. uses TLS)-isConnectInfoSecure :: ConnectInfo -> Bool-isConnectInfoSecure = connectIsSecure---- | Disable TLS certificate validation completely! This makes TLS--- insecure! Use only for testing with self-signed or temporary--- certificates. Note that this option has no effect, if you provide--- your own Manager in `mkMinioConn`.-disableTLSCertValidation :: ConnectInfo -> ConnectInfo-disableTLSCertValidation c = c { connectDisableTLSCertValidation = True }--getHostAddr :: ConnectInfo -> ByteString-getHostAddr ci = if | port == 80 || port == 443 -> toS host-                    | otherwise -> toS $-                                   T.concat [ host, ":" , Lib.Prelude.show port]-  where-    port = connectPort ci-    host = connectHost ci----- | Default Google Compute Storage ConnectInfo. Works only for--- "Simple Migration" use-case with interoperability mode enabled on--- GCP console. For more information ---- https://cloud.google.com/storage/docs/migrating------ Credentials should be supplied before use.-gcsCI :: ConnectInfo-gcsCI = setRegion "us"-        "https://storage.googleapis.com"----- | Default AWS S3 ConnectInfo. Connects to "us-east-1". Credentials--- should be supplied before use.-awsCI :: ConnectInfo-awsCI = "https://s3.amazonaws.com"----- | <https://play.min.io MinIO Play Server>--- ConnectInfo. Credentials are already filled in.-minioPlayCI :: ConnectInfo-minioPlayCI = let playCreds = Credentials "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"-              in setCreds playCreds-                 $ setRegion "us-east-1"-                 "https://play.min.io"---- |--- Represents a bucket in the object store-type Bucket = Text---- |--- Represents an object name-type Object = Text---- | Represents a region-type Region = Text---- | A type alias to represent an Entity-Tag returned by S3-compatible APIs.-type ETag = Text---- | Data type to represent an object encryption key. Create one using--- the `mkSSECKey` function.-newtype SSECKey = SSECKey BA.ScrubbedBytes-                deriving (Eq, Show)---- | Validates that the given ByteString is 32 bytes long and creates--- an encryption key.-mkSSECKey :: MonadThrow m => ByteString -> m SSECKey-mkSSECKey keyBytes | B.length keyBytes /= 32 =-                         throwM MErrVInvalidEncryptionKeyLength-                   | otherwise =-                         return $ SSECKey $ BA.convert keyBytes---- | Data type to represent Server-Side-Encryption settings-data SSE where-    -- | Specifies SSE S3 encryption - server manages encryption keys-    SSE :: SSE-    -- | Specifies that KMS service should be used. The first argument-    -- to the constructor is the Key Id to be used by the server (if-    -- not specified, the default KMS key id is used). The second-    -- argument is the optional KMS context that must have a-    -- `A.ToJSON` instance - please refer to the AWS S3 documentation-    -- for detailed information.-    SSEKMS :: A.ToJSON a => Maybe ByteString -> Maybe a -> SSE-    -- | Specifies server-side encryption with customer provided-    -- key. The argument is the encryption key to be used.-    SSEC :: SSECKey -> SSE--toPutObjectHeaders :: SSE -> [HT.Header]-toPutObjectHeaders sseArg =-    let sseHeader = "x-amz-server-side-encryption"-        sseKmsIdHeader = sseHeader <> "-aws-kms-key-id"-        sseKmsContextHeader = sseHeader <> "-context"-        ssecAlgo = sseHeader <> "-customer-algorithm"-        ssecKey = sseHeader <> "-customer-key"-        ssecKeyMD5 = ssecKey <> "-MD5"--    in case sseArg of-      SSE -> [(sseHeader, "AES256")]--      SSEKMS keyIdMay ctxMay ->-          [(sseHeader, "aws:kms")] ++-          maybe [] (\k -> [(sseKmsIdHeader, k)]) keyIdMay ++-          maybe [] (\k -> [(sseKmsContextHeader, toS $ A.encode k)]) ctxMay--      SSEC (SSECKey sb) ->-          [(ssecAlgo, "AES256"),-           (ssecKey, encodeToBase64 sb),-           (ssecKeyMD5, hashMD5ToBase64 sb)]---- | Data type for options in PutObject call.  Start with the empty--- `defaultPutObjectOptions` and use various the various poo*--- accessors.-data PutObjectOptions = PutObjectOptions {-  -- | Set a standard MIME type describing the format of the object.-    pooContentType        :: Maybe Text-  -- | Set what content encodings have been applied to the object and thus-  -- what decoding mechanisms must be applied to obtain the media-type-  -- referenced by the Content-Type header field.-  , pooContentEncoding    :: Maybe Text-  -- | Set presentational information for the object.-  , pooContentDisposition :: Maybe Text-  -- | Set to specify caching behavior for the object along the-  -- request/reply chain.-  , pooCacheControl       :: Maybe Text-  -- | Set to describe the language(s) intended for the audience.-  , pooContentLanguage    :: Maybe Text-  -- | Set to @STANDARD@ or @REDUCED_REDUNDANCY@ depending on your-  -- performance needs, storage class is @STANDARD@ by default (i.e-  -- when Nothing is passed).-  , pooStorageClass       :: Maybe Text-  -- | Set user defined metadata to store with the object.-  , pooUserMetadata       :: [(Text, Text)]-  -- | Set number of worker threads used to upload an object.-  , pooNumThreads         :: Maybe Word-  -- | Set object encryption parameters for the request.-  , pooSSE                :: Maybe SSE-  }---- | Provide default `PutObjectOptions`.-defaultPutObjectOptions :: PutObjectOptions-defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing---- | If the given header name has the @X-Amz-Meta-@ prefix, it is--- stripped and a Just is returned.-userMetadataHeaderNameMaybe :: Text -> Maybe Text-userMetadataHeaderNameMaybe k =-    let prefix = T.toCaseFold "X-Amz-Meta-"-        n = T.length prefix-    in if T.toCaseFold (T.take n k) == prefix-       then Just (T.drop n k)-       else Nothing--addXAmzMetaPrefix :: Text -> Text-addXAmzMetaPrefix s | isJust (userMetadataHeaderNameMaybe s) = s-                    | otherwise = "X-Amz-Meta-" <> s--mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header]-mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix $ x, encodeUtf8 y))--pooToHeaders :: PutObjectOptions -> [HT.Header]-pooToHeaders poo = userMetadata-                   ++ (catMaybes $ map tupToMaybe (zipWith (,) names values))-                   ++ maybe [] toPutObjectHeaders (pooSSE poo)-  where-    tupToMaybe (k, Just v)  = Just (k, v)-    tupToMaybe (_, Nothing) = Nothing--    userMetadata = mkHeaderFromMetadata $ pooUserMetadata poo--    names = ["content-type",-             "content-encoding",-             "content-disposition",-             "content-language",-             "cache-control",-             "x-amz-storage-class"]-    values = map (fmap encodeUtf8 . (poo &))-             [pooContentType, pooContentEncoding,-              pooContentDisposition, pooContentLanguage,-              pooCacheControl, pooStorageClass]----- |--- BucketInfo returned for list buckets call-data BucketInfo = BucketInfo {-    biName         :: Bucket-  , biCreationDate :: UTCTime-  } deriving (Show, Eq)---- | A type alias to represent a part-number for multipart upload-type PartNumber = Int16---- | A type alias to represent an upload-id for multipart upload-type UploadId = Text---- | A type to represent a part-number and etag.-type PartTuple = (PartNumber, ETag)---- | Represents result from a listing of object parts of an ongoing--- multipart upload.-data ListPartsResult = ListPartsResult {-    lprHasMore  :: Bool-  , lprNextPart :: Maybe Int-  , lprParts    :: [ObjectPartInfo]- } deriving (Show, Eq)---- | Represents information about an object part in an ongoing--- multipart upload.-data ObjectPartInfo = ObjectPartInfo {-    opiNumber  :: PartNumber-  , opiETag    :: ETag-  , opiSize    :: Int64-  , opiModTime :: UTCTime-  } deriving (Show, Eq)---- | Represents result from a listing of incomplete uploads to a--- bucket.-data ListUploadsResult = ListUploadsResult {-    lurHasMore    :: Bool-  , lurNextKey    :: Maybe Text-  , lurNextUpload :: Maybe Text-  , lurUploads    :: [(Object, UploadId, UTCTime)]-  , lurCPrefixes  :: [Text]-  } deriving (Show, Eq)---- | Represents information about a multipart upload.-data UploadInfo = UploadInfo {-    uiKey      :: Object-  , uiUploadId :: UploadId-  , uiInitTime :: UTCTime-  , uiSize     :: Int64-  } deriving (Show, Eq)---- | Represents result from a listing of objects in a bucket.-data ListObjectsResult = ListObjectsResult {-    lorHasMore   :: Bool-  , lorNextToken :: Maybe Text-  , lorObjects   :: [ObjectInfo]-  , lorCPrefixes :: [Text]-  } deriving (Show, Eq)---- | Represents result from a listing of objects version 1 in a bucket.-data ListObjectsV1Result = ListObjectsV1Result {-    lorHasMore'   :: Bool-  , lorNextMarker :: Maybe Text-  , lorObjects'   :: [ObjectInfo]-  , lorCPrefixes' :: [Text]-  } deriving (Show, Eq)---- | Represents information about an object.-data ObjectInfo = ObjectInfo-  { oiObject       :: Object -- ^ Object key-  , oiModTime      :: UTCTime -- ^ Modification time of the object-  , oiETag         :: ETag -- ^ ETag of the object-  , oiSize         :: Int64 -- ^ Size of the object in bytes-  , oiUserMetadata :: H.HashMap Text Text -- ^ A map of user-metadata-                                          -- pairs stored with an-                                          -- object (keys will not-                                          -- have the @X-Amz-Meta-@-                                          -- prefix).-  , oiMetadata     :: H.HashMap Text Text -- ^ A map of metadata-                                          -- key-value pairs (not-                                          -- including the-                                          -- user-metadata pairs)-  } deriving (Show, Eq)---- | Represents source object in server-side copy object-data SourceInfo = SourceInfo-  { srcBucket            :: Text -- ^ Bucket containing the source object-  , srcObject            :: Text -- ^ Source object key-  , srcRange             :: Maybe (Int64, Int64) -- ^ Source object-                                                 -- byte-range-                                                 -- (inclusive)-  , srcIfMatch           :: Maybe Text -- ^ ETag condition on source --                                       -- object is copied only if the-                                       -- source object's ETag matches-                                       -- this value.-  , srcIfNoneMatch       :: Maybe Text -- ^ ETag not match condition-                                       -- on source - object is copied-                                       -- if ETag does not match this-                                       -- value.-  , srcIfModifiedSince   :: Maybe UTCTime -- ^ Copy source object only-                                          -- if the source has been-                                          -- modified since this time.-  , srcIfUnmodifiedSince :: Maybe UTCTime -- ^ Copy source object only-                                          -- if the source has been-                                          -- un-modified since this-                                          -- given time.-  } deriving (Show, Eq)---- | Provide a default for `SourceInfo`-defaultSourceInfo :: SourceInfo-defaultSourceInfo = SourceInfo "" "" Nothing Nothing Nothing Nothing Nothing---- | Represents destination object in server-side copy object-data DestinationInfo = DestinationInfo-                       { dstBucket :: Text -- ^ Destination bucket-                       , dstObject :: Text -- ^ Destination object key-                       } deriving (Show, Eq)---- | Provide a default for `DestinationInfo`-defaultDestinationInfo :: DestinationInfo-defaultDestinationInfo = DestinationInfo "" ""---- | Data type for options when getting an object from the--- service. Start with the empty `defaultGetObjectOptions` and modify--- it using the goo* functions.-data GetObjectOptions = GetObjectOptions {-    -- | Set object's data of given offset begin and end,-    -- [ByteRangeFromTo 0 9] means first ten bytes of the source object.-    gooRange             :: Maybe ByteRange-    -- | Set matching ETag condition, GetObject which matches the following-    -- ETag.-  , gooIfMatch           :: Maybe ETag-    -- | Set matching ETag none condition, GetObject which does not match-    -- the following ETag.-  , gooIfNoneMatch       :: Maybe ETag-    -- | Set object unmodified condition, GetObject unmodified since given time.-  , gooIfUnmodifiedSince :: Maybe UTCTime-    -- | Set object modified condition, GetObject modified since given time.-  , gooIfModifiedSince   :: Maybe UTCTime-    -- | Specify SSE-C key-  , gooSSECKey           :: Maybe SSECKey-  }---- | Provide default  `GetObjectOptions`.-defaultGetObjectOptions :: GetObjectOptions-defaultGetObjectOptions =-    GetObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing--gooToHeaders :: GetObjectOptions -> [HT.Header]-gooToHeaders goo = rangeHdr ++ zip names values-                   ++ maybe [] (toPutObjectHeaders . SSEC) (gooSSECKey goo)-  where-    names = ["If-Match",-             "If-None-Match",-             "If-Unmodified-Since",-             "If-Modified-Since"]-    values = mapMaybe (fmap encodeUtf8 . (goo &))-             [gooIfMatch, gooIfNoneMatch,-              fmap formatRFC1123 . gooIfUnmodifiedSince,-              fmap formatRFC1123 . gooIfModifiedSince]-    rangeHdr = maybe [] (\a -> [(hRange, HT.renderByteRanges [a])])-               $ gooRange goo---- | Data type returned by 'getObject' representing the object being--- retrieved. Use the @gor*@ functions to access its contents.-data GetObjectResponse = GetObjectResponse {-      -- | ObjectInfo of the object being retrieved.-      gorObjectInfo   :: ObjectInfo-      -- | A conduit of the bytes of the object.-    , gorObjectStream :: C.ConduitM () ByteString Minio ()-    }---- | A data-type for events that can occur in the object storage--- server. Reference:--- https://docs.aws.amazon.com/AmazonS3/latest/dev/NotificationHowTo.html#supported-notification-event-types-data Event = ObjectCreated-           | ObjectCreatedPut-           | ObjectCreatedPost-           | ObjectCreatedCopy-           | ObjectCreatedMultipartUpload-           | ObjectRemoved-           | ObjectRemovedDelete-           | ObjectRemovedDeleteMarkerCreated-           | ReducedRedundancyLostObject-           deriving (Eq)--instance Show Event where-  show ObjectCreated                    = "s3:ObjectCreated:*"-  show ObjectCreatedPut                 = "s3:ObjectCreated:Put"-  show ObjectCreatedPost                = "s3:ObjectCreated:Post"-  show ObjectCreatedCopy                = "s3:ObjectCreated:Copy"-  show ObjectCreatedMultipartUpload     = "s3:ObjectCreated:MultipartUpload"-  show ObjectRemoved                    = "s3:ObjectRemoved:*"-  show ObjectRemovedDelete              = "s3:ObjectRemoved:Delete"-  show ObjectRemovedDeleteMarkerCreated = "s3:ObjectRemoved:DeleteMarkerCreated"-  show ReducedRedundancyLostObject      = "s3:ReducedRedundancyLostObject"--textToEvent :: Text -> Maybe Event-textToEvent t = case t of-  "s3:ObjectCreated:*"                   -> Just ObjectCreated-  "s3:ObjectCreated:Put"                 -> Just ObjectCreatedPut-  "s3:ObjectCreated:Post"                -> Just ObjectCreatedPost-  "s3:ObjectCreated:Copy"                -> Just ObjectCreatedCopy-  "s3:ObjectCreated:MultipartUpload"     -> Just ObjectCreatedMultipartUpload-  "s3:ObjectRemoved:*"                   -> Just ObjectRemoved-  "s3:ObjectRemoved:Delete"              -> Just ObjectRemovedDelete-  "s3:ObjectRemoved:DeleteMarkerCreated" -> Just ObjectRemovedDeleteMarkerCreated-  "s3:ReducedRedundancyLostObject"       -> Just ReducedRedundancyLostObject-  _                                      -> Nothing----- | Filter data type - part of notification configuration-data Filter = Filter-  { fFilter :: FilterKey-  } deriving (Show, Eq)---- | defaultFilter is empty, used to create a notification--- configuration.-defaultFilter :: Filter-defaultFilter = Filter defaultFilterKey---- | FilterKey contains FilterRules, and is part of a Filter.-data FilterKey = FilterKey-  { fkKey :: FilterRules-  } deriving (Show, Eq)---- | defaultFilterKey is empty, used to create notification--- configuration.-defaultFilterKey :: FilterKey-defaultFilterKey = FilterKey defaultFilterRules---- | FilterRules represents a collection of `FilterRule`s.-data FilterRules = FilterRules-  { frFilterRules :: [FilterRule]-  } deriving (Show, Eq)---- | defaultFilterRules is empty, used to create notification--- configuration.-defaultFilterRules :: FilterRules-defaultFilterRules = FilterRules []----- | A filter rule that can act based on the suffix or prefix of an--- object. As an example, let's create two filter rules:------    > let suffixRule = FilterRule "suffix" ".jpg"---    > let prefixRule = FilterRule "prefix" "images/"------ The @suffixRule@ restricts the notification to be triggered only--- for objects having a suffix of ".jpg", and the @prefixRule@--- restricts it to objects having a prefix of "images/".-data FilterRule = FilterRule-  { frName  :: Text-  , frValue :: Text-  } deriving (Show, Eq)---- | Arn is an alias of Text-type Arn = Text---- | A data-type representing the configuration for a particular--- notification system. It could represent a Queue, Topic or Lambda--- Function configuration.-data NotificationConfig = NotificationConfig-  { ncId     :: Text-  , ncArn    :: Arn-  , ncEvents :: [Event]-  , ncFilter :: Filter-  } deriving (Show, Eq)---- | A data-type to represent bucket notification configuration. It is--- a collection of queue, topic or lambda function configurations. The--- structure of the types follow closely the XML representation--- described at--- <https://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUTnotification.html>-data Notification = Notification-  { nQueueConfigurations         :: [NotificationConfig]-  , nTopicConfigurations         :: [NotificationConfig]-  , nCloudFunctionConfigurations :: [NotificationConfig]-  } deriving (Eq, Show)---- | The default notification configuration is empty.-defaultNotification :: Notification-defaultNotification = Notification [] [] []-------------------------------------------------------------------------------- Select API Related Types------------------------------------------------------------------------------- | SelectRequest represents the Select API call. Use the--- `selectRequest` function to create a value of this type.-data SelectRequest = SelectRequest-  { srExpression             :: Text-  , srExpressionType         :: ExpressionType-  , srInputSerialization     :: InputSerialization-  , srOutputSerialization    :: OutputSerialization-  , srRequestProgressEnabled :: Maybe Bool-  } deriving (Eq, Show)--data ExpressionType = SQL-                    deriving (Eq, Show)---- | InputSerialization represents format information of the input--- object being queried. Use one of the smart constructors such as--- `defaultCsvInput` as a starting value, and add compression info--- using `setInputCompressionType`-data InputSerialization = InputSerialization-  { isCompressionType :: Maybe CompressionType-  , isFormatInfo      :: InputFormatInfo-  } deriving (Eq, Show)---- | Data type representing the compression setting in a Select--- request.-data CompressionType = CompressionTypeNone-                     | CompressionTypeGzip-                     | CompressionTypeBzip2-                     deriving (Eq, Show)---- | Data type representing input object format information in a--- Select request.-data InputFormatInfo = InputFormatCSV CSVInputProp-                     | InputFormatJSON JSONInputProp-                     | InputFormatParquet-                     deriving (Eq, Show)---- | defaultCsvInput returns InputSerialization with default CSV--- format, and without any compression setting.-defaultCsvInput :: InputSerialization-defaultCsvInput = InputSerialization Nothing (InputFormatCSV defaultCSVProp)---- | linesJsonInput returns InputSerialization with JSON line based--- format with no compression setting.-linesJsonInput :: InputSerialization-linesJsonInput = InputSerialization Nothing-                 (InputFormatJSON $ JSONInputProp JSONTypeLines)---- | documentJsonInput returns InputSerialization with JSON document--- based format with no compression setting.-documentJsonInput :: InputSerialization-documentJsonInput = InputSerialization Nothing-                    (InputFormatJSON $ JSONInputProp JSONTypeDocument)---- | defaultParquetInput returns InputSerialization with Parquet--- format, and no compression setting.-defaultParquetInput :: InputSerialization-defaultParquetInput = InputSerialization Nothing InputFormatParquet---- | setInputCompressionType sets the compression type for the input--- of the SelectRequest-setInputCompressionType :: CompressionType -> SelectRequest-                        -> SelectRequest-setInputCompressionType c i =-    let is = srInputSerialization i-        is' = is { isCompressionType = Just c }-    in i { srInputSerialization = is' }---- | defaultCsvOutput returns OutputSerialization with default CSV--- format.-defaultCsvOutput :: OutputSerialization-defaultCsvOutput = OutputSerializationCSV defaultCSVProp---- | defaultJsonInput returns OutputSerialization with default JSON--- format.-defaultJsonOutput :: OutputSerialization-defaultJsonOutput = OutputSerializationJSON (JSONOutputProp Nothing)---- | selectRequest is used to build a `SelectRequest`--- value. @selectRequest query inputSer outputSer@ represents a--- SelectRequest with the SQL query text given by @query@, the input--- serialization settings (compression format and format information)--- @inputSer@ and the output serialization settings @outputSer@.-selectRequest :: Text -> InputSerialization -> OutputSerialization-              -> SelectRequest-selectRequest sqlQuery inputSer outputSer =-    SelectRequest { srExpression = sqlQuery-                  , srExpressionType = SQL-                  , srInputSerialization = inputSer-                  , srOutputSerialization = outputSer-                  , srRequestProgressEnabled = Nothing-                  }---- | setRequestProgressEnabled sets the flag for turning on progress--- messages when the Select response is being streamed back to the--- client.-setRequestProgressEnabled :: Bool -> SelectRequest -> SelectRequest-setRequestProgressEnabled enabled sr =-    sr { srRequestProgressEnabled = Just enabled }--type CSVInputProp = CSVProp---- | CSVProp represents CSV format properties. It is built up using--- the Monoid instance.-data CSVProp = CSVProp (H.HashMap Text Text)-             deriving (Eq, Show)--#if (__GLASGOW_HASKELL__ >= 804)-instance Semigroup CSVProp where-    (CSVProp a) <> (CSVProp b) = CSVProp (b <> a)-#endif--instance Monoid CSVProp where-    mempty = CSVProp mempty-#if (__GLASGOW_HASKELL__ < 804)-    mappend (CSVProp a) (CSVProp b) = CSVProp (b <> a)-#endif--defaultCSVProp :: CSVProp-defaultCSVProp = mempty---- | Specify the CSV record delimiter property.-recordDelimiter :: Text -> CSVProp-recordDelimiter = CSVProp . H.singleton "RecordDelimiter"---- | Specify the CSV field delimiter property.-fieldDelimiter :: Text -> CSVProp-fieldDelimiter = CSVProp . H.singleton "FieldDelimiter"---- | Specify the CSV quote character property.-quoteCharacter :: Text -> CSVProp-quoteCharacter = CSVProp . H.singleton "QuoteCharacter"---- | Specify the CSV quote-escape character property.-quoteEscapeCharacter :: Text -> CSVProp-quoteEscapeCharacter = CSVProp . H.singleton "QuoteEscapeCharacter"---- | FileHeaderInfo specifies information about column headers for CSV--- format.-data FileHeaderInfo-    = FileHeaderNone -- ^ No column headers are present-    | FileHeaderUse -- ^ Headers are present and they should be used-    | FileHeaderIgnore -- ^ Header are present, but should be ignored-    deriving (Eq, Show)---- | Specify the CSV file header info property.-fileHeaderInfo :: FileHeaderInfo -> CSVProp-fileHeaderInfo = CSVProp . H.singleton "FileHeaderInfo" . toString-  where-    toString FileHeaderNone   = "NONE"-    toString FileHeaderUse    = "USE"-    toString FileHeaderIgnore = "IGNORE"---- | Specify the CSV comment character property. Lines starting with--- this character are ignored by the server.-commentCharacter :: Text -> CSVProp-commentCharacter = CSVProp . H.singleton "Comments"---- | Allow quoted record delimiters inside a row using this property.-allowQuotedRecordDelimiter :: CSVProp-allowQuotedRecordDelimiter = CSVProp $ H.singleton "AllowQuotedRecordDelimiter" "TRUE"---- | Set the CSV format properties in the InputSerialization.-setInputCSVProps :: CSVProp -> InputSerialization -> InputSerialization-setInputCSVProps p is = is { isFormatInfo = InputFormatCSV p }---- | Set the CSV format properties in the OutputSerialization.-outputCSVFromProps :: CSVProp -> OutputSerialization-outputCSVFromProps p = OutputSerializationCSV p--data JSONInputProp = JSONInputProp { jsonipType :: JSONType }-                   deriving (Eq, Show)--data JSONType = JSONTypeDocument | JSONTypeLines-              deriving (Eq, Show)----- | OutputSerialization represents output serialization settings for--- the SelectRequest. Use `defaultCsvOutput` or `defaultJsonOutput` as--- a starting point.-data OutputSerialization = OutputSerializationJSON JSONOutputProp-                         | OutputSerializationCSV CSVOutputProp-                         deriving (Eq, Show)--type CSVOutputProp = CSVProp---- | quoteFields is an output serialization parameter-quoteFields :: QuoteFields -> CSVProp-quoteFields q = CSVProp $ H.singleton "QuoteFields" $-  case q of-    QuoteFieldsAsNeeded -> "ASNEEDED"-    QuoteFieldsAlways   -> "ALWAYS"---- | Represent the QuoteField setting.-data QuoteFields = QuoteFieldsAsNeeded | QuoteFieldsAlways-                 deriving (Eq, Show)--data JSONOutputProp = JSONOutputProp { jsonopRecordDelimiter :: Maybe Text }-                    deriving (Eq, Show)---- | Set the output record delimiter for JSON format-outputJSONFromRecordDelimiter :: Text -> OutputSerialization-outputJSONFromRecordDelimiter t =-    OutputSerializationJSON (JSONOutputProp $ Just t)---- Response related types---- | An EventMessage represents each kind of message received from the server.-data EventMessage = ProgressEventMessage { emProgress :: Progress }-                  | StatsEventMessage { emStats :: Stats }-                  | RequestLevelErrorMessage { emErrorCode    :: Text-                                             , emErrorMessage :: Text-                                             }-                  | RecordPayloadEventMessage { emPayloadBytes :: ByteString }-                  deriving (Eq, Show)--data MsgHeaderName = MessageType-                   | EventType-                   | ContentType-                   | ErrorCode-                   | ErrorMessage-                   deriving (Eq, Show)--msgHeaderValueType :: Word8-msgHeaderValueType = 7--type MessageHeader = (MsgHeaderName, Text)---- | Represent the progress event returned in the Select response.-data Progress = Progress { pBytesScanned   :: Int64-                         , pBytesProcessed :: Int64-                         , pBytesReturned  :: Int64-                         }-              deriving (Eq, Show)---- | Represent the stats event returned at the end of the Select--- response.-type Stats = Progress------------------------------------------------------------------------------- Select API Related Types End------------------------------------------------------------------------------- | Represents different kinds of payload that are used with S3 API--- requests.-data Payload-    = PayloadBS ByteString-    | PayloadH Handle Int64 Int64 -- file handle, offset and length-    | PayloadC Int64 (C.ConduitT () ByteString (ResourceT IO) ()) -- length and byte source--defaultPayload :: Payload-defaultPayload = PayloadBS ""--data AdminReqInfo = AdminReqInfo {-    ariMethod      :: Method-  , ariPayloadHash :: Maybe ByteString-  , ariPayload     :: Payload-  , ariPath        :: ByteString-  , ariHeaders     :: [Header]-  , ariQueryParams :: Query-  }--data S3ReqInfo = S3ReqInfo-  { riMethod        :: Method-  , riBucket        :: Maybe Bucket-  , riObject        :: Maybe Object-  , riQueryParams   :: Query-  , riHeaders       :: [Header]-  , riPayload       :: Payload-  , riPayloadHash   :: Maybe ByteString-  , riRegion        :: Maybe Region-  , riNeedsLocation :: Bool-  }--defaultS3ReqInfo :: S3ReqInfo-defaultS3ReqInfo = S3ReqInfo HT.methodGet Nothing Nothing-                   [] [] defaultPayload Nothing Nothing True--getS3Path :: Maybe Bucket -> Maybe Object -> ByteString-getS3Path b o =-  let segments = map toS $ catMaybes $ b : bool [] [o] (isJust b)-  in-    B.concat ["/", B.intercalate "/" segments]---- | Time to expire for a presigned URL. It interpreted as a number of--- seconds. The maximum duration that can be specified is 7 days.-type UrlExpiry = Int--type RegionMap = H.HashMap Bucket Region---- | The Minio Monad - all computations accessing object storage--- happens in it.-newtype Minio a = Minio {-  unMinio :: ReaderT MinioConn (ResourceT IO) a-  }-  deriving (-      Functor-    , Applicative-    , Monad-    , MonadIO-    , MonadReader MinioConn-    , MonadResource-    )--instance MonadUnliftIO Minio where-  askUnliftIO = Minio $ ReaderT $ \r ->-                withUnliftIO $ \u ->-                return (UnliftIO (unliftIO u . flip runReaderT r . unMinio))---- | MinioConn holds connection info and a connection pool to allow--- for efficient resource re-use.-data MinioConn = MinioConn-  { mcConnInfo    :: ConnectInfo-  , mcConnManager :: NC.Manager-  , mcRegionMap   :: MVar RegionMap-  }--class HasSvcNamespace env where-  getSvcNamespace :: env -> Text--instance HasSvcNamespace MinioConn where-  getSvcNamespace env = let host = connectHost $ mcConnInfo env-                            in if | host  == "storage.googleapis.com" ->-                                    "http://doc.s3.amazonaws.com/2006-03-01"-                                  | otherwise ->-                                    "http://s3.amazonaws.com/doc/2006-03-01/"---- | Takes connection information and returns a connection object to--- be passed to 'runMinio'. The returned value can be kept in the--- application environment and passed to `runMinioWith` whenever--- object storage is accessed.-connect :: ConnectInfo -> IO MinioConn-connect ci = do-  let settings | connectIsSecure ci && connectDisableTLSCertValidation ci =-                 let badTlsSettings = Conn.TLSSettingsSimple True False False-                 in TLS.mkManagerSettings badTlsSettings Nothing-               | connectIsSecure ci = NC.tlsManagerSettings-               | otherwise = defaultManagerSettings-  mgr <- NC.newManager settings-  mkMinioConn ci mgr---- | Run the computation accessing object storage using the given--- `MinioConn`. This reuses connections, but otherwise it is similar--- to `runMinio`.-runMinioWith :: MinioConn -> Minio a -> IO (Either MinioErr a)-runMinioWith conn m = runResourceT $ runMinioResWith conn m---- | Given `ConnectInfo` and a HTTP connection manager, create a--- `MinioConn`.-mkMinioConn :: ConnectInfo -> NC.Manager -> IO MinioConn-mkMinioConn ci mgr = do-    rMapMVar <- M.newMVar H.empty-    return $ MinioConn ci mgr rMapMVar---- | Run the Minio action and return the result or an error.-runMinio :: ConnectInfo -> Minio a -> IO (Either MinioErr a)-runMinio ci m = do-  conn <- connect ci-  runResourceT $ runMinioResWith conn m---- | Similar to 'runMinioWith'. Allows applications to allocate/release--- its resources along side MinIO's internal resources.-runMinioResWith :: MinioConn -> Minio a -> ResourceT IO (Either MinioErr a)-runMinioResWith conn m =-  flip runReaderT conn . unMinio $-    fmap Right m `U.catches`-    [ U.Handler handlerServiceErr-    , U.Handler handlerHE-    , U.Handler handlerFE-    , U.Handler handlerValidation-    ]+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Network.Minio.Data where++import qualified Conduit as C+import qualified Control.Concurrent.MVar as M+import Control.Monad.Trans.Resource+import qualified Data.Aeson as A+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.CaseInsensitive (mk)+import qualified Data.HashMap.Strict as H+import qualified Data.Ini as Ini+import Data.String (IsString (..))+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Time (defaultTimeLocale, formatTime)+import GHC.Show (Show (show))+import Lib.Prelude+import qualified Network.Connection as Conn+import Network.HTTP.Client (defaultManagerSettings)+import qualified Network.HTTP.Client.TLS as TLS+import qualified Network.HTTP.Conduit as NC+import Network.HTTP.Types+  ( ByteRange,+    Header,+    Method,+    Query,+    hRange,+  )+import qualified Network.HTTP.Types as HT+import Network.Minio.Data.Crypto+import Network.Minio.Errors+import System.Directory (doesFileExist, getHomeDirectory)+import qualified System.Environment as Env+import System.FilePath.Posix (combine)+import Text.XML+import qualified UnliftIO as U++-- | max obj size is 5TiB+maxObjectSize :: Int64+maxObjectSize = 5 * 1024 * 1024 * oneMiB++-- | minimum size of parts used in multipart operations.+minPartSize :: Int64+minPartSize = 64 * oneMiB++oneMiB :: Int64+oneMiB = 1024 * 1024++-- | maximum number of parts that can be uploaded for a single object.+maxMultipartParts :: Int64+maxMultipartParts = 10000++-- TODO: Add a type which provides typed constants for region.  this+-- type should have a IsString instance to infer the appropriate+-- constant.++-- | awsRegionMap - library constant+awsRegionMap :: H.HashMap Text Text+awsRegionMap =+  H.fromList+    [ ("us-east-1", "s3.amazonaws.com"),+      ("us-east-2", "s3-us-east-2.amazonaws.com"),+      ("us-west-1", "s3-us-west-1.amazonaws.com"),+      ("us-west-2", "s3-us-west-2.amazonaws.com"),+      ("ca-central-1", "s3-ca-central-1.amazonaws.com"),+      ("ap-south-1", "s3-ap-south-1.amazonaws.com"),+      ("ap-northeast-1", "s3-ap-northeast-1.amazonaws.com"),+      ("ap-northeast-2", "s3-ap-northeast-2.amazonaws.com"),+      ("ap-southeast-1", "s3-ap-southeast-1.amazonaws.com"),+      ("ap-southeast-2", "s3-ap-southeast-2.amazonaws.com"),+      ("eu-west-1", "s3-eu-west-1.amazonaws.com"),+      ("eu-west-2", "s3-eu-west-2.amazonaws.com"),+      ("eu-central-1", "s3-eu-central-1.amazonaws.com"),+      ("sa-east-1", "s3-sa-east-1.amazonaws.com")+    ]++-- | Connection Info data type. To create a 'ConnectInfo' value,+-- enable the @OverloadedStrings@ language extension and use the+-- `IsString` instance to provide a URL, for example:+--+-- > let c :: ConnectInfo = "https://play.min.io"+data ConnectInfo = ConnectInfo+  { connectHost :: Text,+    connectPort :: Int,+    connectAccessKey :: Text,+    connectSecretKey :: Text,+    connectIsSecure :: Bool,+    connectRegion :: Region,+    connectAutoDiscoverRegion :: Bool,+    connectDisableTLSCertValidation :: Bool+  }+  deriving (Eq, Show)++instance IsString ConnectInfo where+  fromString str =+    let req = NC.parseRequest_ str+     in ConnectInfo+          { connectHost = TE.decodeUtf8 $ NC.host req,+            connectPort = NC.port req,+            connectAccessKey = "",+            connectSecretKey = "",+            connectIsSecure = NC.secure req,+            connectRegion = "",+            connectAutoDiscoverRegion = True,+            connectDisableTLSCertValidation = False+          }++-- | Contains access key and secret key to access object storage.+data Credentials = Credentials+  { cAccessKey :: Text,+    cSecretKey :: Text+  }+  deriving (Eq, Show)++-- | A Provider is an action that may return Credentials. Providers+-- may be chained together using 'findFirst'.+type Provider = IO (Maybe Credentials)++-- | Combines the given list of providers, by calling each one in+-- order until Credentials are found.+findFirst :: [Provider] -> Provider+findFirst [] = return Nothing+findFirst (f : fs) = do+  c <- f+  maybe (findFirst fs) (return . Just) c++-- | This Provider loads `Credentials` from @~\/.aws\/credentials@+fromAWSConfigFile :: Provider+fromAWSConfigFile = do+  credsE <- runExceptT $ do+    homeDir <- lift $ getHomeDirectory+    let awsCredsFile = homeDir `combine` ".aws" `combine` "credentials"+    fileExists <- lift $ doesFileExist awsCredsFile+    bool (throwE "FileNotFound") (return ()) fileExists+    ini <- ExceptT $ Ini.readIniFile awsCredsFile+    akey <-+      ExceptT $ return $+        Ini.lookupValue "default" "aws_access_key_id" ini+    skey <-+      ExceptT $ return $+        Ini.lookupValue "default" "aws_secret_access_key" ini+    return $ Credentials akey skey+  return $ hush credsE++-- | This Provider loads `Credentials` from @AWS_ACCESS_KEY_ID@ and+-- @AWS_SECRET_ACCESS_KEY@ environment variables.+fromAWSEnv :: Provider+fromAWSEnv = runMaybeT $ do+  akey <- MaybeT $ Env.lookupEnv "AWS_ACCESS_KEY_ID"+  skey <- MaybeT $ Env.lookupEnv "AWS_SECRET_ACCESS_KEY"+  return $ Credentials (T.pack akey) (T.pack skey)++-- | This Provider loads `Credentials` from @MINIO_ACCESS_KEY@ and+-- @MINIO_SECRET_KEY@ environment variables.+fromMinioEnv :: Provider+fromMinioEnv = runMaybeT $ do+  akey <- MaybeT $ Env.lookupEnv "MINIO_ACCESS_KEY"+  skey <- MaybeT $ Env.lookupEnv "MINIO_SECRET_KEY"+  return $ Credentials (T.pack akey) (T.pack skey)++-- | setCredsFrom retrieves access credentials from the first+-- `Provider` form the given list that succeeds and sets it in the+-- `ConnectInfo`.+setCredsFrom :: [Provider] -> ConnectInfo -> IO ConnectInfo+setCredsFrom ps ci = do+  pMay <- findFirst ps+  maybe+    (throwIO MErrVMissingCredentials)+    (return . (flip setCreds ci))+    pMay++-- | setCreds sets the given `Credentials` in the `ConnectInfo`.+setCreds :: Credentials -> ConnectInfo -> ConnectInfo+setCreds (Credentials accessKey secretKey) connInfo =+  connInfo+    { connectAccessKey = accessKey,+      connectSecretKey = secretKey+    }++-- | Set the S3 region parameter in the `ConnectInfo`+setRegion :: Region -> ConnectInfo -> ConnectInfo+setRegion r connInfo =+  connInfo+    { connectRegion = r,+      connectAutoDiscoverRegion = False+    }++-- | Check if the connection to object storage server is secure+-- (i.e. uses TLS)+isConnectInfoSecure :: ConnectInfo -> Bool+isConnectInfoSecure = connectIsSecure++-- | Disable TLS certificate validation completely! This makes TLS+-- insecure! Use only for testing with self-signed or temporary+-- certificates. Note that this option has no effect, if you provide+-- your own Manager in `mkMinioConn`.+disableTLSCertValidation :: ConnectInfo -> ConnectInfo+disableTLSCertValidation c = c {connectDisableTLSCertValidation = True}++getHostAddr :: ConnectInfo -> ByteString+getHostAddr ci =+  if+      | port == 80 || port == 443 -> toUtf8 host+      | otherwise ->+        toUtf8 $+          T.concat [host, ":", Lib.Prelude.show port]+  where+    port = connectPort ci+    host = connectHost ci++-- | Default Google Compute Storage ConnectInfo. Works only for+-- "Simple Migration" use-case with interoperability mode enabled on+-- GCP console. For more information -+-- https://cloud.google.com/storage/docs/migrating+--+-- Credentials should be supplied before use.+gcsCI :: ConnectInfo+gcsCI =+  setRegion+    "us"+    "https://storage.googleapis.com"++-- | Default AWS S3 ConnectInfo. Connects to "us-east-1". Credentials+-- should be supplied before use.+awsCI :: ConnectInfo+awsCI = "https://s3.amazonaws.com"++-- | <https://play.min.io MinIO Play Server>+-- ConnectInfo. Credentials are already filled in.+minioPlayCI :: ConnectInfo+minioPlayCI =+  let playCreds = Credentials "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"+   in setCreds playCreds $+        setRegion+          "us-east-1"+          "https://play.min.io"++-- |+-- Represents a bucket in the object store+type Bucket = Text++-- |+-- Represents an object name+type Object = Text++-- | Represents a region+type Region = Text++-- | A type alias to represent an Entity-Tag returned by S3-compatible APIs.+type ETag = Text++-- | Data type to represent an object encryption key. Create one using+-- the `mkSSECKey` function.+newtype SSECKey = SSECKey BA.ScrubbedBytes+  deriving (Eq, Show)++-- | Validates that the given ByteString is 32 bytes long and creates+-- an encryption key.+mkSSECKey :: MonadThrow m => ByteString -> m SSECKey+mkSSECKey keyBytes+  | B.length keyBytes /= 32 =+    throwM MErrVInvalidEncryptionKeyLength+  | otherwise =+    return $ SSECKey $ BA.convert keyBytes++-- | Data type to represent Server-Side-Encryption settings+data SSE where+  -- | Specifies SSE S3 encryption - server manages encryption keys+  SSE :: SSE+  -- | Specifies that KMS service should be used. The first argument+  -- to the constructor is the Key Id to be used by the server (if+  -- not specified, the default KMS key id is used). The second+  -- argument is the optional KMS context that must have a+  -- `A.ToJSON` instance - please refer to the AWS S3 documentation+  -- for detailed information.+  SSEKMS :: A.ToJSON a => Maybe ByteString -> Maybe a -> SSE+  -- | Specifies server-side encryption with customer provided+  -- key. The argument is the encryption key to be used.+  SSEC :: SSECKey -> SSE++toPutObjectHeaders :: SSE -> [HT.Header]+toPutObjectHeaders sseArg =+  let sseHeader = "x-amz-server-side-encryption"+      sseKmsIdHeader = sseHeader <> "-aws-kms-key-id"+      sseKmsContextHeader = sseHeader <> "-context"+      ssecAlgo = sseHeader <> "-customer-algorithm"+      ssecKey = sseHeader <> "-customer-key"+      ssecKeyMD5 = ssecKey <> "-MD5"+   in case sseArg of+        SSE -> [(sseHeader, "AES256")]+        SSEKMS keyIdMay ctxMay ->+          [(sseHeader, "aws:kms")]+            ++ maybe [] (\k -> [(sseKmsIdHeader, k)]) keyIdMay+            ++ maybe [] (\k -> [(sseKmsContextHeader, LB.toStrict $ A.encode k)]) ctxMay+        SSEC (SSECKey sb) ->+          [ (ssecAlgo, "AES256"),+            (ssecKey, encodeToBase64 sb),+            (ssecKeyMD5, hashMD5ToBase64 sb)+          ]++-- | Data type for options in PutObject call.  Start with the empty+-- `defaultPutObjectOptions` and use various the various poo*+-- accessors.+data PutObjectOptions = PutObjectOptions+  { -- | Set a standard MIME type describing the format of the object.+    pooContentType :: Maybe Text,+    -- | Set what content encodings have been applied to the object and thus+    -- what decoding mechanisms must be applied to obtain the media-type+    -- referenced by the Content-Type header field.+    pooContentEncoding :: Maybe Text,+    -- | Set presentational information for the object.+    pooContentDisposition :: Maybe Text,+    -- | Set to specify caching behavior for the object along the+    -- request/reply chain.+    pooCacheControl :: Maybe Text,+    -- | Set to describe the language(s) intended for the audience.+    pooContentLanguage :: Maybe Text,+    -- | Set to @STANDARD@ or @REDUCED_REDUNDANCY@ depending on your+    -- performance needs, storage class is @STANDARD@ by default (i.e+    -- when Nothing is passed).+    pooStorageClass :: Maybe Text,+    -- | Set user defined metadata to store with the object.+    pooUserMetadata :: [(Text, Text)],+    -- | Set number of worker threads used to upload an object.+    pooNumThreads :: Maybe Word,+    -- | Set object encryption parameters for the request.+    pooSSE :: Maybe SSE+  }++-- | Provide default `PutObjectOptions`.+defaultPutObjectOptions :: PutObjectOptions+defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing++-- | If the given header name has the @X-Amz-Meta-@ prefix, it is+-- stripped and a Just is returned.+userMetadataHeaderNameMaybe :: Text -> Maybe Text+userMetadataHeaderNameMaybe k =+  let prefix = T.toCaseFold "X-Amz-Meta-"+      n = T.length prefix+   in if T.toCaseFold (T.take n k) == prefix+        then Just (T.drop n k)+        else Nothing++addXAmzMetaPrefix :: Text -> Text+addXAmzMetaPrefix s+  | isJust (userMetadataHeaderNameMaybe s) = s+  | otherwise = "X-Amz-Meta-" <> s++mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header]+mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix $ x, encodeUtf8 y))++pooToHeaders :: PutObjectOptions -> [HT.Header]+pooToHeaders poo =+  userMetadata+    ++ (catMaybes $ map tupToMaybe (zipWith (,) names values))+    ++ maybe [] toPutObjectHeaders (pooSSE poo)+  where+    tupToMaybe (k, Just v) = Just (k, v)+    tupToMaybe (_, Nothing) = Nothing+    userMetadata = mkHeaderFromMetadata $ pooUserMetadata poo+    names =+      [ "content-type",+        "content-encoding",+        "content-disposition",+        "content-language",+        "cache-control",+        "x-amz-storage-class"+      ]+    values =+      map+        (fmap encodeUtf8 . (poo &))+        [ pooContentType,+          pooContentEncoding,+          pooContentDisposition,+          pooContentLanguage,+          pooCacheControl,+          pooStorageClass+        ]++-- |+-- BucketInfo returned for list buckets call+data BucketInfo = BucketInfo+  { biName :: Bucket,+    biCreationDate :: UTCTime+  }+  deriving (Show, Eq)++-- | A type alias to represent a part-number for multipart upload+type PartNumber = Int16++-- | A type alias to represent an upload-id for multipart upload+type UploadId = Text++-- | A type to represent a part-number and etag.+type PartTuple = (PartNumber, ETag)++-- | Represents result from a listing of object parts of an ongoing+-- multipart upload.+data ListPartsResult = ListPartsResult+  { lprHasMore :: Bool,+    lprNextPart :: Maybe Int,+    lprParts :: [ObjectPartInfo]+  }+  deriving (Show, Eq)++-- | Represents information about an object part in an ongoing+-- multipart upload.+data ObjectPartInfo = ObjectPartInfo+  { opiNumber :: PartNumber,+    opiETag :: ETag,+    opiSize :: Int64,+    opiModTime :: UTCTime+  }+  deriving (Show, Eq)++-- | Represents result from a listing of incomplete uploads to a+-- bucket.+data ListUploadsResult = ListUploadsResult+  { lurHasMore :: Bool,+    lurNextKey :: Maybe Text,+    lurNextUpload :: Maybe Text,+    lurUploads :: [(Object, UploadId, UTCTime)],+    lurCPrefixes :: [Text]+  }+  deriving (Show, Eq)++-- | Represents information about a multipart upload.+data UploadInfo = UploadInfo+  { uiKey :: Object,+    uiUploadId :: UploadId,+    uiInitTime :: UTCTime,+    uiSize :: Int64+  }+  deriving (Show, Eq)++-- | Represents result from a listing of objects in a bucket.+data ListObjectsResult = ListObjectsResult+  { lorHasMore :: Bool,+    lorNextToken :: Maybe Text,+    lorObjects :: [ObjectInfo],+    lorCPrefixes :: [Text]+  }+  deriving (Show, Eq)++-- | Represents result from a listing of objects version 1 in a bucket.+data ListObjectsV1Result = ListObjectsV1Result+  { lorHasMore' :: Bool,+    lorNextMarker :: Maybe Text,+    lorObjects' :: [ObjectInfo],+    lorCPrefixes' :: [Text]+  }+  deriving (Show, Eq)++-- | Represents information about an object.+data ObjectInfo = ObjectInfo+  { -- | Object key+    oiObject :: Object,+    -- | Modification time of the object+    oiModTime :: UTCTime,+    -- | ETag of the object+    oiETag :: ETag,+    -- | Size of the object in bytes+    oiSize :: Int64,+    -- | A map of user-metadata+    -- pairs stored with an+    -- object (keys will not+    -- have the @X-Amz-Meta-@+    -- prefix).+    oiUserMetadata :: H.HashMap Text Text,+    -- | A map of metadata+    -- key-value pairs (not+    -- including the+    -- user-metadata pairs)+    oiMetadata :: H.HashMap Text Text+  }+  deriving (Show, Eq)++-- | Represents source object in server-side copy object+data SourceInfo = SourceInfo+  { -- | Bucket containing the source object+    srcBucket :: Text,+    -- | Source object key+    srcObject :: Text,+    -- | Source object+    -- byte-range+    -- (inclusive)+    srcRange :: Maybe (Int64, Int64),+    -- | ETag condition on source -+    -- object is copied only if the+    -- source object's ETag matches+    -- this value.+    srcIfMatch :: Maybe Text,+    -- | ETag not match condition+    -- on source - object is copied+    -- if ETag does not match this+    -- value.+    srcIfNoneMatch :: Maybe Text,+    -- | Copy source object only+    -- if the source has been+    -- modified since this time.+    srcIfModifiedSince :: Maybe UTCTime,+    -- | Copy source object only+    -- if the source has been+    -- un-modified since this+    -- given time.+    srcIfUnmodifiedSince :: Maybe UTCTime+  }+  deriving (Show, Eq)++-- | Provide a default for `SourceInfo`+defaultSourceInfo :: SourceInfo+defaultSourceInfo = SourceInfo "" "" Nothing Nothing Nothing Nothing Nothing++-- | Represents destination object in server-side copy object+data DestinationInfo = DestinationInfo+  { -- | Destination bucket+    dstBucket :: Text,+    -- | Destination object key+    dstObject :: Text+  }+  deriving (Show, Eq)++-- | Provide a default for `DestinationInfo`+defaultDestinationInfo :: DestinationInfo+defaultDestinationInfo = DestinationInfo "" ""++-- | Data type for options when getting an object from the+-- service. Start with the empty `defaultGetObjectOptions` and modify+-- it using the goo* functions.+data GetObjectOptions = GetObjectOptions+  { -- | Set object's data of given offset begin and end,+    -- [ByteRangeFromTo 0 9] means first ten bytes of the source object.+    gooRange :: Maybe ByteRange,+    -- | Set matching ETag condition, GetObject which matches the following+    -- ETag.+    gooIfMatch :: Maybe ETag,+    -- | Set matching ETag none condition, GetObject which does not match+    -- the following ETag.+    gooIfNoneMatch :: Maybe ETag,+    -- | Set object unmodified condition, GetObject unmodified since given time.+    gooIfUnmodifiedSince :: Maybe UTCTime,+    -- | Set object modified condition, GetObject modified since given time.+    gooIfModifiedSince :: Maybe UTCTime,+    -- | Specify SSE-C key+    gooSSECKey :: Maybe SSECKey+  }++-- | Provide default  `GetObjectOptions`.+defaultGetObjectOptions :: GetObjectOptions+defaultGetObjectOptions =+  GetObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing++gooToHeaders :: GetObjectOptions -> [HT.Header]+gooToHeaders goo =+  rangeHdr ++ zip names values+    ++ maybe [] (toPutObjectHeaders . SSEC) (gooSSECKey goo)+  where+    names =+      [ "If-Match",+        "If-None-Match",+        "If-Unmodified-Since",+        "If-Modified-Since"+      ]+    values =+      mapMaybe+        (fmap encodeUtf8 . (goo &))+        [ gooIfMatch,+          gooIfNoneMatch,+          fmap formatRFC1123 . gooIfUnmodifiedSince,+          fmap formatRFC1123 . gooIfModifiedSince+        ]+    rangeHdr =+      maybe [] (\a -> [(hRange, HT.renderByteRanges [a])]) $+        gooRange goo++-- | Data type returned by 'getObject' representing the object being+-- retrieved. Use the @gor*@ functions to access its contents.+data GetObjectResponse = GetObjectResponse+  { -- | ObjectInfo of the object being retrieved.+    gorObjectInfo :: ObjectInfo,+    -- | A conduit of the bytes of the object.+    gorObjectStream :: C.ConduitM () ByteString Minio ()+  }++-- | A data-type for events that can occur in the object storage+-- server. Reference:+-- https://docs.aws.amazon.com/AmazonS3/latest/dev/NotificationHowTo.html#supported-notification-event-types+data Event+  = ObjectCreated+  | ObjectCreatedPut+  | ObjectCreatedPost+  | ObjectCreatedCopy+  | ObjectCreatedMultipartUpload+  | ObjectRemoved+  | ObjectRemovedDelete+  | ObjectRemovedDeleteMarkerCreated+  | ReducedRedundancyLostObject+  deriving (Eq)++instance Show Event where+  show ObjectCreated = "s3:ObjectCreated:*"+  show ObjectCreatedPut = "s3:ObjectCreated:Put"+  show ObjectCreatedPost = "s3:ObjectCreated:Post"+  show ObjectCreatedCopy = "s3:ObjectCreated:Copy"+  show ObjectCreatedMultipartUpload = "s3:ObjectCreated:MultipartUpload"+  show ObjectRemoved = "s3:ObjectRemoved:*"+  show ObjectRemovedDelete = "s3:ObjectRemoved:Delete"+  show ObjectRemovedDeleteMarkerCreated = "s3:ObjectRemoved:DeleteMarkerCreated"+  show ReducedRedundancyLostObject = "s3:ReducedRedundancyLostObject"++textToEvent :: Text -> Maybe Event+textToEvent t = case t of+  "s3:ObjectCreated:*" -> Just ObjectCreated+  "s3:ObjectCreated:Put" -> Just ObjectCreatedPut+  "s3:ObjectCreated:Post" -> Just ObjectCreatedPost+  "s3:ObjectCreated:Copy" -> Just ObjectCreatedCopy+  "s3:ObjectCreated:MultipartUpload" -> Just ObjectCreatedMultipartUpload+  "s3:ObjectRemoved:*" -> Just ObjectRemoved+  "s3:ObjectRemoved:Delete" -> Just ObjectRemovedDelete+  "s3:ObjectRemoved:DeleteMarkerCreated" -> Just ObjectRemovedDeleteMarkerCreated+  "s3:ReducedRedundancyLostObject" -> Just ReducedRedundancyLostObject+  _ -> Nothing++-- | Filter data type - part of notification configuration+data Filter = Filter+  { fFilter :: FilterKey+  }+  deriving (Show, Eq)++-- | defaultFilter is empty, used to create a notification+-- configuration.+defaultFilter :: Filter+defaultFilter = Filter defaultFilterKey++-- | FilterKey contains FilterRules, and is part of a Filter.+data FilterKey = FilterKey+  { fkKey :: FilterRules+  }+  deriving (Show, Eq)++-- | defaultFilterKey is empty, used to create notification+-- configuration.+defaultFilterKey :: FilterKey+defaultFilterKey = FilterKey defaultFilterRules++-- | FilterRules represents a collection of `FilterRule`s.+data FilterRules = FilterRules+  { frFilterRules :: [FilterRule]+  }+  deriving (Show, Eq)++-- | defaultFilterRules is empty, used to create notification+-- configuration.+defaultFilterRules :: FilterRules+defaultFilterRules = FilterRules []++-- | A filter rule that can act based on the suffix or prefix of an+-- object. As an example, let's create two filter rules:+--+--    > let suffixRule = FilterRule "suffix" ".jpg"+--    > let prefixRule = FilterRule "prefix" "images/"+--+-- The @suffixRule@ restricts the notification to be triggered only+-- for objects having a suffix of ".jpg", and the @prefixRule@+-- restricts it to objects having a prefix of "images/".+data FilterRule = FilterRule+  { frName :: Text,+    frValue :: Text+  }+  deriving (Show, Eq)++-- | Arn is an alias of Text+type Arn = Text++-- | A data-type representing the configuration for a particular+-- notification system. It could represent a Queue, Topic or Lambda+-- Function configuration.+data NotificationConfig = NotificationConfig+  { ncId :: Text,+    ncArn :: Arn,+    ncEvents :: [Event],+    ncFilter :: Filter+  }+  deriving (Show, Eq)++-- | A data-type to represent bucket notification configuration. It is+-- a collection of queue, topic or lambda function configurations. The+-- structure of the types follow closely the XML representation+-- described at+-- <https://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUTnotification.html>+data Notification = Notification+  { nQueueConfigurations :: [NotificationConfig],+    nTopicConfigurations :: [NotificationConfig],+    nCloudFunctionConfigurations :: [NotificationConfig]+  }+  deriving (Eq, Show)++-- | The default notification configuration is empty.+defaultNotification :: Notification+defaultNotification = Notification [] [] []++--------------------------------------------------------------------------+-- Select API Related Types+--------------------------------------------------------------------------++-- | SelectRequest represents the Select API call. Use the+-- `selectRequest` function to create a value of this type.+data SelectRequest = SelectRequest+  { srExpression :: Text,+    srExpressionType :: ExpressionType,+    srInputSerialization :: InputSerialization,+    srOutputSerialization :: OutputSerialization,+    srRequestProgressEnabled :: Maybe Bool+  }+  deriving (Eq, Show)++data ExpressionType = SQL+  deriving (Eq, Show)++-- | InputSerialization represents format information of the input+-- object being queried. Use one of the smart constructors such as+-- `defaultCsvInput` as a starting value, and add compression info+-- using `setInputCompressionType`+data InputSerialization = InputSerialization+  { isCompressionType :: Maybe CompressionType,+    isFormatInfo :: InputFormatInfo+  }+  deriving (Eq, Show)++-- | Data type representing the compression setting in a Select+-- request.+data CompressionType+  = CompressionTypeNone+  | CompressionTypeGzip+  | CompressionTypeBzip2+  deriving (Eq, Show)++-- | Data type representing input object format information in a+-- Select request.+data InputFormatInfo+  = InputFormatCSV CSVInputProp+  | InputFormatJSON JSONInputProp+  | InputFormatParquet+  deriving (Eq, Show)++-- | defaultCsvInput returns InputSerialization with default CSV+-- format, and without any compression setting.+defaultCsvInput :: InputSerialization+defaultCsvInput = InputSerialization Nothing (InputFormatCSV defaultCSVProp)++-- | linesJsonInput returns InputSerialization with JSON line based+-- format with no compression setting.+linesJsonInput :: InputSerialization+linesJsonInput =+  InputSerialization+    Nothing+    (InputFormatJSON $ JSONInputProp JSONTypeLines)++-- | documentJsonInput returns InputSerialization with JSON document+-- based format with no compression setting.+documentJsonInput :: InputSerialization+documentJsonInput =+  InputSerialization+    Nothing+    (InputFormatJSON $ JSONInputProp JSONTypeDocument)++-- | defaultParquetInput returns InputSerialization with Parquet+-- format, and no compression setting.+defaultParquetInput :: InputSerialization+defaultParquetInput = InputSerialization Nothing InputFormatParquet++-- | setInputCompressionType sets the compression type for the input+-- of the SelectRequest+setInputCompressionType ::+  CompressionType ->+  SelectRequest ->+  SelectRequest+setInputCompressionType c i =+  let is = srInputSerialization i+      is' = is {isCompressionType = Just c}+   in i {srInputSerialization = is'}++-- | defaultCsvOutput returns OutputSerialization with default CSV+-- format.+defaultCsvOutput :: OutputSerialization+defaultCsvOutput = OutputSerializationCSV defaultCSVProp++-- | defaultJsonInput returns OutputSerialization with default JSON+-- format.+defaultJsonOutput :: OutputSerialization+defaultJsonOutput = OutputSerializationJSON (JSONOutputProp Nothing)++-- | selectRequest is used to build a `SelectRequest`+-- value. @selectRequest query inputSer outputSer@ represents a+-- SelectRequest with the SQL query text given by @query@, the input+-- serialization settings (compression format and format information)+-- @inputSer@ and the output serialization settings @outputSer@.+selectRequest ::+  Text ->+  InputSerialization ->+  OutputSerialization ->+  SelectRequest+selectRequest sqlQuery inputSer outputSer =+  SelectRequest+    { srExpression = sqlQuery,+      srExpressionType = SQL,+      srInputSerialization = inputSer,+      srOutputSerialization = outputSer,+      srRequestProgressEnabled = Nothing+    }++-- | setRequestProgressEnabled sets the flag for turning on progress+-- messages when the Select response is being streamed back to the+-- client.+setRequestProgressEnabled :: Bool -> SelectRequest -> SelectRequest+setRequestProgressEnabled enabled sr =+  sr {srRequestProgressEnabled = Just enabled}++type CSVInputProp = CSVProp++-- | CSVProp represents CSV format properties. It is built up using+-- the Monoid instance.+data CSVProp = CSVProp (H.HashMap Text Text)+  deriving (Eq, Show)++#if (__GLASGOW_HASKELL__ >= 804)+instance Semigroup CSVProp where+    (CSVProp a) <> (CSVProp b) = CSVProp (b <> a)+#endif++instance Monoid CSVProp where+  mempty = CSVProp mempty++#if (__GLASGOW_HASKELL__ < 804)+    mappend (CSVProp a) (CSVProp b) = CSVProp (b <> a)+#endif++defaultCSVProp :: CSVProp+defaultCSVProp = mempty++-- | Specify the CSV record delimiter property.+recordDelimiter :: Text -> CSVProp+recordDelimiter = CSVProp . H.singleton "RecordDelimiter"++-- | Specify the CSV field delimiter property.+fieldDelimiter :: Text -> CSVProp+fieldDelimiter = CSVProp . H.singleton "FieldDelimiter"++-- | Specify the CSV quote character property.+quoteCharacter :: Text -> CSVProp+quoteCharacter = CSVProp . H.singleton "QuoteCharacter"++-- | Specify the CSV quote-escape character property.+quoteEscapeCharacter :: Text -> CSVProp+quoteEscapeCharacter = CSVProp . H.singleton "QuoteEscapeCharacter"++-- | FileHeaderInfo specifies information about column headers for CSV+-- format.+data FileHeaderInfo+  = -- | No column headers are present+    FileHeaderNone+  | -- | Headers are present and they should be used+    FileHeaderUse+  | -- | Header are present, but should be ignored+    FileHeaderIgnore+  deriving (Eq, Show)++-- | Specify the CSV file header info property.+fileHeaderInfo :: FileHeaderInfo -> CSVProp+fileHeaderInfo = CSVProp . H.singleton "FileHeaderInfo" . toString+  where+    toString FileHeaderNone = "NONE"+    toString FileHeaderUse = "USE"+    toString FileHeaderIgnore = "IGNORE"++-- | Specify the CSV comment character property. Lines starting with+-- this character are ignored by the server.+commentCharacter :: Text -> CSVProp+commentCharacter = CSVProp . H.singleton "Comments"++-- | Allow quoted record delimiters inside a row using this property.+allowQuotedRecordDelimiter :: CSVProp+allowQuotedRecordDelimiter = CSVProp $ H.singleton "AllowQuotedRecordDelimiter" "TRUE"++-- | Set the CSV format properties in the InputSerialization.+setInputCSVProps :: CSVProp -> InputSerialization -> InputSerialization+setInputCSVProps p is = is {isFormatInfo = InputFormatCSV p}++-- | Set the CSV format properties in the OutputSerialization.+outputCSVFromProps :: CSVProp -> OutputSerialization+outputCSVFromProps p = OutputSerializationCSV p++data JSONInputProp = JSONInputProp {jsonipType :: JSONType}+  deriving (Eq, Show)++data JSONType = JSONTypeDocument | JSONTypeLines+  deriving (Eq, Show)++-- | OutputSerialization represents output serialization settings for+-- the SelectRequest. Use `defaultCsvOutput` or `defaultJsonOutput` as+-- a starting point.+data OutputSerialization+  = OutputSerializationJSON JSONOutputProp+  | OutputSerializationCSV CSVOutputProp+  deriving (Eq, Show)++type CSVOutputProp = CSVProp++-- | quoteFields is an output serialization parameter+quoteFields :: QuoteFields -> CSVProp+quoteFields q = CSVProp $ H.singleton "QuoteFields" $+  case q of+    QuoteFieldsAsNeeded -> "ASNEEDED"+    QuoteFieldsAlways -> "ALWAYS"++-- | Represent the QuoteField setting.+data QuoteFields = QuoteFieldsAsNeeded | QuoteFieldsAlways+  deriving (Eq, Show)++data JSONOutputProp = JSONOutputProp {jsonopRecordDelimiter :: Maybe Text}+  deriving (Eq, Show)++-- | Set the output record delimiter for JSON format+outputJSONFromRecordDelimiter :: Text -> OutputSerialization+outputJSONFromRecordDelimiter t =+  OutputSerializationJSON (JSONOutputProp $ Just t)++-- Response related types++-- | An EventMessage represents each kind of message received from the server.+data EventMessage+  = ProgressEventMessage {emProgress :: Progress}+  | StatsEventMessage {emStats :: Stats}+  | RequestLevelErrorMessage+      { emErrorCode :: Text,+        emErrorMessage :: Text+      }+  | RecordPayloadEventMessage {emPayloadBytes :: ByteString}+  deriving (Eq, Show)++data MsgHeaderName+  = MessageType+  | EventType+  | ContentType+  | ErrorCode+  | ErrorMessage+  deriving (Eq, Show)++msgHeaderValueType :: Word8+msgHeaderValueType = 7++type MessageHeader = (MsgHeaderName, Text)++-- | Represent the progress event returned in the Select response.+data Progress = Progress+  { pBytesScanned :: Int64,+    pBytesProcessed :: Int64,+    pBytesReturned :: Int64+  }+  deriving (Eq, Show)++-- | Represent the stats event returned at the end of the Select+-- response.+type Stats = Progress++--------------------------------------------------------------------------+-- Select API Related Types End+--------------------------------------------------------------------------++-- | Represents different kinds of payload that are used with S3 API+-- requests.+data Payload+  = PayloadBS ByteString+  | PayloadH Handle Int64 Int64 -- file handle, offset and length+  | PayloadC Int64 (C.ConduitT () ByteString (ResourceT IO) ()) -- length and byte source++defaultPayload :: Payload+defaultPayload = PayloadBS ""++data AdminReqInfo = AdminReqInfo+  { ariMethod :: Method,+    ariPayloadHash :: Maybe ByteString,+    ariPayload :: Payload,+    ariPath :: ByteString,+    ariHeaders :: [Header],+    ariQueryParams :: Query+  }++data S3ReqInfo = S3ReqInfo+  { riMethod :: Method,+    riBucket :: Maybe Bucket,+    riObject :: Maybe Object,+    riQueryParams :: Query,+    riHeaders :: [Header],+    riPayload :: Payload,+    riPayloadHash :: Maybe ByteString,+    riRegion :: Maybe Region,+    riNeedsLocation :: Bool+  }++defaultS3ReqInfo :: S3ReqInfo+defaultS3ReqInfo =+  S3ReqInfo+    HT.methodGet+    Nothing+    Nothing+    []+    []+    defaultPayload+    Nothing+    Nothing+    True++getS3Path :: Maybe Bucket -> Maybe Object -> ByteString+getS3Path b o =+  let segments = map toUtf8 $ catMaybes $ b : bool [] [o] (isJust b)+   in B.concat ["/", B.intercalate "/" segments]++-- | Time to expire for a presigned URL. It interpreted as a number of+-- seconds. The maximum duration that can be specified is 7 days.+type UrlExpiry = Int++type RegionMap = H.HashMap Bucket Region++-- | The Minio Monad - all computations accessing object storage+-- happens in it.+newtype Minio a = Minio+  { unMinio :: ReaderT MinioConn (ResourceT IO) a+  }+  deriving+    ( Functor,+      Applicative,+      Monad,+      MonadIO,+      MonadReader MinioConn,+      MonadResource,+      MonadUnliftIO+    )++-- | MinioConn holds connection info and a connection pool to allow+-- for efficient resource re-use.+data MinioConn = MinioConn+  { mcConnInfo :: ConnectInfo,+    mcConnManager :: NC.Manager,+    mcRegionMap :: MVar RegionMap+  }++class HasSvcNamespace env where+  getSvcNamespace :: env -> Text++instance HasSvcNamespace MinioConn where+  getSvcNamespace env =+    let host = connectHost $ mcConnInfo env+     in if+            | host == "storage.googleapis.com" ->+              "http://doc.s3.amazonaws.com/2006-03-01"+            | otherwise ->+              "http://s3.amazonaws.com/doc/2006-03-01/"++-- | Takes connection information and returns a connection object to+-- be passed to 'runMinio'. The returned value can be kept in the+-- application environment and passed to `runMinioWith` whenever+-- object storage is accessed.+connect :: ConnectInfo -> IO MinioConn+connect ci = do+  let settings+        | connectIsSecure ci && connectDisableTLSCertValidation ci =+          let badTlsSettings = Conn.TLSSettingsSimple True False False+           in TLS.mkManagerSettings badTlsSettings Nothing+        | connectIsSecure ci = NC.tlsManagerSettings+        | otherwise = defaultManagerSettings+  mgr <- NC.newManager settings+  mkMinioConn ci mgr++-- | Run the computation accessing object storage using the given+-- `MinioConn`. This reuses connections, but otherwise it is similar+-- to `runMinio`.+runMinioWith :: MinioConn -> Minio a -> IO (Either MinioErr a)+runMinioWith conn m = runResourceT $ runMinioResWith conn m++-- | Given `ConnectInfo` and a HTTP connection manager, create a+-- `MinioConn`.+mkMinioConn :: ConnectInfo -> NC.Manager -> IO MinioConn+mkMinioConn ci mgr = do+  rMapMVar <- M.newMVar H.empty+  return $ MinioConn ci mgr rMapMVar++-- | Run the Minio action and return the result or an error.+runMinio :: ConnectInfo -> Minio a -> IO (Either MinioErr a)+runMinio ci m = do+  conn <- connect ci+  runResourceT $ runMinioResWith conn m++-- | Similar to 'runMinioWith'. Allows applications to allocate/release+-- its resources along side MinIO's internal resources.+runMinioResWith :: MinioConn -> Minio a -> ResourceT IO (Either MinioErr a)+runMinioResWith conn m =+  flip runReaderT conn . unMinio $+    fmap Right m+      `U.catches` [ U.Handler handlerServiceErr,+                    U.Handler handlerHE,+                    U.Handler handlerFE,+                    U.Handler handlerValidation+                  ]   where     handlerServiceErr = return . Left . MErrService     handlerHE = return . Left . MErrHTTP
src/Network/Minio/Data/ByteString.hs view
@@ -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-  , UriEncodable(..)-  ) where+  ( stripBS,+    UriEncodable (..),+  )+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 Lib.Prelude+import Numeric (showHex)  stripBS :: ByteString -> ByteString stripBS = BC8.dropWhile isSpace . fst . BC8.spanEnd isSpace@@ -40,7 +39,7 @@ instance UriEncodable [Char] where   uriEncode encodeSlash payload =     LB.toStrict $ BB.toLazyByteString $ mconcat $-    map (`uriEncodeChar` encodeSlash) payload+      map (`uriEncodeChar` encodeSlash) payload  instance UriEncodable ByteString where   -- assumes that uriEncode is passed ASCII encoded strings.@@ -59,16 +58,17 @@ uriEncodeChar '/' False = BB.char7 '/' uriEncodeChar ch _   | isAsciiUpper ch-    || isAsciiLower ch-    || isDigit ch-    || (ch == '_')-    || (ch == '-')-    || (ch == '.')-    || (ch == '~') = BB.char7 ch+      || isAsciiLower ch+      || isDigit ch+      || (ch == '_')+      || (ch == '-')+      || (ch == '.')+      || (ch == '~') =+    BB.char7 ch   | otherwise = mconcat $ map f $ B.unpack $ encodeUtf8 $ T.singleton ch   where     f :: Word8 -> BB.Builder     f n = BB.char7 '%' <> BB.string7 hexStr       where         hexStr = map toUpper $ showHex q $ showHex r ""-        (q, r) = divMod (fromIntegral n) (16::Word8)+        (q, r) = divMod (fromIntegral n) (16 :: Word8)
src/Network/Minio/Data/Crypto.hs view
@@ -15,31 +15,31 @@ --  module Network.Minio.Data.Crypto-  (-    hashSHA256-  , hashSHA256FromSource--  , hashMD5-  , hashMD5ToBase64-  , hashMD5FromSource--  , hmacSHA256-  , 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+  ( hashSHA256,+    hashSHA256FromSource,+    hashMD5,+    hashMD5ToBase64,+    hashMD5FromSource,+    hmacSHA256,+    hmacSHA256RawBS,+    digestToBS,+    digestToBase16,+    encodeToBase64,+  )+where -import           Lib.Prelude+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 hashSHA256 = digestToBase16 . hashWith SHA256
src/Network/Minio/Data/Time.hs view
@@ -15,20 +15,18 @@ --  module Network.Minio.Data.Time-  (-    awsTimeFormat-  , awsTimeFormatBS-  , awsDateFormat-  , awsDateFormatBS-  , awsParseTime-  , iso8601TimeFormat-  ) where-+  ( awsTimeFormat,+    awsTimeFormatBS,+    awsDateFormat,+    awsDateFormatBS,+    awsParseTime,+    iso8601TimeFormat,+  )+where -import           Data.ByteString.Char8 (pack)+import Data.ByteString.Char8 (pack) import qualified Data.Time as Time--import           Lib.Prelude+import Lib.Prelude  awsTimeFormat :: UTCTime -> [Char] awsTimeFormat = Time.formatTime Time.defaultTimeLocale "%Y%m%dT%H%M%SZ"
src/Network/Minio/Errors.hs view
@@ -16,74 +16,75 @@  module Network.Minio.Errors where -import           Control.Exception+import Control.Exception+import Lib.Prelude import qualified Network.HTTP.Conduit as NC -import           Lib.Prelude-- --------------------------------- -- Errors ---------------------------------+ -- | Various validation errors-data MErrV = MErrVSinglePUTSizeExceeded Int64-           | MErrVPutSizeExceeded Int64-           | MErrVETagHeaderNotFound-           | MErrVInvalidObjectInfoResponse-           | MErrVInvalidSrcObjSpec Text-           | MErrVInvalidSrcObjByteRange (Int64, Int64)-           | MErrVCopyObjSingleNoRangeAccepted-           | MErrVRegionNotSupported Text-           | MErrVXmlParse Text-           | MErrVInvalidBucketName Text-           | MErrVInvalidObjectName Text-           | MErrVInvalidUrlExpiry Int-           | MErrVJsonParse Text-           | MErrVInvalidHealPath-           | MErrVMissingCredentials-           | MErrVInvalidEncryptionKeyLength-           | MErrVStreamingBodyUnexpectedEOF-           | MErrVUnexpectedPayload+data MErrV+  = MErrVSinglePUTSizeExceeded Int64+  | MErrVPutSizeExceeded Int64+  | MErrVETagHeaderNotFound+  | MErrVInvalidObjectInfoResponse+  | MErrVInvalidSrcObjSpec Text+  | MErrVInvalidSrcObjByteRange (Int64, Int64)+  | MErrVCopyObjSingleNoRangeAccepted+  | MErrVRegionNotSupported Text+  | MErrVXmlParse Text+  | MErrVInvalidBucketName Text+  | MErrVInvalidObjectName Text+  | MErrVInvalidUrlExpiry Int+  | MErrVJsonParse Text+  | MErrVInvalidHealPath+  | MErrVMissingCredentials+  | MErrVInvalidEncryptionKeyLength+  | MErrVStreamingBodyUnexpectedEOF+  | MErrVUnexpectedPayload   deriving (Show, Eq)  instance Exception MErrV  -- | Errors returned by S3 compatible service-data ServiceErr = BucketAlreadyExists-                | BucketAlreadyOwnedByYou-                | NoSuchBucket-                | InvalidBucketName-                | NoSuchKey-                | SelectErr Text Text-                | ServiceErr Text Text+data ServiceErr+  = BucketAlreadyExists+  | BucketAlreadyOwnedByYou+  | NoSuchBucket+  | InvalidBucketName+  | NoSuchKey+  | SelectErr Text Text+  | ServiceErr Text Text   deriving (Show, Eq)  instance Exception ServiceErr  toServiceErr :: Text -> Text -> ServiceErr-toServiceErr "NoSuchKey" _               = NoSuchKey-toServiceErr "NoSuchBucket" _            = NoSuchBucket-toServiceErr "InvalidBucketName" _       = InvalidBucketName+toServiceErr "NoSuchKey" _ = NoSuchKey+toServiceErr "NoSuchBucket" _ = NoSuchBucket+toServiceErr "InvalidBucketName" _ = InvalidBucketName toServiceErr "BucketAlreadyOwnedByYou" _ = BucketAlreadyOwnedByYou-toServiceErr "BucketAlreadyExists" _     = BucketAlreadyExists-toServiceErr code message                = ServiceErr code message-+toServiceErr "BucketAlreadyExists" _ = BucketAlreadyExists+toServiceErr code message = ServiceErr code message  -- | Errors thrown by the library-data MinioErr = MErrHTTP NC.HttpException-              | MErrIO IOException-              | MErrService ServiceErr-              | MErrValidation MErrV+data MinioErr+  = MErrHTTP NC.HttpException+  | MErrIO IOException+  | MErrService ServiceErr+  | MErrValidation MErrV   deriving (Show)  instance Eq MinioErr where-  MErrHTTP _       == MErrHTTP _        = True-  MErrHTTP _       ==  _                = False-  MErrIO _         == MErrIO _          = True-  MErrIO _         == _                 = False-  MErrService a    == MErrService b     = a == b-  MErrService _    == _                 = False-  MErrValidation a == MErrValidation b  = a == b-  MErrValidation _ == _                 = False+  MErrHTTP _ == MErrHTTP _ = True+  MErrHTTP _ == _ = False+  MErrIO _ == MErrIO _ = True+  MErrIO _ == _ = False+  MErrService a == MErrService b = a == b+  MErrService _ == _ = False+  MErrValidation a == MErrValidation b = a == b+  MErrValidation _ == _ = False  instance Exception MinioErr
src/Network/Minio/JsonParser.hs view
@@ -15,28 +15,35 @@ --  module Network.Minio.JsonParser-  (-    parseErrResponseJSON-  ) where--import           Data.Aeson           (FromJSON, eitherDecode, parseJSON,-                                       withObject, (.:))-import qualified Data.Text            as T+  ( parseErrResponseJSON,+  )+where -import           Lib.Prelude+import Data.Aeson+  ( (.:),+    FromJSON,+    eitherDecode,+    parseJSON,+    withObject,+  )+import qualified Data.Text as T+import Lib.Prelude+import Network.Minio.Errors -import           Network.Minio.Errors+data AdminErrJSON = AdminErrJSON+  { aeCode :: Text,+    aeMessage :: Text+  }+  deriving (Eq, Show) -data AdminErrJSON = AdminErrJSON { aeCode    :: Text-                                 , aeMessage :: Text-                                 } deriving (Eq, Show) instance FromJSON AdminErrJSON where-  parseJSON = withObject "AdminErrJSON" $ \v -> AdminErrJSON-    <$> v .: "Code"-    <*> v .: "Message"+  parseJSON = withObject "AdminErrJSON" $ \v ->+    AdminErrJSON+      <$> v .: "Code"+      <*> v .: "Message"  parseErrResponseJSON :: (MonadIO m) => LByteString -> m ServiceErr parseErrResponseJSON jsondata =   case eitherDecode jsondata of     Right aErr -> return $ toServiceErr (aeCode aErr) (aeMessage aErr)-    Left err   -> throwIO $ MErrVJsonParse $ T.pack err+    Left err -> throwIO $ MErrVJsonParse $ T.pack err
src/Network/Minio/ListOps.hs view
@@ -16,20 +16,19 @@  module Network.Minio.ListOps where -import qualified Data.Conduit             as C+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+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-              | ListItemPrefix Text-    deriving (Show, Eq)+data ListItem+  = ListItemObject ObjectInfo+  | ListItemPrefix Text+  deriving (Show, Eq)  -- | @'listObjects' bucket prefix recurse@ lists objects in a bucket -- similar to a file system tree traversal.@@ -48,73 +47,99 @@   where     loop :: Maybe Text -> C.ConduitM () ListItem Minio ()     loop nextToken = do-      let-        delimiter = bool (Just "/") Nothing recurse+      let delimiter = bool (Just "/") Nothing recurse        res <- lift $ listObjects' bucket prefix nextToken delimiter Nothing       CL.sourceList $ map ListItemObject $ lorObjects res-      unless recurse $-        CL.sourceList $ map ListItemPrefix $ lorCPrefixes res+      unless recurse+        $ CL.sourceList+        $ map ListItemPrefix+        $ lorCPrefixes res       when (lorHasMore res) $         loop (lorNextToken res)  -- | Lists objects - similar to @listObjects@, however uses the older -- V1 AWS S3 API. Prefer @listObjects@ to this.-listObjectsV1 :: Bucket -> Maybe Text -> Bool-              -> C.ConduitM () ListItem Minio ()+listObjectsV1 ::+  Bucket ->+  Maybe Text ->+  Bool ->+  C.ConduitM () ListItem Minio () listObjectsV1 bucket prefix recurse = loop Nothing   where     loop :: Maybe Text -> C.ConduitM () ListItem Minio ()     loop nextMarker = do-      let-        delimiter = bool (Just "/") Nothing recurse+      let delimiter = bool (Just "/") Nothing recurse        res <- lift $ listObjectsV1' bucket prefix nextMarker delimiter Nothing       CL.sourceList $ map ListItemObject $ lorObjects' res-      unless recurse $-        CL.sourceList $ map ListItemPrefix $ lorCPrefixes' res+      unless recurse+        $ CL.sourceList+        $ map ListItemPrefix+        $ lorCPrefixes' res       when (lorHasMore' res) $         loop (lorNextMarker res)  -- | List incomplete uploads in a bucket matching the given prefix. If -- recurse is set to True incomplete uploads for the given prefix are -- recursively listed.-listIncompleteUploads :: Bucket -> Maybe Text -> Bool-                      -> C.ConduitM () UploadInfo Minio ()+listIncompleteUploads ::+  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-        delimiter = bool (Just "/") Nothing recurse+      let delimiter = bool (Just "/") Nothing recurse -      res <- lift $ listIncompleteUploads' bucket prefix delimiter-             nextKeyMarker nextUploadIdMarker Nothing+      res <-+        lift $+          listIncompleteUploads'+            bucket+            prefix+            delimiter+            nextKeyMarker+            nextUploadIdMarker+            Nothing        aggrSizes <- lift $ forM (lurUploads res) $ \(uKey, uId, _) -> do-            partInfos <- C.runConduit $ listIncompleteParts bucket uKey uId-                    C..| CC.sinkList-            return $ foldl (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos+        partInfos <-+          C.runConduit $+            listIncompleteParts bucket uKey uId+              C..| CC.sinkList+        return $ foldl (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos -      CL.sourceList $-        map (\((uKey, uId, uInitTime), size) ->-                UploadInfo uKey uId uInitTime size-            ) $ zip (lurUploads res) aggrSizes+      CL.sourceList+        $ map+          ( \((uKey, uId, uInitTime), size) ->+              UploadInfo uKey uId uInitTime size+          )+        $ 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-                    -> C.ConduitM () ObjectPartInfo Minio ()+listIncompleteParts ::+  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-             nextPartMarker+      res <-+        lift $+          listIncompleteParts'+            bucket+            object+            uploadId+            Nothing+            nextPartMarker       CL.sourceList $ lprParts res       when (lprHasMore res) $         loop (show <$> lprNextPart res)
src/Network/Minio/PresignedOperations.hs view
@@ -15,43 +15,40 @@ --  module Network.Minio.PresignedOperations-  ( UrlExpiry-  , makePresignedUrl-  , presignedPutObjectUrl-  , presignedGetObjectUrl-  , presignedHeadObjectUrl--  , PostPolicyCondition(..)-  , ppCondBucket-  , ppCondContentLengthRange-  , ppCondContentType-  , ppCondKey-  , ppCondKeyStartsWith-  , ppCondSuccessActionStatus--  , PostPolicy(..)-  , PostPolicyError(..)-  , newPostPolicy-  , showPostPolicy-  , presignedPostPolicy-  ) where--import           Data.Aeson                ((.=))-import qualified Data.Aeson                as Json-import           Data.ByteString.Builder   (byteString, toLazyByteString)-import qualified Data.HashMap.Strict       as H-import qualified Data.Text                 as T-import qualified Data.Time                 as Time-import qualified Network.HTTP.Conduit      as NC-import qualified Network.HTTP.Types        as HT-import           Network.HTTP.Types.Header (hHost)--import           Lib.Prelude+  ( UrlExpiry,+    makePresignedUrl,+    presignedPutObjectUrl,+    presignedGetObjectUrl,+    presignedHeadObjectUrl,+    PostPolicyCondition (..),+    ppCondBucket,+    ppCondContentLengthRange,+    ppCondContentType,+    ppCondKey,+    ppCondKeyStartsWith,+    ppCondSuccessActionStatus,+    PostPolicy (..),+    PostPolicyError (..),+    newPostPolicy,+    showPostPolicy,+    presignedPostPolicy,+  )+where -import           Network.Minio.Data-import           Network.Minio.Data.Time-import           Network.Minio.Errors-import           Network.Minio.Sign.V4+import Data.Aeson ((.=))+import qualified Data.Aeson as Json+import Data.ByteString.Builder (byteString, toLazyByteString)+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import qualified Data.Time as Time+import Lib.Prelude+import qualified Network.HTTP.Conduit as NC+import qualified Network.HTTP.Types as HT+import Network.HTTP.Types.Header (hHost)+import Network.Minio.Data+import Network.Minio.Data.Time+import Network.Minio.Errors+import Network.Minio.Sign.V4  -- | Generate a presigned URL. This function allows for advanced usage -- - for simple cases prefer the `presigned*Url` functions.@@ -61,42 +58,56 @@ -- -- All extra query parameters or headers are signed, and therefore are -- required to be sent when the generated URL is actually used.-makePresignedUrl :: UrlExpiry -> HT.Method -> Maybe Bucket -> Maybe Object-                 -> Maybe Region -> HT.Query -> HT.RequestHeaders-                 -> Minio ByteString+makePresignedUrl ::+  UrlExpiry ->+  HT.Method ->+  Maybe Bucket ->+  Maybe Object ->+  Maybe Region ->+  HT.Query ->+  HT.RequestHeaders ->+  Minio ByteString makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do-  when (expiry > 7*24*3600 || expiry < 0) $-    throwIO $ MErrVInvalidUrlExpiry expiry+  when (expiry > 7 * 24 * 3600 || expiry < 0)+    $ throwIO+    $ MErrVInvalidUrlExpiry expiry    ci <- asks mcConnInfo -  let-    hostHeader = (hHost, getHostAddr ci)-    req = NC.defaultRequest {-          NC.method = method-        , NC.secure = connectIsSecure ci-        , NC.host = encodeUtf8 $ connectHost ci-        , NC.port = connectPort ci-        , NC.path = getS3Path bucket object-        , NC.requestHeaders = hostHeader : extraHeaders-        , NC.queryString = HT.renderQuery True extraQuery-        }+  let hostHeader = (hHost, getHostAddr ci)+      req =+        NC.defaultRequest+          { NC.method = method,+            NC.secure = connectIsSecure ci,+            NC.host = encodeUtf8 $ connectHost ci,+            NC.port = connectPort ci,+            NC.path = getS3Path bucket object,+            NC.requestHeaders = hostHeader : extraHeaders,+            NC.queryString = HT.renderQuery True extraQuery+          }   ts <- liftIO Time.getCurrentTime -  let sp = SignParams (connectAccessKey ci) (connectSecretKey ci)-           ts region (Just expiry) Nothing-+  let sp =+        SignParams+          (connectAccessKey ci)+          (connectSecretKey ci)+          ts+          region+          (Just expiry)+          Nothing       signPairs = signV4 sp req-       qpToAdd = (fmap . fmap) Just signPairs-      queryStr = HT.renderQueryBuilder True-                 ((HT.parseQuery $ NC.queryString req) ++ qpToAdd)+      queryStr =+        HT.renderQueryBuilder+          True+          ((HT.parseQuery $ NC.queryString req) ++ qpToAdd)       scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci -  return $ toS $ toLazyByteString $ scheme-     <> byteString (getHostAddr ci)-     <> byteString (getS3Path bucket object)-     <> queryStr+  return $ toStrictBS $ toLazyByteString $+    scheme+      <> byteString (getHostAddr ci)+      <> byteString (getS3Path bucket object)+      <> queryStr  -- | Generate a URL with authentication signature to PUT (upload) an -- object. Any extra headers if passed, are signed, and so they are@@ -105,12 +116,22 @@ -- -- For a list of possible headers to pass, please refer to the PUT -- object REST API AWS S3 documentation.-presignedPutObjectUrl :: Bucket -> Object -> UrlExpiry -> HT.RequestHeaders-                      -> Minio ByteString+presignedPutObjectUrl ::+  Bucket ->+  Object ->+  UrlExpiry ->+  HT.RequestHeaders ->+  Minio ByteString presignedPutObjectUrl bucket object expirySeconds extraHeaders = do   region <- asks (Just . connectRegion . mcConnInfo)-  makePresignedUrl expirySeconds HT.methodPut-      (Just bucket) (Just object) region [] extraHeaders+  makePresignedUrl+    expirySeconds+    HT.methodPut+    (Just bucket)+    (Just object)+    region+    []+    extraHeaders  -- | Generate a URL with authentication signature to GET (download) an -- object. All extra query parameters and headers passed here will be@@ -121,12 +142,23 @@ -- -- For a list of possible request parameters and headers, please refer -- to the GET object REST API AWS S3 documentation.-presignedGetObjectUrl :: Bucket -> Object -> UrlExpiry -> HT.Query-                      -> HT.RequestHeaders -> Minio ByteString+presignedGetObjectUrl ::+  Bucket ->+  Object ->+  UrlExpiry ->+  HT.Query ->+  HT.RequestHeaders ->+  Minio ByteString presignedGetObjectUrl bucket object expirySeconds extraQuery extraHeaders = do   region <- asks (Just . connectRegion . mcConnInfo)-  makePresignedUrl expirySeconds HT.methodGet-      (Just bucket) (Just object) region extraQuery extraHeaders+  makePresignedUrl+    expirySeconds+    HT.methodGet+    (Just bucket)+    (Just object)+    region+    extraQuery+    extraHeaders  -- | Generate a URL with authentication signature to make a HEAD -- request on an object. This is used to fetch metadata about an@@ -135,18 +167,29 @@ -- -- For a list of possible headers to pass, please refer to the HEAD -- object REST API AWS S3 documentation.-presignedHeadObjectUrl :: Bucket -> Object -> UrlExpiry-                       -> HT.RequestHeaders -> Minio ByteString+presignedHeadObjectUrl ::+  Bucket ->+  Object ->+  UrlExpiry ->+  HT.RequestHeaders ->+  Minio ByteString presignedHeadObjectUrl bucket object expirySeconds extraHeaders = do   region <- asks (Just . connectRegion . mcConnInfo)-  makePresignedUrl expirySeconds HT.methodHead-      (Just bucket) (Just object) region [] extraHeaders+  makePresignedUrl+    expirySeconds+    HT.methodHead+    (Just bucket)+    (Just object)+    region+    []+    extraHeaders  -- | Represents individual conditions in a Post Policy document.-data PostPolicyCondition = PPCStartsWith Text Text-                         | PPCEquals Text Text-                         | PPCRange Text Int64 Int64-                         deriving (Show, Eq)+data PostPolicyCondition+  = PPCStartsWith Text Text+  | PPCEquals Text Text+  | PPCRange Text Int64 Int64+  deriving (Show, Eq)  instance Json.ToJSON PostPolicyCondition where   toJSON (PPCStartsWith k v) = Json.toJSON ["starts-with", k, v]@@ -160,25 +203,28 @@     Json.foldable [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal]  -- | A PostPolicy is required to perform uploads via browser forms.-data PostPolicy = PostPolicy {-    expiration :: UTCTime-  , conditions :: [PostPolicyCondition]-  } deriving (Show, Eq)+data PostPolicy = PostPolicy+  { expiration :: UTCTime,+    conditions :: [PostPolicyCondition]+  }+  deriving (Show, Eq)  instance Json.ToJSON PostPolicy where   toJSON (PostPolicy e c) =-    Json.object $ [ "expiration" .= iso8601TimeFormat e-                  , "conditions" .= c-                  ]+    Json.object $+      [ "expiration" .= iso8601TimeFormat e,+        "conditions" .= c+      ]   toEncoding (PostPolicy e c) =     Json.pairs ("expiration" .= iso8601TimeFormat e <> "conditions" .= c)  -- | Possible validation errors when creating a PostPolicy.-data PostPolicyError = PPEKeyNotSpecified-                     | PPEBucketNotSpecified-                     | PPEConditionKeyEmpty-                     | PPERangeInvalid-                     deriving (Eq, Show)+data PostPolicyError+  = PPEKeyNotSpecified+  | PPEBucketNotSpecified+  | PPEConditionKeyEmpty+  | PPERangeInvalid+  deriving (Eq, Show)  -- | Set the bucket name that the upload should use. ppCondBucket :: Bucket -> PostPolicyCondition@@ -186,8 +232,10 @@  -- | Set the content length range constraint with minimum and maximum -- byte count values.-ppCondContentLengthRange :: Int64 -> Int64-                         -> PostPolicyCondition+ppCondContentLengthRange ::+  Int64 ->+  Int64 ->+  PostPolicyCondition ppCondContentLengthRange = PPCRange "content-length-range"  -- | Set the content-type header for the upload.@@ -210,83 +258,91 @@  -- | This function creates a PostPolicy after validating its -- arguments.-newPostPolicy :: UTCTime -> [PostPolicyCondition]-              -> Either PostPolicyError PostPolicy+newPostPolicy ::+  UTCTime ->+  [PostPolicyCondition] ->+  Either PostPolicyError PostPolicy newPostPolicy expirationTime conds   -- object name condition must be present   | not $ any (keyEquals "key") conds =-      Left PPEKeyNotSpecified-+    Left PPEKeyNotSpecified   -- bucket name condition must be present   | not $ any (keyEquals "bucket") conds =-      Left PPEBucketNotSpecified-+    Left PPEBucketNotSpecified   -- a condition with an empty key is invalid   | any (keyEquals "") conds || any isEmptyRangeKey conds =-      Left PPEConditionKeyEmpty-+    Left PPEConditionKeyEmpty   -- invalid range check   | any isInvalidRange conds =-      Left PPERangeInvalid-+    Left PPERangeInvalid   -- all good!   | otherwise =-      return $ PostPolicy expirationTime conds-+    return $ PostPolicy expirationTime conds   where     keyEquals k' (PPCStartsWith k _) = k == k'-    keyEquals k' (PPCEquals k _)     = k == k'-    keyEquals _ _                    = False-+    keyEquals k' (PPCEquals k _) = k == k'+    keyEquals _ _ = False     isEmptyRangeKey (PPCRange k _ _) = k == ""-    isEmptyRangeKey _                = False-+    isEmptyRangeKey _ = False     isInvalidRange (PPCRange _ mi ma) = mi < 0 || mi > ma-    isInvalidRange _                  = False+    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-                    -> Minio (ByteString, H.HashMap Text ByteString)+presignedPostPolicy ::+  PostPolicy ->+  Minio (ByteString, H.HashMap Text ByteString) presignedPostPolicy p = do   ci <- asks mcConnInfo   signTime <- liftIO $ Time.getCurrentTime -  let-    extraConditions =-      [ PPCEquals "x-amz-date" (toS $ awsTimeFormat signTime)-      , PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256"-      , PPCEquals "x-amz-credential"-        (T.intercalate "/" [connectAccessKey ci,-                            decodeUtf8 $ mkScope signTime region])-      ]-    ppWithCreds = p {-      conditions = conditions p ++ extraConditions-      }-    sp = 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 $-                     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 = toS $ toLazyByteString $ scheme <> byteString (getHostAddr ci) <>-          byteString "/" <> byteString (toS bucket) <> byteString "/"+  let extraConditions =+        [ PPCEquals "x-amz-date" (toS $ awsTimeFormat signTime),+          PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256",+          PPCEquals+            "x-amz-credential"+            ( T.intercalate+                "/"+                [ connectAccessKey ci,+                  decodeUtf8 $ mkScope signTime region+                ]+            )+        ]+      ppWithCreds =+        p+          { conditions = conditions p ++ extraConditions+          }+      sp =+        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 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 =+        toStrictBS $ toLazyByteString $+          scheme <> byteString (getHostAddr ci)+            <> byteString "/"+            <> byteString bucket+            <> byteString "/"    return (url, formData)
src/Network/Minio/PutObject.hs view
@@ -15,29 +15,24 @@ --  module Network.Minio.PutObject-  (-    putObjectInternal-  , ObjectData(..)-  , selectPartSizes-  ) where-+  ( putObjectInternal,+    ObjectData (..),+    selectPartSizes,+  )+where -import           Conduit                  (takeC)-import qualified Conduit                  as C-import qualified Data.ByteString.Lazy     as LBS-import qualified Data.Conduit.Binary      as CB+import Conduit (takeC)+import qualified Conduit as C+import qualified Data.ByteString.Lazy as LBS+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-+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,37 +45,45 @@ -- 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-                                  -- size.-  | ODStream (C.ConduitM () ByteString m ()) (Maybe Int64) -- ^ Pass-                                                           -- size-                                                           -- (bytes)-                                                           -- if-                                                           -- known.+  = -- | Takes filepath and optional+    -- size.+    ODFile FilePath (Maybe Int64)+  | -- | Pass+    -- size+    -- (bytes)+    -- if+    -- known.+    ODStream (C.ConduitM () ByteString m ()) (Maybe Int64)  -- | Put an object from ObjectData. This high-level API handles -- objects of all sizes, and even if the object size is unknown.-putObjectInternal :: Bucket -> Object -> PutObjectOptions-                  -> ObjectData Minio -> Minio ETag+putObjectInternal ::+  Bucket ->+  Object ->+  PutObjectOptions ->+  ObjectData Minio ->+  Minio ETag putObjectInternal b o opts (ODStream src sizeMay) = do   case sizeMay of     -- unable to get size, so assume non-seekable file     Nothing -> sequentialMultipartUpload b o opts Nothing src-     -- got file size, so check for single/multipart upload     Just size ->-      if | size <= 64 * oneMiB -> do-             bs <- C.runConduit $ src C..| takeC (fromIntegral size) C..| CB.sinkLbs-             putObjectSingle' b o (pooToHeaders opts) $ LBS.toStrict bs-         | size > maxObjectSize -> throwIO $ MErrVPutSizeExceeded size-         | otherwise -> sequentialMultipartUpload b o opts (Just size) src-+      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-                                 hResE+  (isSeekable, handleSizeMay) <-+    either+      (const $ return (False, Nothing))+      return+      hResE    -- prefer given size to queried size.   let finalSizeMay = listToMaybe $ catMaybes [sizeMay, handleSizeMay]@@ -88,18 +91,25 @@   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 =<<-           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) $-                        CB.sourceFile fp+      if+          | 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) $+              CB.sourceFile fp -parallelMultipartUpload :: Bucket -> Object -> PutObjectOptions-                        -> FilePath -> Int64 -> Minio ETag+parallelMultipartUpload ::+  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 @@   let threads = fromMaybe 10 $ pooNumThreads opts    -- perform upload with 'threads' threads-  uploadedPartsE <- limitedMapConcurrently (fromIntegral threads)-                    (uploadPart uploadId) partSizeInfo+  uploadedPartsE <-+    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 @@         putObjectPart b o uploadId partNum [] payload  -- | Upload multipart object from conduit source sequentially-sequentialMultipartUpload :: Bucket -> Object -> PutObjectOptions-                          -> Maybe Int64-                          -> C.ConduitM () ByteString Minio ()-                          -> Minio ETag+sequentialMultipartUpload ::+  Bucket ->+  Object ->+  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,22 +151,23 @@   -- upload parts in loop   let partSizes = selectPartSizes $ maybe maxObjectSize identity sizeMay       (pnums, _, sizes) = List.unzip3 partSizes-  uploadedParts <- C.runConduit-                 $ src-              C..| chunkBSConduit (map fromIntegral sizes)-              C..| CL.map PayloadBS-              C..| uploadPart' uploadId pnums-              C..| CC.sinkList+  uploadedParts <-+    C.runConduit $+      src+        C..| chunkBSConduit (map fromIntegral sizes)+        C..| CL.map PayloadBS+        C..| uploadPart' uploadId pnums+        C..| CC.sinkList    -- complete multipart upload   completeMultipartUpload b o uploadId uploadedParts-   where     uploadPart' _ [] = return ()-    uploadPart' uid (pn:pns) = do+    uploadPart' uid (pn : pns) = do       payloadMay <- C.await       case payloadMay of         Nothing -> return ()-        Just payload -> do pinfo <- lift $ putObjectPart b o uid pn [] payload-                           C.yield pinfo-                           uploadPart' uid pns+        Just payload -> do+          pinfo <- lift $ putObjectPart b o uid pn [] payload+          C.yield pinfo+          uploadPart' uid pns
src/Network/Minio/S3API.hs view
@@ -15,150 +15,166 @@ --  module Network.Minio.S3API-  (-    Region-  , getLocation--  -- * Listing buckets-  ---------------------  , getService--  -- * Listing objects-  ---------------------  , ListObjectsResult(..)-  , ListObjectsV1Result(..)-  , listObjects'-  , listObjectsV1'+  ( Region,+    getLocation, -  -- * Retrieving buckets-  , headBucket+    -- * Listing buckets+    --------------------+    getService, -  -- * Retrieving objects-  ------------------------  , getObject'-  , headObject+    -- * Listing objects+    --------------------+    ListObjectsResult (..),+    ListObjectsV1Result (..),+    listObjects',+    listObjectsV1', -  -- * Creating buckets and objects-  ----------------------------------  , putBucket-  , ETag-  , maxSinglePutObjectSizeBytes-  , putObjectSingle'-  , putObjectSingle-  , copyObjectSingle+    -- * Retrieving buckets+    headBucket, -  -- * Multipart Upload APIs-  ---------------------------  , UploadId-  , PartTuple-  , Payload(..)-  , PartNumber-  , newMultipartUpload-  , putObjectPart-  , copyObjectPart-  , completeMultipartUpload-  , abortMultipartUpload-  , ListUploadsResult(..)-  , listIncompleteUploads'-  , ListPartsResult(..)-  , listIncompleteParts'+    -- * Retrieving objects+    -----------------------+    getObject',+    headObject, -  -- * Deletion APIs-  ---------------------------  , deleteBucket-  , deleteObject+    -- * Creating buckets and objects+    ---------------------------------+    putBucket,+    ETag,+    maxSinglePutObjectSizeBytes,+    putObjectSingle',+    putObjectSingle,+    copyObjectSingle, -  -- * Presigned Operations-  ------------------------------  , module Network.Minio.PresignedOperations+    -- * Multipart Upload APIs+    --------------------------+    UploadId,+    PartTuple,+    Payload (..),+    PartNumber,+    newMultipartUpload,+    putObjectPart,+    copyObjectPart,+    completeMultipartUpload,+    abortMultipartUpload,+    ListUploadsResult (..),+    listIncompleteUploads',+    ListPartsResult (..),+    listIncompleteParts', -  -- ** Bucket Policies-  , getBucketPolicy-  , setBucketPolicy+    -- * Deletion APIs+    --------------------------+    deleteBucket,+    deleteObject, -  -- * Bucket Notifications-  --------------------------  , Notification(..)-  , NotificationConfig(..)-  , Arn-  , Event(..)-  , Filter(..)-  , FilterKey(..)-  , FilterRules(..)-  , FilterRule(..)-  , getBucketNotification-  , putBucketNotification-  , removeAllBucketNotification-  ) where+    -- * Presigned Operations+    -----------------------------+    module Network.Minio.PresignedOperations, -import qualified Data.ByteString                   as BS-import qualified Data.Text                         as T-import qualified Network.HTTP.Conduit              as NC-import qualified Network.HTTP.Types                as HT-import           Network.HTTP.Types.Status         (status404)-import           UnliftIO                          (Handler (Handler))+    -- ** Bucket Policies+    getBucketPolicy,+    setBucketPolicy, -import           Lib.Prelude+    -- * Bucket Notifications+    -------------------------+    Notification (..),+    NotificationConfig (..),+    Arn,+    Event (..),+    Filter (..),+    FilterKey (..),+    FilterRules (..),+    FilterRule (..),+    getBucketNotification,+    putBucketNotification,+    removeAllBucketNotification,+  )+where -import           Network.Minio.API-import           Network.Minio.APICommon-import           Network.Minio.Data-import           Network.Minio.Errors-import           Network.Minio.PresignedOperations-import           Network.Minio.Utils-import           Network.Minio.XmlGenerator-import           Network.Minio.XmlParser+import 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 Network.Minio.API+import Network.Minio.APICommon+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.PresignedOperations+import Network.Minio.Utils+import Network.Minio.XmlGenerator+import Network.Minio.XmlParser+import UnliftIO (Handler (Handler))  -- | Fetch all buckets from the service. getService :: Minio [BucketInfo] getService = do-  resp <- executeRequest $ defaultS3ReqInfo {-      riNeedsLocation = False-    }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riNeedsLocation = False+        }   parseListBuckets $ NC.responseBody resp  -- Parse headers from getObject and headObject calls. parseGetObjectHeaders :: Object -> [HT.Header] -> Maybe ObjectInfo parseGetObjectHeaders object headers =-    let metadataPairs = getMetadata headers-        userMetadata = getUserMetadataMap metadataPairs-        metadata = getNonUserMetadataMap metadataPairs-    in ObjectInfo <$> Just object-                  <*> getLastModifiedHeader headers-                  <*> getETagHeader headers-                  <*> getContentLength headers-                  <*> Just userMetadata-                  <*> Just metadata+  let metadataPairs = getMetadata headers+      userMetadata = getUserMetadataMap metadataPairs+      metadata = getNonUserMetadataMap metadataPairs+   in ObjectInfo <$> Just object+        <*> getLastModifiedHeader headers+        <*> getETagHeader headers+        <*> getContentLength headers+        <*> Just userMetadata+        <*> Just metadata  -- | GET an object from the service and return parsed ObjectInfo and a -- conduit source for the object content-getObject' :: Bucket -> Object -> HT.Query -> [HT.Header]-           -> Minio GetObjectResponse+getObject' ::+  Bucket ->+  Object ->+  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-               objInfoMaybe-    return $ GetObjectResponse { gorObjectInfo = objInfo-                               , gorObjectStream = NC.responseBody resp-                               }+  resp <- mkStreamRequest reqInfo+  let objInfoMaybe = parseGetObjectHeaders object $ NC.responseHeaders resp+  objInfo <-+    maybe+      (throwIO MErrVInvalidObjectInfoResponse)+      return+      objInfoMaybe+  return $+    GetObjectResponse+      { gorObjectInfo = objInfo,+        gorObjectStream = NC.responseBody resp+      }   where-    reqInfo = defaultS3ReqInfo { riBucket = Just bucket-                               , riObject = Just object-                               , riQueryParams = queryParams-                               , riHeaders = headers-                               }+    reqInfo =+      defaultS3ReqInfo+        { riBucket = Just bucket,+          riObject = Just object,+          riQueryParams = queryParams,+          riHeaders = headers+               -- This header is required for safety as otherwise http-client,+               -- sends Accept-Encoding: gzip, and the server may actually gzip+               -- body. In that case Content-Length header will be missing.+            <> [("Accept-Encoding", "identity")]+        }  -- | Creates a bucket via a PUT bucket call. putBucket :: Bucket -> Region -> Minio () putBucket bucket location = do   ns <- asks getSvcNamespace   void $ executeRequest $-    defaultS3ReqInfo { riMethod = HT.methodPut-        , riBucket = Just bucket-        , riPayload = PayloadBS $ mkCreateBucketConfig ns location-        , riNeedsLocation = False-        }+    defaultS3ReqInfo+      { riMethod = HT.methodPut,+        riBucket = Just bucket,+        riPayload = PayloadBS $ mkCreateBucketConfig ns location,+        riNeedsLocation = False+      }  -- | Single PUT object size. maxSinglePutObjectSizeBytes :: Int64@@ -172,315 +188,432 @@ putObjectSingle' bucket object headers bs = do   let size = fromIntegral (BS.length bs)   -- check length is within single PUT object size.-  when (size > maxSinglePutObjectSizeBytes) $-    throwIO $ MErrVSinglePUTSizeExceeded size+  when (size > maxSinglePutObjectSizeBytes)+    $ throwIO+    $ MErrVSinglePUTSizeExceeded size    let payload = mkStreamingPayload $ PayloadBS bs-  resp <- executeRequest $-          defaultS3ReqInfo { riMethod = HT.methodPut-              , riBucket = Just bucket-              , riObject = Just object-              , riHeaders = headers-              , riPayload = payload-              }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just bucket,+          riObject = Just object,+          riHeaders = headers,+          riPayload = payload+        }    let rheaders = NC.responseHeaders resp       etag = getETagHeader rheaders   maybe     (throwIO MErrVETagHeaderNotFound)-    return etag+    return+    etag  -- | PUT an object into the service. This function performs a single -- PUT object call, and so can only transfer objects upto 5GiB.-putObjectSingle :: Bucket -> Object -> [HT.Header] -> Handle -> Int64-                -> Int64 -> Minio ETag+putObjectSingle ::+  Bucket ->+  Object ->+  [HT.Header] ->+  Handle ->+  Int64 ->+  Int64 ->+  Minio ETag putObjectSingle bucket object headers h offset size = do   -- check length is within single PUT object size.-  when (size > maxSinglePutObjectSizeBytes) $-    throwIO $ MErrVSinglePUTSizeExceeded size+  when (size > maxSinglePutObjectSizeBytes)+    $ throwIO+    $ MErrVSinglePUTSizeExceeded size    -- content-length header is automatically set by library.   let payload = mkStreamingPayload $ PayloadH h offset size-  resp <- executeRequest $-          defaultS3ReqInfo { riMethod = HT.methodPut-                           , riBucket = Just bucket-                           , riObject = Just object-                           , riHeaders = headers-                           , riPayload = payload-                           }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just bucket,+          riObject = Just object,+          riHeaders = headers,+          riPayload = payload+        }    let rheaders = NC.responseHeaders resp       etag = getETagHeader rheaders   maybe     (throwIO MErrVETagHeaderNotFound)-    return etag+    return+    etag  -- | List objects in a bucket matching prefix up to delimiter, -- starting from nextMarker.-listObjectsV1' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int-            -> Minio ListObjectsV1Result+listObjectsV1' ::+  Bucket ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Int ->+  Minio ListObjectsV1Result listObjectsV1' bucket prefix nextMarker delimiter maxKeys = do-  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet-                               , riBucket = Just bucket-                               , riQueryParams = mkOptionalParams params-                               }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodGet,+          riBucket = Just bucket,+          riQueryParams = mkOptionalParams params+        }   parseListObjectsV1Response $ NC.responseBody resp   where-    params = [-        ("marker", nextMarker)-      , ("prefix", prefix)-      , ("delimiter", delimiter)-      , ("max-keys", show <$> maxKeys)+    params =+      [ ("marker", nextMarker),+        ("prefix", prefix),+        ("delimiter", delimiter),+        ("max-keys", show <$> maxKeys)       ]  -- | List objects in a bucket matching prefix up to delimiter, -- starting from nextToken.-listObjects' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int-            -> Minio ListObjectsResult+listObjects' ::+  Bucket ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Int ->+  Minio ListObjectsResult listObjects' bucket prefix nextToken delimiter maxKeys = do-  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet-                               , riBucket = Just bucket-                               , riQueryParams = mkOptionalParams params-                               }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodGet,+          riBucket = Just bucket,+          riQueryParams = mkOptionalParams params+        }   parseListObjectsResponse $ NC.responseBody resp   where-    params = [-        ("list-type", Just "2")-      , ("continuation_token", nextToken)-      , ("prefix", prefix)-      , ("delimiter", delimiter)-      , ("max-keys", show <$> maxKeys)+    params =+      [ ("list-type", Just "2"),+        ("continuation_token", nextToken),+        ("prefix", prefix),+        ("delimiter", delimiter),+        ("max-keys", show <$> maxKeys)       ]  -- | DELETE a bucket from the service. deleteBucket :: Bucket -> Minio ()-deleteBucket bucket = void $-  executeRequest $-    defaultS3ReqInfo { riMethod = HT.methodDelete-        , riBucket = Just bucket-        }+deleteBucket bucket =+  void+    $ executeRequest+    $ defaultS3ReqInfo+      { riMethod = HT.methodDelete,+        riBucket = Just bucket+      }  -- | DELETE an object from the service. deleteObject :: Bucket -> Object -> Minio ()-deleteObject bucket object = void $-  executeRequest $-    defaultS3ReqInfo { riMethod = HT.methodDelete-        , riBucket = Just bucket-        , riObject = Just object-        }+deleteObject bucket object =+  void+    $ executeRequest+    $ defaultS3ReqInfo+      { 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-                               , riBucket = Just bucket-                               , riObject = Just object-                               , riQueryParams = [("uploads", Nothing)]-                               , riHeaders = headers-                               }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPost,+          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]-              -> Payload -> Minio PartTuple+putObjectPart ::+  Bucket ->+  Object ->+  UploadId ->+  PartNumber ->+  [HT.Header] ->+  Payload ->+  Minio PartTuple putObjectPart bucket object uploadId partNumber headers payload = do   -- transform payload to conduit to enable streaming signature   let payload' = mkStreamingPayload payload-  resp <- executeRequest $-          defaultS3ReqInfo { riMethod = HT.methodPut-                           , riBucket = Just bucket-                           , riObject = Just object-                           , riQueryParams = mkOptionalParams params-                           , riHeaders = headers-                           , riPayload = payload'-                           }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just bucket,+          riObject = Just object,+          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 = [-        ("uploadId", Just uploadId)-      , ("partNumber", Just $ show partNumber)+    params =+      [ ("uploadId", Just uploadId),+        ("partNumber", Just $ show partNumber)       ]  srcInfoToHeaders :: SourceInfo -> [HT.Header]-srcInfoToHeaders srcInfo = ("x-amz-copy-source",-                            toS $ T.concat ["/", srcBucket srcInfo,-                                            "/", srcObject srcInfo]-                           ) : rangeHdr ++ zip names values+srcInfoToHeaders srcInfo =+  ( "x-amz-copy-source",+    toUtf8 $+      T.concat+        [ "/",+          srcBucket srcInfo,+          "/",+          srcObject srcInfo+        ]+  )+    : rangeHdr+    ++ zip names values   where-    names = ["x-amz-copy-source-if-match", "x-amz-copy-source-if-none-match",-             "x-amz-copy-source-if-unmodified-since",-             "x-amz-copy-source-if-modified-since"]-    values = mapMaybe (fmap encodeUtf8 . (srcInfo &))-             [srcIfMatch, srcIfNoneMatch,-              fmap formatRFC1123 . srcIfUnmodifiedSince,-              fmap formatRFC1123 . srcIfModifiedSince]-    rangeHdr = maybe [] (\a -> [("x-amz-copy-source-range", HT.renderByteRanges [a])])-               $ toByteRange <$> srcRange srcInfo+    names =+      [ "x-amz-copy-source-if-match",+        "x-amz-copy-source-if-none-match",+        "x-amz-copy-source-if-unmodified-since",+        "x-amz-copy-source-if-modified-since"+      ]+    values =+      mapMaybe+        (fmap encodeUtf8 . (srcInfo &))+        [ srcIfMatch,+          srcIfNoneMatch,+          fmap formatRFC1123 . srcIfUnmodifiedSince,+          fmap formatRFC1123 . srcIfModifiedSince+        ]+    rangeHdr =+      maybe [] (\a -> [("x-amz-copy-source-range", HT.renderByteRanges [a])]) $+        toByteRange <$> srcRange srcInfo     toByteRange :: (Int64, Int64) -> HT.ByteRange     toByteRange (x, y) = HT.ByteRangeFromTo (fromIntegral x) (fromIntegral y)  -- | Performs server-side copy of an object or part of an object as an -- upload part of an ongoing multi-part upload.-copyObjectPart :: DestinationInfo -> SourceInfo -> UploadId-               -> PartNumber -> [HT.Header] -> Minio (ETag, UTCTime)+copyObjectPart ::+  DestinationInfo ->+  SourceInfo ->+  UploadId ->+  PartNumber ->+  [HT.Header] ->+  Minio (ETag, UTCTime) copyObjectPart dstInfo srcInfo uploadId partNumber headers = do-  resp <- executeRequest $-          defaultS3ReqInfo { riMethod = HT.methodPut-              , riBucket = Just $ dstBucket dstInfo-              , riObject = Just $ dstObject dstInfo-              , riQueryParams = mkOptionalParams params-              , riHeaders = headers ++ srcInfoToHeaders srcInfo-              }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just $ dstBucket dstInfo,+          riObject = Just $ dstObject dstInfo,+          riQueryParams = mkOptionalParams params,+          riHeaders = headers ++ srcInfoToHeaders srcInfo+        }    parseCopyObjectResponse $ NC.responseBody resp   where-    params = [-        ("uploadId", Just uploadId)-      , ("partNumber", Just $ show partNumber)+    params =+      [ ("uploadId", Just uploadId),+        ("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]-                 -> Minio (ETag, UTCTime)+copyObjectSingle ::+  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 $-          defaultS3ReqInfo { riMethod = HT.methodPut-              , riBucket = Just bucket-              , riObject = Just object-              , riHeaders = headers ++ srcInfoToHeaders srcInfo-              }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just bucket,+          riObject = Just object,+          riHeaders = headers ++ srcInfoToHeaders srcInfo+        }   parseCopyObjectResponse $ NC.responseBody resp  -- | Complete a multipart upload.-completeMultipartUpload :: Bucket -> Object -> UploadId -> [PartTuple]-                        -> Minio ETag+completeMultipartUpload ::+  Bucket ->+  Object ->+  UploadId ->+  [PartTuple] ->+  Minio ETag completeMultipartUpload bucket object uploadId partTuple = do-  resp <- executeRequest $-          defaultS3ReqInfo { riMethod = HT.methodPost-              , riBucket = Just bucket-              , riObject = Just object-              , riQueryParams = mkOptionalParams params-              , riPayload = PayloadBS $-                            mkCompleteMultipartUploadRequest partTuple-              }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPost,+          riBucket = Just bucket,+          riObject = Just object,+          riQueryParams = mkOptionalParams params,+          riPayload =+            PayloadBS $+              mkCompleteMultipartUploadRequest partTuple+        }   parseCompleteMultipartUploadResponse $ NC.responseBody resp   where     params = [("uploadId", Just uploadId)]  -- | Abort a multipart upload. abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio ()-abortMultipartUpload bucket object uploadId = void $-  executeRequest $ defaultS3ReqInfo { riMethod = HT.methodDelete-                              , riBucket = Just bucket-                              , riObject = Just object-                              , riQueryParams = mkOptionalParams params-                              }+abortMultipartUpload bucket object uploadId =+  void+    $ executeRequest+    $ defaultS3ReqInfo+      { 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-                       -> Maybe Text -> Maybe Int -> Minio ListUploadsResult+listIncompleteUploads' ::+  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-                               , riBucket = Just bucket-                               , riQueryParams = params-                               }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodGet,+          riBucket = Just bucket,+          riQueryParams = params+        }   parseListUploadsResponse $ NC.responseBody resp   where     -- build query params-    params = ("uploads", Nothing) : mkOptionalParams-             [ ("prefix", prefix)-             , ("delimiter", delimiter)-             , ("key-marker", keyMarker)-             , ("upload-id-marker", uploadIdMarker)-             , ("max-uploads", show <$> maxKeys)-             ]-+    params =+      ("uploads", Nothing)+        : mkOptionalParams+          [ ("prefix", prefix),+            ("delimiter", delimiter),+            ("key-marker", keyMarker),+            ("upload-id-marker", uploadIdMarker),+            ("max-uploads", show <$> maxKeys)+          ]  -- | List parts of an ongoing multipart upload.-listIncompleteParts' :: Bucket -> Object -> UploadId -> Maybe Text-                     -> Maybe Text -> Minio ListPartsResult+listIncompleteParts' ::+  Bucket ->+  Object ->+  UploadId ->+  Maybe Text ->+  Maybe Text ->+  Minio ListPartsResult listIncompleteParts' bucket object uploadId maxParts partNumMarker = do-  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet-                               , riBucket = Just bucket-                               , riObject = Just object-                               , riQueryParams = mkOptionalParams params-                               }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodGet,+          riBucket = Just bucket,+          riObject = Just object,+          riQueryParams = mkOptionalParams params+        }   parseListPartsResponse $ NC.responseBody resp   where     -- build optional query params-    params = [-        ("uploadId", Just uploadId)-      , ("part-number-marker", partNumMarker)-      , ("max-parts", maxParts)+    params =+      [ ("uploadId", Just uploadId),+        ("part-number-marker", partNumMarker),+        ("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-                                            , riBucket = Just bucket-                                            , riObject = Just object-                                            , riHeaders = reqHeaders-                                            }--  maybe (throwIO MErrVInvalidObjectInfoResponse) return $-    parseGetObjectHeaders object $ NC.responseHeaders resp-+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodHead,+          riBucket = Just bucket,+          riObject = Just object,+          riHeaders = reqHeaders+               -- This header is required for safety as otherwise http-client,+               -- sends Accept-Encoding: gzip, and the server may actually gzip+               -- body. In that case Content-Length header will be missing.+            <> [("Accept-Encoding", "identity")]+        }+  maybe (throwIO MErrVInvalidObjectInfoResponse) return+    $ parseGetObjectHeaders object+    $ NC.responseHeaders resp  -- | Query the object store if a given bucket exists. headBucket :: Bucket -> Minio Bool-headBucket bucket = headBucketEx `catches`-                    [ Handler handleNoSuchBucket-                    , Handler handleStatus404-                    ]-+headBucket bucket =+  headBucketEx+    `catches` [ Handler handleNoSuchBucket,+                Handler handleStatus404+              ]   where     handleNoSuchBucket :: ServiceErr -> Minio Bool-    handleNoSuchBucket e | e == NoSuchBucket = return False-                         | otherwise = throwIO e-+    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+        then return False+        else throwIO e     handleStatus404 e = throwIO e-     headBucketEx = do-      resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodHead-                                   , riBucket = Just bucket-                                   }+      resp <-+        executeRequest $+          defaultS3ReqInfo+            { riMethod = HT.methodHead,+              riBucket = Just bucket+            }       return $ NC.responseStatus resp == HT.ok200  -- | Set the notification configuration on a bucket. putBucketNotification :: Bucket -> Notification -> Minio () putBucketNotification bucket ncfg = do   ns <- asks getSvcNamespace-  void $ executeRequest $ defaultS3ReqInfo { riMethod = HT.methodPut-                              , riBucket = Just bucket-                              , riQueryParams = [("notification", Nothing)]-                              , riPayload = PayloadBS $-                                            mkPutNotificationRequest ns ncfg-                              }+  void $ executeRequest $+    defaultS3ReqInfo+      { riMethod = HT.methodPut,+        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-                               , riBucket = Just bucket-                               , riQueryParams = [("notification", Nothing)]-                               }+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodGet,+          riBucket = Just bucket,+          riQueryParams = [("notification", Nothing)]+        }   parseNotification $ NC.responseBody resp  -- | Remove all notifications configured on a bucket.@@ -490,11 +623,14 @@ -- | Fetch the policy if any on a bucket. getBucketPolicy :: Bucket -> Minio Text getBucketPolicy bucket = do-  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet-                               , riBucket = Just bucket-                               , riQueryParams = [("policy", Nothing)]-                               }-  return $ toS $ NC.responseBody resp+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodGet,+          riBucket = Just bucket,+          riQueryParams = [("policy", Nothing)]+        }+  return $ decodeUtf8Lenient $ toStrictBS $ NC.responseBody resp  -- | Set a new policy on a bucket. -- As a special condition if the policy is empty@@ -506,18 +642,22 @@     else putBucketPolicy bucket policy  -- | Save a new policy on a bucket.-putBucketPolicy :: Bucket -> Text -> Minio()+putBucketPolicy :: Bucket -> Text -> Minio () putBucketPolicy bucket policy = do-  void $ executeRequest $ defaultS3ReqInfo { riMethod = HT.methodPut-                              , riBucket = Just bucket-                              , riQueryParams = [("policy", Nothing)]-                              , riPayload = PayloadBS $ encodeUtf8 policy-                              }+  void $ executeRequest $+    defaultS3ReqInfo+      { riMethod = HT.methodPut,+        riBucket = Just bucket,+        riQueryParams = [("policy", Nothing)],+        riPayload = PayloadBS $ encodeUtf8 policy+      }  -- | Delete any policy set on a bucket.-deleteBucketPolicy :: Bucket -> Minio()+deleteBucketPolicy :: Bucket -> Minio () deleteBucketPolicy bucket = do-  void $ executeRequest $ defaultS3ReqInfo { riMethod = HT.methodDelete-                              , riBucket = Just bucket-                              , riQueryParams = [("policy", Nothing)]-                              }+  void $ executeRequest $+    defaultS3ReqInfo+      { riMethod = HT.methodDelete,+        riBucket = Just bucket,+        riQueryParams = [("policy", Nothing)]+      }
src/Network/Minio/SelectAPI.hs view
@@ -15,113 +15,103 @@ --  module Network.Minio.SelectAPI-  (--  -- | The `selectObjectContent` allows querying CSV, JSON or Parquet-  -- format objects in AWS S3 and in MinIO using SQL Select-  -- statements. This allows significant reduction of data transfer-  -- from object storage for computation-intensive tasks, as relevant-  -- data is filtered close to the storage.--    selectObjectContent--  , SelectRequest-  , selectRequest--  -- *** Input Serialization--  , InputSerialization-  , defaultCsvInput-  , linesJsonInput-  , documentJsonInput-  , defaultParquetInput-  , setInputCSVProps--  , CompressionType(..)-  , setInputCompressionType--  -- *** CSV Format details--  -- | CSV format options such as delimiters and quote characters are-  -- specified using using the functions below. Options are combined-  -- monoidally.--  , CSVProp-  , recordDelimiter-  , fieldDelimiter-  , quoteCharacter-  , quoteEscapeCharacter-  , commentCharacter-  , allowQuotedRecordDelimiter-  , FileHeaderInfo(..)-  , fileHeaderInfo-  , QuoteFields(..)-  , quoteFields--  -- *** Output Serialization--  , OutputSerialization-  , defaultCsvOutput-  , defaultJsonOutput-  , outputCSVFromProps-  , outputJSONFromRecordDelimiter+  ( -- | The `selectObjectContent` allows querying CSV, JSON or Parquet+    -- format objects in AWS S3 and in MinIO using SQL Select+    -- statements. This allows significant reduction of data transfer+    -- from object storage for computation-intensive tasks, as relevant+    -- data is filtered close to the storage.+    selectObjectContent,+    SelectRequest,+    selectRequest, -  -- *** Progress messages+    -- *** Input Serialization+    InputSerialization,+    defaultCsvInput,+    linesJsonInput,+    documentJsonInput,+    defaultParquetInput,+    setInputCSVProps,+    CompressionType (..),+    setInputCompressionType, -  , setRequestProgressEnabled+    -- *** CSV Format details -  -- *** Interpreting Select output+    -- | CSV format options such as delimiters and quote characters are+    -- specified using using the functions below. Options are combined+    -- monoidally.+    CSVProp,+    recordDelimiter,+    fieldDelimiter,+    quoteCharacter,+    quoteEscapeCharacter,+    commentCharacter,+    allowQuotedRecordDelimiter,+    FileHeaderInfo (..),+    fileHeaderInfo,+    QuoteFields (..),+    quoteFields, -  -- | The conduit returned by `selectObjectContent` returns values of-  -- the `EventMessage` data type. This returns the query output-  -- messages formatted according to the chosen output serialization,-  -- interleaved with progress messages (if enabled by-  -- `setRequestProgressEnabled`), and at the end a statistics-  -- message.-  ---  -- If the application is interested in only the payload, then-  -- `getPayloadBytes` can be used. For example to simply print the-  -- payload to stdout:-  ---  -- > resultConduit <- selectObjectContent bucket object mySelectRequest-  -- > runConduit $ resultConduit .| getPayloadBytes .| stdoutC-  ---  -- Note that runConduit, the connect operator (.|) and stdoutC are-  -- all from the "conduit" package.+    -- *** Output Serialization+    OutputSerialization,+    defaultCsvOutput,+    defaultJsonOutput,+    outputCSVFromProps,+    outputJSONFromRecordDelimiter, -  , getPayloadBytes-  , EventMessage(..)-  , Progress(..)-  , Stats-  ) where+    -- *** Progress messages+    setRequestProgressEnabled, -import           Conduit                    ((.|))-import qualified Conduit                    as C-import qualified Data.Binary                as Bin-import qualified Data.ByteString            as B-import qualified Data.ByteString.Lazy       as LB-import           Data.Digest.CRC32          (crc32, crc32Update)-import qualified Network.HTTP.Conduit       as NC-import qualified Network.HTTP.Types         as HT-import           UnliftIO                   (MonadUnliftIO)+    -- *** Interpreting Select output -import           Lib.Prelude+    -- | The conduit returned by `selectObjectContent` returns values of+    -- the `EventMessage` data type. This returns the query output+    -- messages formatted according to the chosen output serialization,+    -- interleaved with progress messages (if enabled by+    -- `setRequestProgressEnabled`), and at the end a statistics+    -- message.+    --+    -- If the application is interested in only the payload, then+    -- `getPayloadBytes` can be used. For example to simply print the+    -- payload to stdout:+    --+    -- > resultConduit <- selectObjectContent bucket object mySelectRequest+    -- > runConduit $ resultConduit .| getPayloadBytes .| stdoutC+    --+    -- Note that runConduit, the connect operator (.|) and stdoutC are+    -- all from the "conduit" package.+    getPayloadBytes,+    EventMessage (..),+    Progress (..),+    Stats,+  )+where -import           Network.Minio.API-import           Network.Minio.Data-import           Network.Minio.Errors-import           Network.Minio.Utils-import           Network.Minio.XmlGenerator-import           Network.Minio.XmlParser+import Conduit ((.|))+import qualified Conduit as C+import qualified Data.Binary as Bin+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Digest.CRC32 (crc32, crc32Update)+import Lib.Prelude+import qualified Network.HTTP.Conduit as NC+import qualified Network.HTTP.Types as HT+import Network.Minio.API+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.Utils+import Network.Minio.XmlGenerator+import Network.Minio.XmlParser+import UnliftIO (MonadUnliftIO) -data EventStreamException = ESEPreludeCRCFailed-                          | ESEMessageCRCFailed-                          | ESEUnexpectedEndOfStream-                          | ESEDecodeFail [Char]-                          | ESEInvalidHeaderType-                          | ESEInvalidHeaderValueType-                          | ESEInvalidMessageType-    deriving (Eq, Show)+data EventStreamException+  = ESEPreludeCRCFailed+  | ESEMessageCRCFailed+  | ESEUnexpectedEndOfStream+  | ESEDecodeFail [Char]+  | ESEInvalidHeaderType+  | ESEInvalidHeaderValueType+  | ESEInvalidMessageType+  deriving (Eq, Show)  instance Exception EventStreamException @@ -131,169 +121,174 @@  parseBinary :: Bin.Binary a => ByteString -> IO a parseBinary b = do-    case Bin.decodeOrFail $ LB.fromStrict b of-      Left (_, _, msg) -> throwIO $ ESEDecodeFail msg-      Right (_, _, r)  -> return r+  case Bin.decodeOrFail $ LB.fromStrict b of+    Left (_, _, msg) -> throwIO $ ESEDecodeFail msg+    Right (_, _, r) -> return r  bytesToHeaderName :: Text -> IO MsgHeaderName bytesToHeaderName t = case t of-  ":message-type"  -> return MessageType-  ":event-type"    -> return EventType-  ":content-type"  -> return ContentType-  ":error-code"    -> return ErrorCode+  ":message-type" -> return MessageType+  ":event-type" -> return EventType+  ":content-type" -> return ContentType+  ":error-code" -> return ErrorCode   ":error-message" -> return ErrorMessage-  _                -> throwIO ESEInvalidHeaderType+  _ -> throwIO ESEInvalidHeaderType -parseHeaders :: MonadUnliftIO m-             => Word32 -> C.ConduitM ByteString a m [MessageHeader]+parseHeaders ::+  MonadUnliftIO m =>+  Word32 ->+  C.ConduitM ByteString a m [MessageHeader] parseHeaders 0 = return [] parseHeaders hdrLen = do-    bs1 <- readNBytes 1-    n :: Word8 <- liftIO $ parseBinary bs1+  bs1 <- readNBytes 1+  n :: Word8 <- liftIO $ parseBinary bs1 -    headerKeyBytes <- readNBytes $ fromIntegral n-    let headerKey = decodeUtf8Lenient headerKeyBytes-    headerName <- liftIO $ bytesToHeaderName headerKey+  headerKeyBytes <- readNBytes $ fromIntegral n+  let headerKey = decodeUtf8Lenient headerKeyBytes+  headerName <- liftIO $ bytesToHeaderName headerKey -    bs2 <- readNBytes 1-    headerValueType :: Word8 <- liftIO $ parseBinary bs2-    when (headerValueType /= 7) $ throwIO ESEInvalidHeaderValueType+  bs2 <- readNBytes 1+  headerValueType :: Word8 <- liftIO $ parseBinary bs2+  when (headerValueType /= 7) $ throwIO ESEInvalidHeaderValueType -    bs3 <- readNBytes 2-    vLen :: Word16 <- liftIO $ parseBinary bs3-    headerValueBytes <- readNBytes $ fromIntegral vLen-    let headerValue = decodeUtf8Lenient headerValueBytes-        m = (headerName, headerValue)-        k = 1 + fromIntegral n + 1 + 2 + fromIntegral vLen+  bs3 <- readNBytes 2+  vLen :: Word16 <- liftIO $ parseBinary bs3+  headerValueBytes <- readNBytes $ fromIntegral vLen+  let headerValue = decodeUtf8Lenient headerValueBytes+      m = (headerName, headerValue)+      k = 1 + fromIntegral n + 1 + 2 + fromIntegral vLen -    ms <- parseHeaders (hdrLen - k)-    return (m:ms)+  ms <- parseHeaders (hdrLen - k)+  return (m : ms)  -- readNBytes returns N bytes read from the string and throws an -- exception if N bytes are not present on the stream. readNBytes :: MonadUnliftIO m => Int -> C.ConduitM ByteString a m ByteString readNBytes n = do-    b <- LB.toStrict <$> (C.takeCE n .| C.sinkLazy)-    if B.length b /= n-        then throwIO ESEUnexpectedEndOfStream-        else return b+  b <- LB.toStrict <$> (C.takeCE n .| C.sinkLazy)+  if B.length b /= n+    then throwIO ESEUnexpectedEndOfStream+    else return b -crcCheck :: MonadUnliftIO m-         => C.ConduitM ByteString ByteString m ()+crcCheck ::+  MonadUnliftIO m =>+  C.ConduitM ByteString ByteString m () crcCheck = do-    b <- readNBytes 12-    n :: Word32 <- liftIO $ parseBinary $ B.take 4 b-    preludeCRC :: Word32 <- liftIO $ parseBinary $ B.drop 8 b-    when (crc32 (B.take 8 b) /= preludeCRC) $-        throwIO ESEPreludeCRCFailed+  b <- readNBytes 12+  n :: Word32 <- liftIO $ parseBinary $ B.take 4 b+  preludeCRC :: Word32 <- liftIO $ parseBinary $ B.drop 8 b+  when (crc32 (B.take 8 b) /= preludeCRC) $+    throwIO ESEPreludeCRCFailed -    -- we do not yield the checksum-    C.yield $ B.take 8 b+  -- we do not yield the checksum+  C.yield $ B.take 8 b -    -- 12 bytes have been read off the current message. Now read the-    -- next (n-12)-4 bytes and accumulate the checksum, and yield it.-    let startCrc = crc32 b-    finalCrc <- accumulateYield (fromIntegral n-16) startCrc+  -- 12 bytes have been read off the current message. Now read the+  -- next (n-12)-4 bytes and accumulate the checksum, and yield it.+  let startCrc = crc32 b+  finalCrc <- accumulateYield (fromIntegral n -16) startCrc -    bs <- readNBytes 4-    expectedCrc :: Word32 <- liftIO $ parseBinary bs+  bs <- readNBytes 4+  expectedCrc :: Word32 <- liftIO $ parseBinary bs -    when (finalCrc /= expectedCrc) $-        throwIO ESEMessageCRCFailed+  when (finalCrc /= expectedCrc) $+    throwIO ESEMessageCRCFailed -    -- we unconditionally recurse - downstream figures out when to-    -- quit reading the stream-    crcCheck+  -- we unconditionally recurse - downstream figures out when to+  -- quit reading the stream+  crcCheck   where     accumulateYield n checkSum = do-        let toRead = min n chunkSize-        b <- readNBytes toRead-        let c' = crc32Update checkSum b-            n' = n - B.length b-        C.yield b-        if n' > 0-            then accumulateYield n' c'-            else return c'+      let toRead = min n chunkSize+      b <- readNBytes toRead+      let c' = crc32Update checkSum b+          n' = n - B.length b+      C.yield b+      if n' > 0+        then accumulateYield n' c'+        else return c'  handleMessage :: MonadUnliftIO m => C.ConduitT ByteString EventMessage m () handleMessage = do-    b1 <- readNBytes 4-    msgLen :: Word32 <- liftIO $ parseBinary b1--    b2 <- readNBytes 4-    hdrLen :: Word32 <- liftIO $ parseBinary b2--    hs <- parseHeaders hdrLen--    let payloadLen = msgLen - hdrLen - 16-        getHdrVal h = fmap snd . headMay . filter ((h ==) . fst)-        eventHdrValue = getHdrVal EventType hs-        msgHdrValue = getHdrVal MessageType hs-        errCode = getHdrVal ErrorCode hs-        errMsg = getHdrVal ErrorMessage hs+  b1 <- readNBytes 4+  msgLen :: Word32 <- liftIO $ parseBinary b1 -    case msgHdrValue of-      Just "event" -> do-          case eventHdrValue of-            Just "Records" -> passThrough $ fromIntegral payloadLen-            Just "Cont" -> return ()-            Just "Progress" -> do-                bs <- readNBytes $ fromIntegral payloadLen-                progress <- parseSelectProgress bs-                C.yield $ ProgressEventMessage progress-            Just "Stats" -> do-                bs <- readNBytes $ fromIntegral payloadLen-                stats <- parseSelectProgress bs-                C.yield $ StatsEventMessage stats-            Just "End" -> return ()-            _ -> throwIO ESEInvalidMessageType-          when (eventHdrValue /= Just "End") handleMessage+  b2 <- readNBytes 4+  hdrLen :: Word32 <- liftIO $ parseBinary b2 -      Just "error" -> do-          let reqMsgMay = RequestLevelErrorMessage <$> errCode <*> errMsg-          maybe (throwIO ESEInvalidMessageType) C.yield reqMsgMay+  hs <- parseHeaders hdrLen -      _ -> throwIO ESEInvalidMessageType+  let payloadLen = msgLen - hdrLen - 16+      getHdrVal h = fmap snd . headMay . filter ((h ==) . fst)+      eventHdrValue = getHdrVal EventType hs+      msgHdrValue = getHdrVal MessageType hs+      errCode = getHdrVal ErrorCode hs+      errMsg = getHdrVal ErrorMessage hs +  case msgHdrValue of+    Just "event" -> do+      case eventHdrValue of+        Just "Records" -> passThrough $ fromIntegral payloadLen+        Just "Cont" -> return ()+        Just "Progress" -> do+          bs <- readNBytes $ fromIntegral payloadLen+          progress <- parseSelectProgress bs+          C.yield $ ProgressEventMessage progress+        Just "Stats" -> do+          bs <- readNBytes $ fromIntegral payloadLen+          stats <- parseSelectProgress bs+          C.yield $ StatsEventMessage stats+        Just "End" -> return ()+        _ -> throwIO ESEInvalidMessageType+      when (eventHdrValue /= Just "End") handleMessage+    Just "error" -> do+      let reqMsgMay = RequestLevelErrorMessage <$> errCode <*> errMsg+      maybe (throwIO ESEInvalidMessageType) C.yield reqMsgMay+    _ -> throwIO ESEInvalidMessageType   where     passThrough 0 = return ()     passThrough n = do-        let c = min n chunkSize-        b <- readNBytes c-        C.yield $ RecordPayloadEventMessage b-        passThrough $ n - B.length b-+      let c = min n chunkSize+      b <- readNBytes c+      C.yield $ RecordPayloadEventMessage b+      passThrough $ n - B.length b -selectProtoConduit :: MonadUnliftIO m-                   => C.ConduitT ByteString EventMessage m ()+selectProtoConduit ::+  MonadUnliftIO m =>+  C.ConduitT ByteString EventMessage m () selectProtoConduit = crcCheck .| handleMessage  -- | selectObjectContent calls the SelectRequest on the given -- object. It returns a Conduit of event messages that can be consumed -- by the client.-selectObjectContent :: Bucket -> Object -> SelectRequest-                    -> Minio (C.ConduitT () EventMessage Minio ())+selectObjectContent ::+  Bucket ->+  Object ->+  SelectRequest ->+  Minio (C.ConduitT () EventMessage Minio ()) selectObjectContent b o r = do-    let reqInfo = defaultS3ReqInfo { riMethod = HT.methodPost-                                   , riBucket = Just b-                                   , riObject = Just o-                                   , riPayload = PayloadBS $ mkSelectRequest r-                                   , riNeedsLocation = False-                                   , riQueryParams = [("select", Nothing), ("select-type", Just "2")]-                                   }-    --print $ mkSelectRequest r-    resp <- mkStreamRequest reqInfo-    return $ NC.responseBody resp .| selectProtoConduit+  let reqInfo =+        defaultS3ReqInfo+          { riMethod = HT.methodPost,+            riBucket = Just b,+            riObject = Just o,+            riPayload = PayloadBS $ mkSelectRequest r,+            riNeedsLocation = False,+            riQueryParams = [("select", Nothing), ("select-type", Just "2")]+          }+  --print $ mkSelectRequest r+  resp <- mkStreamRequest reqInfo+  return $ NC.responseBody resp .| selectProtoConduit  -- | A helper conduit that returns only the record payload bytes. getPayloadBytes :: MonadIO m => C.ConduitT EventMessage ByteString m () getPayloadBytes = do-    evM <- C.await-    case evM of-      Just v -> do-          case v of-            RecordPayloadEventMessage b  -> C.yield b-            RequestLevelErrorMessage c m -> liftIO $ throwIO $ SelectErr c m-            _                            -> return ()-          getPayloadBytes-      Nothing -> return ()+  evM <- C.await+  case evM of+    Just v -> do+      case v of+        RecordPayloadEventMessage b -> C.yield b+        RequestLevelErrorMessage c m -> liftIO $ throwIO $ SelectErr c m+        _ -> return ()+      getPayloadBytes+    Nothing -> return ()
src/Network/Minio/Sign/V4.hs view
@@ -13,57 +13,62 @@ -- See the License for the specific language governing permissions and -- limitations under the License. --+{-# LANGUAGE BangPatterns #-}  module Network.Minio.Sign.V4 where -import qualified Conduit                       as C-import qualified Data.ByteString               as B-import qualified Data.ByteString.Base64        as Base64-import qualified Data.ByteString.Char8         as B8-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 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 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 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-                 [ H.hAuthorization-                 , H.hContentType-                 , H.hUserAgent-                 ]+ignoredHeaders =+  Set.fromList $+    map+      CI.foldedCase+      [ H.hAuthorization,+        H.hContentType,+        H.hUserAgent+      ] -data SignV4Data = SignV4Data {-      sv4SignTime         :: UTCTime-    , sv4Scope            :: ByteString-    , sv4CanonicalRequest :: ByteString-    , sv4HeadersToSign    :: [(ByteString, ByteString)]-    , sv4Output           :: [(ByteString, ByteString)]-    , sv4StringToSign     :: ByteString-    , sv4SigningKey       :: ByteString-    } deriving (Show)+data SignV4Data = SignV4Data+  { sv4SignTime :: UTCTime,+    sv4Scope :: ByteString,+    sv4CanonicalRequest :: ByteString,+    sv4HeadersToSign :: [(ByteString, ByteString)],+    sv4Output :: [(ByteString, ByteString)],+    sv4StringToSign :: ByteString,+    sv4SigningKey :: ByteString+  }+  deriving (Show) -data SignParams = SignParams {-      spAccessKey   :: Text-    , spSecretKey   :: Text-    , spTimeStamp   :: UTCTime-    , spRegion      :: Maybe Text-    , spExpirySecs  :: Maybe Int-    , spPayloadHash :: Maybe ByteString-    } deriving (Show)+data SignParams = SignParams+  { spAccessKey :: Text,+    spSecretKey :: Text,+    spTimeStamp :: UTCTime,+    spRegion :: Maybe Text,+    spExpirySecs :: Maybe Int,+    spPayloadHash :: Maybe ByteString+  }+  deriving (Show)  debugPrintSignV4Data :: SignV4Data -> IO () debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do@@ -79,22 +84,23 @@   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-                    [ "AWS4-HMAC-SHA256 Credential="-                    , toS accessKey-                    , "/"-                    , scope-                    , ", SignedHeaders="-                    , signedHeaderKeys-                    , ", Signature="-                    , sign-                    ]-    in (H.hAuthorization, authValue)+  let authValue =+        B.concat+          [ "AWS4-HMAC-SHA256 Credential=",+            toUtf8 accessKey,+            "/",+            scope,+            ", SignedHeaders=",+            signedHeaderKeys,+            ", Signature=",+            sign+          ]+   in (H.hAuthorization, authValue)  -- | Given SignParams and request details, including request method, -- request path, headers, query params and payload hash, generates an@@ -110,122 +116,132 @@ -- the request. signV4 :: SignParams -> NC.Request -> [(ByteString, ByteString)] signV4 !sp !req =-  let-    region = fromMaybe "" $ spRegion sp-    ts = spTimeStamp sp-    scope = mkScope ts region-    accessKey = toS $ spAccessKey sp-    secretKey = toS $ spSecretKey sp-    expiry = spExpirySecs sp--    -- headers to be added to the request-    datePair = ("X-Amz-Date", awsTimeFormatBS ts)-    computedHeaders = NC.requestHeaders req ++-                      if isJust $ expiry-                      then []-                      else [(\(x, y) -> (mk x, y)) datePair]-    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")-             , ("X-Amz-Credential", B.concat [accessKey, "/", scope])-             , datePair-             , ("X-Amz-Expires", maybe "" show expiry)-             , ("X-Amz-SignedHeaders", signedHeaderKeys)-             ]-    finalQP = parseQuery (NC.queryString req)  ++-              if isJust expiry-              then (fmap . fmap) Just authQP-              else []--    -- 1. compute canonical request-    canonicalRequest = mkCanonicalRequest False sp-                       (NC.setQueryString finalQP req)-                       headersToSign--    -- 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-    sha256Hdr = ("x-amz-content-sha256",-                 fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp)-    output = if isJust expiry-             then ("X-Amz-Signature", signature) : authQP-             else [(\(x, y) -> (CI.foldedCase x, y)) authHeader,-                   datePair, sha256Hdr]--  in output-+  let region = fromMaybe "" $ spRegion sp+      ts = spTimeStamp sp+      scope = mkScope ts region+      accessKey = toUtf8 $ spAccessKey sp+      secretKey = toUtf8 $ spSecretKey sp+      expiry = spExpirySecs sp+      sha256Hdr =+        ( "x-amz-content-sha256",+          fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp+        )+      -- headers to be added to the request+      datePair = ("X-Amz-Date", awsTimeFormatBS ts)+      computedHeaders =+        NC.requestHeaders req+          ++ if isJust $ expiry+            then []+            else map (\(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"),+          ("X-Amz-Credential", B.concat [accessKey, "/", scope]),+          datePair,+          ("X-Amz-Expires", maybe "" showBS expiry),+          ("X-Amz-SignedHeaders", signedHeaderKeys)+        ]+      finalQP =+        parseQuery (NC.queryString req)+          ++ if isJust expiry+            then (fmap . fmap) Just authQP+            else []+      -- 1. compute canonical request+      canonicalRequest =+        mkCanonicalRequest+          False+          sp+          (NC.setQueryString finalQP req)+          headersToSign+      -- 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+          then ("X-Amz-Signature", signature) : authQP+          else+            [ (\(x, y) -> (CI.foldedCase x, y)) authHeader,+              datePair,+              sha256Hdr+            ]+   in output  mkScope :: UTCTime -> Text -> ByteString-mkScope ts region = B.intercalate "/"-  [ toS $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts-  , toS region-  , "s3"-  , "aws4_request"-  ]+mkScope ts region =+  B.intercalate+    "/"+    [ toUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts,+      toUtf8 region,+      "s3",+      "aws4_request"+    ]  getHeadersToSign :: [Header] -> [(ByteString, ByteString)] getHeadersToSign !h =   filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $-  map (\(x, y) -> (CI.foldedCase x, stripBS y)) h+    map (\(x, y) -> (CI.foldedCase x, stripBS y)) h -mkCanonicalRequest :: Bool -> SignParams -> NC.Request -> [(ByteString, ByteString)]-                   -> ByteString+mkCanonicalRequest ::+  Bool ->+  SignParams ->+  NC.Request ->+  [(ByteString, ByteString)] ->+  ByteString mkCanonicalRequest !isStreaming !sp !req !headersForSign =-  let-    canonicalQueryString = B.intercalate "&" $-      map (\(x, y) -> B.concat [x, "=", y]) $-      sort $ map (\(x, y) ->-                    (uriEncode True x, maybe "" (uriEncode True) y)) $-      (parseQuery $ NC.queryString req)--    sortedHeaders = sort headersForSign--    canonicalHeaders = B.concat $-      map (\(x, y) -> B.concat [x, ":", y, "\n"]) sortedHeaders--    signedHeaders = B.intercalate ";" $ map fst sortedHeaders--    payloadHashStr =+  let canonicalQueryString =+        B.intercalate "&"+          $ map (\(x, y) -> B.concat [x, "=", y])+          $ sort+          $ map+            ( \(x, y) ->+                (uriEncode True x, maybe "" (uriEncode True) y)+            )+          $ (parseQuery $ NC.queryString req)+      sortedHeaders = sort headersForSign+      canonicalHeaders =+        B.concat $+          map (\(x, y) -> B.concat [x, ":", y, "\n"]) sortedHeaders+      signedHeaders = B.intercalate ";" $ map fst sortedHeaders+      payloadHashStr =         if isStreaming-        then "STREAMING-AWS4-HMAC-SHA256-PAYLOAD"-        else fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp-  in-    B.intercalate "\n"-    [ NC.method req-    , uriEncode False $ NC.path req-    , canonicalQueryString-    , canonicalHeaders-    , signedHeaders-    , payloadHashStr-    ]+          then "STREAMING-AWS4-HMAC-SHA256-PAYLOAD"+          else fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp+   in B.intercalate+        "\n"+        [ NC.method req,+          uriEncode False $ NC.path req,+          canonicalQueryString,+          canonicalHeaders,+          signedHeaders,+          payloadHashStr+        ]  mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString-mkStringToSign ts !scope !canonicalRequest = B.intercalate "\n"-                                             [ "AWS4-HMAC-SHA256"-                                             , awsTimeFormatBS ts-                                             , scope-                                             , hashSHA256 canonicalRequest-                                             ]+mkStringToSign ts !scope !canonicalRequest =+  B.intercalate+    "\n"+    [ "AWS4-HMAC-SHA256",+      awsTimeFormatBS ts,+      scope,+      hashSHA256 canonicalRequest+    ]  mkSigningKey :: UTCTime -> Text -> ByteString -> ByteString-mkSigningKey ts region !secretKey = hmacSHA256RawBS "aws4_request"-                                  . hmacSHA256RawBS "s3"-                                  . hmacSHA256RawBS (toS region)-                                  . hmacSHA256RawBS (awsDateFormatBS ts)-                                  $ B.concat ["AWS4", secretKey]+mkSigningKey ts region !secretKey =+  hmacSHA256RawBS "aws4_request"+    . hmacSHA256RawBS "s3"+    . hmacSHA256RawBS (toUtf8 region)+    . hmacSHA256RawBS (awsDateFormatBS ts)+    $ B.concat ["AWS4", secretKey]  computeSignature :: ByteString -> ByteString -> ByteString computeSignature !toSign !key = digestToBase16 $ hmacSHA256 toSign key@@ -233,18 +249,19 @@ -- | Takes a validated Post Policy JSON bytestring, the signing time, -- and ConnInfo and returns form-data for the POST upload containing -- just the signature and the encoded post-policy.-signV4PostPolicy :: ByteString -> SignParams-                 -> Map.HashMap Text ByteString+signV4PostPolicy ::+  ByteString ->+  SignParams ->+  Map.HashMap Text ByteString signV4PostPolicy !postPolicyJSON !sp =-  let-    stringToSign = Base64.encode postPolicyJSON-    region = fromMaybe "" $ spRegion sp-    signingKey = mkSigningKey (spTimeStamp sp) region $ toS $ spSecretKey sp-    signature = computeSignature stringToSign signingKey-  in-    Map.fromList [ ("x-amz-signature", signature)-                 , ("policy", stringToSign)-                 ]+  let stringToSign = Base64.encode postPolicyJSON+      region = fromMaybe "" $ spRegion sp+      signingKey = mkSigningKey (spTimeStamp sp) region $ toUtf8 $ spSecretKey sp+      signature = computeSignature stringToSign signingKey+   in Map.fromList+        [ ("x-amz-signature", signature),+          ("policy", stringToSign)+        ]  chunkSizeConstant :: Int chunkSizeConstant = 64 * 1024@@ -252,140 +269,141 @@ -- base16Len computes the number of bytes required to represent @n (> 0)@ in -- hexadecimal. base16Len :: Integral a => a -> Int-base16Len n | n == 0 = 0-            | otherwise = 1 + base16Len (n `div` 16)+base16Len n+  | n == 0 = 0+  | otherwise = 1 + base16Len (n `div` 16)  signedStreamLength :: Int64 -> Int64 signedStreamLength dataLen =-  let-    chunkSzInt = fromIntegral chunkSizeConstant-    (numChunks, lastChunkLen) = quotRem dataLen chunkSzInt---    -- Structure of a chunk:-    --   string(IntHexBase(chunk-size)) + ";chunk-signature=" + signature + \r\n + chunk-data + \r\n-    encodedChunkLen csz = fromIntegral (base16Len csz) + 17 + 64 + 2 + csz + 2-    fullChunkSize = encodedChunkLen chunkSzInt-    lastChunkSize = bool 0 (encodedChunkLen lastChunkLen) $ lastChunkLen > 0-    finalChunkSize = 1 + 17 + 64 + 2 + 2-  in-    numChunks * fullChunkSize + lastChunkSize + finalChunkSize+  let chunkSzInt = fromIntegral chunkSizeConstant+      (numChunks, lastChunkLen) = quotRem dataLen chunkSzInt+      -- Structure of a chunk:+      --   string(IntHexBase(chunk-size)) + ";chunk-signature=" + signature + \r\n + chunk-data + \r\n+      encodedChunkLen csz = fromIntegral (base16Len csz) + 17 + 64 + 2 + csz + 2+      fullChunkSize = encodedChunkLen chunkSzInt+      lastChunkSize = bool 0 (encodedChunkLen lastChunkLen) $ lastChunkLen > 0+      finalChunkSize = 1 + 17 + 64 + 2 + 2+   in numChunks * fullChunkSize + lastChunkSize + finalChunkSize -signV4Stream :: Int64 -> SignParams -> NC.Request-             -> (C.ConduitT () ByteString (C.ResourceT IO) () -> NC.Request)-             -- -> ([Header], C.ConduitT () ByteString (C.ResourceT IO) () -> NC.RequestBody)+signV4Stream ::+  Int64 ->+  SignParams ->+  NC.Request ->+  (C.ConduitT () ByteString (C.ResourceT IO) () -> NC.Request)+-- -> ([Header], C.ConduitT () ByteString (C.ResourceT IO) () -> NC.RequestBody) signV4Stream !payloadLength !sp !req =-  let-    ts = spTimeStamp sp--    addContentEncoding hs =+  let ts = spTimeStamp sp+      addContentEncoding hs =         let ceMay = headMay $ filter (\(x, _) -> x == "content-encoding") hs-        in case ceMay of-             Nothing      -> ("content-encoding", "aws-chunked") : hs-             Just (_, ce) -> ("content-encoding", ce <> ",aws-chunked") :-                             filter (\(x, _) -> x /= "content-encoding") hs--    -- headers to be added to the request-    datePair = ("X-Amz-Date", awsTimeFormatBS ts)-    computedHeaders = addContentEncoding $-                      datePair : NC.requestHeaders req--    -- headers specific to streaming signature-    signedContentLength = signedStreamLength payloadLength-    streamingHeaders :: [Header]-    streamingHeaders =-        [ ("x-amz-decoded-content-length", show payloadLength)-        , ("content-length", show signedContentLength )-        , ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD")-        ]-    headersToSign = getHeadersToSign $ computedHeaders ++ streamingHeaders-    signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign-    finalQP = parseQuery (NC.queryString req)--    -- 1. Compute Seed Signature-    -- 1.1 Canonical Request-    canonicalReq = mkCanonicalRequest True sp-                   (NC.setQueryString finalQP req)-                   headersToSign--    region = fromMaybe "" $ spRegion sp-    scope = mkScope ts region-    accessKey = spAccessKey sp-    secretKey = spSecretKey sp--    -- 1.2 String toSign-    stringToSign = mkStringToSign ts scope canonicalReq--    -- 1.3 Compute signature-    -- 1.3.1 compute signing key-    signingKey = mkSigningKey ts region $ toS secretKey--    -- 1.3.2 Compute signature-    seedSignature = computeSignature stringToSign signingKey--    -- 1.3.3 Compute Auth Header-    authHeader = mkAuthHeader accessKey scope signedHeaderKeys seedSignature--    -- 1.4 Updated headers for the request-    finalReqHeaders = authHeader : (computedHeaders ++ streamingHeaders)-    -- headersToAdd = authHeader : datePair : streamingHeaders--    toHexStr n = B8.pack $ printf "%x" n--    (numParts, lastPSize) = payloadLength `quotRem` fromIntegral chunkSizeConstant--    -- Function to compute string to sign for each chunk.-    chunkStrToSign prevSign currChunkHash =-        B.intercalate "\n"-        [ "AWS4-HMAC-SHA256-PAYLOAD"-        , awsTimeFormatBS ts-        , scope-        , prevSign-        , hashSHA256 ""-        , currChunkHash+         in case ceMay of+              Nothing -> ("content-encoding", "aws-chunked") : hs+              Just (_, ce) ->+                ("content-encoding", ce <> ",aws-chunked")+                  : filter (\(x, _) -> x /= "content-encoding") hs+      -- headers to be added to the request+      datePair = ("X-Amz-Date", awsTimeFormatBS ts)+      computedHeaders =+        addContentEncoding $+          datePair : NC.requestHeaders req+      -- headers specific to streaming signature+      signedContentLength = signedStreamLength payloadLength+      streamingHeaders :: [Header]+      streamingHeaders =+        [ ("x-amz-decoded-content-length", showBS payloadLength),+          ("content-length", showBS signedContentLength),+          ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD")         ]+      headersToSign = getHeadersToSign $ computedHeaders ++ streamingHeaders+      signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign+      finalQP = parseQuery (NC.queryString req)+      -- 1. Compute Seed Signature+      -- 1.1 Canonical Request+      canonicalReq =+        mkCanonicalRequest+          True+          sp+          (NC.setQueryString finalQP req)+          headersToSign+      region = fromMaybe "" $ spRegion sp+      scope = mkScope ts region+      accessKey = spAccessKey sp+      secretKey = spSecretKey sp+      -- 1.2 String toSign+      stringToSign = mkStringToSign ts scope canonicalReq+      -- 1.3 Compute signature+      -- 1.3.1 compute signing key+      signingKey = mkSigningKey ts region $ 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 -    -- Read n byte from upstream and return a strict bytestring.-    mustTakeN n = do-        bs <- toS <$> (C.takeCE n C..| C.sinkLazy)+      toHexStr n = B8.pack $ printf "%x" n+      (numParts, lastPSize) = payloadLength `quotRem` fromIntegral chunkSizeConstant+      -- Function to compute string to sign for each chunk.+      chunkStrToSign prevSign currChunkHash =+        B.intercalate+          "\n"+          [ "AWS4-HMAC-SHA256-PAYLOAD",+            awsTimeFormatBS ts,+            scope,+            prevSign,+            hashSHA256 "",+            currChunkHash+          ]+      -- Read n byte from upstream and return a strict bytestring.+      mustTakeN n = do+        bs <- LB.toStrict <$> (C.takeCE n C..| C.sinkLazy)         when (B.length bs /= n) $-            throwIO MErrVStreamingBodyUnexpectedEOF+          throwIO MErrVStreamingBodyUnexpectedEOF         return bs--    signerConduit n lps prevSign =-         -- First case encodes a full chunk of length-         -- 'chunkSizeConstant'.-      if | n > 0 -> do-               bs <- mustTakeN chunkSizeConstant-               let strToSign = chunkStrToSign prevSign (hashSHA256 bs)-                   nextSign = computeSignature strToSign signingKey-                   chunkBS = toHexStr chunkSizeConstant-                          <> ";chunk-signature="-                          <> nextSign <> "\r\n" <> bs <> "\r\n"-               C.yield chunkBS-               signerConduit (n-1) lps nextSign+      signerConduit n lps prevSign =+        -- First case encodes a full chunk of length+        -- 'chunkSizeConstant'.+        if+            | n > 0 -> do+              bs <- mustTakeN chunkSizeConstant+              let strToSign = chunkStrToSign prevSign (hashSHA256 bs)+                  nextSign = computeSignature strToSign signingKey+                  chunkBS =+                    toHexStr chunkSizeConstant+                      <> ";chunk-signature="+                      <> nextSign+                      <> "\r\n"+                      <> bs+                      <> "\r\n"+              C.yield chunkBS+              signerConduit (n -1) lps nextSign -         -- Second case encodes the last chunk which is smaller than-         -- 'chunkSizeConstant'-         | lps > 0 -> do-               bs <- mustTakeN $ fromIntegral lps-               let strToSign = chunkStrToSign prevSign (hashSHA256 bs)-                   nextSign = computeSignature strToSign signingKey-                   chunkBS = toHexStr lps <> ";chunk-signature="-                          <> nextSign <> "\r\n" <> bs <> "\r\n"-               C.yield chunkBS-               signerConduit 0 0 nextSign+            -- Second case encodes the last chunk which is smaller than+            -- 'chunkSizeConstant'+            | lps > 0 -> do+              bs <- mustTakeN $ fromIntegral lps+              let strToSign = chunkStrToSign prevSign (hashSHA256 bs)+                  nextSign = computeSignature strToSign signingKey+                  chunkBS =+                    toHexStr lps <> ";chunk-signature="+                      <> nextSign+                      <> "\r\n"+                      <> bs+                      <> "\r\n"+              C.yield chunkBS+              signerConduit 0 0 nextSign -         -- Last case encodes the final signature chunk that has no-         -- data.-         | otherwise -> do-               let strToSign = chunkStrToSign prevSign (hashSHA256 "")-                   nextSign = computeSignature strToSign signingKey-                   lastChunkBS = "0;chunk-signature=" <> nextSign <> "\r\n\r\n"-               C.yield lastChunkBS-  in-    \src -> req { NC.requestHeaders = finalReqHeaders-                , NC.requestBody =-                  NC.requestBodySource signedContentLength $-                  src C..| signerConduit numParts lastPSize seedSignature-                }+            -- Last case encodes the final signature chunk that has no+            -- data.+            | otherwise -> do+              let strToSign = chunkStrToSign prevSign (hashSHA256 "")+                  nextSign = computeSignature strToSign signingKey+                  lastChunkBS = "0;chunk-signature=" <> nextSign <> "\r\n\r\n"+              C.yield lastChunkBS+   in \src ->+        req+          { NC.requestHeaders = finalReqHeaders,+            NC.requestBody =+              NC.requestBodySource signedContentLength $+                src C..| signerConduit numParts lastPSize seedSignature+          }
src/Network/Minio/Utils.hs view
@@ -16,37 +16,40 @@  module Network.Minio.Utils where -import qualified Conduit                       as C-import           Control.Monad.IO.Unlift       (MonadUnliftIO)-import qualified Control.Monad.Trans.Resource  as R-import qualified Data.ByteString               as B-import qualified Data.ByteString.Lazy          as LB-import           Data.CaseInsensitive          (mk, original)-import qualified Data.Conduit.Binary           as CB-import qualified Data.HashMap.Strict           as H-import qualified Data.List                     as List-import qualified Data.Text                     as T-import           Data.Text.Read                (decimal)-import           Data.Time                     (defaultTimeLocale, parseTimeM,-                                                rfc822DateFormat)-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 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--import           Network.Minio.Data-import           Network.Minio.Data.ByteString-import           Network.Minio.JsonParser      (parseErrResponseJSON)-import           Network.Minio.XmlParser       (parseErrResponse)+import qualified Conduit as C+import Control.Monad.IO.Unlift (MonadUnliftIO)+import qualified Control.Monad.Trans.Resource as R+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.CaseInsensitive (mk, original)+import qualified Data.Conduit.Binary as CB+import qualified Data.HashMap.Strict as H+import qualified Data.List as List+import qualified Data.Text as T+import Data.Text.Read (decimal)+import Data.Time+  ( 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 -allocateReadFile :: (MonadUnliftIO m, R.MonadResource m)-                 => FilePath -> m (R.ReleaseKey, Handle)+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,30 +59,37 @@  -- | Queries the file size from the handle. Catches any file operation -- exceptions and returns Nothing instead.-getFileSize :: (MonadUnliftIO m, R.MonadResource m)-            => Handle -> m (Maybe Int64)+getFileSize ::+  (MonadUnliftIO m, R.MonadResource m) =>+  Handle ->+  m (Maybe Int64) getFileSize h = do   resE <- liftIO $ try $ fromIntegral <$> IO.hFileSize h   case resE of     Left (_ :: IOException) -> return Nothing-    Right s                 -> return $ Just s+    Right s -> return $ Just s  -- | Queries if handle is seekable. Catches any file operation -- exceptions and return False instead.-isHandleSeekable :: (R.MonadResource m, MonadUnliftIO m)-               => Handle -> m Bool+isHandleSeekable ::+  (R.MonadResource m, MonadUnliftIO m) =>+  Handle ->+  m Bool isHandleSeekable h = do   resE <- liftIO $ try $ IO.hIsSeekable h   case resE of     Left (_ :: IOException) -> return False-    Right v                 -> return v+    Right v -> return v  -- | Helper function that opens a handle to the filepath and performs -- the given action on it. Exceptions of type MError are caught and -- returned - both during file handle allocation and when the action -- is run.-withNewHandle :: (MonadUnliftIO m, R.MonadResource m)-              => FilePath -> (Handle -> m a) -> m (Either IOException a)+withNewHandle ::+  (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@@ -103,24 +113,27 @@  getMetadata :: [HT.Header] -> [(Text, Text)] getMetadata =-    map ((\(x, y) -> (decodeUtf8Lenient $ original x, decodeUtf8Lenient $ stripBS y)))+  map ((\(x, y) -> (decodeUtf8Lenient $ original x, decodeUtf8Lenient $ stripBS y)))  toMaybeMetadataHeader :: (Text, Text) -> Maybe (Text, Text) toMaybeMetadataHeader (k, v) =-    (, v) <$> userMetadataHeaderNameMaybe k+  (,v) <$> userMetadataHeaderNameMaybe k  getNonUserMetadataMap :: [(Text, Text)] -> H.HashMap Text Text-getNonUserMetadataMap = H.fromList-                      . filter ( isNothing-                               . userMetadataHeaderNameMaybe-                               . fst-                               )+getNonUserMetadataMap =+  H.fromList+    . filter+      ( isNothing+          . userMetadataHeaderNameMaybe+          . fst+      )  -- | This function collects all headers starting with `x-amz-meta-` -- and strips off this prefix, and returns a map. getUserMetadataMap :: [(Text, Text)] -> H.HashMap Text Text-getUserMetadataMap = H.fromList-                   . mapMaybe toMaybeMetadataHeader+getUserMetadataMap =+  H.fromList+    . mapMaybe toMaybeMetadataHeader  getLastModifiedHeader :: [HT.Header] -> Maybe UTCTime getLastModifiedHeader hs = do@@ -132,17 +145,19 @@   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-                      in (s >= 200 && s < 300)+isSuccessStatus sts =+  let s = HT.statusCode sts+   in (s >= 200 && s < 300) -httpLbs :: MonadIO m-        => NC.Request -> NC.Manager-        -> m (NC.Response LByteString)+httpLbs ::+  MonadIO m =>+  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 @@       Just "application/json" -> do         sErr <- parseErrResponseJSON $ NC.responseBody resp         throwIO sErr--      _ -> throwIO $ NC.HttpExceptionRequest req $-        NC.StatusCodeException (void resp) (show resp)+      _ ->+        throwIO $ NC.HttpExceptionRequest req $+          NC.StatusCodeException (void resp) (showBS resp)    return resp   where-    tryHttpEx :: IO (NC.Response LByteString)-              -> IO (Either NC.HttpException (NC.Response LByteString))+    tryHttpEx ::+      IO (NC.Response LByteString) ->+      IO (Either NC.HttpException (NC.Response LByteString))     tryHttpEx = try-    contentTypeMay resp = lookupHeader Hdr.hContentType $-                          NC.responseHeaders resp+    contentTypeMay resp =+      lookupHeader Hdr.hContentType $+        NC.responseHeaders resp -http :: (MonadUnliftIO m, R.MonadResource m)-     => NC.Request -> NC.Manager-     -> m (Response (C.ConduitT () ByteString m ()))+http ::+  (MonadUnliftIO m, R.MonadResource 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 @@         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-+          NC.StatusCodeException (void resp) content    return resp   where-    tryHttpEx :: (MonadUnliftIO m) => m a-              -> m (Either NC.HttpException a)+    tryHttpEx ::+      (MonadUnliftIO m) =>+      m a ->+      m (Either NC.HttpException a)     tryHttpEx = try-    contentTypeMay resp = lookupHeader Hdr.hContentType $-                          NC.responseHeaders resp+    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-                       => Int -> (t -> m a) -> [t] -> m [a]+limitedMapConcurrently ::+  MonadUnliftIO m =>+  Int ->+  (t -> m a) ->+  [t] ->+  m [a] limitedMapConcurrently 0 _ _ = return [] limitedMapConcurrently count act args = do   t' <- U.newTVarIO count@@ -205,17 +229,15 @@   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-+        then U.writeTVar t (v -1)+        else U.retrySTM     signalSem t = U.atomically $ do       v <- U.readTVar t-      U.writeTVar t (v+1)+      U.writeTVar t (v + 1)  -- helper function to 'drop' empty optional parameter. mkQuery :: Text -> Maybe Text -> Maybe (Text, Text)@@ -224,7 +246,7 @@ -- helper function to build query parameters that are optional. -- don't use it with mandatory query params with empty value. mkOptionalParams :: [(Text, Maybe Text)] -> HT.Query-mkOptionalParams params = HT.toQuery $ uncurry  mkQuery <$> params+mkOptionalParams params = HT.toQuery $ uncurry mkQuery <$> params  -- | Conduit that rechunks bytestrings into the given chunk -- lengths. Stops after given chunk lengths are yielded. Stops if@@ -232,23 +254,30 @@ -- received. Does not throw any errors. chunkBSConduit :: (Monad m) => [Int] -> C.ConduitM ByteString ByteString m () chunkBSConduit [] = return ()-chunkBSConduit (s:ss) = do-    bs <- fmap LB.toStrict $ C.takeCE s C..| C.sinkLazy-    if | B.length bs == s -> C.yield bs >> chunkBSConduit ss-       | B.length bs > 0  -> C.yield bs-       | otherwise        -> return ()+chunkBSConduit (s : ss) = do+  bs <- fmap LB.toStrict $ C.takeCE s C..| C.sinkLazy+  if+      | B.length bs == s -> C.yield bs >> chunkBSConduit ss+      | B.length bs > 0 -> C.yield bs+      | otherwise -> return ()  -- | Select part sizes - the logic is that the minimum part-size will -- be 64MiB. selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]-selectPartSizes size = uncurry (List.zip3 [1..]) $-                       List.unzip $ loop 0 size+selectPartSizes size =+  uncurry (List.zip3 [1 ..])+    $ List.unzip+    $ loop 0 size   where     ceil :: Double -> Int64     ceil = ceiling-    partSize = max minPartSize (ceil $ fromIntegral size /-                               fromIntegral maxMultipartParts)-+    partSize =+      max+        minPartSize+        ( ceil $+            fromIntegral size+              / fromIntegral maxMultipartParts+        )     m = fromIntegral partSize     loop st sz       | st > sz = []@@ -257,16 +286,16 @@  lookupRegionCache :: Bucket -> Minio (Maybe Region) lookupRegionCache b = do-    rMVar <- asks mcRegionMap-    rMap <- UM.readMVar rMVar-    return $ H.lookup b rMap+  rMVar <- asks mcRegionMap+  rMap <- UM.readMVar rMVar+  return $ H.lookup b rMap  addToRegionCache :: Bucket -> Region -> Minio () addToRegionCache b region = do-    rMVar <- asks mcRegionMap-    UM.modifyMVar_ rMVar $ return . H.insert b region+  rMVar <- asks mcRegionMap+  UM.modifyMVar_ rMVar $ return . H.insert b region  deleteFromRegionCache :: Bucket -> Minio () deleteFromRegionCache b = do-    rMVar <- asks mcRegionMap-    UM.modifyMVar_ rMVar $ return . H.delete b+  rMVar <- asks mcRegionMap+  UM.modifyMVar_ rMVar $ return . H.delete b
src/Network/Minio/XmlGenerator.hs view
@@ -15,63 +15,80 @@ --  module Network.Minio.XmlGenerator-  ( mkCreateBucketConfig-  , mkCompleteMultipartUploadRequest-  , mkPutNotificationRequest-  , mkSelectRequest-  ) where-+  ( mkCreateBucketConfig,+    mkCompleteMultipartUploadRequest,+    mkPutNotificationRequest,+    mkSelectRequest,+  )+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 qualified Data.HashMap.Strict as H+import qualified Data.Text as T+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"-        [ NodeElement $ s3Element "LocationConstraint"-          [ NodeContent location]+    s3Element n = Element (s3Name ns n) mempty+    root =+      s3Element+        "CreateBucketConfiguration"+        [ NodeElement $+            s3Element+              "LocationConstraint"+              [NodeContent location]         ]-      bucketConfig = Document (Prologue [] Nothing []) root []+    bucketConfig = Document (Prologue [] Nothing []) root []  -- | Create a completeMultipartUpload request body XML mkCompleteMultipartUploadRequest :: [PartTuple] -> ByteString mkCompleteMultipartUploadRequest partInfo =   LBS.toStrict $ renderLBS def cmur   where-    root = Element "CompleteMultipartUpload" mempty $-           map (NodeElement . mkPart) partInfo-    mkPart (n, etag) = Element "Part" mempty-                               [ NodeElement $ Element "PartNumber" mempty-                                 [NodeContent $ T.pack $ show n]-                               , NodeElement $ Element "ETag" mempty-                                 [NodeContent etag]-                               ]+    root =+      Element "CompleteMultipartUpload" mempty $+        map (NodeElement . mkPart) partInfo+    mkPart (n, etag) =+      Element+        "Part"+        mempty+        [ NodeElement $+            Element+              "PartNumber"+              mempty+              [NodeContent $ T.pack $ show n],+          NodeElement $+            Element+              "ETag"+              mempty+              [NodeContent etag]+        ]     cmur = Document (Prologue [] Nothing []) root []  -- Simplified XML representation without element attributes.-data XNode = XNode Text [XNode]-           | XLeaf Text Text+data XNode+  = XNode Text [XNode]+  | XLeaf Text Text   deriving (Eq, Show)  toXML :: Text -> XNode -> ByteString-toXML ns node = LBS.toStrict $ renderLBS def $-  Document (Prologue [] Nothing []) (xmlNode node) []+toXML ns node =+  LBS.toStrict $ renderLBS def $+    Document (Prologue [] Nothing []) (xmlNode node) []   where     xmlNode :: XNode -> Element-    xmlNode (XNode name nodes)   = Element (s3Name ns name) mempty $-                                   map (NodeElement . xmlNode) nodes-    xmlNode (XLeaf name content) = Element (s3Name ns name) mempty-                                   [NodeContent content]+    xmlNode (XNode name nodes) =+      Element (s3Name ns name) mempty $+        map (NodeElement . xmlNode) nodes+    xmlNode (XLeaf name content) =+      Element+        (s3Name ns name)+        mempty+        [NodeContent content]  class ToXNode a where   toXNode :: a -> XNode@@ -80,24 +97,29 @@   toXNode = XLeaf "Event" . show  instance ToXNode Notification where-  toXNode (Notification qc tc lc) = XNode "NotificationConfiguration" $-    map (toXNodesWithArnName "QueueConfiguration" "Queue") qc ++-    map (toXNodesWithArnName "TopicConfiguration" "Topic") tc ++-    map (toXNodesWithArnName "CloudFunctionConfiguration" "CloudFunction") lc+  toXNode (Notification qc tc lc) =+    XNode "NotificationConfiguration" $+      map (toXNodesWithArnName "QueueConfiguration" "Queue") qc+        ++ map (toXNodesWithArnName "TopicConfiguration" "Topic") tc+        ++ map (toXNodesWithArnName "CloudFunctionConfiguration" "CloudFunction") lc  toXNodesWithArnName :: Text -> Text -> NotificationConfig -> XNode toXNodesWithArnName eltName arnName (NotificationConfig id arn events fRule) =-  XNode eltName $ [XLeaf "Id" id, XLeaf arnName arn] ++ map toXNode events ++-  [toXNode fRule]+  XNode eltName $+    [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-                                                 , XLeaf "Value" v-                                                 ]+getFRXNode (FilterRule n v) =+  XNode+    "FilterRule"+    [ XLeaf "Name" n,+      XLeaf "Value" v+    ]  mkPutNotificationRequest :: Text -> Notification -> ByteString mkPutNotificationRequest ns = toXML ns . toXNode@@ -106,60 +128,103 @@ mkSelectRequest r = LBS.toStrict $ renderLBS def sr   where     sr = Document (Prologue [] Nothing []) root []-    root = Element "SelectRequest" mempty $-           [ NodeElement (Element "Expression" mempty-                          [NodeContent $ srExpression r])-           , NodeElement (Element "ExpressionType" mempty-                          [NodeContent $ show $ srExpressionType r])-           , NodeElement (Element "InputSerialization" mempty $-                          inputSerializationNodes $ srInputSerialization r)-           , NodeElement (Element "OutputSerialization" mempty $-                          outputSerializationNodes $ srOutputSerialization r)-           ] ++ maybe [] reqProgElem (srRequestProgressEnabled r)-    reqProgElem enabled = [NodeElement-                           (Element "RequestProgress" mempty-                             [NodeElement-                              (Element "Enabled" mempty-                                [NodeContent-                                 (if enabled then "TRUE" else "FALSE")]-                              )-                             ]-                           )-                          ]-    inputSerializationNodes is = comprTypeNode (isCompressionType is) ++-                                 [NodeElement $ formatNode (isFormatInfo is)]-    comprTypeNode (Just c) = [NodeElement $ Element "CompressionType" mempty-                              [NodeContent $ case c of-                                  CompressionTypeNone  -> "NONE"-                                  CompressionTypeGzip  -> "GZIP"-                                  CompressionTypeBzip2 -> "BZIP2"-                              ]-                             ]+    root =+      Element "SelectRequest" mempty $+        [ NodeElement+            ( Element+                "Expression"+                mempty+                [NodeContent $ srExpression r]+            ),+          NodeElement+            ( Element+                "ExpressionType"+                mempty+                [NodeContent $ show $ srExpressionType r]+            ),+          NodeElement+            ( Element "InputSerialization" mempty+                $ inputSerializationNodes+                $ srInputSerialization r+            ),+          NodeElement+            ( Element "OutputSerialization" mempty+                $ outputSerializationNodes+                $ srOutputSerialization r+            )+        ]+          ++ maybe [] reqProgElem (srRequestProgressEnabled r)+    reqProgElem enabled =+      [ NodeElement+          ( Element+              "RequestProgress"+              mempty+              [ NodeElement+                  ( Element+                      "Enabled"+                      mempty+                      [ NodeContent+                          (if enabled then "TRUE" else "FALSE")+                      ]+                  )+              ]+          )+      ]+    inputSerializationNodes is =+      comprTypeNode (isCompressionType is)+        ++ [NodeElement $ formatNode (isFormatInfo is)]+    comprTypeNode (Just c) =+      [ NodeElement $+          Element+            "CompressionType"+            mempty+            [ NodeContent $ case c of+                CompressionTypeNone -> "NONE"+                CompressionTypeGzip -> "GZIP"+                CompressionTypeBzip2 -> "BZIP2"+            ]+      ]     comprTypeNode Nothing = []-     kvElement (k, v) = Element (Name k Nothing Nothing) mempty [NodeContent v]     formatNode (InputFormatCSV (CSVProp h)) =-      Element "CSV" mempty-      (map NodeElement $ map kvElement $ H.toList h)+      Element+        "CSV"+        mempty+        (map NodeElement $ map kvElement $ H.toList h)     formatNode (InputFormatJSON p) =-      Element "JSON" mempty-      [NodeElement-        (Element "Type" mempty-          [NodeContent $ case jsonipType p of-              JSONTypeDocument -> "DOCUMENT"-              JSONTypeLines    -> "LINES"-          ]-        )-      ]+      Element+        "JSON"+        mempty+        [ NodeElement+            ( Element+                "Type"+                mempty+                [ NodeContent $ case jsonipType p of+                    JSONTypeDocument -> "DOCUMENT"+                    JSONTypeLines -> "LINES"+                ]+            )+        ]     formatNode InputFormatParquet = Element "Parquet" mempty []-     outputSerializationNodes (OutputSerializationJSON j) =-      [NodeElement (Element "JSON" mempty $-                     rdElem $ jsonopRecordDelimiter j)]+      [ NodeElement+          ( Element "JSON" mempty+              $ rdElem+              $ jsonopRecordDelimiter j+          )+      ]     outputSerializationNodes (OutputSerializationCSV (CSVProp h)) =-      [NodeElement $ Element "CSV" mempty-       (map NodeElement $ map kvElement $ H.toList h)]-+      [ NodeElement $+          Element+            "CSV"+            mempty+            (map NodeElement $ map kvElement $ H.toList h)+      ]     rdElem Nothing = []-    rdElem (Just t) = [NodeElement $ Element "RecordDelimiter" mempty-                        [NodeContent t]]+    rdElem (Just t) =+      [ NodeElement $+          Element+            "RecordDelimiter"+            mempty+            [NodeContent t]+      ]
src/Network/Minio/XmlParser.hs view
@@ -15,34 +15,32 @@ --  module Network.Minio.XmlParser-  ( parseListBuckets-  , parseLocation-  , parseNewMultipartUpload-  , parseCompleteMultipartUploadResponse-  , parseCopyObjectResponse-  , parseListObjectsResponse-  , parseListObjectsV1Response-  , parseListUploadsResponse-  , parseListPartsResponse-  , parseErrResponse-  , parseNotification-  , parseSelectProgress-  ) where+  ( parseListBuckets,+    parseLocation,+    parseNewMultipartUpload,+    parseCompleteMultipartUploadResponse,+    parseCopyObjectResponse,+    parseListObjectsResponse,+    parseListObjectsV1Response,+    parseListUploadsResponse,+    parseListPartsResponse,+    parseErrResponse,+    parseNotification,+    parseSelectProgress,+  )+where  import qualified Data.ByteString.Lazy as LB-import qualified Data.HashMap.Strict  as H-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 qualified Data.HashMap.Strict as H+import Data.List (zip3, zip4, zip6)+import qualified Data.Text as T+import Data.Text.Read (decimal)+import Data.Time+import Lib.Prelude+import Network.Minio.Data+import Network.Minio.Errors+import Text.XML+import Text.XML.Cursor hiding (bool)  -- | Represent the time format string returned by S3 API calls. s3TimeFormat :: [Char]@@ -58,12 +56,14 @@ -- | Parse time strings from XML parseS3XMLTime :: MonadIO m => Text -> m UTCTime parseS3XMLTime t =-    maybe (throwIO $ MErrVXmlParse $ "timestamp parse failure: " <> t) return $-    parseTimeM True defaultTimeLocale s3TimeFormat $ T.unpack t+  maybe (throwIO $ MErrVXmlParse $ "timestamp parse failure: " <> t) return+    $ parseTimeM True defaultTimeLocale s3TimeFormat+    $ T.unpack t  parseDecimal :: (MonadIO m, Integral a) => Text -> m a-parseDecimal numStr = either (throwIO . MErrVXmlParse . show) return $-                      fst <$> decimal numStr+parseDecimal numStr =+  either (throwIO . MErrVXmlParse . show) return $+    fst <$> decimal numStr  parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a] parseDecimals numStr = forM numStr parseDecimal@@ -72,18 +72,18 @@ s3Elem ns = element . s3Name ns  parseRoot :: (MonadIO m) => LByteString -> m Cursor-parseRoot = either (throwIO . MErrVXmlParse . show) (return . fromDocument)-          . parseLBS def+parseRoot =+  either (throwIO . MErrVXmlParse . show) (return . fromDocument)+    . parseLBS def  -- | Parse the response XML of a list buckets call. parseListBuckets :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m [BucketInfo] parseListBuckets xmldata = do   r <- parseRoot xmldata   ns <- asks getSvcNamespace-  let-    s3Elem' = s3Elem ns-    names = r $// s3Elem' "Bucket" &// s3Elem' "Name" &/ content-    timeStrings = r $// s3Elem' "Bucket" &// s3Elem' "CreationDate" &/ content+  let s3Elem' = s3Elem ns+      names = r $// s3Elem' "Bucket" &// s3Elem' "Name" &/ content+      timeStrings = r $// s3Elem' "Bucket" &// s3Elem' "CreationDate" &/ content    times <- mapM parseS3XMLTime timeStrings   return $ zipWith BucketInfo names times@@ -116,41 +116,38 @@ parseCopyObjectResponse xmldata = do   r <- parseRoot xmldata   ns <- asks getSvcNamespace-  let-    s3Elem' = s3Elem ns-    mtimeStr = T.concat $ r $// s3Elem' "LastModified" &/ content+  let s3Elem' = s3Elem ns+      mtimeStr = T.concat $ r $// s3Elem' "LastModified" &/ content    mtime <- parseS3XMLTime mtimeStr   return (T.concat $ r $// s3Elem' "ETag" &/ content, mtime)  -- | Parse the response XML of a list objects v1 call.-parseListObjectsV1Response :: (MonadReader env m, HasSvcNamespace env, MonadIO m)-                         => LByteString -> m ListObjectsV1Result+parseListObjectsV1Response ::+  (MonadReader env m, HasSvcNamespace env, MonadIO m) =>+  LByteString ->+  m ListObjectsV1Result parseListObjectsV1Response xmldata = do   r <- parseRoot xmldata   ns <- asks getSvcNamespace-  let-    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-    -- if response xml contains empty etag response fill them with as-    -- many empty Text for the zip4 below to work as intended.-    etags = etagsList ++ repeat ""-    sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content+  let 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+      -- if response xml contains empty etag response fill them with as+      -- many empty Text for the zip4 below to work as intended.+      etags = etagsList ++ repeat ""+      sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content    modTimes <- mapM parseS3XMLTime modTimeStr   sizes <- parseDecimals sizeStr -  let-    objects = map (uncurry6 ObjectInfo) $-              zip6 keys modTimes etags sizes (repeat H.empty) (repeat H.empty)+  let objects =+        map (uncurry6 ObjectInfo) $+          zip6 keys modTimes etags sizes (repeat H.empty) (repeat H.empty)    return $ ListObjectsV1Result hasMore nextMarker objects prefixes @@ -159,28 +156,24 @@ parseListObjectsResponse xmldata = do   r <- parseRoot xmldata   ns <- asks getSvcNamespace-  let-    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-    -- if response xml contains empty etag response fill them with as-    -- many empty Text for the zip4 below to work as intended.-    etags = etagsList ++ repeat ""-    sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content+  let 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+      -- if response xml contains empty etag response fill them with as+      -- many empty Text for the zip4 below to work as intended.+      etags = etagsList ++ repeat ""+      sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content    modTimes <- mapM parseS3XMLTime modTimeStr   sizes <- parseDecimals sizeStr -  let-    objects = map (uncurry6 ObjectInfo) $-              zip6 keys modTimes etags sizes (repeat H.empty) (repeat H.empty)+  let objects =+        map (uncurry6 ObjectInfo) $+          zip6 keys modTimes etags sizes (repeat H.empty) (repeat H.empty)    return $ ListObjectsResult hasMore nextToken objects prefixes @@ -189,20 +182,18 @@ parseListUploadsResponse xmldata = do   r <- parseRoot xmldata   ns <- asks getSvcNamespace-  let-    s3Elem' = s3Elem ns-    hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)-    prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content-    nextKey = headMay $ r $/ s3Elem' "NextKeyMarker" &/ content-    nextUpload = headMay $ r $/ s3Elem' "NextUploadIdMarker" &/ content-    uploadKeys = r $/ s3Elem' "Upload" &/ s3Elem' "Key" &/ content-    uploadIds = r $/ s3Elem' "Upload" &/ s3Elem' "UploadId" &/ content-    uploadInitTimeStr = r $/ s3Elem' "Upload" &/ s3Elem' "Initiated" &/ content+  let s3Elem' = s3Elem ns+      hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)+      prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content+      nextKey = headMay $ r $/ s3Elem' "NextKeyMarker" &/ content+      nextUpload = headMay $ r $/ s3Elem' "NextUploadIdMarker" &/ content+      uploadKeys = r $/ s3Elem' "Upload" &/ s3Elem' "Key" &/ content+      uploadIds = r $/ s3Elem' "Upload" &/ s3Elem' "UploadId" &/ content+      uploadInitTimeStr = r $/ s3Elem' "Upload" &/ s3Elem' "Initiated" &/ content    uploadInitTimes <- mapM parseS3XMLTime uploadInitTimeStr -  let-    uploads = zip3 uploadKeys uploadIds uploadInitTimes+  let uploads = zip3 uploadKeys uploadIds uploadInitTimes    return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes @@ -210,27 +201,25 @@ parseListPartsResponse xmldata = do   r <- parseRoot xmldata   ns <- asks getSvcNamespace-  let-    s3Elem' = s3Elem ns-    hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)-    nextPartNumStr = headMay $ r $/ s3Elem' "NextPartNumberMarker" &/ content-    partNumberStr = r $/ s3Elem' "Part" &/ s3Elem' "PartNumber" &/ content-    partModTimeStr = r $/ s3Elem' "Part" &/ s3Elem' "LastModified" &/ content-    partETags = r $/ s3Elem' "Part" &/ s3Elem' "ETag" &/ content-    partSizeStr = r $/ s3Elem' "Part" &/ s3Elem' "Size" &/ content+  let s3Elem' = s3Elem ns+      hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)+      nextPartNumStr = headMay $ r $/ s3Elem' "NextPartNumberMarker" &/ content+      partNumberStr = r $/ s3Elem' "Part" &/ s3Elem' "PartNumber" &/ content+      partModTimeStr = r $/ s3Elem' "Part" &/ s3Elem' "LastModified" &/ content+      partETags = r $/ s3Elem' "Part" &/ s3Elem' "ETag" &/ content+      partSizeStr = r $/ s3Elem' "Part" &/ s3Elem' "Size" &/ content    partModTimes <- mapM parseS3XMLTime partModTimeStr   partSizes <- parseDecimals partSizeStr   partNumbers <- parseDecimals partNumberStr   nextPartNum <- parseDecimals $ maybeToList nextPartNumStr -  let-    partInfos = map (uncurry4 ObjectPartInfo) $-                zip4 partNumbers partETags partSizes partModTimes+  let partInfos =+        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,28 +239,31 @@     <*> (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-+       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" &/-                  s3Elem ns "FilterRule" &| getFilterRule ns-      return $ NotificationConfig id arn events-        (Filter $ FilterKey $ FilterRules rules)+          rules =+            c $/ s3Elem ns "Filter" &/ s3Elem ns "S3Key"+              &/ s3Elem ns "FilterRule" &| getFilterRule ns+      return $+        NotificationConfig+          id+          arn+          events+          (Filter $ FilterKey $ FilterRules rules)  parseSelectProgress :: MonadIO m => ByteString -> m Progress parseSelectProgress xmldata = do-    r <- parseRoot $ LB.fromStrict xmldata-    let bScanned = T.concat $ r $/ element "BytesScanned" &/ content-        bProcessed = T.concat $ r $/element "BytesProcessed" &/ content-        bReturned = T.concat $ r $/element "BytesReturned" &/ content-    Progress <$> parseDecimal bScanned-             <*> parseDecimal bProcessed-             <*> parseDecimal bReturned+  r <- parseRoot $ LB.fromStrict xmldata+  let bScanned = T.concat $ r $/ element "BytesScanned" &/ content+      bProcessed = T.concat $ r $/ element "BytesProcessed" &/ content+      bReturned = T.concat $ r $/ element "BytesReturned" &/ content+  Progress <$> parseDecimal bScanned+    <*> parseDecimal bProcessed+    <*> parseDecimal bReturned
stack.yaml view
@@ -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 @@ - '.' # 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: {}
test/LiveServer.hs view
@@ -1,1009 +1,1182 @@ {-# LANGUAGE OverloadedStrings #-}------ MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.------ Licensed under the Apache License, Version 2.0 (the "License");--- you may not use this file except in compliance with the License.--- You may obtain a copy of the License at------     http://www.apache.org/licenses/LICENSE-2.0------ Unless required by applicable law or agreed to in writing, software--- distributed under the License is distributed on an "AS IS" BASIS,--- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.--- See the License for the specific language governing permissions and--- limitations under the License.-----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-import qualified Data.ByteString                       as BS-import           Data.Conduit                          (yield)-import qualified Data.Conduit.Binary                   as CB-import           Data.Conduit.Combinators              (sinkList)-import qualified Data.HashMap.Strict                   as H-import qualified Data.Text                             as T-import           Data.Time                             (fromGregorian)-import qualified Data.Time                             as Time-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--main :: IO ()-main = defaultMain tests--tests :: TestTree-tests = testGroup "Tests" [liveServerUnitTests]---- conduit that generates random binary stream of given length-randomDataSrc :: MonadIO m => Int64 -> C.ConduitM () ByteString m ()-randomDataSrc s' = genBS s'-  where-    concatIt bs n = BS.concat $ 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-                genBS (s - oneMiB)--mkRandFile :: R.MonadResource m => Int64 -> m FilePath-mkRandFile size = do-  dir <- liftIO $ getTemporaryDirectory-  C.runConduit $ randomDataSrc size C..| CB.sinkTempFile dir "miniohstest.random"--funTestBucketPrefix :: Text-funTestBucketPrefix = "miniohstest-"--loadTestServer :: IO ConnectInfo-loadTestServer = do-    val <- lookupEnv "MINIO_LOCAL"-    isSecure <- lookupEnv "MINIO_SECURE"-    return $ case (val, isSecure) of-      (Just _, Just _) -> setCreds (Credentials "minio" "minio123") "https://localhost:9000"-      (Just _, Nothing) -> setCreds (Credentials "minio" "minio123") "http://localhost:9000"-      (Nothing, _) -> minioPlayCI--funTestWithBucket :: 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'))-  let b = T.concat [funTestBucketPrefix, T.pack bktSuffix]-      liftStep = liftIO . step-  connInfo <- loadTestServer-  ret <- runMinio connInfo $ do-    liftStep $ "Creating bucket for test - " ++ t-    foundBucket <- bucketExists b-    liftIO $ foundBucket @?= False-    makeBucket b Nothing-    minioTest liftStep b-    deleteBucket b-  isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)--liveServerUnitTests :: TestTree-liveServerUnitTests = testGroup "Unit tests against a live server"-  [ basicTests-  , listingTest-  , highLevelListingTest-  , lowLevelMultipartTest-  , putObjectSizeTest-  , putObjectNoSizeTest-  , multipartTest-  , putObjectContentTypeTest-  , putObjectContentLanguageTest-  , putObjectStorageClassTest-  , putObjectUserMetadataTest-  , getObjectTest-  , copyObjectTests-  , presignedUrlFunTest-  , presignedPostPolicyFunTest-  , bucketPolicyFunTest-  , getNPutSSECTest-  ]--basicTests :: TestTree-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) $-      liftIO $-      assertFailure ("The bucket " ++ show bucket ++-                     " was expected to exist.")--    step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised."-    mbE <- try $ makeBucket bucket Nothing-    case mbE of-      Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou-      _        -> return ()--    step "makeBucket with an invalid bucket name and check for appropriate exception."-    invalidMBE <- try $ makeBucket "invalidBucketName" Nothing-    case invalidMBE of-      Left exn -> liftIO $ exn @?= MErrVInvalidBucketName "invalidBucketName"-      _        -> return ()--    step "getLocation works"-    region <- getLocation bucket-    liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region)--    step "singlepart putObject works"-    fPutObject bucket "lsb-release" "/etc/lsb-release" defaultPutObjectOptions--    step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception"-    fpE <- try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" defaultPutObjectOptions-    case fpE of-      Left exn -> liftIO $ exn @?= NoSuchBucket-      _        -> return ()--    outFile <- mkRandFile 0-    step "simple fGetObject works"-    fGetObject bucket "lsb-release" outFile defaultGetObjectOptions--    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 {-      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 {-      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 {-      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 {-      gooRange = (Just $ HT.ByteRangeFrom 1)-      }--    step "fGetObject a non-existent object and check for NoSuchKey exception"-    resE3 <- try $ fGetObject bucket "noSuchKey" outFile defaultGetObjectOptions-    case resE3 of-      Left exn -> liftIO $ exn @?= NoSuchKey-      _        -> return ()--    step "create new multipart upload works"-    uid <- newMultipartUpload bucket "newmpupload" []-    liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")--    step "abort a new multipart upload works"-    abortMultipartUpload bucket "newmpupload" uid--    step "delete object works"-    deleteObject bucket "lsb-release"--    step "statObject test"-    let object = "sample"-    step "create an object"-    inputFile <- mkRandFile 0-    fPutObject bucket object inputFile defaultPutObjectOptions--    step "get metadata of the object"-    res <- statObject bucket object defaultGetObjectOptions-    liftIO $ (oiSize res) @?= 0--    step "delete object"-    deleteObject bucket object--lowLevelMultipartTest :: TestTree-lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $-    \step bucket -> do-      -- low-level multipart operation tests.-      let object = "newmpupload"-          mb15 = 15 * 1024 * 1024--      step "Prepare for low-level multipart tests."-      step "create new multipart upload"-      uid <- newMultipartUpload bucket object []-      liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")--      randFile <- mkRandFile mb15--      step "put object parts 1 of 1"-      h <- liftIO $ SIO.openBinaryFile randFile SIO.ReadMode-      partInfo <- putObjectPart bucket object uid 1 [] $ PayloadH h 0 mb15--      step "complete multipart"-      void $ completeMultipartUpload bucket object uid [partInfo]--      destFile <- mkRandFile 0-      step  "Retrieve the created object and check size"-      fGetObject bucket object destFile defaultGetObjectOptions-      gotSize <- withNewHandle destFile getFileSize-      liftIO $ gotSize == Right (Just mb15) @?-        "Wrong file size of put file after getting"--      step  "Cleanup actions"-      removeObject bucket object--putObjectSizeTest :: TestTree-putObjectSizeTest = funTestWithBucket "PutObject of conduit source with size" $-  \step bucket -> do-      -- putObject test (conduit source, size specified)-      let obj = "msingle"-          mb1 = 1 * 1024 * 1024--      step "Prepare for putObject with from source with size."-      rFile <- mkRandFile mb1--      step "Upload single file."-      putObject bucket obj (CB.sourceFile rFile) (Just mb1) defaultPutObjectOptions--      step "Retrieve and verify file size"-      destFile <- mkRandFile 0-      fGetObject bucket obj destFile defaultGetObjectOptions-      gotSize <- withNewHandle destFile getFileSize-      liftIO $ gotSize == Right (Just mb1) @?-        "Wrong file size of put file after getting"--      step "Cleanup actions"-      deleteObject bucket obj--putObjectNoSizeTest :: TestTree-putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no size" $-  \step bucket -> do-      -- putObject test (conduit source, no size specified)-      let obj = "mpart"-          mb70 = 70 * 1024 * 1024--      step "Prepare for putObject with from source without providing size."-      rFile <- mkRandFile mb70--      step "Upload multipart file."-      putObject bucket obj (CB.sourceFile rFile) Nothing defaultPutObjectOptions--      step "Retrieve and verify file size"-      destFile <- mkRandFile 0-      fGetObject bucket obj destFile defaultGetObjectOptions-      gotSize <- withNewHandle destFile getFileSize-      liftIO $ gotSize == Right (Just mb70) @?-        "Wrong file size of put file after getting"--      step "Cleanup actions"-      deleteObject bucket obj--highLevelListingTest :: TestTree-highLevelListingTest = funTestWithBucket "High-level listObjects Test" $-  \step bucket -> do-      step "High-level listObjects Test"-      step "put 3 objects"-      let expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3", "o4"]-          extractObjectsFromList os =-              mapM (\t -> case t of-                       ListItemObject o -> Just $ oiObject o-                       _                -> Nothing) os-          expectedNonRecList = ["o4", "dir/"]-          extractObjectsAndDirsFromList os =-              map (\t -> case t of-                      ListItemObject o -> oiObject o-                      ListItemPrefix d -> d) os--      forM_ expectedObjects $-        \obj -> fPutObject bucket obj "/etc/lsb-release" defaultPutObjectOptions--      step "High-level listing of objects"-      items <- C.runConduit $ listObjects bucket Nothing False C..| sinkList-      liftIO $ assertEqual "Objects/Dirs match failed!" expectedNonRecList $-        extractObjectsAndDirsFromList items--      step "High-level recursive listing of objects"-      objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList--      liftIO $ assertEqual "Objects match failed!"-        (Just $ sort expectedObjects) $-        extractObjectsFromList objects--      step "High-level listing of objects (version 1)"-      itemsV1 <- C.runConduit $ listObjectsV1 bucket Nothing False C..| sinkList-      liftIO $ assertEqual "Objects/Dirs match failed!" expectedNonRecList $-        extractObjectsAndDirsFromList itemsV1--      step "High-level recursive listing of objects (version 1)"-      objectsV1 <- C.runConduit $ listObjectsV1 bucket Nothing True C..|-                   sinkList--      liftIO $ assertEqual "Objects match failed!"-        (Just $ sort expectedObjects) $-        extractObjectsFromList objectsV1--      let expectedPrefListing = ["dir/o1", "dir/dir1/", "dir/dir2/"]-          expectedPrefListingRec = Just ["dir/dir1/o2", "dir/dir2/o3", "dir/o1"]-      step "High-level listing with prefix"-      prefItems <- C.runConduit $ listObjects bucket (Just "dir/") False C..| sinkList-      liftIO $ assertEqual "Objects/Dirs under prefix match failed!"-        expectedPrefListing $ extractObjectsAndDirsFromList prefItems--      step "High-level listing with prefix recursive"-      prefItemsRec <- C.runConduit $ listObjects bucket (Just "dir/") True C..| sinkList-      liftIO $ assertEqual "Objects/Dirs under prefix match recursive failed!"-        expectedPrefListingRec $ extractObjectsFromList prefItemsRec--      step "High-level listing with prefix (version 1)"-      prefItemsV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") False C..| sinkList-      liftIO $ assertEqual "Objects/Dirs under prefix match failed!"-        expectedPrefListing $ extractObjectsAndDirsFromList prefItemsV1--      step "High-level listing with prefix recursive (version 1)"-      prefItemsRecV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") True C..| sinkList-      liftIO $ assertEqual "Objects/Dirs under prefix match recursive failed!"-        expectedPrefListingRec $ extractObjectsFromList prefItemsRecV1--      step "Cleanup actions"-      forM_ expectedObjects $-        \obj -> removeObject bucket obj--      step "High-level listIncompleteUploads Test"-      let object = "newmpupload"-      step "create 10 multipart uploads"-      forM_ [1..10::Int] $ \_ -> do-        uid <- newMultipartUpload bucket object []-        liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")--      step "High-level listing of incomplete multipart uploads"-      uploads <- C.runConduit $-                 listIncompleteUploads bucket (Just "newmpupload") True C..|-                 sinkList-      liftIO $ length uploads @?= 10--      step "cleanup"-      forM_ uploads $ \(UploadInfo _ uid _ _) ->-                        abortMultipartUpload bucket object uid--      step "High-level listIncompleteParts Test"-      let mb5 = 5 * 1024 * 1024--      step "create a multipart upload"-      uid <- newMultipartUpload bucket object []-      liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."--      step "put object parts 1..10"-      inputFile <- mkRandFile mb5-      h <- liftIO $ SIO.openBinaryFile inputFile SIO.ReadMode-      forM_ [1..10] $ \pnum ->-        putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5--      step "fetch list parts"-      incompleteParts <- C.runConduit $ listIncompleteParts bucket object uid-                         C..| sinkList-      liftIO $ length incompleteParts @?= 10--      step "cleanup"-      abortMultipartUpload bucket object uid--listingTest :: TestTree-listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do-      step "listObjects' test"-      step "put 10 objects"-      let objects = (\s ->T.concat ["lsb-release", T.pack (show s)]) <$> [1..10::Int]--      forM_ [1..10::Int] $ \s ->-        fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release" defaultPutObjectOptions--      step "Simple list"-      res <- listObjects' bucket Nothing Nothing Nothing Nothing-      let expectedObjects = sort objects-      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 .-                          ("lsb-release":) .-                          (\x -> [x]) .-                          T.pack .-                          show) [1..10::Int]-      liftIO $ assertEqual "Objects match failed!" expected-        (map oiObject $ lorObjects' resV1)--      step "Cleanup actions"-      forM_ objects $ \obj -> deleteObject bucket obj--      step "listIncompleteUploads' test"-      step "create 10 multipart uploads"-      let object = "newmpupload"-      forM_ [1..10::Int] $ \_ -> do-        uid <- newMultipartUpload bucket object []-        liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")--      step "list incomplete multipart uploads"-      incompleteUploads <- listIncompleteUploads' bucket (Just "newmpupload") Nothing-                           Nothing Nothing Nothing-      liftIO $ (length $ lurUploads incompleteUploads) @?= 10--      step "cleanup"-      forM_ (lurUploads incompleteUploads) $-        \(_, uid, _) -> abortMultipartUpload bucket object uid--      step "Basic listIncompleteParts Test"-      let mb5 = 5 * 1024 * 1024--      step "create a multipart upload"-      uid <- newMultipartUpload bucket object []-      liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")--      step "put object parts 1..10"-      inputFile <- mkRandFile mb5-      h <- liftIO $ SIO.openBinaryFile inputFile SIO.ReadMode-      forM_ [1..10] $ \pnum ->-        putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5--      step "fetch list parts"-      listPartsResult <- listIncompleteParts' bucket object uid Nothing Nothing-      liftIO $ (length $ lprParts listPartsResult) @?= 10-      abortMultipartUpload bucket object uid--presignedUrlFunTest :: TestTree-presignedUrlFunTest = funTestWithBucket "presigned Url tests" $-  \step bucket -> do-    let obj = "mydir/myput"-        obj2 = "mydir1/myfile1"--    -- manager for http requests-    mgr <- liftIO $ NC.newManager NC.tlsManagerSettings--    step "PUT object presigned URL - makePresignedUrl"-    putUrl <- 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) @?-      "presigned PUT failed"--    step "GET object presigned URL - makePresignedUrl"-    getUrl <- makePresignedUrl 3600 HT.methodGet (Just bucket)-           (Just obj) (Just "us-east-1") [] []--    getResp <- getR mgr getUrl-    liftIO $ (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) @?-      "presigned put and get got mismatched data"--    step "PUT object presigned - presignedPutObjectURL"-    putUrl2 <- presignedPutObjectUrl bucket obj2 604800 []--    let size2 = 1200-    testFile <- mkRandFile size2--    putResp2 <- putR size2 testFile mgr putUrl2-    liftIO $ (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-                   NC.httpLbs (req {NC.method = HT.methodHead}) mgr-    liftIO $ (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"--    step "GET object presigned URL - presignedGetObjectUrl"-    getUrl2 <- presignedGetObjectUrl bucket obj2 3600 [] []--    getResp2 <- getR mgr getUrl2-    liftIO $ (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) @?-      "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' = req { 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-      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-                      , ppCondKey key-                      , ppCondContentLengthRange 1 1000-                      , ppCondContentType "application/octet-stream"-                      , ppCondSuccessActionStatus 200-                      ]--        expirationTime = Time.addUTCTime 3600 now-        postPolicyE = newPostPolicy expirationTime policyConds--        size = 1000 :: Int64--    inputFile <- mkRandFile size--    case postPolicyE of-      Left err -> liftIO $ assertFailure $ show err-      Right postPolicy -> do-        (url, formData) <- presignedPostPolicy postPolicy-        -- liftIO (print url) >> liftIO (print formData)-        result <- liftIO $ postForm url formData inputFile-        liftIO $ (NC.responseStatus result == HT.status200) @?-          "presigned POST failed"--    mapM_ (removeObject bucket) [key]-    where--      postForm url formData inputFile = do-        req <- NC.parseRequest $ toS url-        let parts = map (\(x, y) -> Form.partBS x y) $-                    H.toList formData-            parts' = parts ++ [Form.partFile "file" inputFile]-        req' <- Form.formDataBody parts' req-        mgr <- NC.newManager NC.tlsManagerSettings-        NC.httpLbs req' mgr--bucketPolicyFunTest :: TestTree-bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $-  \step bucket -> do--    step "bucketPolicy basic test - no policy exception"-    resE <- try $ getBucketPolicy bucket-    case resE of-      Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist"-      _        -> return ()--    resE' <- try $ setBucketPolicy bucket T.empty-    case resE' of-      Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist"-      _        -> return ()--    let expectedPolicyJSON = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket\"]},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket/*\"]}]}"--    step "try a malformed policy, expect error"-    resE'' <- try $ setBucketPolicy bucket expectedPolicyJSON-    case resE'' of-      Left exn -> liftIO $ exn @?= ServiceErr "MalformedPolicy" "Policy has invalid resource."-      _        -> return ()--    let expectedPolicyJSON' = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "\"]},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "/*\"]}]}"--    step "set bucket policy"-    setBucketPolicy bucket expectedPolicyJSON'--    let obj = "myobject"--    step "verify bucket policy: (1) create `myobject`"-    putObject bucket obj (replicateC 100 "c") Nothing defaultPutObjectOptions--    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,-                         "/", toS obj]-    respE <- liftIO $ (fmap (Right . toS) $ NC.simpleHttp $ toS 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")--    deleteObject bucket obj--    step "delete bucket policy"-    setBucketPolicy bucket T.empty--multipartTest :: TestTree-multipartTest = funTestWithBucket "Multipart Tests" $-  \step bucket -> do-    step "Prepare for putObjectInternal with non-seekable file, with size."-    step "Upload multipart file."-    let mb80 = 80 * 1024 * 1024-        obj = "mpart"--    void $ putObjectInternal bucket obj defaultPutObjectOptions $ ODFile "/dev/zero" (Just mb80)--    step "Retrieve and verify file size"-    destFile <- mkRandFile 0-    fGetObject bucket obj destFile defaultGetObjectOptions-    gotSize <- withNewHandle destFile getFileSize-    liftIO $ gotSize == Right (Just mb80) @?-      "Wrong file size of put file after getting"--    step "Cleanup actions"-    removeObject bucket obj--    step "cleanup"-    removeObject bucket "big"--    step "Prepare for removeIncompleteUpload"-    -- low-level multipart operation tests.-    let object = "newmpupload"-        kb5 = 5 * 1024--    step "create new multipart upload"-    uid <- newMultipartUpload bucket object []-    liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."--    randFile <- mkRandFile kb5--    step "upload 2 parts"-    forM_ [1,2] $ \partNum -> do-      h <- liftIO $ SIO.openBinaryFile randFile SIO.ReadMode-      void $ putObjectPart bucket object uid partNum [] $ PayloadH h 0 kb5--    step "remove ongoing upload"-    removeIncompleteUpload bucket object-    uploads <- C.runConduit $ listIncompleteUploads bucket (Just object) False-               C..| sinkList-    liftIO $ (null uploads) @? "removeIncompleteUploads didn't complete successfully"--putObjectContentTypeTest :: TestTree-putObjectContentTypeTest = funTestWithBucket "putObject contentType tests" $-  \step bucket -> do-    step "fPutObject content type test"-    let object = "xxx-content-type"-        size1 = 100 :: Int64--    step "create server object with content-type"-    inputFile <- mkRandFile size1-    fPutObject bucket object inputFile defaultPutObjectOptions {-      pooContentType = Just "application/javascript"-      }--    -- retrieve obj info to check-    oi <- headObject bucket object []-    let m = oiMetadata oi--    step "Validate content-type"-    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 {-      pooContentEncoding = Just "identity"-      }--    oiCE <- headObject bucket object []-    let m' = oiMetadata oiCE--    step "Validate content-encoding"-    liftIO $ assertEqual "Content-Encoding did not match" (Just "identity")-      (H.lookup "Content-Encoding" m')--    step "Cleanup actions"--    removeObject bucket object--putObjectContentLanguageTest :: TestTree-putObjectContentLanguageTest = funTestWithBucket "putObject contentLanguage tests" $-  \step bucket -> do-    step "fPutObject content language test"-    let object = "xxx-content-language"-        size1 = 100 :: Int64--    step "create server object with content-language"-    inputFile <- mkRandFile size1-    fPutObject bucket object inputFile defaultPutObjectOptions {-      pooContentLanguage = Just "en-US"-      }--    -- retrieve obj info to check-    oi <- headObject bucket object []-    let m = oiMetadata oi--    step "Validate content-language"-    liftIO $ assertEqual "content-language did not match" (Just "en-US")-      (H.lookup "Content-Language" m)-    step "Cleanup actions"--    removeObject bucket object--putObjectUserMetadataTest :: TestTree-putObjectUserMetadataTest = funTestWithBucket "putObject user-metadata test" $-  \step bucket -> do-    step "putObject user-metadata test"-    let object = "object-with-metadata"-        size1 = 100 :: Int64--    step "create server object with usermetdata"-    inputFile <- mkRandFile size1--    fPutObject bucket object inputFile defaultPutObjectOptions {-      pooUserMetadata = [ ("x-Amz-meta-mykey1", "myval1")-                        , ("mykey2", "myval2")-                        ]-      }--    step "Validate user-metadata"-    -- retrieve obj info to check-    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)) $-                     H.toList m-        ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]--    liftIO $ (sortedMeta == ref) @? "Metadata mismatch!"--    step "Cleanup actions"-    removeObject bucket object--getObjectTest :: TestTree-getObjectTest = funTestWithBucket "getObject test" $-  \step bucket -> do-    step "putObject with some metadata"-    let object = "object-with-metadata"-        size1 = 100 :: Int64--    inputFile <- mkRandFile size1-    fPutObject bucket object inputFile defaultPutObjectOptions {-      pooUserMetadata = [ ("x-Amz-meta-mykey1", "myval1")-                        , ("mykey2", "myval2")-                        ]-      }--    step "get the object - check the metadata matches"-    -- retrieve obj info to check-    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)) $-                     H.toList m-        ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]--    liftIO $ (sortedMeta == ref) @? "Metadata mismatch!"--    step "get the object content"-    getObjectHash <- hashSHA256FromSource $ gorObjectStream gor-    inputHash <- hashSHA256FromSource $ C.sourceFile inputFile-    liftIO $ (getObjectHash == inputHash) @? "Input file and output file mismatched!"--    step "Cleanup actions"-    removeObject bucket object--putObjectStorageClassTest :: TestTree-putObjectStorageClassTest = funTestWithBucket "putObject storageClass tests" $-  \step bucket -> do-    step "fPutObject storage class test"-    let object = "xxx-storage-class-standard"-        object' = "xxx-storage-class-reduced"-        object'' = "xxx-storage-class-invalid"-        size1 = 100 :: Int64-        size0 = 0 :: Int64--    step "create server objects with storageClass"-    inputFile <- mkRandFile size1-    inputFile' <- mkRandFile size1-    inputFile'' <- mkRandFile size0--    fPutObject bucket object inputFile defaultPutObjectOptions {-      pooStorageClass = Just "STANDARD"-      }--    fPutObject bucket object' inputFile' defaultPutObjectOptions {-      pooStorageClass = Just "REDUCED_REDUNDANCY"-      }--    removeObject bucket object--    -- retrieve obj info to check-    oi' <- headObject bucket object' []-    let m' = oiMetadata oi'--    step "Validate x-amz-storage-class rrs"-    liftIO $ assertEqual "storageClass did not match" (Just "REDUCED_REDUNDANCY")-      (H.lookup "X-Amz-Storage-Class" m')--    fpE <- try $ fPutObject bucket object'' inputFile'' defaultPutObjectOptions {-      pooStorageClass = Just "INVALID_STORAGE_CLASS"-      }-    case fpE of-      Left exn -> liftIO $ exn @?= ServiceErr "InvalidStorageClass" "Invalid storage class."-      _        -> return ()--    step "Cleanup actions"--    removeObject bucket object'--copyObjectTests :: TestTree-copyObjectTests = funTestWithBucket "copyObject related tests" $-  \step bucket -> do-    step "copyObjectSingle basic tests"-    let object = "xxx"-        objCopy = "xxxCopy"-        size1 = 100 :: Int64--    step "create server object to copy"-    inputFile <- mkRandFile size1-    fPutObject bucket object inputFile defaultPutObjectOptions--    step "copy object"-    let srcInfo = defaultSourceInfo { srcBucket = bucket, srcObject = object}-    (etag, modTime) <- copyObjectSingle bucket objCopy srcInfo []--    -- retrieve obj info to check-    oi <- headObject bucket objCopy []-    let t = oiModTime oi-    let e = oiETag oi-    let s = oiSize oi--    let isMTimeDiffOk = abs (diffUTCTime modTime t) < 1.0--    liftIO $ (s == size1 && e == etag && isMTimeDiffOk) @?-      "Copied object did not match expected."--    step "cleanup actions"-    removeObject bucket object-    removeObject bucket objCopy--    step "copyObjectPart basic tests"-    let srcObj = "XXX"-        copyObj = "XXXCopy"--    step "Prepare"-    let mb15 = 15 * 1024 * 1024-        mb5 = 5 * 1024 * 1024-    randFile <- mkRandFile mb15-    fPutObject bucket srcObj randFile defaultPutObjectOptions--    step "create new multipart upload"-    uid <- newMultipartUpload bucket copyObj []-    liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."--    step "put object parts 1-3"-    let srcInfo' = defaultSourceInfo { srcBucket = bucket, srcObject = srcObj }-        dstInfo' = defaultDestinationInfo { dstBucket = bucket, dstObject = copyObj }-    parts <- forM [1..3] $ \p -> do-      (etag', _) <- copyObjectPart dstInfo' srcInfo'{-        srcRange = Just $ (,) ((p-1)*mb5) ((p-1)*mb5 + (mb5 - 1))-        } uid (fromIntegral p) []-      return (fromIntegral p, etag')--    step "complete multipart"-    void $ completeMultipartUpload bucket copyObj uid parts--    step "verify copied object size"-    oi' <- headObject bucket copyObj []-    let s' = oiSize oi'--    liftIO $ (s' == mb15) @? "Size failed to match"--    step "Cleanup actions"-    removeObject bucket srcObj-    removeObject bucket copyObj--    step "copyObject basic tests"-    let srcs = ["XXX", "XXXL"]-        copyObjs = ["XXXCopy", "XXXLCopy"]-        sizes = map (* (1024 * 1024)) [15, 65]--    step "Prepare"-    forM_ (zip srcs sizes) $ \(src, size) -> do-      inputFile' <- mkRandFile size-      fPutObject bucket src inputFile' defaultPutObjectOptions--    step "make small and large object copy"-    forM_ (zip copyObjs srcs) $ \(cp, src) ->-      copyObject defaultDestinationInfo {dstBucket = bucket, dstObject = cp} defaultSourceInfo {srcBucket = bucket, srcObject = src}--    step "verify uploaded objects"-    uploadedSizes <- fmap oiSize <$> forM copyObjs (\o -> headObject bucket o [])--    liftIO $ (sizes == uploadedSizes) @? "Uploaded obj sizes failed to match"--    forM_ (srcs ++ copyObjs) (removeObject bucket)--    step "copyObject with offset test "-    let src = "XXX"-        size = 15 * 1024 * 1024--    step "Prepare"-    inputFile' <- mkRandFile size-    fPutObject bucket src inputFile' defaultPutObjectOptions--    step "copy last 10MiB of object"-    copyObject defaultDestinationInfo { dstBucket = bucket, dstObject = copyObj } defaultSourceInfo {-        srcBucket = bucket-      , srcObject = src-      , srcRange = Just $ (,) (5 * 1024 * 1024) (size - 1)-      }--    step "verify uploaded object"-    cSize <- oiSize <$> headObject bucket copyObj []--    liftIO $ (cSize == 10 * 1024 * 1024) @? "Uploaded obj size mismatched!"--    forM_ [src, copyObj] (removeObject bucket)--getNPutSSECTest :: TestTree-getNPutSSECTest =-    funTestWithBucket "Get and Put SSE-C Test" $ \step bucket -> do-       -- Skip this test if the server is not using TLS as encryption is-       -- disabled anyway.-       isTLSConn <- asks (connectIsSecure . mcConnInfo)-       if isTLSConn-           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--                   let mb1 = 1024*1024-                       obj = "1"-                   step "Upload an object using the encryption key"-                   rFile <- mkRandFile mb1-                   let putOpts = defaultPutObjectOptions { pooSSE = Just $ SSEC key }-                   fPutObject bucket obj rFile putOpts--                   step "Stat object without key - should fail"-                   headRes <- try $ statObject bucket obj defaultGetObjectOptions-                   case headRes of-                     Right _ -> liftIO $ assertFailure "Cannot perform head object on encrypted object without specifying key"-                     Left ex@(NC.HttpExceptionRequest _ (NC.StatusCodeException rsp _))-                         | NC.responseStatus rsp == HT.status400 -> return ()-                         | otherwise -> liftIO $ assertFailure $ "Unexpected err: " ++ show ex-                     Left ex -> liftIO $ assertFailure $ "Unexpected err: " ++ show ex--                   step "Get file and check length"-                   dstFile <- mkRandFile 0-                   let getOpts = defaultGetObjectOptions { gooSSECKey = Just key }-                   fGetObject bucket obj dstFile getOpts--                   gotSize <- withNewHandle dstFile getFileSize-                   liftIO $ 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"++--+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++import Conduit (replicateC)+import qualified Conduit as C+import qualified Control.Monad.Trans.Resource as R+import qualified Data.ByteString as BS+import Data.Conduit (yield)+import qualified Data.Conduit.Binary as CB+import Data.Conduit.Combinators (sinkList)+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 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 Test.QuickCheck as Q+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck as QC+import qualified UnliftIO.IO as UIO++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [liveServerUnitTests]++-- conduit that generates random binary stream of given length+randomDataSrc :: MonadIO m => Int64 -> C.ConduitM () ByteString m ()+randomDataSrc s' = genBS s'+  where+    concatIt bs n =+      BS.concat $+        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+          genBS (s - oneMiB)++mkRandFile :: R.MonadResource m => Int64 -> m FilePath+mkRandFile size = do+  dir <- liftIO getTemporaryDirectory+  C.runConduit $ randomDataSrc size C..| CB.sinkTempFile dir "miniohstest.random"++funTestBucketPrefix :: Text+funTestBucketPrefix = "miniohstest-"++loadTestServer :: IO ConnectInfo+loadTestServer = do+  val <- lookupEnv "MINIO_LOCAL"+  isSecure <- lookupEnv "MINIO_SECURE"+  return $ case (val, isSecure) of+    (Just _, Just _) -> setCreds (Credentials "minio" "minio123") "https://localhost:9000"+    (Just _, Nothing) -> setCreds (Credentials "minio" "minio123") "http://localhost:9000"+    (Nothing, _) -> minioPlayCI++funTestWithBucket ::+  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'))+  let b = T.concat [funTestBucketPrefix, T.pack bktSuffix]+      liftStep = liftIO . step+  connInfo <- loadTestServer+  ret <- runMinio connInfo $ do+    liftStep $ "Creating bucket for test - " ++ t+    foundBucket <- bucketExists b+    liftIO $ foundBucket @?= False+    makeBucket b Nothing+    minioTest liftStep b+    deleteBucket b+  isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)++liveServerUnitTests :: TestTree+liveServerUnitTests =+  testGroup+    "Unit tests against a live server"+    [ basicTests,+      listingTest,+      highLevelListingTest,+      lowLevelMultipartTest,+      putObjectSizeTest,+      putObjectNoSizeTest,+      multipartTest,+      putObjectContentTypeTest,+      putObjectContentLanguageTest,+      putObjectStorageClassTest,+      putObjectUserMetadataTest,+      getObjectTest,+      copyObjectTests,+      presignedUrlFunTest,+      presignedPostPolicyFunTest,+      bucketPolicyFunTest,+      getNPutSSECTest+    ]++basicTests :: TestTree+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)+      $ liftIO+      $ assertFailure+        ( "The bucket " ++ show bucket+            ++ " was expected to exist."+        )++    step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised."+    mbE <- try $ makeBucket bucket Nothing+    case mbE of+      Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou+      _ -> return ()++    step "makeBucket with an invalid bucket name and check for appropriate exception."+    invalidMBE <- try $ makeBucket "invalidBucketName" Nothing+    case invalidMBE of+      Left exn -> liftIO $ exn @?= MErrVInvalidBucketName "invalidBucketName"+      _ -> return ()++    step "getLocation works"+    region <- getLocation bucket+    liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region)++    step "singlepart putObject works"+    testFilepath <- mkRandFile 200+    fPutObject bucket "test-file" testFilepath defaultPutObjectOptions++    step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception"+    fpE <- try $ fPutObject "nosuchbucket" "test-file-2" testFilepath defaultPutObjectOptions+    case fpE of+      Left exn -> liftIO $ exn @?= NoSuchBucket+      _ -> return ()++    outFile <- mkRandFile 0+    step "simple fGetObject works"+    fGetObject bucket "test-file" outFile defaultGetObjectOptions++    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+          "test-file"+          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+          "test-file"+          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+          "test-file"+          outFile+          defaultGetObjectOptions+            { gooRange = (Just $ HT.ByteRangeFromTo 100 300)+            }+    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+      "test-file"+      outFile+      defaultGetObjectOptions+        { gooRange = (Just $ HT.ByteRangeFrom 1)+        }++    step "fGetObject a non-existent object and check for NoSuchKey exception"+    resE3 <- try $ fGetObject bucket "noSuchKey" outFile defaultGetObjectOptions+    case resE3 of+      Left exn -> liftIO $ exn @?= NoSuchKey+      _ -> return ()++    step "create new multipart upload works"+    uid <- newMultipartUpload bucket "newmpupload" []+    liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")++    step "abort a new multipart upload works"+    abortMultipartUpload bucket "newmpupload" uid++    step "delete object works"+    deleteObject bucket "test-file"++    step "statObject test"+    let object = "sample"+    step "create an object"+    inputFile <- mkRandFile 0+    fPutObject bucket object inputFile defaultPutObjectOptions++    step "get metadata of the object"+    res <- statObject bucket object defaultGetObjectOptions+    liftIO $ (oiSize res) @?= 0++    step "delete object"+    deleteObject bucket object++lowLevelMultipartTest :: TestTree+lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $+  \step bucket -> do+    -- low-level multipart operation tests.+    let object = "newmpupload"+        mb15 = 15 * 1024 * 1024++    step "Prepare for low-level multipart tests."+    step "create new multipart upload"+    uid <- newMultipartUpload bucket object []+    liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")++    randFile <- mkRandFile mb15++    step "put object parts 1 of 1"+    partInfo <-+      UIO.withBinaryFile randFile UIO.ReadMode $ \h ->+        putObjectPart bucket object uid 1 [] $ PayloadH h 0 mb15++    step "complete multipart"+    void $ completeMultipartUpload bucket object uid [partInfo]++    destFile <- mkRandFile 0+    step "Retrieve the created object and check size"+    fGetObject bucket object destFile defaultGetObjectOptions+    gotSize <- withNewHandle destFile getFileSize+    liftIO $+      gotSize == Right (Just mb15)+        @? "Wrong file size of put file after getting"++    step "Cleanup actions"+    removeObject bucket object++putObjectSizeTest :: TestTree+putObjectSizeTest = funTestWithBucket "PutObject of conduit source with size" $+  \step bucket -> do+    -- putObject test (conduit source, size specified)+    let obj = "msingle"+        mb1 = 1 * 1024 * 1024++    step "Prepare for putObject with from source with size."+    rFile <- mkRandFile mb1++    step "Upload single file."+    putObject bucket obj (CB.sourceFile rFile) (Just mb1) defaultPutObjectOptions++    step "Retrieve and verify file size"+    destFile <- mkRandFile 0+    fGetObject bucket obj destFile defaultGetObjectOptions+    gotSize <- withNewHandle destFile getFileSize+    liftIO $+      gotSize == Right (Just mb1)+        @? "Wrong file size of put file after getting"++    step "Cleanup actions"+    deleteObject bucket obj++putObjectNoSizeTest :: TestTree+putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no size" $+  \step bucket -> do+    -- putObject test (conduit source, no size specified)+    let obj = "mpart"+        mb70 = 70 * 1024 * 1024++    step "Prepare for putObject with from source without providing size."+    rFile <- mkRandFile mb70++    step "Upload multipart file."+    putObject bucket obj (CB.sourceFile rFile) Nothing defaultPutObjectOptions++    step "Retrieve and verify file size"+    destFile <- mkRandFile 0+    fGetObject bucket obj destFile defaultGetObjectOptions+    gotSize <- withNewHandle destFile getFileSize+    liftIO $+      gotSize == Right (Just mb70)+        @? "Wrong file size of put file after getting"++    step "Cleanup actions"+    deleteObject bucket obj++highLevelListingTest :: TestTree+highLevelListingTest = funTestWithBucket "High-level listObjects Test" $+  \step bucket -> do+    step "High-level listObjects Test"+    step "put 3 objects"+    let expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3", "o4"]+        extractObjectsFromList os =+          mapM+            ( \t -> case t of+                ListItemObject o -> Just $ oiObject o+                _ -> Nothing+            )+            os+        expectedNonRecList = ["o4", "dir/"]+        extractObjectsAndDirsFromList os =+          map+            ( \t -> case t of+                ListItemObject o -> oiObject o+                ListItemPrefix d -> d+            )+            os++    testFilepath <- mkRandFile 200+    forM_ expectedObjects $+      \obj -> fPutObject bucket obj testFilepath defaultPutObjectOptions++    step "High-level listing of objects"+    items <- C.runConduit $ listObjects bucket Nothing False C..| sinkList+    liftIO $ assertEqual "Objects/Dirs match failed!" expectedNonRecList $+      extractObjectsAndDirsFromList items++    step "High-level recursive listing of objects"+    objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList++    liftIO+      $ assertEqual+        "Objects match failed!"+        (Just $ sort expectedObjects)+      $ extractObjectsFromList objects++    step "High-level listing of objects (version 1)"+    itemsV1 <- C.runConduit $ listObjectsV1 bucket Nothing False C..| sinkList+    liftIO $ assertEqual "Objects/Dirs match failed!" expectedNonRecList $+      extractObjectsAndDirsFromList itemsV1++    step "High-level recursive listing of objects (version 1)"+    objectsV1 <-+      C.runConduit $+        listObjectsV1 bucket Nothing True+          C..| sinkList++    liftIO+      $ assertEqual+        "Objects match failed!"+        (Just $ sort expectedObjects)+      $ extractObjectsFromList objectsV1++    let expectedPrefListing = ["dir/o1", "dir/dir1/", "dir/dir2/"]+        expectedPrefListingRec = Just ["dir/dir1/o2", "dir/dir2/o3", "dir/o1"]+    step "High-level listing with prefix"+    prefItems <- C.runConduit $ listObjects bucket (Just "dir/") False C..| sinkList+    liftIO+      $ assertEqual+        "Objects/Dirs under prefix match failed!"+        expectedPrefListing+      $ extractObjectsAndDirsFromList prefItems++    step "High-level listing with prefix recursive"+    prefItemsRec <- C.runConduit $ listObjects bucket (Just "dir/") True C..| sinkList+    liftIO+      $ assertEqual+        "Objects/Dirs under prefix match recursive failed!"+        expectedPrefListingRec+      $ extractObjectsFromList prefItemsRec++    step "High-level listing with prefix (version 1)"+    prefItemsV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") False C..| sinkList+    liftIO+      $ assertEqual+        "Objects/Dirs under prefix match failed!"+        expectedPrefListing+      $ extractObjectsAndDirsFromList prefItemsV1++    step "High-level listing with prefix recursive (version 1)"+    prefItemsRecV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") True C..| sinkList+    liftIO+      $ assertEqual+        "Objects/Dirs under prefix match recursive failed!"+        expectedPrefListingRec+      $ extractObjectsFromList prefItemsRecV1++    step "Cleanup actions"+    forM_ expectedObjects $+      \obj -> removeObject bucket obj++    step "High-level listIncompleteUploads Test"+    let object = "newmpupload"+    step "create 10 multipart uploads"+    forM_ [1 .. 10 :: Int] $ \_ -> do+      uid <- newMultipartUpload bucket object []+      liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")++    step "High-level listing of incomplete multipart uploads"+    uploads <-+      C.runConduit $+        listIncompleteUploads bucket (Just "newmpupload") True+          C..| sinkList+    liftIO $ length uploads @?= 10++    step "cleanup"+    forM_ uploads $ \(UploadInfo _ uid _ _) ->+      abortMultipartUpload bucket object uid++    step "High-level listIncompleteParts Test"+    let mb5 = 5 * 1024 * 1024++    step "create a multipart upload"+    uid <- newMultipartUpload bucket object []+    liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."++    step "put object parts 1..10"+    inputFile <- mkRandFile mb5+    UIO.withBinaryFile inputFile UIO.ReadMode $ \h ->+      forM_ [1 .. 10] $ \pnum ->+        putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5++    step "fetch list parts"+    incompleteParts <-+      C.runConduit $+        listIncompleteParts bucket object uid+          C..| sinkList+    liftIO $ length incompleteParts @?= 10++    step "cleanup"+    abortMultipartUpload bucket object uid++listingTest :: TestTree+listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do+  step "listObjects' test"+  step "put 10 objects"+  let objects = (\s -> T.concat ["test-file-", T.pack (show s)]) <$> [1 .. 10 :: Int]++  testFilepath <- mkRandFile 200+  forM_ [1 .. 10 :: Int] $ \s ->+    fPutObject bucket (T.concat ["test-file-", T.pack (show s)]) testFilepath defaultPutObjectOptions++  step "Simple list"+  res <- listObjects' bucket Nothing Nothing Nothing Nothing+  let expectedObjects = sort objects+  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+                . ("test-file-" :)+                . (\x -> [x])+                . T.pack+                . show+            )+            [1 .. 10 :: Int]+  liftIO $+    assertEqual+      "Objects match failed!"+      expected+      (map oiObject $ lorObjects' resV1)++  step "Cleanup actions"+  forM_ objects $ \obj -> deleteObject bucket obj++  step "listIncompleteUploads' test"+  step "create 10 multipart uploads"+  let object = "newmpupload"+  forM_ [1 .. 10 :: Int] $ \_ -> do+    uid <- newMultipartUpload bucket object []+    liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")++  step "list incomplete multipart uploads"+  incompleteUploads <-+    listIncompleteUploads'+      bucket+      (Just "newmpupload")+      Nothing+      Nothing+      Nothing+      Nothing+  liftIO $ (length $ lurUploads incompleteUploads) @?= 10++  step "cleanup"+  forM_ (lurUploads incompleteUploads) $+    \(_, uid, _) -> abortMultipartUpload bucket object uid++  step "Basic listIncompleteParts Test"+  let mb5 = 5 * 1024 * 1024++  step "create a multipart upload"+  uid <- newMultipartUpload bucket object []+  liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.")++  step "put object parts 1..10"+  inputFile <- mkRandFile mb5+  UIO.withBinaryFile inputFile UIO.ReadMode $ \h ->+    forM_ [1 .. 10] $ \pnum ->+      putObjectPart bucket object uid pnum [] $ PayloadH h 0 mb5++  step "fetch list parts"+  listPartsResult <- listIncompleteParts' bucket object uid Nothing Nothing+  liftIO $ (length $ lprParts listPartsResult) @?= 10+  abortMultipartUpload bucket object uid++presignedUrlFunTest :: TestTree+presignedUrlFunTest = funTestWithBucket "presigned Url tests" $+  \step bucket -> do+    let obj = "mydir/myput"+        obj2 = "mydir1/myfile1"++    -- manager for http requests+    mgr <- liftIO $ NC.newManager NC.tlsManagerSettings++    step "PUT object presigned URL - makePresignedUrl"+    putUrl <-+      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)+        @? "presigned PUT failed"++    step "GET object presigned URL - makePresignedUrl"+    getUrl <-+      makePresignedUrl+        3600+        HT.methodGet+        (Just bucket)+        (Just obj)+        (Just "us-east-1")+        []+        []++    getResp <- getR mgr getUrl+    liftIO $+      (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)+        @? "presigned put and get got mismatched data"++    step "PUT object presigned - presignedPutObjectURL"+    putUrl2 <- presignedPutObjectUrl bucket obj2 604800 []++    let size2 = 1200+    testFile <- mkRandFile size2++    putResp2 <- putR size2 testFile mgr putUrl2+    liftIO $+      (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 $ decodeUtf8 headUrl+      NC.httpLbs (req {NC.method = HT.methodHead}) mgr+    liftIO $+      (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 == 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)+        @? "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)+        @? "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 $ decodeUtf8 url+      let req' =+            req+              { 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 $ 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,+            ppCondKey key,+            ppCondContentLengthRange 1 1000,+            ppCondContentType "application/octet-stream",+            ppCondSuccessActionStatus 200+          ]+        expirationTime = Time.addUTCTime 3600 now+        postPolicyE = newPostPolicy expirationTime policyConds+        size = 1000 :: Int64++    inputFile <- mkRandFile size++    case postPolicyE of+      Left err -> liftIO $ assertFailure $ show err+      Right postPolicy -> do+        (url, formData) <- presignedPostPolicy postPolicy+        -- liftIO (print url) >> liftIO (print formData)+        result <- liftIO $ postForm url formData inputFile+        liftIO $+          (NC.responseStatus result == HT.status200)+            @? "presigned POST failed"++    mapM_ (removeObject bucket) [key]+  where+    postForm url formData inputFile = do+      req <- NC.parseRequest $ toS $ decodeUtf8 url+      let parts =+            map (\(x, y) -> Form.partBS x y) $+              H.toList formData+          parts' = parts ++ [Form.partFile "file" inputFile]+      req' <- Form.formDataBody parts' req+      mgr <- NC.newManager NC.tlsManagerSettings+      NC.httpLbs req' mgr++bucketPolicyFunTest :: TestTree+bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $+  \step bucket -> do+    step "bucketPolicy basic test - no policy exception"+    resE <- try $ getBucketPolicy bucket+    case resE of+      Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist"+      _ -> return ()++    resE' <- try $ setBucketPolicy bucket T.empty+    case resE' of+      Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist"+      _ -> return ()++    let expectedPolicyJSON = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket\"]},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket/*\"]}]}"++    step "try a malformed policy, expect error"+    resE'' <- try $ setBucketPolicy bucket expectedPolicyJSON+    case resE'' of+      Left exn -> liftIO $ exn @?= ServiceErr "MalformedPolicy" "bucket name does not match"+      _ -> return ()++    let expectedPolicyJSON' = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "\"]},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "/*\"]}]}"++    step "set bucket policy"+    setBucketPolicy bucket expectedPolicyJSON'++    let obj = "myobject"++    step "verify bucket policy: (1) create `myobject`"+    putObject bucket obj (replicateC 100 "c") Nothing defaultPutObjectOptions++    step "verify bucket policy: (2) get `myobject` anonymously"+    connInfo <- asks mcConnInfo+    let proto = bool "http://" "https://" $ connectIsSecure connInfo+        url =+          BS.concat+            [ proto,+              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")++    deleteObject bucket obj++    step "delete bucket policy"+    setBucketPolicy bucket T.empty++multipartTest :: TestTree+multipartTest = funTestWithBucket "Multipart Tests" $+  \step bucket -> do+    -- Commenting out test since it's platform specific.+    -- FIXME: Need to find a platform agnostic way to test this.+    -- step "Prepare for putObjectInternal with non-seekable file, with size."+    -- step "Upload multipart file."+    -- let mb80 = 80 * 1024 * 1024+    --     obj = "mpart"++    -- void $ putObjectInternal bucket obj defaultPutObjectOptions $ ODFile "/dev/zero" (Just mb80)++    -- step "Retrieve and verify file size"+    -- destFile <- mkRandFile 0+    -- fGetObject bucket obj destFile defaultGetObjectOptions+    -- gotSize <- withNewHandle destFile getFileSize+    -- liftIO $+    --   gotSize == Right (Just mb80)+    --     @? "Wrong file size of put file after getting"++    -- step "Cleanup actions"+    -- removeObject bucket obj++    -- step "cleanup"+    -- removeObject bucket "big"++    step "Prepare for removeIncompleteUpload"+    -- low-level multipart operation tests.+    let object = "newmpupload"+        kb5 = 5 * 1024++    step "create new multipart upload"+    uid <- newMultipartUpload bucket object []+    liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."++    randFile <- mkRandFile kb5++    step "upload 2 parts"+    forM_ [1, 2] $ \partNum -> do+      UIO.withBinaryFile randFile UIO.ReadMode $ \h ->+        void $ putObjectPart bucket object uid partNum [] $ PayloadH h 0 kb5++    step "remove ongoing upload"+    removeIncompleteUpload bucket object+    uploads <-+      C.runConduit $+        listIncompleteUploads bucket (Just object) False+          C..| sinkList+    liftIO $ (null uploads) @? "removeIncompleteUploads didn't complete successfully"++putObjectContentTypeTest :: TestTree+putObjectContentTypeTest = funTestWithBucket "putObject contentType tests" $+  \step bucket -> do+    step "fPutObject content type test"+    let object = "xxx-content-type"+        size1 = 100 :: Int64++    step "create server object with content-type"+    inputFile <- mkRandFile size1+    fPutObject+      bucket+      object+      inputFile+      defaultPutObjectOptions+        { pooContentType = Just "application/javascript"+        }++    -- retrieve obj info to check+    oi <- headObject bucket object []+    let m = oiMetadata oi++    step "Validate content-type"+    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+        { pooContentEncoding = Just "identity"+        }++    oiCE <- headObject bucket object []+    let m' = oiMetadata oiCE++    step "Validate content-encoding"+    liftIO $+      assertEqual+        "Content-Encoding did not match"+        (Just "identity")+        (H.lookup "Content-Encoding" m')++    step "Cleanup actions"++    removeObject bucket object++putObjectContentLanguageTest :: TestTree+putObjectContentLanguageTest = funTestWithBucket "putObject contentLanguage tests" $+  \step bucket -> do+    step "fPutObject content language test"+    let object = "xxx-content-language"+        size1 = 100 :: Int64++    step "create server object with content-language"+    inputFile <- mkRandFile size1+    fPutObject+      bucket+      object+      inputFile+      defaultPutObjectOptions+        { pooContentLanguage = Just "en-US"+        }++    -- retrieve obj info to check+    oi <- headObject bucket object []+    let m = oiMetadata oi++    step "Validate content-language"+    liftIO $+      assertEqual+        "content-language did not match"+        (Just "en-US")+        (H.lookup "Content-Language" m)+    step "Cleanup actions"++    removeObject bucket object++putObjectUserMetadataTest :: TestTree+putObjectUserMetadataTest = funTestWithBucket "putObject user-metadata test" $+  \step bucket -> do+    step "putObject user-metadata test"+    let object = "object-with-metadata"+        size1 = 100 :: Int64++    step "create server object with usermetdata"+    inputFile <- mkRandFile size1++    fPutObject+      bucket+      object+      inputFile+      defaultPutObjectOptions+        { pooUserMetadata =+            [ ("x-Amz-meta-mykey1", "myval1"),+              ("mykey2", "myval2")+            ]+        }++    step "Validate user-metadata"+    -- retrieve obj info to check+    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)) $+            H.toList m+        ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]++    liftIO $ (sortedMeta == ref) @? "Metadata mismatch!"++    step "Cleanup actions"+    removeObject bucket object++getObjectTest :: TestTree+getObjectTest = funTestWithBucket "getObject test" $+  \step bucket -> do+    step "putObject with some metadata"+    let object = "object-with-metadata"+        size1 = 100 :: Int64++    inputFile <- mkRandFile size1+    fPutObject+      bucket+      object+      inputFile+      defaultPutObjectOptions+        { pooUserMetadata =+            [ ("x-Amz-meta-mykey1", "myval1"),+              ("mykey2", "myval2")+            ]+        }++    step "get the object - check the metadata matches"+    -- retrieve obj info to check+    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)) $+            H.toList m+        ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")]++    liftIO $ (sortedMeta == ref) @? "Metadata mismatch!"++    step "get the object content"+    getObjectHash <- hashSHA256FromSource $ gorObjectStream gor+    inputHash <- hashSHA256FromSource $ C.sourceFile inputFile+    liftIO $ (getObjectHash == inputHash) @? "Input file and output file mismatched!"++    step "Cleanup actions"+    removeObject bucket object++putObjectStorageClassTest :: TestTree+putObjectStorageClassTest = funTestWithBucket "putObject storageClass tests" $+  \step bucket -> do+    step "fPutObject storage class test"+    let object = "xxx-storage-class-standard"+        object' = "xxx-storage-class-reduced"+        object'' = "xxx-storage-class-invalid"+        size1 = 100 :: Int64+        size0 = 0 :: Int64++    step "create server objects with storageClass"+    inputFile <- mkRandFile size1+    inputFile' <- mkRandFile size1+    inputFile'' <- mkRandFile size0++    fPutObject+      bucket+      object+      inputFile+      defaultPutObjectOptions+        { pooStorageClass = Just "STANDARD"+        }++    fPutObject+      bucket+      object'+      inputFile'+      defaultPutObjectOptions+        { pooStorageClass = Just "REDUCED_REDUNDANCY"+        }++    removeObject bucket object++    -- retrieve obj info to check+    oi' <- headObject bucket object' []+    let m' = oiMetadata oi'++    step "Validate x-amz-storage-class rrs"+    liftIO $+      assertEqual+        "storageClass did not match"+        (Just "REDUCED_REDUNDANCY")+        (H.lookup "X-Amz-Storage-Class" m')++    fpE <-+      try $+        fPutObject+          bucket+          object''+          inputFile''+          defaultPutObjectOptions+            { pooStorageClass = Just "INVALID_STORAGE_CLASS"+            }+    case fpE of+      Left exn -> liftIO $ exn @?= ServiceErr "InvalidStorageClass" "Invalid storage class."+      _ -> return ()++    step "Cleanup actions"++    removeObject bucket object'++copyObjectTests :: TestTree+copyObjectTests = funTestWithBucket "copyObject related tests" $+  \step bucket -> do+    step "copyObjectSingle basic tests"+    let object = "xxx"+        objCopy = "xxxCopy"+        size1 = 100 :: Int64++    step "create server object to copy"+    inputFile <- mkRandFile size1+    fPutObject bucket object inputFile defaultPutObjectOptions++    step "copy object"+    let srcInfo = defaultSourceInfo {srcBucket = bucket, srcObject = object}+    (etag, modTime) <- copyObjectSingle bucket objCopy srcInfo []++    -- retrieve obj info to check+    oi <- headObject bucket objCopy []+    let t = oiModTime oi+    let e = oiETag oi+    let s = oiSize oi++    let isMTimeDiffOk = abs (diffUTCTime modTime t) < 1.0++    liftIO $+      (s == size1 && e == etag && isMTimeDiffOk)+        @? "Copied object did not match expected."++    step "cleanup actions"+    removeObject bucket object+    removeObject bucket objCopy++    step "copyObjectPart basic tests"+    let srcObj = "XXX"+        copyObj = "XXXCopy"++    step "Prepare"+    let mb15 = 15 * 1024 * 1024+        mb5 = 5 * 1024 * 1024+    randFile <- mkRandFile mb15+    fPutObject bucket srcObj randFile defaultPutObjectOptions++    step "create new multipart upload"+    uid <- newMultipartUpload bucket copyObj []+    liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id."++    step "put object parts 1-3"+    let srcInfo' = defaultSourceInfo {srcBucket = bucket, srcObject = srcObj}+        dstInfo' = defaultDestinationInfo {dstBucket = bucket, dstObject = copyObj}+    parts <- forM [1 .. 3] $ \p -> do+      (etag', _) <-+        copyObjectPart+          dstInfo'+          srcInfo'+            { srcRange = Just $ (,) ((p -1) * mb5) ((p -1) * mb5 + (mb5 - 1))+            }+          uid+          (fromIntegral p)+          []+      return (fromIntegral p, etag')++    step "complete multipart"+    void $ completeMultipartUpload bucket copyObj uid parts++    step "verify copied object size"+    oi' <- headObject bucket copyObj []+    let s' = oiSize oi'++    liftIO $ (s' == mb15) @? "Size failed to match"++    step "Cleanup actions"+    removeObject bucket srcObj+    removeObject bucket copyObj++    step "copyObject basic tests"+    let srcs = ["XXX", "XXXL"]+        copyObjs = ["XXXCopy", "XXXLCopy"]+        sizes = map (* (1024 * 1024)) [15, 65]++    step "Prepare"+    forM_ (zip srcs sizes) $ \(src, size) -> do+      inputFile' <- mkRandFile size+      fPutObject bucket src inputFile' defaultPutObjectOptions++    step "make small and large object copy"+    forM_ (zip copyObjs srcs) $ \(cp, src) ->+      copyObject defaultDestinationInfo {dstBucket = bucket, dstObject = cp} defaultSourceInfo {srcBucket = bucket, srcObject = src}++    step "verify uploaded objects"+    uploadedSizes <- fmap oiSize <$> forM copyObjs (\o -> headObject bucket o [])++    liftIO $ (sizes == uploadedSizes) @? "Uploaded obj sizes failed to match"++    forM_ (srcs ++ copyObjs) (removeObject bucket)++    step "copyObject with offset test "+    let src = "XXX"+        size = 15 * 1024 * 1024++    step "Prepare"+    inputFile' <- mkRandFile size+    fPutObject bucket src inputFile' defaultPutObjectOptions++    step "copy last 10MiB of object"+    copyObject+      defaultDestinationInfo {dstBucket = bucket, dstObject = copyObj}+      defaultSourceInfo+        { srcBucket = bucket,+          srcObject = src,+          srcRange = Just $ (,) (5 * 1024 * 1024) (size - 1)+        }++    step "verify uploaded object"+    cSize <- oiSize <$> headObject bucket copyObj []++    liftIO $ (cSize == 10 * 1024 * 1024) @? "Uploaded obj size mismatched!"++    forM_ [src, copyObj] (removeObject bucket)++getNPutSSECTest :: TestTree+getNPutSSECTest =+  funTestWithBucket "Get and Put SSE-C Test" $ \step bucket -> do+    -- Skip this test if the server is not using TLS as encryption is+    -- disabled anyway.+    isTLSConn <- asks (connectIsSecure . mcConnInfo)+    if isTLSConn+      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++        let mb1 = 1024 * 1024+            obj = "1"+        step "Upload an object using the encryption key"+        rFile <- mkRandFile mb1+        let putOpts = defaultPutObjectOptions {pooSSE = Just $ SSEC key}+        fPutObject bucket obj rFile putOpts++        step "Stat object without key - should fail"+        headRes <- try $ statObject bucket obj defaultGetObjectOptions+        case headRes of+          Right _ -> liftIO $ assertFailure "Cannot perform head object on encrypted object without specifying key"+          Left ex@(NC.HttpExceptionRequest _ (NC.StatusCodeException rsp _))+            | NC.responseStatus rsp == HT.status400 -> return ()+            | otherwise -> liftIO $ assertFailure $ "Unexpected err: " ++ show ex+          Left ex -> liftIO $ assertFailure $ "Unexpected err: " ++ show ex++        step "Get file and check length"+        dstFile <- mkRandFile 0+        let getOpts = defaultGetObjectOptions {gooSSECKey = Just key}+        fGetObject bucket obj dstFile getOpts++        gotSize <- withNewHandle dstFile getFileSize+        liftIO $+          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 view
@@ -15,88 +15,100 @@ --  module Network.Minio.API.Test-  ( bucketNameValidityTests-  , objectNameValidityTests-  , parseServerInfoJSONTest-  , parseHealStatusTest-  , parseHealStartRespTest-  ) where--import           Data.Aeson             (eitherDecode)-import           Test.Tasty-import           Test.Tasty.HUnit--import           Lib.Prelude+  ( bucketNameValidityTests,+    objectNameValidityTests,+    parseServerInfoJSONTest,+    parseHealStatusTest,+    parseHealStartRespTest,+  )+where -import           Network.Minio.AdminAPI-import           Network.Minio.API+import Data.Aeson (eitherDecode)+import Lib.Prelude+import Network.Minio.API+import Network.Minio.AdminAPI+import Test.Tasty+import Test.Tasty.HUnit  assertBool' :: Bool -> Assertion assertBool' = assertBool "Test failed!"  bucketNameValidityTests :: TestTree-bucketNameValidityTests = testGroup "Bucket Name Validity Tests"-  [ testCase "Too short 1" $ assertBool' $ not $ isValidBucketName ""-  , testCase "Too short 2" $ assertBool' $ not $ isValidBucketName "ab"-  , testCase "Too long 1" $ assertBool' $ not $ isValidBucketName "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"-  , testCase "Has upper case" $ assertBool' $ not $ isValidBucketName "ABCD"-  , testCase "Has punctuation" $ assertBool' $ not $ isValidBucketName "abc,2"-  , testCase "Has hyphen at end" $ assertBool' $ not $ isValidBucketName "abc-"-  , testCase "Has consecutive dot" $ assertBool' $ not $ isValidBucketName "abck..eedg"-  , testCase "Looks like IP" $  assertBool' $ not $ isValidBucketName "10.0.0.1"-  , testCase "Valid bucket name 1" $ assertBool' $ isValidBucketName "abcd.pqeq.rea"-  , testCase "Valid bucket name 2" $ assertBool' $ isValidBucketName "abcdedgh1d"-  , testCase "Valid bucket name 3" $ assertBool' $ isValidBucketName "abc-de-dg-h1d"-  ]+bucketNameValidityTests =+  testGroup+    "Bucket Name Validity Tests"+    [ testCase "Too short 1" $ assertBool' $ not $ isValidBucketName "",+      testCase "Too short 2" $ assertBool' $ not $ isValidBucketName "ab",+      testCase "Too long 1" $ assertBool' $ not $ isValidBucketName "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",+      testCase "Has upper case" $ assertBool' $ not $ isValidBucketName "ABCD",+      testCase "Has punctuation" $ assertBool' $ not $ isValidBucketName "abc,2",+      testCase "Has hyphen at end" $ assertBool' $ not $ isValidBucketName "abc-",+      testCase "Has consecutive dot" $ assertBool' $ not $ isValidBucketName "abck..eedg",+      testCase "Looks like IP" $ assertBool' $ not $ isValidBucketName "10.0.0.1",+      testCase "Valid bucket name 1" $ assertBool' $ isValidBucketName "abcd.pqeq.rea",+      testCase "Valid bucket name 2" $ assertBool' $ isValidBucketName "abcdedgh1d",+      testCase "Valid bucket name 3" $ assertBool' $ isValidBucketName "abc-de-dg-h1d"+    ]  objectNameValidityTests :: TestTree-objectNameValidityTests = testGroup "Object Name Validity Tests"-  [ testCase "Empty name" $ assertBool' $ not $ isValidObjectName ""-  , testCase "Has unicode characters" $ assertBool' $ isValidObjectName "日本国"-  ]+objectNameValidityTests =+  testGroup+    "Object Name Validity Tests"+    [ testCase "Empty name" $ assertBool' $ not $ isValidObjectName "",+      testCase "Has unicode characters" $ assertBool' $ isValidObjectName "日本国"+    ]  parseServerInfoJSONTest :: TestTree-parseServerInfoJSONTest = testGroup "Parse MinIO Admin API ServerInfo JSON test" $-  map (\(tName, tDesc, tfn, tVal) -> testCase tName $ assertBool tDesc $-        tfn (eitherDecode tVal :: Either [Char] [ServerInfo])) testCases+parseServerInfoJSONTest =+  testGroup "Parse MinIO Admin API ServerInfo JSON test" $+    map+      ( \(tName, tDesc, tfn, tVal) ->+          testCase tName $ assertBool tDesc $+            tfn (eitherDecode tVal :: Either [Char] [ServerInfo])+      )+      testCases   where-    testCases = [ ("FSBackend", "Verify server info json parsing for FS backend", isRight, fsJSON)-                , ("Erasure Backend", "Verify server info json parsing for Erasure backend", isRight, erasureJSON)-                , ("Unknown Backend", "Verify server info json parsing for invalid backend", isLeft, invalidJSON)-                ]+    testCases =+      [ ("FSBackend", "Verify server info json parsing for FS backend", isRight, fsJSON),+        ("Erasure Backend", "Verify server info json parsing for Erasure backend", isRight, erasureJSON),+        ("Unknown Backend", "Verify server info json parsing for invalid backend", isLeft, invalidJSON)+      ]     fsJSON = "[{\"error\":\"\",\"addr\":\"192.168.1.218:9000\",\"data\":{\"storage\":{\"Used\":20530,\"Backend\":{\"Type\":1,\"OnlineDisks\":0,\"OfflineDisks\":0,\"StandardSCData\":0,\"StandardSCParity\":0,\"RRSCData\":0,\"RRSCParity\":0,\"Sets\":null}},\"network\":{\"transferred\":808,\"received\":1160},\"http\":{\"totalHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalGETs\":{\"count\":1,\"avgDuration\":\"0s\"},\"successGETs\":{\"count\":1,\"avgDuration\":\"0s\"},\"totalPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"}},\"server\":{\"uptime\":5992503019270,\"version\":\"DEVELOPMENT.GOGET\",\"commitID\":\"DEVELOPMENT.GOGET\",\"region\":\"\",\"sqsARN\":[]}}}]"-     erasureJSON = "[{\"error\":\"\",\"addr\":\"192.168.1.218:9000\",\"data\":{\"storage\":{\"Used\":83084,\"Backend\":{\"Type\":2,\"OnlineDisks\":4,\"OfflineDisks\":0,\"StandardSCData\":2,\"StandardSCParity\":2,\"RRSCData\":2,\"RRSCParity\":2,\"Sets\":[[{\"uuid\":\"16ec6f2c-9197-4787-904a-36bb2c2683f8\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"4052e086-ef99-4aa5-ae2b-8e27559432f6\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"d0639950-ddd3-45b0-93ca-fd86f5d79f72\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"30ec68c0-37e1-4592-82c1-26b143c0ac10\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]]}},\"network\":{\"transferred\":404,\"received\":0},\"http\":{\"totalHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalGETs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successGETs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"}},\"server\":{\"uptime\":2738903073,\"version\":\"DEVELOPMENT.GOGET\",\"commitID\":\"DEVELOPMENT.GOGET\",\"region\":\"\",\"sqsARN\":[]}}}]"-     invalidJSON = "[{\"error\":\"\",\"addr\":\"192.168.1.218:9000\",\"data\":{\"storage\":{\"Used\":83084,\"Backend\":{\"Type\":42,\"OnlineDisks\":4,\"OfflineDisks\":0,\"StandardSCData\":2,\"StandardSCParity\":2,\"RRSCData\":2,\"RRSCParity\":2,\"Sets\":[[{\"uuid\":\"16ec6f2c-9197-4787-904a-36bb2c2683f8\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"4052e086-ef99-4aa5-ae2b-8e27559432f6\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"d0639950-ddd3-45b0-93ca-fd86f5d79f72\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"30ec68c0-37e1-4592-82c1-26b143c0ac10\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]]}},\"network\":{\"transferred\":404,\"received\":0},\"http\":{\"totalHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalGETs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successGETs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"}},\"server\":{\"uptime\":2738903073,\"version\":\"DEVELOPMENT.GOGET\",\"commitID\":\"DEVELOPMENT.GOGET\",\"region\":\"\",\"sqsARN\":[]}}}]"  parseHealStatusTest :: TestTree-parseHealStatusTest = testGroup "Parse MinIO Admin API HealStatus JSON test" $-  map (\(tName, tDesc, tfn, tVal) -> testCase tName $ assertBool tDesc $-        tfn (eitherDecode tVal :: Either [Char] HealStatus)) testCases-+parseHealStatusTest =+  testGroup "Parse MinIO Admin API HealStatus JSON test" $+    map+      ( \(tName, tDesc, tfn, tVal) ->+          testCase tName $ assertBool tDesc $+            tfn (eitherDecode tVal :: Either [Char] HealStatus)+      )+      testCases   where-    testCases = [ ("Good", "Verify heal result item for erasure backend", isRight, erasureJSON')-                , ("Corrupted", "Verify heal result item for erasure backend", isLeft, invalidJSON')-                , ("Incorrect Value", "Verify heal result item for erasure backend", isLeft, invalidItemType)-                ]-+    testCases =+      [ ("Good", "Verify heal result item for erasure backend", isRight, erasureJSON'),+        ("Corrupted", "Verify heal result item for erasure backend", isLeft, invalidJSON'),+        ("Incorrect Value", "Verify heal result item for erasure backend", isLeft, invalidItemType)+      ]     erasureJSON' = "{\"Summary\":\"finished\",\"StartTime\":\"2018-06-05T08:09:47.644465513Z\",\"NumDisks\":4,\"Settings\":{\"recursive\":false,\"dryRun\":false},\"Items\":[{\"resultId\":1,\"type\":\"metadata\",\"bucket\":\"\",\"object\":\"\",\"detail\":\"disk-format\",\"diskCount\":4,\"setCount\":1,\"before\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"after\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"objectSize\":0}]}"-     invalidJSON' = "{\"Summary\":\"finished\",\"StartTime\":\"2018-06-05T08:09:47.644465513Z\",\"NumDisks\":4,\"Settings\":{\"recursive\":false,\"dryRun\":false},\"Items\":[{\"resultId\":1,\"type\":\"metadata\",\"bucket\":\"\",\"object\":\"\",\"detail\":\"disk-format\",\"diskCount\":4,\"setCount\":1,\"before\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"after\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"objectSize\":0}]"-     invalidItemType = "{\"Summary\":\"finished\",\"StartTime\":\"2018-06-05T08:09:47.644465513Z\",\"NumDisks\":4,\"Settings\":{\"recursive\":false,\"dryRun\":false},\"Items\":[{\"resultId\":1,\"type\":\"hello\",\"bucket\":\"\",\"object\":\"\",\"detail\":\"disk-format\",\"diskCount\":4,\"setCount\":1,\"before\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"after\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"objectSize\":0}]}"  parseHealStartRespTest :: TestTree-parseHealStartRespTest = testGroup "Parse MinIO Admin API HealStartResp JSON test" $-  map (\(tName, tDesc, tfn, tVal) -> testCase tName $ assertBool tDesc $-        tfn (eitherDecode tVal :: Either [Char] HealStartResp)) testCases-+parseHealStartRespTest =+  testGroup "Parse MinIO Admin API HealStartResp JSON test" $+    map+      ( \(tName, tDesc, tfn, tVal) ->+          testCase tName $ assertBool tDesc $+            tfn (eitherDecode tVal :: Either [Char] HealStartResp)+      )+      testCases   where-    testCases = [ ("Good", "Verify heal start response for erasure backend", isRight, hsrJSON)-                , ("Missing Token", "Verify heal start response for erasure backend", isLeft, missingTokenJSON)-                ]-+    testCases =+      [ ("Good", "Verify heal start response for erasure backend", isRight, hsrJSON),+        ("Missing Token", "Verify heal start response for erasure backend", isLeft, missingTokenJSON)+      ]     hsrJSON = "{\"clientToken\":\"3a3aca49-77dd-4b78-bba7-0978f119b23e\",\"clientAddress\":\"127.0.0.1\",\"startTime\":\"2018-06-05T08:09:47.644394493Z\"}"-     missingTokenJSON = "{\"clientAddress\":\"127.0.0.1\",\"startTime\":\"2018-06-05T08:09:47.644394493Z\"}"
test/Network/Minio/JsonParser/Test.hs view
@@ -15,23 +15,23 @@ --  module Network.Minio.JsonParser.Test-  (-    jsonParserTests-  ) where--import           Test.Tasty-import           Test.Tasty.HUnit-import           UnliftIO                 (MonadUnliftIO)--import           Lib.Prelude+  ( jsonParserTests,+  )+where -import           Network.Minio.Errors-import           Network.Minio.JsonParser+import Lib.Prelude+import Network.Minio.Errors+import Network.Minio.JsonParser+import Test.Tasty+import Test.Tasty.HUnit+import UnliftIO (MonadUnliftIO)  jsonParserTests :: TestTree-jsonParserTests = testGroup "JSON Parser Tests"-  [ testCase "Test parseErrResponseJSON" testParseErrResponseJSON-  ]+jsonParserTests =+  testGroup+    "JSON Parser Tests"+    [ testCase "Test parseErrResponseJSON" testParseErrResponseJSON+    ]  tryValidationErr :: (MonadUnliftIO m) => m a -> m (Either MErrV a) tryValidationErr act = try act@@ -43,22 +43,21 @@ testParseErrResponseJSON = do   -- 1. Test parsing of an invalid error json.   parseResE <- tryValidationErr $ parseErrResponseJSON "ClearlyInvalidJSON"-  when (isRight parseResE) $-    assertFailure $ "Parsing should have failed => " ++ show parseResE+  when (isRight parseResE)+    $ assertFailure+    $ "Parsing should have failed => " ++ show parseResE    forM_ cases $ \(jsondata, sErr) -> do     parseErr <- tryValidationErr $ parseErrResponseJSON jsondata     either assertValidationErr (@?= sErr) parseErr-   where-    cases =  [-      -- 2. Test parsing of a valid error json.-      ("{\"Code\":\"InvalidAccessKeyId\",\"Message\":\"The access key ID you provided does not exist in our records.\",\"Key\":\"\",\"BucketName\":\"\",\"Resource\":\"/minio/admin/v1/info\",\"RequestId\":\"3L137\",\"HostId\":\"3L137\"}",-       ServiceErr "InvalidAccessKeyId" "The access key ID you provided does not exist in our records."-      )-      ,-      -- 3. Test parsing of a valid, empty Resource.-      ("{\"Code\":\"SignatureDoesNotMatch\",\"Message\":\"The request signature we calculated does not match the signature you provided. Check your key and signing method.\",\"Key\":\"\",\"BucketName\":\"\",\"Resource\":\"/minio/admin/v1/info\",\"RequestId\":\"3L137\",\"HostId\":\"3L137\"}",-       ServiceErr "SignatureDoesNotMatch" "The request signature we calculated does not match the signature you provided. Check your key and signing method."-      )+    cases =+      [ -- 2. Test parsing of a valid error json.+        ( "{\"Code\":\"InvalidAccessKeyId\",\"Message\":\"The access key ID you provided does not exist in our records.\",\"Key\":\"\",\"BucketName\":\"\",\"Resource\":\"/minio/admin/v1/info\",\"RequestId\":\"3L137\",\"HostId\":\"3L137\"}",+          ServiceErr "InvalidAccessKeyId" "The access key ID you provided does not exist in our records."+        ),+        -- 3. Test parsing of a valid, empty Resource.+        ( "{\"Code\":\"SignatureDoesNotMatch\",\"Message\":\"The request signature we calculated does not match the signature you provided. Check your key and signing method.\",\"Key\":\"\",\"BucketName\":\"\",\"Resource\":\"/minio/admin/v1/info\",\"RequestId\":\"3L137\",\"HostId\":\"3L137\"}",+          ServiceErr "SignatureDoesNotMatch" "The request signature we calculated does not match the signature you provided. Check your key and signing method."+        )       ]
test/Network/Minio/TestHelpers.hs view
@@ -15,18 +15,19 @@ --  module Network.Minio.TestHelpers-  ( runTestNS-  ) where--import           Network.Minio.Data+  ( runTestNS,+  )+where -import           Lib.Prelude+import Lib.Prelude+import Network.Minio.Data -newtype TestNS = TestNS { testNamespace :: Text }+newtype TestNS = TestNS {testNamespace :: Text}  instance HasSvcNamespace TestNS where   getSvcNamespace = testNamespace  runTestNS :: ReaderT TestNS m a -> m a-runTestNS = flip runReaderT $-            TestNS "http://s3.amazonaws.com/doc/2006-03-01/"+runTestNS =+  flip runReaderT $+    TestNS "http://s3.amazonaws.com/doc/2006-03-01/"
test/Network/Minio/Utils/Test.hs view
@@ -15,33 +15,32 @@ --  module Network.Minio.Utils.Test-  (-    limitedMapConcurrentlyTests-  ) where--import           Test.Tasty-import           Test.Tasty.HUnit--import           Lib.Prelude+  ( limitedMapConcurrentlyTests,+  )+where -import           Network.Minio.Utils+import Lib.Prelude+import Network.Minio.Utils+import Test.Tasty+import Test.Tasty.HUnit  limitedMapConcurrentlyTests :: TestTree-limitedMapConcurrentlyTests = testGroup "limitedMapConcurrently Tests"-  [ testCase "Test with various thread counts" testLMC-  ]+limitedMapConcurrentlyTests =+  testGroup+    "limitedMapConcurrently Tests"+    [ testCase "Test with various thread counts" testLMC+    ]  testLMC :: Assertion testLMC = do   let maxNum = 50   -- test with thread count of 1 to 2*maxNum-  forM_ [1..(2*maxNum)] $ \threads -> do-    res <- limitedMapConcurrently threads compute [1..maxNum]+  forM_ [1 .. (2 * maxNum)] $ \threads -> do+    res <- limitedMapConcurrently threads compute [1 .. maxNum]     sum res @?= overallResultCheck maxNum   where     -- simple function to run in each thread     compute :: Int -> IO Int-    compute n = return $ sum [1..n]-+    compute n = return $ sum [1 .. n]     -- function to check overall result-    overallResultCheck n = sum $ map (\t -> (t * (t+1)) `div` 2) [1..n]+    overallResultCheck n = sum $ map (\t -> (t * (t + 1)) `div` 2) [1 .. n]
test/Network/Minio/XmlGenerator/Test.hs view
@@ -13,30 +13,31 @@ -- 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-import           Test.Tasty.HUnit-import           Text.RawString.QQ          (r)--import           Lib.Prelude+module Network.Minio.XmlGenerator.Test+  ( xmlGeneratorTests,+  )+where -import           Network.Minio.Data-import           Network.Minio.TestHelpers-import           Network.Minio.XmlGenerator-import           Network.Minio.XmlParser    (parseNotification)+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"-  [ testCase "Test mkCreateBucketConfig" testMkCreateBucketConfig-  , testCase "Test mkCompleteMultipartUploadRequest" testMkCompleteMultipartUploadRequest-  , testCase "Test mkPutNotificationRequest" testMkPutNotificationRequest-  , testCase "Test mkSelectRequest" testMkSelectRequest-  ]+xmlGeneratorTests =+  testGroup+    "XML Generator Tests"+    [ testCase "Test mkCreateBucketConfig" testMkCreateBucketConfig,+      testCase "Test mkCompleteMultipartUploadRequest" testMkCompleteMultipartUploadRequest,+      testCase "Test mkPutNotificationRequest" testMkPutNotificationRequest,+      testCase "Test mkSelectRequest" testMkSelectRequest+    ]  testMkCreateBucketConfig :: Assertion testMkCreateBucketConfig = do@@ -44,100 +45,129 @@   assertEqual "CreateBucketConfiguration xml should match: " expected $     mkCreateBucketConfig ns "EU"   where-    expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\-               \<CreateBucketConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\-               \<LocationConstraint>EU</LocationConstraint>\-               \</CreateBucketConfiguration>"+    expected =+      "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+      \<CreateBucketConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+      \<LocationConstraint>EU</LocationConstraint>\+      \</CreateBucketConfiguration>"  testMkCompleteMultipartUploadRequest :: Assertion testMkCompleteMultipartUploadRequest =   assertEqual "completeMultipartUpload xml should match: " expected $-  mkCompleteMultipartUploadRequest [(1, "abc")]+    mkCompleteMultipartUploadRequest [(1, "abc")]   where-    expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\-    \<CompleteMultipartUpload>\-    \<Part>\-    \<PartNumber>1</PartNumber><ETag>abc</ETag>\-    \</Part>\-    \</CompleteMultipartUpload>"-+    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!")-      (@?= val) ntf+    either+      (\_ -> assertFailure "XML Parse Error!")+      (@?= val)+      ntf   where-    cases = [ Notification []-              [ NotificationConfig-                "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4"-                "arn:aws:sns:us-east-1:account-id:s3notificationtopic2"-                [ReducedRedundancyLostObject, ObjectCreated] defaultFilter-              ]-              []-            , Notification-              [ NotificationConfig-                "1" "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"-                [ObjectCreatedPut]-                (Filter $ FilterKey $ FilterRules-                  [ FilterRule "prefix" "images/"-                  , FilterRule "suffix" ".jpg"])-              , NotificationConfig-                "" "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"-                [ObjectCreated] defaultFilter-              ]-              [ NotificationConfig-                "" "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"-                [ReducedRedundancyLostObject] defaultFilter-              ]-              [ NotificationConfig-                "ObjectCreatedEvents" "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"-                [ObjectCreated] defaultFilter-              ]-            ]+    cases =+      [ Notification+          []+          [ NotificationConfig+              "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4"+              "arn:aws:sns:us-east-1:account-id:s3notificationtopic2"+              [ReducedRedundancyLostObject, ObjectCreated]+              defaultFilter+          ]+          [],+        Notification+          [ NotificationConfig+              "1"+              "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"+              [ObjectCreatedPut]+              ( Filter $ FilterKey $+                  FilterRules+                    [ FilterRule "prefix" "images/",+                      FilterRule "suffix" ".jpg"+                    ]+              ),+            NotificationConfig+              ""+              "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"+              [ObjectCreated]+              defaultFilter+          ]+          [ NotificationConfig+              ""+              "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"+              [ReducedRedundancyLostObject]+              defaultFilter+          ]+          [ NotificationConfig+              "ObjectCreatedEvents"+              "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"+              [ObjectCreated]+              defaultFilter+          ]+      ]  testMkSelectRequest :: Assertion testMkSelectRequest = mapM_ assertFn cases   where     assertFn (a, b) = assertEqual "selectRequest XML should match: " b $ mkSelectRequest a-    cases = [ ( SelectRequest "Select * from S3Object" SQL-                (InputSerialization (Just CompressionTypeGzip)-                 (InputFormatCSV $ fileHeaderInfo FileHeaderIgnore-                                <> recordDelimiter "\n"-                                <> fieldDelimiter ","-                                <> quoteCharacter "\""-                                <> quoteEscapeCharacter "\""-                 ))-                (OutputSerializationCSV $ quoteFields QuoteFieldsAsNeeded-                                       <> recordDelimiter "\n"-                                       <> fieldDelimiter ","-                                       <> quoteCharacter "\""-                                       <> quoteEscapeCharacter "\""+    cases =+      [ ( SelectRequest+            "Select * from S3Object"+            SQL+            ( InputSerialization+                (Just CompressionTypeGzip)+                ( InputFormatCSV $+                    fileHeaderInfo FileHeaderIgnore+                      <> 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 $-                setInputCompressionType CompressionTypeGzip $-                selectRequest "Select * from S3Object" documentJsonInput-                (outputJSONFromRecordDelimiter "\n")-              , [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>GZIP</CompressionType><JSON><Type>DOCUMENT</Type></JSON></InputSerialization><OutputSerialization><JSON><RecordDelimiter>+        ),+        ( setRequestProgressEnabled False+            $ setInputCompressionType CompressionTypeGzip+            $ selectRequest+              "Select * from S3Object"+              documentJsonInput+              (outputJSONFromRecordDelimiter "\n"),+          [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>GZIP</CompressionType><JSON><Type>DOCUMENT</Type></JSON></InputSerialization><OutputSerialization><JSON><RecordDelimiter> </RecordDelimiter></JSON></OutputSerialization><RequestProgress><Enabled>FALSE</Enabled></RequestProgress></SelectRequest>|]-              )-            , ( setRequestProgressEnabled False $-                setInputCompressionType CompressionTypeNone $-                selectRequest "Select * from S3Object" defaultParquetInput-                (outputCSVFromProps $ quoteFields QuoteFieldsAsNeeded-                                   <> recordDelimiter "\n"-                                   <> fieldDelimiter ","-                                   <> quoteCharacter "\""-                                   <> quoteEscapeCharacter "\"")-              , [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>NONE</CompressionType><Parquet/></InputSerialization><OutputSerialization><CSV><QuoteCharacter>&#34;</QuoteCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter>+        ),+        ( setRequestProgressEnabled False+            $ setInputCompressionType CompressionTypeNone+            $ selectRequest+              "Select * from S3Object"+              defaultParquetInput+              ( outputCSVFromProps $+                  quoteFields QuoteFieldsAsNeeded+                    <> recordDelimiter "\n"+                    <> fieldDelimiter ","+                    <> quoteCharacter "\""+                    <> quoteEscapeCharacter "\""+              ),+          [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>NONE</CompressionType><Parquet/></InputSerialization><OutputSerialization><CSV><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 view
@@ -13,39 +13,40 @@ -- See the License for the specific language governing permissions and -- limitations under the License. --- {-# LANGUAGE QuasiQuotes #-}-module Network.Minio.XmlParser.Test-  ( xmlParserTests-  ) where -import qualified Data.HashMap.Strict       as H-import           Data.Time                 (fromGregorian)-import           Test.Tasty-import           Test.Tasty.HUnit-import           Text.RawString.QQ         (r)-import           UnliftIO                  (MonadUnliftIO)--import           Lib.Prelude+module Network.Minio.XmlParser.Test+  ( xmlParserTests,+  )+where -import           Network.Minio.Data-import           Network.Minio.Errors-import           Network.Minio.TestHelpers-import           Network.Minio.XmlParser+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)  xmlParserTests :: TestTree-xmlParserTests = testGroup "XML Parser Tests"-  [ testCase "Test parseLocation" testParseLocation-  , testCase "Test parseNewMultipartUpload" testParseNewMultipartUpload-  , testCase "Test parseListObjectsResponse" testParseListObjectsResult-  , testCase "Test parseListObjectsV1Response" testParseListObjectsV1Result-  , testCase "Test parseListUploadsresponse" testParseListIncompleteUploads-  , testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse-  , testCase "Test parseListPartsResponse" testParseListPartsResponse-  , testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse-  , testCase "Test parseNotification" testParseNotification-  , testCase "Test parseSelectProgress" testParseSelectProgress-  ]+xmlParserTests =+  testGroup+    "XML Parser Tests"+    [ testCase "Test parseLocation" testParseLocation,+      testCase "Test parseNewMultipartUpload" testParseNewMultipartUpload,+      testCase "Test parseListObjectsResponse" testParseListObjectsResult,+      testCase "Test parseListObjectsV1Response" testParseListObjectsV1Result,+      testCase "Test parseListUploadsresponse" testParseListIncompleteUploads,+      testCase "Test parseCompleteMultipartUploadResponse" testParseCompleteMultipartUploadResponse,+      testCase "Test parseListPartsResponse" testParseListPartsResponse,+      testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse,+      testCase "Test parseNotification" testParseNotification,+      testCase "Test parseSelectProgress" testParseSelectProgress+    ]  tryValidationErr :: (MonadUnliftIO m) => m a -> m (Either MErrV a) tryValidationErr act = try act@@ -54,232 +55,232 @@ assertValidtionErr e = assertFailure $ "Failed due to validation error => " ++ show e  eitherValidationErr :: Either MErrV a -> (a -> Assertion) -> Assertion-eitherValidationErr (Left e) _  = assertValidtionErr e+eitherValidationErr (Left e) _ = assertValidtionErr e eitherValidationErr (Right a) f = f a  testParseLocation :: Assertion testParseLocation = do   -- 1. Test parsing of an invalid location constraint xml.   parseResE <- tryValidationErr $ parseLocation "ClearlyInvalidXml"-  when (isRight parseResE) $-    assertFailure $ "Parsing should have failed => " ++ show parseResE+  when (isRight parseResE)+    $ assertFailure+    $ "Parsing should have failed => " ++ show parseResE    forM_ cases $ \(xmldata, expectedLocation) -> do     parseLocE <- tryValidationErr $ parseLocation xmldata     either assertValidtionErr (@?= expectedLocation) parseLocE   where-    cases =  [-      -- 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"-      )+    cases =+      [ -- 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 = [-      ("<?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>\-       \  <UploadId>VXBsb2FkIElEIGZvciA2aWWpbmcncyBteS1tb3ZpZS5tMnRzIHVwbG9hZA</UploadId>\-       \</InitiateMultipartUploadResult>",-       "VXBsb2FkIElEIGZvciA2aWWpbmcncyBteS1tb3ZpZS5tMnRzIHVwbG9hZA"-      ),-      ("<?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>\-       \  <UploadId>EXAMPLEJZ6e0YupT2h66iePQCc9IEbYbDUy4RTpMeoSMLPRp8Z5o1u8feSRonpvnWsKKG35tI2LB9VDPiCgTy.Gq2VxQLYjrue4Nq.NBdqI-</UploadId>\-       \</InitiateMultipartUploadResult>",-       "EXAMPLEJZ6e0YupT2h66iePQCc9IEbYbDUy4RTpMeoSMLPRp8Z5o1u8feSRonpvnWsKKG35tI2LB9VDPiCgTy.Gq2VxQLYjrue4Nq.NBdqI-"-      )+    cases =+      [ ( "<?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>\+          \  <UploadId>VXBsb2FkIElEIGZvciA2aWWpbmcncyBteS1tb3ZpZS5tMnRzIHVwbG9hZA</UploadId>\+          \</InitiateMultipartUploadResult>",+          "VXBsb2FkIElEIGZvciA2aWWpbmcncyBteS1tb3ZpZS5tMnRzIHVwbG9hZA"+        ),+        ( "<?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>\+          \  <UploadId>EXAMPLEJZ6e0YupT2h66iePQCc9IEbYbDUy4RTpMeoSMLPRp8Z5o1u8feSRonpvnWsKKG35tI2LB9VDPiCgTy.Gq2VxQLYjrue4Nq.NBdqI-</UploadId>\+          \</InitiateMultipartUploadResult>",+          "EXAMPLEJZ6e0YupT2h66iePQCc9IEbYbDUy4RTpMeoSMLPRp8Z5o1u8feSRonpvnWsKKG35tI2LB9VDPiCgTy.Gq2VxQLYjrue4Nq.NBdqI-"+        )       ]  testParseListObjectsResult :: Assertion testParseListObjectsResult = do-  let-    xmldata = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\-              \<ListBucketResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\-              \<Name>bucket</Name>\-              \<Prefix/>\-              \<NextContinuationToken>opaque</NextContinuationToken>\-              \<KeyCount>1000</KeyCount>\-              \<MaxKeys>1000</MaxKeys>\-              \<IsTruncated>true</IsTruncated>\-              \<Contents>\-              \<Key>my-image.jpg</Key>\-              \<LastModified>2009-10-12T17:50:30.000Z</LastModified>\-              \<ETag>&quot;fba9dede5f27731c9771645a39863328&quot;</ETag>\-              \<Size>434234</Size>\-              \<StorageClass>STANDARD</StorageClass>\-              \</Contents>\-              \</ListBucketResult>"--    expectedListResult = 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+  let xmldata =+        "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+        \<ListBucketResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+        \<Name>bucket</Name>\+        \<Prefix/>\+        \<NextContinuationToken>opaque</NextContinuationToken>\+        \<KeyCount>1000</KeyCount>\+        \<MaxKeys>1000</MaxKeys>\+        \<IsTruncated>true</IsTruncated>\+        \<Contents>\+        \<Key>my-image.jpg</Key>\+        \<LastModified>2009-10-12T17:50:30.000Z</LastModified>\+        \<ETag>&quot;fba9dede5f27731c9771645a39863328&quot;</ETag>\+        \<Size>434234</Size>\+        \<StorageClass>STANDARD</StorageClass>\+        \</Contents>\+        \</ListBucketResult>"+      expectedListResult = 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    parsedListObjectsResult <- tryValidationErr $ runTestNS $ parseListObjectsResponse xmldata   eitherValidationErr parsedListObjectsResult (@?= expectedListResult)  testParseListObjectsV1Result :: Assertion testParseListObjectsV1Result = do-  let-    xmldata = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\-              \<ListBucketResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\-              \<Name>bucket</Name>\-              \<Prefix/>\-              \<NextMarker>my-image1.jpg</NextMarker>\-              \<KeyCount>1000</KeyCount>\-              \<MaxKeys>1000</MaxKeys>\-              \<IsTruncated>true</IsTruncated>\-              \<Contents>\-              \<Key>my-image.jpg</Key>\-              \<LastModified>2009-10-12T17:50:30.000Z</LastModified>\-              \<ETag>&quot;fba9dede5f27731c9771645a39863328&quot;</ETag>\-              \<Size>434234</Size>\-              \<StorageClass>STANDARD</StorageClass>\-              \</Contents>\-              \</ListBucketResult>"--    expectedListResult = ListObjectsV1Result True (Just "my-image1.jpg") [object1] []-    object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 H.empty H.empty-    modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12+  let xmldata =+        "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+        \<ListBucketResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+        \<Name>bucket</Name>\+        \<Prefix/>\+        \<NextMarker>my-image1.jpg</NextMarker>\+        \<KeyCount>1000</KeyCount>\+        \<MaxKeys>1000</MaxKeys>\+        \<IsTruncated>true</IsTruncated>\+        \<Contents>\+        \<Key>my-image.jpg</Key>\+        \<LastModified>2009-10-12T17:50:30.000Z</LastModified>\+        \<ETag>&quot;fba9dede5f27731c9771645a39863328&quot;</ETag>\+        \<Size>434234</Size>\+        \<StorageClass>STANDARD</StorageClass>\+        \</Contents>\+        \</ListBucketResult>"+      expectedListResult = ListObjectsV1Result True (Just "my-image1.jpg") [object1] []+      object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 H.empty H.empty+      modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12    parsedListObjectsV1Result <- tryValidationErr $ runTestNS $ parseListObjectsV1Response xmldata   eitherValidationErr parsedListObjectsV1Result (@?= expectedListResult)  testParseListIncompleteUploads :: Assertion testParseListIncompleteUploads = do-  let-    xmldata = "<ListMultipartUploadsResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\-  \<Bucket>example-bucket</Bucket>\-  \<KeyMarker/>\-  \<UploadIdMarker/>\-  \<NextKeyMarker>sample.jpg</NextKeyMarker>\-  \<NextUploadIdMarker>Xgw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1W99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--</NextUploadIdMarker>\-  \<Delimiter>/</Delimiter>\-  \<Prefix/>\-  \<MaxUploads>1000</MaxUploads>\-  \<IsTruncated>false</IsTruncated>\-  \<Upload>\-    \<Key>sample.jpg</Key>\-    \<UploadId>Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--</UploadId>\-    \<Initiator>\-      \<ID>314133b66967d86f031c7249d1d9a80249109428335cd0ef1cdc487b4566cb1b</ID>\-      \<DisplayName>s3-nickname</DisplayName>\-    \</Initiator>\-    \<Owner>\-      \<ID>314133b66967d86f031c7249d1d9a80249109428335cd0ef1cdc487b4566cb1b</ID>\-      \<DisplayName>s3-nickname</DisplayName>\-    \</Owner>\-    \<StorageClass>STANDARD</StorageClass>\-    \<Initiated>2010-11-26T19:24:17.000Z</Initiated>\-  \</Upload>\-  \<CommonPrefixes>\-    \<Prefix>photos/</Prefix>\-  \</CommonPrefixes>\-  \<CommonPrefixes>\-    \<Prefix>videos/</Prefix>\-  \</CommonPrefixes>\-  \</ListMultipartUploadsResult>"-    expectedListResult = ListUploadsResult False (Just "sample.jpg") (Just "Xgw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1W99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--") uploads prefixes-    uploads = [("sample.jpg", "Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--", initTime)]-    initTime = UTCTime (fromGregorian 2010 11 26) 69857-    prefixes = ["photos/", "videos/"]+  let xmldata =+        "<ListMultipartUploadsResult xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+        \<Bucket>example-bucket</Bucket>\+        \<KeyMarker/>\+        \<UploadIdMarker/>\+        \<NextKeyMarker>sample.jpg</NextKeyMarker>\+        \<NextUploadIdMarker>Xgw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1W99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--</NextUploadIdMarker>\+        \<Delimiter>/</Delimiter>\+        \<Prefix/>\+        \<MaxUploads>1000</MaxUploads>\+        \<IsTruncated>false</IsTruncated>\+        \<Upload>\+        \<Key>sample.jpg</Key>\+        \<UploadId>Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--</UploadId>\+        \<Initiator>\+        \<ID>314133b66967d86f031c7249d1d9a80249109428335cd0ef1cdc487b4566cb1b</ID>\+        \<DisplayName>s3-nickname</DisplayName>\+        \</Initiator>\+        \<Owner>\+        \<ID>314133b66967d86f031c7249d1d9a80249109428335cd0ef1cdc487b4566cb1b</ID>\+        \<DisplayName>s3-nickname</DisplayName>\+        \</Owner>\+        \<StorageClass>STANDARD</StorageClass>\+        \<Initiated>2010-11-26T19:24:17.000Z</Initiated>\+        \</Upload>\+        \<CommonPrefixes>\+        \<Prefix>photos/</Prefix>\+        \</CommonPrefixes>\+        \<CommonPrefixes>\+        \<Prefix>videos/</Prefix>\+        \</CommonPrefixes>\+        \</ListMultipartUploadsResult>"+      expectedListResult = ListUploadsResult False (Just "sample.jpg") (Just "Xgw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1W99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--") uploads prefixes+      uploads = [("sample.jpg", "Agw4MJT6ZPAVxpY0SAuGN7q4uWJJM22ZYg1N99trdp4tpO88.PT6.MhO0w2E17eutfAvQfQWoajgE_W2gpcxQw--", initTime)]+      initTime = UTCTime (fromGregorian 2010 11 26) 69857+      prefixes = ["photos/", "videos/"]    parsedListUploadsResult <- tryValidationErr $ runTestNS $ parseListUploadsResponse xmldata   eitherValidationErr parsedListUploadsResult (@?= expectedListResult) - testParseCompleteMultipartUploadResponse :: Assertion testParseCompleteMultipartUploadResponse = do-  let-    xmldata = "<?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>\-  \<Key>Example-Object</Key>\-  \<ETag>\"3858f62230ac3c915f300c664312c11f-9\"</ETag>\-\</CompleteMultipartUploadResult>"-    expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\""+  let xmldata =+        "<?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>\+        \<Key>Example-Object</Key>\+        \<ETag>\"3858f62230ac3c915f300c664312c11f-9\"</ETag>\+        \</CompleteMultipartUploadResult>"+      expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\""    parsedETagE <- runExceptT $ runTestNS $ parseCompleteMultipartUploadResponse xmldata   eitherValidationErr parsedETagE (@?= expectedETag)  testParseListPartsResponse :: Assertion testParseListPartsResponse = do-  let-    xmldata = "<?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>\-  \<UploadId>XXBsb2FkIElEIGZvciBlbHZpbmcncyVcdS1tb3ZpZS5tMnRzEEEwbG9hZA</UploadId>\-  \<Initiator>\-      \<ID>arn:aws:iam::111122223333:user/some-user-11116a31-17b5-4fb7-9df5-b288870f11xx</ID>\-      \<DisplayName>umat-user-11116a31-17b5-4fb7-9df5-b288870f11xx</DisplayName>\-  \</Initiator>\-  \<Owner>\-    \<ID>75aa57f09aa0c8caeab4f8c24e99d10f8e7faeebf76c078efc7c6caea54ba06a</ID>\-    \<DisplayName>someName</DisplayName>\-  \</Owner>\-  \<StorageClass>STANDARD</StorageClass>\-  \<PartNumberMarker>1</PartNumberMarker>\-  \<NextPartNumberMarker>3</NextPartNumberMarker>\-  \<MaxParts>2</MaxParts>\-  \<IsTruncated>true</IsTruncated>\-  \<Part>\-    \<PartNumber>2</PartNumber>\-    \<LastModified>2010-11-10T20:48:34.000Z</LastModified>\-    \<ETag>\"7778aef83f66abc1fa1e8477f296d394\"</ETag>\-    \<Size>10485760</Size>\-  \</Part>\-  \<Part>\-    \<PartNumber>3</PartNumber>\-    \<LastModified>2010-11-10T20:48:33.000Z</LastModified>\-    \<ETag>\"aaaa18db4cc2f85cedef654fccc4a4x8\"</ETag>\-    \<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-    part2 = ObjectPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2-    modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10+  let xmldata =+        "<?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>\+        \<UploadId>XXBsb2FkIElEIGZvciBlbHZpbmcncyVcdS1tb3ZpZS5tMnRzEEEwbG9hZA</UploadId>\+        \<Initiator>\+        \<ID>arn:aws:iam::111122223333:user/some-user-11116a31-17b5-4fb7-9df5-b288870f11xx</ID>\+        \<DisplayName>umat-user-11116a31-17b5-4fb7-9df5-b288870f11xx</DisplayName>\+        \</Initiator>\+        \<Owner>\+        \<ID>75aa57f09aa0c8caeab4f8c24e99d10f8e7faeebf76c078efc7c6caea54ba06a</ID>\+        \<DisplayName>someName</DisplayName>\+        \</Owner>\+        \<StorageClass>STANDARD</StorageClass>\+        \<PartNumberMarker>1</PartNumberMarker>\+        \<NextPartNumberMarker>3</NextPartNumberMarker>\+        \<MaxParts>2</MaxParts>\+        \<IsTruncated>true</IsTruncated>\+        \<Part>\+        \<PartNumber>2</PartNumber>\+        \<LastModified>2010-11-10T20:48:34.000Z</LastModified>\+        \<ETag>\"7778aef83f66abc1fa1e8477f296d394\"</ETag>\+        \<Size>10485760</Size>\+        \</Part>\+        \<Part>\+        \<PartNumber>3</PartNumber>\+        \<LastModified>2010-11-10T20:48:33.000Z</LastModified>\+        \<ETag>\"aaaa18db4cc2f85cedef654fccc4a4x8\"</ETag>\+        \<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+      part2 = ObjectPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2+      modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10    parsedListPartsResult <- runExceptT $ runTestNS $ parseListPartsResponse xmldata   eitherValidationErr parsedListPartsResult (@?= expectedListResult)  testParseCopyObjectResponse :: Assertion testParseCopyObjectResponse = do-  let-    cases = [ ("<?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))-            , ("<?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))]+  let cases =+        [ ( "<?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+            )+          ),+          ( "<?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+            )+          )+        ]    forM_ cases $ \(xmldata, (etag, modTime)) -> do     parseResult <- runExceptT $ runTestNS $ parseCopyObjectResponse xmldata@@ -287,73 +288,88 @@  testParseNotification :: Assertion testParseNotification = do-  let-    cases = [ ("<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\-\  <TopicConfiguration>\-\    <Id>YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4</Id>\-\    <Topic>arn:aws:sns:us-east-1:account-id:s3notificationtopic2</Topic>\-\    <Event>s3:ReducedRedundancyLostObject</Event>\-\    <Event>s3:ObjectCreated:*</Event>\-\  </TopicConfiguration>\-\</NotificationConfiguration>",-               Notification []-                [ NotificationConfig+  let cases =+        [ ( "<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+            \  <TopicConfiguration>\+            \    <Id>YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4</Id>\+            \    <Topic>arn:aws:sns:us-east-1:account-id:s3notificationtopic2</Topic>\+            \    <Event>s3:ReducedRedundancyLostObject</Event>\+            \    <Event>s3:ObjectCreated:*</Event>\+            \  </TopicConfiguration>\+            \</NotificationConfiguration>",+            Notification+              []+              [ NotificationConfig                   "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4"                   "arn:aws:sns:us-east-1:account-id:s3notificationtopic2"-                  [ReducedRedundancyLostObject, ObjectCreated] defaultFilter-                ]-                [])-            , ("<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\-\  <CloudFunctionConfiguration>\-\    <Id>ObjectCreatedEvents</Id>\-\    <CloudFunction>arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail</CloudFunction>\-\    <Event>s3:ObjectCreated:*</Event>\-\  </CloudFunctionConfiguration>\-\  <QueueConfiguration>\-\      <Id>1</Id>\-\      <Filter>\-\          <S3Key>\-\              <FilterRule>\-\                  <Name>prefix</Name>\-\                  <Value>images/</Value>\-\              </FilterRule>\-\              <FilterRule>\-\                  <Name>suffix</Name>\-\                  <Value>.jpg</Value>\-\              </FilterRule>\-\          </S3Key>\-\     </Filter>\-\     <Queue>arn:aws:sqs:us-west-2:444455556666:s3notificationqueue</Queue>\-\     <Event>s3:ObjectCreated:Put</Event>\-\  </QueueConfiguration>\-\  <TopicConfiguration>\-\    <Topic>arn:aws:sns:us-east-1:356671443308:s3notificationtopic2</Topic>\-\    <Event>s3:ReducedRedundancyLostObject</Event>\-\  </TopicConfiguration>\-\  <QueueConfiguration>\-\    <Queue>arn:aws:sqs:us-east-1:356671443308:s3notificationqueue</Queue>\-\    <Event>s3:ObjectCreated:*</Event>\-\  </QueueConfiguration>)\-\</NotificationConfiguration>",-               Notification [ NotificationConfig-                              "1" "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"-                              [ObjectCreatedPut]-                              (Filter $ FilterKey $ FilterRules-                               [FilterRule "prefix" "images/",-                                FilterRule "suffix" ".jpg"])-                            , NotificationConfig-                              "" "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"-                              [ObjectCreated] defaultFilter-                            ]-                            [ NotificationConfig-                              "" "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"-                              [ReducedRedundancyLostObject] defaultFilter-                            ]-                            [ NotificationConfig-                              "ObjectCreatedEvents" "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"-                              [ObjectCreated] defaultFilter-                            ])-            ]+                  [ReducedRedundancyLostObject, ObjectCreated]+                  defaultFilter+              ]+              []+          ),+          ( "<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\+            \  <CloudFunctionConfiguration>\+            \    <Id>ObjectCreatedEvents</Id>\+            \    <CloudFunction>arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail</CloudFunction>\+            \    <Event>s3:ObjectCreated:*</Event>\+            \  </CloudFunctionConfiguration>\+            \  <QueueConfiguration>\+            \      <Id>1</Id>\+            \      <Filter>\+            \          <S3Key>\+            \              <FilterRule>\+            \                  <Name>prefix</Name>\+            \                  <Value>images/</Value>\+            \              </FilterRule>\+            \              <FilterRule>\+            \                  <Name>suffix</Name>\+            \                  <Value>.jpg</Value>\+            \              </FilterRule>\+            \          </S3Key>\+            \     </Filter>\+            \     <Queue>arn:aws:sqs:us-west-2:444455556666:s3notificationqueue</Queue>\+            \     <Event>s3:ObjectCreated:Put</Event>\+            \  </QueueConfiguration>\+            \  <TopicConfiguration>\+            \    <Topic>arn:aws:sns:us-east-1:356671443308:s3notificationtopic2</Topic>\+            \    <Event>s3:ReducedRedundancyLostObject</Event>\+            \  </TopicConfiguration>\+            \  <QueueConfiguration>\+            \    <Queue>arn:aws:sqs:us-east-1:356671443308:s3notificationqueue</Queue>\+            \    <Event>s3:ObjectCreated:*</Event>\+            \  </QueueConfiguration>)\+            \</NotificationConfiguration>",+            Notification+              [ NotificationConfig+                  "1"+                  "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue"+                  [ObjectCreatedPut]+                  ( Filter $ FilterKey $+                      FilterRules+                        [ FilterRule "prefix" "images/",+                          FilterRule "suffix" ".jpg"+                        ]+                  ),+                NotificationConfig+                  ""+                  "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"+                  [ObjectCreated]+                  defaultFilter+              ]+              [ NotificationConfig+                  ""+                  "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"+                  [ReducedRedundancyLostObject]+                  defaultFilter+              ]+              [ NotificationConfig+                  "ObjectCreatedEvents"+                  "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"+                  [ObjectCreated]+                  defaultFilter+              ]+          )+        ]    forM_ cases $ \(xmldata, val) -> do     result <- runExceptT $ runTestNS $ parseNotification xmldata@@ -362,20 +378,25 @@ -- | 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)-                , ([r|<?xml version="1.0" encoding="UTF-8"?>+</Progress>|],+            Progress 512 1024 1024+          ),+          ( [r|<?xml version="1.0" encoding="UTF-8"?> <Stats>      <BytesScanned>512</BytesScanned>      <BytesProcessed>1024</BytesProcessed>      <BytesReturned>1024</BytesReturned>-</Stats>|], Progress 512 1024 1024)-                ]+</Stats>|],+            Progress 512 1024 1024+          )+        ] -    forM_ cases $ \(xmldata, progress) -> do-        result <- runExceptT $ parseSelectProgress xmldata-        eitherValidationErr result (@?= progress)+  forM_ cases $ \(xmldata, progress) -> do+    result <- runExceptT $ parseSelectProgress xmldata+    eitherValidationErr result (@?= progress)
test/Spec.hs view
@@ -14,21 +14,18 @@ -- 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-import           Network.Minio.PutObject-import           Network.Minio.Utils.Test-import           Network.Minio.XmlGenerator.Test-import           Network.Minio.XmlParser.Test+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+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,82 +48,84 @@ --   ]  qcProps :: TestTree-qcProps = testGroup "(checked by QuickCheck)"-  [ QC.testProperty "selectPartSizes:" $-    \n -> let (pns, offs, sizes) = L.unzip3 (selectPartSizes n)-+qcProps =+  testGroup+    "(checked by QuickCheck)"+    [ QC.testProperty "selectPartSizes:" $+        \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))-+              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-                     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 ||-             (isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk &&-              isSizesConstantExceptLast && isMinPartSizeOk)--  , QC.testProperty "selectCopyRanges:" $-    \(start, end) ->-      let (_, pairs) = L.unzip (selectCopyRanges (start, end))--          -- is last part's snd offset end?-          isLastPartOk = maybe False ((end ==) . snd) $ lastMay pairs-          -- is first part's fst offset start-          isFirstPartOk = maybe False ((start ==) . fst) $ headMay pairs--          -- 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 &&-                          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 &&-                        and (map (\(a, b) -> a == b + 1) $ zip fsts snds)--      in start < 0 || start > end ||-         (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts)--  , QC.testProperty "mkSSECKey:" $-    \w8s -> let bs = B.pack w8s-                r = mkSSECKey bs-            in case r of-                Just _  -> B.length bs == 32+                if+                    | nparts > 1 -> -- last part can be smaller but > 0+                      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+                || ( isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk+                       && isSizesConstantExceptLast+                       && isMinPartSizeOk+                   ),+      QC.testProperty "selectCopyRanges:" $+        \(start, end) ->+          let (_, pairs) = L.unzip (selectCopyRanges (start, end))+              -- is last part's snd offset end?+              isLastPartOk = maybe False ((end ==) . snd) $ lastMay pairs+              -- is first part's fst offset start+              isFirstPartOk = maybe False ((start ==) . fst) $ headMay pairs+              -- 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+                  && 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+                  && and (map (\(a, b) -> a == b + 1) $ zip fsts snds)+           in start < 0 || start > end+                || (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts),+      QC.testProperty "mkSSECKey:" $+        \w8s ->+          let bs = B.pack w8s+              r = mkSSECKey bs+           in case r of+                Just _ -> B.length bs == 32                 Nothing -> B.length bs /= 32-  ]+    ]  unitTests :: TestTree-unitTests = testGroup "Unit tests" [ xmlGeneratorTests, xmlParserTests-                                   , bucketNameValidityTests-                                   , objectNameValidityTests-                                   , parseServerInfoJSONTest-                                   , parseHealStatusTest-                                   , parseHealStartRespTest-                                   , limitedMapConcurrentlyTests-                                   ]+unitTests =+  testGroup+    "Unit tests"+    [ xmlGeneratorTests,+      xmlParserTests,+      bucketNameValidityTests,+      objectNameValidityTests,+      parseServerInfoJSONTest,+      parseHealStatusTest,+      parseHealStartRespTest,+      limitedMapConcurrentlyTests+    ]