minio-hs 1.0.1 → 1.1.0

raw patch · 52 files changed

+1856/−627 lines, 52 filesdep +inidep −data-defaultdep ~filepathPVP ok

version bump matches the API change (PVP)

Dependencies added: ini

Dependencies removed: data-default

Dependency ranges changed: filepath

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• README.md +36/−18
• docs/API.md +111/−59
• examples/BucketExists.hs +2/−2
• examples/CopyObject.hs +2/−2
• examples/FileUploader.hs +13/−13
• examples/GetConfig.hs +30/−0
• examples/GetObject.hs +7/−6
• examples/HeadObject.hs +2/−2
• examples/Heal.hs +34/−0
• examples/ListBuckets.hs +2/−2
• examples/ListIncompleteUploads.hs +4/−5
• examples/ListObjects.hs +4/−6
• examples/MakeBucket.hs +39/−0
• examples/Makebucket.hs +0/−40
• examples/PresignedGetObject.hs +2/−2
• examples/PresignedPostPolicy.hs +2/−2
• examples/PresignedPutObject.hs +2/−2
• examples/PutObject.hs +4/−3
• examples/RemoveBucket.hs +38/−0
• examples/RemoveIncompleteUpload.hs +2/−2
• examples/RemoveObject.hs +2/−2
• examples/Removebucket.hs +0/−38
• examples/ServerInfo.hs +30/−0
• examples/ServiceSendRestart.hs +30/−0
• examples/ServiceSendStop.hs +30/−0
• examples/ServiceStatus.hs +30/−0
• examples/SetConfig.hs +32/−0
• minio-hs.cabal +19/−5
• src/Network/Minio.hs +24/−6
• src/Network/Minio/API.hs +31/−41
• src/Network/Minio/APICommon.hs +44/−0
• src/Network/Minio/AdminAPI.hs +559/−0
• src/Network/Minio/CopyObject.hs +1/−2
• src/Network/Minio/Data.hs +185/−114
• src/Network/Minio/Errors.hs +4/−1
• src/Network/Minio/JsonParser.hs +42/−0
• src/Network/Minio/PresignedOperations.hs +27/−18
• src/Network/Minio/PutObject.hs +2/−1
• src/Network/Minio/S3API.hs +32/−31
• src/Network/Minio/Sign/V4.hs +59/−58
• src/Network/Minio/Utils.hs +4/−0
• src/Network/Minio/XmlGenerator.hs +9/−9
• src/Network/Minio/XmlParser.hs +77/−59
• test/LiveServer.hs +40/−37
• test/Network/Minio/API/Test.hs +52/−1
• test/Network/Minio/JsonParser/Test.hs +64/−0
• test/Network/Minio/TestHelpers.hs +32/−0
• test/Network/Minio/Utils/Test.hs +4/−4
• test/Network/Minio/XmlGenerator/Test.hs +11/−9
• test/Network/Minio/XmlParser/Test.hs +16/−16
• test/Spec.hs +13/−9

@@ -1,6 +1,21 @@ Changelog ========== +## Version 1.1.0++This version brings the following changes:++* Adds experimental Admin APIs (#88, #91, #93, #94, #95, #100)+* Adds support for using Google Compute Storage service when S3+  compatibility mode is enabled (#96, #99)++This version also brings some breaking changes (via #101):++* Adds IsString instance to load server address, and updates+  initialization API to be more user friendly+* Drops usage of data-default package and exposes explicit default+  values for various types used in the library.+ ## Version 1.0.1  This version brings the following (non-breaking) changes:

@@ -44,19 +44,37 @@ ### FileUploader.hs ``` haskell #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs --package optparse-applicative --package filepath+-- stack --resolver lts-11.1 runghc --package minio-hs --package optparse-applicative --package filepath -{-# Language OverloadedStrings, ScopedTypeVariables #-}-import Network.Minio+--+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+-- -import Control.Monad.Catch (catchIf)-import Control.Monad.IO.Class (liftIO)-import Data.Monoid ((<>))-import Data.Text (pack)-import Options.Applicative-import Prelude-import System.FilePath.Posix +{-# 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+ -- | The following example uses minio's play server at -- https://play.minio.io:9000.  The endpoint and associated -- credentials are provided via the libary constant,@@ -77,27 +95,27 @@              <> header              "FileUploader - a simple file-uploader program using minio-hs") -ignoreMinioErr :: ServiceErr -> Minio ()-ignoreMinioErr = return . const ()-- main :: IO () main = do   let bucket = "my-bucket" -  -- Parse command line argument, namely --filename.+  -- Parse command line argument   filepath <- execParser cmdParser   let object = pack $ takeBaseName filepath    res <- runMinio minioPlayCI $ do     -- Make a bucket; catch bucket already exists exception if thrown.-    catchIf (== BucketAlreadyOwnedByYou) (makeBucket bucket Nothing) ignoreMinioErr+    bErr <- try $ makeBucket bucket Nothing+    case bErr of+      Left (MErrService BucketAlreadyOwnedByYou) -> return ()+      Left e                                     -> throwIO e+      Right _                                    -> return ()      -- Upload filepath to bucket; object is derived from filepath.-    fPutObject bucket object filepath+    fPutObject bucket object filepath def    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." ``` 

