diff --git a/CHANGELOG.md b/CHANGELOG.md --- 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/examples/FileUploader.hs b/examples/FileUploader.hs --- 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 @@ -71,5 +70,5 @@ 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 --- 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 @@ main :: IO () main = do res <- - runMinio minioPlayCI $ + runMinio + minioPlayCI getConfig print res diff --git a/examples/GetObject.hs b/examples/GetObject.hs --- a/examples/GetObject.hs +++ b/examples/GetObject.hs @@ -37,5 +37,5 @@ 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 --- 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 --- a/examples/ListIncompleteUploads.hs +++ b/examples/ListIncompleteUploads.hs @@ -34,9 +34,9 @@ -- 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 (liftIO . print) print res {- diff --git a/examples/ListObjects.hs b/examples/ListObjects.hs --- a/examples/ListObjects.hs +++ b/examples/ListObjects.hs @@ -34,9 +34,9 @@ -- 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 (liftIO . print) print res {- diff --git a/examples/PresignedGetObject.hs b/examples/PresignedGetObject.hs --- a/examples/PresignedGetObject.hs +++ b/examples/PresignedGetObject.hs @@ -46,7 +46,7 @@ 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 @@ -77,7 +77,8 @@ 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/PresignedPostPolicy.hs b/examples/PresignedPostPolicy.hs --- a/examples/PresignedPostPolicy.hs +++ b/examples/PresignedPostPolicy.hs @@ -55,7 +55,7 @@ ] case policyE of - Left err -> putStrLn $ show err + Left err -> print err Right policy -> do res <- runMinio minioPlayCI $ do (url, formData) <- presignedPostPolicy policy @@ -73,13 +73,15 @@ ] 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) + 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/PresignedPutObject.hs b/examples/PresignedPutObject.hs --- a/examples/PresignedPutObject.hs +++ b/examples/PresignedPutObject.hs @@ -48,7 +48,8 @@ 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/examples/SelectObject.hs b/examples/SelectObject.hs --- 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 @@ 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 --- 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 @@ main :: IO () main = do res <- - runMinio minioPlayCI $ + runMinio + minioPlayCI getServerInfo print res diff --git a/examples/ServiceSendRestart.hs b/examples/ServiceSendRestart.hs --- 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 --- 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 --- 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 @@ main :: IO () main = do res <- - runMinio minioPlayCI $ + runMinio + minioPlayCI serviceStatus print res diff --git a/minio-hs.cabal b/minio-hs.cabal --- 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 @@ -21,22 +21,53 @@ 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 + , LambdaCase , MultiParamTypeClasses , MultiWayIf - , NoImplicitPrelude , OverloadedStrings , RankNTypes , ScopedTypeVariables - , TypeFamilies , TupleSections + , TypeFamilies + + other-modules: Lib.Prelude , Network.Minio.API , Network.Minio.APICommon @@ -55,9 +86,14 @@ , 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 - , aeson >= 1.2 + , relude >= 0.7 && < 2 + , aeson >= 1.2 && < 3 , base64-bytestring >= 1.0 , binary >= 0.8.5.0 , bytestring >= 0.10 @@ -77,6 +113,7 @@ , http-types >= 0.12 , ini , memory >= 0.14 + , network-uri , raw-strings-qq >= 1 , resourcet >= 1.2 , retry @@ -291,7 +328,3 @@ 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 --- a/src/Lib/Prelude.hs +++ b/src/Lib/Prelude.hs @@ -20,6 +20,7 @@ showBS, toStrictBS, fromStrictBS, + lastMay, ) where @@ -29,14 +30,6 @@ ( UTCTime (..), diffUTCTime, ) -import Protolude as Exports hiding - ( Handler, - catch, - catches, - throwIO, - try, - yield, - ) import UnliftIO as Exports ( Handler, catch, @@ -50,10 +43,13 @@ 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 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -55,6 +55,7 @@ gcsCI, -- * Minio Monad + ---------------- -- | The Minio Monad provides connection-reuse, bucket-location @@ -224,7 +225,6 @@ 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/API.hs b/src/Network/Minio/API.hs --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -19,6 +19,7 @@ S3ReqInfo (..), runMinio, executeRequest, + buildRequest, mkStreamRequest, getLocation, isValidBucketName, @@ -40,6 +41,7 @@ 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 @@ return regionMay +-- | Returns the region to be used for the request. getRegion :: S3ReqInfo -> Minio (Maybe Region) getRegion ri = do ci <- asks mcConnInfo @@ -85,10 +88,10 @@ -- 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 @@ -104,6 +107,42 @@ (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 + then + return $ + if bucketHasPeriods bucket + then pathStyle + else virtualStyle + else return pathStyle + ) + buildRequest :: S3ReqInfo -> Minio NC.Request buildRequest ri = do maybe (return ()) checkBucketNameValidity $ riBucket ri @@ -111,17 +150,15 @@ ci <- asks mcConnInfo - regionMay <- getRegion ri - - regionHost <- maybe (return $ connectHost ci) getRegionHost regionMay + (host, path, regionMay) <- getHostPathRegion ri - 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 @@ 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 @@ (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,40 +194,52 @@ -- 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' + 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 $ - 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 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 @@ -235,8 +286,8 @@ not ( or [ len < 3 || len > 63, - or (map labelCheck labels), - or (map labelCharsCheck labels), + any labelCheck labels, + any labelCharsCheck labels, isIPCheck ] ) @@ -266,9 +317,9 @@ -- 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 + unless (isValidBucketName bucket) $ + throwIO $ + MErrVInvalidBucketName bucket isValidObjectName :: Object -> Bool isValidObjectName object = @@ -276,6 +327,6 @@ checkObjectNameValidity :: MonadIO m => Object -> m () checkObjectNameValidity object = - when (not $ isValidObjectName object) - $ throwIO - $ MErrVInvalidObjectName object + unless (isValidObjectName object) $ + throwIO $ + MErrVInvalidObjectName object diff --git a/src/Network/Minio/APICommon.hs b/src/Network/Minio/APICommon.hs --- a/src/Network/Minio/APICommon.hs +++ b/src/Network/Minio/APICommon.hs @@ -20,6 +20,7 @@ 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 @@ -45,7 +46,7 @@ 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) @@ -70,3 +71,10 @@ 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/AdminAPI.hs b/src/Network/Minio/AdminAPI.hs --- a/src/Network/Minio/AdminAPI.hs +++ b/src/Network/Minio/AdminAPI.hs @@ -16,8 +16,9 @@ module Network.Minio.AdminAPI ( -- * MinIO Admin API - -------------------- + -------------------- + -- | Provides MinIO admin API and related types. It is in -- experimental state. DriveInfo (..), @@ -52,10 +53,7 @@ where import Data.Aeson - ( (.:), - (.:?), - (.=), - FromJSON, + ( FromJSON, ToJSON, Value (Object), eitherDecode, @@ -66,6 +64,9 @@ toJSON, withObject, withText, + (.:), + (.:?), + (.=), ) import qualified Data.Aeson as A import Data.Aeson.Types (typeMismatch) @@ -89,7 +90,7 @@ diEndpoint :: Text, diState :: Text } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON DriveInfo where parseJSON = withObject "DriveInfo" $ \v -> @@ -102,7 +103,7 @@ { scParity :: Int, scData :: Int } - deriving (Eq, Show) + deriving stock (Show, Eq) data ErasureInfo = ErasureInfo { eiOnlineDisks :: Int, @@ -111,7 +112,7 @@ eiReducedRedundancy :: StorageClass, eiSets :: [[DriveInfo]] } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON ErasureInfo where parseJSON = withObject "ErasureInfo" $ \v -> do @@ -131,7 +132,7 @@ data Backend = BackendFS | BackendErasure ErasureInfo - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON Backend where parseJSON = withObject "Backend" $ \v -> do @@ -145,7 +146,7 @@ { csTransferred :: Int64, csReceived :: Int64 } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON ConnStats where parseJSON = withObject "ConnStats" $ \v -> @@ -160,7 +161,7 @@ spRegion :: Text, spSqsArns :: [Text] } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON ServerProps where parseJSON = withObject "SIServer" $ \v -> do @@ -176,7 +177,7 @@ { siUsed :: Int64, siBackend :: Backend } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON StorageInfo where parseJSON = withObject "StorageInfo" $ \v -> @@ -188,7 +189,7 @@ { caCount :: Int64, caAvgDuration :: Text } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON CountNAvgTime where parseJSON = withObject "CountNAvgTime" $ \v -> @@ -208,7 +209,7 @@ hsTotalDeletes :: CountNAvgTime, hsSuccessDeletes :: CountNAvgTime } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON HttpStats where parseJSON = withObject "HttpStats" $ \v -> @@ -230,7 +231,7 @@ sdHttpStats :: HttpStats, sdProps :: ServerProps } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON SIData where parseJSON = withObject "SIData" $ \v -> @@ -245,7 +246,7 @@ siAddr :: Text, siData :: SIData } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON ServerInfo where parseJSON = withObject "ServerInfo" $ \v -> @@ -258,7 +259,7 @@ { svVersion :: Text, svCommitId :: Text } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON ServerVersion where parseJSON = withObject "ServerVersion" $ \v -> @@ -270,7 +271,7 @@ { ssVersion :: ServerVersion, ssUptime :: NominalDiffTime } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON ServiceStatus where parseJSON = withObject "ServiceStatus" $ \v -> do @@ -282,7 +283,7 @@ data ServiceAction = ServiceActionRestart | ServiceActionStop - deriving (Eq, Show) + deriving stock (Show, Eq) instance ToJSON ServiceAction where toJSON a = object ["action" .= serviceActionToText a] @@ -300,7 +301,7 @@ hsrClientAddr :: Text, hsrStartTime :: UTCTime } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON HealStartResp where parseJSON = withObject "HealStartResp" $ \v -> @@ -313,7 +314,7 @@ { hoRecursive :: Bool, hoDryRun :: Bool } - deriving (Eq, Show) + deriving stock (Show, Eq) instance ToJSON HealOpts where toJSON (HealOpts r d) = @@ -332,7 +333,7 @@ | HealItemBucket | HealItemBucketMetadata | HealItemObject - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON HealItemType where parseJSON = withText "HealItemType" $ \v -> case v of @@ -347,7 +348,7 @@ nsErrSet :: Bool, nsErrMessage :: Text } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON NodeSummary where parseJSON = withObject "NodeSummary" $ \v -> @@ -360,7 +361,7 @@ { scrStatus :: Bool, scrNodeSummary :: [NodeSummary] } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON SetConfigResult where parseJSON = withObject "SetConfigResult" $ \v -> @@ -382,7 +383,7 @@ hriBefore :: [DriveInfo], hriAfter :: [DriveInfo] } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON HealResultItem where parseJSON = withObject "HealResultItem" $ \v -> @@ -414,7 +415,7 @@ hsFailureDetail :: Maybe Text, hsItems :: Maybe [HealResultItem] } - deriving (Eq, Show) + deriving stock (Show, Eq) instance FromJSON HealStatus where parseJSON = withObject "HealStatus" $ \v -> @@ -428,12 +429,14 @@ healPath :: Maybe Bucket -> Maybe Text -> ByteString healPath bucket prefix = do - if (isJust bucket) + if isJust bucket then encodeUtf8 $ - "v1/heal/" <> fromMaybe "" bucket <> "/" + "v1/heal/" + <> fromMaybe "" bucket + <> "/" <> fromMaybe "" prefix - else encodeUtf8 $ "v1/heal/" + else encodeUtf8 ("v1/heal/" :: Text) -- | Get server version and uptime. serviceStatus :: Minio ServiceStatus @@ -596,12 +599,11 @@ 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/CopyObject.hs b/src/Network/Minio/CopyObject.hs --- a/src/Network/Minio/CopyObject.hs +++ b/src/Network/Minio/CopyObject.hs @@ -45,11 +45,10 @@ when ( isJust rangeMay - && or - [ startOffset < 0, - endOffset < startOffset, - endOffset >= fromIntegral srcSize - ] + && ( (startOffset < 0) + || (endOffset < startOffset) + || (endOffset >= srcSize) + ) ) $ throwIO $ MErrVInvalidSrcObjByteRange range @@ -69,9 +68,8 @@ -- 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 $ + 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 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 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -22,7 +22,14 @@ 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 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,11 +54,18 @@ ) import qualified Network.HTTP.Types as HT import Network.Minio.Data.Crypto + ( 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 @@ -79,20 +91,20 @@ 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, @@ -110,7 +122,7 @@ connectAutoDiscoverRegion :: Bool, connectDisableTLSCertValidation :: Bool } - deriving (Eq, Show) + deriving stock (Eq, Show) instance IsString ConnectInfo where fromString str = @@ -131,7 +143,7 @@ { 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'. @@ -149,19 +161,21 @@ 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 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 + return $ either (const Nothing) Just credsE -- | This Provider loads `Credentials` from @AWS_ACCESS_KEY_ID@ and -- @AWS_SECRET_ACCESS_KEY@ environment variables. @@ -187,7 +201,7 @@ pMay <- findFirst ps maybe (throwIO MErrVMissingCredentials) - (return . (flip setCreds ci)) + (return . (`setCreds` ci)) pMay -- | setCreds sets the given `Credentials` in the `ConnectInfo`. @@ -220,11 +234,11 @@ getHostAddr :: ConnectInfo -> ByteString getHostAddr ci = - if - | port == 80 || port == 443 -> toUtf8 host - | otherwise -> - toUtf8 $ - T.concat [host, ":", Lib.Prelude.show port] + if port == 80 || port == 443 + then encodeUtf8 host + else + encodeUtf8 $ + T.concat [host, ":", show port] where port = connectPort ci host = connectHost ci @@ -273,16 +287,16 @@ -- | 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. 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 @@ -368,12 +382,12 @@ | 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) @@ -404,7 +418,7 @@ { 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 @@ -422,7 +436,7 @@ lprNextPart :: Maybe Int, lprParts :: [ObjectPartInfo] } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Represents information about an object part in an ongoing -- multipart upload. @@ -432,7 +446,7 @@ opiSize :: Int64, opiModTime :: UTCTime } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Represents result from a listing of incomplete uploads to a -- bucket. @@ -443,7 +457,7 @@ lurUploads :: [(Object, UploadId, UTCTime)], lurCPrefixes :: [Text] } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Represents information about a multipart upload. data UploadInfo = UploadInfo @@ -452,7 +466,7 @@ uiInitTime :: UTCTime, uiSize :: Int64 } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Represents result from a listing of objects in a bucket. data ListObjectsResult = ListObjectsResult @@ -461,7 +475,7 @@ 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 @@ -470,7 +484,7 @@ lorObjects' :: [ObjectInfo], lorCPrefixes' :: [Text] } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Represents information about an object. data ObjectInfo = ObjectInfo @@ -494,7 +508,7 @@ -- 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 @@ -526,7 +540,7 @@ -- given time. srcIfUnmodifiedSince :: Maybe UTCTime } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Provide a default for `SourceInfo` defaultSourceInfo :: SourceInfo @@ -539,7 +553,7 @@ -- | Destination object key dstObject :: Text } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Provide a default for `DestinationInfo` defaultDestinationInfo :: DestinationInfo @@ -573,7 +587,8 @@ gooToHeaders :: GetObjectOptions -> [HT.Header] gooToHeaders goo = - rangeHdr ++ zip names values + rangeHdr + ++ zip names values ++ maybe [] (toPutObjectHeaders . SSEC) (gooSSECKey goo) where names = @@ -616,18 +631,18 @@ | 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 @@ -643,10 +658,10 @@ _ -> Nothing -- | Filter data type - part of notification configuration -data Filter = Filter +newtype Filter = Filter { fFilter :: FilterKey } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | defaultFilter is empty, used to create a notification -- configuration. @@ -654,10 +669,10 @@ defaultFilter = Filter defaultFilterKey -- | FilterKey contains FilterRules, and is part of a Filter. -data FilterKey = FilterKey +newtype FilterKey = FilterKey { fkKey :: FilterRules } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | defaultFilterKey is empty, used to create notification -- configuration. @@ -665,10 +680,10 @@ defaultFilterKey = FilterKey defaultFilterRules -- | FilterRules represents a collection of `FilterRule`s. -data FilterRules = FilterRules +newtype FilterRules = FilterRules { frFilterRules :: [FilterRule] } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | defaultFilterRules is empty, used to create notification -- configuration. @@ -688,7 +703,7 @@ { frName :: Text, frValue :: Text } - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Arn is an alias of Text type Arn = Text @@ -702,7 +717,7 @@ 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 @@ -714,7 +729,7 @@ nTopicConfigurations :: [NotificationConfig], nCloudFunctionConfigurations :: [NotificationConfig] } - deriving (Eq, Show) + deriving stock (Show, Eq) -- | The default notification configuration is empty. defaultNotification :: Notification @@ -733,10 +748,10 @@ 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 @@ -746,7 +761,7 @@ { isCompressionType :: Maybe CompressionType, isFormatInfo :: InputFormatInfo } - deriving (Eq, Show) + deriving stock (Show, Eq) -- | Data type representing the compression setting in a Select -- request. @@ -754,7 +769,7 @@ = CompressionTypeNone | CompressionTypeGzip | CompressionTypeBzip2 - deriving (Eq, Show) + deriving stock (Show, Eq) -- | Data type representing input object format information in a -- Select request. @@ -762,7 +777,7 @@ = InputFormatCSV CSVInputProp | InputFormatJSON JSONInputProp | InputFormatParquet - deriving (Eq, Show) + deriving stock (Show, Eq) -- | defaultCsvInput returns InputSerialization with default CSV -- format, and without any compression setting. @@ -841,20 +856,17 @@ -- | CSVProp represents CSV format properties. It is built up using -- the Monoid instance. -data CSVProp = CSVProp (H.HashMap Text Text) - deriving (Eq, Show) +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 defaultCSVProp :: CSVProp defaultCSVProp = mempty @@ -884,15 +896,15 @@ 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. @@ -909,13 +921,13 @@ -- | Set the CSV format properties in the OutputSerialization. outputCSVFromProps :: CSVProp -> OutputSerialization -outputCSVFromProps p = OutputSerializationCSV p +outputCSVFromProps = OutputSerializationCSV -data JSONInputProp = JSONInputProp {jsonipType :: JSONType} - deriving (Eq, Show) +newtype JSONInputProp = JSONInputProp {jsonipType :: JSONType} + 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 @@ -923,23 +935,24 @@ data OutputSerialization = OutputSerializationJSON JSONOutputProp | OutputSerializationCSV CSVOutputProp - deriving (Eq, Show) + deriving stock (Show, Eq) 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 - deriving (Eq, Show) + deriving stock (Show, Eq) -data JSONOutputProp = JSONOutputProp {jsonopRecordDelimiter :: Maybe Text} - deriving (Eq, Show) +newtype JSONOutputProp = JSONOutputProp {jsonopRecordDelimiter :: Maybe Text} + deriving stock (Show, Eq) -- | Set the output record delimiter for JSON format outputJSONFromRecordDelimiter :: Text -> OutputSerialization @@ -957,7 +970,7 @@ emErrorMessage :: Text } | RecordPayloadEventMessage {emPayloadBytes :: ByteString} - deriving (Eq, Show) + deriving stock (Show, Eq) data MsgHeaderName = MessageType @@ -965,7 +978,7 @@ | ContentType | ErrorCode | ErrorMessage - deriving (Eq, Show) + deriving stock (Show, Eq) msgHeaderValueType :: Word8 msgHeaderValueType = 7 @@ -978,7 +991,7 @@ pBytesProcessed :: Int64, pBytesReturned :: Int64 } - deriving (Eq, Show) + deriving stock (Show, Eq) -- | Represent the stats event returned at the end of the Select -- response. @@ -1016,7 +1029,8 @@ riPayload :: Payload, riPayloadHash :: Maybe ByteString, riRegion :: Maybe Region, - riNeedsLocation :: Bool + riNeedsLocation :: Bool, + riPresignExpirySecs :: Maybe UrlExpiry } defaultS3ReqInfo :: S3ReqInfo @@ -1031,16 +1045,13 @@ Nothing Nothing True + Nothing 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] --- | 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 @@ -1048,7 +1059,7 @@ newtype Minio a = Minio { unMinio :: ReaderT MinioConn (ResourceT IO) a } - deriving + deriving newtype ( Functor, Applicative, Monad, @@ -1072,11 +1083,10 @@ 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 @@ -1086,8 +1096,8 @@ 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 --- a/src/Network/Minio/Data/ByteString.hs +++ b/src/Network/Minio/Data/ByteString.hs @@ -25,9 +25,8 @@ 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 @@ -38,8 +37,10 @@ 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. @@ -64,11 +65,11 @@ || (ch == '-') || (ch == '.') || (ch == '~') = - BB.char7 ch + BB.char7 ch | otherwise = mconcat $ map f $ B.unpack $ encodeUtf8 $ T.singleton ch where f :: Word8 -> BB.Builder f n = BB.char7 '%' <> BB.string7 hexStr where hexStr = map toUpper $ showHex q $ showHex r "" - (q, r) = divMod (fromIntegral n) (16 :: Word8) + (q, r) = divMod n (16 :: Word8) diff --git a/src/Network/Minio/Data/Crypto.hs b/src/Network/Minio/Data/Crypto.hs --- a/src/Network/Minio/Data/Crypto.hs +++ b/src/Network/Minio/Data/Crypto.hs @@ -39,7 +39,6 @@ import Data.ByteArray (ByteArrayAccess, convert) import Data.ByteArray.Encoding (Base (Base16, Base64), convertToBase) import qualified Data.Conduit as C -import Lib.Prelude hashSHA256 :: ByteString -> ByteString hashSHA256 = digestToBase16 . hashWith SHA256 diff --git a/src/Network/Minio/Data/Time.hs b/src/Network/Minio/Data/Time.hs --- a/src/Network/Minio/Data/Time.hs +++ b/src/Network/Minio/Data/Time.hs @@ -21,12 +21,17 @@ awsDateFormatBS, awsParseTime, iso8601TimeFormat, + UrlExpiry, ) where 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/Errors.hs b/src/Network/Minio/Errors.hs --- 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 @@ | MErrVInvalidEncryptionKeyLength | MErrVStreamingBodyUnexpectedEOF | MErrVUnexpectedPayload - deriving (Show, Eq) + deriving stock (Show, Eq) instance Exception MErrV @@ -57,7 +62,7 @@ | NoSuchKey | SelectErr Text Text | ServiceErr Text Text - deriving (Show, Eq) + deriving stock (Show, Eq) instance Exception ServiceErr @@ -75,7 +80,7 @@ | 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 --- a/src/Network/Minio/JsonParser.hs +++ b/src/Network/Minio/JsonParser.hs @@ -20,11 +20,11 @@ where import Data.Aeson - ( (.:), - FromJSON, + ( FromJSON, eitherDecode, parseJSON, withObject, + (.:), ) import qualified Data.Text as T import Lib.Prelude @@ -34,7 +34,7 @@ { 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 --- a/src/Network/Minio/ListOps.hs +++ b/src/Network/Minio/ListOps.hs @@ -19,16 +19,47 @@ 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. @@ -51,10 +82,10 @@ 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 +104,10 @@ 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 +135,23 @@ 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 - ( \((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 --- 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. -- @@ -42,14 +44,21 @@ 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) +{- 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. -- @@ -68,46 +77,26 @@ HT.RequestHeaders -> Minio ByteString makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do - when (expiry > 7 * 24 * 3600 || expiry < 0) - $ throwIO - $ MErrVInvalidUrlExpiry expiry - - ci <- asks mcConnInfo + when (expiry > 7 * 24 * 3600 || expiry < 0) $ + throwIO $ + MErrVInvalidUrlExpiry expiry - 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 $ encodeUtf8 uriString -- | Generate a URL with authentication signature to PUT (upload) an -- object. Any extra headers if passed, are signed, and so they are @@ -189,29 +178,39 @@ = PPCStartsWith Text Text | PPCEquals Text Text | PPCRange Text Int64 Int64 - deriving (Show, Eq) + 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) + 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] +{- ORMOLU_ENABLE -} -- | A PostPolicy is required to perform uploads via browser forms. data PostPolicy = PostPolicy { expiration :: UTCTime, conditions :: [PostPolicyCondition] } - deriving (Show, Eq) + deriving stock (Show, Eq) instance Json.ToJSON PostPolicy where toJSON (PostPolicy e c) = - Json.object $ + Json.object [ "expiration" .= iso8601TimeFormat e, "conditions" .= c ] @@ -224,7 +223,7 @@ | PPEBucketNotSpecified | PPEConditionKeyEmpty | PPERangeInvalid - deriving (Eq, Show) + deriving stock (Show, Eq) -- | Set the bucket name that the upload should use. ppCondBucket :: Bucket -> PostPolicyCondition @@ -265,19 +264,19 @@ 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' @@ -299,10 +298,10 @@ 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" (toS $ awsTimeFormat signTime), + [ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime), PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256", PPCEquals "x-amz-credential" @@ -331,18 +330,23 @@ mkPair (PPCEquals k v) = Just (k, v) mkPair _ = Nothing formFromPolicy = - H.map toUtf8 $ H.fromList $ catMaybes $ - mkPair <$> conditions ppWithCreds + H.map encodeUtf8 $ + H.fromList $ + mapMaybe + 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/PutObject.hs b/src/Network/Minio/PutObject.hs --- a/src/Network/Minio/PutObject.hs +++ b/src/Network/Minio/PutObject.hs @@ -71,13 +71,13 @@ 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 hResE <- withNewHandle fp $ \h -> - liftM2 (,) (isHandleSeekable h) (getFileSize h) + liftA2 (,) (isHandleSeekable h) (getFileSize h) (isSeekable, handleSizeMay) <- either @@ -95,13 +95,13 @@ 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/S3API.hs b/src/Network/Minio/S3API.hs --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -19,10 +19,12 @@ getLocation, -- * Listing buckets + -------------------- getService, -- * Listing objects + -------------------- ListObjectsResult (..), ListObjectsV1Result (..), @@ -33,11 +35,13 @@ headBucket, -- * Retrieving objects + ----------------------- getObject', headObject, -- * Creating buckets and objects + --------------------------------- putBucket, ETag, @@ -47,6 +51,7 @@ copyObjectSingle, -- * Multipart Upload APIs + -------------------------- UploadId, PartTuple, @@ -63,11 +68,13 @@ listIncompleteParts', -- * Deletion APIs + -------------------------- deleteBucket, deleteObject, -- * Presigned Operations + ----------------------------- module Network.Minio.PresignedOperations, @@ -76,6 +83,7 @@ setBucketPolicy, -- * Bucket Notifications + ------------------------- Notification (..), NotificationConfig (..), @@ -123,7 +131,8 @@ let metadataPairs = getMetadata headers userMetadata = getUserMetadataMap metadataPairs metadata = getNonUserMetadataMap metadataPairs - in ObjectInfo <$> Just object + in ObjectInfo + <$> Just object <*> getLastModifiedHeader headers <*> getETagHeader headers <*> getContentLength headers @@ -157,24 +166,26 @@ { 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 +199,9 @@ 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 +233,9 @@ 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 +312,23 @@ -- | 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 @@ -370,7 +381,7 @@ srcInfoToHeaders :: SourceInfo -> [HT.Header] srcInfoToHeaders srcInfo = ( "x-amz-copy-source", - toUtf8 $ + encodeUtf8 $ T.concat [ "/", srcBucket srcInfo, @@ -396,8 +407,7 @@ 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) @@ -477,14 +487,14 @@ -- | 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)] @@ -553,15 +563,16 @@ { 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 @@ 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 @@ -- | 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/SelectAPI.hs b/src/Network/Minio/SelectAPI.hs --- a/src/Network/Minio/SelectAPI.hs +++ b/src/Network/Minio/SelectAPI.hs @@ -111,7 +111,7 @@ | ESEInvalidHeaderType | ESEInvalidHeaderValueType | ESEInvalidMessageType - deriving (Eq, Show) + deriving stock (Eq, Show) instance Exception EventStreamException @@ -186,7 +186,7 @@ -- 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 @@ -219,7 +219,7 @@ 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 @@ -276,7 +276,7 @@ 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 --- a/src/Network/Minio/Sign/V4.hs +++ b/src/Network/Minio/Sign/V4.hs @@ -58,17 +58,17 @@ sv4StringToSign :: ByteString, sv4SigningKey :: ByteString } - deriving (Show) + deriving stock (Show) data SignParams = SignParams { spAccessKey :: Text, spSecretKey :: Text, spTimeStamp :: UTCTime, spRegion :: Maybe Text, - spExpirySecs :: Maybe Int, + 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 @@ let authValue = B.concat [ "AWS4-HMAC-SHA256 Credential=", - toUtf8 accessKey, + encodeUtf8 accessKey, "/", scope, ", SignedHeaders=", @@ -119,8 +119,8 @@ 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", @@ -130,9 +130,9 @@ 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 @@ if isJust expiry then ("X-Amz-Signature", signature) : authQP else - [ (\(x, y) -> (CI.foldedCase x, y)) authHeader, + [ first CI.foldedCase authHeader, datePair, sha256Hdr ] @@ -179,8 +179,8 @@ 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" ] @@ -188,7 +188,7 @@ 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 @@ 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 $ @@ -239,7 +238,7 @@ mkSigningKey ts region !secretKey = hmacSHA256RawBS "aws4_request" . hmacSHA256RawBS "s3" - . hmacSHA256RawBS (toUtf8 region) + . hmacSHA256RawBS (encodeUtf8 region) . hmacSHA256RawBS (awsDateFormatBS ts) $ B.concat ["AWS4", secretKey] @@ -256,7 +255,7 @@ 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 +293,7 @@ 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 +331,7 @@ 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 @@ -365,41 +364,42 @@ -- '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 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -52,7 +52,7 @@ 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 @@ -- | 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 @@ (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 @@ -103,17 +103,17 @@ 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 = 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 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) = @@ -143,7 +143,7 @@ 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 @@ -170,8 +170,9 @@ 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 @@ 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 @@ -233,7 +235,7 @@ 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 @@ -265,9 +267,9 @@ -- 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 @@ -278,7 +280,7 @@ 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 --- a/src/Network/Minio/XmlGenerator.hs +++ b/src/Network/Minio/XmlGenerator.hs @@ -23,9 +23,7 @@ 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 import Text.XML @@ -73,12 +71,13 @@ data XNode = XNode Text [XNode] | XLeaf Text Text - deriving (Eq, Show) + deriving stock (Eq, Show) 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) = @@ -94,7 +93,7 @@ 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,10 @@ ++ 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 @@ -143,14 +143,14 @@ [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 @@ ] 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 . kvElement) (csvPropsList c)) formatNode (InputFormatJSON p) = Element "JSON" @@ -208,17 +208,17 @@ 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 . kvElement) (csvPropsList c)) ] rdElem Nothing = [] rdElem (Just t) = diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -32,7 +32,7 @@ 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 @@ -56,9 +56,9 @@ -- | 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 = @@ -132,7 +132,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ -235,9 +235,10 @@ qcfg = map node $ r $/ s3Elem' "QueueConfiguration" tcfg = map node $ r $/ s3Elem' "TopicConfiguration" lcfg = map node $ r $/ s3Elem' "CloudFunctionConfiguration" - Notification <$> (mapM (parseNode ns "Queue") qcfg) - <*> (mapM (parseNode ns "Topic") tcfg) - <*> (mapM (parseNode ns "CloudFunction") lcfg) + Notification + <$> 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 @@ -245,15 +246,18 @@ 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 + events = mapMaybe 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 - id + itemId arn events (Filter $ FilterKey $ FilterRules rules) @@ -264,6 +268,7 @@ 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/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: lts-16.0 +resolver: lts-19.7 # User packages to be built. # Various formats can be used as shown in the example below. @@ -39,9 +39,7 @@ - '.' # 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/test/LiveServer.hs b/test/LiveServer.hs --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -34,11 +34,10 @@ import Network.Minio import Network.Minio.Data import Network.Minio.Data.Crypto -import Network.Minio.PutObject import Network.Minio.S3API import Network.Minio.Utils import System.Directory (getTemporaryDirectory) -import System.Environment (lookupEnv) +import qualified System.Environment as Env import qualified Test.QuickCheck as Q import Test.Tasty import Test.Tasty.HUnit @@ -53,7 +52,7 @@ -- 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 $ @@ -80,8 +79,8 @@ 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" @@ -134,12 +133,13 @@ \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 @@ -180,7 +180,7 @@ "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 @@ "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 @@ "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 @@ "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 @@ 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 @@ 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 @@ 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 @@ \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 $ @@ -361,8 +359,9 @@ 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 @@ -375,8 +374,9 @@ 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 <- @@ -433,7 +433,7 @@ 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 <- @@ -495,7 +495,7 @@ map ( T.concat . ("test-file-" :) - . (\x -> [x]) + . (: []) . T.pack . show ) @@ -514,7 +514,7 @@ 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 <- @@ -525,7 +525,7 @@ Nothing Nothing Nothing - liftIO $ (length $ lurUploads incompleteUploads) @?= 10 + liftIO $ length (lurUploads incompleteUploads) @?= 10 step "cleanup" forM_ (lurUploads incompleteUploads) $ @@ -536,7 +536,7 @@ 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 @@ -546,7 +546,7 @@ 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 @@ -615,7 +615,7 @@ 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) @@ -643,7 +643,7 @@ 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, @@ -653,14 +653,14 @@ } 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 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 = @@ -689,9 +689,9 @@ 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) $ + map (uncurry Form.partBS) $ H.toList formData parts' = parts ++ [Form.partFile "file" inputFile] req' <- Form.formDataBody parts' req @@ -738,17 +738,17 @@ [ 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 - Right s -> liftIO $ s @?= (BS.concat $ replicate 100 "c") + Right s -> liftIO $ s @?= BS.concat (replicate 100 "c") deleteObject bucket obj @@ -803,7 +803,7 @@ 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" $ @@ -910,8 +910,9 @@ 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 (bimap T.toLower T.toLower) $ + H.toList m ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")] liftIO $ (sortedMeta == ref) @? "Metadata mismatch!" @@ -944,8 +945,9 @@ 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 (bimap T.toLower T.toLower) $ + H.toList m ref = sort [("mykey1", "myval1"), ("mykey2", "myval2")] liftIO $ (sortedMeta == ref) @? "Metadata mismatch!" @@ -1073,7 +1075,7 @@ 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/Network/Minio/API/Test.hs b/test/Network/Minio/API/Test.hs --- a/test/Network/Minio/API/Test.hs +++ b/test/Network/Minio/API/Test.hs @@ -24,7 +24,6 @@ where import Data.Aeson (eitherDecode) -import Lib.Prelude import Network.Minio.API import Network.Minio.AdminAPI import Test.Tasty @@ -63,8 +62,9 @@ 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 +82,9 @@ 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 +102,9 @@ 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 --- a/test/Network/Minio/JsonParser/Test.hs +++ b/test/Network/Minio/JsonParser/Test.hs @@ -34,7 +34,7 @@ ] 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 @@ -43,9 +43,9 @@ 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/TestHelpers.hs b/test/Network/Minio/TestHelpers.hs --- a/test/Network/Minio/TestHelpers.hs +++ b/test/Network/Minio/TestHelpers.hs @@ -19,7 +19,6 @@ ) 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 --- a/test/Network/Minio/Utils/Test.hs +++ b/test/Network/Minio/Utils/Test.hs @@ -19,7 +19,6 @@ ) where -import Lib.Prelude import Network.Minio.Utils import Test.Tasty import Test.Tasty.HUnit diff --git a/test/Network/Minio/XmlGenerator/Test.hs b/test/Network/Minio/XmlGenerator/Test.hs --- a/test/Network/Minio/XmlGenerator/Test.hs +++ b/test/Network/Minio/XmlGenerator/Test.hs @@ -90,11 +90,12 @@ "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 @@ <> 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|] ) ] diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -49,7 +49,7 @@ ] 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 @@ -62,9 +62,9 @@ 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 @@ "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 "" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -55,31 +55,33 @@ \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 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 (> 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) $ + listToMaybe sizes | otherwise -> False in n < 0 - || ( isPNumsAscendingFrom1 && isOffsetsAsc && isSumSizeOk + || ( isPNumsAscendingFrom1 + && isOffsetsAsc + && isSumSizeOk && isSizesConstantExceptLast && isMinPartSizeOk ), @@ -89,23 +91,24 @@ -- 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 isContParts = length fsts == length snds - && and (map (\(a, b) -> a == b + 1) $ zip fsts snds) - in start < 0 || start > end + && all (\(a, b) -> a == b + 1) (zip fsts snds) + in start < 0 + || start > end || (isLastPartOk && isFirstPartOk && isPartSizesOk && isContParts), QC.testProperty "mkSSECKey:" $ \w8s ->