From ab2c6b0b020e10cc41f88c6e1fd9407bfb618fea Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Fri, 16 Oct 2020 17:08:34 -0700 Subject: [PATCH 01/24] Bump up version for new release (#158) --- CHANGELOG.md | 7 +++++++ minio-hs.cabal | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ed767c9..2fb715c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,13 @@ Changelog ========== +## Version 1.5.3 + +* Fix windows build +* Fix support for Yandex Storage (#147) +* Fix for HEAD requests to S3/Minio (#155) +* Bump up some dependencies, new code formatting, Github CI, example fixes and other minor improvements. + ## Version 1.5.2 * Fix region `us-west-2` for AWS S3 (#139) diff --git a/minio-hs.cabal b/minio-hs.cabal index 18183cb..de76b9e 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: minio-hs -version: 1.5.2 +version: 1.5.3 synopsis: A MinIO Haskell Library for Amazon S3 compatible cloud storage. description: The MinIO Haskell client library provides simple APIs to From 5ab80384ae533ed9f5904737f3f80e285dc22847 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Tue, 5 Jan 2021 12:30:28 -0800 Subject: [PATCH 02/24] Fix Actions CI (#159) --- .github/workflows/haskell-cabal.yml | 2 +- .github/workflows/haskell-stack.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/haskell-cabal.yml b/.github/workflows/haskell-cabal.yml index 147d760..afd98cf 100644 --- a/.github/workflows/haskell-cabal.yml +++ b/.github/workflows/haskell-cabal.yml @@ -42,7 +42,7 @@ jobs: steps: - uses: actions/checkout@v2 - - uses: actions/setup-haskell@v1.1 + - uses: haskell/actions/setup@v1 with: ghc-version: ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} diff --git a/.github/workflows/haskell-stack.yml b/.github/workflows/haskell-stack.yml index c8518fa..9496b6e 100644 --- a/.github/workflows/haskell-stack.yml +++ b/.github/workflows/haskell-stack.yml @@ -29,7 +29,7 @@ jobs: steps: - uses: actions/checkout@v2 - - uses: actions/setup-haskell@v1.1 + - uses: haskell/actions/setup@v1 with: ghc-version: ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} From 73bc5b64a08992700d160d8b5450e89aedf54396 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Wed, 3 Mar 2021 15:44:12 -0800 Subject: [PATCH 03/24] Fix XML generation test for S3 SELECT (#161) - Test was failing because of non-unique ordering of CSV properties. It is fixed by sorting the CSV properties before serialization. --- src/Network/Minio/Data.hs | 22 ++++++---- src/Network/Minio/XmlGenerator.hs | 32 +++++++------- test/Network/Minio/XmlGenerator/Test.hs | 57 +++++++++++++------------ 3 files changed, 59 insertions(+), 52 deletions(-) diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index b4d12b2..1584e3d 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -155,11 +155,13 @@ fromAWSConfigFile = do bool (throwE "FileNotFound") (return ()) fileExists ini <- ExceptT $ Ini.readIniFile awsCredsFile akey <- - ExceptT $ return $ - Ini.lookupValue "default" "aws_access_key_id" ini + ExceptT $ + return $ + Ini.lookupValue "default" "aws_access_key_id" ini skey <- - ExceptT $ return $ - Ini.lookupValue "default" "aws_secret_access_key" ini + ExceptT $ + return $ + Ini.lookupValue "default" "aws_secret_access_key" ini return $ Credentials akey skey return $ hush credsE @@ -856,6 +858,9 @@ instance Monoid CSVProp where mappend (CSVProp a) (CSVProp b) = CSVProp (b <> a) #endif +csvPropsList :: CSVProp -> [(Text, Text)] +csvPropsList (CSVProp h) = sort $ H.toList h + defaultCSVProp :: CSVProp defaultCSVProp = mempty @@ -929,10 +934,11 @@ type CSVOutputProp = CSVProp -- | quoteFields is an output serialization parameter quoteFields :: QuoteFields -> CSVProp -quoteFields q = CSVProp $ H.singleton "QuoteFields" $ - case q of - QuoteFieldsAsNeeded -> "ASNEEDED" - QuoteFieldsAlways -> "ALWAYS" +quoteFields q = CSVProp $ + H.singleton "QuoteFields" $ + case q of + QuoteFieldsAsNeeded -> "ASNEEDED" + QuoteFieldsAlways -> "ALWAYS" -- | Represent the QuoteField setting. data QuoteFields = QuoteFieldsAsNeeded | QuoteFieldsAlways diff --git a/src/Network/Minio/XmlGenerator.hs b/src/Network/Minio/XmlGenerator.hs index 8c30426..3efe1b7 100644 --- a/src/Network/Minio/XmlGenerator.hs +++ b/src/Network/Minio/XmlGenerator.hs @@ -23,7 +23,6 @@ module Network.Minio.XmlGenerator where import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashMap.Strict as H import qualified Data.Text as T import Lib.Prelude import Network.Minio.Data @@ -77,8 +76,9 @@ data XNode toXML :: Text -> XNode -> ByteString toXML ns node = - LBS.toStrict $ renderLBS def $ - Document (Prologue [] Nothing []) (xmlNode node) [] + LBS.toStrict $ + renderLBS def $ + Document (Prologue [] Nothing []) (xmlNode node) [] where xmlNode :: XNode -> Element xmlNode (XNode name nodes) = @@ -143,14 +143,14 @@ mkSelectRequest r = LBS.toStrict $ renderLBS def sr [NodeContent $ show $ srExpressionType r] ), NodeElement - ( Element "InputSerialization" mempty - $ inputSerializationNodes - $ srInputSerialization r + ( Element "InputSerialization" mempty $ + inputSerializationNodes $ + srInputSerialization r ), NodeElement - ( Element "OutputSerialization" mempty - $ outputSerializationNodes - $ srOutputSerialization r + ( Element "OutputSerialization" mempty $ + outputSerializationNodes $ + srOutputSerialization r ) ] ++ maybe [] reqProgElem (srRequestProgressEnabled r) @@ -186,11 +186,11 @@ mkSelectRequest r = LBS.toStrict $ renderLBS def sr ] comprTypeNode Nothing = [] kvElement (k, v) = Element (Name k Nothing Nothing) mempty [NodeContent v] - formatNode (InputFormatCSV (CSVProp h)) = + formatNode (InputFormatCSV c) = Element "CSV" mempty - (map NodeElement $ map kvElement $ H.toList h) + (map NodeElement $ map kvElement $ csvPropsList c) formatNode (InputFormatJSON p) = Element "JSON" @@ -208,17 +208,17 @@ mkSelectRequest r = LBS.toStrict $ renderLBS def sr formatNode InputFormatParquet = Element "Parquet" mempty [] outputSerializationNodes (OutputSerializationJSON j) = [ NodeElement - ( Element "JSON" mempty - $ rdElem - $ jsonopRecordDelimiter j + ( Element "JSON" mempty $ + rdElem $ + jsonopRecordDelimiter j ) ] - outputSerializationNodes (OutputSerializationCSV (CSVProp h)) = + outputSerializationNodes (OutputSerializationCSV c) = [ NodeElement $ Element "CSV" mempty - (map NodeElement $ map kvElement $ H.toList h) + (map NodeElement $ map kvElement $ csvPropsList c) ] rdElem Nothing = [] rdElem (Just t) = diff --git a/test/Network/Minio/XmlGenerator/Test.hs b/test/Network/Minio/XmlGenerator/Test.hs index d34bcf2..c32852e 100644 --- a/test/Network/Minio/XmlGenerator/Test.hs +++ b/test/Network/Minio/XmlGenerator/Test.hs @@ -90,11 +90,12 @@ testMkPutNotificationRequest = "1" "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue" [ObjectCreatedPut] - ( Filter $ FilterKey $ - FilterRules - [ FilterRule "prefix" "images/", - FilterRule "suffix" ".jpg" - ] + ( Filter $ + FilterKey $ + FilterRules + [ FilterRule "prefix" "images/", + FilterRule "suffix" ".jpg" + ] ), NotificationConfig "" @@ -142,32 +143,32 @@ testMkSelectRequest = mapM_ assertFn cases <> quoteEscapeCharacter "\"" ) (Just False), - [r|Select * from S3ObjectSQLGZIP" -IGNORE","ASNEEDED -",FALSE|] + [r|Select * from S3ObjectSQLGZIP,IGNORE"" +,""ASNEEDED +FALSE|] ), - ( setRequestProgressEnabled False - $ setInputCompressionType CompressionTypeGzip - $ selectRequest - "Select * from S3Object" - documentJsonInput - (outputJSONFromRecordDelimiter "\n"), + ( 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 -",FALSE|] + ( setRequestProgressEnabled False $ + setInputCompressionType CompressionTypeNone $ + selectRequest + "Select * from S3Object" + defaultParquetInput + ( outputCSVFromProps $ + quoteFields QuoteFieldsAsNeeded + <> recordDelimiter "\n" + <> fieldDelimiter "," + <> quoteCharacter "\"" + <> quoteEscapeCharacter "\"" + ), + [r|Select * from S3ObjectSQLNONE,""ASNEEDED +FALSE|] ) ] From b8cc1e57eecf717c8c0e4645680d9b1bc03201f9 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Wed, 3 Mar 2021 16:11:45 -0800 Subject: [PATCH 04/24] Update formatting with latest ormolu 1.4 (#163) --- examples/ListIncompleteUploads.hs | 6 +- examples/ListObjects.hs | 6 +- examples/PresignedPostPolicy.hs | 5 +- src/Network/Minio.hs | 1 + src/Network/Minio/API.hs | 18 +-- src/Network/Minio/AdminAPI.hs | 17 +-- src/Network/Minio/CopyObject.hs | 10 +- src/Network/Minio/Data/ByteString.hs | 6 +- src/Network/Minio/JsonParser.hs | 4 +- src/Network/Minio/ListOps.hs | 35 ++--- src/Network/Minio/PresignedOperations.hs | 35 +++-- src/Network/Minio/S3API.hs | 172 ++++++++++++----------- src/Network/Minio/Sign/V4.hs | 20 +-- src/Network/Minio/Utils.hs | 16 ++- src/Network/Minio/XmlParser.hs | 6 +- test/LiveServer.hs | 68 ++++----- test/Network/Minio/API/Test.hs | 15 +- test/Network/Minio/JsonParser/Test.hs | 6 +- test/Network/Minio/XmlParser/Test.hs | 17 +-- 19 files changed, 249 insertions(+), 214 deletions(-) diff --git a/examples/ListIncompleteUploads.hs b/examples/ListIncompleteUploads.hs index b41da7a..4b17389 100755 --- a/examples/ListIncompleteUploads.hs +++ b/examples/ListIncompleteUploads.hs @@ -34,9 +34,9 @@ main = do -- 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)) + runMinio minioPlayCI $ + runConduit $ + listIncompleteUploads bucket Nothing True .| mapM_C (\v -> (liftIO $ print v)) print res {- diff --git a/examples/ListObjects.hs b/examples/ListObjects.hs index 924615f..a25917e 100755 --- a/examples/ListObjects.hs +++ b/examples/ListObjects.hs @@ -34,9 +34,9 @@ main = do -- 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)) + runMinio minioPlayCI $ + runConduit $ + listObjects bucket Nothing True .| mapM_C (\v -> (liftIO $ print v)) print res {- diff --git a/examples/PresignedPostPolicy.hs b/examples/PresignedPostPolicy.hs index 310a188..05d1d4d 100755 --- a/examples/PresignedPostPolicy.hs +++ b/examples/PresignedPostPolicy.hs @@ -73,8 +73,9 @@ main = do ] formOptions = B.intercalate " " $ map formFn $ H.toList formData - return $ B.intercalate " " $ - ["curl", formOptions, "-F file=@/tmp/photo.jpg", url] + return $ + B.intercalate " " $ + ["curl", formOptions, "-F file=@/tmp/photo.jpg", url] case res of Left e -> putStrLn $ "post-policy error: " ++ (show e) diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 5642945..7a30d9e 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -55,6 +55,7 @@ module Network.Minio gcsCI, -- * Minio Monad + ---------------- -- | The Minio Monad provides connection-reuse, bucket-location diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index 7444218..eb8d113 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -186,9 +186,9 @@ buildRequest ri = do retryAPIRequest :: Minio a -> Minio a retryAPIRequest apiCall = do resE <- - retrying retryPolicy (const shouldRetry) - $ const - $ try apiCall + retrying retryPolicy (const shouldRetry) $ + const $ + try apiCall either throwIO return resE where -- Retry using the full-jitter backoff method for up to 10 mins @@ -266,9 +266,9 @@ isValidBucketName bucket = -- 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 = @@ -276,6 +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/AdminAPI.hs b/src/Network/Minio/AdminAPI.hs index dcada23..3c338ec 100644 --- a/src/Network/Minio/AdminAPI.hs +++ b/src/Network/Minio/AdminAPI.hs @@ -16,7 +16,8 @@ module Network.Minio.AdminAPI ( -- * MinIO Admin API - -------------------- + + -------------------- -- | Provides MinIO admin API and related types. It is in -- experimental state. @@ -52,10 +53,7 @@ module Network.Minio.AdminAPI where import Data.Aeson - ( (.:), - (.:?), - (.=), - FromJSON, + ( FromJSON, ToJSON, Value (Object), eitherDecode, @@ -66,6 +64,9 @@ import Data.Aeson toJSON, withObject, withText, + (.:), + (.:?), + (.=), ) import qualified Data.Aeson as A import Data.Aeson.Types (typeMismatch) @@ -610,9 +611,9 @@ buildAdminRequest areq = do areq { ariPayloadHash = Just sha256Hash, ariHeaders = - hostHeader - : sha256Header sha256Hash - : ariHeaders areq + hostHeader : + sha256Header sha256Hash : + ariHeaders areq } signReq = toRequest ci newAreq sp = diff --git a/src/Network/Minio/CopyObject.hs b/src/Network/Minio/CopyObject.hs index 36c4443..c5adaaa 100644 --- a/src/Network/Minio/CopyObject.hs +++ b/src/Network/Minio/CopyObject.hs @@ -51,8 +51,8 @@ copyObjectInternal b' o srcInfo = do endOffset >= fromIntegral srcSize ] ) - $ throwIO - $ MErrVInvalidSrcObjByteRange range + $ throwIO $ + MErrVInvalidSrcObjByteRange range -- 1. If sz > 64MiB (minPartSize) use multipart copy, OR -- 2. If startOffset /= 0 use multipart copy @@ -69,9 +69,9 @@ copyObjectInternal b' o srcInfo = do -- 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 + 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 diff --git a/src/Network/Minio/Data/ByteString.hs b/src/Network/Minio/Data/ByteString.hs index 00ddb22..09e68d5 100644 --- a/src/Network/Minio/Data/ByteString.hs +++ b/src/Network/Minio/Data/ByteString.hs @@ -38,8 +38,10 @@ class UriEncodable s where instance UriEncodable [Char] where uriEncode encodeSlash payload = - LB.toStrict $ BB.toLazyByteString $ mconcat $ - map (`uriEncodeChar` encodeSlash) payload + LB.toStrict $ + BB.toLazyByteString $ + mconcat $ + map (`uriEncodeChar` encodeSlash) payload instance UriEncodable ByteString where -- assumes that uriEncode is passed ASCII encoded strings. diff --git a/src/Network/Minio/JsonParser.hs b/src/Network/Minio/JsonParser.hs index 901fd8e..9d0ce46 100644 --- a/src/Network/Minio/JsonParser.hs +++ b/src/Network/Minio/JsonParser.hs @@ -20,11 +20,11 @@ module Network.Minio.JsonParser where import Data.Aeson - ( (.:), - FromJSON, + ( FromJSON, eitherDecode, parseJSON, withObject, + (.:), ) import qualified Data.Text as T import Lib.Prelude diff --git a/src/Network/Minio/ListOps.hs b/src/Network/Minio/ListOps.hs index 42050ec..723370c 100644 --- a/src/Network/Minio/ListOps.hs +++ b/src/Network/Minio/ListOps.hs @@ -51,10 +51,10 @@ listObjects bucket prefix recurse = loop Nothing 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) @@ -73,10 +73,10 @@ listObjectsV1 bucket prefix recurse = loop Nothing 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) @@ -104,19 +104,20 @@ listIncompleteUploads bucket prefix recurse = loop Nothing Nothing 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 + 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 - CL.sourceList - $ map + CL.sourceList $ + map ( \((uKey, uId, uInitTime), size) -> UploadInfo uKey uId uInitTime size ) - $ zip (lurUploads res) aggrSizes + $ zip (lurUploads res) aggrSizes when (lurHasMore res) $ loop (lurNextKey res) (lurNextUpload res) diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs index 9c7f37f..81bafa8 100644 --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -68,9 +68,9 @@ makePresignedUrl :: 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 @@ -103,11 +103,13 @@ makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do ((HT.parseQuery $ NC.queryString req) ++ qpToAdd) scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci - return $ toStrictBS $ 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 @@ -331,18 +333,21 @@ presignedPostPolicy p = do mkPair (PPCEquals k v) = Just (k, v) mkPair _ = Nothing formFromPolicy = - H.map toUtf8 $ H.fromList $ catMaybes $ - mkPair <$> conditions ppWithCreds + 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 "/" + toStrictBS $ + toLazyByteString $ + scheme <> byteString (getHostAddr ci) + <> byteString "/" + <> byteString bucket + <> byteString "/" return (url, formData) diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index f016951..38dfe47 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -19,10 +19,12 @@ module Network.Minio.S3API getLocation, -- * Listing buckets + -------------------- getService, -- * Listing objects + -------------------- ListObjectsResult (..), ListObjectsV1Result (..), @@ -33,11 +35,13 @@ module Network.Minio.S3API headBucket, -- * Retrieving objects + ----------------------- getObject', headObject, -- * Creating buckets and objects + --------------------------------- putBucket, ETag, @@ -47,6 +51,7 @@ module Network.Minio.S3API copyObjectSingle, -- * Multipart Upload APIs + -------------------------- UploadId, PartTuple, @@ -63,11 +68,13 @@ module Network.Minio.S3API listIncompleteParts', -- * Deletion APIs + -------------------------- deleteBucket, deleteObject, -- * Presigned Operations + ----------------------------- module Network.Minio.PresignedOperations, @@ -76,6 +83,7 @@ module Network.Minio.S3API setBucketPolicy, -- * Bucket Notifications + ------------------------- Notification (..), NotificationConfig (..), @@ -157,24 +165,26 @@ getObject' bucket object queryParams headers = do { riBucket = Just bucket, riObject = Just object, riQueryParams = queryParams, - riHeaders = headers - -- This header is required for safety as otherwise http-client, - -- sends Accept-Encoding: gzip, and the server may actually gzip - -- body. In that case Content-Length header will be missing. - <> [("Accept-Encoding", "identity")] + riHeaders = + headers + -- This header is required for safety as otherwise http-client, + -- sends Accept-Encoding: gzip, and the server may actually gzip + -- body. In that case Content-Length header will be missing. + <> [("Accept-Encoding", "identity")] } -- | Creates a bucket via a PUT bucket call. putBucket :: Bucket -> Region -> Minio () putBucket bucket location = do ns <- asks getSvcNamespace - void $ executeRequest $ - defaultS3ReqInfo - { riMethod = HT.methodPut, - riBucket = Just bucket, - riPayload = PayloadBS $ mkCreateBucketConfig ns location, - riNeedsLocation = False - } + void $ + executeRequest $ + defaultS3ReqInfo + { riMethod = HT.methodPut, + riBucket = Just bucket, + riPayload = PayloadBS $ mkCreateBucketConfig ns location, + riNeedsLocation = False + } -- | Single PUT object size. maxSinglePutObjectSizeBytes :: Int64 @@ -188,9 +198,9 @@ 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 <- @@ -222,9 +232,9 @@ putObjectSingle :: 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 @@ -301,23 +311,23 @@ listObjects' bucket prefix nextToken delimiter maxKeys = do -- | DELETE a bucket from the service. deleteBucket :: Bucket -> Minio () deleteBucket bucket = - void - $ executeRequest - $ defaultS3ReqInfo - { riMethod = HT.methodDelete, - riBucket = Just 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 - } + void $ + executeRequest $ + defaultS3ReqInfo + { riMethod = HT.methodDelete, + riBucket = Just bucket, + riObject = Just object + } -- | Create a new multipart upload. newMultipartUpload :: Bucket -> Object -> [HT.Header] -> Minio UploadId @@ -377,8 +387,8 @@ srcInfoToHeaders srcInfo = "/", srcObject srcInfo ] - ) - : rangeHdr + ) : + rangeHdr ++ zip names values where names = @@ -477,14 +487,14 @@ completeMultipartUpload bucket object uploadId partTuple = do -- | 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 - } + void $ + executeRequest $ + defaultS3ReqInfo + { riMethod = HT.methodDelete, + riBucket = Just bucket, + riObject = Just object, + riQueryParams = mkOptionalParams params + } where params = [("uploadId", Just uploadId)] @@ -509,14 +519,14 @@ listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker maxKeys where -- build query params params = - ("uploads", Nothing) - : mkOptionalParams - [ ("prefix", prefix), - ("delimiter", delimiter), - ("key-marker", keyMarker), - ("upload-id-marker", uploadIdMarker), - ("max-uploads", show <$> maxKeys) - ] + ("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' :: @@ -553,15 +563,16 @@ headObject bucket object reqHeaders = do { riMethod = HT.methodHead, riBucket = Just bucket, riObject = Just object, - riHeaders = reqHeaders - -- This header is required for safety as otherwise http-client, - -- sends Accept-Encoding: gzip, and the server may actually gzip - -- body. In that case Content-Length header will be missing. - <> [("Accept-Encoding", "identity")] + riHeaders = + reqHeaders + -- This header is required for safety as otherwise http-client, + -- sends Accept-Encoding: gzip, and the server may actually gzip + -- body. In that case Content-Length header will be missing. + <> [("Accept-Encoding", "identity")] } - maybe (throwIO MErrVInvalidObjectInfoResponse) return - $ parseGetObjectHeaders object - $ NC.responseHeaders resp + maybe (throwIO MErrVInvalidObjectInfoResponse) return $ + parseGetObjectHeaders object $ + NC.responseHeaders resp -- | Query the object store if a given bucket exists. headBucket :: Bucket -> Minio Bool @@ -594,15 +605,16 @@ headBucket 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 @@ -644,20 +656,22 @@ setBucketPolicy bucket policy = do -- | Save a new policy on a bucket. putBucketPolicy :: Bucket -> Text -> Minio () putBucketPolicy bucket policy = do - void $ executeRequest $ - defaultS3ReqInfo - { riMethod = HT.methodPut, - 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 = 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/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 6f3e7aa..923d946 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -198,14 +198,14 @@ mkCanonicalRequest :: 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) + 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 $ @@ -298,8 +298,8 @@ signV4Stream !payloadLength !sp !req = in case ceMay of Nothing -> ("content-encoding", "aws-chunked") : hs Just (_, ce) -> - ("content-encoding", ce <> ",aws-chunked") - : filter (\(x, _) -> x /= "content-encoding") hs + ("content-encoding", ce <> ",aws-chunked") : + filter (\(x, _) -> x /= "content-encoding") hs -- headers to be added to the request datePair = ("X-Amz-Date", awsTimeFormatBS ts) computedHeaders = diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index 79f2c0f..769f5a7 100644 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -170,8 +170,9 @@ httpLbs req mgr = do sErr <- parseErrResponseJSON $ NC.responseBody resp throwIO sErr _ -> - throwIO $ NC.HttpExceptionRequest req $ - NC.StatusCodeException (void resp) (showBS resp) + throwIO $ + NC.HttpExceptionRequest req $ + NC.StatusCodeException (void resp) (showBS resp) return resp where @@ -199,8 +200,9 @@ http req mgr = do throwIO sErr _ -> do content <- LB.toStrict . NC.responseBody <$> NC.lbsResponse resp - throwIO $ NC.HttpExceptionRequest req $ - NC.StatusCodeException (void resp) content + throwIO $ + NC.HttpExceptionRequest req $ + NC.StatusCodeException (void resp) content return resp where @@ -265,9 +267,9 @@ chunkBSConduit (s : ss) = do -- be 64MiB. selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)] selectPartSizes size = - uncurry (List.zip3 [1 ..]) - $ List.unzip - $ loop 0 size + uncurry (List.zip3 [1 ..]) $ + List.unzip $ + loop 0 size where ceil :: Double -> Int64 ceil = ceiling diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index 8ecd36a..fb97874 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -56,9 +56,9 @@ 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 = diff --git a/test/LiveServer.hs b/test/LiveServer.hs index f0fa3ae..b07fcc2 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -134,12 +134,12 @@ basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do step "getService works and contains the test bucket." buckets <- getService - unless (length (filter (== bucket) $ map biName buckets) == 1) - $ 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 @@ -361,22 +361,24 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $ step "High-level listing of objects" items <- C.runConduit $ listObjects bucket Nothing False C..| sinkList - liftIO $ assertEqual "Objects/Dirs match failed!" expectedNonRecList $ - extractObjectsAndDirsFromList items + liftIO $ + assertEqual "Objects/Dirs match failed!" expectedNonRecList $ + extractObjectsAndDirsFromList items step "High-level recursive listing of objects" objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList - liftIO - $ assertEqual + liftIO $ + assertEqual "Objects match failed!" (Just $ sort expectedObjects) - $ extractObjectsFromList objects + $ 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 + liftIO $ + assertEqual "Objects/Dirs match failed!" expectedNonRecList $ + extractObjectsAndDirsFromList itemsV1 step "High-level recursive listing of objects (version 1)" objectsV1 <- @@ -384,45 +386,45 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $ listObjectsV1 bucket Nothing True C..| sinkList - liftIO - $ assertEqual + liftIO $ + assertEqual "Objects match failed!" (Just $ sort expectedObjects) - $ extractObjectsFromList objectsV1 + $ 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 + liftIO $ + assertEqual "Objects/Dirs under prefix match failed!" expectedPrefListing - $ extractObjectsAndDirsFromList prefItems + $ extractObjectsAndDirsFromList prefItems step "High-level listing with prefix recursive" prefItemsRec <- C.runConduit $ listObjects bucket (Just "dir/") True C..| sinkList - liftIO - $ assertEqual + liftIO $ + assertEqual "Objects/Dirs under prefix match recursive failed!" expectedPrefListingRec - $ extractObjectsFromList prefItemsRec + $ extractObjectsFromList prefItemsRec step "High-level listing with prefix (version 1)" prefItemsV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") False C..| sinkList - liftIO - $ assertEqual + liftIO $ + assertEqual "Objects/Dirs under prefix match failed!" expectedPrefListing - $ extractObjectsAndDirsFromList prefItemsV1 + $ extractObjectsAndDirsFromList prefItemsV1 step "High-level listing with prefix recursive (version 1)" prefItemsRecV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") True C..| sinkList - liftIO - $ assertEqual + liftIO $ + assertEqual "Objects/Dirs under prefix match recursive failed!" expectedPrefListingRec - $ extractObjectsFromList prefItemsRecV1 + $ extractObjectsFromList prefItemsRecV1 step "Cleanup actions" forM_ expectedObjects $ @@ -910,8 +912,9 @@ putObjectUserMetadataTest = funTestWithBucket "putObject user-metadata test" $ 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 + sort $ + map (\(k, v) -> (T.toLower k, T.toLower v)) $ + H.toList m ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")] liftIO $ (sortedMeta == ref) @? "Metadata mismatch!" @@ -944,8 +947,9 @@ getObjectTest = funTestWithBucket "getObject test" $ 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 + sort $ + map (\(k, v) -> (T.toLower k, T.toLower v)) $ + H.toList m ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")] liftIO $ (sortedMeta == ref) @? "Metadata mismatch!" diff --git a/test/Network/Minio/API/Test.hs b/test/Network/Minio/API/Test.hs index 7b9b9d6..e35b8a8 100644 --- a/test/Network/Minio/API/Test.hs +++ b/test/Network/Minio/API/Test.hs @@ -63,8 +63,9 @@ parseServerInfoJSONTest = testGroup "Parse MinIO Admin API ServerInfo JSON test" $ map ( \(tName, tDesc, tfn, tVal) -> - testCase tName $ assertBool tDesc $ - tfn (eitherDecode tVal :: Either [Char] [ServerInfo]) + testCase tName $ + assertBool tDesc $ + tfn (eitherDecode tVal :: Either [Char] [ServerInfo]) ) testCases where @@ -82,8 +83,9 @@ parseHealStatusTest = testGroup "Parse MinIO Admin API HealStatus JSON test" $ map ( \(tName, tDesc, tfn, tVal) -> - testCase tName $ assertBool tDesc $ - tfn (eitherDecode tVal :: Either [Char] HealStatus) + testCase tName $ + assertBool tDesc $ + tfn (eitherDecode tVal :: Either [Char] HealStatus) ) testCases where @@ -101,8 +103,9 @@ parseHealStartRespTest = testGroup "Parse MinIO Admin API HealStartResp JSON test" $ map ( \(tName, tDesc, tfn, tVal) -> - testCase tName $ assertBool tDesc $ - tfn (eitherDecode tVal :: Either [Char] HealStartResp) + testCase tName $ + assertBool tDesc $ + tfn (eitherDecode tVal :: Either [Char] HealStartResp) ) testCases where diff --git a/test/Network/Minio/JsonParser/Test.hs b/test/Network/Minio/JsonParser/Test.hs index a60a209..fbf4102 100644 --- a/test/Network/Minio/JsonParser/Test.hs +++ b/test/Network/Minio/JsonParser/Test.hs @@ -43,9 +43,9 @@ 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 diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs index f2ad52a..65aac09 100644 --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -62,9 +62,9 @@ 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 @@ -344,11 +344,12 @@ testParseNotification = do "1" "arn:aws:sqs:us-west-2:444455556666:s3notificationqueue" [ObjectCreatedPut] - ( Filter $ FilterKey $ - FilterRules - [ FilterRule "prefix" "images/", - FilterRule "suffix" ".jpg" - ] + ( Filter $ + FilterKey $ + FilterRules + [ FilterRule "prefix" "images/", + FilterRule "suffix" ".jpg" + ] ), NotificationConfig "" From aa2382b2e9503a16d00e9c71f2f2d0ebb14186c4 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Mon, 8 Mar 2021 16:35:52 -0800 Subject: [PATCH 05/24] Use region specific endpoints for AWS S3 in presigned Urls (#164) - Also update standard S3 endpoints - Unify code that determines if path style or virtual style must be used for regular and presigned requests Fixes #160 --- minio-hs.cabal | 1 + src/Network/Minio/API.hs | 116 ++++++++++++++++------- src/Network/Minio/APICommon.hs | 8 ++ src/Network/Minio/Data.hs | 37 ++++---- src/Network/Minio/Data/Time.hs | 5 + src/Network/Minio/PresignedOperations.hs | 53 ++++------- src/Network/Minio/Sign/V4.hs | 2 +- test/LiveServer.hs | 1 - 8 files changed, 132 insertions(+), 91 deletions(-) diff --git a/minio-hs.cabal b/minio-hs.cabal index de76b9e..3cda739 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -77,6 +77,7 @@ common base-settings , http-types >= 0.12 , ini , memory >= 0.14 + , network-uri , raw-strings-qq >= 1 , resourcet >= 1.2 , retry diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index eb8d113..2d9d49b 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -19,6 +19,7 @@ module Network.Minio.API S3ReqInfo (..), runMinio, executeRequest, + buildRequest, mkStreamRequest, getLocation, isValidBucketName, @@ -40,6 +41,7 @@ import qualified Data.HashMap.Strict as H import qualified Data.Text as T import qualified Data.Time.Clock as Time import Lib.Prelude +import qualified Network.HTTP.Client as NClient import Network.HTTP.Conduit (Response) import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT @@ -78,6 +80,7 @@ discoverRegion ri = runMaybeT $ do return regionMay +-- | Returns the region to be used for the request. getRegion :: S3ReqInfo -> Minio (Maybe Region) getRegion ri = do ci <- asks mcConnInfo @@ -104,6 +107,42 @@ getRegionHost r = do (H.lookup r awsRegionMap) else return $ connectHost ci +-- | Computes the appropriate host, path and region for the request. +-- +-- For AWS, always use virtual bucket style, unless bucket has periods. For +-- MinIO and other non-AWS, default to path style. +getHostPathRegion :: S3ReqInfo -> Minio (Text, ByteString, Maybe Region) +getHostPathRegion ri = do + ci <- asks mcConnInfo + regionMay <- getRegion ri + case riBucket ri of + Nothing -> + -- Implies a ListBuckets request. + return (connectHost ci, "/", regionMay) + Just bucket -> do + regionHost <- case regionMay of + Nothing -> return $ connectHost ci + Just "" -> return $ connectHost ci + Just r -> getRegionHost r + let pathStyle = + ( regionHost, + getS3Path (riBucket ri) (riObject ri), + regionMay + ) + virtualStyle = + ( ( bucket <> "." <> regionHost, + encodeUtf8 $ "/" <> fromMaybe "" (riObject ri), + regionMay + ) + ) + if + | isAWSConnectInfo ci -> + return $ + if bucketHasPeriods bucket + then pathStyle + else virtualStyle + | otherwise -> return pathStyle + buildRequest :: S3ReqInfo -> Minio NC.Request buildRequest ri = do maybe (return ()) checkBucketNameValidity $ riBucket ri @@ -111,17 +150,15 @@ buildRequest ri = do ci <- asks mcConnInfo - regionMay <- getRegion ri + (host, path, regionMay) <- getHostPathRegion ri - regionHost <- maybe (return $ connectHost ci) getRegionHost regionMay - - let ri' = + let ci' = ci {connectHost = host} + hostHeader = (hHost, getHostAddr ci') + 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 @@ -129,7 +166,7 @@ buildRequest ri = do NC.secure = connectIsSecure ci', NC.host = encodeUtf8 $ connectHost ci', NC.port = connectPort ci', - NC.path = getS3Path (riBucket ri') (riObject ri'), + NC.path = path, NC.requestHeaders = riHeaders ri', NC.queryString = HT.renderQuery False $ riQueryParams ri' } @@ -142,11 +179,13 @@ buildRequest ri = do (connectSecretKey ci') timeStamp (riRegion ri') - Nothing + (riPresignExpirySecs ri') Nothing -- Cases to handle: -- + -- 0. Handle presign URL case. + -- -- 1. Connection is secure: use unsigned payload -- -- 2. Insecure connection, streaming signature is enabled via use of @@ -155,33 +194,44 @@ buildRequest ri = do -- 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} + | isJust (riPresignExpirySecs ri') -> + -- case 0 from above. + do + let signPairs = signV4 sp baseRequest + qpToAdd = (fmap . fmap) Just signPairs + existingQueryParams = HT.parseQuery (NC.queryString baseRequest) + updatedQueryParams = existingQueryParams ++ qpToAdd + return $ NClient.setQueryString updatedQueryParams baseRequest + | isStreamingPayload (riPayload ri') && (not $ connectIsSecure ci') -> + -- case 2 from above. + 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 + sp' <- + if + | connectIsSecure ci' -> + -- case 1 described above. + return sp + | otherwise -> + -- case 3 described above. + 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') - } + 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 diff --git a/src/Network/Minio/APICommon.hs b/src/Network/Minio/APICommon.hs index 6ea8717..992a9b5 100644 --- a/src/Network/Minio/APICommon.hs +++ b/src/Network/Minio/APICommon.hs @@ -20,6 +20,7 @@ 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 Data.Text as T import Lib.Prelude import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT @@ -70,3 +71,10 @@ mkStreamingPayload payload = isStreamingPayload :: Payload -> Bool isStreamingPayload (PayloadC _ _) = True isStreamingPayload _ = False + +-- | Checks if the connect info is for Amazon S3. +isAWSConnectInfo :: ConnectInfo -> Bool +isAWSConnectInfo ci = ".amazonaws.com" `T.isSuffixOf` connectHost ci + +bucketHasPeriods :: Bucket -> Bool +bucketHasPeriods b = isJust $ T.find (== '.') b diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 1584e3d..389efb9 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -49,6 +49,7 @@ import Network.HTTP.Types ) import qualified Network.HTTP.Types as HT import Network.Minio.Data.Crypto +import Network.Minio.Data.Time import Network.Minio.Errors import System.Directory (doesFileExist, getHomeDirectory) import qualified System.Environment as Env @@ -79,20 +80,20 @@ maxMultipartParts = 10000 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") + [ ("us-east-1", "s3.us-east-1.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, @@ -1022,7 +1023,8 @@ data S3ReqInfo = S3ReqInfo riPayload :: Payload, riPayloadHash :: Maybe ByteString, riRegion :: Maybe Region, - riNeedsLocation :: Bool + riNeedsLocation :: Bool, + riPresignExpirySecs :: Maybe UrlExpiry } defaultS3ReqInfo :: S3ReqInfo @@ -1037,16 +1039,13 @@ defaultS3ReqInfo = Nothing Nothing True + Nothing getS3Path :: Maybe Bucket -> Maybe Object -> ByteString getS3Path b o = let segments = map toUtf8 $ catMaybes $ b : bool [] [o] (isJust b) in B.concat ["/", B.intercalate "/" segments] --- | Time to expire for a presigned URL. It interpreted as a number of --- seconds. The maximum duration that can be specified is 7 days. -type UrlExpiry = Int - type RegionMap = H.HashMap Bucket Region -- | The Minio Monad - all computations accessing object storage diff --git a/src/Network/Minio/Data/Time.hs b/src/Network/Minio/Data/Time.hs index aec713d..c2699e4 100644 --- a/src/Network/Minio/Data/Time.hs +++ b/src/Network/Minio/Data/Time.hs @@ -21,6 +21,7 @@ module Network.Minio.Data.Time awsDateFormatBS, awsParseTime, iso8601TimeFormat, + UrlExpiry, ) where @@ -28,6 +29,10 @@ import Data.ByteString.Char8 (pack) import qualified Data.Time as Time import Lib.Prelude +-- | Time to expire for a presigned URL. It interpreted as a number of +-- seconds. The maximum duration that can be specified is 7 days. +type UrlExpiry = Int + awsTimeFormat :: UTCTime -> [Char] awsTimeFormat = Time.formatTime Time.defaultTimeLocale "%Y%m%dT%H%M%SZ" diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs index 81bafa8..8e753ea 100644 --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -42,13 +42,14 @@ 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.Client as NClient import qualified Network.HTTP.Types as HT -import Network.HTTP.Types.Header (hHost) +import Network.Minio.API (buildRequest) import Network.Minio.Data import Network.Minio.Data.Time import Network.Minio.Errors import Network.Minio.Sign.V4 +import Network.URI (uriToString) -- | Generate a presigned URL. This function allows for advanced usage -- - for simple cases prefer the `presigned*Url` functions. @@ -72,44 +73,22 @@ makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do 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 s3ri = + defaultS3ReqInfo + { riPresignExpirySecs = Just expiry, + riMethod = method, + riBucket = bucket, + riObject = object, + riRegion = region, + riQueryParams = extraQuery, + riHeaders = extraHeaders } - ts <- liftIO Time.getCurrentTime - 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) - scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci + req <- buildRequest s3ri + let uri = NClient.getUri req + uriString = uriToString identity uri "" - return $ - toStrictBS $ - toLazyByteString $ - scheme - <> byteString (getHostAddr ci) - <> byteString (getS3Path bucket object) - <> queryStr + return $ toUtf8 uriString -- | Generate a URL with authentication signature to PUT (upload) an -- object. Any extra headers if passed, are signed, and so they are diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 923d946..0d183c5 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -65,7 +65,7 @@ data SignParams = SignParams spSecretKey :: Text, spTimeStamp :: UTCTime, spRegion :: Maybe Text, - spExpirySecs :: Maybe Int, + spExpirySecs :: Maybe UrlExpiry, spPayloadHash :: Maybe ByteString } deriving (Show) diff --git a/test/LiveServer.hs b/test/LiveServer.hs index b07fcc2..8f31058 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -34,7 +34,6 @@ 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) From c52f2811fe8eb2a657f1467d0798067a15deb395 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Mon, 22 Mar 2021 09:36:01 -0700 Subject: [PATCH 06/24] Use single CI file based on kowainik (#162) * Use single CI file based on kowainik --- .github/workflows/ci.yml | 185 ++++++++++++++++++++++++++++ .github/workflows/haskell-cabal.yml | 122 ------------------ .github/workflows/haskell-stack.yml | 108 ---------------- .travis.yml | 61 --------- 4 files changed, 185 insertions(+), 291 deletions(-) create mode 100644 .github/workflows/ci.yml delete mode 100644 .github/workflows/haskell-cabal.yml delete mode 100644 .github/workflows/haskell-stack.yml delete mode 100644 .travis.yml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..e58ad89 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,185 @@ +name: CI + +# Trigger the workflow on push or pull request, but only for the main branch +on: + pull_request: + push: + branches: [master] + +# Env vars for tests +env: + MINIO_ACCESS_KEY: minio + MINIO_SECRET_KEY: minio123 + MINIO_LOCAL: 1 + MINIO_SECURE: 1 + +jobs: + cabal: + name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} + runs-on: ${{ matrix.os }} + strategy: + matrix: + os: [ubuntu-latest, macOS-latest, windows-latest] + cabal: ["3.2"] + ghc: + - "8.4.4" + - "8.6.5" + - "8.8.4" + - "8.10.2" + exclude: + - os: macOS-latest + ghc: 8.8.4 + - os: macOS-latest + ghc: 8.6.5 + - os: windows-latest + ghc: 8.10.2 + - os: windows-latest + ghc: 8.6.5 + + steps: + - uses: actions/checkout@v2 + if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main' + + - uses: actions/setup-haskell@v1.1.4 + id: setup-haskell-cabal + name: Setup Haskell + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} + + - name: Configure + run: | + cabal configure --enable-tests --enable-benchmarks --test-show-details=direct -fexamples -flive-test + + - name: Freeze + run: | + cabal freeze + + - uses: actions/cache@v2.1.3 + name: Cache ~/.cabal/store + with: + path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} + key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} + + - name: Install dependencies + run: | + cabal build all --only-dependencies -fexamples -flive-test + + - name: Build + run: | + cabal build all -fexamples + + - name: Setup MinIO for testing (Linux) + if: matrix.os == 'ubuntu-latest' + run: | + mkdir -p /tmp/minio /tmp/minio-config/certs + cp test/cert/* /tmp/minio-config/certs/ + (cd /tmp/minio; wget -q https://dl.min.io/server/minio/release/linux-amd64/minio; chmod +x ./minio) + sudo cp /tmp/minio-config/certs/public.crt /usr/local/share/ca-certificates/ + sudo update-ca-certificates + + - name: Setup MinIO for testing (MacOS) + if: matrix.os == 'macos-latest' + run: | + mkdir -p /tmp/minio /tmp/minio-config/certs + cp test/cert/* /tmp/minio-config/certs/ + (cd /tmp/minio; wget -q https://dl.min.io/server/minio/release/darwin-amd64/minio; chmod +x ./minio) + sudo security add-trusted-cert -d -r trustRoot -k /Library/Keychains/System.keychain /tmp/minio-config/certs/public.crt + + - name: Setup MinIO for testing (Windows) + if: matrix.os == 'windows-latest' + run: | + New-Item -ItemType Directory -Path "$env:temp/minio-config/certs/" + Copy-Item -Path test\cert\* -Destination "$env:temp/minio-config/certs/" + Invoke-WebRequest -Uri https://dl.minio.io/server/minio/release/windows-amd64/minio.exe -OutFile $HOME/minio.exe + Import-Certificate -FilePath "$env:temp/minio-config/certs/public.crt" -CertStoreLocation Cert:\LocalMachine\Root + + - name: Test (Non-Windows) + if: matrix.os != 'windows-latest' + run: | + /tmp/minio/minio server --quiet --certs-dir /tmp/minio-config/certs data1 data2 data3 data4 2>&1 > minio.log & + ghc --version + cabal --version + cabal test all -flive-test + + - name: Test (Windows) + if: matrix.os == 'windows-latest' + run: | + Start-Process -NoNewWindow -FilePath "$HOME/minio.exe" -ArgumentList "--certs-dir", "$env:temp/minio-config/certs", "server", "$env:temp/data1", "$env:temp/data2", "$env:temp/data3", "$env:temp/data4" + ghc --version + cabal --version + cabal test all -flive-test + + stack: + name: stack / ghc ${{ matrix.ghc }} + runs-on: ${{ matrix.os }} + strategy: + matrix: + stack: ["2.3.1"] + ghc: ["8.8.4"] + os: [ubuntu-latest] + + steps: + - uses: actions/checkout@v2 + if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main' + + - uses: actions/setup-haskell@v1.1.4 + name: Setup Haskell Stack + with: + ghc-version: ${{ matrix.ghc }} + stack-version: ${{ matrix.stack }} + + - uses: actions/cache@v2.1.3 + name: Cache ~/.stack + with: + path: ~/.stack + key: ${{ runner.os }}-${{ matrix.ghc }}-stack + + - name: Install dependencies + run: | + stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies + + - name: Build + run: | + stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --flag minio-hs:examples + + - name: Setup MinIO for testing (Linux) + if: matrix.os == 'ubuntu-latest' + run: | + mkdir -p /tmp/minio /tmp/minio-config/certs + cp test/cert/* /tmp/minio-config/certs/ + (cd /tmp/minio; wget -q https://dl.min.io/server/minio/release/linux-amd64/minio; chmod +x ./minio) + sudo cp /tmp/minio-config/certs/public.crt /usr/local/share/ca-certificates/ + sudo update-ca-certificates + + - name: Setup MinIO for testing (MacOS) + if: matrix.os == 'macos-latest' + run: | + mkdir -p /tmp/minio /tmp/minio-config/certs + cp test/cert/* /tmp/minio-config/certs/ + (cd /tmp/minio; wget -q https://dl.min.io/server/minio/release/darwin-amd64/minio; chmod +x ./minio) + sudo security add-trusted-cert -d -r trustRoot -k /Library/Keychains/System.keychain /tmp/minio-config/certs/public.crt + + - name: Setup MinIO for testing (Windows) + if: matrix.os == 'windows-latest' + run: | + New-Item -ItemType Directory -Path "$env:temp/minio-config/certs/" + Copy-Item -Path test\cert\* -Destination "$env:temp/minio-config/certs/" + Invoke-WebRequest -Uri https://dl.minio.io/server/minio/release/windows-amd64/minio.exe -OutFile $HOME/minio.exe + Import-Certificate -FilePath "$env:temp/minio-config/certs/public.crt" -CertStoreLocation Cert:\LocalMachine\Root + + - name: Test (Non-Windows) + if: matrix.os != 'windows-latest' + run: | + /tmp/minio/minio server --quiet --certs-dir /tmp/minio-config/certs data1 data2 data3 data4 2>&1 > minio.log & + ghc --version + stack --version + stack test --system-ghc --flag minio-hs:live-test + + - name: Test (Windows) + if: matrix.os == 'windows-latest' + run: | + Start-Process -NoNewWindow -FilePath "$HOME/minio.exe" -ArgumentList "--certs-dir", "$env:temp/minio-config/certs", "server", "$env:temp/data1", "$env:temp/data2", "$env:temp/data3", "$env:temp/data4" + ghc --version + cabal --version + stack test --system-ghc --flag minio-hs:live-test diff --git a/.github/workflows/haskell-cabal.yml b/.github/workflows/haskell-cabal.yml deleted file mode 100644 index afd98cf..0000000 --- a/.github/workflows/haskell-cabal.yml +++ /dev/null @@ -1,122 +0,0 @@ -name: Haskell CI (Cabal) - -on: - schedule: - # Run every weekday - - cron: '0 0 * * 1-5' - push: - branches: [ master ] - pull_request: - branches: [ master ] - -jobs: - cabal-build: - - runs-on: ${{ matrix.os }} - strategy: - fail-fast: false - matrix: - ghc: ['8.4', '8.6', '8.8', '8.10'] - cabal: ['3.2'] - os: [ubuntu-latest, macOS-latest] - experimental: [false] - include: - - ghc: '8.6' - cabal: '3.2' - os: windows-latest - experimental: false - - ghc: '8.10' - cabal: '3.2' - os: windows-latest - experimental: false - - # Appears to be buggy to build in windows with ghc 8.4 and 8.8 - - ghc: '8.4' - cabal: '3.2' - os: windows-latest - experimental: true - - ghc: '8.8' - cabal: '3.2' - os: windows-latest - experimental: true - - steps: - - uses: actions/checkout@v2 - - uses: haskell/actions/setup@v1 - with: - ghc-version: ${{ matrix.ghc }} - cabal-version: ${{ matrix.cabal }} - - - name: Cache - uses: actions/cache@v2 - env: - cache-name: cabal-cache-${{ matrix.ghc }}-${{ matrix.cabal }} - with: - path: | - ~/.cabal - ~/.stack - %appdata%\cabal - %LOCALAPPDATA%\Programs\stack - key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/stack.yaml') }} - restore-keys: | - ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/stack.yaml') }} - ${{ runner.os }}-build-${{ env.cache-name }}- - ${{ runner.os }}-build- - ${{ runner.os }}- - - - name: Before install (Linux) - if: matrix.os == 'ubuntu-latest' - run: | - mkdir -p /tmp/minio /tmp/minio-config/certs - cp test/cert/* /tmp/minio-config/certs/ - (cd /tmp/minio; wget -q https://dl.min.io/server/minio/release/linux-amd64/minio; chmod +x ./minio) - sudo cp /tmp/minio-config/certs/public.crt /usr/local/share/ca-certificates/ - sudo update-ca-certificates - - - name: Before install (MacOS) - if: matrix.os == 'macos-latest' - run: | - mkdir -p /tmp/minio /tmp/minio-config/certs - cp test/cert/* /tmp/minio-config/certs/ - (cd /tmp/minio; wget -q https://dl.min.io/server/minio/release/darwin-amd64/minio; chmod +x ./minio) - sudo security add-trusted-cert -d -r trustRoot -k /Library/Keychains/System.keychain /tmp/minio-config/certs/public.crt - - - name: Before install (Windows) - if: matrix.os == 'windows-latest' - run: | - New-Item -ItemType Directory -Path "$env:temp/minio-config/certs/" - Copy-Item -Path test\cert\* -Destination "$env:temp/minio-config/certs/" - Invoke-WebRequest -Uri https://dl.minio.io/server/minio/release/windows-amd64/minio.exe -OutFile $HOME/minio.exe - Import-Certificate -FilePath "$env:temp/minio-config/certs/public.crt" -CertStoreLocation Cert:\LocalMachine\Root - - - name: Install dependencies, build and test (Non-Windows) - if: matrix.os != 'windows-latest' - env: - MINIO_ACCESS_KEY: minio - MINIO_SECRET_KEY: minio123 - MINIO_LOCAL: 1 - MINIO_SECURE: 1 - continue-on-error: ${{ matrix.experimental }} - run: | - /tmp/minio/minio server --quiet --certs-dir /tmp/minio-config/certs data1 data2 data3 data4 2>&1 > minio.log & - ghc --version - cabal --version - cabal new-update - cabal new-build --enable-tests --enable-benchmarks -fexamples - cabal new-test --enable-tests -flive-test - - - name: Install dependencies, build and test (Windows) - if: matrix.os == 'windows-latest' - env: - MINIO_ACCESS_KEY: minio - MINIO_SECRET_KEY: minio123 - MINIO_LOCAL: 1 - MINIO_SECURE: 1 - continue-on-error: ${{ matrix.experimental }} - run: | - Start-Process -NoNewWindow -FilePath "$HOME/minio.exe" -ArgumentList "--certs-dir", "$env:temp/minio-config/certs", "server", "$env:temp/data1", "$env:temp/data2", "$env:temp/data3", "$env:temp/data4" - ghc --version - cabal --version - cabal new-update - cabal new-build --enable-tests --enable-benchmarks -fexamples - cabal new-test --enable-tests -flive-test diff --git a/.github/workflows/haskell-stack.yml b/.github/workflows/haskell-stack.yml deleted file mode 100644 index 9496b6e..0000000 --- a/.github/workflows/haskell-stack.yml +++ /dev/null @@ -1,108 +0,0 @@ -name: Haskell CI (Stack) - -on: - schedule: - # Run every weekday - - cron: '0 0 * * 1-5' - push: - branches: [ master ] - pull_request: - branches: [ master ] - -jobs: - stack-build: - - runs-on: ${{ matrix.os }} - strategy: - fail-fast: false - matrix: - ghc: ['8.8'] - cabal: ['3.2'] - os: [ubuntu-latest, macOS-latest] - experimental: [false] - include: - # Appears to be buggy to build in windows with ghc 8.8 - - ghc: '8.8' - cabal: '3.2' - os: windows-latest - experimental: true - - steps: - - uses: actions/checkout@v2 - - uses: haskell/actions/setup@v1 - with: - ghc-version: ${{ matrix.ghc }} - cabal-version: ${{ matrix.cabal }} - enable-stack: true - - - name: Cache - uses: actions/cache@v2 - env: - cache-name: stack-cache-${{ matrix.ghc }}-${{ matrix.cabal }} - with: - path: | - ~/.cabal - ~/.stack - %appdata%\cabal - %LOCALAPPDATA%\Programs\stack - key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/stack.yaml') }} - restore-keys: | - ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/stack.yaml') }} - ${{ runner.os }}-build-${{ env.cache-name }}- - ${{ runner.os }}-build- - ${{ runner.os }}- - - - name: Before install (Linux) - if: matrix.os == 'ubuntu-latest' - run: | - mkdir -p /tmp/minio /tmp/minio-config/certs - cp test/cert/* /tmp/minio-config/certs/ - (cd /tmp/minio; wget -q https://dl.min.io/server/minio/release/linux-amd64/minio; chmod +x ./minio) - sudo cp /tmp/minio-config/certs/public.crt /usr/local/share/ca-certificates/ - sudo update-ca-certificates - - - name: Before install (MacOS) - if: matrix.os == 'macos-latest' - run: | - mkdir -p /tmp/minio /tmp/minio-config/certs - cp test/cert/* /tmp/minio-config/certs/ - (cd /tmp/minio; wget -q https://dl.min.io/server/minio/release/darwin-amd64/minio; chmod +x ./minio) - sudo security add-trusted-cert -d -r trustRoot -k /Library/Keychains/System.keychain /tmp/minio-config/certs/public.crt - - - name: Before install (Windows) - if: matrix.os == 'windows-latest' - run: | - New-Item -ItemType Directory -Path "$env:temp/minio-config/certs/" - Copy-Item -Path test\cert\* -Destination "$env:temp/minio-config/certs/" - Invoke-WebRequest -Uri https://dl.minio.io/server/minio/release/windows-amd64/minio.exe -OutFile $HOME/minio.exe - Import-Certificate -FilePath "$env:temp/minio-config/certs/public.crt" -CertStoreLocation Cert:\LocalMachine\Root - - - name: Install dependencies, build and test (Non-Windows) - if: matrix.os != 'windows-latest' - env: - MINIO_ACCESS_KEY: minio - MINIO_SECRET_KEY: minio123 - MINIO_LOCAL: 1 - MINIO_SECURE: 1 - continue-on-error: ${{ matrix.experimental }} - run: | - /tmp/minio/minio server --quiet --certs-dir /tmp/minio-config/certs data1 data2 data3 data4 2>&1 > minio.log & - ghc --version - stack --version - stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --flag minio-hs:examples - stack test --system-ghc --flag minio-hs:live-test - - - name: Install dependencies, build and test (Windows) - if: matrix.os == 'windows-latest' - env: - MINIO_ACCESS_KEY: minio - MINIO_SECRET_KEY: minio123 - MINIO_LOCAL: 1 - MINIO_SECURE: 1 - continue-on-error: ${{ matrix.experimental }} - run: | - Start-Process -NoNewWindow -FilePath "$HOME/minio.exe" -ArgumentList "--certs-dir", "$env:temp/minio-config/certs", "server", "$env:temp/data1", "$env:temp/data2", "$env:temp/data3", "$env:temp/data4" - ghc --version - stack --version - stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --flag minio-hs:examples - stack test --system-ghc --flag minio-hs:live-test diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 02e87f7..0000000 --- a/.travis.yml +++ /dev/null @@ -1,61 +0,0 @@ -sudo: true -language: haskell - -git: - depth: 5 - -cabal: "3.0" - -cache: - directories: - - "$HOME/.cabal/store" - - "$HOME/.stack" - - "$TRAVIS_BUILD_DIR/.stack-work" - -matrix: - include: - - # Cabal - - ghc: 8.4.4 - - ghc: 8.6.5 - - ghc: 8.8.3 - - # Stack - - ghc: 8.6.5 - env: STACK_YAML="$TRAVIS_BUILD_DIR/stack.yaml" - -before_install: - - sudo apt-get install devscripts - - mkdir /tmp/minio /tmp/certs - - (cd /tmp/minio; wget https://dl.min.io/server/minio/release/linux-amd64/minio; chmod +x ./minio) - - (cd /tmp/certs; openssl req -newkey rsa:2048 -nodes -keyout private.key -x509 -days 36500 -out public.crt -subj "/C=US/ST=NRW/L=Earth/O=CompanyName/OU=IT/CN=localhost/emailAddress=email@example.com") - - sudo cp /tmp/certs/public.crt /usr/local/share/ca-certificates/ - - sudo update-ca-certificates - - MINIO_ACCESS_KEY=minio MINIO_SECRET_KEY=minio123 /tmp/minio/minio server --quiet --certs-dir /tmp/certs data 2>&1 > minio.log & - -install: - - | - if [ -z "$STACK_YAML" ]; then - ghc --version - cabal --version - cabal new-update - cabal new-build --enable-tests --enable-benchmarks -fexamples - else - # install stack - curl -sSL https://get.haskellstack.org/ | sh - - # build project with stack - stack --version - stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --flag minio-hs:examples - fi - -script: - - | - if [ -z "$STACK_YAML" ]; then - MINIO_LOCAL=1 MINIO_SECURE=1 cabal new-test --enable-tests -flive-test - else - MINIO_LOCAL=1 MINIO_SECURE=1 stack test --system-ghc --flag minio-hs:live-test - fi - -notifications: - email: false From 193be5943267446f91e93638688905365ce3557a Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Thu, 10 Feb 2022 10:43:43 -0800 Subject: [PATCH 07/24] Update CI (#166) --- .github/workflows/ci.yml | 42 ++++++++++++++++++++++++---------------- minio-hs.cabal | 2 +- 2 files changed, 26 insertions(+), 18 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index e58ad89..4b3feab 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -3,9 +3,16 @@ name: CI # Trigger the workflow on push or pull request, but only for the main branch on: pull_request: + branches: [master] push: branches: [master] +# This ensures that previous jobs for the PR are canceled when the PR is +# updated. +concurrency: + group: ${{ github.workflow }}-${{ github.head_ref }} + cancel-in-progress: true + # Env vars for tests env: MINIO_ACCESS_KEY: minio @@ -15,32 +22,32 @@ env: jobs: cabal: - name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} + name: ${{ matrix.os }} / ghc-${{ matrix.ghc }} / cabal-${{ matrix.cabal }} runs-on: ${{ matrix.os }} strategy: matrix: - os: [ubuntu-latest, macOS-latest, windows-latest] - cabal: ["3.2"] + os: [ubuntu-latest, windows-latest] # Removed macos-latest due to cert issues. + cabal: ["3.6"] ghc: - - "8.4.4" - - "8.6.5" + # - "9.0.1" + - "8.10.7" - "8.8.4" - - "8.10.2" - exclude: - - os: macOS-latest - ghc: 8.8.4 - - os: macOS-latest - ghc: 8.6.5 - - os: windows-latest - ghc: 8.10.2 - - os: windows-latest - ghc: 8.6.5 + - "8.6.5" + # exclude: + # - os: macOS-latest + # ghc: 8.8.4 + # - os: macOS-latest + # ghc: 8.6.5 + # - os: windows-latest + # ghc: 8.10.7 + # - os: windows-latest + # ghc: 8.6.5 steps: - uses: actions/checkout@v2 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main' - - uses: actions/setup-haskell@v1.1.4 + - uses: haskell/actions/setup@v1 id: setup-haskell-cabal name: Setup Haskell with: @@ -123,9 +130,10 @@ jobs: - uses: actions/checkout@v2 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main' - - uses: actions/setup-haskell@v1.1.4 + - uses: haskell/actions/setup@v1 name: Setup Haskell Stack with: + enable-stack: true ghc-version: ${{ matrix.ghc }} stack-version: ${{ matrix.stack }} diff --git a/minio-hs.cabal b/minio-hs.cabal index 3cda739..759c676 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -57,7 +57,7 @@ common base-settings , Network.Minio.JsonParser build-depends: base >= 4.7 && < 5 , protolude >= 0.3 && < 0.4 - , aeson >= 1.2 + , aeson >= 1.2 && < 2 , base64-bytestring >= 1.0 , binary >= 0.8.5.0 , bytestring >= 0.10 From c59b7066fcf9ece059ac226e28e7de9f5004edf6 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Thu, 10 Feb 2022 13:34:11 -0800 Subject: [PATCH 08/24] Updates from new ormolu 0.4 (#167) * Changes from formatter * Fix github action run on master branch --- .github/workflows/ci.yml | 4 +- src/Network/Minio/API.hs | 78 ++++++++++++------------ src/Network/Minio/AdminAPI.hs | 4 +- src/Network/Minio/Data.hs | 16 ++--- src/Network/Minio/Data/ByteString.hs | 2 +- src/Network/Minio/PresignedOperations.hs | 10 +-- src/Network/Minio/PutObject.hs | 12 ++-- src/Network/Minio/SelectAPI.hs | 4 +- src/Network/Minio/Sign/V4.hs | 54 ++++++++-------- src/Network/Minio/Utils.hs | 2 +- test/LiveServer.hs | 2 +- test/Spec.hs | 8 +-- 12 files changed, 98 insertions(+), 98 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 4b3feab..888ce4a 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -1,6 +1,6 @@ name: CI -# Trigger the workflow on push or pull request, but only for the main branch +# Trigger the workflow on push or pull request, but only for the master branch on: pull_request: branches: [master] @@ -45,7 +45,7 @@ jobs: steps: - uses: actions/checkout@v2 - if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main' + if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' - uses: haskell/actions/setup@v1 id: setup-haskell-cabal diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index 2d9d49b..87c3337 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -88,10 +88,10 @@ getRegion ri = do -- getService/makeBucket/getLocation -- don't need location if | not $ riNeedsLocation ri -> - return $ Just $ connectRegion ci + return $ Just $ connectRegion ci -- if autodiscovery of location is disabled by user | not $ connectAutoDiscoverRegion ci -> - return $ Just $ connectRegion ci + return $ Just $ connectRegion ci -- discover the region for the request | otherwise -> discoverRegion ri @@ -137,10 +137,10 @@ getHostPathRegion ri = do ) if | isAWSConnectInfo ci -> - return $ - if bucketHasPeriods bucket - then pathStyle - else virtualStyle + return $ + if bucketHasPeriods bucket + then pathStyle + else virtualStyle | otherwise -> return pathStyle buildRequest :: S3ReqInfo -> Minio NC.Request @@ -196,42 +196,42 @@ buildRequest ri = do if | isJust (riPresignExpirySecs ri') -> - -- case 0 from above. - do - let signPairs = signV4 sp baseRequest - qpToAdd = (fmap . fmap) Just signPairs - existingQueryParams = HT.parseQuery (NC.queryString baseRequest) - updatedQueryParams = existingQueryParams ++ qpToAdd - return $ NClient.setQueryString updatedQueryParams baseRequest + -- case 0 from above. + do + let signPairs = signV4 sp baseRequest + qpToAdd = (fmap . fmap) Just signPairs + existingQueryParams = HT.parseQuery (NC.queryString baseRequest) + updatedQueryParams = existingQueryParams ++ qpToAdd + return $ NClient.setQueryString updatedQueryParams baseRequest | isStreamingPayload (riPayload ri') && (not $ connectIsSecure ci') -> - -- case 2 from above. - do - (pLen, pSrc) <- case riPayload ri of - PayloadC l src -> return (l, src) - _ -> throwIO MErrVUnexpectedPayload - let reqFn = signV4Stream pLen sp baseRequest - return $ reqFn pSrc + -- case 2 from above. + 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 - sp' <- - if - | connectIsSecure ci' -> - -- case 1 described above. - return sp - | otherwise -> - -- case 3 described above. - do - pHash <- getPayloadSHA256Hash $ riPayload ri' - return $ sp {spPayloadHash = Just pHash} + do + sp' <- + if + | connectIsSecure ci' -> + -- case 1 described above. + return sp + | otherwise -> + -- case 3 described above. + 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') - } + 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 diff --git a/src/Network/Minio/AdminAPI.hs b/src/Network/Minio/AdminAPI.hs index 3c338ec..1016537 100644 --- a/src/Network/Minio/AdminAPI.hs +++ b/src/Network/Minio/AdminAPI.hs @@ -599,8 +599,8 @@ buildAdminRequest areq = do sha256Hash <- if | connectIsSecure ci -> - -- if secure connection - return "UNSIGNED-PAYLOAD" + -- if secure connection + return "UNSIGNED-PAYLOAD" -- otherwise compute sha256 | otherwise -> getPayloadSHA256Hash (ariPayload areq) diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 389efb9..4c976b9 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -226,8 +226,8 @@ getHostAddr ci = if | port == 80 || port == 443 -> toUtf8 host | otherwise -> - toUtf8 $ - T.concat [host, ":", Lib.Prelude.show port] + toUtf8 $ + T.concat [host, ":", Lib.Prelude.show port] where port = connectPort ci host = connectHost ci @@ -283,9 +283,9 @@ newtype SSECKey = SSECKey BA.ScrubbedBytes mkSSECKey :: MonadThrow m => ByteString -> m SSECKey mkSSECKey keyBytes | B.length keyBytes /= 32 = - throwM MErrVInvalidEncryptionKeyLength + throwM MErrVInvalidEncryptionKeyLength | otherwise = - return $ SSECKey $ BA.convert keyBytes + return $ SSECKey $ BA.convert keyBytes -- | Data type to represent Server-Side-Encryption settings data SSE where @@ -1079,9 +1079,9 @@ instance HasSvcNamespace MinioConn where let host = connectHost $ mcConnInfo env in if | host == "storage.googleapis.com" -> - "http://doc.s3.amazonaws.com/2006-03-01" + "http://doc.s3.amazonaws.com/2006-03-01" | otherwise -> - "http://s3.amazonaws.com/doc/2006-03-01/" + "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 @@ -1091,8 +1091,8 @@ 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 + let badTlsSettings = Conn.TLSSettingsSimple True False False + in TLS.mkManagerSettings badTlsSettings Nothing | connectIsSecure ci = NC.tlsManagerSettings | otherwise = defaultManagerSettings mgr <- NC.newManager settings diff --git a/src/Network/Minio/Data/ByteString.hs b/src/Network/Minio/Data/ByteString.hs index 09e68d5..714b42a 100644 --- a/src/Network/Minio/Data/ByteString.hs +++ b/src/Network/Minio/Data/ByteString.hs @@ -66,7 +66,7 @@ uriEncodeChar ch _ || (ch == '-') || (ch == '.') || (ch == '~') = - BB.char7 ch + BB.char7 ch | otherwise = mconcat $ map f $ B.unpack $ encodeUtf8 $ T.singleton ch where f :: Word8 -> BB.Builder diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs index 8e753ea..4ee3256 100644 --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -246,19 +246,19 @@ newPostPolicy :: 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' diff --git a/src/Network/Minio/PutObject.hs b/src/Network/Minio/PutObject.hs index 3eb1552..447ecbf 100644 --- a/src/Network/Minio/PutObject.hs +++ b/src/Network/Minio/PutObject.hs @@ -71,8 +71,8 @@ putObjectInternal b o opts (ODStream src sizeMay) = do 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 + 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 @@ -95,13 +95,13 @@ putObjectInternal b o opts (ODFile fp sizeMay) = do Just size -> if | size <= 64 * oneMiB -> - either throwIO return - =<< withNewHandle fp (\h -> putObjectSingle b o (pooToHeaders opts) h 0 size) + 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 + sequentialMultipartUpload b o opts (Just size) $ + CB.sourceFile fp parallelMultipartUpload :: Bucket -> diff --git a/src/Network/Minio/SelectAPI.hs b/src/Network/Minio/SelectAPI.hs index dc336e2..3863268 100644 --- a/src/Network/Minio/SelectAPI.hs +++ b/src/Network/Minio/SelectAPI.hs @@ -186,7 +186,7 @@ crcCheck = do -- 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 + finalCrc <- accumulateYield (fromIntegral n - 16) startCrc bs <- readNBytes 4 expectedCrc :: Word32 <- liftIO $ parseBinary bs @@ -276,7 +276,7 @@ selectObjectContent b o r = do riNeedsLocation = False, riQueryParams = [("select", Nothing), ("select-type", Just "2")] } - --print $ mkSelectRequest r + -- print $ mkSelectRequest r resp <- mkStreamRequest reqInfo return $ NC.responseBody resp .| selectProtoConduit diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 0d183c5..2aaeee8 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -365,41 +365,41 @@ signV4Stream !payloadLength !sp !req = -- '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 + 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 + 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 + 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, diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index 769f5a7..579b8e1 100644 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -235,7 +235,7 @@ limitedMapConcurrently count act args = do waitSem t = U.atomically $ do v <- U.readTVar t if v > 0 - then U.writeTVar t (v -1) + then U.writeTVar t (v - 1) else U.retrySTM signalSem t = U.atomically $ do v <- U.readTVar t diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 8f31058..635e6f3 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -1076,7 +1076,7 @@ copyObjectTests = funTestWithBucket "copyObject related tests" $ copyObjectPart dstInfo' srcInfo' - { srcRange = Just $ (,) ((p -1) * mb5) ((p -1) * mb5 + (mb5 - 1)) + { srcRange = Just $ (,) ((p - 1) * mb5) ((p - 1) * mb5 + (mb5 - 1)) } uid (fromIntegral p) diff --git a/test/Spec.hs b/test/Spec.hs index 95e5c1a..36a7cf9 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -72,11 +72,11 @@ qcProps = 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) + 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 + maybe True (\x -> x >= 0 && x <= minPartSize) $ + headMay sizes | otherwise -> False in n < 0 || ( isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk From bdac380c77a699e640c411dd04d99acff5bdd646 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Fri, 11 Feb 2022 13:48:08 -0800 Subject: [PATCH 09/24] Replace protolude with relude and build with GHC 9.0.2 (#168) - relude is a better and more commonly used library - Add compiler warnings and fixes - Update stack lts to 18.24 - Add explicit deriving strategies --- .github/workflows/ci.yml | 8 +- examples/FileUploader.hs | 1 - minio-hs.cabal | 45 ++++++-- src/Lib/Prelude.hs | 14 +-- src/Network/Minio.hs | 1 - src/Network/Minio/APICommon.hs | 2 +- src/Network/Minio/AdminAPI.hs | 44 ++++---- src/Network/Minio/CopyObject.hs | 14 ++- src/Network/Minio/Data.hs | 131 ++++++++++++----------- src/Network/Minio/Data/ByteString.hs | 5 +- src/Network/Minio/Data/Crypto.hs | 1 - src/Network/Minio/Errors.hs | 17 +-- src/Network/Minio/JsonParser.hs | 2 +- src/Network/Minio/ListOps.hs | 37 ++++++- src/Network/Minio/PresignedOperations.hs | 12 +-- src/Network/Minio/PutObject.hs | 2 +- src/Network/Minio/S3API.hs | 2 +- src/Network/Minio/SelectAPI.hs | 4 +- src/Network/Minio/Sign/V4.hs | 22 ++-- src/Network/Minio/Utils.hs | 18 ++-- src/Network/Minio/XmlGenerator.hs | 9 +- src/Network/Minio/XmlParser.hs | 16 +-- stack.yaml | 6 +- stack.yaml.lock | 24 +---- test/LiveServer.hs | 20 ++-- test/Network/Minio/API/Test.hs | 1 - test/Network/Minio/TestHelpers.hs | 1 - test/Network/Minio/Utils/Test.hs | 1 - test/Spec.hs | 10 +- 29 files changed, 259 insertions(+), 211 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 888ce4a..43df085 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -29,7 +29,7 @@ jobs: os: [ubuntu-latest, windows-latest] # Removed macos-latest due to cert issues. cabal: ["3.6"] ghc: - # - "9.0.1" + - "9.0.2" - "8.10.7" - "8.8.4" - "8.6.5" @@ -122,13 +122,13 @@ jobs: runs-on: ${{ matrix.os }} strategy: matrix: - stack: ["2.3.1"] - ghc: ["8.8.4"] + stack: ["2.7.3"] + ghc: ["8.10.7"] os: [ubuntu-latest] steps: - uses: actions/checkout@v2 - if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main' + if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' - uses: haskell/actions/setup@v1 name: Setup Haskell Stack diff --git a/examples/FileUploader.hs b/examples/FileUploader.hs index 88c4c60..dde340f 100755 --- a/examples/FileUploader.hs +++ b/examples/FileUploader.hs @@ -19,7 +19,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -import Data.Monoid ((<>)) import Data.Text (pack) import Network.Minio import Options.Applicative diff --git a/minio-hs.cabal b/minio-hs.cabal index 759c676..9826ffd 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -21,22 +21,52 @@ extra-source-files: examples/*.hs README.md stack.yaml +tested-with: GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + +source-repository head + type: git + location: https://github.com/minio/minio-hs.git common base-settings ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -haddock + if impl(ghc >= 8.0) + ghc-options: -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths + + -- Add this when we have time. Fixing partial-fields requires major version + -- bump at this time. + -- if impl(ghc >= 8.4) + -- ghc-options: -Wpartial-fields + -- -Wmissing-export-lists + + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + -Werror=missing-deriving-strategies + default-language: Haskell2010 + default-extensions: BangPatterns + , DerivingStrategies , FlexibleContexts , FlexibleInstances , MultiParamTypeClasses , MultiWayIf - , NoImplicitPrelude , OverloadedStrings , RankNTypes , ScopedTypeVariables - , TypeFamilies , TupleSections + , TypeFamilies + + other-modules: Lib.Prelude , Network.Minio.API , Network.Minio.APICommon @@ -55,8 +85,13 @@ common base-settings , Network.Minio.XmlGenerator , Network.Minio.XmlParser , Network.Minio.JsonParser + + mixins: base hiding (Prelude) + , relude (Relude as Prelude) + , relude + build-depends: base >= 4.7 && < 5 - , protolude >= 0.3 && < 0.4 + , relude >= 0.7 && < 2 , aeson >= 1.2 && < 2 , base64-bytestring >= 1.0 , binary >= 0.8.5.0 @@ -292,7 +327,3 @@ executable SetConfig import: examples-settings scope: private main-is: SetConfig.hs - -source-repository head - type: git - location: https://github.com/minio/minio-hs diff --git a/src/Lib/Prelude.hs b/src/Lib/Prelude.hs index a6b6cf7..5d16a89 100644 --- a/src/Lib/Prelude.hs +++ b/src/Lib/Prelude.hs @@ -20,6 +20,7 @@ module Lib.Prelude showBS, toStrictBS, fromStrictBS, + lastMay, ) where @@ -29,14 +30,6 @@ import Data.Time as Exports ( UTCTime (..), diffUTCTime, ) -import Protolude as Exports hiding - ( Handler, - catch, - catches, - throwIO, - try, - yield, - ) import UnliftIO as Exports ( Handler, catch, @@ -50,10 +43,13 @@ 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) +showBS a = encodeUtf8 (show a :: Text) toStrictBS :: LByteString -> ByteString toStrictBS = LB.toStrict fromStrictBS :: ByteString -> LByteString fromStrictBS = LB.fromStrict + +lastMay :: [a] -> Maybe a +lastMay a = last <$> nonEmpty a diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 7a30d9e..0a882c9 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -225,7 +225,6 @@ This module exports the high-level MinIO API for object storage. import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Combinators as CC -import Lib.Prelude import Network.Minio.CopyObject import Network.Minio.Data import Network.Minio.Errors diff --git a/src/Network/Minio/APICommon.hs b/src/Network/Minio/APICommon.hs index 992a9b5..320bf0c 100644 --- a/src/Network/Minio/APICommon.hs +++ b/src/Network/Minio/APICommon.hs @@ -46,7 +46,7 @@ getPayloadSHA256Hash (PayloadC _ _) = throwIO MErrVUnexpectedPayload getRequestBody :: Payload -> NC.RequestBody getRequestBody (PayloadBS bs) = NC.RequestBodyBS bs getRequestBody (PayloadH h off size) = - NC.requestBodySource (fromIntegral size) $ + NC.requestBodySource size $ sourceHandleRange h (return . fromIntegral $ off) diff --git a/src/Network/Minio/AdminAPI.hs b/src/Network/Minio/AdminAPI.hs index 1016537..d27e2d4 100644 --- a/src/Network/Minio/AdminAPI.hs +++ b/src/Network/Minio/AdminAPI.hs @@ -90,7 +90,7 @@ data DriveInfo = DriveInfo diEndpoint :: Text, diState :: Text } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON DriveInfo where parseJSON = withObject "DriveInfo" $ \v -> @@ -103,7 +103,7 @@ data StorageClass = StorageClass { scParity :: Int, scData :: Int } - deriving (Eq, Show) + deriving stock (Show, Eq) data ErasureInfo = ErasureInfo { eiOnlineDisks :: Int, @@ -112,7 +112,7 @@ data ErasureInfo = ErasureInfo eiReducedRedundancy :: StorageClass, eiSets :: [[DriveInfo]] } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON ErasureInfo where parseJSON = withObject "ErasureInfo" $ \v -> do @@ -132,7 +132,7 @@ instance FromJSON ErasureInfo where data Backend = BackendFS | BackendErasure ErasureInfo - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON Backend where parseJSON = withObject "Backend" $ \v -> do @@ -146,7 +146,7 @@ data ConnStats = ConnStats { csTransferred :: Int64, csReceived :: Int64 } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON ConnStats where parseJSON = withObject "ConnStats" $ \v -> @@ -161,7 +161,7 @@ data ServerProps = ServerProps spRegion :: Text, spSqsArns :: [Text] } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON ServerProps where parseJSON = withObject "SIServer" $ \v -> do @@ -177,7 +177,7 @@ data StorageInfo = StorageInfo { siUsed :: Int64, siBackend :: Backend } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON StorageInfo where parseJSON = withObject "StorageInfo" $ \v -> @@ -189,7 +189,7 @@ data CountNAvgTime = CountNAvgTime { caCount :: Int64, caAvgDuration :: Text } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON CountNAvgTime where parseJSON = withObject "CountNAvgTime" $ \v -> @@ -209,7 +209,7 @@ data HttpStats = HttpStats hsTotalDeletes :: CountNAvgTime, hsSuccessDeletes :: CountNAvgTime } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON HttpStats where parseJSON = withObject "HttpStats" $ \v -> @@ -231,7 +231,7 @@ data SIData = SIData sdHttpStats :: HttpStats, sdProps :: ServerProps } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON SIData where parseJSON = withObject "SIData" $ \v -> @@ -246,7 +246,7 @@ data ServerInfo = ServerInfo siAddr :: Text, siData :: SIData } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON ServerInfo where parseJSON = withObject "ServerInfo" $ \v -> @@ -259,7 +259,7 @@ data ServerVersion = ServerVersion { svVersion :: Text, svCommitId :: Text } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON ServerVersion where parseJSON = withObject "ServerVersion" $ \v -> @@ -271,7 +271,7 @@ data ServiceStatus = ServiceStatus { ssVersion :: ServerVersion, ssUptime :: NominalDiffTime } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON ServiceStatus where parseJSON = withObject "ServiceStatus" $ \v -> do @@ -283,7 +283,7 @@ instance FromJSON ServiceStatus where data ServiceAction = ServiceActionRestart | ServiceActionStop - deriving (Eq, Show) + deriving stock (Show, Eq) instance ToJSON ServiceAction where toJSON a = object ["action" .= serviceActionToText a] @@ -301,7 +301,7 @@ data HealStartResp = HealStartResp hsrClientAddr :: Text, hsrStartTime :: UTCTime } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON HealStartResp where parseJSON = withObject "HealStartResp" $ \v -> @@ -314,7 +314,7 @@ data HealOpts = HealOpts { hoRecursive :: Bool, hoDryRun :: Bool } - deriving (Eq, Show) + deriving stock (Show, Eq) instance ToJSON HealOpts where toJSON (HealOpts r d) = @@ -333,7 +333,7 @@ data HealItemType | HealItemBucket | HealItemBucketMetadata | HealItemObject - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON HealItemType where parseJSON = withText "HealItemType" $ \v -> case v of @@ -348,7 +348,7 @@ data NodeSummary = NodeSummary nsErrSet :: Bool, nsErrMessage :: Text } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON NodeSummary where parseJSON = withObject "NodeSummary" $ \v -> @@ -361,7 +361,7 @@ data SetConfigResult = SetConfigResult { scrStatus :: Bool, scrNodeSummary :: [NodeSummary] } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON SetConfigResult where parseJSON = withObject "SetConfigResult" $ \v -> @@ -383,7 +383,7 @@ data HealResultItem = HealResultItem hriBefore :: [DriveInfo], hriAfter :: [DriveInfo] } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON HealResultItem where parseJSON = withObject "HealResultItem" $ \v -> @@ -415,7 +415,7 @@ data HealStatus = HealStatus hsFailureDetail :: Maybe Text, hsItems :: Maybe [HealResultItem] } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON HealStatus where parseJSON = withObject "HealStatus" $ \v -> @@ -434,7 +434,7 @@ healPath bucket prefix = do encodeUtf8 $ "v1/heal/" <> fromMaybe "" bucket <> "/" <> fromMaybe "" prefix - else encodeUtf8 $ "v1/heal/" + else encodeUtf8 ("v1/heal/" :: Text) -- | Get server version and uptime. serviceStatus :: Minio ServiceStatus diff --git a/src/Network/Minio/CopyObject.hs b/src/Network/Minio/CopyObject.hs index c5adaaa..7454346 100644 --- a/src/Network/Minio/CopyObject.hs +++ b/src/Network/Minio/CopyObject.hs @@ -45,11 +45,10 @@ copyObjectInternal b' o srcInfo = do when ( isJust rangeMay - && or - [ startOffset < 0, - endOffset < startOffset, - endOffset >= fromIntegral srcSize - ] + && ( (startOffset < 0) + || (endOffset < startOffset) + || (endOffset >= srcSize) + ) ) $ throwIO $ MErrVInvalidSrcObjByteRange range @@ -70,8 +69,7 @@ copyObjectInternal b' o srcInfo = do selectCopyRanges :: (Int64, Int64) -> [(PartNumber, (Int64, Int64))] selectCopyRanges (st, end) = zip pns $ - map (\(x, y) -> (st + x, st + x + y - 1)) $ - zip startOffsets partSizes + zipWith (\x y -> (st + x, st + x + y - 1)) startOffsets partSizes where size = end - st + 1 (pns, startOffsets, partSizes) = List.unzip3 $ selectPartSizes size @@ -88,7 +86,7 @@ multiPartCopyObject :: multiPartCopyObject b o cps srcSize = do uid <- newMultipartUpload b o [] - let byteRange = maybe (0, fromIntegral $ srcSize - 1) identity $ srcRange cps + let byteRange = maybe (0, srcSize - 1) identity $ srcRange cps partRanges = selectCopyRanges byteRange partSources = map diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 4c976b9..d367d9a 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -22,7 +22,14 @@ module Network.Minio.Data where import qualified Conduit as C import qualified Control.Concurrent.MVar as M +import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Resource + ( MonadResource, + MonadThrow (..), + MonadUnliftIO, + ResourceT, + runResourceT, + ) import qualified Data.Aeson as A import qualified Data.ByteArray as BA import qualified Data.ByteString as B @@ -30,12 +37,10 @@ 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 Lib.Prelude (UTCTime, throwIO) import qualified Network.Connection as Conn import Network.HTTP.Client (defaultManagerSettings) import qualified Network.HTTP.Client.TLS as TLS @@ -49,12 +54,18 @@ import Network.HTTP.Types ) import qualified Network.HTTP.Types as HT import Network.Minio.Data.Crypto -import Network.Minio.Data.Time + ( encodeToBase64, + hashMD5ToBase64, + ) +import Network.Minio.Data.Time (UrlExpiry) import Network.Minio.Errors + ( MErrV (MErrVInvalidEncryptionKeyLength, MErrVMissingCredentials), + MinioErr (..), + ) import System.Directory (doesFileExist, getHomeDirectory) import qualified System.Environment as Env import System.FilePath.Posix (combine) -import Text.XML +import Text.XML (Name (Name)) import qualified UnliftIO as U -- | max obj size is 5TiB @@ -111,7 +122,7 @@ data ConnectInfo = ConnectInfo connectAutoDiscoverRegion :: Bool, connectDisableTLSCertValidation :: Bool } - deriving (Eq, Show) + deriving stock (Eq, Show) instance IsString ConnectInfo where fromString str = @@ -132,7 +143,7 @@ data Credentials = Credentials { cAccessKey :: Text, cSecretKey :: Text } - deriving (Eq, Show) + deriving stock (Eq, Show) -- | A Provider is an action that may return Credentials. Providers -- may be chained together using 'findFirst'. @@ -164,7 +175,7 @@ fromAWSConfigFile = do return $ Ini.lookupValue "default" "aws_secret_access_key" ini return $ Credentials akey skey - return $ hush credsE + return $ either (const Nothing) Just credsE -- | This Provider loads `Credentials` from @AWS_ACCESS_KEY_ID@ and -- @AWS_SECRET_ACCESS_KEY@ environment variables. @@ -224,10 +235,10 @@ disableTLSCertValidation c = c {connectDisableTLSCertValidation = True} getHostAddr :: ConnectInfo -> ByteString getHostAddr ci = if - | port == 80 || port == 443 -> toUtf8 host + | port == 80 || port == 443 -> encodeUtf8 host | otherwise -> - toUtf8 $ - T.concat [host, ":", Lib.Prelude.show port] + encodeUtf8 $ + T.concat [host, ":", show port] where port = connectPort ci host = connectHost ci @@ -276,7 +287,7 @@ 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 stock (Eq, Show) -- | Validates that the given ByteString is 32 bytes long and creates -- an encryption key. @@ -407,7 +418,7 @@ data BucketInfo = BucketInfo { biName :: Bucket, biCreationDate :: UTCTime } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | A type alias to represent a part-number for multipart upload type PartNumber = Int16 @@ -425,7 +436,7 @@ data ListPartsResult = ListPartsResult lprNextPart :: Maybe Int, lprParts :: [ObjectPartInfo] } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Represents information about an object part in an ongoing -- multipart upload. @@ -435,7 +446,7 @@ data ObjectPartInfo = ObjectPartInfo opiSize :: Int64, opiModTime :: UTCTime } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Represents result from a listing of incomplete uploads to a -- bucket. @@ -446,7 +457,7 @@ data ListUploadsResult = ListUploadsResult lurUploads :: [(Object, UploadId, UTCTime)], lurCPrefixes :: [Text] } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Represents information about a multipart upload. data UploadInfo = UploadInfo @@ -455,7 +466,7 @@ data UploadInfo = UploadInfo uiInitTime :: UTCTime, uiSize :: Int64 } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Represents result from a listing of objects in a bucket. data ListObjectsResult = ListObjectsResult @@ -464,7 +475,7 @@ data ListObjectsResult = ListObjectsResult lorObjects :: [ObjectInfo], lorCPrefixes :: [Text] } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Represents result from a listing of objects version 1 in a bucket. data ListObjectsV1Result = ListObjectsV1Result @@ -473,7 +484,7 @@ data ListObjectsV1Result = ListObjectsV1Result lorObjects' :: [ObjectInfo], lorCPrefixes' :: [Text] } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Represents information about an object. data ObjectInfo = ObjectInfo @@ -497,7 +508,7 @@ data ObjectInfo = ObjectInfo -- user-metadata pairs) oiMetadata :: H.HashMap Text Text } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Represents source object in server-side copy object data SourceInfo = SourceInfo @@ -529,7 +540,7 @@ data SourceInfo = SourceInfo -- given time. srcIfUnmodifiedSince :: Maybe UTCTime } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Provide a default for `SourceInfo` defaultSourceInfo :: SourceInfo @@ -542,7 +553,7 @@ data DestinationInfo = DestinationInfo -- | Destination object key dstObject :: Text } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Provide a default for `DestinationInfo` defaultDestinationInfo :: DestinationInfo @@ -619,18 +630,18 @@ data Event | ObjectRemovedDelete | ObjectRemovedDeleteMarkerCreated | ReducedRedundancyLostObject - deriving (Eq) + deriving stock (Eq, Show) -instance Show Event where - show ObjectCreated = "s3:ObjectCreated:*" - show ObjectCreatedPut = "s3:ObjectCreated:Put" - show ObjectCreatedPost = "s3:ObjectCreated:Post" - show ObjectCreatedCopy = "s3:ObjectCreated:Copy" - show ObjectCreatedMultipartUpload = "s3:ObjectCreated:MultipartUpload" - show ObjectRemoved = "s3:ObjectRemoved:*" - show ObjectRemovedDelete = "s3:ObjectRemoved:Delete" - show ObjectRemovedDeleteMarkerCreated = "s3:ObjectRemoved:DeleteMarkerCreated" - show ReducedRedundancyLostObject = "s3:ReducedRedundancyLostObject" +instance ToText Event where + toText ObjectCreated = "s3:ObjectCreated:*" + toText ObjectCreatedPut = "s3:ObjectCreated:Put" + toText ObjectCreatedPost = "s3:ObjectCreated:Post" + toText ObjectCreatedCopy = "s3:ObjectCreated:Copy" + toText ObjectCreatedMultipartUpload = "s3:ObjectCreated:MultipartUpload" + toText ObjectRemoved = "s3:ObjectRemoved:*" + toText ObjectRemovedDelete = "s3:ObjectRemoved:Delete" + toText ObjectRemovedDeleteMarkerCreated = "s3:ObjectRemoved:DeleteMarkerCreated" + toText ReducedRedundancyLostObject = "s3:ReducedRedundancyLostObject" textToEvent :: Text -> Maybe Event textToEvent t = case t of @@ -649,7 +660,7 @@ textToEvent t = case t of data Filter = Filter { fFilter :: FilterKey } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | defaultFilter is empty, used to create a notification -- configuration. @@ -660,7 +671,7 @@ defaultFilter = Filter defaultFilterKey data FilterKey = FilterKey { fkKey :: FilterRules } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | defaultFilterKey is empty, used to create notification -- configuration. @@ -671,7 +682,7 @@ defaultFilterKey = FilterKey defaultFilterRules data FilterRules = FilterRules { frFilterRules :: [FilterRule] } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | defaultFilterRules is empty, used to create notification -- configuration. @@ -691,7 +702,7 @@ data FilterRule = FilterRule { frName :: Text, frValue :: Text } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Arn is an alias of Text type Arn = Text @@ -705,7 +716,7 @@ data NotificationConfig = NotificationConfig ncEvents :: [Event], ncFilter :: Filter } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | A data-type to represent bucket notification configuration. It is -- a collection of queue, topic or lambda function configurations. The @@ -717,7 +728,7 @@ data Notification = Notification nTopicConfigurations :: [NotificationConfig], nCloudFunctionConfigurations :: [NotificationConfig] } - deriving (Eq, Show) + deriving stock (Show, Eq) -- | The default notification configuration is empty. defaultNotification :: Notification @@ -736,10 +747,10 @@ data SelectRequest = SelectRequest srOutputSerialization :: OutputSerialization, srRequestProgressEnabled :: Maybe Bool } - deriving (Eq, Show) + deriving stock (Show, Eq) data ExpressionType = SQL - deriving (Eq, Show) + deriving stock (Show, Eq) -- | InputSerialization represents format information of the input -- object being queried. Use one of the smart constructors such as @@ -749,7 +760,7 @@ data InputSerialization = InputSerialization { isCompressionType :: Maybe CompressionType, isFormatInfo :: InputFormatInfo } - deriving (Eq, Show) + deriving stock (Show, Eq) -- | Data type representing the compression setting in a Select -- request. @@ -757,7 +768,7 @@ data CompressionType = CompressionTypeNone | CompressionTypeGzip | CompressionTypeBzip2 - deriving (Eq, Show) + deriving stock (Show, Eq) -- | Data type representing input object format information in a -- Select request. @@ -765,7 +776,7 @@ data InputFormatInfo = InputFormatCSV CSVInputProp | InputFormatJSON JSONInputProp | InputFormatParquet - deriving (Eq, Show) + deriving stock (Show, Eq) -- | defaultCsvInput returns InputSerialization with default CSV -- format, and without any compression setting. @@ -845,7 +856,7 @@ 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 stock (Show, Eq) #if (__GLASGOW_HASKELL__ >= 804) instance Semigroup CSVProp where @@ -890,15 +901,15 @@ data FileHeaderInfo FileHeaderUse | -- | Header are present, but should be ignored FileHeaderIgnore - deriving (Eq, Show) + deriving stock (Show, Eq) -- | Specify the CSV file header info property. fileHeaderInfo :: FileHeaderInfo -> CSVProp -fileHeaderInfo = CSVProp . H.singleton "FileHeaderInfo" . toString +fileHeaderInfo = CSVProp . H.singleton "FileHeaderInfo" . toStr where - toString FileHeaderNone = "NONE" - toString FileHeaderUse = "USE" - toString FileHeaderIgnore = "IGNORE" + toStr FileHeaderNone = "NONE" + toStr FileHeaderUse = "USE" + toStr FileHeaderIgnore = "IGNORE" -- | Specify the CSV comment character property. Lines starting with -- this character are ignored by the server. @@ -918,10 +929,10 @@ outputCSVFromProps :: CSVProp -> OutputSerialization outputCSVFromProps p = OutputSerializationCSV p data JSONInputProp = JSONInputProp {jsonipType :: JSONType} - deriving (Eq, Show) + deriving stock (Show, Eq) data JSONType = JSONTypeDocument | JSONTypeLines - deriving (Eq, Show) + deriving stock (Show, Eq) -- | OutputSerialization represents output serialization settings for -- the SelectRequest. Use `defaultCsvOutput` or `defaultJsonOutput` as @@ -929,7 +940,7 @@ data JSONType = JSONTypeDocument | JSONTypeLines data OutputSerialization = OutputSerializationJSON JSONOutputProp | OutputSerializationCSV CSVOutputProp - deriving (Eq, Show) + deriving stock (Show, Eq) type CSVOutputProp = CSVProp @@ -943,10 +954,10 @@ quoteFields q = CSVProp $ -- | Represent the QuoteField setting. data QuoteFields = QuoteFieldsAsNeeded | QuoteFieldsAlways - deriving (Eq, Show) + deriving stock (Show, Eq) data JSONOutputProp = JSONOutputProp {jsonopRecordDelimiter :: Maybe Text} - deriving (Eq, Show) + deriving stock (Show, Eq) -- | Set the output record delimiter for JSON format outputJSONFromRecordDelimiter :: Text -> OutputSerialization @@ -964,7 +975,7 @@ data EventMessage emErrorMessage :: Text } | RecordPayloadEventMessage {emPayloadBytes :: ByteString} - deriving (Eq, Show) + deriving stock (Show, Eq) data MsgHeaderName = MessageType @@ -972,7 +983,7 @@ data MsgHeaderName | ContentType | ErrorCode | ErrorMessage - deriving (Eq, Show) + deriving stock (Show, Eq) msgHeaderValueType :: Word8 msgHeaderValueType = 7 @@ -985,7 +996,7 @@ data Progress = Progress pBytesProcessed :: Int64, pBytesReturned :: Int64 } - deriving (Eq, Show) + deriving stock (Show, Eq) -- | Represent the stats event returned at the end of the Select -- response. @@ -1043,7 +1054,7 @@ defaultS3ReqInfo = getS3Path :: Maybe Bucket -> Maybe Object -> ByteString getS3Path b o = - let segments = map toUtf8 $ catMaybes $ b : bool [] [o] (isJust b) + let segments = map encodeUtf8 $ catMaybes $ b : bool [] [o] (isJust b) in B.concat ["/", B.intercalate "/" segments] type RegionMap = H.HashMap Bucket Region @@ -1053,7 +1064,7 @@ type RegionMap = H.HashMap Bucket Region newtype Minio a = Minio { unMinio :: ReaderT MinioConn (ResourceT IO) a } - deriving + deriving newtype ( Functor, Applicative, Monad, diff --git a/src/Network/Minio/Data/ByteString.hs b/src/Network/Minio/Data/ByteString.hs index 714b42a..5e57018 100644 --- a/src/Network/Minio/Data/ByteString.hs +++ b/src/Network/Minio/Data/ByteString.hs @@ -25,9 +25,8 @@ 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 (isAsciiLower, isAsciiUpper) +import Data.Char (isAsciiLower, isAsciiUpper, isDigit, isSpace, toUpper) import qualified Data.Text as T -import Lib.Prelude import Numeric (showHex) stripBS :: ByteString -> ByteString @@ -73,4 +72,4 @@ uriEncodeChar ch _ 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 n (16 :: Word8) diff --git a/src/Network/Minio/Data/Crypto.hs b/src/Network/Minio/Data/Crypto.hs index 2ca750a..af51cb3 100644 --- a/src/Network/Minio/Data/Crypto.hs +++ b/src/Network/Minio/Data/Crypto.hs @@ -39,7 +39,6 @@ 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/Errors.hs b/src/Network/Minio/Errors.hs index eadeadd..91c6860 100644 --- a/src/Network/Minio/Errors.hs +++ b/src/Network/Minio/Errors.hs @@ -14,10 +14,15 @@ -- limitations under the License. -- -module Network.Minio.Errors where +module Network.Minio.Errors + ( MErrV (..), + ServiceErr (..), + MinioErr (..), + toServiceErr, + ) +where -import Control.Exception -import Lib.Prelude +import Control.Exception (IOException) import qualified Network.HTTP.Conduit as NC --------------------------------- @@ -44,7 +49,7 @@ data MErrV | MErrVInvalidEncryptionKeyLength | MErrVStreamingBodyUnexpectedEOF | MErrVUnexpectedPayload - deriving (Show, Eq) + deriving stock (Show, Eq) instance Exception MErrV @@ -57,7 +62,7 @@ data ServiceErr | NoSuchKey | SelectErr Text Text | ServiceErr Text Text - deriving (Show, Eq) + deriving stock (Show, Eq) instance Exception ServiceErr @@ -75,7 +80,7 @@ data MinioErr | MErrIO IOException | MErrService ServiceErr | MErrValidation MErrV - deriving (Show) + deriving stock (Show) instance Eq MinioErr where MErrHTTP _ == MErrHTTP _ = True diff --git a/src/Network/Minio/JsonParser.hs b/src/Network/Minio/JsonParser.hs index 9d0ce46..4f84f5d 100644 --- a/src/Network/Minio/JsonParser.hs +++ b/src/Network/Minio/JsonParser.hs @@ -34,7 +34,7 @@ data AdminErrJSON = AdminErrJSON { aeCode :: Text, aeMessage :: Text } - deriving (Eq, Show) + deriving stock (Eq, Show) instance FromJSON AdminErrJSON where parseJSON = withObject "AdminErrJSON" $ \v -> diff --git a/src/Network/Minio/ListOps.hs b/src/Network/Minio/ListOps.hs index 723370c..d288af7 100644 --- a/src/Network/Minio/ListOps.hs +++ b/src/Network/Minio/ListOps.hs @@ -19,16 +19,47 @@ module Network.Minio.ListOps where import qualified Data.Conduit as C import qualified Data.Conduit.Combinators as CC import qualified Data.Conduit.List as CL -import Lib.Prelude import Network.Minio.Data + ( Bucket, + ListObjectsResult + ( lorCPrefixes, + lorHasMore, + lorNextToken, + lorObjects + ), + ListObjectsV1Result + ( lorCPrefixes', + lorHasMore', + lorNextMarker, + lorObjects' + ), + ListPartsResult (lprHasMore, lprNextPart, lprParts), + ListUploadsResult + ( lurHasMore, + lurNextKey, + lurNextUpload, + lurUploads + ), + Minio, + Object, + ObjectInfo, + ObjectPartInfo (opiSize), + UploadId, + UploadInfo (UploadInfo), + ) import Network.Minio.S3API + ( listIncompleteParts', + listIncompleteUploads', + listObjects', + listObjectsV1', + ) -- | 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) + deriving stock (Show, Eq) -- | @'listObjects' bucket prefix recurse@ lists objects in a bucket -- similar to a file system tree traversal. @@ -110,7 +141,7 @@ listIncompleteUploads bucket prefix recurse = loop Nothing Nothing C.runConduit $ listIncompleteParts bucket uKey uId C..| CC.sinkList - return $ foldl (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos + return $ foldl' (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos CL.sourceList $ map diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs index 4ee3256..e08beb0 100644 --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -88,7 +88,7 @@ makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do let uri = NClient.getUri req uriString = uriToString identity uri "" - return $ toUtf8 uriString + return $ encodeUtf8 uriString -- | Generate a URL with authentication signature to PUT (upload) an -- object. Any extra headers if passed, are signed, and so they are @@ -170,7 +170,7 @@ data PostPolicyCondition = PPCStartsWith Text Text | PPCEquals Text Text | PPCRange Text Int64 Int64 - deriving (Show, Eq) + deriving stock (Show, Eq) instance Json.ToJSON PostPolicyCondition where toJSON (PPCStartsWith k v) = Json.toJSON ["starts-with", k, v] @@ -188,7 +188,7 @@ data PostPolicy = PostPolicy { expiration :: UTCTime, conditions :: [PostPolicyCondition] } - deriving (Show, Eq) + deriving stock (Show, Eq) instance Json.ToJSON PostPolicy where toJSON (PostPolicy e c) = @@ -205,7 +205,7 @@ data PostPolicyError | PPEBucketNotSpecified | PPEConditionKeyEmpty | PPERangeInvalid - deriving (Eq, Show) + deriving stock (Show, Eq) -- | Set the bucket name that the upload should use. ppCondBucket :: Bucket -> PostPolicyCondition @@ -283,7 +283,7 @@ presignedPostPolicy p = do signTime <- liftIO $ Time.getCurrentTime let extraConditions = - [ PPCEquals "x-amz-date" (toS $ awsTimeFormat signTime), + [ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime), PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256", PPCEquals "x-amz-credential" @@ -312,7 +312,7 @@ presignedPostPolicy p = do mkPair (PPCEquals k v) = Just (k, v) mkPair _ = Nothing formFromPolicy = - H.map toUtf8 $ + H.map encodeUtf8 $ H.fromList $ catMaybes $ mkPair <$> conditions ppWithCreds diff --git a/src/Network/Minio/PutObject.hs b/src/Network/Minio/PutObject.hs index 447ecbf..e1a8ff3 100644 --- a/src/Network/Minio/PutObject.hs +++ b/src/Network/Minio/PutObject.hs @@ -77,7 +77,7 @@ putObjectInternal b o opts (ODStream src sizeMay) = do | 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) + liftA2 (,) (isHandleSeekable h) (getFileSize h) (isSeekable, handleSizeMay) <- either diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index 38dfe47..77befdf 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -380,7 +380,7 @@ putObjectPart bucket object uploadId partNumber headers payload = do srcInfoToHeaders :: SourceInfo -> [HT.Header] srcInfoToHeaders srcInfo = ( "x-amz-copy-source", - toUtf8 $ + encodeUtf8 $ T.concat [ "/", srcBucket srcInfo, diff --git a/src/Network/Minio/SelectAPI.hs b/src/Network/Minio/SelectAPI.hs index 3863268..01db5e7 100644 --- a/src/Network/Minio/SelectAPI.hs +++ b/src/Network/Minio/SelectAPI.hs @@ -111,7 +111,7 @@ data EventStreamException | ESEInvalidHeaderType | ESEInvalidHeaderValueType | ESEInvalidMessageType - deriving (Eq, Show) + deriving stock (Eq, Show) instance Exception EventStreamException @@ -219,7 +219,7 @@ handleMessage = do hs <- parseHeaders hdrLen let payloadLen = msgLen - hdrLen - 16 - getHdrVal h = fmap snd . headMay . filter ((h ==) . fst) + getHdrVal h = fmap snd . find ((h ==) . fst) eventHdrValue = getHdrVal EventType hs msgHdrValue = getHdrVal MessageType hs errCode = getHdrVal ErrorCode hs diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 2aaeee8..37e8950 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -58,7 +58,7 @@ data SignV4Data = SignV4Data sv4StringToSign :: ByteString, sv4SigningKey :: ByteString } - deriving (Show) + deriving stock (Show) data SignParams = SignParams { spAccessKey :: Text, @@ -68,7 +68,7 @@ data SignParams = SignParams spExpirySecs :: Maybe UrlExpiry, spPayloadHash :: Maybe ByteString } - deriving (Show) + deriving stock (Show) debugPrintSignV4Data :: SignV4Data -> IO () debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do @@ -92,7 +92,7 @@ mkAuthHeader accessKey scope signedHeaderKeys sign = let authValue = B.concat [ "AWS4-HMAC-SHA256 Credential=", - toUtf8 accessKey, + encodeUtf8 accessKey, "/", scope, ", SignedHeaders=", @@ -119,8 +119,8 @@ signV4 !sp !req = let region = fromMaybe "" $ spRegion sp ts = spTimeStamp sp scope = mkScope ts region - accessKey = toUtf8 $ spAccessKey sp - secretKey = toUtf8 $ spSecretKey sp + accessKey = encodeUtf8 $ spAccessKey sp + secretKey = encodeUtf8 $ spSecretKey sp expiry = spExpirySecs sp sha256Hdr = ( "x-amz-content-sha256", @@ -179,8 +179,8 @@ mkScope :: UTCTime -> Text -> ByteString mkScope ts region = B.intercalate "/" - [ toUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts, - toUtf8 region, + [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts, + encodeUtf8 region, "s3", "aws4_request" ] @@ -239,7 +239,7 @@ mkSigningKey :: UTCTime -> Text -> ByteString -> ByteString mkSigningKey ts region !secretKey = hmacSHA256RawBS "aws4_request" . hmacSHA256RawBS "s3" - . hmacSHA256RawBS (toUtf8 region) + . hmacSHA256RawBS (encodeUtf8 region) . hmacSHA256RawBS (awsDateFormatBS ts) $ B.concat ["AWS4", secretKey] @@ -256,7 +256,7 @@ signV4PostPolicy :: signV4PostPolicy !postPolicyJSON !sp = let stringToSign = Base64.encode postPolicyJSON region = fromMaybe "" $ spRegion sp - signingKey = mkSigningKey (spTimeStamp sp) region $ toUtf8 $ spSecretKey sp + signingKey = mkSigningKey (spTimeStamp sp) region $ encodeUtf8 $ spSecretKey sp signature = computeSignature stringToSign signingKey in Map.fromList [ ("x-amz-signature", signature), @@ -294,7 +294,7 @@ signV4Stream :: signV4Stream !payloadLength !sp !req = let ts = spTimeStamp sp addContentEncoding hs = - let ceMay = headMay $ filter (\(x, _) -> x == "content-encoding") hs + let ceMay = find (\(x, _) -> x == "content-encoding") hs in case ceMay of Nothing -> ("content-encoding", "aws-chunked") : hs Just (_, ce) -> @@ -332,7 +332,7 @@ signV4Stream !payloadLength !sp !req = stringToSign = mkStringToSign ts scope canonicalReq -- 1.3 Compute signature -- 1.3.1 compute signing key - signingKey = mkSigningKey ts region $ toUtf8 secretKey + signingKey = mkSigningKey ts region $ encodeUtf8 secretKey -- 1.3.2 Compute signature seedSignature = computeSignature stringToSign signingKey -- 1.3.3 Compute Auth Header diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index 579b8e1..af0f3c8 100644 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -52,7 +52,7 @@ allocateReadFile :: m (R.ReleaseKey, Handle) allocateReadFile fp = do (rk, hdlE) <- R.allocate (openReadFile fp) cleanup - either (\(e :: IOException) -> throwIO e) (return . (rk,)) hdlE + either (\(e :: U.IOException) -> throwIO e) (return . (rk,)) hdlE where openReadFile f = U.try $ IO.openBinaryFile f IO.ReadMode cleanup = either (const $ return ()) IO.hClose @@ -60,25 +60,25 @@ 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) => + (MonadUnliftIO m) => Handle -> m (Maybe Int64) getFileSize h = do resE <- liftIO $ try $ fromIntegral <$> IO.hFileSize h case resE of - Left (_ :: IOException) -> return Nothing + Left (_ :: U.IOException) -> return Nothing 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) => + (R.MonadResource m) => Handle -> m Bool isHandleSeekable h = do resE <- liftIO $ try $ IO.hIsSeekable h case resE of - Left (_ :: IOException) -> return False + Left (_ :: U.IOException) -> return False Right v -> return v -- | Helper function that opens a handle to the filepath and performs @@ -89,7 +89,7 @@ withNewHandle :: (MonadUnliftIO m, R.MonadResource m) => FilePath -> (Handle -> m a) -> - m (Either IOException a) + m (Either U.IOException a) withNewHandle fp fileAction = do -- opening a handle can throw MError exception. handleE <- try $ allocateReadFile fp @@ -106,7 +106,7 @@ mkHeaderFromPairs :: [(ByteString, ByteString)] -> [HT.Header] mkHeaderFromPairs = map ((\(x, y) -> (mk x, y))) lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString -lookupHeader hdr = headMay . map snd . filter (\(h, _) -> h == hdr) +lookupHeader hdr = listToMaybe . map snd . filter (\(h, _) -> h == hdr) getETagHeader :: [HT.Header] -> Maybe Text getETagHeader hs = decodeUtf8Lenient <$> lookupHeader Hdr.hETag hs @@ -143,7 +143,7 @@ getLastModifiedHeader hs = do getContentLength :: [HT.Header] -> Maybe Int64 getContentLength hs = do nbs <- decodeUtf8Lenient <$> lookupHeader Hdr.hContentLength hs - fst <$> hush (decimal nbs) + fst <$> either (const Nothing) Just (decimal nbs) decodeUtf8Lenient :: ByteString -> Text decodeUtf8Lenient = decodeUtf8With lenientDecode @@ -280,7 +280,7 @@ selectPartSizes size = fromIntegral size / fromIntegral maxMultipartParts ) - m = fromIntegral partSize + m = partSize loop st sz | st > sz = [] | st + m >= sz = [(st, sz - st)] diff --git a/src/Network/Minio/XmlGenerator.hs b/src/Network/Minio/XmlGenerator.hs index 3efe1b7..a2c381f 100644 --- a/src/Network/Minio/XmlGenerator.hs +++ b/src/Network/Minio/XmlGenerator.hs @@ -24,7 +24,6 @@ where import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T -import Lib.Prelude import Network.Minio.Data import Text.XML @@ -72,7 +71,7 @@ mkCompleteMultipartUploadRequest partInfo = data XNode = XNode Text [XNode] | XLeaf Text Text - deriving (Eq, Show) + deriving stock (Eq, Show) toXML :: Text -> XNode -> ByteString toXML ns node = @@ -94,7 +93,7 @@ class ToXNode a where toXNode :: a -> XNode instance ToXNode Event where - toXNode = XLeaf "Event" . show + toXNode = XLeaf "Event" . toText instance ToXNode Notification where toXNode (Notification qc tc lc) = @@ -104,9 +103,9 @@ instance ToXNode Notification where ++ map (toXNodesWithArnName "CloudFunctionConfiguration" "CloudFunction") lc toXNodesWithArnName :: Text -> Text -> NotificationConfig -> XNode -toXNodesWithArnName eltName arnName (NotificationConfig id arn events fRule) = +toXNodesWithArnName eltName arnName (NotificationConfig itemId arn events fRule) = XNode eltName $ - [XLeaf "Id" id, XLeaf arnName arn] ++ map toXNode events + [XLeaf "Id" itemId, XLeaf arnName arn] ++ map toXNode events ++ [toXNode fRule] instance ToXNode Filter where diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index fb97874..94a2f29 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -32,7 +32,7 @@ where import qualified Data.ByteString.Lazy as LB import qualified Data.HashMap.Strict as H -import Data.List (zip3, zip4, zip6) +import Data.List (zip4, zip6) import qualified Data.Text as T import Data.Text.Read (decimal) import Data.Time @@ -132,7 +132,7 @@ parseListObjectsV1Response xmldata = do ns <- asks getSvcNamespace let s3Elem' = s3Elem ns hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content) - nextMarker = headMay $ r $/ s3Elem' "NextMarker" &/ content + nextMarker = listToMaybe $ 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 @@ -158,7 +158,7 @@ parseListObjectsResponse xmldata = do ns <- asks getSvcNamespace let s3Elem' = s3Elem ns hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content) - nextToken = headMay $ r $/ s3Elem' "NextContinuationToken" &/ content + nextToken = listToMaybe $ 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 @@ -185,8 +185,8 @@ parseListUploadsResponse xmldata = do 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 + nextKey = listToMaybe $ r $/ s3Elem' "NextKeyMarker" &/ content + nextUpload = listToMaybe $ 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 @@ -203,7 +203,7 @@ parseListPartsResponse xmldata = do ns <- asks getSvcNamespace let s3Elem' = s3Elem ns hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content) - nextPartNumStr = headMay $ r $/ s3Elem' "NextPartNumberMarker" &/ content + nextPartNumStr = listToMaybe $ 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 @@ -245,7 +245,7 @@ parseNotification xmldata = do in FilterRule name value parseNode ns arnName nodeData = do let c = fromNode nodeData - id = T.concat $ c $/ s3Elem ns "Id" &/ content + itemId = 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 = @@ -253,7 +253,7 @@ parseNotification xmldata = do &/ s3Elem ns "FilterRule" &| getFilterRule ns return $ NotificationConfig - id + itemId arn events (Filter $ FilterKey $ FilterRules rules) diff --git a/stack.yaml b/stack.yaml index dc4ff19..d3426be 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: lts-16.0 +resolver: lts-18.24 # User packages to be built. # Various formats can be used as shown in the example below. @@ -39,9 +39,7 @@ packages: - '.' # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) -extra-deps: -- unliftio-core-0.2.0.1 -- protolude-0.3.0 +extra-deps: [] # Override default flag values for local packages and extra-deps flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock index a6fcdc8..84717da 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,24 +3,10 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -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 +packages: [] snapshots: - completed: - size: 531237 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/0.yaml - sha256: 210e15b7043e2783115afe16b0d54914b1611cdaa73f3ca3ca7f8e0847ff54e5 - original: lts-16.0 + size: 587821 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/24.yaml + sha256: 06d844ba51e49907bd29cb58b4a5f86ee7587a4cd7e6cf395eeec16cba619ce8 + original: lts-18.24 diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 635e6f3..194dbeb 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -37,7 +37,7 @@ import Network.Minio.Data.Crypto import Network.Minio.S3API import Network.Minio.Utils import System.Directory (getTemporaryDirectory) -import System.Environment (lookupEnv) +import qualified System.Environment as Env import qualified Test.QuickCheck as Q import Test.Tasty import Test.Tasty.HUnit @@ -79,8 +79,8 @@ funTestBucketPrefix = "miniohstest-" loadTestServer :: IO ConnectInfo loadTestServer = do - val <- lookupEnv "MINIO_LOCAL" - isSecure <- lookupEnv "MINIO_SECURE" + val <- Env.lookupEnv "MINIO_LOCAL" + isSecure <- Env.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" @@ -616,7 +616,7 @@ presignedUrlFunTest = funTestWithBucket "presigned Url tests" $ headUrl <- presignedHeadObjectUrl bucket obj2 3600 [] headResp <- do - let req = NC.parseRequest_ $ toS $ decodeUtf8 headUrl + let req = NC.parseRequest_ $ decodeUtf8 headUrl NC.httpLbs (req {NC.method = HT.methodHead}) mgr liftIO $ (NC.responseStatus headResp == HT.status200) @@ -644,7 +644,7 @@ presignedUrlFunTest = funTestWithBucket "presigned Url tests" $ mapM_ (removeObject bucket) [obj, obj2] where putR size filePath mgr url = do - let req = NC.parseRequest_ $ toS $ decodeUtf8 url + let req = NC.parseRequest_ $ decodeUtf8 url let req' = req { NC.method = HT.methodPut, @@ -654,7 +654,7 @@ presignedUrlFunTest = funTestWithBucket "presigned Url tests" $ } NC.httpLbs req' mgr getR mgr url = do - let req = NC.parseRequest_ $ toS $ decodeUtf8 url + let req = NC.parseRequest_ $ decodeUtf8 url NC.httpLbs req mgr presignedPostPolicyFunTest :: TestTree @@ -690,7 +690,7 @@ presignedPostPolicyFunTest = funTestWithBucket "Presigned Post Policy tests" $ mapM_ (removeObject bucket) [key] where postForm url formData inputFile = do - req <- NC.parseRequest $ toS $ decodeUtf8 url + req <- NC.parseRequest $ decodeUtf8 url let parts = map (\(x, y) -> Form.partBS x y) $ H.toList formData @@ -739,13 +739,13 @@ bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $ [ proto, getHostAddr connInfo, "/", - toUtf8 bucket, + encodeUtf8 bucket, "/", - toUtf8 obj + encodeUtf8 obj ] respE <- liftIO $ - (fmap (Right . toStrictBS) $ NC.simpleHttp $ toS $ decodeUtf8 url) + fmap (Right . toStrictBS) (NC.simpleHttp $ decodeUtf8 url) `catch` (\(e :: NC.HttpException) -> return $ Left (show e :: Text)) case respE of Left err -> liftIO $ assertFailure $ show err diff --git a/test/Network/Minio/API/Test.hs b/test/Network/Minio/API/Test.hs index e35b8a8..81aef01 100644 --- a/test/Network/Minio/API/Test.hs +++ b/test/Network/Minio/API/Test.hs @@ -24,7 +24,6 @@ module Network.Minio.API.Test where import Data.Aeson (eitherDecode) -import Lib.Prelude import Network.Minio.API import Network.Minio.AdminAPI import Test.Tasty diff --git a/test/Network/Minio/TestHelpers.hs b/test/Network/Minio/TestHelpers.hs index 32de0d9..7c0244d 100644 --- a/test/Network/Minio/TestHelpers.hs +++ b/test/Network/Minio/TestHelpers.hs @@ -19,7 +19,6 @@ module Network.Minio.TestHelpers ) where -import Lib.Prelude import Network.Minio.Data newtype TestNS = TestNS {testNamespace :: Text} diff --git a/test/Network/Minio/Utils/Test.hs b/test/Network/Minio/Utils/Test.hs index 1e82308..f8d0633 100644 --- a/test/Network/Minio/Utils/Test.hs +++ b/test/Network/Minio/Utils/Test.hs @@ -19,7 +19,6 @@ module Network.Minio.Utils.Test ) where -import Lib.Prelude import Network.Minio.Utils import Test.Tasty import Test.Tasty.HUnit diff --git a/test/Spec.hs b/test/Spec.hs index 36a7cf9..418e04f 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -73,10 +73,10 @@ qcProps = if | nparts > 1 -> -- last part can be smaller but > 0 all (>= minPartSize) (take (nparts - 1) sizes) - && all (\s -> s > 0) (drop (nparts - 1) sizes) + && all (> 0) (drop (nparts - 1) sizes) | nparts == 1 -> -- size may be 0 here. maybe True (\x -> x >= 0 && x <= minPartSize) $ - headMay sizes + listToMaybe sizes | otherwise -> False in n < 0 || ( isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk @@ -89,16 +89,16 @@ qcProps = -- 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 + isFirstPartOk = maybe False ((start ==) . fst) $ listToMaybe pairs -- each pair is >=64MiB except last, and all those parts -- have same size. - initSizes = maybe [] (map (\(a, b) -> b - a + 1)) $ initMay pairs + initSizes = maybe [] (map (\(a, b) -> b - a + 1)) $ init <$> nonEmpty pairs isPartSizesOk = all (>= minPartSize) initSizes && maybe True (\k -> all (== k) initSizes) - (headMay initSizes) + (listToMaybe initSizes) -- returned offsets are contiguous. fsts = drop 1 $ map fst pairs snds = take (length pairs - 1) $ map snd pairs From baee20dfb641606ecb0e666a430ee2bd828f8d61 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Tue, 24 May 2022 15:34:47 -0700 Subject: [PATCH 10/24] Support aeson 2 (#169) --- minio-hs.cabal | 2 +- src/Network/Minio/PresignedOperations.hs | 14 ++++++++++++++ stack.yaml | 2 +- stack.yaml.lock | 8 ++++---- 4 files changed, 20 insertions(+), 6 deletions(-) diff --git a/minio-hs.cabal b/minio-hs.cabal index 9826ffd..0c8650b 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -92,7 +92,7 @@ common base-settings build-depends: base >= 4.7 && < 5 , relude >= 0.7 && < 2 - , aeson >= 1.2 && < 2 + , aeson >= 1.2 && < 3 , base64-bytestring >= 1.0 , binary >= 0.8.5.0 , bytestring >= 0.10 diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs index e08beb0..44f21e2 100644 --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- -- MinIO Haskell SDK, (C) 2017 MinIO, Inc. -- @@ -51,6 +53,10 @@ import Network.Minio.Errors import Network.Minio.Sign.V4 import Network.URI (uriToString) +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as A +#endif + -- | Generate a presigned URL. This function allows for advanced usage -- - for simple cases prefer the `presigned*Url` functions. -- @@ -174,12 +180,20 @@ data PostPolicyCondition instance Json.ToJSON PostPolicyCondition where toJSON (PPCStartsWith k v) = Json.toJSON ["starts-with", k, v] +#if MIN_VERSION_aeson(2,0,0) + toJSON (PPCEquals k v) = Json.object [(A.fromText k) .= v] +#else toJSON (PPCEquals k v) = Json.object [k .= v] +#endif toJSON (PPCRange k minVal maxVal) = Json.toJSON [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal] toEncoding (PPCStartsWith k v) = Json.foldable ["starts-with", k, v] +#if MIN_VERSION_aeson(2,0,0) + toEncoding (PPCEquals k v) = Json.pairs ((A.fromText k) .= v) +#else toEncoding (PPCEquals k v) = Json.pairs (k .= v) +#endif toEncoding (PPCRange k minVal maxVal) = Json.foldable [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal] diff --git a/stack.yaml b/stack.yaml index d3426be..f3a3b8a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: lts-18.24 +resolver: lts-19.7 # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/stack.yaml.lock b/stack.yaml.lock index 84717da..8787e19 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 587821 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/24.yaml - sha256: 06d844ba51e49907bd29cb58b4a5f86ee7587a4cd7e6cf395eeec16cba619ce8 - original: lts-18.24 + size: 618884 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/7.yaml + sha256: 57d4ce67cc097fea2058446927987bc1f7408890e3a6df0da74e5e318f051c20 + original: lts-19.7 From 7b6547aca0473f4855a788d76b83b1f16dbbfd8a Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Wed, 25 May 2022 10:21:56 -0700 Subject: [PATCH 11/24] Test GHC 9.0.2 and 9.2.2 with Stack (#170) --- .github/workflows/ci.yml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 43df085..6efe221 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -123,7 +123,10 @@ jobs: strategy: matrix: stack: ["2.7.3"] - ghc: ["8.10.7"] + ghc: + - "8.10.7" + - "9.0.2" + - "9.2.2" os: [ubuntu-latest] steps: From b91a7afd6b27b7f2d06f3ad1db11d2784a1882e0 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Fri, 27 May 2022 12:07:28 -0700 Subject: [PATCH 12/24] Update with changes for ormolu 0.5.0.0 (#171) - Add ormolu check to CI --- .github/workflows/ci.yml | 6 ++++ examples/PresignedGetObject.hs | 3 +- examples/PresignedPutObject.hs | 3 +- src/Network/Minio/AdminAPI.hs | 10 +++--- src/Network/Minio/CopyObject.hs | 4 +-- src/Network/Minio/Data.hs | 3 +- src/Network/Minio/ListOps.hs | 6 ++-- src/Network/Minio/PresignedOperations.hs | 7 ++++- src/Network/Minio/S3API.hs | 23 +++++++------- src/Network/Minio/Sign/V4.hs | 23 +++++++------- src/Network/Minio/XmlGenerator.hs | 3 +- src/Network/Minio/XmlParser.hs | 13 +++++--- test/LiveServer.hs | 39 ++++++++++++------------ test/Spec.hs | 7 +++-- 14 files changed, 89 insertions(+), 61 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 6efe221..6ba68b1 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -21,9 +21,15 @@ env: MINIO_SECURE: 1 jobs: + ormolu: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v2 + - uses: mrkkrp/ormolu-action@v6 cabal: name: ${{ matrix.os }} / ghc-${{ matrix.ghc }} / cabal-${{ matrix.cabal }} runs-on: ${{ matrix.os }} + needs: ormolu strategy: matrix: os: [ubuntu-latest, windows-latest] # Removed macos-latest due to cert issues. diff --git a/examples/PresignedGetObject.hs b/examples/PresignedGetObject.hs index 7a87445..5c2e8e5 100755 --- a/examples/PresignedGetObject.hs +++ b/examples/PresignedGetObject.hs @@ -77,7 +77,8 @@ main = do let hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"] curlCmd = B.intercalate " " $ - ["curl --fail"] ++ map hdrOpt headers + ["curl --fail"] + ++ map hdrOpt headers ++ ["-o /tmp/myfile", B.concat ["'", url, "'"]] putStrLn $ diff --git a/examples/PresignedPutObject.hs b/examples/PresignedPutObject.hs index b44bdee..2355dc7 100755 --- a/examples/PresignedPutObject.hs +++ b/examples/PresignedPutObject.hs @@ -48,7 +48,8 @@ main = do let hdrOpt (k, v) = B.concat ["-H '", original k, ": ", v, "'"] curlCmd = B.intercalate " " $ - ["curl "] ++ map hdrOpt headers + ["curl "] + ++ map hdrOpt headers ++ ["-T /tmp/myfile", B.concat ["'", url, "'"]] putStrLn $ diff --git a/src/Network/Minio/AdminAPI.hs b/src/Network/Minio/AdminAPI.hs index d27e2d4..0193215 100644 --- a/src/Network/Minio/AdminAPI.hs +++ b/src/Network/Minio/AdminAPI.hs @@ -432,7 +432,9 @@ healPath bucket prefix = do if (isJust bucket) then encodeUtf8 $ - "v1/heal/" <> fromMaybe "" bucket <> "/" + "v1/heal/" + <> fromMaybe "" bucket + <> "/" <> fromMaybe "" prefix else encodeUtf8 ("v1/heal/" :: Text) @@ -611,9 +613,9 @@ buildAdminRequest areq = do areq { ariPayloadHash = Just sha256Hash, ariHeaders = - hostHeader : - sha256Header sha256Hash : - ariHeaders areq + hostHeader + : sha256Header sha256Hash + : ariHeaders areq } signReq = toRequest ci newAreq sp = diff --git a/src/Network/Minio/CopyObject.hs b/src/Network/Minio/CopyObject.hs index 7454346..4d173a0 100644 --- a/src/Network/Minio/CopyObject.hs +++ b/src/Network/Minio/CopyObject.hs @@ -50,8 +50,8 @@ copyObjectInternal b' o srcInfo = do || (endOffset >= srcSize) ) ) - $ throwIO $ - MErrVInvalidSrcObjByteRange range + $ throwIO + $ MErrVInvalidSrcObjByteRange range -- 1. If sz > 64MiB (minPartSize) use multipart copy, OR -- 2. If startOffset /= 0 use multipart copy diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index d367d9a..5127fc6 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -587,7 +587,8 @@ defaultGetObjectOptions = gooToHeaders :: GetObjectOptions -> [HT.Header] gooToHeaders goo = - rangeHdr ++ zip names values + rangeHdr + ++ zip names values ++ maybe [] (toPutObjectHeaders . SSEC) (gooSSECKey goo) where names = diff --git a/src/Network/Minio/ListOps.hs b/src/Network/Minio/ListOps.hs index d288af7..65860c0 100644 --- a/src/Network/Minio/ListOps.hs +++ b/src/Network/Minio/ListOps.hs @@ -143,12 +143,12 @@ listIncompleteUploads bucket prefix recurse = loop Nothing Nothing C..| CC.sinkList return $ foldl' (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos - CL.sourceList $ - map + CL.sourceList + $ map ( \((uKey, uId, uInitTime), size) -> UploadInfo uKey uId uInitTime size ) - $ zip (lurUploads res) aggrSizes + $ zip (lurUploads res) aggrSizes when (lurHasMore res) $ loop (lurNextKey res) (lurNextUpload res) diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs index 44f21e2..b289a1e 100644 --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -53,9 +53,11 @@ import Network.Minio.Errors import Network.Minio.Sign.V4 import Network.URI (uriToString) +{- ORMOLU_DISABLE -} #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.Key as A #endif +{- ORMOLU_ENABLE -} -- | Generate a presigned URL. This function allows for advanced usage -- - for simple cases prefer the `presigned*Url` functions. @@ -178,6 +180,7 @@ data PostPolicyCondition | PPCRange Text Int64 Int64 deriving stock (Show, Eq) +{- ORMOLU_DISABLE -} instance Json.ToJSON PostPolicyCondition where toJSON (PPCStartsWith k v) = Json.toJSON ["starts-with", k, v] #if MIN_VERSION_aeson(2,0,0) @@ -196,6 +199,7 @@ instance Json.ToJSON PostPolicyCondition where #endif toEncoding (PPCRange k minVal maxVal) = Json.foldable [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal] +{- ORMOLU_ENABLE -} -- | A PostPolicy is required to perform uploads via browser forms. data PostPolicy = PostPolicy @@ -338,7 +342,8 @@ presignedPostPolicy p = do url = toStrictBS $ toLazyByteString $ - scheme <> byteString (getHostAddr ci) + scheme + <> byteString (getHostAddr ci) <> byteString "/" <> byteString bucket <> byteString "/" diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index 77befdf..f8fbd4e 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -131,7 +131,8 @@ parseGetObjectHeaders object headers = let metadataPairs = getMetadata headers userMetadata = getUserMetadataMap metadataPairs metadata = getNonUserMetadataMap metadataPairs - in ObjectInfo <$> Just object + in ObjectInfo + <$> Just object <*> getLastModifiedHeader headers <*> getETagHeader headers <*> getContentLength headers @@ -387,8 +388,8 @@ srcInfoToHeaders srcInfo = "/", srcObject srcInfo ] - ) : - rangeHdr + ) + : rangeHdr ++ zip names values where names = @@ -519,14 +520,14 @@ listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker maxKeys where -- build query params params = - ("uploads", Nothing) : - mkOptionalParams - [ ("prefix", prefix), - ("delimiter", delimiter), - ("key-marker", keyMarker), - ("upload-id-marker", uploadIdMarker), - ("max-uploads", show <$> maxKeys) - ] + ("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' :: diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 37e8950..4338b45 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -198,14 +198,14 @@ mkCanonicalRequest :: 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) + 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 $ @@ -298,8 +298,8 @@ signV4Stream !payloadLength !sp !req = in case ceMay of Nothing -> ("content-encoding", "aws-chunked") : hs Just (_, ce) -> - ("content-encoding", ce <> ",aws-chunked") : - filter (\(x, _) -> x /= "content-encoding") hs + ("content-encoding", ce <> ",aws-chunked") + : filter (\(x, _) -> x /= "content-encoding") hs -- headers to be added to the request datePair = ("X-Amz-Date", awsTimeFormatBS ts) computedHeaders = @@ -385,7 +385,8 @@ signV4Stream !payloadLength !sp !req = let strToSign = chunkStrToSign prevSign (hashSHA256 bs) nextSign = computeSignature strToSign signingKey chunkBS = - toHexStr lps <> ";chunk-signature=" + toHexStr lps + <> ";chunk-signature=" <> nextSign <> "\r\n" <> bs diff --git a/src/Network/Minio/XmlGenerator.hs b/src/Network/Minio/XmlGenerator.hs index a2c381f..6c84e5f 100644 --- a/src/Network/Minio/XmlGenerator.hs +++ b/src/Network/Minio/XmlGenerator.hs @@ -105,7 +105,8 @@ instance ToXNode Notification where toXNodesWithArnName :: Text -> Text -> NotificationConfig -> XNode toXNodesWithArnName eltName arnName (NotificationConfig itemId arn events fRule) = XNode eltName $ - [XLeaf "Id" itemId, XLeaf arnName arn] ++ map toXNode events + [XLeaf "Id" itemId, XLeaf arnName arn] + ++ map toXNode events ++ [toXNode fRule] instance ToXNode Filter where diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index 94a2f29..b537082 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -235,7 +235,8 @@ parseNotification xmldata = do qcfg = map node $ r $/ s3Elem' "QueueConfiguration" tcfg = map node $ r $/ s3Elem' "TopicConfiguration" lcfg = map node $ r $/ s3Elem' "CloudFunctionConfiguration" - Notification <$> (mapM (parseNode ns "Queue") qcfg) + Notification + <$> (mapM (parseNode ns "Queue") qcfg) <*> (mapM (parseNode ns "Topic") tcfg) <*> (mapM (parseNode ns "CloudFunction") lcfg) where @@ -249,8 +250,11 @@ parseNotification xmldata = do 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 + c + $/ s3Elem ns "Filter" + &/ s3Elem ns "S3Key" + &/ s3Elem ns "FilterRule" + &| getFilterRule ns return $ NotificationConfig itemId @@ -264,6 +268,7 @@ parseSelectProgress xmldata = do 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 + Progress + <$> parseDecimal bScanned <*> parseDecimal bProcessed <*> parseDecimal bReturned diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 194dbeb..1efd549 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -136,7 +136,8 @@ basicTests = funTestWithBucket "Basic tests" $ unless (length (filter (== bucket) $ map biName buckets) == 1) $ liftIO $ assertFailure - ( "The bucket " ++ show bucket + ( "The bucket " + ++ show bucket ++ " was expected to exist." ) @@ -367,11 +368,11 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $ step "High-level recursive listing of objects" objects <- C.runConduit $ listObjects bucket Nothing True C..| sinkList - liftIO $ - assertEqual + liftIO + $ assertEqual "Objects match failed!" (Just $ sort expectedObjects) - $ extractObjectsFromList objects + $ extractObjectsFromList objects step "High-level listing of objects (version 1)" itemsV1 <- C.runConduit $ listObjectsV1 bucket Nothing False C..| sinkList @@ -385,45 +386,45 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $ listObjectsV1 bucket Nothing True C..| sinkList - liftIO $ - assertEqual + liftIO + $ assertEqual "Objects match failed!" (Just $ sort expectedObjects) - $ extractObjectsFromList objectsV1 + $ 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 + liftIO + $ assertEqual "Objects/Dirs under prefix match failed!" expectedPrefListing - $ extractObjectsAndDirsFromList prefItems + $ extractObjectsAndDirsFromList prefItems step "High-level listing with prefix recursive" prefItemsRec <- C.runConduit $ listObjects bucket (Just "dir/") True C..| sinkList - liftIO $ - assertEqual + liftIO + $ assertEqual "Objects/Dirs under prefix match recursive failed!" expectedPrefListingRec - $ extractObjectsFromList prefItemsRec + $ extractObjectsFromList prefItemsRec step "High-level listing with prefix (version 1)" prefItemsV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") False C..| sinkList - liftIO $ - assertEqual + liftIO + $ assertEqual "Objects/Dirs under prefix match failed!" expectedPrefListing - $ extractObjectsAndDirsFromList prefItemsV1 + $ extractObjectsAndDirsFromList prefItemsV1 step "High-level listing with prefix recursive (version 1)" prefItemsRecV1 <- C.runConduit $ listObjectsV1 bucket (Just "dir/") True C..| sinkList - liftIO $ - assertEqual + liftIO + $ assertEqual "Objects/Dirs under prefix match recursive failed!" expectedPrefListingRec - $ extractObjectsFromList prefItemsRecV1 + $ extractObjectsFromList prefItemsRecV1 step "Cleanup actions" forM_ expectedObjects $ diff --git a/test/Spec.hs b/test/Spec.hs index 418e04f..e0c0b09 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -79,7 +79,9 @@ qcProps = listToMaybe sizes | otherwise -> False in n < 0 - || ( isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk + || ( isPNumsAscendingFrom1 + && isOffsetsAsc + && isSumSizeOk && isSizesConstantExceptLast && isMinPartSizeOk ), @@ -105,7 +107,8 @@ qcProps = isContParts = length fsts == length snds && and (map (\(a, b) -> a == b + 1) $ zip fsts snds) - in start < 0 || start > end + in start < 0 + || start > end || (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts), QC.testProperty "mkSSECKey:" $ \w8s -> From d59f45fec4481313cfb5fafd635558ce385e7422 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Fri, 27 May 2022 14:33:05 -0700 Subject: [PATCH 13/24] Hlint fixes (#173) * Hlint fixes - Will require major version bump as some types were changed from data to newtype * ormolu fixes after hlint --- examples/FileUploader.hs | 2 +- examples/GetConfig.hs | 4 +- examples/GetObject.hs | 2 +- examples/Heal.hs | 1 - examples/ListIncompleteUploads.hs | 2 +- examples/ListObjects.hs | 2 +- examples/PresignedGetObject.hs | 2 +- examples/PresignedPostPolicy.hs | 9 ++-- examples/SelectObject.hs | 4 +- examples/ServerInfo.hs | 4 +- examples/ServiceSendRestart.hs | 1 - examples/ServiceSendStop.hs | 1 - examples/ServiceStatus.hs | 4 +- minio-hs.cabal | 1 + src/Network/Minio/API.hs | 45 ++++++++++---------- src/Network/Minio/AdminAPI.hs | 13 +++--- src/Network/Minio/Data.hs | 49 +++++++++------------ src/Network/Minio/ListOps.hs | 13 +++--- src/Network/Minio/PresignedOperations.hs | 9 ++-- src/Network/Minio/S3API.hs | 3 +- src/Network/Minio/Sign/V4.hs | 23 +++++----- src/Network/Minio/Utils.hs | 4 +- src/Network/Minio/XmlGenerator.hs | 4 +- src/Network/Minio/XmlParser.hs | 8 ++-- test/LiveServer.hs | 54 ++++++++++++------------ test/Network/Minio/JsonParser/Test.hs | 2 +- test/Network/Minio/XmlParser/Test.hs | 2 +- test/Spec.hs | 12 +++--- 28 files changed, 136 insertions(+), 144 deletions(-) diff --git a/examples/FileUploader.hs b/examples/FileUploader.hs index dde340f..c5f3555 100755 --- a/examples/FileUploader.hs +++ b/examples/FileUploader.hs @@ -70,5 +70,5 @@ main = do 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 249a2c7..364affa 100755 --- a/examples/GetConfig.hs +++ b/examples/GetConfig.hs @@ -16,7 +16,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -- -{-# LANGUAGE OverloadedStrings #-} import Network.Minio import Network.Minio.AdminAPI @@ -25,6 +24,7 @@ import Prelude main :: IO () main = do res <- - runMinio minioPlayCI $ + runMinio + minioPlayCI getConfig print res diff --git a/examples/GetObject.hs b/examples/GetObject.hs index ffd2c1e..97d9b2d 100755 --- a/examples/GetObject.hs +++ b/examples/GetObject.hs @@ -37,5 +37,5 @@ main = do 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/Heal.hs b/examples/Heal.hs index 35a9a20..0d9e5e1 100755 --- a/examples/Heal.hs +++ b/examples/Heal.hs @@ -16,7 +16,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -- -{-# LANGUAGE OverloadedStrings #-} import Network.Minio import Network.Minio.AdminAPI diff --git a/examples/ListIncompleteUploads.hs b/examples/ListIncompleteUploads.hs index 4b17389..6313766 100755 --- a/examples/ListIncompleteUploads.hs +++ b/examples/ListIncompleteUploads.hs @@ -36,7 +36,7 @@ main = do res <- runMinio minioPlayCI $ runConduit $ - listIncompleteUploads bucket Nothing True .| mapM_C (\v -> (liftIO $ print v)) + listIncompleteUploads bucket Nothing True .| mapM_C (liftIO . print) print res {- diff --git a/examples/ListObjects.hs b/examples/ListObjects.hs index a25917e..58a42ff 100755 --- a/examples/ListObjects.hs +++ b/examples/ListObjects.hs @@ -36,7 +36,7 @@ main = do res <- runMinio minioPlayCI $ runConduit $ - listObjects bucket Nothing True .| mapM_C (\v -> (liftIO $ print v)) + listObjects bucket Nothing True .| mapM_C (liftIO . print) print res {- diff --git a/examples/PresignedGetObject.hs b/examples/PresignedGetObject.hs index 5c2e8e5..5add112 100755 --- a/examples/PresignedGetObject.hs +++ b/examples/PresignedGetObject.hs @@ -46,7 +46,7 @@ main = do res <- runMinio minioPlayCI $ do liftIO $ B.putStrLn "Upload a file that we will fetch with a presigned URL..." putObject bucket object (CC.repeat "a") (Just kb15) defaultPutObjectOptions - liftIO $ putStrLn $ "Done. Object created at: my-bucket/my-object" + liftIO $ putStrLn "Done. Object created at: my-bucket/my-object" -- Extract Etag of uploaded object oi <- statObject bucket object defaultGetObjectOptions diff --git a/examples/PresignedPostPolicy.hs b/examples/PresignedPostPolicy.hs index 05d1d4d..ac1f9bb 100755 --- a/examples/PresignedPostPolicy.hs +++ b/examples/PresignedPostPolicy.hs @@ -55,7 +55,7 @@ main = do ] case policyE of - Left err -> putStrLn $ show err + Left err -> print err Right policy -> do res <- runMinio minioPlayCI $ do (url, formData) <- presignedPostPolicy policy @@ -74,13 +74,14 @@ main = do formOptions = B.intercalate " " $ map formFn $ H.toList formData return $ - B.intercalate " " $ + B.intercalate + " " ["curl", formOptions, "-F file=@/tmp/photo.jpg", url] case res of - Left e -> putStrLn $ "post-policy error: " ++ (show e) + Left e -> putStrLn $ "post-policy error: " ++ show e Right cmd -> do - putStrLn $ "Put a photo at /tmp/photo.jpg and run command:\n" + putStrLn "Put a photo at /tmp/photo.jpg and run command:\n" -- print the generated curl command Char8.putStrLn cmd diff --git a/examples/SelectObject.hs b/examples/SelectObject.hs index 033ddeb..f4c5ab1 100755 --- a/examples/SelectObject.hs +++ b/examples/SelectObject.hs @@ -19,7 +19,7 @@ {-# LANGUAGE OverloadedStrings #-} import qualified Conduit as C -import Control.Monad (when) +import Control.Monad (unless) import Network.Minio import Prelude @@ -35,7 +35,7 @@ main = do res <- runMinio minioPlayCI $ do exists <- bucketExists bucket - when (not exists) $ + unless exists $ makeBucket bucket Nothing C.liftIO $ putStrLn "Uploading csv object" diff --git a/examples/ServerInfo.hs b/examples/ServerInfo.hs index a11ec07..bc24a1c 100755 --- a/examples/ServerInfo.hs +++ b/examples/ServerInfo.hs @@ -16,7 +16,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -- -{-# LANGUAGE OverloadedStrings #-} import Network.Minio import Network.Minio.AdminAPI @@ -25,6 +24,7 @@ import Prelude main :: IO () main = do res <- - runMinio minioPlayCI $ + runMinio + minioPlayCI getServerInfo print res diff --git a/examples/ServiceSendRestart.hs b/examples/ServiceSendRestart.hs index a8f565b..70b89df 100755 --- a/examples/ServiceSendRestart.hs +++ b/examples/ServiceSendRestart.hs @@ -16,7 +16,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -- -{-# LANGUAGE OverloadedStrings #-} import Network.Minio import Network.Minio.AdminAPI diff --git a/examples/ServiceSendStop.hs b/examples/ServiceSendStop.hs index b4fd277..56a1167 100755 --- a/examples/ServiceSendStop.hs +++ b/examples/ServiceSendStop.hs @@ -16,7 +16,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -- -{-# LANGUAGE OverloadedStrings #-} import Network.Minio import Network.Minio.AdminAPI diff --git a/examples/ServiceStatus.hs b/examples/ServiceStatus.hs index 39739be..60a7bcd 100755 --- a/examples/ServiceStatus.hs +++ b/examples/ServiceStatus.hs @@ -16,7 +16,6 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -- -{-# LANGUAGE OverloadedStrings #-} import Network.Minio import Network.Minio.AdminAPI @@ -25,6 +24,7 @@ import Prelude main :: IO () main = do res <- - runMinio minioPlayCI $ + runMinio + minioPlayCI serviceStatus print res diff --git a/minio-hs.cabal b/minio-hs.cabal index 0c8650b..14a38d3 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -58,6 +58,7 @@ common base-settings , DerivingStrategies , FlexibleContexts , FlexibleInstances + , LambdaCase , MultiParamTypeClasses , MultiWayIf , OverloadedStrings diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index 87c3337..a4f7633 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -130,18 +130,18 @@ getHostPathRegion ri = do regionMay ) virtualStyle = - ( ( bucket <> "." <> regionHost, - encodeUtf8 $ "/" <> fromMaybe "" (riObject ri), - regionMay - ) + ( bucket <> "." <> regionHost, + encodeUtf8 $ "/" <> fromMaybe "" (riObject ri), + regionMay ) - if - | isAWSConnectInfo ci -> - return $ - if bucketHasPeriods bucket - then pathStyle - else virtualStyle - | otherwise -> return pathStyle + ( if isAWSConnectInfo ci + then + return $ + if bucketHasPeriods bucket + then pathStyle + else virtualStyle + else return pathStyle + ) buildRequest :: S3ReqInfo -> Minio NC.Request buildRequest ri = do @@ -203,7 +203,7 @@ buildRequest ri = do existingQueryParams = HT.parseQuery (NC.queryString baseRequest) updatedQueryParams = existingQueryParams ++ qpToAdd return $ NClient.setQueryString updatedQueryParams baseRequest - | isStreamingPayload (riPayload ri') && (not $ connectIsSecure ci') -> + | isStreamingPayload (riPayload ri') && not (connectIsSecure ci') -> -- case 2 from above. do (pLen, pSrc) <- case riPayload ri of @@ -214,15 +214,16 @@ buildRequest ri = do | otherwise -> do sp' <- - if - | connectIsSecure ci' -> - -- case 1 described above. - return sp - | otherwise -> - -- case 3 described above. + ( if connectIsSecure ci' + then -- case 1 described above. + return sp + else + ( -- case 3 described above. do pHash <- getPayloadSHA256Hash $ riPayload ri' return $ sp {spPayloadHash = Just pHash} + ) + ) let signHeaders = signV4 sp' baseRequest return $ @@ -285,8 +286,8 @@ isValidBucketName bucket = not ( or [ len < 3 || len > 63, - or (map labelCheck labels), - or (map labelCharsCheck labels), + any labelCheck labels, + any labelCharsCheck labels, isIPCheck ] ) @@ -316,7 +317,7 @@ isValidBucketName bucket = -- Throws exception iff bucket name is invalid according to AWS rules. checkBucketNameValidity :: MonadIO m => Bucket -> m () checkBucketNameValidity bucket = - when (not $ isValidBucketName bucket) $ + unless (isValidBucketName bucket) $ throwIO $ MErrVInvalidBucketName bucket @@ -326,6 +327,6 @@ isValidObjectName object = checkObjectNameValidity :: MonadIO m => Object -> m () checkObjectNameValidity object = - when (not $ isValidObjectName object) $ + unless (isValidObjectName object) $ throwIO $ MErrVInvalidObjectName object diff --git a/src/Network/Minio/AdminAPI.hs b/src/Network/Minio/AdminAPI.hs index 0193215..b15598c 100644 --- a/src/Network/Minio/AdminAPI.hs +++ b/src/Network/Minio/AdminAPI.hs @@ -429,7 +429,7 @@ instance FromJSON HealStatus where healPath :: Maybe Bucket -> Maybe Text -> ByteString healPath bucket prefix = do - if (isJust bucket) + if isJust bucket then encodeUtf8 $ "v1/heal/" @@ -599,12 +599,11 @@ buildAdminRequest :: AdminReqInfo -> Minio NC.Request buildAdminRequest areq = do ci <- asks mcConnInfo sha256Hash <- - if - | connectIsSecure ci -> - -- if secure connection - return "UNSIGNED-PAYLOAD" - -- otherwise compute sha256 - | otherwise -> getPayloadSHA256Hash (ariPayload areq) + if connectIsSecure ci + then -- if secure connection + return "UNSIGNED-PAYLOAD" + else -- otherwise compute sha256 + getPayloadSHA256Hash (ariPayload areq) timeStamp <- liftIO getCurrentTime diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 5127fc6..a49098e 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -161,7 +161,7 @@ findFirst (f : fs) = do fromAWSConfigFile :: Provider fromAWSConfigFile = do credsE <- runExceptT $ do - homeDir <- lift $ getHomeDirectory + homeDir <- lift getHomeDirectory let awsCredsFile = homeDir `combine` ".aws" `combine` "credentials" fileExists <- lift $ doesFileExist awsCredsFile bool (throwE "FileNotFound") (return ()) fileExists @@ -201,7 +201,7 @@ setCredsFrom ps ci = do pMay <- findFirst ps maybe (throwIO MErrVMissingCredentials) - (return . (flip setCreds ci)) + (return . (`setCreds` ci)) pMay -- | setCreds sets the given `Credentials` in the `ConnectInfo`. @@ -234,11 +234,11 @@ disableTLSCertValidation c = c {connectDisableTLSCertValidation = True} getHostAddr :: ConnectInfo -> ByteString getHostAddr ci = - if - | port == 80 || port == 443 -> encodeUtf8 host - | otherwise -> - encodeUtf8 $ - T.concat [host, ":", show port] + if port == 80 || port == 443 + then encodeUtf8 host + else + encodeUtf8 $ + T.concat [host, ":", show port] where port = connectPort ci host = connectHost ci @@ -382,12 +382,12 @@ addXAmzMetaPrefix s | otherwise = "X-Amz-Meta-" <> s mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header] -mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix $ x, encodeUtf8 y)) +mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix x, encodeUtf8 y)) pooToHeaders :: PutObjectOptions -> [HT.Header] pooToHeaders poo = userMetadata - ++ (catMaybes $ map tupToMaybe (zipWith (,) names values)) + ++ mapMaybe tupToMaybe (zip names values) ++ maybe [] toPutObjectHeaders (pooSSE poo) where tupToMaybe (k, Just v) = Just (k, v) @@ -658,7 +658,7 @@ textToEvent t = case t of _ -> Nothing -- | Filter data type - part of notification configuration -data Filter = Filter +newtype Filter = Filter { fFilter :: FilterKey } deriving stock (Show, Eq) @@ -669,7 +669,7 @@ defaultFilter :: Filter defaultFilter = Filter defaultFilterKey -- | FilterKey contains FilterRules, and is part of a Filter. -data FilterKey = FilterKey +newtype FilterKey = FilterKey { fkKey :: FilterRules } deriving stock (Show, Eq) @@ -680,7 +680,7 @@ defaultFilterKey :: FilterKey defaultFilterKey = FilterKey defaultFilterRules -- | FilterRules represents a collection of `FilterRule`s. -data FilterRules = FilterRules +newtype FilterRules = FilterRules { frFilterRules :: [FilterRule] } deriving stock (Show, Eq) @@ -856,21 +856,15 @@ type CSVInputProp = CSVProp -- | CSVProp represents CSV format properties. It is built up using -- the Monoid instance. -data CSVProp = CSVProp (H.HashMap Text Text) +newtype CSVProp = CSVProp (H.HashMap Text Text) deriving stock (Show, Eq) -#if (__GLASGOW_HASKELL__ >= 804) instance Semigroup CSVProp where - (CSVProp a) <> (CSVProp b) = CSVProp (b <> a) -#endif + (CSVProp a) <> (CSVProp b) = CSVProp (b <> a) instance Monoid CSVProp where mempty = CSVProp mempty -#if (__GLASGOW_HASKELL__ < 804) - mappend (CSVProp a) (CSVProp b) = CSVProp (b <> a) -#endif - csvPropsList :: CSVProp -> [(Text, Text)] csvPropsList (CSVProp h) = sort $ H.toList h @@ -927,9 +921,9 @@ setInputCSVProps p is = is {isFormatInfo = InputFormatCSV p} -- | Set the CSV format properties in the OutputSerialization. outputCSVFromProps :: CSVProp -> OutputSerialization -outputCSVFromProps p = OutputSerializationCSV p +outputCSVFromProps = OutputSerializationCSV -data JSONInputProp = JSONInputProp {jsonipType :: JSONType} +newtype JSONInputProp = JSONInputProp {jsonipType :: JSONType} deriving stock (Show, Eq) data JSONType = JSONTypeDocument | JSONTypeLines @@ -957,7 +951,7 @@ quoteFields q = CSVProp $ data QuoteFields = QuoteFieldsAsNeeded | QuoteFieldsAlways deriving stock (Show, Eq) -data JSONOutputProp = JSONOutputProp {jsonopRecordDelimiter :: Maybe Text} +newtype JSONOutputProp = JSONOutputProp {jsonopRecordDelimiter :: Maybe Text} deriving stock (Show, Eq) -- | Set the output record delimiter for JSON format @@ -1089,11 +1083,10 @@ class HasSvcNamespace env where 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/" + in ( if host == "storage.googleapis.com" + then "http://doc.s3.amazonaws.com/2006-03-01" + else "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 diff --git a/src/Network/Minio/ListOps.hs b/src/Network/Minio/ListOps.hs index 65860c0..ac71252 100644 --- a/src/Network/Minio/ListOps.hs +++ b/src/Network/Minio/ListOps.hs @@ -143,12 +143,15 @@ listIncompleteUploads bucket prefix recurse = loop Nothing Nothing C..| CC.sinkList return $ foldl' (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos - CL.sourceList - $ map - ( \((uKey, uId, uInitTime), size) -> - UploadInfo uKey uId uInitTime size + CL.sourceList $ + zipWith + ( curry + ( \((uKey, uId, uInitTime), size) -> + UploadInfo uKey uId uInitTime size + ) ) - $ zip (lurUploads res) aggrSizes + (lurUploads res) + aggrSizes when (lurHasMore res) $ loop (lurNextKey res) (lurNextUpload res) diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs index b289a1e..dadca93 100644 --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -210,7 +210,7 @@ data PostPolicy = PostPolicy instance Json.ToJSON PostPolicy where toJSON (PostPolicy e c) = - Json.object $ + Json.object [ "expiration" .= iso8601TimeFormat e, "conditions" .= c ] @@ -298,7 +298,7 @@ presignedPostPolicy :: Minio (ByteString, H.HashMap Text ByteString) presignedPostPolicy p = do ci <- asks mcConnInfo - signTime <- liftIO $ Time.getCurrentTime + signTime <- liftIO Time.getCurrentTime let extraConditions = [ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime), @@ -332,8 +332,9 @@ presignedPostPolicy p = do formFromPolicy = H.map encodeUtf8 $ H.fromList $ - catMaybes $ - mkPair <$> conditions ppWithCreds + mapMaybe + mkPair + (conditions ppWithCreds) formData = formFromPolicy `H.union` signData -- compute POST upload URL bucket = H.lookupDefault "" "bucket" formData diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index f8fbd4e..80555f0 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -407,8 +407,7 @@ srcInfoToHeaders srcInfo = fmap formatRFC1123 . srcIfModifiedSince ] rangeHdr = - maybe [] (\a -> [("x-amz-copy-source-range", HT.renderByteRanges [a])]) $ - toByteRange <$> srcRange srcInfo + 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) diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 4338b45..86d604b 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -130,9 +130,9 @@ signV4 !sp !req = datePair = ("X-Amz-Date", awsTimeFormatBS ts) computedHeaders = NC.requestHeaders req - ++ if isJust $ expiry + ++ if isJust expiry then [] - else map (\(x, y) -> (mk x, y)) [datePair, sha256Hdr] + else map (first mk) [datePair, sha256Hdr] headersToSign = getHeadersToSign computedHeaders signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign -- query-parameters to be added before signing for presigned URLs @@ -169,7 +169,7 @@ signV4 !sp !req = if isJust expiry then ("X-Amz-Signature", signature) : authQP else - [ (\(x, y) -> (CI.foldedCase x, y)) authHeader, + [ first CI.foldedCase authHeader, datePair, sha256Hdr ] @@ -188,7 +188,7 @@ mkScope ts region = getHeadersToSign :: [Header] -> [(ByteString, ByteString)] getHeadersToSign !h = filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $ - map (\(x, y) -> (CI.foldedCase x, stripBS y)) h + map (bimap CI.foldedCase stripBS) h mkCanonicalRequest :: Bool -> @@ -198,14 +198,13 @@ mkCanonicalRequest :: 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) + B.intercalate "&" $ + map (\(x, y) -> B.concat [x, "=", y]) $ + sort $ + map + ( bimap (uriEncode True) (maybe "" (uriEncode True)) + ) + (parseQuery $ NC.queryString req) sortedHeaders = sort headersForSign canonicalHeaders = B.concat $ diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index af0f3c8..2ecab7c 100644 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -103,7 +103,7 @@ withNewHandle fp fileAction = do return resE mkHeaderFromPairs :: [(ByteString, ByteString)] -> [HT.Header] -mkHeaderFromPairs = map ((\(x, y) -> (mk x, y))) +mkHeaderFromPairs = map (first mk) lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString lookupHeader hdr = listToMaybe . map snd . filter (\(h, _) -> h == hdr) @@ -113,7 +113,7 @@ 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) = diff --git a/src/Network/Minio/XmlGenerator.hs b/src/Network/Minio/XmlGenerator.hs index 6c84e5f..730def0 100644 --- a/src/Network/Minio/XmlGenerator.hs +++ b/src/Network/Minio/XmlGenerator.hs @@ -190,7 +190,7 @@ mkSelectRequest r = LBS.toStrict $ renderLBS def sr Element "CSV" mempty - (map NodeElement $ map kvElement $ csvPropsList c) + (map (NodeElement . kvElement) (csvPropsList c)) formatNode (InputFormatJSON p) = Element "JSON" @@ -218,7 +218,7 @@ mkSelectRequest r = LBS.toStrict $ renderLBS def sr Element "CSV" mempty - (map NodeElement $ map kvElement $ csvPropsList c) + (map (NodeElement . kvElement) (csvPropsList c)) ] rdElem Nothing = [] rdElem (Just t) = diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index b537082..7ab2178 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -236,9 +236,9 @@ parseNotification xmldata = do tcfg = map node $ r $/ s3Elem' "TopicConfiguration" lcfg = map node $ r $/ s3Elem' "CloudFunctionConfiguration" Notification - <$> (mapM (parseNode ns "Queue") qcfg) - <*> (mapM (parseNode ns "Topic") tcfg) - <*> (mapM (parseNode ns "CloudFunction") lcfg) + <$> mapM (parseNode ns "Queue") qcfg + <*> mapM (parseNode ns "Topic") tcfg + <*> mapM (parseNode ns "CloudFunction") lcfg where getFilterRule ns c = let name = T.concat $ c $/ s3Elem ns "Name" &/ content @@ -248,7 +248,7 @@ parseNotification xmldata = do let c = fromNode nodeData itemId = T.concat $ c $/ s3Elem ns "Id" &/ content arn = T.concat $ c $/ s3Elem ns arnName &/ content - events = catMaybes $ map textToEvent $ c $/ s3Elem ns "Event" &/ content + events = mapMaybe textToEvent (c $/ s3Elem ns "Event" &/ content) rules = c $/ s3Elem ns "Filter" diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 1efd549..8c93ea1 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -52,7 +52,7 @@ tests = testGroup "Tests" [liveServerUnitTests] -- conduit that generates random binary stream of given length randomDataSrc :: MonadIO m => Int64 -> C.ConduitM () ByteString m () -randomDataSrc s' = genBS s' +randomDataSrc = genBS where concatIt bs n = BS.concat $ @@ -180,7 +180,7 @@ basicTests = funTestWithBucket "Basic tests" $ "test-file" outFile defaultGetObjectOptions - { gooIfUnmodifiedSince = (Just unmodifiedTime) + { gooIfUnmodifiedSince = Just unmodifiedTime } case resE of Left exn -> liftIO $ exn @?= ServiceErr "PreconditionFailed" "At least one of the pre-conditions you specified did not hold" @@ -194,7 +194,7 @@ basicTests = funTestWithBucket "Basic tests" $ "test-file" outFile defaultGetObjectOptions - { gooIfMatch = (Just "invalid-etag") + { 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" @@ -208,7 +208,7 @@ basicTests = funTestWithBucket "Basic tests" $ "test-file" outFile defaultGetObjectOptions - { gooRange = (Just $ HT.ByteRangeFromTo 100 300) + { gooRange = Just $ HT.ByteRangeFromTo 100 300 } case resE2 of Left exn -> liftIO $ exn @?= ServiceErr "InvalidRange" "The requested range is not satisfiable" @@ -220,7 +220,7 @@ basicTests = funTestWithBucket "Basic tests" $ "test-file" outFile defaultGetObjectOptions - { gooRange = (Just $ HT.ByteRangeFrom 1) + { gooRange = Just $ HT.ByteRangeFrom 1 } step "fGetObject a non-existent object and check for NoSuchKey exception" @@ -231,7 +231,7 @@ basicTests = funTestWithBucket "Basic tests" $ step "create new multipart upload works" uid <- newMultipartUpload bucket "newmpupload" [] - liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") + liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id." step "abort a new multipart upload works" abortMultipartUpload bucket "newmpupload" uid @@ -247,7 +247,7 @@ basicTests = funTestWithBucket "Basic tests" $ step "get metadata of the object" res <- statObject bucket object defaultGetObjectOptions - liftIO $ (oiSize res) @?= 0 + liftIO $ oiSize res @?= 0 step "delete object" deleteObject bucket object @@ -262,7 +262,7 @@ lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $ 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.") + liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id." randFile <- mkRandFile mb15 @@ -338,22 +338,20 @@ 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 = + let extractObjectsFromList = mapM - ( \t -> case t of + ( \case ListItemObject o -> Just $ oiObject o _ -> Nothing ) - os - expectedNonRecList = ["o4", "dir/"] - extractObjectsAndDirsFromList os = + extractObjectsAndDirsFromList = map - ( \t -> case t of + ( \case ListItemObject o -> oiObject o ListItemPrefix d -> d ) - os + expectedObjects = ["dir/o1", "dir/dir1/o2", "dir/dir2/o3", "o4"] + expectedNonRecList = ["o4", "dir/"] testFilepath <- mkRandFile 200 forM_ expectedObjects $ @@ -435,7 +433,7 @@ highLevelListingTest = funTestWithBucket "High-level listObjects Test" $ step "create 10 multipart uploads" forM_ [1 .. 10 :: Int] $ \_ -> do uid <- newMultipartUpload bucket object [] - liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") + liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id." step "High-level listing of incomplete multipart uploads" uploads <- @@ -497,7 +495,7 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do map ( T.concat . ("test-file-" :) - . (\x -> [x]) + . (: []) . T.pack . show ) @@ -516,7 +514,7 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do let object = "newmpupload" forM_ [1 .. 10 :: Int] $ \_ -> do uid <- newMultipartUpload bucket object [] - liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") + liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id." step "list incomplete multipart uploads" incompleteUploads <- @@ -527,7 +525,7 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do Nothing Nothing Nothing - liftIO $ (length $ lurUploads incompleteUploads) @?= 10 + liftIO $ length (lurUploads incompleteUploads) @?= 10 step "cleanup" forM_ (lurUploads incompleteUploads) $ @@ -538,7 +536,7 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do step "create a multipart upload" uid <- newMultipartUpload bucket object [] - liftIO $ (T.length uid > 0) @? ("Got an empty multipartUpload Id.") + liftIO $ (T.length uid > 0) @? "Got an empty multipartUpload Id." step "put object parts 1..10" inputFile <- mkRandFile mb5 @@ -548,7 +546,7 @@ listingTest = funTestWithBucket "Listing Test" $ \step bucket -> do step "fetch list parts" listPartsResult <- listIncompleteParts' bucket object uid Nothing Nothing - liftIO $ (length $ lprParts listPartsResult) @?= 10 + liftIO $ length (lprParts listPartsResult) @?= 10 abortMultipartUpload bucket object uid presignedUrlFunTest :: TestTree @@ -662,7 +660,7 @@ presignedPostPolicyFunTest :: TestTree presignedPostPolicyFunTest = funTestWithBucket "Presigned Post Policy tests" $ \step bucket -> do step "presignedPostPolicy basic test" - now <- liftIO $ Time.getCurrentTime + now <- liftIO Time.getCurrentTime let key = "presignedPostPolicyTest/myfile" policyConds = @@ -693,7 +691,7 @@ presignedPostPolicyFunTest = funTestWithBucket "Presigned Post Policy tests" $ postForm url formData inputFile = do req <- NC.parseRequest $ decodeUtf8 url let parts = - map (\(x, y) -> Form.partBS x y) $ + map (uncurry Form.partBS) $ H.toList formData parts' = parts ++ [Form.partFile "file" inputFile] req' <- Form.formDataBody parts' req @@ -750,7 +748,7 @@ bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $ `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") + Right s -> liftIO $ s @?= BS.concat (replicate 100 "c") deleteObject bucket obj @@ -805,7 +803,7 @@ multipartTest = funTestWithBucket "Multipart Tests" $ C.runConduit $ listIncompleteUploads bucket (Just object) False C..| sinkList - liftIO $ (null uploads) @? "removeIncompleteUploads didn't complete successfully" + liftIO $ null uploads @? "removeIncompleteUploads didn't complete successfully" putObjectContentTypeTest :: TestTree putObjectContentTypeTest = funTestWithBucket "putObject contentType tests" $ @@ -913,7 +911,7 @@ putObjectUserMetadataTest = funTestWithBucket "putObject user-metadata test" $ -- need to do a case-insensitive comparison sortedMeta = sort $ - map (\(k, v) -> (T.toLower k, T.toLower v)) $ + map (bimap T.toLower T.toLower) $ H.toList m ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")] @@ -948,7 +946,7 @@ getObjectTest = funTestWithBucket "getObject test" $ -- need to do a case-insensitive comparison sortedMeta = sort $ - map (\(k, v) -> (T.toLower k, T.toLower v)) $ + map (bimap T.toLower T.toLower) $ H.toList m ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")] diff --git a/test/Network/Minio/JsonParser/Test.hs b/test/Network/Minio/JsonParser/Test.hs index fbf4102..9048455 100644 --- a/test/Network/Minio/JsonParser/Test.hs +++ b/test/Network/Minio/JsonParser/Test.hs @@ -34,7 +34,7 @@ jsonParserTests = ] tryValidationErr :: (MonadUnliftIO m) => m a -> m (Either MErrV a) -tryValidationErr act = try act +tryValidationErr = try assertValidationErr :: MErrV -> Assertion assertValidationErr e = assertFailure $ "Failed due to validation error => " ++ show e diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs index 65aac09..1520952 100644 --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -49,7 +49,7 @@ xmlParserTests = ] tryValidationErr :: (MonadUnliftIO m) => m a -> m (Either MErrV a) -tryValidationErr act = try act +tryValidationErr = try assertValidtionErr :: MErrV -> Assertion assertValidtionErr e = assertFailure $ "Failed due to validation error => " ++ show e diff --git a/test/Spec.hs b/test/Spec.hs index e0c0b09..e851043 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -55,17 +55,17 @@ qcProps = \n -> let (pns, offs, sizes) = L.unzip3 (selectPartSizes n) -- check that pns increments from 1. - isPNumsAscendingFrom1 = all (\(a, b) -> a == b) $ zip pns [1 ..] + isPNumsAscendingFrom1 = all (uncurry (==)) $ zip pns [1 ..] consPairs [] = [] consPairs [_] = [] - consPairs (a : (b : c)) = (a, b) : (consPairs (b : c)) + consPairs (a : (b : c)) = (a, b) : consPairs (b : c) -- check `offs` is monotonically increasing. - isOffsetsAsc = all (\(a, b) -> a < b) $ consPairs offs + isOffsetsAsc = all (uncurry (<)) $ 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) + all (uncurry (==)) (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 @@ -94,7 +94,7 @@ qcProps = isFirstPartOk = maybe False ((start ==) . fst) $ listToMaybe pairs -- each pair is >=64MiB except last, and all those parts -- have same size. - initSizes = maybe [] (map (\(a, b) -> b - a + 1)) $ init <$> nonEmpty pairs + initSizes = maybe [] (map (\(a, b) -> b - a + 1) . init) (nonEmpty pairs) isPartSizesOk = all (>= minPartSize) initSizes && maybe @@ -106,7 +106,7 @@ qcProps = snds = take (length pairs - 1) $ map snd pairs isContParts = length fsts == length snds - && and (map (\(a, b) -> a == b + 1) $ zip fsts snds) + && all (\(a, b) -> a == b + 1) (zip fsts snds) in start < 0 || start > end || (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts), From d82b093b6bd25e14ed230c8a62260f79f827ae5c Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Fri, 27 May 2022 16:22:18 -0700 Subject: [PATCH 14/24] Bump up version for new release (#172) - Also add hlint to CI - Also update CI with latest action versions --- .github/workflows/ci.yml | 53 +++++++++++++++++++++++++++++++--------- CHANGELOG.md | 9 +++++++ minio-hs.cabal | 2 +- 3 files changed, 51 insertions(+), 13 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 6ba68b1..8f99aee 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -24,8 +24,25 @@ jobs: ormolu: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - uses: mrkkrp/ormolu-action@v6 + + hlint: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v3 + + - name: 'Set up HLint' + uses: haskell/actions/hlint-setup@v2 + with: + version: '3.4' + + - name: 'Run HLint' + uses: haskell/actions/hlint-run@v2 + with: + path: '["src/", "test/", "examples"]' + fail-on: warning + cabal: name: ${{ matrix.os }} / ghc-${{ matrix.ghc }} / cabal-${{ matrix.cabal }} runs-on: ${{ matrix.os }} @@ -50,10 +67,10 @@ jobs: # ghc: 8.6.5 steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' - - uses: haskell/actions/setup@v1 + - uses: haskell/actions/setup@v2 id: setup-haskell-cabal name: Setup Haskell with: @@ -68,11 +85,15 @@ jobs: run: | cabal freeze - - uses: actions/cache@v2.1.3 - name: Cache ~/.cabal/store + - uses: actions/cache@v3 + name: Cache ~/.cabal/packages, ~/.cabal/store and dist-newstyle with: - path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} - key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} + path: | + ~/.cabal/packages + ~/.cabal/store + dist-newstyle + key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('**/*.cabal', '**/cabal.project', '**/cabal.project.freeze') }} + restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- - name: Install dependencies run: | @@ -128,7 +149,6 @@ jobs: runs-on: ${{ matrix.os }} strategy: matrix: - stack: ["2.7.3"] ghc: - "8.10.7" - "9.0.2" @@ -139,18 +159,27 @@ jobs: - uses: actions/checkout@v2 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' - - uses: haskell/actions/setup@v1 + - uses: haskell/actions/setup@v2 name: Setup Haskell Stack with: enable-stack: true ghc-version: ${{ matrix.ghc }} - stack-version: ${{ matrix.stack }} + stack-version: 'latest' - - uses: actions/cache@v2.1.3 + - uses: actions/cache@v3 name: Cache ~/.stack with: path: ~/.stack - key: ${{ runner.os }}-${{ matrix.ghc }}-stack + key: ${{ runner.os }}-stack-global-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }} + restore-keys: | + ${{ runner.os }}-stack-global- + - uses: actions/cache@v3 + name: Cache .stack-work + with: + path: .stack-work + key: ${{ runner.os }}-stack-work-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }}-${{ hashFiles('**/*.hs') }} + restore-keys: | + ${{ runner.os }}-stack-work- - name: Install dependencies run: | diff --git a/CHANGELOG.md b/CHANGELOG.md index 2fb715c..49da420 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,15 @@ Changelog ========== +## Version 1.6.0 + +* HLint fixes - some types were changed to newtype (#173) +* Fix XML generation test for S3 SELECT (#161) +* Use region specific endpoints for AWS S3 in presigned Urls (#164) +* Replace protolude with relude and build with GHC 9.0.2 (#168) +* Support aeson 2 (#169) +* CI updates and code formatting changes with ormolu 0.5.0.0 + ## Version 1.5.3 * Fix windows build diff --git a/minio-hs.cabal b/minio-hs.cabal index 14a38d3..4318367 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: minio-hs -version: 1.5.3 +version: 1.6.0 synopsis: A MinIO Haskell Library for Amazon S3 compatible cloud storage. description: The MinIO Haskell client library provides simple APIs to From e06bb4c949c88283d2f3acc79e9375c7579ca8fe Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Tue, 4 Oct 2022 09:25:39 -0700 Subject: [PATCH 15/24] Enable partial fields warning (#179) - Updates exported type `EventMessage` - so avoid exporting partial functions. --- CHANGELOG.md | 4 ++++ Setup.hs | 19 ------------------- minio-hs.cabal | 8 ++++---- src/Network/Minio/Data.hs | 13 +++++++------ 4 files changed, 15 insertions(+), 29 deletions(-) delete mode 100644 Setup.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 49da420..0a747e6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,10 @@ Changelog ========== +## Version 1.7.0 -- Unreleased + +* Fix data type `EventMessage` to not export partial fields + ## Version 1.6.0 * HLint fixes - some types were changed to newtype (#173) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index a3c845d..0000000 --- a/Setup.hs +++ /dev/null @@ -1,19 +0,0 @@ --- --- MinIO Haskell SDK, (C) 2017 MinIO, Inc. --- --- Licensed under the Apache License, Version 2.0 (the "License"); --- you may not use this file except in compliance with the License. --- You may obtain a copy of the License at --- --- http://www.apache.org/licenses/LICENSE-2.0 --- --- Unless required by applicable law or agreed to in writing, software --- distributed under the License is distributed on an "AS IS" BASIS, --- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. --- See the License for the specific language governing permissions and --- limitations under the License. --- - -import Distribution.Simple - -main = defaultMain diff --git a/minio-hs.cabal b/minio-hs.cabal index 4318367..708ba6d 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.2 +cabal-version: 2.4 name: minio-hs version: 1.6.0 synopsis: A MinIO Haskell Library for Amazon S3 compatible cloud @@ -44,9 +44,9 @@ common base-settings -- Add this when we have time. Fixing partial-fields requires major version -- bump at this time. - -- if impl(ghc >= 8.4) - -- ghc-options: -Wpartial-fields - -- -Wmissing-export-lists + if impl(ghc >= 8.4) + ghc-options: -Wpartial-fields + -- -Wmissing-export-lists if impl(ghc >= 8.8) ghc-options: -Wmissing-deriving-strategies diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index a49098e..3fcd514 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -963,13 +963,14 @@ outputJSONFromRecordDelimiter t = -- | An EventMessage represents each kind of message received from the server. data EventMessage - = ProgressEventMessage {emProgress :: Progress} - | StatsEventMessage {emStats :: Stats} + = ProgressEventMessage Progress + | StatsEventMessage Stats | RequestLevelErrorMessage - { emErrorCode :: Text, - emErrorMessage :: Text - } - | RecordPayloadEventMessage {emPayloadBytes :: ByteString} + Text + -- ^ Error code + Text + -- ^ Error message + | RecordPayloadEventMessage ByteString deriving stock (Show, Eq) data MsgHeaderName From 7eef9b08eaf62f0fd3f56b6b8e5a5ae612e8e5e9 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Tue, 4 Oct 2022 09:25:56 -0700 Subject: [PATCH 16/24] Update CI configs (#180) --- .github/workflows/ci.yml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 8f99aee..c0e2bf3 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -35,7 +35,7 @@ jobs: - name: 'Set up HLint' uses: haskell/actions/hlint-setup@v2 with: - version: '3.4' + version: '3.5' - name: 'Run HLint' uses: haskell/actions/hlint-run@v2 @@ -50,8 +50,9 @@ jobs: strategy: matrix: os: [ubuntu-latest, windows-latest] # Removed macos-latest due to cert issues. - cabal: ["3.6"] + cabal: ["3.6", "3.8"] ghc: + - "9.2.4" - "9.0.2" - "8.10.7" - "8.8.4" @@ -152,7 +153,7 @@ jobs: ghc: - "8.10.7" - "9.0.2" - - "9.2.2" + - "9.2.4" os: [ubuntu-latest] steps: From 0b3a5559fd95c4214a93545b1d602aa985c6f0c8 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Tue, 4 Oct 2022 09:56:38 -0700 Subject: [PATCH 17/24] Fix deprecation warnings (#181) --- CHANGELOG.md | 1 + minio-hs.cabal | 2 +- src/Network/Minio/Data/Time.hs | 3 ++- src/Network/Minio/XmlParser.hs | 9 +++------ 4 files changed, 7 insertions(+), 8 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0a747e6..7c18bee 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,7 @@ Changelog ## Version 1.7.0 -- Unreleased * Fix data type `EventMessage` to not export partial fields +* Bump up min bound on time dep and fix deprecation warnings. ## Version 1.6.0 diff --git a/minio-hs.cabal b/minio-hs.cabal index 708ba6d..1ac3120 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -118,7 +118,7 @@ common base-settings , resourcet >= 1.2 , retry , text >= 1.2 - , time >= 1.8 + , time >= 1.9 , transformers >= 0.5 , unliftio >= 0.2 && < 0.3 , unliftio-core >= 0.2 && < 0.3 diff --git a/src/Network/Minio/Data/Time.hs b/src/Network/Minio/Data/Time.hs index c2699e4..2c5760c 100644 --- a/src/Network/Minio/Data/Time.hs +++ b/src/Network/Minio/Data/Time.hs @@ -27,6 +27,7 @@ where import Data.ByteString.Char8 (pack) import qualified Data.Time as Time +import Data.Time.Format.ISO8601 (iso8601Show) import Lib.Prelude -- | Time to expire for a presigned URL. It interpreted as a number of @@ -49,4 +50,4 @@ awsParseTime :: [Char] -> Maybe UTCTime awsParseTime = Time.parseTimeM False Time.defaultTimeLocale "%Y%m%dT%H%M%SZ" iso8601TimeFormat :: UTCTime -> [Char] -iso8601TimeFormat = Time.formatTime Time.defaultTimeLocale (Time.iso8601DateFormat $ Just "%T%QZ") +iso8601TimeFormat = iso8601Show diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index 7ab2178..06ce443 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -36,16 +36,13 @@ import Data.List (zip4, zip6) import qualified Data.Text as T import Data.Text.Read (decimal) import Data.Time +import Data.Time.Format.ISO8601 (iso8601ParseM) 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] -s3TimeFormat = iso8601DateFormat $ Just "%T%QZ" - -- | Helper functions. uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e uncurry4 f (a, b, c, d) = f a b c d @@ -57,8 +54,8 @@ uncurry6 f (a, b, c, d, e, g) = f a b c d e g parseS3XMLTime :: MonadIO m => Text -> m UTCTime parseS3XMLTime t = maybe (throwIO $ MErrVXmlParse $ "timestamp parse failure: " <> t) return $ - parseTimeM True defaultTimeLocale s3TimeFormat $ - T.unpack t + iso8601ParseM $ + toString t parseDecimal :: (MonadIO m, Integral a) => Text -> m a parseDecimal numStr = From d87d67b75b1b9f60a40a5dcdb3ad0aaa4abcf545 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Tue, 4 Oct 2022 15:07:41 -0700 Subject: [PATCH 18/24] Add `dev` flag to cabal file and update README (#182) This turns on the GHC option `-Werror` to ensure that warnings fail the build in dev mode. The flag is enabled in the CI. README is updated with cabal based instructions. --- .github/workflows/ci.yml | 16 ++++---- README.md | 87 +++++++++++++++++++++++++--------------- minio-hs.cabal | 29 +++++++++----- 3 files changed, 82 insertions(+), 50 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index c0e2bf3..0d7e171 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -80,7 +80,7 @@ jobs: - name: Configure run: | - cabal configure --enable-tests --enable-benchmarks --test-show-details=direct -fexamples -flive-test + cabal configure --enable-tests --enable-benchmarks --test-show-details=direct -fexamples -fdev -flive-test - name: Freeze run: | @@ -98,11 +98,11 @@ jobs: - name: Install dependencies run: | - cabal build all --only-dependencies -fexamples -flive-test + cabal build --only-dependencies - name: Build run: | - cabal build all -fexamples + cabal build - name: Setup MinIO for testing (Linux) if: matrix.os == 'ubuntu-latest' @@ -135,7 +135,7 @@ jobs: /tmp/minio/minio server --quiet --certs-dir /tmp/minio-config/certs data1 data2 data3 data4 2>&1 > minio.log & ghc --version cabal --version - cabal test all -flive-test + cabal test - name: Test (Windows) if: matrix.os == 'windows-latest' @@ -143,7 +143,7 @@ jobs: Start-Process -NoNewWindow -FilePath "$HOME/minio.exe" -ArgumentList "--certs-dir", "$env:temp/minio-config/certs", "server", "$env:temp/data1", "$env:temp/data2", "$env:temp/data3", "$env:temp/data4" ghc --version cabal --version - cabal test all -flive-test + cabal test stack: name: stack / ghc ${{ matrix.ghc }} @@ -188,7 +188,7 @@ jobs: - name: Build run: | - stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --flag minio-hs:examples + stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --flag minio-hs:examples --flag minio-hs:live-test --flag minio-hs:dev - name: Setup MinIO for testing (Linux) if: matrix.os == 'ubuntu-latest' @@ -221,7 +221,7 @@ jobs: /tmp/minio/minio server --quiet --certs-dir /tmp/minio-config/certs data1 data2 data3 data4 2>&1 > minio.log & ghc --version stack --version - stack test --system-ghc --flag minio-hs:live-test + stack test --system-ghc --flag minio-hs:live-test --flag minio-hs:dev - name: Test (Windows) if: matrix.os == 'windows-latest' @@ -229,4 +229,4 @@ jobs: Start-Process -NoNewWindow -FilePath "$HOME/minio.exe" -ArgumentList "--certs-dir", "$env:temp/minio-config/certs", "server", "$env:temp/data1", "$env:temp/data2", "$env:temp/data3", "$env:temp/data4" ghc --version cabal --version - stack test --system-ghc --flag minio-hs:live-test + stack test --system-ghc --flag minio-hs:live-test --flag minio-hs:dev diff --git a/README.md b/README.md index a2115f1..a6703c8 100644 --- a/README.md +++ b/README.md @@ -1,10 +1,8 @@ -# MinIO Client SDK for Haskell [![Build Status](https://travis-ci.org/minio/minio-hs.svg?branch=master)](https://travis-ci.org/minio/minio-hs)[![Hackage](https://img.shields.io/hackage/v/minio-hs.svg)](https://hackage.haskell.org/package/minio-hs)[![Slack](https://slack.min.io/slack?type=svg)](https://slack.min.io) +# MinIO Haskell Client SDK for Amazon S3 Compatible Cloud Storage [![Build Status](https://travis-ci.org/minio/minio-hs.svg?branch=master)](https://travis-ci.org/minio/minio-hs)[![Hackage](https://img.shields.io/hackage/v/minio-hs.svg)](https://hackage.haskell.org/package/minio-hs)[![Slack](https://slack.min.io/slack?type=svg)](https://slack.min.io) -The MinIO Haskell Client SDK provides simple APIs to access [MinIO](https://min.io) and Amazon S3 compatible object storage server. +The MinIO Haskell Client SDK provides simple APIs to access [MinIO](https://min.io) and any Amazon S3 compatible object storage. -## Minimum Requirements - -- The Haskell [stack](https://docs.haskellstack.org/en/stable/README/) +This guide assumes that you have a working [Haskell development environment](https://www.haskell.org/downloads/). ## Installation @@ -12,20 +10,35 @@ The MinIO Haskell Client SDK provides simple APIs to access [MinIO](https://min. Simply add `minio-hs` to your project's `.cabal` dependencies section or if you are using hpack, to your `package.yaml` file as usual. -### Try it out directly with `ghci` +### Try it out in a [REPL](https://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop) + +#### For a cabal based environment + +Download the library source and change to the extracted directory: + +``` sh +$ cabal get minio-hs +$ cd minio-hs-1.6.0/ # directory name could be different +``` + +Then load the `ghci` REPL environment with the library and browse the available APIs: + +``` sh +$ cabal repl +ghci> :browse Network.Minio +``` + +#### For a stack based environment From your home folder or any non-haskell project directory, just run: ```sh - stack install minio-hs - ``` Then start an interpreter session and browse the available APIs with: ```sh - $ stack ghci > :browse Network.Minio ``` @@ -134,44 +147,52 @@ main = do ### Development -To setup: +#### Download the source ```sh -git clone https://github.com/minio/minio-hs.git +$ git clone https://github.com/minio/minio-hs.git +$ cd minio-hs/ +``` -cd minio-hs/ +#### Build the package: -stack install -``` - -Tests can be run with: +With `cabal`: ```sh - -stack test - +$ # Configure cabal for development enabling all optional flags defined by the package. +$ cabal configure --enable-tests --test-show-details=direct -fexamples -fdev -flive-test +$ cabal build ``` -A section of the tests use the remote MinIO Play server at `https://play.min.io` by default. For library development, using this remote server maybe slow. To run the tests against a locally running MinIO live server at `http://localhost:9000`, just set the environment `MINIO_LOCAL` to any value (and unset it to switch back to Play). +With `stack`: -To run the live server tests, set a build flag as shown below: +``` sh +$ stack build --test --no-run-tests --flag minio-hs:live-test --flag minio-hs:dev --flag minio-hs:examples +``` +#### Running tests: + +A section of the tests use the remote MinIO Play server at `https://play.min.io` by default. For library development, using this remote server maybe slow. To run the tests against a locally running MinIO live server at `http://localhost:9000` with the credentials `access_key=minio` and `secret_key=minio123`, just set the environment `MINIO_LOCAL` to any value (and unset it to switch back to Play). + +With `cabal`: ```sh - -stack test --flag minio-hs:live-test - -# OR against a local MinIO server with: - -MINIO_LOCAL=1 stack test --flag minio-hs:live-test - +$ export MINIO_LOCAL=1 # to run live tests against local MinIO server +$ cabal test ``` -The configured CI system always runs both test-suites for every change. +With `stack`: -Documentation can be locally built with: +``` sh +$ export MINIO_LOCAL=1 # to run live tests against local MinIO server +stack test --flag minio-hs:live-test --flag minio-hs:dev +``` + +This will run all the test suites. + +#### Building documentation: ```sh - -stack haddock - +$ cabal haddock +$ # OR +$ stack haddock ``` diff --git a/minio-hs.cabal b/minio-hs.cabal index 1ac3120..45772cf 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -14,21 +14,28 @@ maintainer: dev@min.io category: Network, AWS, Object Storage build-type: Simple stability: Experimental -extra-source-files: +extra-doc-files: CHANGELOG.md CONTRIBUTING.md docs/API.md - examples/*.hs README.md +extra-source-files: + examples/*.hs stack.yaml -tested-with: GHC == 8.8.4 +tested-with: GHC == 8.6.5 + , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 + , GHC == 9.2.4 source-repository head type: git location: https://github.com/minio/minio-hs.git +Flag dev + Description: Build package in development mode + Default: False + Manual: True common base-settings ghc-options: -Wall @@ -41,16 +48,20 @@ common base-settings ghc-options: -Wredundant-constraints if impl(ghc >= 8.2) ghc-options: -fhide-source-paths - - -- Add this when we have time. Fixing partial-fields requires major version - -- bump at this time. if impl(ghc >= 8.4) ghc-options: -Wpartial-fields -- -Wmissing-export-lists - if impl(ghc >= 8.8) ghc-options: -Wmissing-deriving-strategies -Werror=missing-deriving-strategies + -- if impl(ghc >= 8.10) + -- ghc-options: -Wunused-packages -- disabled due to bug related to mixin config + if impl(ghc >= 9.0) + ghc-options: -Winvalid-haddock + if impl(ghc >= 9.2) + ghc-options: -Wredundant-bang-patterns + if flag(dev) + ghc-options: -Werror default-language: Haskell2010 @@ -105,7 +116,6 @@ common base-settings , cryptonite-conduit >= 0.2 , digest >= 0.0.1 , directory - , exceptions , filepath >= 1.4 , http-client >= 0.5 , http-client-tls @@ -114,7 +124,6 @@ common base-settings , ini , memory >= 0.14 , network-uri - , raw-strings-qq >= 1 , resourcet >= 1.2 , retry , text >= 1.2 @@ -153,6 +162,7 @@ test-suite minio-hs-live-server-test , Network.Minio.XmlGenerator.Test , Network.Minio.XmlParser.Test build-depends: minio-hs + , raw-strings-qq , tasty , tasty-hunit , tasty-quickcheck @@ -167,6 +177,7 @@ test-suite minio-hs-test hs-source-dirs: test, src main-is: Spec.hs build-depends: minio-hs + , raw-strings-qq , QuickCheck , tasty , tasty-hunit From f4ae55468e7d7aea9e89214a985ccb0dd9f4ddbf Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Fri, 23 Dec 2022 07:53:27 -0800 Subject: [PATCH 19/24] Add Credentials module to use Assume Role API (#184) This exports a new module for retrieving STS based credentials, however they are not yet convenient to use in the library - the session token needs to be included as a custom header and may not be possible with all APIs. --- .github/workflows/ci.yml | 2 +- examples/AssumeRole.hs | 33 +++ minio-hs.cabal | 7 + src/Network/Minio/API.hs | 12 +- src/Network/Minio/AdminAPI.hs | 180 ++++++++++----- src/Network/Minio/Credentials.hs | 144 ++++++++++++ src/Network/Minio/Data.hs | 57 ++++- src/Network/Minio/PresignedOperations.hs | 17 +- src/Network/Minio/Sign/V4.hs | 269 +++++++++++++++-------- src/Network/Minio/XmlParser.hs | 105 ++++++++- test/LiveServer.hs | 13 +- 11 files changed, 663 insertions(+), 176 deletions(-) create mode 100644 examples/AssumeRole.hs create mode 100644 src/Network/Minio/Credentials.hs diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 0d7e171..ed3a64d 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -25,7 +25,7 @@ jobs: runs-on: ubuntu-latest steps: - uses: actions/checkout@v3 - - uses: mrkkrp/ormolu-action@v6 + - uses: mrkkrp/ormolu-action@v8 hlint: runs-on: ubuntu-latest diff --git a/examples/AssumeRole.hs b/examples/AssumeRole.hs new file mode 100644 index 0000000..649f517 --- /dev/null +++ b/examples/AssumeRole.hs @@ -0,0 +1,33 @@ +-- +-- MinIO Haskell SDK, (C) 2022 MinIO, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- +{-# LANGUAGE OverloadedStrings #-} + +import Network.Minio.Credentials +import Prelude + +main :: IO () +main = do + res <- + retrieveCredentials + $ STSAssumeRole + "https://play.min.io" + ( CredentialValue + "Q3AM3UQ867SPQQA43P2F" + "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG" + Nothing + ) + $ defaultSTSAssumeRoleOptions {saroLocation = Just "us-east-1"} + print res diff --git a/minio-hs.cabal b/minio-hs.cabal index 45772cf..c2cb360 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -128,6 +128,7 @@ common base-settings , retry , text >= 1.2 , time >= 1.9 + , time-units ^>= 1.0.0 , transformers >= 0.5 , unliftio >= 0.2 && < 0.3 , unliftio-core >= 0.2 && < 0.3 @@ -140,6 +141,7 @@ library exposed-modules: Network.Minio , Network.Minio.AdminAPI , Network.Minio.S3API + , Network.Minio.Credentials Flag live-test Description: Build the test suite that runs against a live MinIO server @@ -339,3 +341,8 @@ executable SetConfig import: examples-settings scope: private main-is: SetConfig.hs + +executable AssumeRole + import: examples-settings + scope: private + main-is: AssumeRole.hs diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index a4f7633..60a676c 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -34,6 +34,7 @@ import Control.Retry limitRetriesByCumulativeDelay, retrying, ) +import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.Char as C import qualified Data.Conduit as C @@ -44,6 +45,7 @@ import Lib.Prelude import qualified Network.HTTP.Client as NClient import Network.HTTP.Conduit (Response) import qualified Network.HTTP.Conduit as NC +import Network.HTTP.Types (simpleQueryToQuery) import qualified Network.HTTP.Types as HT import Network.HTTP.Types.Header (hHost) import Network.Minio.APICommon @@ -176,7 +178,8 @@ buildRequest ri = do let sp = SignParams (connectAccessKey ci') - (connectSecretKey ci') + (BA.convert (encodeUtf8 $ connectSecretKey ci' :: ByteString)) + ServiceS3 timeStamp (riRegion ri') (riPresignExpirySecs ri') @@ -198,8 +201,8 @@ buildRequest ri = do | isJust (riPresignExpirySecs ri') -> -- case 0 from above. do - let signPairs = signV4 sp baseRequest - qpToAdd = (fmap . fmap) Just signPairs + let signPairs = signV4QueryParams sp baseRequest + qpToAdd = simpleQueryToQuery signPairs existingQueryParams = HT.parseQuery (NC.queryString baseRequest) updatedQueryParams = existingQueryParams ++ qpToAdd return $ NClient.setQueryString updatedQueryParams baseRequest @@ -229,8 +232,7 @@ buildRequest ri = do return $ baseRequest { NC.requestHeaders = - NC.requestHeaders baseRequest - ++ mkHeaderFromPairs signHeaders, + NC.requestHeaders baseRequest ++ signHeaders, NC.requestBody = getRequestBody (riPayload ri') } diff --git a/src/Network/Minio/AdminAPI.hs b/src/Network/Minio/AdminAPI.hs index b15598c..c12db15 100644 --- a/src/Network/Minio/AdminAPI.hs +++ b/src/Network/Minio/AdminAPI.hs @@ -70,6 +70,7 @@ import Data.Aeson ) import qualified Data.Aeson as A import Data.Aeson.Types (typeMismatch) +import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T @@ -95,9 +96,12 @@ data DriveInfo = DriveInfo instance FromJSON DriveInfo where parseJSON = withObject "DriveInfo" $ \v -> DriveInfo - <$> v .: "uuid" - <*> v .: "endpoint" - <*> v .: "state" + <$> v + .: "uuid" + <*> v + .: "endpoint" + <*> v + .: "state" data StorageClass = StorageClass { scParity :: Int, @@ -120,12 +124,16 @@ instance FromJSON ErasureInfo where offlineDisks <- v .: "OfflineDisks" stdClass <- StorageClass - <$> v .: "StandardSCData" - <*> v .: "StandardSCParity" + <$> v + .: "StandardSCData" + <*> v + .: "StandardSCParity" rrClass <- StorageClass - <$> v .: "RRSCData" - <*> v .: "RRSCParity" + <$> v + .: "RRSCData" + <*> v + .: "RRSCParity" sets <- v .: "Sets" return $ ErasureInfo onlineDisks offlineDisks stdClass rrClass sets @@ -151,8 +159,10 @@ data ConnStats = ConnStats instance FromJSON ConnStats where parseJSON = withObject "ConnStats" $ \v -> ConnStats - <$> v .: "transferred" - <*> v .: "received" + <$> v + .: "transferred" + <*> v + .: "received" data ServerProps = ServerProps { spUptime :: NominalDiffTime, @@ -182,8 +192,10 @@ data StorageInfo = StorageInfo instance FromJSON StorageInfo where parseJSON = withObject "StorageInfo" $ \v -> StorageInfo - <$> v .: "Used" - <*> v .: "Backend" + <$> v + .: "Used" + <*> v + .: "Backend" data CountNAvgTime = CountNAvgTime { caCount :: Int64, @@ -194,8 +206,10 @@ data CountNAvgTime = CountNAvgTime instance FromJSON CountNAvgTime where parseJSON = withObject "CountNAvgTime" $ \v -> CountNAvgTime - <$> v .: "count" - <*> v .: "avgDuration" + <$> v + .: "count" + <*> v + .: "avgDuration" data HttpStats = HttpStats { hsTotalHeads :: CountNAvgTime, @@ -214,16 +228,26 @@ data HttpStats = HttpStats 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" + <$> 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, @@ -236,10 +260,14 @@ data SIData = SIData instance FromJSON SIData where parseJSON = withObject "SIData" $ \v -> SIData - <$> v .: "storage" - <*> v .: "network" - <*> v .: "http" - <*> v .: "server" + <$> v + .: "storage" + <*> v + .: "network" + <*> v + .: "http" + <*> v + .: "server" data ServerInfo = ServerInfo { siError :: Text, @@ -251,9 +279,12 @@ data ServerInfo = ServerInfo instance FromJSON ServerInfo where parseJSON = withObject "ServerInfo" $ \v -> ServerInfo - <$> v .: "error" - <*> v .: "addr" - <*> v .: "data" + <$> v + .: "error" + <*> v + .: "addr" + <*> v + .: "data" data ServerVersion = ServerVersion { svVersion :: Text, @@ -264,8 +295,10 @@ data ServerVersion = ServerVersion instance FromJSON ServerVersion where parseJSON = withObject "ServerVersion" $ \v -> ServerVersion - <$> v .: "version" - <*> v .: "commitID" + <$> v + .: "version" + <*> v + .: "commitID" data ServiceStatus = ServiceStatus { ssVersion :: ServerVersion, @@ -306,9 +339,12 @@ data HealStartResp = HealStartResp instance FromJSON HealStartResp where parseJSON = withObject "HealStartResp" $ \v -> HealStartResp - <$> v .: "clientToken" - <*> v .: "clientAddress" - <*> v .: "startTime" + <$> v + .: "clientToken" + <*> v + .: "clientAddress" + <*> v + .: "startTime" data HealOpts = HealOpts { hoRecursive :: Bool, @@ -325,8 +361,10 @@ instance ToJSON HealOpts where instance FromJSON HealOpts where parseJSON = withObject "HealOpts" $ \v -> HealOpts - <$> v .: "recursive" - <*> v .: "dryRun" + <$> v + .: "recursive" + <*> v + .: "dryRun" data HealItemType = HealItemMetadata @@ -353,9 +391,12 @@ data NodeSummary = NodeSummary instance FromJSON NodeSummary where parseJSON = withObject "NodeSummary" $ \v -> NodeSummary - <$> v .: "name" - <*> v .: "errSet" - <*> v .: "errMsg" + <$> v + .: "name" + <*> v + .: "errSet" + <*> v + .: "errMsg" data SetConfigResult = SetConfigResult { scrStatus :: Bool, @@ -366,8 +407,10 @@ data SetConfigResult = SetConfigResult instance FromJSON SetConfigResult where parseJSON = withObject "SetConfigResult" $ \v -> SetConfigResult - <$> v .: "status" - <*> v .: "nodeResults" + <$> v + .: "status" + <*> v + .: "nodeResults" data HealResultItem = HealResultItem { hriResultIdx :: Int, @@ -388,16 +431,26 @@ data HealResultItem = HealResultItem 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" + <$> 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" @@ -420,12 +473,18 @@ data HealStatus = HealStatus instance FromJSON HealStatus where parseJSON = withObject "HealStatus" $ \v -> HealStatus - <$> v .: "Summary" - <*> v .: "StartTime" - <*> v .: "Settings" - <*> v .: "NumDisks" - <*> v .:? "Detail" - <*> v .: "Items" + <$> v + .: "Summary" + <*> v + .: "StartTime" + <*> v + .: "Settings" + <*> v + .: "NumDisks" + <*> v + .:? "Detail" + <*> v + .: "Items" healPath :: Maybe Bucket -> Maybe Text -> ByteString healPath bucket prefix = do @@ -620,7 +679,8 @@ buildAdminRequest areq = do sp = SignParams (connectAccessKey ci) - (connectSecretKey ci) + (BA.convert (encodeUtf8 $ connectSecretKey ci :: ByteString)) + ServiceS3 timeStamp Nothing Nothing @@ -630,7 +690,7 @@ buildAdminRequest areq = do -- Update signReq with Authorization header containing v4 signature return signReq - { NC.requestHeaders = ariHeaders newAreq ++ mkHeaderFromPairs signHeaders + { NC.requestHeaders = ariHeaders newAreq ++ signHeaders } where toRequest :: ConnectInfo -> AdminReqInfo -> NC.Request diff --git a/src/Network/Minio/Credentials.hs b/src/Network/Minio/Credentials.hs new file mode 100644 index 0000000..ccbf179 --- /dev/null +++ b/src/Network/Minio/Credentials.hs @@ -0,0 +1,144 @@ +-- +-- MinIO Haskell SDK, (C) 2017-2022 MinIO, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +module Network.Minio.Credentials + ( CredentialValue (..), + CredentialProvider (..), + AccessKey, + SecretKey, + SessionToken, + defaultSTSAssumeRoleOptions, + STSAssumeRole (..), + STSAssumeRoleOptions (..), + ) +where + +import qualified Data.Time as Time +import Data.Time.Units (Second) +import Network.HTTP.Client (RequestBody (RequestBodyBS)) +import qualified Network.HTTP.Client as NC +import qualified Network.HTTP.Client.TLS as NC +import Network.HTTP.Types (hContentType, methodPost, renderSimpleQuery) +import Network.HTTP.Types.Header (hHost) +import Network.Minio.Data +import Network.Minio.Data.Crypto (hashSHA256) +import Network.Minio.Sign.V4 +import Network.Minio.Utils (httpLbs) +import Network.Minio.XmlParser (parseSTSAssumeRoleResult) + +class CredentialProvider p where + retrieveCredentials :: p -> IO CredentialValue + +stsVersion :: ByteString +stsVersion = "2011-06-15" + +defaultDurationSeconds :: Second +defaultDurationSeconds = 3600 + +data STSAssumeRole = STSAssumeRole + { sarEndpoint :: Text, + sarCredentials :: CredentialValue, + sarOptions :: STSAssumeRoleOptions + } + +data STSAssumeRoleOptions = STSAssumeRoleOptions + { -- | Desired validity for the generated credentials. + saroDurationSeconds :: Maybe Second, + -- | IAM policy to apply for the generated credentials. + saroPolicyJSON :: Maybe ByteString, + -- | Location is usually required for AWS. + saroLocation :: Maybe Text, + saroRoleARN :: Maybe Text, + saroRoleSessionName :: Maybe Text, + -- | Optional HTTP connection manager + saroHTTPManager :: Maybe NC.Manager + } + +-- | Default STS Assume Role options +defaultSTSAssumeRoleOptions :: STSAssumeRoleOptions +defaultSTSAssumeRoleOptions = + STSAssumeRoleOptions + { saroDurationSeconds = Just defaultDurationSeconds, + saroPolicyJSON = Nothing, + saroLocation = Nothing, + saroRoleARN = Nothing, + saroRoleSessionName = Nothing, + saroHTTPManager = Nothing + } + +instance CredentialProvider STSAssumeRole where + retrieveCredentials sar = do + -- Assemble STS request + let requiredParams = + [ ("Action", "AssumeRole"), + ("Version", stsVersion) + ] + opts = sarOptions sar + durSecs :: Int = + fromIntegral $ + fromMaybe defaultDurationSeconds $ + saroDurationSeconds opts + otherParams = + [ ("RoleArn",) . encodeUtf8 <$> saroRoleARN opts, + ("RoleSessionName",) . encodeUtf8 <$> saroRoleSessionName opts, + Just ("DurationSeconds", show durSecs), + ("Policy",) <$> saroPolicyJSON opts + ] + parameters = requiredParams ++ catMaybes otherParams + (host, port, isSecure) = + let endPt = NC.parseRequest_ $ toString $ sarEndpoint sar + in (NC.host endPt, NC.port endPt, NC.secure endPt) + reqBody = renderSimpleQuery False parameters + req = + NC.defaultRequest + { NC.host = host, + NC.port = port, + NC.secure = isSecure, + NC.method = methodPost, + NC.requestHeaders = + [ (hHost, getHostHeader (host, port)), + (hContentType, "application/x-www-form-urlencoded") + ], + NC.requestBody = RequestBodyBS reqBody + } + + -- Sign the STS request. + timeStamp <- liftIO Time.getCurrentTime + let sp = + SignParams + { spAccessKey = coerce $ cvAccessKey $ sarCredentials sar, + spSecretKey = coerce $ cvSecretKey $ sarCredentials sar, + spService = ServiceSTS, + spTimeStamp = timeStamp, + spRegion = saroLocation opts, + spExpirySecs = Nothing, + spPayloadHash = Just $ hashSHA256 reqBody + } + signHeaders = signV4 sp req + signedReq = + req + { NC.requestHeaders = NC.requestHeaders req ++ signHeaders + } + settings = bool NC.defaultManagerSettings NC.tlsManagerSettings isSecure + + -- Make the STS request + mgr <- maybe (NC.newManager settings) return $ saroHTTPManager opts + resp <- httpLbs signedReq mgr + result <- + parseSTSAssumeRoleResult + (toStrict $ NC.responseBody resp) + "https://sts.amazonaws.com/doc/2011-06-15/" + return $ arcCredentials $ arrRoleCredentials result diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 3fcd514..018c7f8 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -232,16 +232,14 @@ isConnectInfoSecure = connectIsSecure disableTLSCertValidation :: ConnectInfo -> ConnectInfo disableTLSCertValidation c = c {connectDisableTLSCertValidation = True} -getHostAddr :: ConnectInfo -> ByteString -getHostAddr ci = +getHostHeader :: (ByteString, Int) -> ByteString +getHostHeader (host, port) = if port == 80 || port == 443 - then encodeUtf8 host - else - encodeUtf8 $ - T.concat [host, ":", show port] - where - port = connectPort ci - host = connectHost ci + then host + else host <> ":" <> show port + +getHostAddr :: ConnectInfo -> ByteString +getHostAddr ci = getHostHeader (encodeUtf8 $ connectHost ci, connectPort ci) -- | Default Google Compute Storage ConnectInfo. Works only for -- "Simple Migration" use-case with interoperability mode enabled on @@ -1002,6 +1000,47 @@ type Stats = Progress -- Select API Related Types End -------------------------------------------------------------------------- +---------------------------------------- +-- Credentials Start +---------------------------------------- + +newtype AccessKey = AccessKey {unAccessKey :: Text} + deriving stock (Show) + deriving newtype (Eq, IsString) + +newtype SecretKey = SecretKey {unSecretKey :: BA.ScrubbedBytes} + deriving stock (Show) + deriving newtype (Eq, IsString) + +newtype SessionToken = SessionToken {unSessionToken :: BA.ScrubbedBytes} + deriving stock (Show) + deriving newtype (Eq, IsString) + +data CredentialValue = CredentialValue + { cvAccessKey :: AccessKey, + cvSecretKey :: SecretKey, + cvSessionToken :: Maybe SessionToken + } + deriving stock (Eq, Show) + +data AssumeRoleCredentials = AssumeRoleCredentials + { arcCredentials :: CredentialValue, + arcExpiration :: UTCTime + } + deriving stock (Show, Eq) + +data AssumeRoleResult = AssumeRoleResult + { arrSourceIdentity :: Text, + arrAssumedRoleArn :: Text, + arrAssumedRoleId :: Text, + arrRoleCredentials :: AssumeRoleCredentials + } + deriving stock (Show, Eq) + +---------------------------------------- +-- Credentials End +---------------------------------------- + -- | Represents different kinds of payload that are used with S3 API -- requests. data Payload diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs index dadca93..f651deb 100644 --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -39,6 +39,7 @@ where import Data.Aeson ((.=)) import qualified Data.Aeson as Json +import qualified Data.ByteArray as BA import Data.ByteString.Builder (byteString, toLazyByteString) import qualified Data.HashMap.Strict as H import qualified Data.Text as T @@ -300,7 +301,7 @@ presignedPostPolicy p = do ci <- asks mcConnInfo signTime <- liftIO Time.getCurrentTime - let extraConditions = + let extraConditions signParams = [ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime), PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256", PPCEquals @@ -308,23 +309,24 @@ presignedPostPolicy p = do ( T.intercalate "/" [ connectAccessKey ci, - decodeUtf8 $ mkScope signTime region + decodeUtf8 $ credentialScope signParams ] ) ] - ppWithCreds = + ppWithCreds signParams = p - { conditions = conditions p ++ extraConditions + { conditions = conditions p ++ extraConditions signParams } sp = SignParams (connectAccessKey ci) - (connectSecretKey ci) + (BA.convert (encodeUtf8 $ connectSecretKey ci :: ByteString)) + ServiceS3 signTime (Just $ connectRegion ci) Nothing Nothing - signData = signV4PostPolicy (showPostPolicy ppWithCreds) sp + signData = signV4PostPolicy (showPostPolicy $ ppWithCreds sp) sp -- compute form-data mkPair (PPCStartsWith k v) = Just (k, v) mkPair (PPCEquals k v) = Just (k, v) @@ -334,12 +336,11 @@ presignedPostPolicy p = do H.fromList $ mapMaybe mkPair - (conditions ppWithCreds) + (conditions $ ppWithCreds sp) 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 $ diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 86d604b..73f9f2a 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -18,19 +18,22 @@ module Network.Minio.Sign.V4 where import qualified Conduit as C +import qualified Data.ByteArray as BA 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 Data.List (partition) +import qualified Data.List.NonEmpty as NE import qualified Data.Time as Time import Lib.Prelude import qualified Network.HTTP.Conduit as NC -import Network.HTTP.Types (Header, parseQuery) +import Network.HTTP.Types (Header, SimpleQuery, hContentEncoding, parseQuery) import qualified Network.HTTP.Types as H +import Network.HTTP.Types.Header (RequestHeaders) import Network.Minio.Data.ByteString import Network.Minio.Data.Crypto import Network.Minio.Data.Time @@ -60,9 +63,17 @@ data SignV4Data = SignV4Data } deriving stock (Show) +data Service = ServiceS3 | ServiceSTS + deriving stock (Eq, Show) + +toByteString :: Service -> ByteString +toByteString ServiceS3 = "s3" +toByteString ServiceSTS = "sts" + data SignParams = SignParams { spAccessKey :: Text, - spSecretKey :: Text, + spSecretKey :: BA.ScrubbedBytes, + spService :: Service, spTimeStamp :: UTCTime, spRegion :: Maybe Text, spExpirySecs :: Maybe UrlExpiry, @@ -102,6 +113,9 @@ mkAuthHeader accessKey scope signedHeaderKeys sign = ] in (H.hAuthorization, authValue) +data IsStreaming = IsStreamingLength Int64 | NotStreaming + deriving stock (Eq, Show) + -- | Given SignParams and request details, including request method, -- request path, headers, query params and payload hash, generates an -- updated set of headers, including the x-amz-date header and the @@ -114,33 +128,19 @@ mkAuthHeader accessKey scope signedHeaderKeys sign = -- is being created. The expiry is interpreted as an integer number of -- seconds. The output will be the list of query-parameters to add to -- the request. -signV4 :: SignParams -> NC.Request -> [(ByteString, ByteString)] -signV4 !sp !req = - let region = fromMaybe "" $ spRegion sp - ts = spTimeStamp sp - scope = mkScope ts region - accessKey = encodeUtf8 $ spAccessKey sp - secretKey = encodeUtf8 $ spSecretKey sp +signV4QueryParams :: SignParams -> NC.Request -> SimpleQuery +signV4QueryParams !sp !req = + let scope = credentialScope 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 (first mk) [datePair, sha256Hdr] - headersToSign = getHeadersToSign computedHeaders + + headersToSign = getHeadersToSign $ NC.requestHeaders req 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-Credential", B.concat [encodeUtf8 $ spAccessKey sp, "/", scope]), + ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp), ("X-Amz-Expires", maybe "" showBS expiry), ("X-Amz-SignedHeaders", signedHeaderKeys) ] @@ -156,40 +156,129 @@ signV4 !sp !req = sp (NC.setQueryString finalQP req) headersToSign + -- 2. compute string to sign - stringToSign = mkStringToSign ts scope canonicalRequest + stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest -- 3.1 compute signing key - signingKey = mkSigningKey ts region secretKey + signingKey = getSigningKey sp + -- 3.2 compute signature + signature = computeSignature stringToSign signingKey + in ("X-Amz-Signature", signature) : authQP + +-- | Given SignParams and request details, including request method, request +-- path, headers, query params and payload hash, generates an updated set of +-- headers, including the x-amz-date header and the Authorization header, which +-- includes the signature. +-- +-- The output is the list of headers to be added to authenticate the request. +signV4 :: SignParams -> NC.Request -> [Header] +signV4 !sp !req = + let scope = credentialScope sp + + -- extra headers to be added for signing purposes. + extraHeaders = + ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp) + : ( -- payload hash is only used for S3 (not STS) + [ ( "x-amz-content-sha256", + fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp + ) + | spService sp == ServiceS3 + ] + ) + + -- 1. compute canonical request + reqHeaders = NC.requestHeaders req ++ extraHeaders + (canonicalRequest, signedHeaderKeys) = + getCanonicalRequestAndSignedHeaders + NotStreaming + sp + req + reqHeaders + + -- 2. compute string to sign + stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest + -- 3.1 compute signing key + signingKey = getSigningKey sp -- 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 - [ first CI.foldedCase authHeader, - datePair, - sha256Hdr - ] - in output + in authHeader : extraHeaders -mkScope :: UTCTime -> Text -> ByteString -mkScope ts region = - B.intercalate - "/" - [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" ts, - encodeUtf8 region, - "s3", - "aws4_request" - ] +credentialScope :: SignParams -> ByteString +credentialScope sp = + let region = fromMaybe "" $ spRegion sp + in B.intercalate + "/" + [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" $ spTimeStamp sp, + encodeUtf8 region, + toByteString $ spService sp, + "aws4_request" + ] +-- Folds header name, trims whitespace in header values, skips ignored headers +-- and sorts headers. getHeadersToSign :: [Header] -> [(ByteString, ByteString)] getHeadersToSign !h = filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $ map (bimap CI.foldedCase stripBS) h +-- | Given the list of headers in the request, computes the canonical headers +-- and the signed headers strings. +getCanonicalHeaders :: NonEmpty Header -> (ByteString, ByteString) +getCanonicalHeaders h = + let -- Folds header name, trims spaces in header values, skips ignored + -- headers and sorts headers by name (we must not re-order multi-valued + -- headers). + headersToSign = + NE.toList $ + NE.sortBy (\a b -> compare (fst a) (fst b)) $ + NE.fromList $ + NE.filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $ + NE.map (bimap CI.foldedCase stripBS) h + + canonicalHeaders = mconcat $ map (\(a, b) -> a <> ":" <> b <> "\n") headersToSign + signedHeaderKeys = B.intercalate ";" $ map fst headersToSign + in (canonicalHeaders, signedHeaderKeys) + +getCanonicalRequestAndSignedHeaders :: + IsStreaming -> + SignParams -> + NC.Request -> + [Header] -> + (ByteString, ByteString) +getCanonicalRequestAndSignedHeaders isStreaming sp req requestHeaders = + let httpMethod = NC.method req + + canonicalUri = uriEncode False $ NC.path req + + canonicalQueryString = + B.intercalate "&" $ + map (\(x, y) -> B.concat [x, "=", y]) $ + sort $ + map + ( bimap (uriEncode True) (maybe "" (uriEncode True)) + ) + (parseQuery $ NC.queryString req) + + (canonicalHeaders, signedHeaderKeys) = getCanonicalHeaders $ NE.fromList requestHeaders + payloadHashStr = + case isStreaming of + IsStreamingLength _ -> "STREAMING-AWS4-HMAC-SHA256-PAYLOAD" + NotStreaming -> fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp + + canonicalRequest = + B.intercalate + "\n" + [ httpMethod, + canonicalUri, + canonicalQueryString, + canonicalHeaders, + signedHeaderKeys, + payloadHashStr + ] + in (canonicalRequest, signedHeaderKeys) + mkCanonicalRequest :: Bool -> SignParams -> @@ -197,10 +286,12 @@ mkCanonicalRequest :: [(ByteString, ByteString)] -> ByteString mkCanonicalRequest !isStreaming !sp !req !headersForSign = - let canonicalQueryString = + let httpMethod = NC.method req + canonicalUri = uriEncode False $ NC.path req + canonicalQueryString = B.intercalate "&" $ map (\(x, y) -> B.concat [x, "=", y]) $ - sort $ + sortBy (\a b -> compare (fst a) (fst b)) $ map ( bimap (uriEncode True) (maybe "" (uriEncode True)) ) @@ -216,8 +307,8 @@ mkCanonicalRequest !isStreaming !sp !req !headersForSign = else fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp in B.intercalate "\n" - [ NC.method req, - uriEncode False $ NC.path req, + [ httpMethod, + canonicalUri, canonicalQueryString, canonicalHeaders, signedHeaders, @@ -234,13 +325,13 @@ mkStringToSign ts !scope !canonicalRequest = hashSHA256 canonicalRequest ] -mkSigningKey :: UTCTime -> Text -> ByteString -> ByteString -mkSigningKey ts region !secretKey = +getSigningKey :: SignParams -> ByteString +getSigningKey sp = hmacSHA256RawBS "aws4_request" - . hmacSHA256RawBS "s3" - . hmacSHA256RawBS (encodeUtf8 region) - . hmacSHA256RawBS (awsDateFormatBS ts) - $ B.concat ["AWS4", secretKey] + . hmacSHA256RawBS (toByteString $ spService sp) + . hmacSHA256RawBS (encodeUtf8 $ fromMaybe "" $ spRegion sp) + . hmacSHA256RawBS (awsDateFormatBS $ spTimeStamp sp) + $ B.concat ["AWS4", BA.convert $ spSecretKey sp] computeSignature :: ByteString -> ByteString -> ByteString computeSignature !toSign !key = digestToBase16 $ hmacSHA256 toSign key @@ -254,8 +345,7 @@ signV4PostPolicy :: Map.HashMap Text ByteString signV4PostPolicy !postPolicyJSON !sp = let stringToSign = Base64.encode postPolicyJSON - region = fromMaybe "" $ spRegion sp - signingKey = mkSigningKey (spTimeStamp sp) region $ encodeUtf8 $ spSecretKey sp + signingKey = getSigningKey sp signature = computeSignature stringToSign signingKey in Map.fromList [ ("x-amz-signature", signature), @@ -284,60 +374,59 @@ signedStreamLength dataLen = finalChunkSize = 1 + 17 + 64 + 2 + 2 in numChunks * fullChunkSize + lastChunkSize + finalChunkSize +-- For streaming S3, we need to update the content-encoding header. +addContentEncoding :: [Header] -> [Header] +addContentEncoding hs = + -- assume there is at most one content-encoding header. + let (ceHdrs, others) = partition ((== hContentEncoding) . fst) hs + in maybe + (hContentEncoding, "aws-chunked") + (\(k, v) -> (k, v <> ",aws-chunked")) + (listToMaybe ceHdrs) + : others + 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 ceMay = find (\(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 + + -- compute the updated list of headers to be added for signing purposes. signedContentLength = signedStreamLength payloadLength - streamingHeaders :: [Header] - streamingHeaders = - [ ("x-amz-decoded-content-length", showBS payloadLength), + extraHeaders = + [ ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp), + ("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) + requestHeaders = + addContentEncoding $ + foldr setHeader (NC.requestHeaders req) extraHeaders + -- 1. Compute Seed Signature -- 1.1 Canonical Request - canonicalReq = - mkCanonicalRequest - True + (canonicalReq, signedHeaderKeys) = + getCanonicalRequestAndSignedHeaders + (IsStreamingLength payloadLength) sp - (NC.setQueryString finalQP req) - headersToSign - region = fromMaybe "" $ spRegion sp - scope = mkScope ts region + req + requestHeaders + + scope = credentialScope sp 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 $ encodeUtf8 secretKey + signingKey = getSigningKey sp -- 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) + finalReqHeaders = authHeader : requestHeaders -- headersToAdd = authHeader : datePair : streamingHeaders toHexStr n = B8.pack $ printf "%x" n @@ -407,3 +496,9 @@ signV4Stream !payloadLength !sp !req = NC.requestBodySource signedContentLength $ src C..| signerConduit numParts lastPSize seedSignature } + +-- "setHeader r hdr" adds the hdr to r, replacing it in r if it already exists. +setHeader :: Header -> RequestHeaders -> RequestHeaders +setHeader hdr r = + let r' = filter (\(name, _) -> name /= fst hdr) r + in hdr : r' diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index 06ce443..ae55d48 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -27,9 +27,11 @@ module Network.Minio.XmlParser parseErrResponse, parseNotification, parseSelectProgress, + parseSTSAssumeRoleResult, ) where +import qualified Data.ByteArray as BA import qualified Data.ByteString.Lazy as LB import qualified Data.HashMap.Strict as H import Data.List (zip4, zip6) @@ -220,8 +222,8 @@ parseListPartsResponse xmldata = do parseErrResponse :: (MonadIO m) => LByteString -> m ServiceErr parseErrResponse xmldata = do r <- parseRoot xmldata - let code = T.concat $ r $/ element "Code" &/ content - message = T.concat $ r $/ element "Message" &/ content + let code = T.concat $ r $/ laxElement "Code" &/ content + message = T.concat $ r $/ laxElement "Message" &/ content return $ toServiceErr code message parseNotification :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m Notification @@ -269,3 +271,102 @@ parseSelectProgress xmldata = do <$> parseDecimal bScanned <*> parseDecimal bProcessed <*> parseDecimal bReturned + +-- +-- +-- Alice +-- +-- arn:aws:sts::123456789012:assumed-role/demo/TestAR +-- ARO123EXAMPLE123:TestAR +-- +-- +-- ASIAIOSFODNN7EXAMPLE +-- wJalrXUtnFEMI/K7MDENG/bPxRfiCYzEXAMPLEKEY +-- +-- AQoDYXdzEPT//////////wEXAMPLEtc764bNrC9SAPBSM22wDOk4x4HIZ8j4FZTwdQW +-- LWsKWHGBuFqwAeMicRXmxfpSPfIeoIYRqTflfKD8YUuwthAx7mSEI/qkPpKPi/kMcGd +-- QrmGdeehM4IC1NtBmUpp2wUE8phUZampKsburEDy0KPkyQDYwT7WZ0wq5VSXDvp75YU +-- 9HFvlRd8Tx6q6fE8YQcHNVXAkiY9q6d+xo0rKwT38xVqr7ZD0u0iPPkUL64lIZbqBAz +-- +scqKmlzm8FDrypNC9Yjc8fPOLn9FX9KSYvKTr4rvx3iSIlTJabIQwj2ICCR/oLxBA== +-- +-- 2019-11-09T13:34:41Z +-- +-- 6 +-- +-- +-- c6104cbe-af31-11e0-8154-cbc7ccf896c7 +-- +-- + +parseSTSAssumeRoleResult :: MonadIO m => ByteString -> Text -> m AssumeRoleResult +parseSTSAssumeRoleResult xmldata namespace = do + r <- parseRoot $ LB.fromStrict xmldata + let s3Elem' = s3Elem namespace + sourceIdentity = + T.concat $ + r + $/ s3Elem' "AssumeRoleResult" + &/ s3Elem' "SourceIdentity" + &/ content + roleArn = + T.concat $ + r + $/ s3Elem' "AssumeRoleResult" + &/ s3Elem' "AssumedRoleUser" + &/ s3Elem' "Arn" + &/ content + roleId = + T.concat $ + r + $/ s3Elem' "AssumeRoleResult" + &/ s3Elem' "AssumedRoleUser" + &/ s3Elem' "AssumedRoleId" + &/ content + + convSB :: Text -> BA.ScrubbedBytes + convSB = BA.convert . (encodeUtf8 :: Text -> ByteString) + + credsInfo = do + cr <- + maybe (Left $ MErrVXmlParse "No Credentials Element found") Right $ + listToMaybe $ + r $/ s3Elem' "AssumeRoleResult" &/ s3Elem' "Credentials" + let cur = fromNode $ node cr + return + ( CredentialValue + { cvAccessKey = + coerce $ + T.concat $ + cur $/ s3Elem' "AccessKeyId" &/ content, + cvSecretKey = + coerce $ + convSB $ + T.concat $ + cur + $/ s3Elem' "SecretAccessKey" + &/ content, + cvSessionToken = + Just $ + coerce $ + convSB $ + T.concat $ + cur + $/ s3Elem' "SessionToken" + &/ content + }, + T.concat $ cur $/ s3Elem' "Expiration" &/ content + ) + creds <- either throwIO pure credsInfo + expiry <- parseS3XMLTime $ snd creds + let roleCredentials = + AssumeRoleCredentials + { arcCredentials = fst creds, + arcExpiration = expiry + } + return + AssumeRoleResult + { arrSourceIdentity = sourceIdentity, + arrAssumedRoleArn = roleArn, + arrAssumedRoleId = roleId, + arrRoleCredentials = roleCredentials + } diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 8c93ea1..613caf3 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -279,7 +279,8 @@ lowLevelMultipartTest = funTestWithBucket "Low-level Multipart Test" $ fGetObject bucket object destFile defaultGetObjectOptions gotSize <- withNewHandle destFile getFileSize liftIO $ - gotSize == Right (Just mb15) + gotSize + == Right (Just mb15) @? "Wrong file size of put file after getting" step "Cleanup actions" @@ -303,7 +304,8 @@ putObjectSizeTest = funTestWithBucket "PutObject of conduit source with size" $ fGetObject bucket obj destFile defaultGetObjectOptions gotSize <- withNewHandle destFile getFileSize liftIO $ - gotSize == Right (Just mb1) + gotSize + == Right (Just mb1) @? "Wrong file size of put file after getting" step "Cleanup actions" @@ -327,7 +329,8 @@ putObjectNoSizeTest = funTestWithBucket "PutObject of conduit source with no siz fGetObject bucket obj destFile defaultGetObjectOptions gotSize <- withNewHandle destFile getFileSize liftIO $ - gotSize == Right (Just mb70) + gotSize + == Right (Just mb70) @? "Wrong file size of put file after getting" step "Cleanup actions" @@ -569,6 +572,7 @@ presignedUrlFunTest = funTestWithBucket "presigned Url tests" $ [] [] + print putUrl let size1 = 1000 :: Int64 inputFile <- mkRandFile size1 @@ -1176,7 +1180,8 @@ getNPutSSECTest = gotSize <- withNewHandle dstFile getFileSize liftIO $ - gotSize == Right (Just mb1) + gotSize + == Right (Just mb1) @? "Wrong file size of object when getting" step "Cleanup" From 5d58cb3bfc1b339fdb4884cc12f57c45db25b757 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Thu, 27 Apr 2023 02:14:38 +0800 Subject: [PATCH 20/24] fix: update AWS region map (#185) --- src/Network/Minio/Data.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 018c7f8..53b2823 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -97,13 +97,29 @@ awsRegionMap = ("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-south-2", "s3.ap-south-2.amazonaws.com"), ("ap-northeast-1", "s3.ap-northeast-1.amazonaws.com"), ("ap-northeast-2", "s3.ap-northeast-2.amazonaws.com"), + ("ap-northeast-3", "s3.ap-northeast-3.amazonaws.com"), ("ap-southeast-1", "s3.ap-southeast-1.amazonaws.com"), ("ap-southeast-2", "s3.ap-southeast-2.amazonaws.com"), + ("ap-southeast-3", "s3.ap-southeast-3.amazonaws.com"), ("eu-west-1", "s3.eu-west-1.amazonaws.com"), ("eu-west-2", "s3.eu-west-2.amazonaws.com"), + ("eu-west-3", "s3.eu-west-3.amazonaws.com"), ("eu-central-1", "s3.eu-central-1.amazonaws.com"), + ("eu-central-2", "s3.eu-central-2.amazonaws.com"), + ("eu-south-1", "s3.eu-south-1.amazonaws.com"), + ("eu-south-2", "s3.eu-south-2.amazonaws.com"), + ("af-south-1", "s3.af-south-1.amazonaws.com"), + ("ap-east-1", "s3.ap-east-1.amazonaws.com"), + ("cn-north-1", "s3.cn-north-1.amazonaws.com.cn"), + ("cn-northwest-1", "s3.cn-northwest-1.amazonaws.com.cn"), + ("eu-north-1", "s3.eu-north-1.amazonaws.com"), + ("me-south-1", "s3.me-south-1.amazonaws.com"), + ("me-central-1", "s3.me-central-1.amazonaws.com"), + ("us-gov-east-1", "s3.us-gov-east-1.amazonaws.com"), + ("us-gov-west-1", "s3.us-gov-west-1.amazonaws.com"), ("sa-east-1", "s3.sa-east-1.amazonaws.com") ] From 6d3925d597c765fb5ab1e6528df0ce4340b984da Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Wed, 26 Apr 2023 11:18:07 -0700 Subject: [PATCH 21/24] Fix XML generator tests (#187) - Differences in quoting of XML content does not impact the equality of XML docs, so we parse generated XML docs and compare for equality. --- test/Network/Minio/XmlGenerator/Test.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/test/Network/Minio/XmlGenerator/Test.hs b/test/Network/Minio/XmlGenerator/Test.hs index c32852e..64555d3 100644 --- a/test/Network/Minio/XmlGenerator/Test.hs +++ b/test/Network/Minio/XmlGenerator/Test.hs @@ -20,6 +20,7 @@ module Network.Minio.XmlGenerator.Test ) where +import qualified Data.ByteString.Lazy as LBS import Lib.Prelude import Network.Minio.Data import Network.Minio.TestHelpers @@ -28,6 +29,7 @@ import Network.Minio.XmlParser (parseNotification) import Test.Tasty import Test.Tasty.HUnit import Text.RawString.QQ (r) +import Text.XML (def, parseLBS) xmlGeneratorTests :: TestTree xmlGeneratorTests = @@ -120,7 +122,13 @@ testMkPutNotificationRequest = testMkSelectRequest :: Assertion testMkSelectRequest = mapM_ assertFn cases where - assertFn (a, b) = assertEqual "selectRequest XML should match: " b $ mkSelectRequest a + assertFn (a, b) = + let generatedReqDoc = parseLBS def $ LBS.fromStrict $ mkSelectRequest a + expectedReqDoc = parseLBS def $ LBS.fromStrict b + in case (generatedReqDoc, expectedReqDoc) of + (Right genDoc, Right expDoc) -> assertEqual "selectRequest XML should match: " expDoc genDoc + (Left err, _) -> assertFailure $ "Generated selectRequest failed to parse as XML" ++ show err + (_, Left err) -> assertFailure $ "Expected selectRequest failed to parse as XML" ++ show err cases = [ ( SelectRequest "Select * from S3Object" @@ -143,8 +151,8 @@ testMkSelectRequest = mapM_ assertFn cases <> quoteEscapeCharacter "\"" ) (Just False), - [r|Select * from S3ObjectSQLGZIP,IGNORE"" -,""ASNEEDED + [r|Select * from S3ObjectSQLGZIP,IGNORE"" +,""ASNEEDED FALSE|] ), ( setRequestProgressEnabled False $ @@ -168,7 +176,7 @@ testMkSelectRequest = mapM_ assertFn cases <> quoteCharacter "\"" <> quoteEscapeCharacter "\"" ), - [r|Select * from S3ObjectSQLNONE,""ASNEEDED + [r|Select * from S3ObjectSQLNONE,""ASNEEDED FALSE|] ) ] From 7ae8a8179db72d276a0a1cfd94ae4039c5124dfa Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Mon, 1 May 2023 13:08:14 -0700 Subject: [PATCH 22/24] Add GHC 9.4 to CI (#186) --- .github/workflows/ci.yml | 28 ++++++++++++---------------- minio-hs.cabal | 3 ++- 2 files changed, 14 insertions(+), 17 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index ed3a64d..86a342c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -50,22 +50,18 @@ jobs: strategy: matrix: os: [ubuntu-latest, windows-latest] # Removed macos-latest due to cert issues. - cabal: ["3.6", "3.8"] + cabal: ["3.6", "3.8", "latest"] ghc: - - "9.2.4" - - "9.0.2" - - "8.10.7" - - "8.8.4" - - "8.6.5" - # exclude: - # - os: macOS-latest - # ghc: 8.8.4 - # - os: macOS-latest - # ghc: 8.6.5 - # - os: windows-latest - # ghc: 8.10.7 - # - os: windows-latest - # ghc: 8.6.5 + - "9.4" + - "9.2" + - "9.0" + - "8.10" + - "8.8" + - "8.6" + exclude: + - os: windows-latest + ghc: "9.4" + cabal: "3.6" steps: - uses: actions/checkout@v3 @@ -157,7 +153,7 @@ jobs: os: [ubuntu-latest] steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' - uses: haskell/actions/setup@v2 diff --git a/minio-hs.cabal b/minio-hs.cabal index c2cb360..bdb2242 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -26,7 +26,8 @@ tested-with: GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 - , GHC == 9.2.4 + , GHC == 9.2.7 + , GHC == 9.4.5 source-repository head type: git From fa62ed599a108f005e2c4e40b0859838c346aa24 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Wed, 3 May 2023 17:52:46 -0700 Subject: [PATCH 23/24] Add support for AssumeRole STS API (#188) This change adds support for requesting temporary object storage credentials using the STS API. Some breaking changes are introduced to enable this support: - `Credentials` type has been removed. Use the `CredentialValue` type instead. Corresponding to this the type signature for `setCreds` has changed, though the functionality is the same. - The type alias `Provider` has been renamed to `CredentialLoader` to avoid naming confusion. --- CHANGELOG.md | 14 +- README.md | 2 +- examples/AssumeRole.hs | 38 ++- minio-hs.cabal | 9 +- src/Network/Minio.hs | 28 ++- src/Network/Minio/API.hs | 28 ++- src/Network/Minio/AdminAPI.hs | 12 +- src/Network/Minio/Credentials.hs | 161 ++++-------- src/Network/Minio/Credentials/AssumeRole.hs | 264 ++++++++++++++++++++ src/Network/Minio/Credentials/Types.hs | 85 +++++++ src/Network/Minio/Data.hs | 186 ++++++-------- src/Network/Minio/Errors.hs | 3 +- src/Network/Minio/PresignedOperations.hs | 16 +- src/Network/Minio/S3API.hs | 10 +- src/Network/Minio/Sign/V4.hs | 52 ++-- src/Network/Minio/Utils.hs | 70 ++---- src/Network/Minio/XmlCommon.hs | 65 +++++ src/Network/Minio/XmlGenerator.hs | 3 +- src/Network/Minio/XmlParser.hs | 146 +---------- test/LiveServer.hs | 76 +++++- test/Spec.hs | 3 +- 21 files changed, 781 insertions(+), 490 deletions(-) create mode 100644 src/Network/Minio/Credentials/AssumeRole.hs create mode 100644 src/Network/Minio/Credentials/Types.hs create mode 100644 src/Network/Minio/XmlCommon.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 7c18bee..31e3336 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,8 +3,18 @@ Changelog ## Version 1.7.0 -- Unreleased -* Fix data type `EventMessage` to not export partial fields -* Bump up min bound on time dep and fix deprecation warnings. +* Fix data type `EventMessage` to not export partial fields (#179) +* Bump up min bound on time dep and fix deprecation warnings (#181) +* Add `dev` flag to cabal for building with warnings as errors (#182) +* Fix AWS region map (#185) +* Fix XML generator tests (#187) +* Add support for STS Assume Role API (#188) + +### Breaking changes in 1.7.0 + +* `Credentials` type has been removed. Use `CredentialValue` instead. +* `Provider` type has been replaced with `CredentialLoader`. +* `EventMessage` data type is updated. ## Version 1.6.0 diff --git a/README.md b/README.md index a6703c8..1553931 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# MinIO Haskell Client SDK for Amazon S3 Compatible Cloud Storage [![Build Status](https://travis-ci.org/minio/minio-hs.svg?branch=master)](https://travis-ci.org/minio/minio-hs)[![Hackage](https://img.shields.io/hackage/v/minio-hs.svg)](https://hackage.haskell.org/package/minio-hs)[![Slack](https://slack.min.io/slack?type=svg)](https://slack.min.io) +# MinIO Haskell Client SDK for Amazon S3 Compatible Cloud Storage [![CI](https://github.com/minio/minio-hs/actions/workflows/ci.yml/badge.svg)](https://github.com/minio/minio-hs/actions/workflows/ci.yml)[![Hackage](https://img.shields.io/hackage/v/minio-hs.svg)](https://hackage.haskell.org/package/minio-hs)[![Slack](https://slack.min.io/slack?type=svg)](https://slack.min.io) The MinIO Haskell Client SDK provides simple APIs to access [MinIO](https://min.io) and any Amazon S3 compatible object storage. diff --git a/examples/AssumeRole.hs b/examples/AssumeRole.hs index 649f517..a053ddf 100644 --- a/examples/AssumeRole.hs +++ b/examples/AssumeRole.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2022 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -15,19 +15,33 @@ -- {-# LANGUAGE OverloadedStrings #-} -import Network.Minio.Credentials +import Control.Monad.IO.Class (liftIO) +import Network.Minio import Prelude main :: IO () main = do - res <- - retrieveCredentials - $ STSAssumeRole - "https://play.min.io" - ( CredentialValue - "Q3AM3UQ867SPQQA43P2F" - "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG" - Nothing - ) - $ defaultSTSAssumeRoleOptions {saroLocation = Just "us-east-1"} + -- Use play credentials for example. + let assumeRole = + STSAssumeRole + ( CredentialValue + "Q3AM3UQ867SPQQA43P2F" + "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG" + Nothing + ) + $ defaultSTSAssumeRoleOptions + { saroLocation = Just "us-east-1", + saroEndpoint = Just "https://play.min.io:9000" + } + + -- Retrieve temporary credentials and print them. + cv <- requestSTSCredential assumeRole + print $ "Temporary credentials" ++ show (credentialValueText $ fst cv) + print $ "Expiry" ++ show (snd cv) + + -- Configure 'ConnectInfo' to request temporary credentials on demand. + ci <- setSTSCredential assumeRole "https://play.min.io" + res <- runMinio ci $ do + buckets <- listBuckets + liftIO $ print $ "Top 5 buckets: " ++ show (take 5 buckets) print res diff --git a/minio-hs.cabal b/minio-hs.cabal index bdb2242..620ef4c 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -77,8 +77,6 @@ common base-settings , RankNTypes , ScopedTypeVariables , TupleSections - , TypeFamilies - other-modules: Lib.Prelude , Network.Minio.API @@ -97,7 +95,11 @@ common base-settings , Network.Minio.Utils , Network.Minio.XmlGenerator , Network.Minio.XmlParser + , Network.Minio.XmlCommon , Network.Minio.JsonParser + , Network.Minio.Credentials.Types + , Network.Minio.Credentials.AssumeRole + , Network.Minio.Credentials mixins: base hiding (Prelude) , relude (Relude as Prelude) @@ -142,7 +144,6 @@ library exposed-modules: Network.Minio , Network.Minio.AdminAPI , Network.Minio.S3API - , Network.Minio.Credentials Flag live-test Description: Build the test suite that runs against a live MinIO server @@ -164,6 +165,7 @@ test-suite minio-hs-live-server-test , Network.Minio.Utils.Test , Network.Minio.XmlGenerator.Test , Network.Minio.XmlParser.Test + , Network.Minio.Credentials build-depends: minio-hs , raw-strings-qq , tasty @@ -197,6 +199,7 @@ test-suite minio-hs-test , Network.Minio.Utils.Test , Network.Minio.XmlGenerator.Test , Network.Minio.XmlParser.Test + , Network.Minio.Credentials Flag examples Description: Build the examples diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index 0a882c9..3cfd9bf 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -16,7 +16,7 @@ -- | -- Module: Network.Minio --- Copyright: (c) 2017-2019 MinIO Dev Team +-- Copyright: (c) 2017-2023 MinIO Dev Team -- License: Apache 2.0 -- Maintainer: MinIO Dev Team -- @@ -24,13 +24,17 @@ -- storage servers like MinIO. module Network.Minio ( -- * Credentials - Credentials (..), + CredentialValue (..), + credentialValueText, + AccessKey (..), + SecretKey (..), + SessionToken (..), - -- ** Credential providers + -- ** Credential Loaders - -- | Run actions that retrieve 'Credentials' from the environment or + -- | Run actions that retrieve 'CredentialValue's from the environment or -- files or other custom sources. - Provider, + CredentialLoader, fromAWSConfigFile, fromAWSEnv, fromMinioEnv, @@ -54,6 +58,15 @@ module Network.Minio awsCI, gcsCI, + -- ** STS Credential types + STSAssumeRole (..), + STSAssumeRoleOptions (..), + defaultSTSAssumeRoleOptions, + requestSTSCredential, + setSTSCredential, + ExpiryTime (..), + STSCredentialProvider, + -- * Minio Monad ---------------- @@ -225,14 +238,15 @@ This module exports the high-level MinIO API for object storage. import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Combinators as CC +import Network.Minio.API import Network.Minio.CopyObject +import Network.Minio.Credentials 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] diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index 60a676c..34f45dd 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -26,6 +26,7 @@ module Network.Minio.API checkBucketNameValidity, isValidObjectName, checkObjectNameValidity, + requestSTSCredential, ) where @@ -34,7 +35,6 @@ import Control.Retry limitRetriesByCumulativeDelay, retrying, ) -import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.Char as C import qualified Data.Conduit as C @@ -42,6 +42,7 @@ 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.Client (defaultManagerSettings) import qualified Network.HTTP.Client as NClient import Network.HTTP.Conduit (Response) import qualified Network.HTTP.Conduit as NC @@ -49,6 +50,7 @@ import Network.HTTP.Types (simpleQueryToQuery) import qualified Network.HTTP.Types as HT import Network.HTTP.Types.Header (hHost) import Network.Minio.APICommon +import Network.Minio.Credentials import Network.Minio.Data import Network.Minio.Errors import Network.Minio.Sign.V4 @@ -145,6 +147,20 @@ getHostPathRegion ri = do else return pathStyle ) +-- | requestSTSCredential requests temporary credentials using the Security Token +-- Service API. The returned credential will include a populated 'SessionToken' +-- and an 'ExpiryTime'. +requestSTSCredential :: STSCredentialProvider p => p -> IO (CredentialValue, ExpiryTime) +requestSTSCredential p = do + endpoint <- maybe (throwIO $ MErrValidation MErrVSTSEndpointNotFound) return $ getSTSEndpoint p + let endPt = NC.parseRequest_ $ toString endpoint + settings + | NC.secure endPt = NC.tlsManagerSettings + | otherwise = defaultManagerSettings + + mgr <- NC.newManager settings + liftIO $ retrieveSTSCredentials p ("", 0, False) mgr + buildRequest :: S3ReqInfo -> Minio NC.Request buildRequest ri = do maybe (return ()) checkBucketNameValidity $ riBucket ri @@ -175,10 +191,14 @@ buildRequest ri = do timeStamp <- liftIO Time.getCurrentTime + mgr <- asks mcConnManager + cv <- liftIO $ getCredential (connectCreds ci') (getEndpoint ci') mgr + let sp = SignParams - (connectAccessKey ci') - (BA.convert (encodeUtf8 $ connectSecretKey ci' :: ByteString)) + (coerce $ cvAccessKey cv) + (coerce $ cvSecretKey cv) + (coerce $ cvSessionToken cv) ServiceS3 timeStamp (riRegion ri') diff --git a/src/Network/Minio/AdminAPI.hs b/src/Network/Minio/AdminAPI.hs index c12db15..fc3ed46 100644 --- a/src/Network/Minio/AdminAPI.hs +++ b/src/Network/Minio/AdminAPI.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2018 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2018-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -70,7 +70,6 @@ import Data.Aeson ) import qualified Data.Aeson as A import Data.Aeson.Types (typeMismatch) -import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T @@ -81,6 +80,7 @@ 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.Credentials import Network.Minio.Data import Network.Minio.Errors import Network.Minio.Sign.V4 @@ -666,6 +666,9 @@ buildAdminRequest areq = do timeStamp <- liftIO getCurrentTime + mgr <- asks mcConnManager + cv <- liftIO $ getCredential (connectCreds ci) (getEndpoint ci) mgr + let hostHeader = (hHost, getHostAddr ci) newAreq = areq @@ -678,8 +681,9 @@ buildAdminRequest areq = do signReq = toRequest ci newAreq sp = SignParams - (connectAccessKey ci) - (BA.convert (encodeUtf8 $ connectSecretKey ci :: ByteString)) + (coerce $ cvAccessKey cv) + (coerce $ cvSecretKey cv) + (coerce $ cvSessionToken cv) ServiceS3 timeStamp Nothing diff --git a/src/Network/Minio/Credentials.hs b/src/Network/Minio/Credentials.hs index ccbf179..2920370 100644 --- a/src/Network/Minio/Credentials.hs +++ b/src/Network/Minio/Credentials.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2017-2022 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -16,129 +16,62 @@ module Network.Minio.Credentials ( CredentialValue (..), - CredentialProvider (..), - AccessKey, - SecretKey, - SessionToken, + credentialValueText, + STSCredentialProvider (..), + AccessKey (..), + SecretKey (..), + SessionToken (..), + ExpiryTime (..), + STSCredentialStore, + initSTSCredential, + getSTSCredential, + Creds (..), + getCredential, + Endpoint, + + -- * STS Assume Role defaultSTSAssumeRoleOptions, STSAssumeRole (..), STSAssumeRoleOptions (..), ) where -import qualified Data.Time as Time -import Data.Time.Units (Second) -import Network.HTTP.Client (RequestBody (RequestBodyBS)) +import Data.Time (diffUTCTime, getCurrentTime) import qualified Network.HTTP.Client as NC -import qualified Network.HTTP.Client.TLS as NC -import Network.HTTP.Types (hContentType, methodPost, renderSimpleQuery) -import Network.HTTP.Types.Header (hHost) -import Network.Minio.Data -import Network.Minio.Data.Crypto (hashSHA256) -import Network.Minio.Sign.V4 -import Network.Minio.Utils (httpLbs) -import Network.Minio.XmlParser (parseSTSAssumeRoleResult) +import Network.Minio.Credentials.AssumeRole +import Network.Minio.Credentials.Types +import qualified UnliftIO.MVar as M -class CredentialProvider p where - retrieveCredentials :: p -> IO CredentialValue - -stsVersion :: ByteString -stsVersion = "2011-06-15" - -defaultDurationSeconds :: Second -defaultDurationSeconds = 3600 - -data STSAssumeRole = STSAssumeRole - { sarEndpoint :: Text, - sarCredentials :: CredentialValue, - sarOptions :: STSAssumeRoleOptions +data STSCredentialStore = STSCredentialStore + { cachedCredentials :: M.MVar (CredentialValue, ExpiryTime), + refreshAction :: Endpoint -> NC.Manager -> IO (CredentialValue, ExpiryTime) } -data STSAssumeRoleOptions = STSAssumeRoleOptions - { -- | Desired validity for the generated credentials. - saroDurationSeconds :: Maybe Second, - -- | IAM policy to apply for the generated credentials. - saroPolicyJSON :: Maybe ByteString, - -- | Location is usually required for AWS. - saroLocation :: Maybe Text, - saroRoleARN :: Maybe Text, - saroRoleSessionName :: Maybe Text, - -- | Optional HTTP connection manager - saroHTTPManager :: Maybe NC.Manager - } +initSTSCredential :: STSCredentialProvider p => p -> IO STSCredentialStore +initSTSCredential p = do + let action = retrieveSTSCredentials p + -- start with dummy credential, so that refresh happens for first request. + now <- getCurrentTime + mvar <- M.newMVar (CredentialValue mempty mempty mempty, coerce now) + return $ + STSCredentialStore + { cachedCredentials = mvar, + refreshAction = action + } --- | Default STS Assume Role options -defaultSTSAssumeRoleOptions :: STSAssumeRoleOptions -defaultSTSAssumeRoleOptions = - STSAssumeRoleOptions - { saroDurationSeconds = Just defaultDurationSeconds, - saroPolicyJSON = Nothing, - saroLocation = Nothing, - saroRoleARN = Nothing, - saroRoleSessionName = Nothing, - saroHTTPManager = Nothing - } +getSTSCredential :: STSCredentialStore -> Endpoint -> NC.Manager -> IO (CredentialValue, Bool) +getSTSCredential store ep mgr = M.modifyMVar (cachedCredentials store) $ \cc@(v, expiry) -> do + now <- getCurrentTime + if diffUTCTime now (coerce expiry) > 0 + then do + res <- refreshAction store ep mgr + return (res, (fst res, True)) + else return (cc, (v, False)) -instance CredentialProvider STSAssumeRole where - retrieveCredentials sar = do - -- Assemble STS request - let requiredParams = - [ ("Action", "AssumeRole"), - ("Version", stsVersion) - ] - opts = sarOptions sar - durSecs :: Int = - fromIntegral $ - fromMaybe defaultDurationSeconds $ - saroDurationSeconds opts - otherParams = - [ ("RoleArn",) . encodeUtf8 <$> saroRoleARN opts, - ("RoleSessionName",) . encodeUtf8 <$> saroRoleSessionName opts, - Just ("DurationSeconds", show durSecs), - ("Policy",) <$> saroPolicyJSON opts - ] - parameters = requiredParams ++ catMaybes otherParams - (host, port, isSecure) = - let endPt = NC.parseRequest_ $ toString $ sarEndpoint sar - in (NC.host endPt, NC.port endPt, NC.secure endPt) - reqBody = renderSimpleQuery False parameters - req = - NC.defaultRequest - { NC.host = host, - NC.port = port, - NC.secure = isSecure, - NC.method = methodPost, - NC.requestHeaders = - [ (hHost, getHostHeader (host, port)), - (hContentType, "application/x-www-form-urlencoded") - ], - NC.requestBody = RequestBodyBS reqBody - } +data Creds + = CredsStatic CredentialValue + | CredsSTS STSCredentialStore - -- Sign the STS request. - timeStamp <- liftIO Time.getCurrentTime - let sp = - SignParams - { spAccessKey = coerce $ cvAccessKey $ sarCredentials sar, - spSecretKey = coerce $ cvSecretKey $ sarCredentials sar, - spService = ServiceSTS, - spTimeStamp = timeStamp, - spRegion = saroLocation opts, - spExpirySecs = Nothing, - spPayloadHash = Just $ hashSHA256 reqBody - } - signHeaders = signV4 sp req - signedReq = - req - { NC.requestHeaders = NC.requestHeaders req ++ signHeaders - } - settings = bool NC.defaultManagerSettings NC.tlsManagerSettings isSecure - - -- Make the STS request - mgr <- maybe (NC.newManager settings) return $ saroHTTPManager opts - resp <- httpLbs signedReq mgr - result <- - parseSTSAssumeRoleResult - (toStrict $ NC.responseBody resp) - "https://sts.amazonaws.com/doc/2011-06-15/" - return $ arcCredentials $ arrRoleCredentials result +getCredential :: Creds -> Endpoint -> NC.Manager -> IO CredentialValue +getCredential (CredsStatic v) _ _ = return v +getCredential (CredsSTS s) ep mgr = fst <$> getSTSCredential s ep mgr diff --git a/src/Network/Minio/Credentials/AssumeRole.hs b/src/Network/Minio/Credentials/AssumeRole.hs new file mode 100644 index 0000000..0328ec6 --- /dev/null +++ b/src/Network/Minio/Credentials/AssumeRole.hs @@ -0,0 +1,264 @@ +-- +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +module Network.Minio.Credentials.AssumeRole where + +import qualified Data.ByteArray as BA +import qualified Data.ByteString.Lazy as LB +import qualified Data.Text as T +import qualified Data.Time as Time +import Data.Time.Units (Second) +import Lib.Prelude (UTCTime, throwIO) +import Network.HTTP.Client (RequestBody (RequestBodyBS)) +import qualified Network.HTTP.Client as NC +import Network.HTTP.Types (hContentType, methodPost, renderSimpleQuery) +import Network.HTTP.Types.Header (hHost) +import Network.Minio.Credentials.Types +import Network.Minio.Data.Crypto (hashSHA256) +import Network.Minio.Errors (MErrV (..)) +import Network.Minio.Sign.V4 +import Network.Minio.Utils (getHostHeader, httpLbs) +import Network.Minio.XmlCommon +import Text.XML.Cursor hiding (bool) + +stsVersion :: ByteString +stsVersion = "2011-06-15" + +defaultDurationSeconds :: Second +defaultDurationSeconds = 3600 + +-- | Assume Role API argument. +data STSAssumeRole = STSAssumeRole + { -- | Credentials to use in the AssumeRole STS API. + sarCredentials :: CredentialValue, + -- | Optional settings. + sarOptions :: STSAssumeRoleOptions + } + +-- | Options for STS Assume Role API. +data STSAssumeRoleOptions = STSAssumeRoleOptions + { -- | STS endpoint to which the request will be made. For MinIO, this is the + -- same as the server endpoint. For AWS, this has to be the Security Token + -- Service endpoint. If using with 'setSTSCredential', this option can be + -- left as 'Nothing' and the endpoint in 'ConnectInfo' will be used. + saroEndpoint :: Maybe Text, + -- | Desired validity for the generated credentials. + saroDurationSeconds :: Maybe Second, + -- | IAM policy to apply for the generated credentials. + saroPolicyJSON :: Maybe ByteString, + -- | Location is usually required for AWS. + saroLocation :: Maybe Text, + saroRoleARN :: Maybe Text, + saroRoleSessionName :: Maybe Text + } + +-- | Default STS Assume Role options - all options are Nothing, except for +-- duration which is set to 1 hour. +defaultSTSAssumeRoleOptions :: STSAssumeRoleOptions +defaultSTSAssumeRoleOptions = + STSAssumeRoleOptions + { saroEndpoint = Nothing, + saroDurationSeconds = Just 3600, + saroPolicyJSON = Nothing, + saroLocation = Nothing, + saroRoleARN = Nothing, + saroRoleSessionName = Nothing + } + +data AssumeRoleCredentials = AssumeRoleCredentials + { arcCredentials :: CredentialValue, + arcExpiration :: UTCTime + } + deriving stock (Show, Eq) + +data AssumeRoleResult = AssumeRoleResult + { arrSourceIdentity :: Text, + arrAssumedRoleArn :: Text, + arrAssumedRoleId :: Text, + arrRoleCredentials :: AssumeRoleCredentials + } + deriving stock (Show, Eq) + +-- | parseSTSAssumeRoleResult parses an XML response of the following form: +-- +-- +-- +-- Alice +-- +-- arn:aws:sts::123456789012:assumed-role/demo/TestAR +-- ARO123EXAMPLE123:TestAR +-- +-- +-- ASIAIOSFODNN7EXAMPLE +-- wJalrXUtnFEMI/K7MDENG/bPxRfiCYzEXAMPLEKEY +-- +-- AQoDYXdzEPT//////////wEXAMPLEtc764bNrC9SAPBSM22wDOk4x4HIZ8j4FZTwdQW +-- LWsKWHGBuFqwAeMicRXmxfpSPfIeoIYRqTflfKD8YUuwthAx7mSEI/qkPpKPi/kMcGd +-- QrmGdeehM4IC1NtBmUpp2wUE8phUZampKsburEDy0KPkyQDYwT7WZ0wq5VSXDvp75YU +-- 9HFvlRd8Tx6q6fE8YQcHNVXAkiY9q6d+xo0rKwT38xVqr7ZD0u0iPPkUL64lIZbqBAz +-- +scqKmlzm8FDrypNC9Yjc8fPOLn9FX9KSYvKTr4rvx3iSIlTJabIQwj2ICCR/oLxBA== +-- +-- 2019-11-09T13:34:41Z +-- +-- 6 +-- +-- +-- c6104cbe-af31-11e0-8154-cbc7ccf896c7 +-- +-- +parseSTSAssumeRoleResult :: MonadIO m => ByteString -> Text -> m AssumeRoleResult +parseSTSAssumeRoleResult xmldata namespace = do + r <- parseRoot $ LB.fromStrict xmldata + let s3Elem' = s3Elem namespace + sourceIdentity = + T.concat $ + r + $/ s3Elem' "AssumeRoleResult" + &/ s3Elem' "SourceIdentity" + &/ content + roleArn = + T.concat $ + r + $/ s3Elem' "AssumeRoleResult" + &/ s3Elem' "AssumedRoleUser" + &/ s3Elem' "Arn" + &/ content + roleId = + T.concat $ + r + $/ s3Elem' "AssumeRoleResult" + &/ s3Elem' "AssumedRoleUser" + &/ s3Elem' "AssumedRoleId" + &/ content + + convSB :: Text -> BA.ScrubbedBytes + convSB = BA.convert . (encodeUtf8 :: Text -> ByteString) + + credsInfo = do + cr <- + maybe (Left $ MErrVXmlParse "No Credentials Element found") Right $ + listToMaybe $ + r $/ s3Elem' "AssumeRoleResult" &/ s3Elem' "Credentials" + let cur = fromNode $ node cr + return + ( CredentialValue + { cvAccessKey = + coerce $ + T.concat $ + cur $/ s3Elem' "AccessKeyId" &/ content, + cvSecretKey = + coerce $ + convSB $ + T.concat $ + cur + $/ s3Elem' "SecretAccessKey" + &/ content, + cvSessionToken = + Just $ + coerce $ + convSB $ + T.concat $ + cur + $/ s3Elem' "SessionToken" + &/ content + }, + T.concat $ cur $/ s3Elem' "Expiration" &/ content + ) + creds <- either throwIO pure credsInfo + expiry <- parseS3XMLTime $ snd creds + let roleCredentials = + AssumeRoleCredentials + { arcCredentials = fst creds, + arcExpiration = expiry + } + return + AssumeRoleResult + { arrSourceIdentity = sourceIdentity, + arrAssumedRoleArn = roleArn, + arrAssumedRoleId = roleId, + arrRoleCredentials = roleCredentials + } + +instance STSCredentialProvider STSAssumeRole where + getSTSEndpoint = saroEndpoint . sarOptions + retrieveSTSCredentials sar (host', port', isSecure') mgr = do + -- Assemble STS request + let requiredParams = + [ ("Action", "AssumeRole"), + ("Version", stsVersion) + ] + opts = sarOptions sar + + durSecs :: Int = + fromIntegral $ + fromMaybe defaultDurationSeconds $ + saroDurationSeconds opts + otherParams = + [ ("RoleArn",) . encodeUtf8 <$> saroRoleARN opts, + ("RoleSessionName",) . encodeUtf8 <$> saroRoleSessionName opts, + Just ("DurationSeconds", show durSecs), + ("Policy",) <$> saroPolicyJSON opts + ] + parameters = requiredParams ++ catMaybes otherParams + (host, port, isSecure) = + case getSTSEndpoint sar of + Just ep -> + let endPt = NC.parseRequest_ $ toString ep + in (NC.host endPt, NC.port endPt, NC.secure endPt) + Nothing -> (host', port', isSecure') + reqBody = renderSimpleQuery False parameters + req = + NC.defaultRequest + { NC.host = host, + NC.port = port, + NC.secure = isSecure, + NC.method = methodPost, + NC.requestHeaders = + [ (hHost, getHostHeader (host, port)), + (hContentType, "application/x-www-form-urlencoded") + ], + NC.requestBody = RequestBodyBS reqBody + } + + -- Sign the STS request. + timeStamp <- liftIO Time.getCurrentTime + let sp = + SignParams + { spAccessKey = coerce $ cvAccessKey $ sarCredentials sar, + spSecretKey = coerce $ cvSecretKey $ sarCredentials sar, + spSessionToken = coerce $ cvSessionToken $ sarCredentials sar, + spService = ServiceSTS, + spTimeStamp = timeStamp, + spRegion = saroLocation opts, + spExpirySecs = Nothing, + spPayloadHash = Just $ hashSHA256 reqBody + } + signHeaders = signV4 sp req + signedReq = + req + { NC.requestHeaders = NC.requestHeaders req ++ signHeaders + } + + -- Make the STS request + resp <- httpLbs signedReq mgr + result <- + parseSTSAssumeRoleResult + (toStrict $ NC.responseBody resp) + "https://sts.amazonaws.com/doc/2011-06-15/" + return + ( arcCredentials $ arrRoleCredentials result, + coerce $ arcExpiration $ arrRoleCredentials result + ) diff --git a/src/Network/Minio/Credentials/Types.hs b/src/Network/Minio/Credentials/Types.hs new file mode 100644 index 0000000..a9c33bc --- /dev/null +++ b/src/Network/Minio/Credentials/Types.hs @@ -0,0 +1,85 @@ +-- +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Network.Minio.Credentials.Types where + +import qualified Data.ByteArray as BA +import Lib.Prelude (UTCTime) +import qualified Network.HTTP.Client as NC + +-- | Access Key type. +newtype AccessKey = AccessKey {unAccessKey :: Text} + deriving stock (Show) + deriving newtype (Eq, IsString, Semigroup, Monoid) + +-- | Secret Key type - has a show instance that does not print the value. +newtype SecretKey = SecretKey {unSecretKey :: BA.ScrubbedBytes} + deriving stock (Show) + deriving newtype (Eq, IsString, Semigroup, Monoid) + +-- | Session Token type - has a show instance that does not print the value. +newtype SessionToken = SessionToken {unSessionToken :: BA.ScrubbedBytes} + deriving stock (Show) + deriving newtype (Eq, IsString, Semigroup, Monoid) + +-- | Object storage credential data type. It has support for the optional +-- for using temporary credentials requested via STS. +-- +-- The show instance for this type does not print the value of secrets for +-- security. +data CredentialValue = CredentialValue + { cvAccessKey :: AccessKey, + cvSecretKey :: SecretKey, + cvSessionToken :: Maybe SessionToken + } + deriving stock (Eq, Show) + +scrubbedToText :: BA.ScrubbedBytes -> Text +scrubbedToText = + let b2t :: ByteString -> Text + b2t = decodeUtf8 + s2b :: BA.ScrubbedBytes -> ByteString + s2b = BA.convert + in b2t . s2b + +-- | Convert a 'CredentialValue' to a text tuple. Use this to output the +-- credential to files or other programs. +credentialValueText :: CredentialValue -> (Text, Text, Maybe Text) +credentialValueText cv = + ( coerce $ cvAccessKey cv, + (scrubbedToText . coerce) $ cvSecretKey cv, + scrubbedToText . coerce <$> cvSessionToken cv + ) + +-- | Endpoint represented by host, port and TLS enabled flag. +type Endpoint = (ByteString, Int, Bool) + +-- | Typeclass for STS credential providers. +class STSCredentialProvider p where + retrieveSTSCredentials :: + p -> + -- | STS Endpoint (host, port, isSecure) + Endpoint -> + NC.Manager -> + IO (CredentialValue, ExpiryTime) + getSTSEndpoint :: p -> Maybe Text + +-- | 'ExpiryTime' represents a time at which a credential expires. +newtype ExpiryTime = ExpiryTime {unExpiryTime :: UTCTime} + deriving stock (Show) + deriving newtype (Eq) diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 53b2823..6e53d5a 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -34,9 +34,9 @@ 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 qualified Data.List as List import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Time (defaultTimeLocale, formatTime) @@ -53,6 +53,7 @@ import Network.HTTP.Types hRange, ) import qualified Network.HTTP.Types as HT +import Network.Minio.Credentials import Network.Minio.Data.Crypto ( encodeToBase64, hashMD5ToBase64, @@ -62,11 +63,12 @@ import Network.Minio.Errors ( MErrV (MErrVInvalidEncryptionKeyLength, MErrVMissingCredentials), MinioErr (..), ) +import Network.Minio.Utils import System.Directory (doesFileExist, getHomeDirectory) import qualified System.Environment as Env import System.FilePath.Posix (combine) -import Text.XML (Name (Name)) import qualified UnliftIO as U +import qualified UnliftIO.MVar as UM -- | max obj size is 5TiB maxObjectSize :: Int64 @@ -131,14 +133,15 @@ awsRegionMap = data ConnectInfo = ConnectInfo { connectHost :: Text, connectPort :: Int, - connectAccessKey :: Text, - connectSecretKey :: Text, + connectCreds :: Creds, connectIsSecure :: Bool, connectRegion :: Region, connectAutoDiscoverRegion :: Bool, connectDisableTLSCertValidation :: Bool } - deriving stock (Eq, Show) + +getEndpoint :: ConnectInfo -> Endpoint +getEndpoint ci = (encodeUtf8 $ connectHost ci, connectPort ci, connectIsSecure ci) instance IsString ConnectInfo where fromString str = @@ -146,8 +149,7 @@ instance IsString ConnectInfo where in ConnectInfo { connectHost = TE.decodeUtf8 $ NC.host req, connectPort = NC.port req, - connectAccessKey = "", - connectSecretKey = "", + connectCreds = CredsStatic $ CredentialValue mempty mempty mempty, connectIsSecure = NC.secure req, connectRegion = "", connectAutoDiscoverRegion = True, @@ -161,20 +163,21 @@ data Credentials = Credentials } deriving stock (Eq, Show) --- | A Provider is an action that may return Credentials. Providers --- may be chained together using 'findFirst'. -type Provider = IO (Maybe Credentials) +-- | A 'CredentialLoader' is an action that may return a 'CredentialValue'. +-- Loaders may be chained together using 'findFirst'. +type CredentialLoader = IO (Maybe CredentialValue) --- | Combines the given list of providers, by calling each one in --- order until Credentials are found. -findFirst :: [Provider] -> Provider +-- | Combines the given list of loaders, by calling each one in +-- order until a 'CredentialValue' is returned. +findFirst :: [CredentialLoader] -> IO (Maybe CredentialValue) findFirst [] = return Nothing findFirst (f : fs) = do c <- f maybe (findFirst fs) (return . Just) c --- | This Provider loads `Credentials` from @~\/.aws\/credentials@ -fromAWSConfigFile :: Provider +-- | This action returns a 'CredentialValue' populated from +-- @~\/.aws\/credentials@ +fromAWSConfigFile :: CredentialLoader fromAWSConfigFile = do credsE <- runExceptT $ do homeDir <- lift getHomeDirectory @@ -190,29 +193,28 @@ fromAWSConfigFile = do ExceptT $ return $ Ini.lookupValue "default" "aws_secret_access_key" ini - return $ Credentials akey skey + return $ CredentialValue (coerce akey) (fromString $ T.unpack skey) Nothing return $ either (const Nothing) Just credsE --- | This Provider loads `Credentials` from @AWS_ACCESS_KEY_ID@ and --- @AWS_SECRET_ACCESS_KEY@ environment variables. -fromAWSEnv :: Provider +-- | This action returns a 'CredentialValue` populated from @AWS_ACCESS_KEY_ID@ +-- and @AWS_SECRET_ACCESS_KEY@ environment variables. +fromAWSEnv :: CredentialLoader 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) + return $ CredentialValue (fromString akey) (fromString skey) Nothing --- | This Provider loads `Credentials` from @MINIO_ACCESS_KEY@ and --- @MINIO_SECRET_KEY@ environment variables. -fromMinioEnv :: Provider +-- | This action returns a 'CredentialValue' populated from @MINIO_ACCESS_KEY@ +-- and @MINIO_SECRET_KEY@ environment variables. +fromMinioEnv :: CredentialLoader 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) + return $ CredentialValue (fromString akey) (fromString skey) Nothing --- | 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 retrieves access credentials from the first action in the +-- given list that succeeds and sets it in the 'ConnectInfo'. +setCredsFrom :: [CredentialLoader] -> ConnectInfo -> IO ConnectInfo setCredsFrom ps ci = do pMay <- findFirst ps maybe @@ -220,14 +222,21 @@ setCredsFrom ps ci = do (return . (`setCreds` ci)) pMay --- | setCreds sets the given `Credentials` in the `ConnectInfo`. -setCreds :: Credentials -> ConnectInfo -> ConnectInfo -setCreds (Credentials accessKey secretKey) connInfo = +-- | setCreds sets the given `CredentialValue` in the `ConnectInfo`. +setCreds :: CredentialValue -> ConnectInfo -> ConnectInfo +setCreds cv connInfo = connInfo - { connectAccessKey = accessKey, - connectSecretKey = secretKey + { connectCreds = CredsStatic cv } +-- | 'setSTSCredential' configures `ConnectInfo` to retrieve temporary +-- credentials via the STS API on demand. It is automatically refreshed on +-- expiry. +setSTSCredential :: STSCredentialProvider p => p -> ConnectInfo -> IO ConnectInfo +setSTSCredential p ci = do + store <- initSTSCredential p + return ci {connectCreds = CredsSTS store} + -- | Set the S3 region parameter in the `ConnectInfo` setRegion :: Region -> ConnectInfo -> ConnectInfo setRegion r connInfo = @@ -248,12 +257,6 @@ isConnectInfoSecure = connectIsSecure disableTLSCertValidation :: ConnectInfo -> ConnectInfo disableTLSCertValidation c = c {connectDisableTLSCertValidation = True} -getHostHeader :: (ByteString, Int) -> ByteString -getHostHeader (host, port) = - if port == 80 || port == 443 - then host - else host <> ":" <> show port - getHostAddr :: ConnectInfo -> ByteString getHostAddr ci = getHostHeader (encodeUtf8 $ connectHost ci, connectPort ci) @@ -278,7 +281,7 @@ awsCI = "https://s3.amazonaws.com" -- ConnectInfo. Credentials are already filled in. minioPlayCI :: ConnectInfo minioPlayCI = - let playCreds = Credentials "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG" + let playCreds = CredentialValue "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG" Nothing in setCreds playCreds $ setRegion "us-east-1" @@ -380,24 +383,6 @@ data PutObjectOptions = PutObjectOptions defaultPutObjectOptions :: PutObjectOptions defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing --- | If the given header name has the @X-Amz-Meta-@ prefix, it is --- stripped and a Just is returned. -userMetadataHeaderNameMaybe :: Text -> Maybe Text -userMetadataHeaderNameMaybe k = - let prefix = T.toCaseFold "X-Amz-Meta-" - n = T.length prefix - in if T.toCaseFold (T.take n k) == prefix - then Just (T.drop n k) - else Nothing - -addXAmzMetaPrefix :: Text -> Text -addXAmzMetaPrefix s - | isJust (userMetadataHeaderNameMaybe s) = s - | otherwise = "X-Amz-Meta-" <> s - -mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header] -mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix x, encodeUtf8 y)) - pooToHeaders :: PutObjectOptions -> [HT.Header] pooToHeaders poo = userMetadata @@ -437,6 +422,29 @@ data BucketInfo = BucketInfo -- | A type alias to represent a part-number for multipart upload type PartNumber = Int16 +-- | 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 + where + ceil :: Double -> Int64 + ceil = ceiling + partSize = + max + minPartSize + ( ceil $ + fromIntegral size + / fromIntegral maxMultipartParts + ) + m = partSize + loop st sz + | st > sz = [] + | st + m >= sz = [(st, sz - st)] + | otherwise = (st, m) : loop (st + m) sz + -- | A type alias to represent an upload-id for multipart upload type UploadId = Text @@ -1016,47 +1024,6 @@ type Stats = Progress -- Select API Related Types End -------------------------------------------------------------------------- ----------------------------------------- --- Credentials Start ----------------------------------------- - -newtype AccessKey = AccessKey {unAccessKey :: Text} - deriving stock (Show) - deriving newtype (Eq, IsString) - -newtype SecretKey = SecretKey {unSecretKey :: BA.ScrubbedBytes} - deriving stock (Show) - deriving newtype (Eq, IsString) - -newtype SessionToken = SessionToken {unSessionToken :: BA.ScrubbedBytes} - deriving stock (Show) - deriving newtype (Eq, IsString) - -data CredentialValue = CredentialValue - { cvAccessKey :: AccessKey, - cvSecretKey :: SecretKey, - cvSessionToken :: Maybe SessionToken - } - deriving stock (Eq, Show) - -data AssumeRoleCredentials = AssumeRoleCredentials - { arcCredentials :: CredentialValue, - arcExpiration :: UTCTime - } - deriving stock (Show, Eq) - -data AssumeRoleResult = AssumeRoleResult - { arrSourceIdentity :: Text, - arrAssumedRoleArn :: Text, - arrAssumedRoleId :: Text, - arrRoleCredentials :: AssumeRoleCredentials - } - deriving stock (Show, Eq) - ----------------------------------------- --- Credentials End ----------------------------------------- - -- | Represents different kinds of payload that are used with S3 API -- requests. data Payload @@ -1202,9 +1169,22 @@ runMinioRes ci m = do conn <- liftIO $ connect ci runMinioResWith conn m -s3Name :: Text -> Text -> Name -s3Name ns s = Name s (Just ns) Nothing - -- | Format as per RFC 1123. formatRFC1123 :: UTCTime -> T.Text formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" + +lookupRegionCache :: Bucket -> Minio (Maybe Region) +lookupRegionCache b = do + 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 + +deleteFromRegionCache :: Bucket -> Minio () +deleteFromRegionCache b = do + rMVar <- asks mcRegionMap + UM.modifyMVar_ rMVar $ return . H.delete b diff --git a/src/Network/Minio/Errors.hs b/src/Network/Minio/Errors.hs index 91c6860..fa6ac0b 100644 --- a/src/Network/Minio/Errors.hs +++ b/src/Network/Minio/Errors.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -49,6 +49,7 @@ data MErrV | MErrVInvalidEncryptionKeyLength | MErrVStreamingBodyUnexpectedEOF | MErrVUnexpectedPayload + | MErrVSTSEndpointNotFound deriving stock (Show, Eq) instance Exception MErrV diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs index f651deb..631f302 100644 --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} - -- --- MinIO Haskell SDK, (C) 2017 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -15,6 +13,7 @@ -- See the License for the specific language governing permissions and -- limitations under the License. -- +{-# LANGUAGE CPP #-} module Network.Minio.PresignedOperations ( UrlExpiry, @@ -39,7 +38,6 @@ where import Data.Aeson ((.=)) import qualified Data.Aeson as Json -import qualified Data.ByteArray as BA import Data.ByteString.Builder (byteString, toLazyByteString) import qualified Data.HashMap.Strict as H import qualified Data.Text as T @@ -48,6 +46,7 @@ import Lib.Prelude import qualified Network.HTTP.Client as NClient import qualified Network.HTTP.Types as HT import Network.Minio.API (buildRequest) +import Network.Minio.Credentials import Network.Minio.Data import Network.Minio.Data.Time import Network.Minio.Errors @@ -300,6 +299,8 @@ presignedPostPolicy :: presignedPostPolicy p = do ci <- asks mcConnInfo signTime <- liftIO Time.getCurrentTime + mgr <- asks mcConnManager + cv <- liftIO $ getCredential (connectCreds ci) (getEndpoint ci) mgr let extraConditions signParams = [ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime), @@ -308,7 +309,7 @@ presignedPostPolicy p = do "x-amz-credential" ( T.intercalate "/" - [ connectAccessKey ci, + [ coerce $ cvAccessKey cv, decodeUtf8 $ credentialScope signParams ] ) @@ -319,8 +320,9 @@ presignedPostPolicy p = do } sp = SignParams - (connectAccessKey ci) - (BA.convert (encodeUtf8 $ connectSecretKey ci :: ByteString)) + (coerce $ cvAccessKey cv) + (coerce $ cvSecretKey cv) + (coerce $ cvSessionToken cv) ServiceS3 signTime (Just $ connectRegion ci) diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index 80555f0..f628b48 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -14,6 +14,14 @@ -- limitations under the License. -- +-- | +-- Module: Network.Minio.S3API +-- Copyright: (c) 2017-2023 MinIO Dev Team +-- License: Apache 2.0 +-- Maintainer: MinIO Dev Team +-- +-- Lower-level API for S3 compatible object stores. Start with @Network.Minio@ +-- and use this only if needed. module Network.Minio.S3API ( Region, getLocation, diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index 73f9f2a..f822e44 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -15,7 +15,16 @@ -- {-# LANGUAGE BangPatterns #-} -module Network.Minio.Sign.V4 where +module Network.Minio.Sign.V4 + ( SignParams (..), + signV4QueryParams, + signV4, + signV4PostPolicy, + signV4Stream, + Service (..), + credentialScope, + ) +where import qualified Conduit as C import qualified Data.ByteArray as BA @@ -23,6 +32,7 @@ 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 @@ -52,17 +62,6 @@ ignoredHeaders = H.hUserAgent ] -data SignV4Data = SignV4Data - { sv4SignTime :: UTCTime, - sv4Scope :: ByteString, - sv4CanonicalRequest :: ByteString, - sv4HeadersToSign :: [(ByteString, ByteString)], - sv4Output :: [(ByteString, ByteString)], - sv4StringToSign :: ByteString, - sv4SigningKey :: ByteString - } - deriving stock (Show) - data Service = ServiceS3 | ServiceSTS deriving stock (Eq, Show) @@ -73,6 +72,7 @@ toByteString ServiceSTS = "sts" data SignParams = SignParams { spAccessKey :: Text, spSecretKey :: BA.ScrubbedBytes, + spSessionToken :: Maybe BA.ScrubbedBytes, spService :: Service, spTimeStamp :: UTCTime, spRegion :: Maybe Text, @@ -81,23 +81,6 @@ data SignParams = SignParams } deriving stock (Show) -debugPrintSignV4Data :: SignV4Data -> IO () -debugPrintSignV4Data (SignV4Data t s cr h2s o sts sk) = do - B8.putStrLn "SignV4Data:" - B8.putStr "Timestamp: " >> print t - B8.putStr "Scope: " >> B8.putStrLn s - B8.putStrLn "Canonical Request:" - B8.putStrLn cr - B8.putStr "Headers to Sign: " >> print h2s - B8.putStr "Output: " >> print o - B8.putStr "StringToSign: " >> B8.putStrLn sts - B8.putStr "SigningKey: " >> printBytes sk - B8.putStrLn "END of SignV4Data =========" - where - printBytes b = do - 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 = @@ -116,6 +99,9 @@ mkAuthHeader accessKey scope signedHeaderKeys sign = data IsStreaming = IsStreamingLength Int64 | NotStreaming deriving stock (Eq, Show) +amzSecurityToken :: ByteString +amzSecurityToken = "X-Amz-Security-Token" + -- | Given SignParams and request details, including request method, -- request path, headers, query params and payload hash, generates an -- updated set of headers, including the x-amz-date header and the @@ -144,6 +130,7 @@ signV4QueryParams !sp !req = ("X-Amz-Expires", maybe "" showBS expiry), ("X-Amz-SignedHeaders", signedHeaderKeys) ] + ++ maybeToList ((amzSecurityToken,) . BA.convert <$> spSessionToken sp) finalQP = parseQuery (NC.queryString req) ++ if isJust expiry @@ -185,6 +172,7 @@ signV4 !sp !req = | spService sp == ServiceS3 ] ) + ++ maybeToList ((mk amzSecurityToken,) . BA.convert <$> spSessionToken sp) -- 1. compute canonical request reqHeaders = NC.requestHeaders req ++ extraHeaders @@ -347,10 +335,11 @@ signV4PostPolicy !postPolicyJSON !sp = let stringToSign = Base64.encode postPolicyJSON signingKey = getSigningKey sp signature = computeSignature stringToSign signingKey - in Map.fromList + in Map.fromList $ [ ("x-amz-signature", signature), ("policy", stringToSign) ] + ++ maybeToList ((decodeUtf8 amzSecurityToken,) . BA.convert <$> spSessionToken sp) chunkSizeConstant :: Int chunkSizeConstant = 64 * 1024 @@ -401,6 +390,7 @@ signV4Stream !payloadLength !sp !req = ("content-length", showBS signedContentLength), ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD") ] + ++ maybeToList ((mk amzSecurityToken,) . BA.convert <$> spSessionToken sp) requestHeaders = addContentEncoding $ foldr setHeader (NC.requestHeaders req) extraHeaders diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index 2ecab7c..f985ddc 100644 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -24,7 +24,6 @@ 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 @@ -37,14 +36,12 @@ 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 Network.Minio.XmlCommon (parseErrResponse) import qualified System.IO as IO import qualified UnliftIO as U import qualified UnliftIO.Async as A -import qualified UnliftIO.MVar as UM allocateReadFile :: (MonadUnliftIO m, R.MonadResource m) => @@ -115,6 +112,16 @@ getMetadata :: [HT.Header] -> [(Text, Text)] getMetadata = map (\(x, y) -> (decodeUtf8Lenient $ original x, decodeUtf8Lenient $ stripBS y)) +-- | If the given header name has the @X-Amz-Meta-@ prefix, it is +-- stripped and a Just is returned. +userMetadataHeaderNameMaybe :: Text -> Maybe Text +userMetadataHeaderNameMaybe k = + let prefix = T.toCaseFold "X-Amz-Meta-" + n = T.length prefix + in if T.toCaseFold (T.take n k) == prefix + then Just (T.drop n k) + else Nothing + toMaybeMetadataHeader :: (Text, Text) -> Maybe (Text, Text) toMaybeMetadataHeader (k, v) = (,v) <$> userMetadataHeaderNameMaybe k @@ -128,6 +135,14 @@ getNonUserMetadataMap = . fst ) +addXAmzMetaPrefix :: Text -> Text +addXAmzMetaPrefix s + | isJust (userMetadataHeaderNameMaybe s) = s + | otherwise = "X-Amz-Meta-" <> s + +mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header] +mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix x, encodeUtf8 y)) + -- | 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 @@ -135,6 +150,12 @@ getUserMetadataMap = H.fromList . mapMaybe toMaybeMetadataHeader +getHostHeader :: (ByteString, Int) -> ByteString +getHostHeader (host_, port_) = + if port_ == 80 || port_ == 443 + then host_ + else host_ <> ":" <> show port_ + getLastModifiedHeader :: [HT.Header] -> Maybe UTCTime getLastModifiedHeader hs = do modTimebs <- decodeUtf8Lenient <$> lookupHeader Hdr.hLastModified hs @@ -262,42 +283,3 @@ chunkBSConduit (s : ss) = do | 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 - where - ceil :: Double -> Int64 - ceil = ceiling - partSize = - max - minPartSize - ( ceil $ - fromIntegral size - / fromIntegral maxMultipartParts - ) - m = partSize - loop st sz - | st > sz = [] - | st + m >= sz = [(st, sz - st)] - | otherwise = (st, m) : loop (st + m) sz - -lookupRegionCache :: Bucket -> Minio (Maybe Region) -lookupRegionCache b = do - 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 - -deleteFromRegionCache :: Bucket -> Minio () -deleteFromRegionCache b = do - rMVar <- asks mcRegionMap - UM.modifyMVar_ rMVar $ return . H.delete b diff --git a/src/Network/Minio/XmlCommon.hs b/src/Network/Minio/XmlCommon.hs new file mode 100644 index 0000000..6c428ce --- /dev/null +++ b/src/Network/Minio/XmlCommon.hs @@ -0,0 +1,65 @@ +-- +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +module Network.Minio.XmlCommon where + +import qualified Data.Text as T +import Data.Text.Read (decimal) +import Data.Time (UTCTime) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import Lib.Prelude (throwIO) +import Network.Minio.Errors +import Text.XML (Name (Name), def, parseLBS) +import Text.XML.Cursor (Axis, Cursor, content, element, fromDocument, laxElement, ($/), (&/)) + +s3Name :: Text -> Text -> Name +s3Name ns s = Name s (Just ns) Nothing + +uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e +uncurry4 f (a, b, c, d) = f a b c d + +uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g +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 $ + iso8601ParseM $ + toString t + +parseDecimal :: (MonadIO m, Integral a) => Text -> m a +parseDecimal numStr = + either (throwIO . MErrVXmlParse . show) return $ + fst <$> decimal numStr + +parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a] +parseDecimals numStr = forM numStr parseDecimal + +s3Elem :: Text -> Text -> Axis +s3Elem ns = element . s3Name ns + +parseRoot :: (MonadIO m) => LByteString -> m Cursor +parseRoot = + either (throwIO . MErrVXmlParse . show) (return . fromDocument) + . parseLBS def + +parseErrResponse :: (MonadIO m) => LByteString -> m ServiceErr +parseErrResponse xmldata = do + r <- parseRoot xmldata + let code = T.concat $ r $/ laxElement "Code" &/ content + message = T.concat $ r $/ laxElement "Message" &/ content + return $ toServiceErr code message diff --git a/src/Network/Minio/XmlGenerator.hs b/src/Network/Minio/XmlGenerator.hs index 730def0..a7f8c31 100644 --- a/src/Network/Minio/XmlGenerator.hs +++ b/src/Network/Minio/XmlGenerator.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2017 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -25,6 +25,7 @@ where import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import Network.Minio.Data +import Network.Minio.XmlCommon import Text.XML -- | Create a bucketConfig request body XML diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index ae55d48..46e4bcf 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2017 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -27,54 +27,18 @@ module Network.Minio.XmlParser parseErrResponse, parseNotification, parseSelectProgress, - parseSTSAssumeRoleResult, ) where -import qualified Data.ByteArray as BA import qualified Data.ByteString.Lazy as LB import qualified Data.HashMap.Strict as H import Data.List (zip4, zip6) import qualified Data.Text as T -import Data.Text.Read (decimal) import Data.Time -import Data.Time.Format.ISO8601 (iso8601ParseM) -import Lib.Prelude import Network.Minio.Data -import Network.Minio.Errors -import Text.XML +import Network.Minio.XmlCommon import Text.XML.Cursor hiding (bool) --- | Helper functions. -uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e -uncurry4 f (a, b, c, d) = f a b c d - -uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g -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 $ - iso8601ParseM $ - toString t - -parseDecimal :: (MonadIO m, Integral a) => Text -> m a -parseDecimal numStr = - either (throwIO . MErrVXmlParse . show) return $ - fst <$> decimal numStr - -parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a] -parseDecimals numStr = forM numStr parseDecimal - -s3Elem :: Text -> Text -> Axis -s3Elem ns = element . s3Name ns - -parseRoot :: (MonadIO m) => LByteString -> m Cursor -parseRoot = - either (throwIO . MErrVXmlParse . show) (return . fromDocument) - . parseLBS def - -- | Parse the response XML of a list buckets call. parseListBuckets :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m [BucketInfo] parseListBuckets xmldata = do @@ -219,13 +183,6 @@ parseListPartsResponse xmldata = do return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos -parseErrResponse :: (MonadIO m) => LByteString -> m ServiceErr -parseErrResponse xmldata = do - r <- parseRoot xmldata - let code = T.concat $ r $/ laxElement "Code" &/ content - message = T.concat $ r $/ laxElement "Message" &/ content - return $ toServiceErr code message - parseNotification :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m Notification parseNotification xmldata = do r <- parseRoot xmldata @@ -271,102 +228,3 @@ parseSelectProgress xmldata = do <$> parseDecimal bScanned <*> parseDecimal bProcessed <*> parseDecimal bReturned - --- --- --- Alice --- --- arn:aws:sts::123456789012:assumed-role/demo/TestAR --- ARO123EXAMPLE123:TestAR --- --- --- ASIAIOSFODNN7EXAMPLE --- wJalrXUtnFEMI/K7MDENG/bPxRfiCYzEXAMPLEKEY --- --- AQoDYXdzEPT//////////wEXAMPLEtc764bNrC9SAPBSM22wDOk4x4HIZ8j4FZTwdQW --- LWsKWHGBuFqwAeMicRXmxfpSPfIeoIYRqTflfKD8YUuwthAx7mSEI/qkPpKPi/kMcGd --- QrmGdeehM4IC1NtBmUpp2wUE8phUZampKsburEDy0KPkyQDYwT7WZ0wq5VSXDvp75YU --- 9HFvlRd8Tx6q6fE8YQcHNVXAkiY9q6d+xo0rKwT38xVqr7ZD0u0iPPkUL64lIZbqBAz --- +scqKmlzm8FDrypNC9Yjc8fPOLn9FX9KSYvKTr4rvx3iSIlTJabIQwj2ICCR/oLxBA== --- --- 2019-11-09T13:34:41Z --- --- 6 --- --- --- c6104cbe-af31-11e0-8154-cbc7ccf896c7 --- --- - -parseSTSAssumeRoleResult :: MonadIO m => ByteString -> Text -> m AssumeRoleResult -parseSTSAssumeRoleResult xmldata namespace = do - r <- parseRoot $ LB.fromStrict xmldata - let s3Elem' = s3Elem namespace - sourceIdentity = - T.concat $ - r - $/ s3Elem' "AssumeRoleResult" - &/ s3Elem' "SourceIdentity" - &/ content - roleArn = - T.concat $ - r - $/ s3Elem' "AssumeRoleResult" - &/ s3Elem' "AssumedRoleUser" - &/ s3Elem' "Arn" - &/ content - roleId = - T.concat $ - r - $/ s3Elem' "AssumeRoleResult" - &/ s3Elem' "AssumedRoleUser" - &/ s3Elem' "AssumedRoleId" - &/ content - - convSB :: Text -> BA.ScrubbedBytes - convSB = BA.convert . (encodeUtf8 :: Text -> ByteString) - - credsInfo = do - cr <- - maybe (Left $ MErrVXmlParse "No Credentials Element found") Right $ - listToMaybe $ - r $/ s3Elem' "AssumeRoleResult" &/ s3Elem' "Credentials" - let cur = fromNode $ node cr - return - ( CredentialValue - { cvAccessKey = - coerce $ - T.concat $ - cur $/ s3Elem' "AccessKeyId" &/ content, - cvSecretKey = - coerce $ - convSB $ - T.concat $ - cur - $/ s3Elem' "SecretAccessKey" - &/ content, - cvSessionToken = - Just $ - coerce $ - convSB $ - T.concat $ - cur - $/ s3Elem' "SessionToken" - &/ content - }, - T.concat $ cur $/ s3Elem' "Expiration" &/ content - ) - creds <- either throwIO pure credsInfo - expiry <- parseS3XMLTime $ snd creds - let roleCredentials = - AssumeRoleCredentials - { arcCredentials = fst creds, - arcExpiration = expiry - } - return - AssumeRoleResult - { arrSourceIdentity = sourceIdentity, - arrAssumedRoleArn = roleArn, - arrAssumedRoleId = roleId, - arrRoleCredentials = roleCredentials - } diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 613caf3..7f73070 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} - -- --- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -32,6 +30,7 @@ import qualified Network.HTTP.Client.MultipartFormData as Form import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT import Network.Minio +import Network.Minio.Credentials (Creds (CredsStatic)) import Network.Minio.Data import Network.Minio.Data.Crypto import Network.Minio.S3API @@ -77,15 +76,35 @@ mkRandFile size = do funTestBucketPrefix :: Text funTestBucketPrefix = "miniohstest-" -loadTestServer :: IO ConnectInfo -loadTestServer = do +loadTestServerConnInfo :: IO ConnectInfo +loadTestServerConnInfo = do val <- Env.lookupEnv "MINIO_LOCAL" isSecure <- Env.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" + (Just _, Just _) -> setCreds (CredentialValue "minio" "minio123" mempty) "https://localhost:9000" + (Just _, Nothing) -> setCreds (CredentialValue "minio" "minio123" mempty) "http://localhost:9000" (Nothing, _) -> minioPlayCI +loadTestServerConnInfoSTS :: IO ConnectInfo +loadTestServerConnInfoSTS = do + val <- Env.lookupEnv "MINIO_LOCAL" + isSecure <- Env.lookupEnv "MINIO_SECURE" + let cv = CredentialValue "minio" "minio123" mempty + assumeRole = + STSAssumeRole + { sarCredentials = cv, + sarOptions = defaultSTSAssumeRoleOptions + } + case (val, isSecure) of + (Just _, Just _) -> setSTSCredential assumeRole "https://localhost:9000" + (Just _, Nothing) -> setSTSCredential assumeRole "http://localhost:9000" + (Nothing, _) -> do + cv' <- case connectCreds minioPlayCI of + CredsStatic c -> return c + _ -> error "unexpected play creds" + let assumeRole' = assumeRole {sarCredentials = cv'} + setSTSCredential assumeRole' minioPlayCI + funTestWithBucket :: TestName -> (([Char] -> Minio ()) -> Bucket -> Minio ()) -> @@ -95,7 +114,7 @@ funTestWithBucket t minioTest = testCaseSteps t $ \step -> do bktSuffix <- liftIO $ generate $ Q.vectorOf 10 (Q.choose ('a', 'z')) let b = T.concat [funTestBucketPrefix, T.pack bktSuffix] liftStep = liftIO . step - connInfo <- loadTestServer + connInfo <- loadTestServerConnInfo ret <- runMinio connInfo $ do liftStep $ "Creating bucket for test - " ++ t foundBucket <- bucketExists b @@ -105,6 +124,17 @@ funTestWithBucket t minioTest = testCaseSteps t $ \step -> do deleteBucket b isRight ret @? ("Functional test " ++ t ++ " failed => " ++ show ret) + connInfoSTS <- loadTestServerConnInfoSTS + let t' = t ++ " (with AssumeRole Credentials)" + ret' <- runMinio connInfoSTS $ do + liftStep $ "Creating bucket for test - " ++ t' + foundBucket <- bucketExists b + liftIO $ foundBucket @?= False + makeBucket b Nothing + minioTest liftStep b + deleteBucket b + isRight ret' @? ("Functional test " ++ t' ++ " failed => " ++ show ret') + liveServerUnitTests :: TestTree liveServerUnitTests = testGroup @@ -125,7 +155,8 @@ liveServerUnitTests = presignedUrlFunTest, presignedPostPolicyFunTest, bucketPolicyFunTest, - getNPutSSECTest + getNPutSSECTest, + assumeRoleRequestTest ] basicTests :: TestTree @@ -1187,3 +1218,30 @@ getNPutSSECTest = step "Cleanup" deleteObject bucket obj else step "Skipping encryption test as server is not using TLS" + +assumeRoleRequestTest :: TestTree +assumeRoleRequestTest = testCaseSteps "Assume Role STS API" $ \step -> do + step "Load credentials" + val <- Env.lookupEnv "MINIO_LOCAL" + isSecure <- Env.lookupEnv "MINIO_SECURE" + let localMinioCred = Just $ CredentialValue "minio" "minio123" mempty + playCreds = + case connectCreds minioPlayCI of + CredsStatic c -> Just c + _ -> Nothing + (cvMay, loc) = + case (val, isSecure) of + (Just _, Just _) -> (localMinioCred, "https://localhost:9000") + (Just _, Nothing) -> (localMinioCred, "http://localhost:9000") + (Nothing, _) -> (playCreds, "https://play.min.io:9000") + cv <- maybe (assertFailure "bad creds") return cvMay + let assumeRole = + STSAssumeRole cv $ + defaultSTSAssumeRoleOptions + { saroLocation = Just "us-east-1", + saroEndpoint = Just loc + } + step "AssumeRole request" + res <- requestSTSCredential assumeRole + let v = credentialValueText $ fst res + print (v, snd res) diff --git a/test/Spec.hs b/test/Spec.hs index e851043..5eadd5b 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,5 +1,5 @@ -- --- MinIO Haskell SDK, (C) 2017, 2018 MinIO, Inc. +-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc. -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. @@ -20,7 +20,6 @@ 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 From 45e88d813ba931f67e18398c03bc783fd84ec0e2 Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Mon, 22 May 2023 12:32:34 -0700 Subject: [PATCH 24/24] Enable StrictData and bump up version for release (#189) * Enable StrictData and bump up version for release - Types defined in Credentials.Types and Network.Minio.Data are now strict * ormolu fixes --- .github/workflows/ci.yml | 4 +++- minio-hs.cabal | 2 +- src/Lib/Prelude.hs | 2 +- src/Network/Minio/API.hs | 6 +++--- src/Network/Minio/Credentials.hs | 2 +- src/Network/Minio/Credentials/AssumeRole.hs | 4 +++- src/Network/Minio/Credentials/Types.hs | 9 +++++++-- src/Network/Minio/Data.hs | 16 ++++++---------- src/Network/Minio/Data/Crypto.hs | 16 ++++++++-------- src/Network/Minio/SelectAPI.hs | 14 +++++++------- src/Network/Minio/Sign/V4.hs | 2 +- src/Network/Minio/Utils.hs | 4 ++-- src/Network/Minio/XmlCommon.hs | 2 +- src/Network/Minio/XmlParser.hs | 2 +- test/LiveServer.hs | 4 ++-- 15 files changed, 47 insertions(+), 42 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 86a342c..8557d4e 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -25,7 +25,9 @@ jobs: runs-on: ubuntu-latest steps: - uses: actions/checkout@v3 - - uses: mrkkrp/ormolu-action@v8 + - uses: haskell-actions/run-ormolu@v12 + with: + version: "0.5.0.1" hlint: runs-on: ubuntu-latest diff --git a/minio-hs.cabal b/minio-hs.cabal index 620ef4c..77d7557 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: minio-hs -version: 1.6.0 +version: 1.7.0 synopsis: A MinIO Haskell Library for Amazon S3 compatible cloud storage. description: The MinIO Haskell client library provides simple APIs to diff --git a/src/Lib/Prelude.hs b/src/Lib/Prelude.hs index 5d16a89..d3af2bd 100644 --- a/src/Lib/Prelude.hs +++ b/src/Lib/Prelude.hs @@ -42,7 +42,7 @@ import UnliftIO as Exports both :: (a -> b) -> (a, a) -> (b, b) both f (a, b) = (f a, f b) -showBS :: Show a => a -> ByteString +showBS :: (Show a) => a -> ByteString showBS a = encodeUtf8 (show a :: Text) toStrictBS :: LByteString -> ByteString diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index 34f45dd..cb4b309 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -150,7 +150,7 @@ getHostPathRegion ri = do -- | requestSTSCredential requests temporary credentials using the Security Token -- Service API. The returned credential will include a populated 'SessionToken' -- and an 'ExpiryTime'. -requestSTSCredential :: STSCredentialProvider p => p -> IO (CredentialValue, ExpiryTime) +requestSTSCredential :: (STSCredentialProvider p) => p -> IO (CredentialValue, ExpiryTime) requestSTSCredential p = do endpoint <- maybe (throwIO $ MErrValidation MErrVSTSEndpointNotFound) return $ getSTSEndpoint p let endPt = NC.parseRequest_ $ toString endpoint @@ -337,7 +337,7 @@ isValidBucketName bucket = isIPCheck = and labelAsNums && length labelAsNums == 4 -- Throws exception iff bucket name is invalid according to AWS rules. -checkBucketNameValidity :: MonadIO m => Bucket -> m () +checkBucketNameValidity :: (MonadIO m) => Bucket -> m () checkBucketNameValidity bucket = unless (isValidBucketName bucket) $ throwIO $ @@ -347,7 +347,7 @@ isValidObjectName :: Object -> Bool isValidObjectName object = T.length object > 0 && B.length (encodeUtf8 object) <= 1024 -checkObjectNameValidity :: MonadIO m => Object -> m () +checkObjectNameValidity :: (MonadIO m) => Object -> m () checkObjectNameValidity object = unless (isValidObjectName object) $ throwIO $ diff --git a/src/Network/Minio/Credentials.hs b/src/Network/Minio/Credentials.hs index 2920370..5058596 100644 --- a/src/Network/Minio/Credentials.hs +++ b/src/Network/Minio/Credentials.hs @@ -47,7 +47,7 @@ data STSCredentialStore = STSCredentialStore refreshAction :: Endpoint -> NC.Manager -> IO (CredentialValue, ExpiryTime) } -initSTSCredential :: STSCredentialProvider p => p -> IO STSCredentialStore +initSTSCredential :: (STSCredentialProvider p) => p -> IO STSCredentialStore initSTSCredential p = do let action = retrieveSTSCredentials p -- start with dummy credential, so that refresh happens for first request. diff --git a/src/Network/Minio/Credentials/AssumeRole.hs b/src/Network/Minio/Credentials/AssumeRole.hs index 0328ec6..7a2df24 100644 --- a/src/Network/Minio/Credentials/AssumeRole.hs +++ b/src/Network/Minio/Credentials/AssumeRole.hs @@ -41,6 +41,8 @@ defaultDurationSeconds :: Second defaultDurationSeconds = 3600 -- | Assume Role API argument. +-- +-- @since 1.7.0 data STSAssumeRole = STSAssumeRole { -- | Credentials to use in the AssumeRole STS API. sarCredentials :: CredentialValue, @@ -119,7 +121,7 @@ data AssumeRoleResult = AssumeRoleResult -- c6104cbe-af31-11e0-8154-cbc7ccf896c7 -- -- -parseSTSAssumeRoleResult :: MonadIO m => ByteString -> Text -> m AssumeRoleResult +parseSTSAssumeRoleResult :: (MonadIO m) => ByteString -> Text -> m AssumeRoleResult parseSTSAssumeRoleResult xmldata namespace = do r <- parseRoot $ LB.fromStrict xmldata let s3Elem' = s3Elem namespace diff --git a/src/Network/Minio/Credentials/Types.hs b/src/Network/Minio/Credentials/Types.hs index a9c33bc..0579758 100644 --- a/src/Network/Minio/Credentials/Types.hs +++ b/src/Network/Minio/Credentials/Types.hs @@ -14,6 +14,7 @@ -- limitations under the License. -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StrictData #-} module Network.Minio.Credentials.Types where @@ -37,11 +38,13 @@ newtype SessionToken = SessionToken {unSessionToken :: BA.ScrubbedBytes} deriving newtype (Eq, IsString, Semigroup, Monoid) -- | Object storage credential data type. It has support for the optional --- for using temporary credentials requested via STS. +-- [SessionToken](https://docs.aws.amazon.com/IAM/latest/UserGuide/id_credentials_temp_use-resources.html) +-- for using temporary credentials requested via STS. -- -- The show instance for this type does not print the value of secrets for -- security. +-- +-- @since 1.7.0 data CredentialValue = CredentialValue { cvAccessKey :: AccessKey, cvSecretKey :: SecretKey, @@ -70,6 +73,8 @@ credentialValueText cv = type Endpoint = (ByteString, Int, Bool) -- | Typeclass for STS credential providers. +-- +-- @since 1.7.0 class STSCredentialProvider p where retrieveSTSCredentials :: p -> diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 6e53d5a..a0a47a3 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -16,6 +16,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} module Network.Minio.Data where @@ -156,15 +157,10 @@ instance IsString ConnectInfo where connectDisableTLSCertValidation = False } --- | Contains access key and secret key to access object storage. -data Credentials = Credentials - { cAccessKey :: Text, - cSecretKey :: Text - } - deriving stock (Eq, Show) - -- | A 'CredentialLoader' is an action that may return a 'CredentialValue'. -- Loaders may be chained together using 'findFirst'. +-- +-- @since 1.7.0 type CredentialLoader = IO (Maybe CredentialValue) -- | Combines the given list of loaders, by calling each one in @@ -232,7 +228,7 @@ setCreds cv connInfo = -- | 'setSTSCredential' configures `ConnectInfo` to retrieve temporary -- credentials via the STS API on demand. It is automatically refreshed on -- expiry. -setSTSCredential :: STSCredentialProvider p => p -> ConnectInfo -> IO ConnectInfo +setSTSCredential :: (STSCredentialProvider p) => p -> ConnectInfo -> IO ConnectInfo setSTSCredential p ci = do store <- initSTSCredential p return ci {connectCreds = CredsSTS store} @@ -308,7 +304,7 @@ newtype SSECKey = SSECKey BA.ScrubbedBytes -- | Validates that the given ByteString is 32 bytes long and creates -- an encryption key. -mkSSECKey :: MonadThrow m => ByteString -> m SSECKey +mkSSECKey :: (MonadThrow m) => ByteString -> m SSECKey mkSSECKey keyBytes | B.length keyBytes /= 32 = throwM MErrVInvalidEncryptionKeyLength @@ -325,7 +321,7 @@ data SSE where -- 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 + 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 diff --git a/src/Network/Minio/Data/Crypto.hs b/src/Network/Minio/Data/Crypto.hs index af51cb3..3180859 100644 --- a/src/Network/Minio/Data/Crypto.hs +++ b/src/Network/Minio/Data/Crypto.hs @@ -43,26 +43,26 @@ import qualified Data.Conduit as C hashSHA256 :: ByteString -> ByteString hashSHA256 = digestToBase16 . hashWith SHA256 -hashSHA256FromSource :: Monad m => C.ConduitM () ByteString m () -> m ByteString +hashSHA256FromSource :: (Monad m) => C.ConduitM () ByteString m () -> m ByteString hashSHA256FromSource src = do digest <- C.connect src sinkSHA256Hash return $ digestToBase16 digest where -- To help with type inference - sinkSHA256Hash :: Monad m => C.ConduitM ByteString Void m (Digest SHA256) + sinkSHA256Hash :: (Monad m) => C.ConduitM ByteString Void m (Digest SHA256) sinkSHA256Hash = sinkHash -- Returns MD5 hash hex encoded. hashMD5 :: ByteString -> ByteString hashMD5 = digestToBase16 . hashWith MD5 -hashMD5FromSource :: Monad m => C.ConduitM () ByteString m () -> m ByteString +hashMD5FromSource :: (Monad m) => C.ConduitM () ByteString m () -> m ByteString hashMD5FromSource src = do digest <- C.connect src sinkMD5Hash return $ digestToBase16 digest where -- To help with type inference - sinkMD5Hash :: Monad m => C.ConduitM ByteString Void m (Digest MD5) + sinkMD5Hash :: (Monad m) => C.ConduitM ByteString Void m (Digest MD5) sinkMD5Hash = sinkHash hmacSHA256 :: ByteString -> ByteString -> HMAC SHA256 @@ -71,15 +71,15 @@ hmacSHA256 message key = hmac key message hmacSHA256RawBS :: ByteString -> ByteString -> ByteString hmacSHA256RawBS message key = convert $ hmacSHA256 message key -digestToBS :: ByteArrayAccess a => a -> ByteString +digestToBS :: (ByteArrayAccess a) => a -> ByteString digestToBS = convert -digestToBase16 :: ByteArrayAccess a => a -> ByteString +digestToBase16 :: (ByteArrayAccess a) => a -> ByteString digestToBase16 = convertToBase Base16 -- Returns MD5 hash base 64 encoded. -hashMD5ToBase64 :: ByteArrayAccess a => a -> ByteString +hashMD5ToBase64 :: (ByteArrayAccess a) => a -> ByteString hashMD5ToBase64 = convertToBase Base64 . hashWith MD5 -encodeToBase64 :: ByteArrayAccess a => a -> ByteString +encodeToBase64 :: (ByteArrayAccess a) => a -> ByteString encodeToBase64 = convertToBase Base64 diff --git a/src/Network/Minio/SelectAPI.hs b/src/Network/Minio/SelectAPI.hs index 01db5e7..621e86c 100644 --- a/src/Network/Minio/SelectAPI.hs +++ b/src/Network/Minio/SelectAPI.hs @@ -119,7 +119,7 @@ instance Exception EventStreamException chunkSize :: Int chunkSize = 32 * 1024 -parseBinary :: Bin.Binary a => ByteString -> IO a +parseBinary :: (Bin.Binary a) => ByteString -> IO a parseBinary b = do case Bin.decodeOrFail $ LB.fromStrict b of Left (_, _, msg) -> throwIO $ ESEDecodeFail msg @@ -135,7 +135,7 @@ bytesToHeaderName t = case t of _ -> throwIO ESEInvalidHeaderType parseHeaders :: - MonadUnliftIO m => + (MonadUnliftIO m) => Word32 -> C.ConduitM ByteString a m [MessageHeader] parseHeaders 0 = return [] @@ -163,7 +163,7 @@ parseHeaders hdrLen = do -- 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 :: (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 @@ -171,7 +171,7 @@ readNBytes n = do else return b crcCheck :: - MonadUnliftIO m => + (MonadUnliftIO m) => C.ConduitM ByteString ByteString m () crcCheck = do b <- readNBytes 12 @@ -208,7 +208,7 @@ crcCheck = do then accumulateYield n' c' else return c' -handleMessage :: MonadUnliftIO m => C.ConduitT ByteString EventMessage m () +handleMessage :: (MonadUnliftIO m) => C.ConduitT ByteString EventMessage m () handleMessage = do b1 <- readNBytes 4 msgLen :: Word32 <- liftIO $ parseBinary b1 @@ -254,7 +254,7 @@ handleMessage = do passThrough $ n - B.length b selectProtoConduit :: - MonadUnliftIO m => + (MonadUnliftIO m) => C.ConduitT ByteString EventMessage m () selectProtoConduit = crcCheck .| handleMessage @@ -281,7 +281,7 @@ selectObjectContent b o r = do return $ NC.responseBody resp .| selectProtoConduit -- | A helper conduit that returns only the record payload bytes. -getPayloadBytes :: MonadIO m => C.ConduitT EventMessage ByteString m () +getPayloadBytes :: (MonadIO m) => C.ConduitT EventMessage ByteString m () getPayloadBytes = do evM <- C.await case evM of diff --git a/src/Network/Minio/Sign/V4.hs b/src/Network/Minio/Sign/V4.hs index f822e44..f306249 100644 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -346,7 +346,7 @@ chunkSizeConstant = 64 * 1024 -- base16Len computes the number of bytes required to represent @n (> 0)@ in -- hexadecimal. -base16Len :: Integral a => a -> Int +base16Len :: (Integral a) => a -> Int base16Len n | n == 0 = 0 | otherwise = 1 + base16Len (n `div` 16) diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index f985ddc..1fcaa84 100644 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -175,7 +175,7 @@ isSuccessStatus sts = in (s >= 200 && s < 300) httpLbs :: - MonadIO m => + (MonadIO m) => NC.Request -> NC.Manager -> m (NC.Response LByteString) @@ -239,7 +239,7 @@ http req mgr = do -- Similar to mapConcurrently but limits the number of threads that -- can run using a quantity semaphore. limitedMapConcurrently :: - MonadUnliftIO m => + (MonadUnliftIO m) => Int -> (t -> m a) -> [t] -> diff --git a/src/Network/Minio/XmlCommon.hs b/src/Network/Minio/XmlCommon.hs index 6c428ce..6892523 100644 --- a/src/Network/Minio/XmlCommon.hs +++ b/src/Network/Minio/XmlCommon.hs @@ -35,7 +35,7 @@ uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g 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 :: (MonadIO m) => Text -> m UTCTime parseS3XMLTime t = maybe (throwIO $ MErrVXmlParse $ "timestamp parse failure: " <> t) return $ iso8601ParseM $ diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index 46e4bcf..ffc2230 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -218,7 +218,7 @@ parseNotification xmldata = do events (Filter $ FilterKey $ FilterRules rules) -parseSelectProgress :: MonadIO m => ByteString -> m Progress +parseSelectProgress :: (MonadIO m) => ByteString -> m Progress parseSelectProgress xmldata = do r <- parseRoot $ LB.fromStrict xmldata let bScanned = T.concat $ r $/ element "BytesScanned" &/ content diff --git a/test/LiveServer.hs b/test/LiveServer.hs index 7f73070..b946da1 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -50,7 +50,7 @@ tests :: TestTree tests = testGroup "Tests" [liveServerUnitTests] -- conduit that generates random binary stream of given length -randomDataSrc :: MonadIO m => Int64 -> C.ConduitM () ByteString m () +randomDataSrc :: (MonadIO m) => Int64 -> C.ConduitM () ByteString m () randomDataSrc = genBS where concatIt bs n = @@ -68,7 +68,7 @@ randomDataSrc = genBS yield $ concatIt byteArr64 oneMiB genBS (s - oneMiB) -mkRandFile :: R.MonadResource m => Int64 -> m FilePath +mkRandFile :: (R.MonadResource m) => Int64 -> m FilePath mkRandFile size = do dir <- liftIO getTemporaryDirectory C.runConduit $ randomDataSrc size C..| CB.sinkTempFile dir "miniohstest.random"