haskell/minio-hs
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Drop dependency on exceptions lib (#87)

Browse Source
This commit is contained in:
Aditya Manthramurthy 2018-05-13 18:18:07 -07:00 committed by Krishnan Parthasarathi
parent 522d49452f
commit d25c7ef1dc
12 changed files with 95 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
minio-hs.cabal
View File

@ -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

8
src/Lib/Prelude.hs
View File

@ -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)

10
src/Network/Minio/API.hs
View File

@ -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

2
src/Network/Minio/CopyObject.hs
View File

@ -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

15
src/Network/Minio/Data.hs
View File

@ -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

2
src/Network/Minio/PresignedOperations.hs
View File

@ -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

8
src/Network/Minio/PutObject.hs
View File

@ -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

26
src/Network/Minio/S3API.hs
View File

@ -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

40
src/Network/Minio/Utils.hs
View File

@ -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

47
src/Network/Minio/XmlParser.hs
View File

@ -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"

29
test/LiveServer.hs
View File

@ -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 ()

11
test/Network/Minio/XmlParser/Test.hs
View File

@ -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