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