@@ -185,7 +185,6 @@ main = do     res <- runMinio minioPlayCI $ do         makeBucket bucketName (Just "us-east-1")-     case res of         Left err -> putStrLn $ "Failed to make bucket: " ++ (show res)         Right _ -> putStrLn $ "makeBucket successful."@@ -225,7 +224,7 @@   <a name="listObjects"></a>-### listObjects :: Bucket -> Maybe Text -> Bool -> C.Producer Minio ObjectInfo+### listObjects :: Bucket -> Maybe Text -> Bool -> C.ConduitM () ObjectInfo Minio ()  List objects in the given bucket, implements version 2 of AWS S3 API. @@ -244,7 +243,7 @@  |Return type   |Description   | |:---|:---|-| _C.Producer Minio ObjectInfo_  | A Conduit Producer of `ObjectInfo` values corresponding to each object. |+| _C.ConduitM () ObjectInfo Minio ()_  | A Conduit Producer of `ObjectInfo` values corresponding to each object. |  __ObjectInfo record type__ @@ -258,11 +257,20 @@ __Example__  ``` haskell-{-# Language OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio -import Data.Conduit (($$))-import Conduit.Combinators (sinkList)+import           Conduit+import           Prelude ++-- | The following example uses minio's play server at+-- https://play.minio.io:9000.  The endpoint and associated+-- credentials are provided via the libary constant,+--+-- > minioPlayCI :: ConnectInfo+--+ main :: IO () main = do   let@@ -270,14 +278,13 @@    -- Performs a recursive listing of all objects under bucket "test"   -- on play.minio.io.-  res <- runMinio minioPlayCI $ do-    listObjects bucket Nothing True $$ sinkList+  res <- runMinio minioPlayCI $+    runConduit $ listObjects bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))   print res- ```  <a name="listObjectsV1"></a>-### listObjectsV1 :: Bucket -> Maybe Text -> Bool -> C.Producer Minio ObjectInfo+### listObjectsV1 :: Bucket -> Maybe Text -> Bool -> C.ConduitM () ObjectInfo Minio ()  List objects in the given bucket, implements version 1 of AWS S3 API. This API is provided for legacy S3 compatible object storage endpoints.@@ -297,7 +304,7 @@  |Return type   |Description   | |:---|:---|-| _C.Producer Minio ObjectInfo_  | A Conduit Producer of `ObjectInfo` values corresponding to each object. |+| _C.ConduitM () ObjectInfo Minio ()_  | A Conduit Producer of `ObjectInfo` values corresponding to each object. |  __ObjectInfo record type__ @@ -311,11 +318,20 @@ __Example__  ``` haskell-{-# Language OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio -import Data.Conduit (($$))-import Conduit.Combinators (sinkList)+import           Conduit+import           Prelude ++-- | The following example uses minio's play server at+-- https://play.minio.io:9000.  The endpoint and associated+-- credentials are provided via the libary constant,+--+-- > minioPlayCI :: ConnectInfo+--+ main :: IO () main = do   let@@ -323,10 +339,9 @@    -- Performs a recursive listing of all objects under bucket "test"   -- on play.minio.io.-  res <- runMinio minioPlayCI $ do-    listObjectsV1 bucket Nothing True $$ sinkList+  res <- runMinio minioPlayCI $+    runConduit $ listObjectsV1 bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))   print res- ```  <a name="listIncompleteUploads"></a>@@ -349,7 +364,7 @@  |Return type   |Description   | |:---|:---|-| _C.Producer Minio UploadInfo_  | A Conduit Producer of `UploadInfo` values corresponding to each incomplete multipart upload |+| _C.ConduitM () UploadInfo Minio ()_  | A Conduit Producer of `UploadInfo` values corresponding to each incomplete multipart upload |  __UploadInfo record type__ @@ -362,20 +377,28 @@ __Example__  ```haskell-{-# Language OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio -import Data.Conduit (($$))-import Conduit.Combinators (sinkList)+import           Conduit+import           Prelude +-- | The following example uses minio's play server at+-- https://play.minio.io:9000.  The endpoint and associated+-- credentials are provided via the libary constant,+--+-- > minioPlayCI :: ConnectInfo+--+ main :: IO () main = do   let     bucket = "test" -  -- Performs a recursive listing of all incompletely uploaded objects-  -- under bucket "test" on play.minio.io.-  res <- runMinio minioPlayCI $ do-    listIncompleteUploads bucket Nothing True $$ sinkList+  -- 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))   print res  ```@@ -383,61 +406,76 @@ ## 3. Object operations  <a name="getObject"></a>-### getObject :: Bucket -> Object -> Minio (C.ResumableSource Minio ByteString)+### getObject :: Bucket -> Object -> GetObjectOptions -> Minio (C.ConduitM () ByteString Minio ()) -Get an object from the service.+Get an object from the S3 service, optionally object ranges can be provided as well.  __Parameters__ -In the expression `getObject bucketName objectName` the parameters+In the expression `getObject bucketName objectName opts` the parameters are:  |Param   |Type   |Description   | |:---|:---| :---| | `bucketName`  | _Bucket_ (alias for `Text`)  | Name of the bucket | | `objectName` | _Object_ (alias for `Text`)  | Name of the object |+| `opts`   | _GetObjectOptions_ | Options for GET requests specifying additional options like If-Match, Range | +__GetObjectOptions record type__++|Field   |Type   |Description   |+|:---|:---| :---|+| `gooRange` | `Maybe ByteRanges` | Represents the byte range of object. E.g ByteRangeFromTo 0 9 represents first ten bytes of the object|+| `gooIfMatch` | `Maybe ETag` (alias for `Text`) | (Optional) ETag of object should match |+| `gooIfNoneMatch` | `Maybe ETag` (alias for `Text`) | (Optional) ETag of object shouldn't match |+| `gooIfUnmodifiedSince` | `Maybe UTCTime` | (Optional) Time since object wasn't modified |+| `gooIfModifiedSince` | `Maybe UTCTime` | (Optional) Time since object was modified |+ __Return Value__  The return value can be incrementally read to process the contents of the object. |Return type   |Description   | |:---|:---|-| _C.ResumableSource Minio ByteString_  | A Conduit ResumableSource of `ByteString` values. |+| _Minio (C.ConduitM () ByteString Minio ())_  | A Conduit source of `ByteString` values. |  __Example__  ```haskell-{-# Language OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio -import Network.Minio-import Data.Conduit (($$+-))-import Data.Conduit.Binary (sinkLbs)-import qualified Data.ByteString.Lazy as LB+import qualified Data.Conduit        as C+import qualified Data.Conduit.Binary as CB +import           Prelude++-- | The following example uses minio's play server at+-- https://play.minio.io:9000.  The endpoint and associated+-- credentials are provided via the libary constant,+--+-- > minioPlayCI :: ConnectInfo+--+ main :: IO () main = do   let-    bucket = "mybucket"-    object = "myobject"--  -- Lists the parts in an incompletely uploaded object identified by-  -- bucket, object and upload ID.+      bucket = "my-bucket"+      object = "my-object"   res <- runMinio minioPlayCI $ do-           source <- getObject bucket object-           source $$+- sinkLbs+    src <- getObject bucket object def+    C.connect src $ CB.sinkFileCautious "/tmp/my-object" -  -- the following the prints the contents of the object.-  putStrLn $ either-    (("Failed to getObject: " ++) . show)-    (("Read an object of length: " ++) . show . LB.length)-    res+  case res of+    Left e  -> putStrLn $ "getObject failed." ++ (show e)+    Right _ -> putStrLn "getObject succeeded." ```  <a name="putObject"></a>-### putObject :: Bucket -> Object -> C.Producer Minio ByteString -> Maybe Int64 -> Minio ()+### putObject :: Bucket -> Object -> C.ConduitM () ByteString Minio () -> Maybe Int64 -> PutObjectOptions -> Minio () Uploads an object to a bucket in the service, from the given input-byte stream of optionally supplied length+byte stream of optionally supplied length. Optionally you can also specify+additional metadata for the object.  __Parameters__ @@ -448,28 +486,42 @@ |:---|:---| :---| | `bucketName`  | _Bucket_ (alias for `Text`)  | Name of the bucket | | `objectName` | _Object_ (alias for `Text`)  | Name of the object |-| `inputSrc` | _C.Producer Minio ByteString_ | A Conduit Producer of `ByteString` values |+| `inputSrc` | _C.ConduitM () ByteString Minio ()_ | A Conduit producer of `ByteString` values |+| `size` | _Int64_ | Provide stream size (optional) |+| `opts` | _PutObjectOptions_ | Optional parameters to provide additional metadata for the object |  __Example__  ```haskell-{-# Language OverloadedStrings #-}-import Network.Minio+{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio+ import qualified Data.Conduit.Combinators as CC +import           Prelude++-- | The following example uses minio's play server at+-- https://play.minio.io:9000.  The endpoint and associated+-- credentials are provided via the libary constant,+--+-- > minioPlayCI :: ConnectInfo+--+ main :: IO () main = do   let-    bucket = "mybucket"-    object = "myobject"-    kb15 = 15 * 1024--  res <- runMinio minioPlayCI $ do-           putObject bucket object (CC.repeat "a") (Just kb15)+      bucket = "test"+      object = "obj"+      localFile = "/etc/lsb-release"+      kb15 = 15 * 1024 +  -- Eg 1. Upload a stream of repeating "a" using putObject with default options.+  res <- runMinio minioPlayCI $+    putObject bucket object (CC.repeat "a") (Just kb15) def   case res of-    Left e -> putStrLn $ "Failed to putObject " ++ show bucket ++ "/" ++ show object-    Right _ -> putStrLn "PutObject was successful"+    Left e   -> putStrLn $ "putObject failed." ++ show e+    Right () -> putStrLn "putObject succeeded."+ ```  <a name="fGetObject"></a>

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs --package optparse-applicative --package filepath+-- stack --resolver lts-11.1 runghc --package minio-hs --package optparse-applicative --package filepath  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -22,14 +22,14 @@ {-# LANGUAGE ScopedTypeVariables #-} import           Network.Minio -import           Control.Monad.Catch    (catchIf)-import           Control.Monad.IO.Class (liftIO)-import           Data.Monoid            ((<>))-import           Data.Text              (pack)+import           Data.Monoid           ((<>))+import           Data.Text             (pack) import           Options.Applicative-import           Prelude import           System.FilePath.Posix+import           UnliftIO              (throwIO, try) +import           Prelude+ -- | The following example uses minio's play server at -- https://play.minio.io:9000.  The endpoint and associated -- credentials are provided via the libary constant,@@ -50,10 +50,6 @@              <> header              "FileUploader - a simple file-uploader program using minio-hs") -ignoreMinioErr :: ServiceErr -> Minio ()-ignoreMinioErr = return . const ()-- main :: IO () main = do   let bucket = "my-bucket"@@ -64,10 +60,14 @@    res <- runMinio minioPlayCI $ do     -- Make a bucket; catch bucket already exists exception if thrown.-    catchIf (== BucketAlreadyOwnedByYou) (makeBucket bucket Nothing) ignoreMinioErr+    bErr <- try $ makeBucket bucket Nothing+    case bErr of+      Left (MErrService BucketAlreadyOwnedByYou) -> return ()+      Left e                                     -> throwIO e+      Right _                                    -> return ()      -- Upload filepath to bucket; object is derived from filepath.-    fPutObject bucket object filepath+    fPutObject bucket object filepath def    case res of     Left e   -> putStrLn $ "file upload failed due to " ++ (show e)

@@ -0,0 +1,30 @@+#!/usr/bin/env stack+-- stack --resolver lts-11.1 runghc --package minio-hs++--+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio+import           Network.Minio.AdminAPI++import           Prelude++main :: IO ()+main = do+  res <- runMinio def $+      getConfig+  print res

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -20,8 +20,9 @@ {-# LANGUAGE OverloadedStrings #-} import           Network.Minio -import           Data.Conduit        (($$+-))-import           Data.Conduit.Binary (sinkLbs)+import qualified Data.Conduit        as C+import qualified Data.Conduit.Binary as CB+ import           Prelude  -- | The following example uses minio's play server at@@ -37,8 +38,8 @@       bucket = "my-bucket"       object = "my-object"   res <- runMinio minioPlayCI $ do-    src <- getObject bucket object-    (src $$+- sinkLbs)+    src <- getObject bucket object def+    C.connect src $ CB.sinkFileCautious "/tmp/my-object"    case res of     Left e  -> putStrLn $ "getObject failed." ++ (show e)

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.

@@ -0,0 +1,34 @@+#!/usr/bin/env stack+-- stack --resolver lts-11.1 runghc --package minio-hs++--+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio+import           Network.Minio.AdminAPI++import           Prelude++main :: IO ()+main = do+  res <- runMinio def $+    do+      hsr <- startHeal Nothing Nothing HealOpts { hoRecursive = True+                                                , hoDryRun = False+                                                }+      getHealStatus Nothing Nothing (hsrClientToken hsr)+  print res

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -20,8 +20,7 @@ {-# LANGUAGE OverloadedStrings #-} import           Network.Minio -import           Data.Conduit             (($$))-import           Data.Conduit.Combinators (sinkList)+import           Conduit import           Prelude  -- | The following example uses minio's play server at@@ -39,7 +38,7 @@   -- Performs a recursive listing of incomplete uploads under bucket "test"   -- on a local minio server.   res <- runMinio minioPlayCI $-    listIncompleteUploads bucket Nothing True $$ sinkList+    runConduit $ listIncompleteUploads bucket Nothing True .| mapM_C (\v -> (liftIO $ print v))   print res    {-

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -20,8 +20,7 @@ {-# LANGUAGE OverloadedStrings #-} import           Network.Minio -import qualified Data.Conduit             as C-import qualified Data.Conduit.Combinators as CC+import           Conduit import           Prelude  @@ -40,9 +39,8 @@   -- Performs a recursive listing of all objects under bucket "test"   -- on play.minio.io.   res <- runMinio minioPlayCI $-    listObjects bucket Nothing True C.$$ CC.sinkList+    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. 

@@ -0,0 +1,39 @@+#!/usr/bin/env stack+-- stack --resolver lts-11.1 runghc --package minio-hs++--+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+++{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio++import           Prelude++-- | The following example uses minio's play server at+-- https://play.minio.io:9000.  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")+  print res

@@ -1,40 +0,0 @@-#!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs------- Minio Haskell SDK, (C) 2017 Minio, Inc.------ Licensed under the Apache License, Version 2.0 (the "License");--- you may not use this file except in compliance with the License.--- You may obtain a copy of the License at------     http://www.apache.org/licenses/LICENSE-2.0------ Unless required by applicable law or agreed to in writing, software--- distributed under the License is distributed on an "AS IS" BASIS,--- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.--- See the License for the specific language governing permissions and--- limitations under the License.------{-# LANGUAGE OverloadedStrings #-}-import           Network.Minio--import           Prelude---- | The following example uses minio's play server at--- https://play.minio.io:9000.  The endpoint and associated--- 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")-  print res

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -22,6 +22,8 @@  import qualified Data.Conduit.Combinators as CC +import           Prelude+ -- | The following example uses minio's play server at -- https://play.minio.io:9000.  The endpoint and associated -- credentials are provided via the libary constant,@@ -43,7 +45,6 @@   case res1 of     Left e   -> putStrLn $ "putObject failed." ++ show e     Right () -> putStrLn "putObject succeeded."-    -- Eg 2. Upload a file using fPutObject with default options.   res2 <- runMinio minioPlayCI $

@@ -0,0 +1,38 @@+#!/usr/bin/env stack+-- stack --resolver lts-11.1 runghc --package minio-hs++--+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+++{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio++import           Prelude++-- | The following example uses minio's play server at+-- https://play.minio.io:9000.  The endpoint and associated+-- credentials are provided via the libary constant,+--+-- > minioPlayCI :: ConnectInfo+--++main :: IO ()+main = do+  let+      bucket = "my-bucket"+  res <- runMinio minioPlayCI $ removeBucket bucket+  print res

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.

@@ -1,8 +1,8 @@ #!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs+-- stack --resolver lts-11.1 runghc --package minio-hs  ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.

@@ -1,38 +0,0 @@-#!/usr/bin/env stack--- stack --resolver lts-9.1 runghc --package minio-hs------- Minio Haskell SDK, (C) 2017 Minio, Inc.------ Licensed under the Apache License, Version 2.0 (the "License");--- you may not use this file except in compliance with the License.--- You may obtain a copy of the License at------     http://www.apache.org/licenses/LICENSE-2.0------ Unless required by applicable law or agreed to in writing, software--- distributed under the License is distributed on an "AS IS" BASIS,--- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.--- See the License for the specific language governing permissions and--- limitations under the License.------{-# LANGUAGE OverloadedStrings #-}-import           Network.Minio--import           Prelude---- | The following example uses minio's play server at--- https://play.minio.io:9000.  The endpoint and associated--- credentials are provided via the libary constant,------ > minioPlayCI :: ConnectInfo-----main :: IO ()-main = do-  let-      bucket = "my-bucket"-  res <- runMinio minioPlayCI $ removeBucket bucket-  print res

@@ -0,0 +1,30 @@+#!/usr/bin/env stack+-- stack --resolver lts-11.1 runghc --package minio-hs++--+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio+import           Network.Minio.AdminAPI++import           Prelude++main :: IO ()+main = do+  res <- runMinio def $+    getServerInfo+  print res

@@ -0,0 +1,30 @@+#!/usr/bin/env stack+-- stack --resolver lts-11.1 runghc --package minio-hs++--+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio+import           Network.Minio.AdminAPI++import           Prelude++main :: IO ()+main = do+  res <- runMinio def $+    serviceSendAction ServiceActionRestart+  print res

@@ -0,0 +1,30 @@+#!/usr/bin/env stack+-- stack --resolver lts-11.1 runghc --package minio-hs++--+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio+import           Network.Minio.AdminAPI++import           Prelude++main :: IO ()+main = do+  res <- runMinio def $+    serviceSendAction ServiceActionStop+  print res

@@ -0,0 +1,30 @@+#!/usr/bin/env stack+-- stack --resolver lts-11.1 runghc --package minio-hs++--+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio+import           Network.Minio.AdminAPI++import           Prelude++main :: IO ()+main = do+  res <- runMinio def $+    serviceStatus+  print res

@@ -0,0 +1,32 @@+#!/usr/bin/env stack+-- stack --resolver lts-11.1 runghc --package minio-hs++--+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++{-# LANGUAGE OverloadedStrings #-}+import           Network.Minio+import           Network.Minio.AdminAPI++import           Prelude++main :: IO ()+main = do+  res <- runMinio def $+    do+      let config = "{\"version\":\"25\",\"credential\":{\"accessKey\":\"minio\",\"secretKey\":\"minio123\"},\"region\":\"\",\"browser\":\"on\",\"worm\":\"off\",\"domain\":\"\",\"storageclass\":{\"standard\":\"\",\"rrs\":\"\"},\"cache\":{\"drives\":[],\"expiry\":90,\"exclude\":[]},\"notify\":{\"amqp\":{\"2\":{\"enable\":false,\"url\":\"amqp://guest:guest@localhost:5672/\",\"exchange\":\"minio\",\"routingKey\":\"minio\",\"exchangeType\":\"direct\",\"deliveryMode\":0,\"mandatory\":false,\"immediate\":false,\"durable\":false,\"internal\":false,\"noWait\":false,\"autoDeleted\":false}},\"elasticsearch\":{\"1\":{\"enable\":false,\"format\":\"namespace\",\"url\":\"http://localhost:9200\",\"index\":\"minio_events\"}},\"kafka\":{\"1\":{\"enable\":false,\"brokers\":null,\"topic\":\"\"}},\"mqtt\":{\"1\":{\"enable\":false,\"broker\":\"\",\"topic\":\"\",\"qos\":0,\"clientId\":\"\",\"username\":\"\",\"password\":\"\",\"reconnectInterval\":0,\"keepAliveInterval\":0}},\"mysql\":{\"1\":{\"enable\":false,\"format\":\"namespace\",\"dsnString\":\"\",\"table\":\"\",\"host\":\"\",\"port\":\"\",\"user\":\"\",\"password\":\"\",\"database\":\"\"}},\"nats\":{\"1\":{\"enable\":false,\"address\":\"\",\"subject\":\"\",\"username\":\"\",\"password\":\"\",\"token\":\"\",\"secure\":false,\"pingInterval\":0,\"streaming\":{\"enable\":false,\"clusterID\":\"\",\"clientID\":\"\",\"async\":false,\"maxPubAcksInflight\":0}}},\"postgresql\":{\"1\":{\"enable\":false,\"format\":\"namespace\",\"connectionString\":\"\",\"table\":\"\",\"host\":\"\",\"port\":\"\",\"user\":\"\",\"password\":\"\",\"database\":\"\"}},\"redis\":{\"test1\":{\"enable\":true,\"format\":\"namespace\",\"address\":\"127.0.0.1:6379\",\"password\":\"\",\"key\":\"bucketevents_ns\"},\"test2\":{\"enable\":true,\"format\":\"access\",\"address\":\"127.0.0.1:6379\",\"password\":\"\",\"key\":\"bucketevents_log\"}},\"webhook\":{\"1\":{\"enable\":true,\"endpoint\":\"http://localhost:3000\"},\"2\":{\"enable\":true,\"endpoint\":\"http://localhost:3001\"}}}}"+      setConfig config+  print res

@@ -1,5 +1,5 @@ name:                minio-hs-version:             1.0.1+version:             1.1.0 synopsis:            A Minio Haskell Library for Amazon S3 compatible cloud                      storage. description:         The Minio Haskell client library provides simple APIs to@@ -27,9 +27,11 @@   hs-source-dirs:      src   ghc-options:         -Wall   exposed-modules:     Network.Minio+                     , Network.Minio.AdminAPI                      , Network.Minio.S3API   other-modules:       Lib.Prelude                      , Network.Minio.API+                     , Network.Minio.APICommon                      , Network.Minio.Data                      , Network.Minio.Data.ByteString                      , Network.Minio.Data.Crypto@@ -43,6 +45,7 @@                      , Network.Minio.Utils                      , Network.Minio.XmlGenerator                      , Network.Minio.XmlParser+                     , Network.Minio.JsonParser   build-depends:       base >= 4.7 && < 5                      , protolude >= 0.2 && < 0.3                      , aeson >= 1.2@@ -54,11 +57,12 @@                      , containers >= 0.5                      , cryptonite >= 0.25                      , cryptonite-conduit >= 0.2-                     , data-default >= 0.7+                     , directory                      , filepath >= 1.4                      , http-client >= 0.5                      , http-conduit >= 2.3                      , http-types >= 0.12+                     , ini                      , memory >= 0.14                      , resourcet >= 1.2                      , text >= 1.2@@ -103,7 +107,9 @@                      , TypeFamilies   other-modules:       Lib.Prelude                      , Network.Minio+                     , Network.Minio.AdminAPI                      , Network.Minio.API+                     , Network.Minio.APICommon                      , Network.Minio.CopyObject                      , Network.Minio.Data                      , Network.Minio.Data.ByteString@@ -115,6 +121,7 @@                      , Network.Minio.PutObject                      , Network.Minio.S3API                      , Network.Minio.Sign.V4+                     , Network.Minio.TestHelpers                      , Network.Minio.Utils                      , Network.Minio.Utils.Test                      , Network.Minio.API.Test@@ -122,6 +129,8 @@                      , Network.Minio.XmlGenerator.Test                      , Network.Minio.XmlParser                      , Network.Minio.XmlParser.Test+                     , Network.Minio.JsonParser+                     , Network.Minio.JsonParser.Test   build-depends:       base                      , minio-hs                      , protolude >= 0.1.6@@ -134,12 +143,12 @@                      , containers                      , cryptonite                      , cryptonite-conduit-                     , data-default                      , directory                      , filepath                      , http-client                      , http-conduit                      , http-types+                     , ini                      , memory                      , QuickCheck                      , resourcet@@ -173,11 +182,12 @@                      , containers                      , cryptonite                      , cryptonite-conduit-                     , data-default+                     , filepath                      , directory                      , http-client                      , http-conduit                      , http-types+                     , ini                      , memory                      , QuickCheck                      , resourcet@@ -207,7 +217,9 @@                      , TypeFamilies   other-modules:       Lib.Prelude                      , Network.Minio+                     , Network.Minio.AdminAPI                      , Network.Minio.API+                     , Network.Minio.APICommon                      , Network.Minio.Data                      , Network.Minio.Data.ByteString                      , Network.Minio.Data.Crypto@@ -219,6 +231,7 @@                      , Network.Minio.PutObject                      , Network.Minio.S3API                      , Network.Minio.Sign.V4+                     , Network.Minio.TestHelpers                      , Network.Minio.Utils                      , Network.Minio.Utils.Test                      , Network.Minio.API.Test@@ -226,7 +239,8 @@                      , Network.Minio.XmlGenerator.Test                      , Network.Minio.XmlParser                      , Network.Minio.XmlParser.Test-+                     , Network.Minio.JsonParser+                     , Network.Minio.JsonParser.Test  source-repository head   type:     git

@@ -18,18 +18,28 @@  module Network.Minio   (+  -- * Credentials+    Credentials (..)+  , fromAWSConfigFile+  , fromAWSEnv+  , fromMinioEnv    -- * Connecting to object storage   ----------------------------------    ConnectInfo(..)-  , awsCI+  , ConnectInfo+  , setRegion+  , setCreds+  , setCredsFrom+  , MinioConn+  , mkMinioConn    -- ** Connection helpers   -------------------------  , awsWithRegionCI   , minioPlayCI-  , minioCI+  , awsCI+  , gcsCI +   -- * Minio Monad   ----------------   -- | The Minio monad provides connection-reuse, bucket-location@@ -38,9 +48,10 @@   -- this Monad.    , Minio+  , runMinioWith   , runMinio-  , def +   -- * Bucket Operations   ---------------------- @@ -75,12 +86,16 @@    -- ** Bucket Notifications   , Notification(..)+  , defaultNotification   , NotificationConfig(..)   , Arn   , Event(..)   , Filter(..)+  , defaultFilter   , FilterKey(..)+  , defaultFilterKey   , FilterRules(..)+  , defaultFilterRules   , FilterRule(..)   , getBucketNotification   , putBucketNotification@@ -98,6 +113,7 @@   , putObject   -- | Input data type represents PutObject options.   , PutObjectOptions+  , defaultPutObjectOptions   , pooContentType   , pooContentEncoding   , pooContentDisposition@@ -110,6 +126,7 @@   , getObject   -- | Input data type represents GetObject options.   , GetObjectOptions+  , defaultGetObjectOptions   , gooRange   , gooIfMatch   , gooIfNoneMatch@@ -119,6 +136,7 @@   -- ** Server-side copying   , copyObject   , SourceInfo+  , defaultSourceInfo   , srcBucket   , srcObject   , srcRange@@ -127,6 +145,7 @@   , srcIfModifiedSince   , srcIfUnmodifiedSince   , DestinationInfo+  , defaultDestinationInfo   , dstBucket   , dstObject @@ -177,7 +196,6 @@ import qualified Data.Conduit             as C import qualified Data.Conduit.Binary      as CB import qualified Data.Conduit.Combinators as CC-import           Data.Default             (def)  import           Lib.Prelude 

@@ -1,5 +1,5 @@ ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -16,7 +16,7 @@  module Network.Minio.API   ( connect-  , RequestInfo(..)+  , S3ReqInfo(..)   , runMinio   , executeRequest   , mkStreamRequest@@ -31,10 +31,9 @@ import qualified Data.ByteString           as B import qualified Data.Char                 as C import qualified Data.Conduit              as C-import           Data.Conduit.Binary       (sourceHandleRange)-import           Data.Default              (def) import qualified Data.Map                  as Map import qualified Data.Text                 as T+import qualified Data.Time.Clock           as Time  import           Network.HTTP.Conduit      (Response) import qualified Network.HTTP.Conduit      as NC@@ -43,36 +42,17 @@  import           Lib.Prelude +import           Network.Minio.APICommon import           Network.Minio.Data-import           Network.Minio.Data.Crypto import           Network.Minio.Errors import           Network.Minio.Sign.V4 import           Network.Minio.Utils import           Network.Minio.XmlParser -sha256Header :: ByteString -> HT.Header-sha256Header = ("x-amz-content-sha256", )--getPayloadSHA256Hash :: (MonadIO m) => Payload -> m ByteString-getPayloadSHA256Hash (PayloadBS bs) = return $ hashSHA256 bs-getPayloadSHA256Hash (PayloadH h off size) = hashSHA256FromSource $-  sourceHandleRange h-    (return . fromIntegral $ off)-    (return . fromIntegral $ size)--getRequestBody :: Payload -> NC.RequestBody-getRequestBody (PayloadBS bs) = NC.RequestBodyBS bs-getRequestBody (PayloadH h off size) =-  NC.requestBodySource (fromIntegral size) $-    sourceHandleRange h-      (return . fromIntegral $ off)-      (return . fromIntegral $ size)-- -- | Fetch bucket location (region) getLocation :: Bucket -> Minio Region getLocation bucket = do-  resp <- executeRequest $ def {+  resp <- executeRequest $ defaultS3ReqInfo {       riBucket = Just bucket     , riQueryParams = [("location", Nothing)]     , riNeedsLocation = False@@ -82,7 +62,7 @@  -- | Looks for region in RegionMap and updates it using getLocation if -- absent.-discoverRegion :: RequestInfo -> Minio (Maybe Region)+discoverRegion :: S3ReqInfo -> Minio (Maybe Region) discoverRegion ri = runMaybeT $ do   bucket <- MaybeT $ return $ riBucket ri   regionMay <- lift $ lookupRegionCache bucket@@ -93,7 +73,7 @@         ) return regionMay  -buildRequest :: RequestInfo -> Minio NC.Request+buildRequest :: S3ReqInfo -> Minio NC.Request buildRequest ri = do   maybe (return ()) checkBucketNameValidity $ riBucket ri   maybe (return ()) checkObjectNameValidity $ riObject ri@@ -128,6 +108,8 @@                    -- otherwise compute sha256                    | otherwise -> getPayloadSHA256Hash (riPayload ri) +  timeStamp <- liftIO Time.getCurrentTime+   let hostHeader = (hHost, getHostAddr ci)       newRi = ri { riPayloadHash = Just sha256Hash                  , riHeaders = hostHeader@@ -136,28 +118,36 @@                  , riRegion = region                  }       newCi = ci { connectHost = regionHost }--  signHeaders <- liftIO $ signV4 newCi newRi Nothing+      signReq = toRequest newCi newRi+      sp = SignParams (connectAccessKey ci) (connectSecretKey ci)+           timeStamp (riRegion newRi) Nothing (riPayloadHash newRi)+  let signHeaders = signV4 sp signReq -  return NC.defaultRequest {-      NC.method = riMethod newRi-    , NC.secure = connectIsSecure newCi-    , NC.host = encodeUtf8 $ connectHost newCi-    , NC.port = connectPort newCi-    , NC.path = getPathFromRI newRi-    , NC.queryString = HT.renderQuery False $ riQueryParams newRi-    , NC.requestHeaders = riHeaders newRi ++ mkHeaderFromPairs signHeaders-    , NC.requestBody = getRequestBody (riPayload newRi)-    }+  -- Update signReq with Authorization header containing v4 signature+  return signReq {+      NC.requestHeaders = riHeaders newRi ++ mkHeaderFromPairs signHeaders+      }+  where+    toRequest :: ConnectInfo -> S3ReqInfo -> NC.Request+    toRequest ci s3Req = NC.defaultRequest {+          NC.method = riMethod s3Req+        , NC.secure = connectIsSecure ci+        , NC.host = encodeUtf8 $ connectHost ci+        , NC.port = connectPort ci+        , NC.path = getS3Path (riBucket s3Req) (riObject s3Req)+        , NC.requestHeaders = riHeaders s3Req+        , NC.queryString = HT.renderQuery False $ riQueryParams s3Req+        , NC.requestBody = getRequestBody (riPayload s3Req)+        } -executeRequest :: RequestInfo -> Minio (Response LByteString)+executeRequest :: S3ReqInfo -> Minio (Response LByteString) executeRequest ri = do   req <- buildRequest ri   mgr <- asks mcConnManager   httpLbs req mgr  -mkStreamRequest :: RequestInfo+mkStreamRequest :: S3ReqInfo                 -> Minio (Response (C.ConduitM () ByteString Minio ())) mkStreamRequest ri = do   req <- buildRequest ri

@@ -0,0 +1,44 @@+--+-- Minio Haskell SDK, (C) 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.APICommon where++import           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++sha256Header :: ByteString -> HT.Header+sha256Header = ("x-amz-content-sha256", )++getPayloadSHA256Hash :: (MonadIO m) => Payload -> m ByteString+getPayloadSHA256Hash (PayloadBS bs) = return $ hashSHA256 bs+getPayloadSHA256Hash (PayloadH h off size) = hashSHA256FromSource $+  sourceHandleRange h+    (return . fromIntegral $ off)+    (return . fromIntegral $ size)++getRequestBody :: Payload -> NC.RequestBody+getRequestBody (PayloadBS bs) = NC.RequestBodyBS bs+getRequestBody (PayloadH h off size) =+  NC.requestBodySource (fromIntegral size) $+    sourceHandleRange h+      (return . fromIntegral $ off)+      (return . fromIntegral $ size)

@@ -0,0 +1,559 @@+--+-- Minio Haskell SDK, (C) 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.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++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)++instance FromJSON DriveInfo where+    parseJSON = withObject "DriveInfo" $ \v -> DriveInfo+        <$> v .: "uuid"+        <*> v .: "endpoint"+        <*> v .: "state"++data StorageClass = StorageClass+                    { scParity :: Int+                    , scData   :: Int+                    } deriving (Eq, Show)++data ErasureInfo = ErasureInfo+                   { 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++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)++data ConnStats = ConnStats+    { csTransferred :: Int64+    , csReceived    :: Int64+    } deriving (Eq, Show)++instance FromJSON ConnStats where+    parseJSON = withObject "ConnStats" $ \v -> ConnStats+        <$> v .: "transferred"+        <*> v .: "received"++data ServerProps = ServerProps+    { spUptime   :: NominalDiffTime+    , spVersion  :: Text+    , spCommitId :: Text+    , spRegion   :: Text+    , spSqsArns  :: [Text]+    } deriving (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++data StorageInfo = StorageInfo+    { siUsed    :: Int64+    , siBackend :: Backend+    } deriving (Eq, Show)++instance FromJSON StorageInfo where+    parseJSON = withObject "StorageInfo" $ \v -> StorageInfo+        <$> v .: "Used"+        <*> v .: "Backend"++data CountNAvgTime = CountNAvgTime+    {  caCount       :: Int64+    ,  caAvgDuration :: Text+    } deriving (Eq, Show)++instance FromJSON CountNAvgTime where+    parseJSON = withObject "CountNAvgTime" $ \v -> CountNAvgTime+        <$> v .: "count"+        <*> v .: "avgDuration"++data HttpStats = HttpStats+    { hsTotalHeads     :: CountNAvgTime+    , hsSuccessHeads   :: CountNAvgTime+    , hsTotalGets      :: CountNAvgTime+    , hsSuccessGets    :: CountNAvgTime+    , hsTotalPuts      :: CountNAvgTime+    , hsSuccessPuts    :: CountNAvgTime+    , hsTotalPosts     :: CountNAvgTime+    , hsSuccessPosts   :: CountNAvgTime+    , hsTotalDeletes   :: CountNAvgTime+    , hsSuccessDeletes :: CountNAvgTime+    } deriving (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"++data SIData = SIData+    { 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"++data ServerInfo = ServerInfo+    { siError :: Text+    , siAddr  :: Text+    , siData  :: SIData+    } deriving (Eq, Show)++instance FromJSON ServerInfo where+    parseJSON = withObject "ServerInfo" $ \v -> ServerInfo+        <$> v .: "error"+        <*> v .: "addr"+        <*> v .: "data"++data ServerVersion = ServerVersion+  { svVersion  :: Text+  , svCommitId :: Text+  } deriving (Eq, Show)++instance FromJSON ServerVersion where+    parseJSON = withObject "ServerVersion" $ \v -> ServerVersion+      <$> v .: "version"+      <*> v .: "commitID"++data ServiceStatus = ServiceStatus+  { 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++data ServiceAction = ServiceActionRestart+                   | ServiceActionStop+                   deriving (Eq, Show)++instance ToJSON ServiceAction where+    toJSON a = object [ "action" .= serviceActionToText a ]++serviceActionToText :: ServiceAction -> Text+serviceActionToText a = case a of+  ServiceActionRestart -> "restart"+  ServiceActionStop    -> "stop"++adminPath :: ByteString+adminPath = "/minio/admin"++data HealStartResp = HealStartResp+  { hsrClientToken :: Text+  , hsrClientAddr  :: Text+  , hsrStartTime   :: UTCTime+  } deriving (Eq, Show)++instance FromJSON HealStartResp where+    parseJSON = withObject "HealStartResp" $ \v -> HealStartResp+        <$> v .: "clientToken"+        <*> v .: "clientAddress"+        <*> v .: "startTime"++data HealOpts = HealOpts+  { hoRecursive :: Bool+  , hoDryRun    :: Bool+  } deriving (Eq, Show)++instance ToJSON HealOpts where+  toJSON (HealOpts r d) =+    object ["recursive" .= r, "dryRun" .= d]+  toEncoding (HealOpts r d) =+    pairs ("recursive" .= r <> "dryRun" .= d)++instance FromJSON HealOpts where+    parseJSON = withObject "HealOpts" $ \v -> HealOpts+      <$> v .: "recursive"+      <*> v .: "dryRun"++data HealItemType = HealItemMetadata+                  | HealItemBucket+                  | HealItemBucketMetadata+                  | HealItemObject+                  deriving (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)++data NodeSummary = NodeSummary+  { nsName       :: Text+  , nsErrSet     :: Bool+  , nsErrMessage :: Text+  } deriving (Eq, Show)++instance FromJSON NodeSummary where+  parseJSON = withObject "NodeSummary" $ \v -> NodeSummary+    <$> v .: "name"+    <*> v .: "errSet"+    <*> v .: "errMsg"++data SetConfigResult = SetConfigResult+  { scrStatus      :: Bool+  , scrNodeSummary :: [NodeSummary]+  } deriving (Eq, Show)++instance FromJSON SetConfigResult where+  parseJSON = withObject "SetConfigResult" $ \v -> SetConfigResult+    <$> v .: "status"+    <*> v .: "nodeResults"++data HealResultItem = HealResultItem+  { hriResultIdx    :: Int+  , hriType         :: HealItemType+  , hriBucket       :: Bucket+  , hriObject       :: Object+  , hriDetail       :: Text+  , hriParityBlocks :: Maybe Int+  , hriDataBlocks   :: Maybe Int+  , hriDiskCount    :: Int+  , hriSetCount     :: Int+  , hriObjectSize   :: Int+  , hriBefore       :: [DriveInfo]+  , hriAfter        :: [DriveInfo]+  } deriving (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")++data HealStatus = HealStatus+  { 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"++healPath :: Maybe Bucket -> Maybe Text -> ByteString+healPath bucket prefix = do+  if (isJust bucket)+    then encodeUtf8 $ "v1/heal/" <> fromMaybe "" bucket <> "/"+         <> fromMaybe "" prefix+    else encodeUtf8 $ "v1/heal/"++-- | Get server version and uptime.+serviceStatus :: Minio ServiceStatus+serviceStatus = do+    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodGet+                                            , ariPayload = PayloadBS B.empty+                                            , ariPayloadHash = Nothing+                                            , ariPath = "v1/service"+                                            , ariHeaders = []+                                            , ariQueryParams = []+                                            }++    let rspBS = NC.responseBody rsp+    case eitherDecode rspBS of+        Right ss -> return ss+        Left err -> throwIO $ MErrVJsonParse $ T.pack err++-- | Send service restart or stop action to Minio server.+serviceSendAction :: ServiceAction -> Minio ()+serviceSendAction action = do+    let payload = PayloadBS $ LBS.toStrict $ A.encode action+    void $ executeAdminRequest AdminReqInfo { ariMethod = HT.methodPost+                                            , ariPayload = payload+                                            , ariPayloadHash = Nothing+                                            , ariPath = "v1/service"+                                            , ariHeaders = []+                                            , ariQueryParams = []+                                            }++-- | Get the current config file from server.+getConfig :: Minio ByteString+getConfig = do+    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodGet+                                            , ariPayload = PayloadBS B.empty+                                            , ariPayloadHash = Nothing+                                            , ariPath = "v1/config"+                                            , ariHeaders = []+                                            , ariQueryParams = []+                                            }+    return $ LBS.toStrict $ NC.responseBody rsp++-- | Set a new config to the server.+setConfig :: ByteString -> Minio SetConfigResult+setConfig config = do+    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodPut+                                            , ariPayload = PayloadBS config+                                            , ariPayloadHash = Nothing+                                            , ariPath = "v1/config"+                                            , ariHeaders = []+                                            , ariQueryParams = []+                                            }++    let rspBS = NC.responseBody rsp+    case eitherDecode rspBS of+        Right scr -> return scr+        Left err  -> throwIO $ MErrVJsonParse $ T.pack err++-- | Get the progress of currently running heal task, this API should be+-- invoked right after `startHeal`. `token` is obtained after `startHeal`+-- which should be used to get the heal status.+getHealStatus :: Maybe Bucket -> Maybe Text -> Text -> Minio HealStatus+getHealStatus bucket prefix token = do+    when (isNothing bucket && isJust prefix) $ throwIO MErrVInvalidHealPath+    let qparams = HT.queryTextToQuery [("clientToken", Just token)]+    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodPost+                                            , ariPayload = PayloadBS B.empty+                                            , ariPayloadHash = Nothing+                                            , ariPath = healPath bucket prefix+                                            , ariHeaders = []+                                            , ariQueryParams = qparams+                                            }+    let rspBS = NC.responseBody rsp+    case eitherDecode rspBS of+        Right hs -> return hs+        Left err -> throwIO $ MErrVJsonParse $ T.pack err++doHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Bool -> Minio HealStartResp+doHeal bucket prefix opts forceStart = do+    when (isNothing bucket && isJust prefix) $ throwIO MErrVInvalidHealPath+    let payload = PayloadBS $ LBS.toStrict $ A.encode opts+    let qparams = bool [] (HT.queryTextToQuery [("forceStart", Just "true")])+                  forceStart++    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodPost+                                            , ariPayload = payload+                                            , ariPayloadHash = Nothing+                                            , ariPath = healPath bucket prefix+                                            , ariHeaders = []+                                            , ariQueryParams = qparams+                                            }++    let rspBS = NC.responseBody rsp+    case eitherDecode rspBS of+        Right hsr -> return hsr+        Left err  -> throwIO $ MErrVJsonParse $ T.pack err++-- | Start a heal sequence that scans data under given (possible empty)+-- `bucket` and `prefix`. The `recursive` bool turns on recursive+-- traversal under the given path. `dryRun` does not mutate on-disk data,+-- but performs data validation. Two heal sequences on overlapping paths+-- may not be initiated. The progress of a heal should be followed using+-- the `HealStatus` API. The server accumulates results of the heal+-- traversal and waits for the client to receive and acknowledge+-- them using the status API+startHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Minio HealStartResp+startHeal bucket prefix opts = doHeal bucket prefix opts False++-- | Similar to start a heal sequence, but force start a new heal sequence+-- even if an active heal is under progress.+forceStartHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Minio HealStartResp+forceStartHeal bucket prefix opts = doHeal bucket prefix opts True++-- | Fetches information for all cluster nodes, such as server+-- properties, storage information, network statistics, etc.+getServerInfo :: Minio [ServerInfo]+getServerInfo = do+    rsp <- executeAdminRequest AdminReqInfo { ariMethod = HT.methodGet+                                            , ariPayload = PayloadBS B.empty+                                            , ariPayloadHash = Nothing+                                            , ariPath = "v1/info"+                                            , ariHeaders = []+                                            , ariQueryParams = []+                                            }+    let rspBS = NC.responseBody rsp+    case eitherDecode rspBS of+        Right si -> return si+        Left err -> throwIO $ MErrVJsonParse $ T.pack err++executeAdminRequest :: AdminReqInfo -> Minio (Response LByteString)+executeAdminRequest ari = do+    req <- buildAdminRequest ari+    mgr <- asks mcConnManager+    httpLbs req mgr++buildAdminRequest :: AdminReqInfo -> Minio NC.Request+buildAdminRequest areq = do+    ci <- asks mcConnInfo+    sha256Hash <- if | connectIsSecure ci ->+                       -- if secure connection+                       return "UNSIGNED-PAYLOAD"++                       -- otherwise compute sha256+                     | otherwise -> getPayloadSHA256Hash (ariPayload areq)++    timeStamp <- liftIO getCurrentTime++    let hostHeader = (hHost, getHostAddr ci)+        newAreq = areq { ariPayloadHash = Just sha256Hash+                       , 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+        }+  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)+        }

@@ -16,7 +16,6 @@  module Network.Minio.CopyObject where -import           Data.Default         (def) import qualified Data.List            as List  import           Lib.Prelude@@ -81,7 +80,7 @@       partRanges = selectCopyRanges byteRange       partSources = map (\(x, (start, end)) -> (x, cps {srcRange = Just (start, end) }))                     partRanges-      dstInfo = def { dstBucket = b, dstObject = o}+      dstInfo = defaultDestinationInfo { dstBucket = b, dstObject = o}    copiedParts <- limitedMapConcurrently 10                  (\(pn, cps') -> do

@@ -1,5 +1,5 @@ ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -25,9 +25,11 @@ import           Control.Monad.Trans.Resource import qualified Data.ByteString              as B import           Data.CaseInsensitive         (mk)-import           Data.Default                 (Default (..))+import qualified Data.Ini                     as Ini import qualified Data.Map                     as Map+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           Network.HTTP.Client          (defaultManagerSettings)@@ -36,6 +38,9 @@                                                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 @@ -91,85 +96,106 @@   , connectAutoDiscoverRegion :: Bool   } deriving (Eq, Show) --- | Connects to a Minio server located at @localhost:9000@ with access--- key /minio/ and secret key /minio123/. It is over __HTTP__ by--- default.-instance Default ConnectInfo where-  def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" True +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+                        }++data Credentials = Credentials { cAccessKey :: Text+                               , cSecretKey :: Text+                               } deriving (Eq, Show)++type Provider = IO (Maybe Credentials)++findFirst :: [Provider] -> Provider+findFirst [] = return Nothing+findFirst (f:fs) = do c <- f+                      maybe (findFirst fs) (return . Just) c++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++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)++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 :: [Provider] -> ConnectInfo -> IO ConnectInfo+setCredsFrom ps ci = do pMay <- findFirst ps+                        maybe+                          (throwIO MErrVMissingCredentials)+                          (return . (flip setCreds ci))+                          pMay++setCreds :: Credentials -> ConnectInfo -> ConnectInfo+setCreds (Credentials accessKey secretKey) connInfo =+    connInfo { connectAccessKey = accessKey+             , connectSecretKey = secretKey+             }++setRegion :: Region -> ConnectInfo -> ConnectInfo+setRegion r connInfo = connInfo { connectRegion = r+                                , connectAutoDiscoverRegion = False+                                }+ getHostAddr :: ConnectInfo -> ByteString-getHostAddr ci = toS $ T.concat [ connectHost ci, ":"-                                , Lib.Prelude.show $ connectPort ci-                                ]+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 GCS ConnectInfo. Works only for "Simple Migration"+-- use-case with interoperability mode enabled on GCP console. For+-- more information - https://cloud.google.com/storage/docs/migrating+-- Credentials should be supplied before use.+gcsCI :: ConnectInfo+gcsCI = setRegion "us"+        "https://storage.googleapis.com"++ -- | Default AWS ConnectInfo. Connects to "us-east-1". Credentials--- should be supplied before use, for e.g.:------ > awsCI {--- >   connectAccessKey = "my-access-key"--- > , connectSecretKey = "my-secret-key"--- > }+-- should be supplied before use. awsCI :: ConnectInfo-awsCI = def {-    connectHost = "s3.amazonaws.com"-  , connectPort = 443-  , connectAccessKey = ""-  , connectSecretKey = ""-  , connectIsSecure = True-  }---- | AWS ConnectInfo with a specified region. It can optionally--- disable the automatic discovery of a bucket's region via the--- Boolean argument.------ > awsWithRegionCI "us-west-1" False {--- >   connectAccessKey = "my-access-key"--- > , connectSecretKey = "my-secret-key"--- > }------ This restricts all operations to the "us-west-1" region and does--- not perform any bucket location requests.-awsWithRegionCI :: Region -> Bool -> ConnectInfo-awsWithRegionCI region autoDiscoverRegion =-  let host = maybe "s3.amazonaws.com" identity $-             Map.lookup region awsRegionMap-  in awsCI {-      connectHost = host-    , connectRegion = region-    , connectAutoDiscoverRegion = autoDiscoverRegion-    }+awsCI = "https://s3.amazonaws.com"   -- | <https://play.minio.io:9000 Minio Play Server> -- ConnectInfo. Credentials are already filled in. minioPlayCI :: ConnectInfo-minioPlayCI = def {-    connectHost = "play.minio.io"-  , connectPort = 9000-  , connectAccessKey = "Q3AM3UQ867SPQQA43P2F"-  , connectSecretKey = "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"-  , connectIsSecure = True-  , connectAutoDiscoverRegion = False-  }---- | ConnectInfo for Minio server. Takes hostname, port and a Boolean--- to enable TLS.------ > minioCI "minio.example.com" 9000 True {--- >   connectAccessKey = "my-access-key"--- > , connectSecretKey = "my-secret-key"--- > }------ This connects to a Minio server at the given hostname and port over--- HTTPS.-minioCI :: Text -> Int -> Bool -> ConnectInfo-minioCI host port isSecure = def {-    connectHost = host-  , connectPort = port-  , connectRegion = "us-east-1"-  , connectIsSecure = isSecure-  , connectAutoDiscoverRegion = False-  }+minioPlayCI = let playCreds = Credentials "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG"+              in setCreds playCreds+                 $ setRegion "us-east-1"+                 "https://play.minio.io:9000"  -- | -- Represents a bucket in the object store@@ -184,27 +210,39 @@ -- TODO: This could be a Sum Type with all defined regions for AWS. type Region = Text --- | A type alias to represent an Entity-Tag returned by S3-compatible--- APIs.+-- | A type alias to represent an Entity-Tag returned by S3-compatible APIs. type ETag = Text  -- | -- Data type represents various options specified for PutObject call. -- To specify PutObject options use the 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   } deriving (Show, Eq)  -- Provide a default instance-instance Default PutObjectOptions where-    def = PutObjectOptions def def def def def def [] def+defaultPutObjectOptions :: PutObjectOptions+defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing  addXAmzMetaPrefix :: Text -> Text addXAmzMetaPrefix s = do@@ -323,29 +361,36 @@   , srcIfUnmodifiedSince :: Maybe UTCTime   } deriving (Show, Eq) -instance Default SourceInfo where-  def = SourceInfo "" "" def def def def def+defaultSourceInfo :: SourceInfo+defaultSourceInfo = SourceInfo "" "" Nothing Nothing Nothing Nothing Nothing  -- | Represents destination object in server-side copy object-data DestinationInfo = DestinationInfo {-  dstBucket   :: Text-  , dstObject :: Text-  } deriving (Show, Eq)+data DestinationInfo = DestinationInfo+                       { dstBucket :: Text+                       , dstObject :: Text+                       } deriving (Show, Eq) -instance Default DestinationInfo where-  def = DestinationInfo "" ""+defaultDestinationInfo :: DestinationInfo+defaultDestinationInfo = DestinationInfo "" ""  data GetObjectOptions = GetObjectOptions {-    -- | [ByteRangeFromTo 0 9] means first ten bytes of the source object.+    -- | 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   } deriving (Show, Eq) -instance Default GetObjectOptions where-  def = GetObjectOptions def def def def def+defaultGetObjectOptions :: GetObjectOptions+defaultGetObjectOptions = GetObjectOptions Nothing Nothing Nothing Nothing Nothing  gooToHeaders :: GetObjectOptions -> [HT.Header] gooToHeaders goo = rangeHdr ++ zip names values@@ -405,23 +450,24 @@   { fFilter :: FilterKey   } deriving (Show, Eq) -instance Default Filter where-  def = Filter def+defaultFilter :: Filter+defaultFilter = Filter defaultFilterKey  data FilterKey = FilterKey   { fkKey :: FilterRules   } deriving (Show, Eq) -instance Default FilterKey where-  def = FilterKey def+defaultFilterKey :: FilterKey+defaultFilterKey = FilterKey defaultFilterRules  data FilterRules = FilterRules   { frFilterRules :: [FilterRule]   } deriving (Show, Eq) -instance Default FilterRules where-  def = FilterRules []+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: --@@ -459,8 +505,8 @@   , nCloudFunctionConfigurations :: [NotificationConfig]   } deriving (Eq, Show) -instance Default Notification where-  def = Notification [] [] []+defaultNotification :: Notification+defaultNotification = Notification [] [] []  -- | Represents different kinds of payload that are used with S3 API -- requests.@@ -469,10 +515,19 @@                         Int64 -- offset                         Int64 -- size -instance Default Payload where-  def = PayloadBS ""+defaultPayload :: Payload+defaultPayload = PayloadBS "" -data RequestInfo = RequestInfo {+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@@ -484,15 +539,13 @@   , riNeedsLocation :: Bool   } -instance Default RequestInfo where-  def = RequestInfo HT.methodGet def def def def def Nothing def True+defaultS3ReqInfo :: S3ReqInfo+defaultS3ReqInfo = S3ReqInfo HT.methodGet Nothing Nothing+                   [] [] defaultPayload Nothing Nothing True -getPathFromRI :: RequestInfo -> ByteString-getPathFromRI ri =-  let-    b = riBucket ri-    o = riObject ri-    segments = map toS $ catMaybes $ b : bool [] [o] (isJust b)+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] @@ -526,6 +579,16 @@   , 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' connect :: ConnectInfo -> IO MinioConn@@ -533,14 +596,11 @@   let settings | connectIsSecure ci = NC.tlsManagerSettings                | otherwise = defaultManagerSettings   mgr <- NC.newManager settings-  rMapMVar <- M.newMVar Map.empty-  return $ MinioConn ci mgr rMapMVar+  mkMinioConn ci mgr --- | Run the Minio action and return the result or an error.-runMinio :: ConnectInfo -> Minio a -> IO (Either MinioErr a)-runMinio ci m = do-  conn <- liftIO $ connect ci-  runResourceT . flip runReaderT conn . unMinio $++runMinioWith :: MinioConn -> Minio a -> IO (Either MinioErr a)+runMinioWith conn m = runResourceT . flip runReaderT conn . unMinio $     fmap Right m `U.catches`     [ U.Handler handlerServiceErr     , U.Handler handlerHE@@ -553,8 +613,19 @@     handlerFE = return . Left . MErrIO     handlerValidation = return . Left . MErrValidation -s3Name :: Text -> Name-s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing+mkMinioConn :: ConnectInfo -> NC.Manager -> IO MinioConn+mkMinioConn ci mgr = do+    rMapMVar <- M.newMVar Map.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+  runMinioWith conn m++s3Name :: Text -> Text -> Name+s3Name ns s = Name s (Just ns) Nothing  -- | Format as per RFC 1123. formatRFC1123 :: UTCTime -> T.Text

@@ -1,5 +1,5 @@ ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -38,6 +38,9 @@            | MErrVInvalidBucketName Text            | MErrVInvalidObjectName Text            | MErrVInvalidUrlExpiry Int+           | MErrVJsonParse Text+           | MErrVInvalidHealPath+           | MErrVMissingCredentials   deriving (Show, Eq)  instance Exception MErrV

@@ -0,0 +1,42 @@+--+-- Minio Haskell SDK, (C) 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.JsonParser+  (+    parseErrResponseJSON+  ) where++import           Data.Aeson           (FromJSON, eitherDecode, parseJSON,+                                       withObject, (.:))+import qualified Data.Text            as T++import           Lib.Prelude++import           Network.Minio.Errors++data AdminErrJSON = AdminErrJSON { aeCode    :: Text+                                 , aeMessage :: Text+                                 } deriving (Eq, Show)+instance FromJSON AdminErrJSON where+  parseJSON = withObject "AdminErrJSON" $ \v -> AdminErrJSON+    <$> v .: "Code"+    <*> v .: "Message"++parseErrResponseJSON :: (MonadIO m) => LByteString -> m ServiceErr+parseErrResponseJSON jsondata =+  case eitherDecode jsondata of+    Right aErr -> return $ toServiceErr (aeCode aErr) (aeMessage aErr)+    Left err   -> throwIO $ MErrVJsonParse $ T.pack err

@@ -39,10 +39,10 @@ import           Data.Aeson                ((.=)) import qualified Data.Aeson                as Json import           Data.ByteString.Builder   (byteString, toLazyByteString)-import           Data.Default              (def) import qualified Data.Map.Strict           as Map 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) @@ -72,25 +72,32 @@    let     hostHeader = (hHost, getHostAddr ci)-    ri = def { riMethod = method-             , riBucket = bucket-             , riObject = object-             , riQueryParams = extraQuery-             , riHeaders = hostHeader : extraHeaders-             , riRegion = Just $ maybe (connectRegion ci) identity region-             }+    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 -  signPairs <- liftIO $ signV4 ci ri (Just expiry)+  let sp = SignParams (connectAccessKey ci) (connectSecretKey ci)+           ts region (Just expiry) Nothing -  let-    qpToAdd = (fmap . fmap) Just signPairs-    queryStr = HT.renderQueryBuilder True (riQueryParams ri ++ qpToAdd)-    scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci+      signPairs = signV4 sp req -  return $ toS $ toLazyByteString $-    scheme <> byteString (getHostAddr ci) <> byteString (getPathFromRI ri) <>-    queryStr+      qpToAdd = (fmap . fmap) Just signPairs+      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+ -- | Generate a URL with authentication signature to PUT (upload) an -- object. Any extra headers if passed, are signed, and so they are -- required when the URL is used to upload data. This could be used,@@ -258,8 +265,10 @@     ppWithCreds = p {       conditions = conditions p ++ extraConditions       }-    signData = signV4PostPolicy (showPostPolicy ppWithCreds)-               signTime ci+    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)

@@ -22,6 +22,7 @@   ) where  +import           Conduit                  (takeC) import qualified Data.ByteString.Lazy     as LBS import qualified Data.Conduit             as C import qualified Data.Conduit.Binary      as CB@@ -68,7 +69,7 @@     -- got file size, so check for single/multipart upload     Just size ->       if | size <= 64 * oneMiB -> do-             bs <- C.runConduit $ src C..| CB.sinkLbs+             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

@@ -92,7 +92,6 @@  import qualified Data.ByteString                   as BS import qualified Data.Conduit                      as C-import           Data.Default                      (def) import qualified Data.Text                         as T import qualified Network.HTTP.Conduit              as NC import qualified Network.HTTP.Types                as HT@@ -112,7 +111,7 @@ -- | Fetch all buckets from the service. getService :: Minio [BucketInfo] getService = do-  resp <- executeRequest $ def {+  resp <- executeRequest $ defaultS3ReqInfo {       riNeedsLocation = False     }   parseListBuckets $ NC.responseBody resp@@ -125,7 +124,7 @@   resp <- mkStreamRequest reqInfo   return (NC.responseHeaders resp, NC.responseBody resp)   where-    reqInfo = def { riBucket = Just bucket+    reqInfo = defaultS3ReqInfo { riBucket = Just bucket                   , riObject = Just object                   , riQueryParams = queryParams                   , riHeaders = headers@@ -133,11 +132,12 @@  -- | Creates a bucket via a PUT bucket call. putBucket :: Bucket -> Region -> Minio ()-putBucket bucket location = void $-  executeRequest $-    def { riMethod = HT.methodPut+putBucket bucket location = do+  ns <- asks getSvcNamespace+  void $ executeRequest $+    defaultS3ReqInfo { riMethod = HT.methodPut         , riBucket = Just bucket-        , riPayload = PayloadBS $ mkCreateBucketConfig location+        , riPayload = PayloadBS $ mkCreateBucketConfig ns location         , riNeedsLocation = False         } @@ -154,7 +154,7 @@    -- content-length header is automatically set by library.   resp <- executeRequest $-          def { riMethod = HT.methodPut+          defaultS3ReqInfo { riMethod = HT.methodPut               , riBucket = Just bucket               , riObject = Just object               , riHeaders = headers@@ -178,7 +178,7 @@    -- content-length header is automatically set by library.   resp <- executeRequest $-          def { riMethod = HT.methodPut+          defaultS3ReqInfo { riMethod = HT.methodPut               , riBucket = Just bucket               , riObject = Just object               , riHeaders = headers@@ -196,7 +196,7 @@ listObjectsV1' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int             -> Minio ListObjectsV1Result listObjectsV1' bucket prefix nextMarker delimiter maxKeys = do-  resp <- executeRequest $ def { riMethod = HT.methodGet+  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet                                , riBucket = Just bucket                                , riQueryParams = mkOptionalParams params                                }@@ -214,7 +214,7 @@ listObjects' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Int             -> Minio ListObjectsResult listObjects' bucket prefix nextToken delimiter maxKeys = do-  resp <- executeRequest $ def { riMethod = HT.methodGet+  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet                                , riBucket = Just bucket                                , riQueryParams = mkOptionalParams params                                }@@ -232,7 +232,7 @@ deleteBucket :: Bucket -> Minio () deleteBucket bucket = void $   executeRequest $-    def { riMethod = HT.methodDelete+    defaultS3ReqInfo { riMethod = HT.methodDelete         , riBucket = Just bucket         } @@ -240,7 +240,7 @@ deleteObject :: Bucket -> Object -> Minio () deleteObject bucket object = void $   executeRequest $-    def { riMethod = HT.methodDelete+    defaultS3ReqInfo { riMethod = HT.methodDelete         , riBucket = Just bucket         , riObject = Just object         }@@ -248,7 +248,7 @@ -- | Create a new multipart upload. newMultipartUpload :: Bucket -> Object -> [HT.Header] -> Minio UploadId newMultipartUpload bucket object headers = do-  resp <- executeRequest $ def { riMethod = HT.methodPost+  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodPost                                , riBucket = Just bucket                                , riObject = Just object                                , riQueryParams = [("uploads", Nothing)]@@ -261,7 +261,7 @@               -> Payload -> Minio PartTuple putObjectPart bucket object uploadId partNumber headers payload = do   resp <- executeRequest $-          def { riMethod = HT.methodPut+          defaultS3ReqInfo { riMethod = HT.methodPut               , riBucket = Just bucket               , riObject = Just object               , riQueryParams = mkOptionalParams params@@ -303,7 +303,7 @@                -> PartNumber -> [HT.Header] -> Minio (ETag, UTCTime) copyObjectPart dstInfo srcInfo uploadId partNumber headers = do   resp <- executeRequest $-          def { riMethod = HT.methodPut+          defaultS3ReqInfo { riMethod = HT.methodPut               , riBucket = Just $ dstBucket dstInfo               , riObject = Just $ dstObject dstInfo               , riQueryParams = mkOptionalParams params@@ -327,7 +327,7 @@   when (isJust $ srcRange srcInfo) $     throwIO MErrVCopyObjSingleNoRangeAccepted   resp <- executeRequest $-          def { riMethod = HT.methodPut+          defaultS3ReqInfo { riMethod = HT.methodPut               , riBucket = Just bucket               , riObject = Just object               , riHeaders = headers ++ srcInfoToHeaders srcInfo@@ -339,7 +339,7 @@                         -> Minio ETag completeMultipartUpload bucket object uploadId partTuple = do   resp <- executeRequest $-          def { riMethod = HT.methodPost+          defaultS3ReqInfo { riMethod = HT.methodPost               , riBucket = Just bucket               , riObject = Just object               , riQueryParams = mkOptionalParams params@@ -353,7 +353,7 @@ -- | Abort a multipart upload. abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio () abortMultipartUpload bucket object uploadId = void $-  executeRequest $ def { riMethod = HT.methodDelete+  executeRequest $ defaultS3ReqInfo { riMethod = HT.methodDelete                               , riBucket = Just bucket                               , riObject = Just object                               , riQueryParams = mkOptionalParams params@@ -365,7 +365,7 @@ listIncompleteUploads' :: Bucket -> Maybe Text -> Maybe Text -> Maybe Text                        -> Maybe Text -> Maybe Int -> Minio ListUploadsResult listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker maxKeys = do-  resp <- executeRequest $ def { riMethod = HT.methodGet+  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet                                , riBucket = Just bucket                                , riQueryParams = params                                }@@ -385,7 +385,7 @@ listIncompleteParts' :: Bucket -> Object -> UploadId -> Maybe Text                      -> Maybe Text -> Minio ListPartsResult listIncompleteParts' bucket object uploadId maxParts partNumMarker = do-  resp <- executeRequest $ def { riMethod = HT.methodGet+  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet                                , riBucket = Just bucket                                , riObject = Just object                                , riQueryParams = mkOptionalParams params@@ -402,7 +402,7 @@ -- | Get metadata of an object. headObject :: Bucket -> Object -> Minio ObjectInfo headObject bucket object = do-  resp <- executeRequest $ def { riMethod = HT.methodHead+  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodHead                                , riBucket = Just bucket                                , riObject = Just object                                }@@ -438,25 +438,26 @@     handleStatus404 e = throwIO e      headBucketEx = do-      resp <- executeRequest $ def { riMethod = HT.methodHead+      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 =-  void $ executeRequest $ def { riMethod = HT.methodPut+putBucketNotification bucket ncfg = do+  ns <- asks getSvcNamespace+  void $ executeRequest $ defaultS3ReqInfo { riMethod = HT.methodPut                               , riBucket = Just bucket                               , riQueryParams = [("notification", Nothing)]                               , riPayload = PayloadBS $-                                            mkPutNotificationRequest ncfg+                                            mkPutNotificationRequest ns ncfg                               }  -- | Retrieve the notification configuration on a bucket. getBucketNotification :: Bucket -> Minio Notification getBucketNotification bucket = do-  resp <- executeRequest $ def { riMethod = HT.methodGet+  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet                                , riBucket = Just bucket                                , riQueryParams = [("notification", Nothing)]                                }@@ -464,12 +465,12 @@  -- | Remove all notifications configured on a bucket. removeAllBucketNotification :: Bucket -> Minio ()-removeAllBucketNotification = flip putBucketNotification def+removeAllBucketNotification = flip putBucketNotification defaultNotification  -- | Fetch the policy if any on a bucket. getBucketPolicy :: Bucket -> Minio Text getBucketPolicy bucket = do-  resp <- executeRequest $ def { riMethod = HT.methodGet+  resp <- executeRequest $ defaultS3ReqInfo { riMethod = HT.methodGet                                , riBucket = Just bucket                                , riQueryParams = [("policy", Nothing)]                                }@@ -487,7 +488,7 @@ -- | Save a new policy on a bucket. putBucketPolicy :: Bucket -> Text -> Minio() putBucketPolicy bucket policy = do-  void $ executeRequest $ def { riMethod = HT.methodPut+  void $ executeRequest $ defaultS3ReqInfo { riMethod = HT.methodPut                               , riBucket = Just bucket                               , riQueryParams = [("policy", Nothing)]                               , riPayload = PayloadBS $ encodeUtf8 policy@@ -496,7 +497,7 @@ -- | Delete any policy set on a bucket. deleteBucketPolicy :: Bucket -> Minio() deleteBucketPolicy bucket = do-  void $ executeRequest $ def { riMethod = HT.methodDelete+  void $ executeRequest $ defaultS3ReqInfo { riMethod = HT.methodDelete                               , riBucket = Just bucket                               , riQueryParams = [("policy", Nothing)]                               }

@@ -17,7 +17,6 @@ module Network.Minio.Sign.V4   (     signV4-  , signV4AtTime   , signV4PostPolicy   , mkScope   , getHeadersToSign@@ -26,22 +25,24 @@   , mkSigningKey   , computeSignature   , SignV4Data(..)+  , SignParams(..)   , debugPrintSignV4Data   ) where -import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import           Data.CaseInsensitive (mk)-import qualified Data.CaseInsensitive as CI-import qualified Data.Set as Set-import qualified Data.Time as Time-import qualified Data.ByteString.Base64 as Base64-import qualified Data.Map.Strict as Map-import           Network.HTTP.Types (Header)-import qualified Network.HTTP.Types.Header as H+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.Map.Strict               as Map+import qualified Data.Set                      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.Header     as H  import           Lib.Prelude-import           Network.Minio.Data+ import           Network.Minio.Data.ByteString import           Network.Minio.Data.Crypto import           Network.Minio.Data.Time@@ -57,15 +58,24 @@                  ]  data SignV4Data = SignV4Data {-    sv4SignTime :: UTCTime-  , sv4Scope :: ByteString-  , sv4CanonicalRequest :: ByteString-  , sv4HeadersToSign :: [(ByteString, ByteString)]-  , sv4Output :: [(ByteString, ByteString)]-  , sv4StringToSign :: ByteString-  , sv4SigningKey :: ByteString-  } deriving (Show)+      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)+ debugPrintSignV4Data :: SignV4Data -> IO () debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do   B8.putStrLn "SignV4Data:"@@ -83,40 +93,33 @@       mapM_ (\x -> B.putStr $ B.concat [show x,  " "]) $ B.unpack b       B8.putStrLn "" --- | Given MinioClient and request details, including request method,+-- | Given SignParams and request details, including request method, -- request path, headers, query params and payload hash, generates an -- updated set of headers, including the x-amz-date header and the -- Authorization header, which includes the signature.-signV4 :: ConnectInfo -> RequestInfo -> Maybe Int-       -> IO [(ByteString, ByteString)]-signV4 !ci !ri !expiry = do-  timestamp <- Time.getCurrentTime-  let signData = signV4AtTime timestamp ci ri expiry-  -- debugPrintSignV4Data signData-  return $ sv4Output signData---- | Takes a timestamp, server params and request params and generates--- AWS Sign V4 data. For normal requests (i.e. without an expiry--- time), the output is the list of headers to add to authenticate the--- request. --+-- For normal requests (i.e. without an expiry time), the output is+-- the list of headers to add to authenticate the request.+-- -- If `expiry` is not Nothing, it is assumed that a presigned request -- is being created. The expiry is interpreted as an integer number of -- seconds. The output will be the list of query-parameters to add to -- the request.-signV4AtTime :: UTCTime -> ConnectInfo -> RequestInfo -> Maybe Int-             -> SignV4Data-signV4AtTime ts ci ri expiry =++signV4 :: SignParams -> NC.Request -> [(ByteString, ByteString)]+signV4 !sp !req =   let-    region = maybe (connectRegion ci) identity $ riRegion ri+    region = fromMaybe "" $ spRegion sp+    ts = spTimeStamp sp     scope = mkScope ts region-    accessKey = toS $ connectAccessKey ci-    secretKey = toS $ connectSecretKey ci+    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 = riHeaders ri ++-                      if isJust expiry+    computedHeaders = NC.requestHeaders req +++                      if isJust $ expiry                       then []                       else [(\(x, y) -> (mk x, y)) datePair]     headersToSign = getHeadersToSign computedHeaders@@ -130,13 +133,13 @@              , ("X-Amz-Expires", maybe "" show expiry)              , ("X-Amz-SignedHeaders", signedHeaderKeys)              ]-    finalQP = riQueryParams ri +++    finalQP = parseQuery (NC.queryString req)  ++               if isJust expiry               then (fmap . fmap) Just authQP               else []      -- 1. compute canonical request-    canonicalRequest = mkCanonicalRequest (ri {riQueryParams = finalQP})+    canonicalRequest = mkCanonicalRequest sp (NC.setQueryString finalQP req)                        headersToSign      -- 2. compute string to sign@@ -167,12 +170,10 @@              else [(\(x, y) -> (CI.foldedCase x, y)) authHeader,                    datePair] -  in-    SignV4Data ts scope canonicalRequest headersToSign output-    stringToSign signingKey+  in output  -mkScope :: UTCTime -> Region -> ByteString+mkScope :: UTCTime -> Text -> ByteString mkScope ts region = B.intercalate "/"   [ toS $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts   , toS region@@ -185,15 +186,15 @@   filter (flip Set.notMember ignoredHeaders . fst) $   map (\(x, y) -> (CI.foldedCase x, stripBS y)) h -mkCanonicalRequest :: RequestInfo -> [(ByteString, ByteString)]+mkCanonicalRequest :: SignParams -> NC.Request -> [(ByteString, ByteString)]                     -> ByteString-mkCanonicalRequest !ri !headersForSign =+mkCanonicalRequest !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)) $-      riQueryParams ri+      (parseQuery $ NC.queryString req)      sortedHeaders = sort headersForSign @@ -204,12 +205,12 @@    in     B.intercalate "\n"-    [ riMethod ri-    , uriEncode False $ getPathFromRI ri+    [ NC.method req+    , uriEncode False $ NC.path req     , canonicalQueryString     , canonicalHeaders     , signedHeaders-    , maybe "UNSIGNED-PAYLOAD" identity $ riPayloadHash ri+    , maybe "UNSIGNED-PAYLOAD" identity $ spPayloadHash sp     ]  mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString@@ -220,7 +221,7 @@                                              , hashSHA256 canonicalRequest                                              ] -mkSigningKey :: UTCTime -> Region -> ByteString -> ByteString+mkSigningKey :: UTCTime -> Text -> ByteString -> ByteString mkSigningKey ts region !secretKey = hmacSHA256RawBS "aws4_request"                                   . hmacSHA256RawBS "s3"                                   . hmacSHA256RawBS (toS region)@@ -233,13 +234,13 @@ -- | 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 -> UTCTime -> ConnectInfo+signV4PostPolicy :: ByteString -> SignParams                  -> Map.Map Text ByteString-signV4PostPolicy !postPolicyJSON !signTime !ci =+signV4PostPolicy !postPolicyJSON !sp =   let     stringToSign = Base64.encode postPolicyJSON-    region = connectRegion ci-    signingKey = mkSigningKey signTime region $ toS $ connectSecretKey ci+    region = fromMaybe "" $ spRegion sp+    signingKey = mkSigningKey (spTimeStamp sp) region $ toS $ spSecretKey sp     signature = computeSignature stringToSign signingKey   in     Map.fromList [ ("x-amz-signature", signature)

@@ -43,6 +43,7 @@  import           Network.Minio.Data import           Network.Minio.Data.ByteString+import           Network.Minio.JsonParser      (parseErrResponseJSON) import           Network.Minio.XmlParser       (parseErrResponse)  allocateReadFile :: (MonadUnliftIO m, R.MonadResource m)@@ -135,6 +136,9 @@     case contentTypeMay resp of       Just "application/xml" -> do         sErr <- parseErrResponse $ NC.responseBody resp+        throwIO sErr+      Just "application/json" -> do+        sErr <- parseErrResponseJSON $ NC.responseBody resp         throwIO sErr        _ -> throwIO $ NC.HttpExceptionRequest req $

@@ -32,10 +32,10 @@   -- | Create a bucketConfig request body XML-mkCreateBucketConfig :: Region -> ByteString-mkCreateBucketConfig location = LBS.toStrict $ renderLBS def bucketConfig+mkCreateBucketConfig :: Text -> Region -> ByteString+mkCreateBucketConfig ns location = LBS.toStrict $ renderLBS def bucketConfig   where-      s3Element n = Element (s3Name n) M.empty+      s3Element n = Element (s3Name ns n) M.empty       root = s3Element "CreateBucketConfiguration"         [ NodeElement $ s3Element "LocationConstraint"           [ NodeContent location]@@ -62,14 +62,14 @@            | XLeaf Text Text   deriving (Eq, Show) -toXML :: XNode -> ByteString-toXML node = LBS.toStrict $ renderLBS def $+toXML :: Text -> XNode -> ByteString+toXML ns node = LBS.toStrict $ renderLBS def $   Document (Prologue [] Nothing []) (xmlNode node) []   where     xmlNode :: XNode -> Element-    xmlNode (XNode name nodes)   = Element (s3Name name) M.empty $+    xmlNode (XNode name nodes)   = Element (s3Name ns name) M.empty $                                    map (NodeElement . xmlNode) nodes-    xmlNode (XLeaf name content) = Element (s3Name name) M.empty+    xmlNode (XLeaf name content) = Element (s3Name ns name) M.empty                                    [NodeContent content]  class ToXNode a where@@ -98,5 +98,5 @@                                                  , XLeaf "Value" v                                                  ] -mkPutNotificationRequest :: Notification -> ByteString-mkPutNotificationRequest = toXML . toXNode+mkPutNotificationRequest :: Text -> Notification -> ByteString+mkPutNotificationRequest ns = toXML ns . toXNode

@@ -66,20 +66,22 @@ parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a] parseDecimals numStr = forM numStr parseDecimal -s3Elem :: Text -> Axis-s3Elem = element . s3Name+s3Elem :: Text -> Text -> Axis+s3Elem ns = element . s3Name ns  parseRoot :: (MonadIO m) => LByteString -> m Cursor parseRoot = either (throwIO . MErrVXmlParse . show) (return . fromDocument)           . parseLBS def  -- | Parse the response XML of a list buckets call.-parseListBuckets :: (MonadIO m) => LByteString -> m [BucketInfo]+parseListBuckets :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m [BucketInfo] parseListBuckets xmldata = do   r <- parseRoot xmldata+  ns <- asks getSvcNamespace   let-    names = r $// s3Elem "Bucket" &// s3Elem "Name" &/ content-    timeStrings = r $// s3Elem "Bucket" &// s3Elem "CreationDate" &/ content+    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@@ -92,46 +94,54 @@   return $ bool "us-east-1" region $ region /= ""  -- | Parse the response XML of an newMultipartUpload call.-parseNewMultipartUpload :: (MonadIO m) => LByteString -> m UploadId+parseNewMultipartUpload :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m UploadId parseNewMultipartUpload xmldata = do   r <- parseRoot xmldata-  return $ T.concat $ r $// s3Elem "UploadId" &/ content+  ns <- asks getSvcNamespace+  let s3Elem' = s3Elem ns+  return $ T.concat $ r $// s3Elem' "UploadId" &/ content  -- | Parse the response XML of completeMultipartUpload call.-parseCompleteMultipartUploadResponse :: (MonadIO m) => LByteString -> m ETag+parseCompleteMultipartUploadResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ETag parseCompleteMultipartUploadResponse xmldata = do   r <- parseRoot xmldata-  return $ T.concat $ r $// s3Elem "ETag" &/ content+  ns <- asks getSvcNamespace+  let s3Elem' = s3Elem ns+  return $ T.concat $ r $// s3Elem' "ETag" &/ content  -- | Parse the response XML of copyObject and copyObjectPart-parseCopyObjectResponse :: (MonadIO m) => LByteString -> m (ETag, UTCTime)+parseCopyObjectResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m (ETag, UTCTime) parseCopyObjectResponse xmldata = do   r <- parseRoot xmldata+  ns <- asks getSvcNamespace   let-    mtimeStr = T.concat $ r $// s3Elem "LastModified" &/ content+    s3Elem' = s3Elem ns+    mtimeStr = T.concat $ r $// s3Elem' "LastModified" &/ content    mtime <- parseS3XMLTime mtimeStr-  return (T.concat $ r $// s3Elem "ETag" &/ content, mtime)+  return (T.concat $ r $// s3Elem' "ETag" &/ content, mtime)  -- | Parse the response XML of a list objects v1 call.-parseListObjectsV1Response :: (MonadIO m)+parseListObjectsV1Response :: (MonadReader env m, HasSvcNamespace env, MonadIO m)                          => LByteString -> m ListObjectsV1Result parseListObjectsV1Response xmldata = do   r <- parseRoot xmldata+  ns <- asks getSvcNamespace   let-    hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content)+    s3Elem' = s3Elem ns+    hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content) -    nextMarker = headMay $ r $/ s3Elem "NextMarker" &/ content+    nextMarker = headMay $ r $/ s3Elem' "NextMarker" &/ content -    prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content+    prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content -    keys = r $/ s3Elem "Contents" &/ s3Elem "Key" &/ content-    modTimeStr = r $/ s3Elem "Contents" &/ s3Elem "LastModified" &/ content-    etagsList = r $/ s3Elem "Contents" &/ s3Elem "ETag" &/ 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+    sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content    modTimes <- mapM parseS3XMLTime modTimeStr   sizes <- parseDecimals sizeStr@@ -142,23 +152,25 @@   return $ ListObjectsV1Result hasMore nextMarker objects prefixes  -- | Parse the response XML of a list objects call.-parseListObjectsResponse :: (MonadIO m) => LByteString -> m ListObjectsResult+parseListObjectsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListObjectsResult parseListObjectsResponse xmldata = do   r <- parseRoot xmldata+  ns <- asks getSvcNamespace   let-    hasMore = ["true"] == (r $/ s3Elem "IsTruncated" &/ content)+    s3Elem' = s3Elem ns+    hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content) -    nextToken = headMay $ r $/ s3Elem "NextContinuationToken" &/ content+    nextToken = headMay $ r $/ s3Elem' "NextContinuationToken" &/ content -    prefixes = r $/ s3Elem "CommonPrefixes" &/ s3Elem "Prefix" &/ content+    prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content -    keys = r $/ s3Elem "Contents" &/ s3Elem "Key" &/ content-    modTimeStr = r $/ s3Elem "Contents" &/ s3Elem "LastModified" &/ content-    etagsList = r $/ s3Elem "Contents" &/ s3Elem "ETag" &/ 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+    sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content    modTimes <- mapM parseS3XMLTime modTimeStr   sizes <- parseDecimals sizeStr@@ -169,17 +181,19 @@   return $ ListObjectsResult hasMore nextToken objects prefixes  -- | Parse the response XML of a list incomplete multipart upload call.-parseListUploadsResponse :: (MonadIO m) => LByteString -> m ListUploadsResult+parseListUploadsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListUploadsResult parseListUploadsResponse xmldata = do   r <- parseRoot xmldata+  ns <- asks getSvcNamespace   let-    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+    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 @@ -188,16 +202,18 @@    return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes -parseListPartsResponse :: (MonadIO m) => LByteString -> m ListPartsResult+parseListPartsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListPartsResult parseListPartsResponse xmldata = do   r <- parseRoot xmldata+  ns <- asks getSvcNamespace   let-    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+    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@@ -218,28 +234,30 @@       message = T.concat $ r $/ element "Message" &/ content   return $ toServiceErr code message -parseNotification :: (MonadIO m) => LByteString -> m Notification+parseNotification :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m Notification parseNotification xmldata = do   r <- parseRoot xmldata-  let qcfg = map node $ r $/ s3Elem "QueueConfiguration"-      tcfg = map node $ r $/ s3Elem "TopicConfiguration"-      lcfg = map node $ r $/ s3Elem "CloudFunctionConfiguration"-  Notification <$> (mapM (parseNode "Queue") qcfg)-    <*> (mapM (parseNode "Topic") tcfg)-    <*> (mapM (parseNode "CloudFunction") lcfg)+  ns <- asks getSvcNamespace+  let s3Elem' = s3Elem ns+      qcfg = map node $ r $/ s3Elem' "QueueConfiguration"+      tcfg = map node $ r $/ s3Elem' "TopicConfiguration"+      lcfg = map node $ r $/ s3Elem' "CloudFunctionConfiguration"+  Notification <$> (mapM (parseNode ns "Queue") qcfg)+    <*> (mapM (parseNode ns "Topic") tcfg)+    <*> (mapM (parseNode ns "CloudFunction") lcfg)   where -    getFilterRule c =-      let name = T.concat $ c $/ s3Elem "Name" &/ content-          value = T.concat $ c $/ s3Elem "Value" &/ content+    getFilterRule ns c =+      let name = T.concat $ c $/ s3Elem ns "Name" &/ content+          value = T.concat $ c $/ s3Elem ns "Value" &/ content       in FilterRule name value -    parseNode arnName nodeData = do+    parseNode ns arnName nodeData = do       let c = fromNode nodeData-          id = T.concat $ c $/ s3Elem "Id" &/ content-          arn = T.concat $ c $/ s3Elem arnName &/ content-          events = catMaybes $ map textToEvent $ c $/ s3Elem "Event" &/ content-          rules = c $/ s3Elem "Filter" &/ s3Elem "S3Key" &/-                  s3Elem "FilterRule" &| getFilterRule+          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)

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- -- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. --@@ -26,7 +27,6 @@ import qualified Data.Conduit                          as C import qualified Data.Conduit.Binary                   as CB import           Data.Conduit.Combinators              (sinkList)-import           Data.Default                          (Default (..)) import qualified Data.Map.Strict                       as Map import qualified Data.Text                             as T import           Data.Time                             (fromGregorian)@@ -83,12 +83,15 @@   bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z'))   let b = T.concat [funTestBucketPrefix, T.pack bktSuffix]       liftStep = liftIO . step-  connInfo <- maybe minioPlayCI (const def) <$> lookupEnv "MINIO_LOCAL"+  connInfo <- ( bool minioPlayCI+                  ( setCreds (Credentials "minio" "minio123") "http://localhost:9000" )+                  . isJust+              ) <$> lookupEnv "MINIO_LOCAL"   ret <- runMinio connInfo $ do     liftStep $ "Creating bucket for test - " ++ t     foundBucket <- bucketExists b     liftIO $ foundBucket @?= False-    makeBucket b def+    makeBucket b Nothing     minioTest liftStep b     deleteBucket b   isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret)@@ -116,7 +119,7 @@        destFile <- mkRandFile 0       step  "Retrieve the created object and check size"-      fGetObject bucket object destFile def+      fGetObject bucket object destFile defaultGetObjectOptions       gotSize <- withNewHandle destFile getFileSize       liftIO $ gotSize == Right (Just mb15) @?         "Wrong file size of put file after getting"@@ -135,11 +138,11 @@       rFile <- mkRandFile mb1        step "Upload single file."-      putObject bucket obj (CB.sourceFile rFile) (Just mb1) def+      putObject bucket obj (CB.sourceFile rFile) (Just mb1) defaultPutObjectOptions        step "Retrieve and verify file size"       destFile <- mkRandFile 0-      fGetObject bucket obj destFile def+      fGetObject bucket obj destFile defaultGetObjectOptions       gotSize <- withNewHandle destFile getFileSize       liftIO $ gotSize == Right (Just mb1) @?         "Wrong file size of put file after getting"@@ -158,11 +161,11 @@       rFile <- mkRandFile mb70        step "Upload multipart file."-      putObject bucket obj (CB.sourceFile rFile) Nothing def+      putObject bucket obj (CB.sourceFile rFile) Nothing defaultPutObjectOptions        step "Retrieve and verify file size"       destFile <- mkRandFile 0-      fGetObject bucket obj destFile def+      fGetObject bucket obj destFile defaultGetObjectOptions       gotSize <- withNewHandle destFile getFileSize       liftIO $ gotSize == Right (Just mb70) @?         "Wrong file size of put file after getting"@@ -177,7 +180,7 @@       step "put 3 objects"       let expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3"]       forM_ expectedObjects $-        \obj -> fPutObject bucket obj "/etc/lsb-release" def+        \obj -> fPutObject bucket obj "/etc/lsb-release" defaultPutObjectOptions        step "High-level listing of objects"       objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList@@ -241,7 +244,7 @@       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" def+        fPutObject bucket (T.concat ["lsb-release", T.pack (show s)]) "/etc/lsb-release" defaultPutObjectOptions        step "Simple list"       res <- listObjects' bucket Nothing Nothing Nothing Nothing@@ -312,11 +315,11 @@       let mb80 = 80 * 1024 * 1024           obj = "mpart" -      void $ putObjectInternal bucket obj def $ ODFile "/dev/zero" (Just mb80)+      void $ putObjectInternal bucket obj defaultPutObjectOptions $ ODFile "/dev/zero" (Just mb80)        step "Retrieve and verify file size"       destFile <- mkRandFile 0-      fGetObject bucket obj destFile def+      fGetObject bucket obj destFile defaultGetObjectOptions       gotSize <- withNewHandle destFile getFileSize       liftIO $ gotSize == Right (Just mb80) @?         "Wrong file size of put file after getting"@@ -356,7 +359,7 @@        step "create server object with content-type"       inputFile <- mkRandFile size1-      fPutObject bucket object inputFile def{+      fPutObject bucket object inputFile defaultPutObjectOptions {         pooContentType = Just "application/javascript"         } @@ -368,7 +371,7 @@       liftIO $ assertEqual "Content-Type did not match" (Just "application/javascript") (Map.lookup "Content-Type" m)        step "upload object with content-encoding set to identity"-      fPutObject bucket object inputFile def {+      fPutObject bucket object inputFile defaultPutObjectOptions {         pooContentEncoding = Just "identity"         } @@ -390,7 +393,7 @@        step "create server object with content-language"       inputFile <- mkRandFile size1-      fPutObject bucket object inputFile def{+      fPutObject bucket object inputFile defaultPutObjectOptions {         pooContentLanguage = Just "en-US"         } @@ -418,11 +421,11 @@       inputFile' <- mkRandFile size1       inputFile'' <- mkRandFile size0 -      fPutObject bucket object inputFile def{+      fPutObject bucket object inputFile defaultPutObjectOptions {         pooStorageClass = Just "STANDARD"         } -      fPutObject bucket object' inputFile' def{+      fPutObject bucket object' inputFile' defaultPutObjectOptions {         pooStorageClass = Just "REDUCED_REDUNDANCY"         } @@ -436,7 +439,7 @@       liftIO $ assertEqual "storageClass did not match" (Just "REDUCED_REDUNDANCY")         (Map.lookup "X-Amz-Storage-Class" m') -      fpE <- try $ fPutObject bucket object'' inputFile'' def{+      fpE <- try $ fPutObject bucket object'' inputFile'' defaultPutObjectOptions {         pooStorageClass = Just "INVALID_STORAGE_CLASS"         }       case fpE of@@ -455,10 +458,10 @@        step "create server object to copy"       inputFile <- mkRandFile size1-      fPutObject bucket object inputFile def+      fPutObject bucket object inputFile defaultPutObjectOptions        step "copy object"-      let srcInfo = def { srcBucket = bucket, srcObject = object}+      let srcInfo = defaultSourceInfo { srcBucket = bucket, srcObject = object}       (etag, modTime) <- copyObjectSingle bucket objCopy srcInfo []        -- retrieve obj info to check@@ -484,15 +487,15 @@       let mb15 = 15 * 1024 * 1024           mb5 = 5 * 1024 * 1024       randFile <- mkRandFile mb15-      fPutObject bucket srcObj randFile def+      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' = def { srcBucket = bucket, srcObject = srcObj }-          dstInfo' = def { dstBucket = bucket, dstObject = copyObj }+      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))@@ -520,11 +523,11 @@       step "Prepare"       forM_ (zip srcs sizes) $ \(src, size) -> do         inputFile' <- mkRandFile size-        fPutObject bucket src inputFile' def+        fPutObject bucket src inputFile' defaultPutObjectOptions        step "make small and large object copy"       forM_ (zip copyObjs srcs) $ \(cp, src) ->-        copyObject def {dstBucket = bucket, dstObject = cp} def{srcBucket = bucket, srcObject = src}+        copyObject defaultDestinationInfo {dstBucket = bucket, dstObject = cp} defaultSourceInfo {srcBucket = bucket, srcObject = src}        step "verify uploaded objects"       uploadedSizes <- fmap oiSize <$> forM copyObjs (headObject bucket)@@ -539,10 +542,10 @@        step "Prepare"       inputFile' <- mkRandFile size-      fPutObject bucket src inputFile' def+      fPutObject bucket src inputFile' defaultPutObjectOptions        step "copy last 10MiB of object"-      copyObject def { dstBucket = bucket, dstObject = copyObj } def{+      copyObject defaultDestinationInfo { dstBucket = bucket, dstObject = copyObj } defaultSourceInfo {           srcBucket = bucket         , srcObject = src         , srcRange = Just $ (,) (5 * 1024 * 1024) (size - 1)@@ -586,21 +589,21 @@       liftIO $ region == "us-east-1" @? ("Got unexpected region => " ++ show region)        step "singlepart putObject works"-      fPutObject bucket "lsb-release" "/etc/lsb-release" def+      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" def+      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 def+      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 def{+      resE <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {         gooIfUnmodifiedSince = (Just unmodifiedTime)         }       case resE of@@ -608,7 +611,7 @@         _        -> return ()        step "fGetObject an object with no matching etag, check for exception"-      resE1 <- try $ fGetObject bucket "lsb-release" outFile def{+      resE1 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {         gooIfMatch = (Just "invalid-etag")         }       case resE1 of@@ -616,7 +619,7 @@         _        -> return ()        step "fGetObject an object with no valid range, check for exception"-      resE2 <- try $ fGetObject bucket "lsb-release" outFile def{+      resE2 <- try $ fGetObject bucket "lsb-release" outFile defaultGetObjectOptions {         gooRange = (Just $ HT.ByteRangeFromTo 100 200)         }       case resE2 of@@ -624,12 +627,12 @@           _        -> return ()        step "fGetObject on object with a valid range"-      fGetObject bucket "lsb-release" outFile def{+      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 def+      resE3 <- try $ fGetObject bucket "noSuchKey" outFile defaultGetObjectOptions       case resE3 of         Left exn -> liftIO $ exn @?= NoSuchKey         _        -> return ()@@ -648,7 +651,7 @@       let object = "sample"       step "create an object"       inputFile <- mkRandFile 0-      fPutObject bucket object inputFile def+      fPutObject bucket object inputFile defaultPutObjectOptions        step "get metadata of the object"       res <- statObject bucket object@@ -814,7 +817,7 @@     let obj = "myobject"      step "verify bucket policy: (1) create `myobject`"-    putObject bucket obj (replicateC 100 "c") Nothing def+    putObject bucket obj (replicateC 100 "c") Nothing defaultPutObjectOptions      step "verify bucket policy: (2) get `myobject` anonymously"     connInfo <- asks mcConnInfo

@@ -1,5 +1,5 @@ ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -17,13 +17,18 @@ 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 +import           Network.Minio.AdminAPI import           Network.Minio.API  assertBool' :: Bool -> Assertion@@ -49,3 +54,49 @@   [ testCase "Empty name" $ assertBool' $ not $ isValidObjectName ""   , testCase "Has unicode characters" $ assertBool' $ isValidObjectName "日本国"   ]++parseServerInfoJSONTest :: TestTree+parseServerInfoJSONTest = testGroup "Parse Minio Admin API ServerInfo JSON test" $+  map (\(tName, tDesc, tfn, tVal) -> testCase tName $ assertBool tDesc $+        tfn (eitherDecode tVal :: Either [Char] [ServerInfo])) testCases+  where+    testCases = [ ("FSBackend", "Verify server info json parsing for FS backend", isRight, fsJSON)+                , ("Erasure Backend", "Verify server info json parsing for Erasure backend", isRight, erasureJSON)+                , ("Unknown Backend", "Verify server info json parsing for invalid backend", isLeft, invalidJSON)+                ]+    fsJSON = "[{\"error\":\"\",\"addr\":\"192.168.1.218:9000\",\"data\":{\"storage\":{\"Used\":20530,\"Backend\":{\"Type\":1,\"OnlineDisks\":0,\"OfflineDisks\":0,\"StandardSCData\":0,\"StandardSCParity\":0,\"RRSCData\":0,\"RRSCParity\":0,\"Sets\":null}},\"network\":{\"transferred\":808,\"received\":1160},\"http\":{\"totalHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalGETs\":{\"count\":1,\"avgDuration\":\"0s\"},\"successGETs\":{\"count\":1,\"avgDuration\":\"0s\"},\"totalPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"}},\"server\":{\"uptime\":5992503019270,\"version\":\"DEVELOPMENT.GOGET\",\"commitID\":\"DEVELOPMENT.GOGET\",\"region\":\"\",\"sqsARN\":[]}}}]"++    erasureJSON = "[{\"error\":\"\",\"addr\":\"192.168.1.218:9000\",\"data\":{\"storage\":{\"Used\":83084,\"Backend\":{\"Type\":2,\"OnlineDisks\":4,\"OfflineDisks\":0,\"StandardSCData\":2,\"StandardSCParity\":2,\"RRSCData\":2,\"RRSCParity\":2,\"Sets\":[[{\"uuid\":\"16ec6f2c-9197-4787-904a-36bb2c2683f8\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"4052e086-ef99-4aa5-ae2b-8e27559432f6\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"d0639950-ddd3-45b0-93ca-fd86f5d79f72\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"30ec68c0-37e1-4592-82c1-26b143c0ac10\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]]}},\"network\":{\"transferred\":404,\"received\":0},\"http\":{\"totalHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalGETs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successGETs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"}},\"server\":{\"uptime\":2738903073,\"version\":\"DEVELOPMENT.GOGET\",\"commitID\":\"DEVELOPMENT.GOGET\",\"region\":\"\",\"sqsARN\":[]}}}]"++    invalidJSON = "[{\"error\":\"\",\"addr\":\"192.168.1.218:9000\",\"data\":{\"storage\":{\"Used\":83084,\"Backend\":{\"Type\":42,\"OnlineDisks\":4,\"OfflineDisks\":0,\"StandardSCData\":2,\"StandardSCParity\":2,\"RRSCData\":2,\"RRSCParity\":2,\"Sets\":[[{\"uuid\":\"16ec6f2c-9197-4787-904a-36bb2c2683f8\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"4052e086-ef99-4aa5-ae2b-8e27559432f6\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"d0639950-ddd3-45b0-93ca-fd86f5d79f72\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"30ec68c0-37e1-4592-82c1-26b143c0ac10\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]]}},\"network\":{\"transferred\":404,\"received\":0},\"http\":{\"totalHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successHEADs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalGETs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successGETs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPUTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successPOSTs\":{\"count\":0,\"avgDuration\":\"0s\"},\"totalDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"},\"successDELETEs\":{\"count\":0,\"avgDuration\":\"0s\"}},\"server\":{\"uptime\":2738903073,\"version\":\"DEVELOPMENT.GOGET\",\"commitID\":\"DEVELOPMENT.GOGET\",\"region\":\"\",\"sqsARN\":[]}}}]"++parseHealStatusTest :: TestTree+parseHealStatusTest = testGroup "Parse Minio Admin API HealStatus JSON test" $+  map (\(tName, tDesc, tfn, tVal) -> testCase tName $ assertBool tDesc $+        tfn (eitherDecode tVal :: Either [Char] HealStatus)) testCases++  where+    testCases = [ ("Good", "Verify heal result item for erasure backend", isRight, erasureJSON')+                , ("Corrupted", "Verify heal result item for erasure backend", isLeft, invalidJSON')+                , ("Incorrect Value", "Verify heal result item for erasure backend", isLeft, invalidItemType)+                ]++    erasureJSON' = "{\"Summary\":\"finished\",\"StartTime\":\"2018-06-05T08:09:47.644465513Z\",\"NumDisks\":4,\"Settings\":{\"recursive\":false,\"dryRun\":false},\"Items\":[{\"resultId\":1,\"type\":\"metadata\",\"bucket\":\"\",\"object\":\"\",\"detail\":\"disk-format\",\"diskCount\":4,\"setCount\":1,\"before\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"after\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"objectSize\":0}]}"++    invalidJSON' = "{\"Summary\":\"finished\",\"StartTime\":\"2018-06-05T08:09:47.644465513Z\",\"NumDisks\":4,\"Settings\":{\"recursive\":false,\"dryRun\":false},\"Items\":[{\"resultId\":1,\"type\":\"metadata\",\"bucket\":\"\",\"object\":\"\",\"detail\":\"disk-format\",\"diskCount\":4,\"setCount\":1,\"before\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"after\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"objectSize\":0}]"++    invalidItemType = "{\"Summary\":\"finished\",\"StartTime\":\"2018-06-05T08:09:47.644465513Z\",\"NumDisks\":4,\"Settings\":{\"recursive\":false,\"dryRun\":false},\"Items\":[{\"resultId\":1,\"type\":\"hello\",\"bucket\":\"\",\"object\":\"\",\"detail\":\"disk-format\",\"diskCount\":4,\"setCount\":1,\"before\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"after\":{\"drives\":[{\"uuid\":\"c3487166-b8a4-481a-b1e7-fb9b249e2500\",\"endpoint\":\"/tmp/1\",\"state\":\"ok\"},{\"uuid\":\"55a6e787-184f-4e4c-bf09-03dcada658a9\",\"endpoint\":\"/tmp/2\",\"state\":\"ok\"},{\"uuid\":\"f035d8c3-fca1-4407-b89c-38c2bcf4a641\",\"endpoint\":\"/tmp/3\",\"state\":\"ok\"},{\"uuid\":\"4f8b79d3-db90-4c1d-87c2-35a28b0d9a13\",\"endpoint\":\"/tmp/4\",\"state\":\"ok\"}]},\"objectSize\":0}]}"++parseHealStartRespTest :: TestTree+parseHealStartRespTest = testGroup "Parse Minio Admin API HealStartResp JSON test" $+  map (\(tName, tDesc, tfn, tVal) -> testCase tName $ assertBool tDesc $+        tfn (eitherDecode tVal :: Either [Char] HealStartResp)) testCases++  where+    testCases = [ ("Good", "Verify heal start response for erasure backend", isRight, hsrJSON)+                , ("Missing Token", "Verify heal start response for erasure backend", isLeft, missingTokenJSON)+                ]++    hsrJSON = "{\"clientToken\":\"3a3aca49-77dd-4b78-bba7-0978f119b23e\",\"clientAddress\":\"127.0.0.1\",\"startTime\":\"2018-06-05T08:09:47.644394493Z\"}"++    missingTokenJSON = "{\"clientAddress\":\"127.0.0.1\",\"startTime\":\"2018-06-05T08:09:47.644394493Z\"}"

@@ -0,0 +1,64 @@+--+-- Minio Haskell SDK, (C) 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.JsonParser.Test+  (+    jsonParserTests+  ) where++import           Test.Tasty+import           Test.Tasty.HUnit+import           UnliftIO                 (MonadUnliftIO)++import           Lib.Prelude++import           Network.Minio.Errors+import           Network.Minio.JsonParser++jsonParserTests :: TestTree+jsonParserTests = testGroup "JSON Parser Tests"+  [ testCase "Test parseErrResponseJSON" testParseErrResponseJSON+  ]++tryValidationErr :: (MonadUnliftIO m) => m a -> m (Either MErrV a)+tryValidationErr act = try act++assertValidationErr :: MErrV -> Assertion+assertValidationErr e = assertFailure $ "Failed due to validation error => " ++ show e++testParseErrResponseJSON :: Assertion+testParseErrResponseJSON = do+  -- 1. Test parsing of an invalid error json.+  parseResE <- tryValidationErr $ parseErrResponseJSON "ClearlyInvalidJSON"+  when (isRight parseResE) $+    assertFailure $ "Parsing should have failed => " ++ show parseResE++  forM_ cases $ \(jsondata, sErr) -> do+    parseErr <- tryValidationErr $ parseErrResponseJSON jsondata+    either assertValidationErr (@?= sErr) parseErr++  where+    cases =  [+      -- 2. Test parsing of a valid error json.+      ("{\"Code\":\"InvalidAccessKeyId\",\"Message\":\"The access key ID you provided does not exist in our records.\",\"Key\":\"\",\"BucketName\":\"\",\"Resource\":\"/minio/admin/v1/info\",\"RequestId\":\"3L137\",\"HostId\":\"3L137\"}",+       ServiceErr "InvalidAccessKeyId" "The access key ID you provided does not exist in our records."+      )+      ,+      -- 3. Test parsing of a valid, empty Resource.+      ("{\"Code\":\"SignatureDoesNotMatch\",\"Message\":\"The request signature we calculated does not match the signature you provided. Check your key and signing method.\",\"Key\":\"\",\"BucketName\":\"\",\"Resource\":\"/minio/admin/v1/info\",\"RequestId\":\"3L137\",\"HostId\":\"3L137\"}",+       ServiceErr "SignatureDoesNotMatch" "The request signature we calculated does not match the signature you provided. Check your key and signing method."+      )+      ]

@@ -0,0 +1,32 @@+--+-- Minio Haskell SDK, (C) 2018 Minio, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.TestHelpers+  ( runTestNS+  ) where++import           Network.Minio.Data++import           Lib.Prelude++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/"

@@ -19,12 +19,12 @@     limitedMapConcurrentlyTests   ) where -import Test.Tasty-import Test.Tasty.HUnit+import           Test.Tasty+import           Test.Tasty.HUnit -import Lib.Prelude+import           Lib.Prelude -import Network.Minio.Utils+import           Network.Minio.Utils  limitedMapConcurrentlyTests :: TestTree limitedMapConcurrentlyTests = testGroup "limitedMapConcurrently Tests"

@@ -23,9 +23,8 @@  import           Lib.Prelude -import           Data.Default               (def)- import           Network.Minio.Data+import           Network.Minio.TestHelpers import           Network.Minio.XmlGenerator import           Network.Minio.XmlParser    (parseNotification) @@ -38,8 +37,9 @@  testMkCreateBucketConfig :: Assertion testMkCreateBucketConfig = do+  let ns = "http://s3.amazonaws.com/doc/2006-03-01/"   assertEqual "CreateBucketConfiguration xml should match: " expected $-    mkCreateBucketConfig "EU"+    mkCreateBucketConfig ns "EU"   where     expected = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\                \<CreateBucketConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\@@ -58,11 +58,13 @@     \</Part>\     \</CompleteMultipartUpload>" + testMkPutNotificationRequest :: Assertion testMkPutNotificationRequest =   forM_ cases $ \val -> do-    let result = toS $ mkPutNotificationRequest val-    ntf <- runExceptT $ parseNotification result+    let ns = "http://s3.amazonaws.com/doc/2006-03-01/"+        result = toS $ mkPutNotificationRequest ns val+    ntf <- runExceptT $ runTestNS $ parseNotification result     either (\_ -> assertFailure "XML Parse Error!")       (@?= val) ntf   where@@ -70,7 +72,7 @@               [ NotificationConfig                 "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4"                 "arn:aws:sns:us-east-1:account-id:s3notificationtopic2"-                [ReducedRedundancyLostObject, ObjectCreated] def+                [ReducedRedundancyLostObject, ObjectCreated] defaultFilter               ]               []             , Notification@@ -82,14 +84,14 @@                   , FilterRule "suffix" ".jpg"])               , NotificationConfig                 "" "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"-                [ObjectCreated] def+                [ObjectCreated] defaultFilter               ]               [ NotificationConfig                 "" "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"-                [ReducedRedundancyLostObject] def+                [ReducedRedundancyLostObject] defaultFilter               ]               [ NotificationConfig                 "ObjectCreatedEvents" "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"-                [ObjectCreated] def+                [ObjectCreated] defaultFilter               ]             ]

@@ -19,17 +19,17 @@     xmlParserTests   ) where -import           Data.Default            (def)-import qualified Data.Map                as Map-import           Data.Time               (fromGregorian)+import qualified Data.Map                  as Map+import           Data.Time                 (fromGregorian) import           Test.Tasty import           Test.Tasty.HUnit-import           UnliftIO                (MonadUnliftIO)+import           UnliftIO                  (MonadUnliftIO)  import           Lib.Prelude  import           Network.Minio.Data import           Network.Minio.Errors+import           Network.Minio.TestHelpers import           Network.Minio.XmlParser  xmlParserTests :: TestTree@@ -83,7 +83,7 @@ testParseNewMultipartUpload :: Assertion testParseNewMultipartUpload = do   forM_ cases $ \(xmldata, expectedUploadId) -> do-    parsedUploadIdE <- tryValidationErr $ parseNewMultipartUpload xmldata+    parsedUploadIdE <- tryValidationErr $ runTestNS $ parseNewMultipartUpload xmldata     eitherValidationErr parsedUploadIdE (@?= expectedUploadId)   where     cases = [@@ -129,7 +129,7 @@     object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 Map.empty     modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 -  parsedListObjectsResult <- tryValidationErr $ parseListObjectsResponse xmldata+  parsedListObjectsResult <- tryValidationErr $ runTestNS $ parseListObjectsResponse xmldata   eitherValidationErr parsedListObjectsResult (@?= expectedListResult)  testParseListObjectsV1Result :: Assertion@@ -156,7 +156,7 @@     object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 Map.empty     modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 -  parsedListObjectsV1Result <- tryValidationErr $ parseListObjectsV1Response xmldata+  parsedListObjectsV1Result <- tryValidationErr $ runTestNS $ parseListObjectsV1Response xmldata   eitherValidationErr parsedListObjectsV1Result (@?= expectedListResult)  testParseListIncompleteUploads :: Assertion@@ -198,7 +198,7 @@     initTime = UTCTime (fromGregorian 2010 11 26) 69857     prefixes = ["photos/", "videos/"] -  parsedListUploadsResult <- tryValidationErr $ parseListUploadsResponse xmldata+  parsedListUploadsResult <- tryValidationErr $ runTestNS $ parseListUploadsResponse xmldata   eitherValidationErr parsedListUploadsResult (@?= expectedListResult)  @@ -214,7 +214,7 @@ \</CompleteMultipartUploadResult>"     expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\"" -  parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata+  parsedETagE <- runExceptT $ runTestNS $ parseCompleteMultipartUploadResponse xmldata   eitherValidationErr parsedETagE (@?= expectedETag)  testParseListPartsResponse :: Assertion@@ -258,7 +258,7 @@     part2 = ObjectPartInfo 3 "\"aaaa18db4cc2f85cedef654fccc4a4x8\"" 10485760 modifiedTime2     modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10 -  parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata+  parsedListPartsResult <- runExceptT $ runTestNS $ parseListPartsResponse xmldata   eitherValidationErr parsedListPartsResult (@?= expectedListResult)  testParseCopyObjectResponse :: Assertion@@ -280,7 +280,7 @@               UTCTime (fromGregorian 2009 10 28) 81120))]    forM_ cases $ \(xmldata, (etag, modTime)) -> do-    parseResult <- runExceptT $ parseCopyObjectResponse xmldata+    parseResult <- runExceptT $ runTestNS $ parseCopyObjectResponse xmldata     eitherValidationErr parseResult (@?= (etag, modTime))  testParseNotification :: Assertion@@ -298,7 +298,7 @@                 [ NotificationConfig                   "YjVkM2Y0YmUtNGI3NC00ZjQyLWEwNGItNDIyYWUxY2I0N2M4"                   "arn:aws:sns:us-east-1:account-id:s3notificationtopic2"-                  [ReducedRedundancyLostObject, ObjectCreated] def+                  [ReducedRedundancyLostObject, ObjectCreated] defaultFilter                 ]                 [])             , ("<NotificationConfiguration xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\">\@@ -341,18 +341,18 @@                                 FilterRule "suffix" ".jpg"])                             , NotificationConfig                               "" "arn:aws:sqs:us-east-1:356671443308:s3notificationqueue"-                              [ObjectCreated] def+                              [ObjectCreated] defaultFilter                             ]                             [ NotificationConfig                               "" "arn:aws:sns:us-east-1:356671443308:s3notificationtopic2"-                              [ReducedRedundancyLostObject] def+                              [ReducedRedundancyLostObject] defaultFilter                             ]                             [ NotificationConfig                               "ObjectCreatedEvents" "arn:aws:lambda:us-west-2:35667example:function:CreateThumbnail"-                              [ObjectCreated] def+                              [ObjectCreated] defaultFilter                             ])             ]    forM_ cases $ \(xmldata, val) -> do-    result <- runExceptT $ parseNotification xmldata+    result <- runExceptT $ runTestNS $ parseNotification xmldata     eitherValidationErr result (@?= val)

@@ -1,5 +1,5 @@ ----- Minio Haskell SDK, (C) 2017 Minio, Inc.+-- Minio Haskell SDK, (C) 2017, 2018 Minio, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -15,9 +15,9 @@ --  import           Test.Tasty-import           Test.Tasty.QuickCheck as QC+import           Test.Tasty.QuickCheck           as QC -import qualified Data.List as L+import qualified Data.List                       as L  import           Lib.Prelude @@ -57,8 +57,8 @@               -- check that pns increments from 1.               isPNumsAscendingFrom1 = all (\(a, b) -> a == b) $ zip pns [1..] -              consPairs [] = []-              consPairs [_] = []+              consPairs []        = []+              consPairs [_]       = []               consPairs (a:(b:c)) = (a, b):(consPairs (b:c))                -- check `offs` is monotonically increasing.@@ -114,7 +114,11 @@   ]  unitTests :: TestTree-unitTests = testGroup "Unit tests" [xmlGeneratorTests, xmlParserTests,-                                    bucketNameValidityTests,-                                    objectNameValidityTests,-                                    limitedMapConcurrentlyTests]+unitTests = testGroup "Unit tests" [ xmlGeneratorTests, xmlParserTests+                                   , bucketNameValidityTests+                                   , objectNameValidityTests+                                   , parseServerInfoJSONTest+                                   , parseHealStatusTest+                                   , parseHealStartRespTest+                                   , limitedMapConcurrentlyTests+                                   ]