diff --git a/minio-hs.cabal b/minio-hs.cabal index bdc5222..5d7545b 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -55,7 +55,6 @@ library , cryptonite , cryptonite-conduit , data-default - , exceptions , filepath , http-client , http-conduit @@ -137,7 +136,6 @@ test-suite minio-hs-live-server-test , cryptonite-conduit , data-default , directory - , exceptions , filepath , http-client , http-conduit @@ -177,7 +175,6 @@ test-suite minio-hs-test , cryptonite-conduit , data-default , directory - , exceptions , http-client , http-conduit , http-types diff --git a/src/Lib/Prelude.hs b/src/Lib/Prelude.hs index 8f072e6..1831d06 100644 --- a/src/Lib/Prelude.hs +++ b/src/Lib/Prelude.hs @@ -19,14 +19,14 @@ module Lib.Prelude , both ) where -import Protolude as Exports +import Protolude as Exports hiding (catch, catches, + throwIO, try) import Control.Monad.Trans.Maybe as Exports (MaybeT (..), runMaybeT) import Data.Time as Exports (UTCTime (..), diffUTCTime) - -import Control.Monad.Catch as Exports (MonadCatch, MonadThrow, - throwM) +import UnliftIO as Exports (catch, catches, throwIO, + try) -- | Apply a function on both elements of a pair both :: (a -> b) -> (a, a) -> (b, b) diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index aafff60..6bbe297 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -116,7 +116,7 @@ buildRequest ri = do Nothing -> return $ connectHost ci Just r -> if "amazonaws.com" `T.isSuffixOf` connectHost ci then maybe - (throwM $ MErrVRegionNotSupported r) + (throwIO $ MErrVRegionNotSupported r) return (Map.lookup r awsRegionMap) else return $ connectHost ci @@ -192,16 +192,16 @@ isValidBucketName bucket = isIPCheck = and labelAsNums && length labelAsNums == 4 -- Throws exception iff bucket name is invalid according to AWS rules. -checkBucketNameValidity :: MonadThrow m => Bucket -> m () +checkBucketNameValidity :: MonadIO m => Bucket -> m () checkBucketNameValidity bucket = when (not $ isValidBucketName bucket) $ - throwM $ MErrVInvalidBucketName bucket + throwIO $ MErrVInvalidBucketName bucket isValidObjectName :: Object -> Bool isValidObjectName object = T.length object > 0 && B.length (encodeUtf8 object) <= 1024 -checkObjectNameValidity :: MonadThrow m => Object -> m () +checkObjectNameValidity :: MonadIO m => Object -> m () checkObjectNameValidity object = when (not $ isValidObjectName object) $ - throwM $ MErrVInvalidObjectName object + throwIO $ MErrVInvalidObjectName object diff --git a/src/Network/Minio/CopyObject.hs b/src/Network/Minio/CopyObject.hs index 29a2edc..66d0e93 100644 --- a/src/Network/Minio/CopyObject.hs +++ b/src/Network/Minio/CopyObject.hs @@ -47,7 +47,7 @@ copyObjectInternal b' o srcInfo = do when (isJust rangeMay && or [startOffset < 0, endOffset < startOffset, endOffset >= fromIntegral srcSize]) $ - throwM $ MErrVInvalidSrcObjByteRange range + throwIO $ MErrVInvalidSrcObjByteRange range -- 1. If sz > 64MiB (minPartSize) use multipart copy, OR -- 2. If startOffset /= 0 use multipart copy diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 15d6598..ebcfb27 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -20,7 +20,6 @@ module Network.Minio.Data where import Control.Concurrent.MVar (MVar) import qualified Control.Concurrent.MVar as M -import qualified Control.Monad.Catch as MC import Control.Monad.IO.Unlift (MonadUnliftIO, UnliftIO (..), askUnliftIO, withUnliftIO) import Control.Monad.Trans.Resource @@ -38,6 +37,7 @@ import Network.HTTP.Types (ByteRange, Header, Method, Query, import qualified Network.HTTP.Types as HT import Network.Minio.Errors import Text.XML +import qualified UnliftIO as U import Lib.Prelude @@ -102,7 +102,6 @@ getHostAddr ci = toS $ T.concat [ connectHost ci, ":" , Lib.Prelude.show $ connectPort ci ] - -- | Default AWS ConnectInfo. Connects to "us-east-1". Credentials -- should be supplied before use, for e.g.: -- @@ -512,8 +511,6 @@ newtype Minio a = Minio { , Monad , MonadIO , MonadReader MinioConn - , MonadThrow - , MonadCatch , MonadResource ) @@ -544,11 +541,11 @@ runMinio :: ConnectInfo -> Minio a -> IO (Either MinioErr a) runMinio ci m = do conn <- liftIO $ connect ci runResourceT . flip runReaderT conn . unMinio $ - fmap Right m `MC.catches` - [ MC.Handler handlerServiceErr - , MC.Handler handlerHE - , MC.Handler handlerFE - , MC.Handler handlerValidation + fmap Right m `U.catches` + [ U.Handler handlerServiceErr + , U.Handler handlerHE + , U.Handler handlerFE + , U.Handler handlerValidation ] where handlerServiceErr = return . Left . MErrService diff --git a/src/Network/Minio/PresignedOperations.hs b/src/Network/Minio/PresignedOperations.hs index 5ea6da7..21f4715 100644 --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -66,7 +66,7 @@ makePresignedUrl :: UrlExpiry -> HT.Method -> Maybe Bucket -> Maybe Object -> Minio ByteString makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do when (expiry > 7*24*3600 || expiry < 0) $ - throwM $ MErrVInvalidUrlExpiry expiry + throwIO $ MErrVInvalidUrlExpiry expiry ci <- asks mcConnInfo diff --git a/src/Network/Minio/PutObject.hs b/src/Network/Minio/PutObject.hs index 7c9ab2a..5c36a78 100644 --- a/src/Network/Minio/PutObject.hs +++ b/src/Network/Minio/PutObject.hs @@ -70,7 +70,7 @@ putObjectInternal b o opts (ODStream src sizeMay) = do if | size <= 64 * oneMiB -> do bs <- C.runConduit $ src C..| CB.sinkLbs putObjectSingle' b o (pooToHeaders opts) $ LBS.toStrict bs - | size > maxObjectSize -> throwM $ MErrVPutSizeExceeded size + | size > maxObjectSize -> throwIO $ MErrVPutSizeExceeded size | otherwise -> sequentialMultipartUpload b o opts (Just size) src putObjectInternal b o opts (ODFile fp sizeMay) = do @@ -90,9 +90,9 @@ putObjectInternal b o opts (ODFile fp sizeMay) = do -- got file size, so check for single/multipart upload Just size -> - if | size <= 64 * oneMiB -> either throwM return =<< + if | size <= 64 * oneMiB -> either throwIO return =<< withNewHandle fp (\h -> putObjectSingle b o (pooToHeaders opts) h 0 size) - | size > maxObjectSize -> throwM $ MErrVPutSizeExceeded size + | size > maxObjectSize -> throwIO $ MErrVPutSizeExceeded size | isSeekable -> parallelMultipartUpload b o opts fp size | otherwise -> sequentialMultipartUpload b o opts (Just size) $ CB.sourceFile fp @@ -112,7 +112,7 @@ parallelMultipartUpload b o opts filePath size = do (uploadPart uploadId) partSizeInfo -- if there were any errors, rethrow exception. - mapM_ throwM $ lefts uploadedPartsE + mapM_ throwIO $ lefts uploadedPartsE -- if we get here, all parts were successfully uploaded. completeMultipartUpload b o uploadId $ rights uploadedPartsE diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index fef6858..7692dae 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -90,16 +90,16 @@ module Network.Minio.S3API , removeAllBucketNotification ) where -import Control.Monad.Catch (Handler (..), catches) import qualified Data.ByteString as BS import qualified Data.Conduit as C import Data.Default (def) import qualified Data.Text as T - -import Lib.Prelude hiding (catches) import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT import Network.HTTP.Types.Status (status404) +import UnliftIO (Handler (Handler)) + +import Lib.Prelude import Network.Minio.API import Network.Minio.Data @@ -150,7 +150,7 @@ putObjectSingle' bucket object headers bs = do let size = fromIntegral (BS.length bs) -- check length is within single PUT object size. when (size > maxSinglePutObjectSizeBytes) $ - throwM $ MErrVSinglePUTSizeExceeded size + throwIO $ MErrVSinglePUTSizeExceeded size -- content-length header is automatically set by library. resp <- executeRequest $ @@ -164,7 +164,7 @@ putObjectSingle' bucket object headers bs = do let rheaders = NC.responseHeaders resp etag = getETagHeader rheaders maybe - (throwM MErrVETagHeaderNotFound) + (throwIO MErrVETagHeaderNotFound) return etag -- | PUT an object into the service. This function performs a single @@ -174,7 +174,7 @@ putObjectSingle :: Bucket -> Object -> [HT.Header] -> Handle -> Int64 putObjectSingle bucket object headers h offset size = do -- check length is within single PUT object size. when (size > maxSinglePutObjectSizeBytes) $ - throwM $ MErrVSinglePUTSizeExceeded size + throwIO $ MErrVSinglePUTSizeExceeded size -- content-length header is automatically set by library. resp <- executeRequest $ @@ -188,7 +188,7 @@ putObjectSingle bucket object headers h offset size = do let rheaders = NC.responseHeaders resp etag = getETagHeader rheaders maybe - (throwM MErrVETagHeaderNotFound) + (throwIO MErrVETagHeaderNotFound) return etag -- | List objects in a bucket matching prefix up to delimiter, @@ -271,7 +271,7 @@ putObjectPart bucket object uploadId partNumber headers payload = do let rheaders = NC.responseHeaders resp etag = getETagHeader rheaders maybe - (throwM MErrVETagHeaderNotFound) + (throwIO MErrVETagHeaderNotFound) (return . (partNumber, )) etag where params = [ @@ -325,7 +325,7 @@ copyObjectSingle :: Bucket -> Object -> SourceInfo -> [HT.Header] copyObjectSingle bucket object srcInfo headers = do -- validate that srcRange is Nothing for this API. when (isJust $ srcRange srcInfo) $ - throwM MErrVCopyObjSingleNoRangeAccepted + throwIO MErrVCopyObjSingleNoRangeAccepted resp <- executeRequest $ def { riMethod = HT.methodPut , riBucket = Just bucket @@ -414,7 +414,7 @@ headObject bucket object = do size = getContentLength headers metadata = getMetadataMap headers - maybe (throwM MErrVInvalidObjectInfoResponse) return $ + maybe (throwIO MErrVInvalidObjectInfoResponse) return $ ObjectInfo <$> Just object <*> modTime <*> etag <*> size <*> Just metadata @@ -428,14 +428,14 @@ headBucket bucket = headBucketEx `catches` where handleNoSuchBucket :: ServiceErr -> Minio Bool handleNoSuchBucket e | e == NoSuchBucket = return False - | otherwise = throwM e + | otherwise = throwIO e handleStatus404 :: NC.HttpException -> Minio Bool handleStatus404 e@(NC.HttpExceptionRequest _ (NC.StatusCodeException res _)) = if NC.responseStatus res == status404 then return False - else throwM e - handleStatus404 e = throwM e + else throwIO e + handleStatus404 e = throwIO e headBucketEx = do resp <- executeRequest $ def { riMethod = HT.methodHead diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index 5051eb3..c6ee53f 100644 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -16,7 +16,6 @@ module Network.Minio.Utils where -import qualified Control.Monad.Catch as MC import Control.Monad.IO.Unlift (MonadUnliftIO) import qualified Control.Monad.Trans.Resource as R import qualified Data.ByteString as B @@ -36,10 +35,9 @@ import qualified Network.HTTP.Conduit as NC import qualified Network.HTTP.Types as HT import qualified Network.HTTP.Types.Header as Hdr import qualified System.IO as IO +import qualified UnliftIO as U import qualified UnliftIO.Async as A -import qualified UnliftIO.Exception as UEx import qualified UnliftIO.MVar as UM -import qualified UnliftIO.STM as U import Lib.Prelude @@ -47,13 +45,13 @@ import Network.Minio.Data import Network.Minio.Data.ByteString import Network.Minio.XmlParser (parseErrResponse) -allocateReadFile :: (MonadUnliftIO m, R.MonadResource m, MonadCatch m) +allocateReadFile :: (MonadUnliftIO m, R.MonadResource m) => FilePath -> m (R.ReleaseKey, Handle) allocateReadFile fp = do (rk, hdlE) <- R.allocate (openReadFile fp) cleanup - either (\(e :: IOException) -> throwM e) (return . (rk,)) hdlE + either (\(e :: IOException) -> throwIO e) (return . (rk,)) hdlE where - openReadFile f = UEx.try $ IO.openBinaryFile f IO.ReadMode + openReadFile f = U.try $ IO.openBinaryFile f IO.ReadMode cleanup = either (const $ return ()) IO.hClose -- | Queries the file size from the handle. Catches any file operation @@ -80,17 +78,17 @@ isHandleSeekable h = do -- the given action on it. Exceptions of type MError are caught and -- returned - both during file handle allocation and when the action -- is run. -withNewHandle :: (MonadUnliftIO m, R.MonadResource m, MonadCatch m) +withNewHandle :: (MonadUnliftIO m, R.MonadResource m) => FilePath -> (Handle -> m a) -> m (Either IOException a) withNewHandle fp fileAction = do -- opening a handle can throw MError exception. - handleE <- MC.try $ allocateReadFile fp + handleE <- try $ allocateReadFile fp either (return . Left) doAction handleE where doAction (rkey, h) = do -- fileAction may also throw MError exception, so we catch and -- return it. - resE <- MC.try $ fileAction h + resE <- try $ fileAction h R.release rkey return resE @@ -127,19 +125,19 @@ isSuccessStatus :: HT.Status -> Bool isSuccessStatus sts = let s = HT.statusCode sts in (s >= 200 && s < 300) -httpLbs :: (R.MonadThrow m, MonadIO m) +httpLbs :: MonadIO m => NC.Request -> NC.Manager -> m (NC.Response LByteString) httpLbs req mgr = do respE <- liftIO $ tryHttpEx $ NC.httpLbs req mgr - resp <- either throwM return respE + resp <- either throwIO return respE unless (isSuccessStatus $ NC.responseStatus resp) $ case contentTypeMay resp of Just "application/xml" -> do sErr <- parseErrResponse $ NC.responseBody resp - throwM sErr + throwIO sErr - _ -> throwM $ NC.HttpExceptionRequest req $ + _ -> throwIO $ NC.HttpExceptionRequest req $ NC.StatusCodeException (void resp) (show resp) return resp @@ -150,23 +148,22 @@ httpLbs req mgr = do contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp -http :: (MonadUnliftIO m, MonadThrow m, R.MonadResource m) +http :: (MonadUnliftIO m, R.MonadResource m) => NC.Request -> NC.Manager -> m (Response (C.ConduitT () ByteString m ())) http req mgr = do respE <- tryHttpEx $ NC.http req mgr - resp <- either throwM return respE + resp <- either throwIO return respE unless (isSuccessStatus $ NC.responseStatus resp) $ case contentTypeMay resp of Just "application/xml" -> do respBody <- C.connect (NC.responseBody resp) CB.sinkLbs - --respBody <- C.unsealConduitT (NC.responseBody resp) C.$$+- CB.sinkLbs sErr <- parseErrResponse respBody - throwM sErr + throwIO sErr _ -> do content <- LB.toStrict . NC.responseBody <$> NC.lbsResponse resp - throwM $ NC.HttpExceptionRequest req $ + throwIO $ NC.HttpExceptionRequest req $ NC.StatusCodeException (void resp) content @@ -174,8 +171,9 @@ http req mgr = do where tryHttpEx :: (MonadUnliftIO m) => m a -> m (Either NC.HttpException a) - tryHttpEx = UEx.try - contentTypeMay resp = lookupHeader Hdr.hContentType $ NC.responseHeaders resp + tryHttpEx = try + contentTypeMay resp = lookupHeader Hdr.hContentType $ + NC.responseHeaders resp -- Similar to mapConcurrently but limits the number of threads that -- can run using a quantity semaphore. @@ -188,7 +186,7 @@ limitedMapConcurrently count act args = do mapM A.wait threads where wThread t arg = - UEx.bracket_ (waitSem t) (signalSem t) $ act arg + U.bracket_ (waitSem t) (signalSem t) $ act arg -- quantity semaphore implementation using TVar waitSem t = U.atomically $ do diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index 9cbebd4..69332cb 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -28,14 +28,13 @@ module Network.Minio.XmlParser , parseNotification ) where -import Control.Monad.Trans.Resource -import Data.List (zip3, zip4, zip5) -import qualified Data.Text as T -import qualified Data.Map as Map -import Data.Text.Read (decimal) +import Data.List (zip3, zip4, zip5) +import qualified Data.Map as Map +import qualified Data.Text as T +import Data.Text.Read (decimal) import Data.Time import Text.XML -import Text.XML.Cursor hiding (bool) +import Text.XML.Cursor hiding (bool) import Lib.Prelude @@ -55,27 +54,27 @@ uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a, b, c, d, e) -> f uncurry5 f (a, b, c, d, e) = f a b c d e -- | Parse time strings from XML -parseS3XMLTime :: (MonadThrow m) => Text -> m UTCTime -parseS3XMLTime = either (throwM . MErrVXmlParse) return +parseS3XMLTime :: (MonadIO m) => Text -> m UTCTime +parseS3XMLTime = either (throwIO . MErrVXmlParse) return . parseTimeM True defaultTimeLocale s3TimeFormat . T.unpack -parseDecimal :: (MonadThrow m, Integral a) => Text -> m a -parseDecimal numStr = either (throwM . MErrVXmlParse . show) return $ +parseDecimal :: (MonadIO m, Integral a) => Text -> m a +parseDecimal numStr = either (throwIO . MErrVXmlParse . show) return $ fst <$> decimal numStr -parseDecimals :: (MonadThrow m, Integral a) => [Text] -> m [a] +parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a] parseDecimals numStr = forM numStr parseDecimal s3Elem :: Text -> Axis s3Elem = element . s3Name -parseRoot :: (MonadThrow m) => LByteString -> m Cursor -parseRoot = either (throwM . MErrVXmlParse . show) (return . fromDocument) +parseRoot :: (MonadIO m) => LByteString -> m Cursor +parseRoot = either (throwIO . MErrVXmlParse . show) (return . fromDocument) . parseLBS def -- | Parse the response XML of a list buckets call. -parseListBuckets :: (MonadThrow m) => LByteString -> m [BucketInfo] +parseListBuckets :: (MonadIO m) => LByteString -> m [BucketInfo] parseListBuckets xmldata = do r <- parseRoot xmldata let @@ -86,26 +85,26 @@ parseListBuckets xmldata = do return $ zipWith BucketInfo names times -- | Parse the response XML of a location request. -parseLocation :: (MonadThrow m) => LByteString -> m Region +parseLocation :: (MonadIO m) => LByteString -> m Region parseLocation xmldata = do r <- parseRoot xmldata let region = T.concat $ r $/ content return $ bool "us-east-1" region $ region /= "" -- | Parse the response XML of an newMultipartUpload call. -parseNewMultipartUpload :: (MonadThrow m) => LByteString -> m UploadId +parseNewMultipartUpload :: (MonadIO m) => LByteString -> m UploadId parseNewMultipartUpload xmldata = do r <- parseRoot xmldata return $ T.concat $ r $// s3Elem "UploadId" &/ content -- | Parse the response XML of completeMultipartUpload call. -parseCompleteMultipartUploadResponse :: (MonadThrow m) => LByteString -> m ETag +parseCompleteMultipartUploadResponse :: (MonadIO m) => LByteString -> m ETag parseCompleteMultipartUploadResponse xmldata = do r <- parseRoot xmldata return $ T.concat $ r $// s3Elem "ETag" &/ content -- | Parse the response XML of copyObject and copyObjectPart -parseCopyObjectResponse :: (MonadThrow m) => LByteString -> m (ETag, UTCTime) +parseCopyObjectResponse :: (MonadIO m) => LByteString -> m (ETag, UTCTime) parseCopyObjectResponse xmldata = do r <- parseRoot xmldata let @@ -115,7 +114,7 @@ parseCopyObjectResponse xmldata = do return (T.concat $ r $// s3Elem "ETag" &/ content, mtime) -- | Parse the response XML of a list objects v1 call. -parseListObjectsV1Response :: (MonadThrow m) +parseListObjectsV1Response :: (MonadIO m) => LByteString -> m ListObjectsV1Result parseListObjectsV1Response xmldata = do r <- parseRoot xmldata @@ -143,7 +142,7 @@ parseListObjectsV1Response xmldata = do return $ ListObjectsV1Result hasMore nextMarker objects prefixes -- | Parse the response XML of a list objects call. -parseListObjectsResponse :: (MonadThrow m) => LByteString -> m ListObjectsResult +parseListObjectsResponse :: (MonadIO m) => LByteString -> m ListObjectsResult parseListObjectsResponse xmldata = do r <- parseRoot xmldata let @@ -170,7 +169,7 @@ parseListObjectsResponse xmldata = do return $ ListObjectsResult hasMore nextToken objects prefixes -- | Parse the response XML of a list incomplete multipart upload call. -parseListUploadsResponse :: (MonadThrow m) => LByteString -> m ListUploadsResult +parseListUploadsResponse :: (MonadIO m) => LByteString -> m ListUploadsResult parseListUploadsResponse xmldata = do r <- parseRoot xmldata let @@ -189,7 +188,7 @@ parseListUploadsResponse xmldata = do return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes -parseListPartsResponse :: (MonadThrow m) => LByteString -> m ListPartsResult +parseListPartsResponse :: (MonadIO m) => LByteString -> m ListPartsResult parseListPartsResponse xmldata = do r <- parseRoot xmldata let @@ -212,14 +211,14 @@ parseListPartsResponse xmldata = do return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos -parseErrResponse :: (MonadThrow m) => LByteString -> m ServiceErr +parseErrResponse :: (MonadIO m) => LByteString -> m ServiceErr parseErrResponse xmldata = do r <- parseRoot xmldata let code = T.concat $ r $/ element "Code" &/ content message = T.concat $ r $/ element "Message" &/ content return $ toServiceErr code message -parseNotification :: (MonadThrow m) => LByteString -> m Notification +parseNotification :: (MonadIO m) => LByteString -> m Notification parseNotification xmldata = do r <- parseRoot xmldata let qcfg = map node $ r $/ s3Elem "QueueConfiguration" diff --git a/test/LiveServer.hs b/test/LiveServer.hs index f868025..39fc5b9 100644 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -20,7 +20,6 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck as QC import Conduit (replicateC) -import qualified Control.Monad.Catch as MC import qualified Control.Monad.Trans.Resource as R import qualified Data.ByteString as BS import Data.Conduit (yield) @@ -437,7 +436,7 @@ liveServerUnitTests = testGroup "Unit tests against a live server" liftIO $ assertEqual "storageClass did not match" (Just "REDUCED_REDUNDANCY") (Map.lookup "X-Amz-Storage-Class" m') - fpE <- MC.try $ fPutObject bucket object'' inputFile'' def{ + fpE <- try $ fPutObject bucket object'' inputFile'' def{ pooStorageClass = Just "INVALID_STORAGE_CLASS" } case fpE of @@ -571,13 +570,13 @@ basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do " was expected to exist.") step "makeBucket again to check if BucketAlreadyOwnedByYou exception is raised." - mbE <- MC.try $ makeBucket bucket Nothing + mbE <- try $ makeBucket bucket Nothing case mbE of Left exn -> liftIO $ exn @?= BucketAlreadyOwnedByYou _ -> return () step "makeBucket with an invalid bucket name and check for appropriate exception." - invalidMBE <- MC.try $ makeBucket "invalidBucketName" Nothing + invalidMBE <- try $ makeBucket "invalidBucketName" Nothing case invalidMBE of Left exn -> liftIO $ exn @?= MErrVInvalidBucketName "invalidBucketName" _ -> return () @@ -590,7 +589,7 @@ basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do fPutObject bucket "lsb-release" "/etc/lsb-release" def step "fPutObject onto a non-existent bucket and check for NoSuchBucket exception" - fpE <- MC.try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" def + fpE <- try $ fPutObject "nosuchbucket" "lsb-release" "/etc/lsb-release" def case fpE of Left exn -> liftIO $ exn @?= NoSuchBucket _ -> return () @@ -601,7 +600,7 @@ basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do let unmodifiedTime = UTCTime (fromGregorian 2010 11 26) 69857 step "fGetObject an object which is modified now but requesting as un-modified in past, check for exception" - resE <- MC.try $ fGetObject bucket "lsb-release" outFile def{ + resE <- try $ fGetObject bucket "lsb-release" outFile def{ gooIfUnmodifiedSince = (Just unmodifiedTime) } case resE of @@ -609,7 +608,7 @@ basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do _ -> return () step "fGetObject an object with no matching etag, check for exception" - resE1 <- MC.try $ fGetObject bucket "lsb-release" outFile def{ + resE1 <- try $ fGetObject bucket "lsb-release" outFile def{ gooIfMatch = (Just "invalid-etag") } case resE1 of @@ -617,7 +616,7 @@ basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do _ -> return () step "fGetObject an object with no valid range, check for exception" - resE2 <- MC.try $ fGetObject bucket "lsb-release" outFile def{ + resE2 <- try $ fGetObject bucket "lsb-release" outFile def{ gooRange = (Just $ HT.ByteRangeFromTo 100 200) } case resE2 of @@ -630,7 +629,7 @@ basicTests = funTestWithBucket "Basic tests" $ \step bucket -> do } step "fGetObject a non-existent object and check for NoSuchKey exception" - resE3 <- MC.try $ fGetObject bucket "noSuchKey" outFile def + resE3 <- try $ fGetObject bucket "noSuchKey" outFile def case resE3 of Left exn -> liftIO $ exn @?= NoSuchKey _ -> return () @@ -705,7 +704,7 @@ presignedUrlFunTest = funTestWithBucket "presigned Url tests" $ step "HEAD object presigned URL - presignedHeadObjectUrl" headUrl <- presignedHeadObjectUrl bucket obj2 3600 [] - headResp <- do req <- NC.parseRequest $ toS headUrl + headResp <- do let req = NC.parseRequest_ $ toS headUrl NC.httpLbs (req {NC.method = HT.methodHead}) mgr liftIO $ (NC.responseStatus headResp == HT.status200) @? "presigned HEAD failed (presignedHeadObjectUrl)" @@ -731,14 +730,14 @@ presignedUrlFunTest = funTestWithBucket "presigned Url tests" $ mapM_ (removeObject bucket) [obj, obj2] where putR size filePath mgr url = do - req <- NC.parseRequest $ toS url + let req = NC.parseRequest_ $ toS url let req' = req { NC.method = HT.methodPut , NC.requestBody = NC.requestBodySource size $ CB.sourceFile filePath} NC.httpLbs req' mgr getR mgr url = do - req <- NC.parseRequest $ toS url + let req = NC.parseRequest_ $ toS url NC.httpLbs req mgr presignedPostPolicyFunTest :: TestTree @@ -789,12 +788,12 @@ bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $ \step bucket -> do step "bucketPolicy basic test - no policy exception" - resE <- MC.try $ getBucketPolicy bucket + resE <- try $ getBucketPolicy bucket case resE of Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist" _ -> return () - resE' <- MC.try $ setBucketPolicy bucket T.empty + resE' <- try $ setBucketPolicy bucket T.empty case resE' of Left exn -> liftIO $ exn @?= ServiceErr "NoSuchBucketPolicy" "The bucket policy does not exist" _ -> return () @@ -802,7 +801,7 @@ bucketPolicyFunTest = funTestWithBucket "Bucket Policy tests" $ let expectedPolicyJSON = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket\"]},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket/*\"]}]}" step "try a malformed policy, expect error" - resE'' <- MC.try $ setBucketPolicy bucket expectedPolicyJSON + resE'' <- try $ setBucketPolicy bucket expectedPolicyJSON case resE'' of Left exn -> liftIO $ exn @?= ServiceErr "MalformedPolicy" "Policy has invalid resource." _ -> return () diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs index 9f804f5..bb89051 100644 --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -19,16 +19,15 @@ module Network.Minio.XmlParser.Test xmlParserTests ) where -import qualified Control.Monad.Catch as MC -import Data.Time (fromGregorian) +import Data.Default (def) import qualified Data.Map as Map +import Data.Time (fromGregorian) import Test.Tasty import Test.Tasty.HUnit +import UnliftIO (MonadUnliftIO) import Lib.Prelude -import Data.Default (def) - import Network.Minio.Data import Network.Minio.Errors import Network.Minio.XmlParser @@ -46,8 +45,8 @@ xmlParserTests = testGroup "XML Parser Tests" , testCase "Test parseNotification" testParseNotification ] -tryValidationErr :: (MC.MonadCatch m) => m a -> m (Either MErrV a) -tryValidationErr act = MC.try act +tryValidationErr :: (MonadUnliftIO m) => m a -> m (Either MErrV a) +tryValidationErr act = try act assertValidtionErr :: MErrV -> Assertion assertValidtionErr e = assertFailure $ "Failed due to validation error => " ++ show e