diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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." ``` diff --git a/docs/API.md b/docs/API.md --- a/docs/API.md +++ b/docs/API.md @@ -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 @@ -### 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 - ``` -### 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 - ``` @@ -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 -### 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." ``` -### 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." + ``` diff --git a/examples/BucketExists.hs b/examples/BucketExists.hs --- a/examples/BucketExists.hs +++ b/examples/BucketExists.hs @@ -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. diff --git a/examples/CopyObject.hs b/examples/CopyObject.hs --- a/examples/CopyObject.hs +++ b/examples/CopyObject.hs @@ -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. diff --git a/examples/FileUploader.hs b/examples/FileUploader.hs --- a/examples/FileUploader.hs +++ b/examples/FileUploader.hs @@ -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) diff --git a/examples/GetConfig.hs b/examples/GetConfig.hs new file mode 100644 --- /dev/null +++ b/examples/GetConfig.hs @@ -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 diff --git a/examples/GetObject.hs b/examples/GetObject.hs --- a/examples/GetObject.hs +++ b/examples/GetObject.hs @@ -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) diff --git a/examples/HeadObject.hs b/examples/HeadObject.hs --- a/examples/HeadObject.hs +++ b/examples/HeadObject.hs @@ -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. diff --git a/examples/Heal.hs b/examples/Heal.hs new file mode 100644 --- /dev/null +++ b/examples/Heal.hs @@ -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 diff --git a/examples/ListBuckets.hs b/examples/ListBuckets.hs --- a/examples/ListBuckets.hs +++ b/examples/ListBuckets.hs @@ -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. diff --git a/examples/ListIncompleteUploads.hs b/examples/ListIncompleteUploads.hs --- a/examples/ListIncompleteUploads.hs +++ b/examples/ListIncompleteUploads.hs @@ -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 {- diff --git a/examples/ListObjects.hs b/examples/ListObjects.hs --- a/examples/ListObjects.hs +++ b/examples/ListObjects.hs @@ -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. diff --git a/examples/MakeBucket.hs b/examples/MakeBucket.hs new file mode 100644 --- /dev/null +++ b/examples/MakeBucket.hs @@ -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 diff --git a/examples/Makebucket.hs b/examples/Makebucket.hs deleted file mode 100644 --- a/examples/Makebucket.hs +++ /dev/null @@ -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 diff --git a/examples/PresignedGetObject.hs b/examples/PresignedGetObject.hs --- a/examples/PresignedGetObject.hs +++ b/examples/PresignedGetObject.hs @@ -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. diff --git a/examples/PresignedPostPolicy.hs b/examples/PresignedPostPolicy.hs --- a/examples/PresignedPostPolicy.hs +++ b/examples/PresignedPostPolicy.hs @@ -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. diff --git a/examples/PresignedPutObject.hs b/examples/PresignedPutObject.hs --- a/examples/PresignedPutObject.hs +++ b/examples/PresignedPutObject.hs @@ -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. diff --git a/examples/PutObject.hs b/examples/PutObject.hs --- a/examples/PutObject.hs +++ b/examples/PutObject.hs @@ -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 $ diff --git a/examples/RemoveBucket.hs b/examples/RemoveBucket.hs new file mode 100644 --- /dev/null +++ b/examples/RemoveBucket.hs @@ -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 diff --git a/examples/RemoveIncompleteUpload.hs b/examples/RemoveIncompleteUpload.hs --- a/examples/RemoveIncompleteUpload.hs +++ b/examples/RemoveIncompleteUpload.hs @@ -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. diff --git a/examples/RemoveObject.hs b/examples/RemoveObject.hs --- a/examples/RemoveObject.hs +++ b/examples/RemoveObject.hs @@ -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. diff --git a/examples/Removebucket.hs b/examples/Removebucket.hs deleted file mode 100644 --- a/examples/Removebucket.hs +++ /dev/null @@ -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 diff --git a/examples/ServerInfo.hs b/examples/ServerInfo.hs new file mode 100644 --- /dev/null +++ b/examples/ServerInfo.hs @@ -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 diff --git a/examples/ServiceSendRestart.hs b/examples/ServiceSendRestart.hs new file mode 100644 --- /dev/null +++ b/examples/ServiceSendRestart.hs @@ -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 diff --git a/examples/ServiceSendStop.hs b/examples/ServiceSendStop.hs new file mode 100644 --- /dev/null +++ b/examples/ServiceSendStop.hs @@ -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 diff --git a/examples/ServiceStatus.hs b/examples/ServiceStatus.hs new file mode 100644 --- /dev/null +++ b/examples/ServiceStatus.hs @@ -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 diff --git a/examples/SetConfig.hs b/examples/SetConfig.hs new file mode 100644 --- /dev/null +++ b/examples/SetConfig.hs @@ -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 diff --git a/minio-hs.cabal b/minio-hs.cabal --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -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 diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -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 diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -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 diff --git a/src/Network/Minio/APICommon.hs b/src/Network/Minio/APICommon.hs new file mode 100644 --- /dev/null +++ b/src/Network/Minio/APICommon.hs @@ -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) diff --git a/src/Network/Minio/AdminAPI.hs b/src/Network/Minio/AdminAPI.hs new file mode 100644 --- /dev/null +++ b/src/Network/Minio/AdminAPI.hs @@ -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) + } diff --git a/src/Network/Minio/CopyObject.hs b/src/Network/Minio/CopyObject.hs --- a/src/Network/Minio/CopyObject.hs +++ b/src/Network/Minio/CopyObject.hs @@ -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 diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -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" -- | -- 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 diff --git a/src/Network/Minio/Errors.hs b/src/Network/Minio/Errors.hs --- a/src/Network/Minio/Errors.hs +++ b/src/Network/Minio/Errors.hs @@ -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 diff --git a/src/Network/Minio/JsonParser.hs b/src/Network/Minio/JsonParser.hs new file mode 100644 --- /dev/null +++ b/src/Network/Minio/JsonParser.hs @@ -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 diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -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) diff --git a/src/Network/Minio/PutObject.hs b/src/Network/Minio/PutObject.hs --- a/src/Network/Minio/PutObject.hs +++ b/src/Network/Minio/PutObject.hs @@ -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 diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -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)] } diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -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) diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -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 $ diff --git a/src/Network/Minio/XmlGenerator.hs b/src/Network/Minio/XmlGenerator.hs --- a/src/Network/Minio/XmlGenerator.hs +++ b/src/Network/Minio/XmlGenerator.hs @@ -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 diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -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) diff --git a/test/LiveServer.hs b/test/LiveServer.hs --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -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 diff --git a/test/Network/Minio/API/Test.hs b/test/Network/Minio/API/Test.hs --- a/test/Network/Minio/API/Test.hs +++ b/test/Network/Minio/API/Test.hs @@ -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\"}" diff --git a/test/Network/Minio/JsonParser/Test.hs b/test/Network/Minio/JsonParser/Test.hs new file mode 100644 --- /dev/null +++ b/test/Network/Minio/JsonParser/Test.hs @@ -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." + ) + ] diff --git a/test/Network/Minio/TestHelpers.hs b/test/Network/Minio/TestHelpers.hs new file mode 100644 --- /dev/null +++ b/test/Network/Minio/TestHelpers.hs @@ -0,0 +1,32 @@ +-- +-- Minio Haskell SDK, (C) 2018 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +module Network.Minio.TestHelpers + ( runTestNS + ) where + +import Network.Minio.Data + +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/" diff --git a/test/Network/Minio/Utils/Test.hs b/test/Network/Minio/Utils/Test.hs --- a/test/Network/Minio/Utils/Test.hs +++ b/test/Network/Minio/Utils/Test.hs @@ -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" diff --git a/test/Network/Minio/XmlGenerator/Test.hs b/test/Network/Minio/XmlGenerator/Test.hs --- a/test/Network/Minio/XmlGenerator/Test.hs +++ b/test/Network/Minio/XmlGenerator/Test.hs @@ -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 = "\ \\ @@ -58,11 +58,13 @@ \\ \" + 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 ] ] diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -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 @@ \" 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 ] []) , ("\ @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 + ]