minio-hs 1.5.3 → 1.6.0
raw patch · 46 files changed
+841/−659 lines, 46 filesdep +network-uridep +reludedep −protoludedep ~aeson
Dependencies added: network-uri, relude
Dependencies removed: protolude
Dependency ranges changed: aeson
Files
- CHANGELOG.md +9/−0
- examples/FileUploader.hs +1/−2
- examples/GetConfig.hs +2/−2
- examples/GetObject.hs +1/−1
- examples/Heal.hs +0/−1
- examples/ListIncompleteUploads.hs +3/−3
- examples/ListObjects.hs +3/−3
- examples/PresignedGetObject.hs +3/−2
- examples/PresignedPostPolicy.hs +7/−5
- examples/PresignedPutObject.hs +2/−1
- examples/SelectObject.hs +2/−2
- examples/ServerInfo.hs +2/−2
- examples/ServiceSendRestart.hs +0/−1
- examples/ServiceSendStop.hs +0/−1
- examples/ServiceStatus.hs +2/−2
- minio-hs.cabal +42/−9
- src/Lib/Prelude.hs +5/−9
- src/Network/Minio.hs +1/−1
- src/Network/Minio/API.hs +97/−46
- src/Network/Minio/APICommon.hs +9/−1
- src/Network/Minio/AdminAPI.hs +37/−35
- src/Network/Minio/CopyObject.hs +7/−9
- src/Network/Minio/Data.hs +125/−115
- src/Network/Minio/Data/ByteString.hs +7/−6
- src/Network/Minio/Data/Crypto.hs +0/−1
- src/Network/Minio/Data/Time.hs +5/−0
- src/Network/Minio/Errors.hs +11/−6
- src/Network/Minio/JsonParser.hs +3/−3
- src/Network/Minio/ListOps.hs +56/−21
- src/Network/Minio/PresignedOperations.hs +60/−56
- src/Network/Minio/PutObject.hs +7/−7
- src/Network/Minio/S3API.hs +87/−73
- src/Network/Minio/SelectAPI.hs +4/−4
- src/Network/Minio/Sign/V4.hs +51/−51
- src/Network/Minio/Utils.hs +21/−19
- src/Network/Minio/XmlGenerator.hs +21/−21
- src/Network/Minio/XmlParser.hs +23/−18
- stack.yaml +2/−4
- test/LiveServer.hs +54/−52
- test/Network/Minio/API/Test.hs +9/−7
- test/Network/Minio/JsonParser/Test.hs +4/−4
- test/Network/Minio/TestHelpers.hs +0/−1
- test/Network/Minio/Utils/Test.hs +0/−1
- test/Network/Minio/XmlGenerator/Test.hs +29/−28
- test/Network/Minio/XmlParser/Test.hs +10/−9
- test/Spec.hs +17/−14
CHANGELOG.md view
@@ -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
examples/FileUploader.hs view
@@ -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."
examples/GetConfig.hs view
@@ -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
examples/GetObject.hs view
@@ -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."
examples/Heal.hs view
@@ -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
examples/ListIncompleteUploads.hs view
@@ -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 {-
examples/ListObjects.hs view
@@ -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 {-
examples/PresignedGetObject.hs view
@@ -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 $
examples/PresignedPostPolicy.hs view
@@ -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
examples/PresignedPutObject.hs view
@@ -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 $
examples/SelectObject.hs view
@@ -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"
examples/ServerInfo.hs view
@@ -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
examples/ServiceSendRestart.hs view
@@ -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
examples/ServiceSendStop.hs view
@@ -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
examples/ServiceStatus.hs view
@@ -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
minio-hs.cabal view
@@ -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
src/Lib/Prelude.hs view
@@ -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
src/Network/Minio.hs view
@@ -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
src/Network/Minio/API.hs view
@@ -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
src/Network/Minio/APICommon.hs view
@@ -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
src/Network/Minio/AdminAPI.hs view
@@ -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
src/Network/Minio/CopyObject.hs view
@@ -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
src/Network/Minio/Data.hs view
@@ -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
src/Network/Minio/Data/ByteString.hs view
@@ -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)
src/Network/Minio/Data/Crypto.hs view
@@ -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
src/Network/Minio/Data/Time.hs view
@@ -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"
src/Network/Minio/Errors.hs view
@@ -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
src/Network/Minio/JsonParser.hs view
@@ -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 ->
src/Network/Minio/ListOps.hs view
@@ -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)
src/Network/Minio/PresignedOperations.hs view
@@ -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)
src/Network/Minio/PutObject.hs view
@@ -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 ->
src/Network/Minio/S3API.hs view
@@ -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)]+ }
src/Network/Minio/SelectAPI.hs view
@@ -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
src/Network/Minio/Sign/V4.hs view
@@ -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,
src/Network/Minio/Utils.hs view
@@ -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)]
src/Network/Minio/XmlGenerator.hs view
@@ -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) =
src/Network/Minio/XmlParser.hs view
@@ -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
stack.yaml view
@@ -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: {}
test/LiveServer.hs view
@@ -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)
test/Network/Minio/API/Test.hs view
@@ -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
test/Network/Minio/JsonParser/Test.hs view
@@ -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
test/Network/Minio/TestHelpers.hs view
@@ -19,7 +19,6 @@ ) where -import Lib.Prelude import Network.Minio.Data newtype TestNS = TestNS {testNamespace :: Text}
test/Network/Minio/Utils/Test.hs view
@@ -19,7 +19,6 @@ ) where -import Lib.Prelude import Network.Minio.Utils import Test.Tasty import Test.Tasty.HUnit
test/Network/Minio/XmlGenerator/Test.hs view
@@ -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|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>GZIP</CompressionType><CSV><QuoteCharacter>"</QuoteCharacter><RecordDelimiter>-</RecordDelimiter><FileHeaderInfo>IGNORE</FileHeaderInfo><QuoteEscapeCharacter>"</QuoteEscapeCharacter><FieldDelimiter>,</FieldDelimiter></CSV></InputSerialization><OutputSerialization><CSV><QuoteCharacter>"</QuoteCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter>-</RecordDelimiter><QuoteEscapeCharacter>"</QuoteEscapeCharacter><FieldDelimiter>,</FieldDelimiter></CSV></OutputSerialization><RequestProgress><Enabled>FALSE</Enabled></RequestProgress></SelectRequest>|]+ [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>GZIP</CompressionType><CSV><FieldDelimiter>,</FieldDelimiter><FileHeaderInfo>IGNORE</FileHeaderInfo><QuoteCharacter>"</QuoteCharacter><QuoteEscapeCharacter>"</QuoteEscapeCharacter><RecordDelimiter>+</RecordDelimiter></CSV></InputSerialization><OutputSerialization><CSV><FieldDelimiter>,</FieldDelimiter><QuoteCharacter>"</QuoteCharacter><QuoteEscapeCharacter>"</QuoteEscapeCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter>+</RecordDelimiter></CSV></OutputSerialization><RequestProgress><Enabled>FALSE</Enabled></RequestProgress></SelectRequest>|] ),- ( setRequestProgressEnabled False- $ setInputCompressionType CompressionTypeGzip- $ selectRequest- "Select * from S3Object"- documentJsonInput- (outputJSONFromRecordDelimiter "\n"),+ ( setRequestProgressEnabled False $+ setInputCompressionType CompressionTypeGzip $+ selectRequest+ "Select * from S3Object"+ documentJsonInput+ (outputJSONFromRecordDelimiter "\n"), [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>GZIP</CompressionType><JSON><Type>DOCUMENT</Type></JSON></InputSerialization><OutputSerialization><JSON><RecordDelimiter> </RecordDelimiter></JSON></OutputSerialization><RequestProgress><Enabled>FALSE</Enabled></RequestProgress></SelectRequest>|] ),- ( setRequestProgressEnabled False- $ setInputCompressionType CompressionTypeNone- $ selectRequest- "Select * from S3Object"- defaultParquetInput- ( outputCSVFromProps $- quoteFields QuoteFieldsAsNeeded- <> recordDelimiter "\n"- <> fieldDelimiter ","- <> quoteCharacter "\""- <> quoteEscapeCharacter "\""- ),- [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>NONE</CompressionType><Parquet/></InputSerialization><OutputSerialization><CSV><QuoteCharacter>"</QuoteCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter>-</RecordDelimiter><QuoteEscapeCharacter>"</QuoteEscapeCharacter><FieldDelimiter>,</FieldDelimiter></CSV></OutputSerialization><RequestProgress><Enabled>FALSE</Enabled></RequestProgress></SelectRequest>|]+ ( setRequestProgressEnabled False $+ setInputCompressionType CompressionTypeNone $+ selectRequest+ "Select * from S3Object"+ defaultParquetInput+ ( outputCSVFromProps $+ quoteFields QuoteFieldsAsNeeded+ <> recordDelimiter "\n"+ <> fieldDelimiter ","+ <> quoteCharacter "\""+ <> quoteEscapeCharacter "\""+ ),+ [r|<?xml version="1.0" encoding="UTF-8"?><SelectRequest><Expression>Select * from S3Object</Expression><ExpressionType>SQL</ExpressionType><InputSerialization><CompressionType>NONE</CompressionType><Parquet/></InputSerialization><OutputSerialization><CSV><FieldDelimiter>,</FieldDelimiter><QuoteCharacter>"</QuoteCharacter><QuoteEscapeCharacter>"</QuoteEscapeCharacter><QuoteFields>ASNEEDED</QuoteFields><RecordDelimiter>+</RecordDelimiter></CSV></OutputSerialization><RequestProgress><Enabled>FALSE</Enabled></RequestProgress></SelectRequest>|] ) ]
test/Network/Minio/XmlParser/Test.hs view
@@ -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 ""
test/Spec.hs view
@@ -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 ->