diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,14 @@ Changelog ========== +## Version 1.0.1 + +This version brings the following (non-breaking) changes: + +* Remove dependency on text-format (#86) +* Remove direct dependency on exceptions (#87) +* Adds lower-bounds on dependencies. + ## Version 1.0.0 This new release changes the following APIs to add new capabilities: diff --git a/minio-hs.cabal b/minio-hs.cabal --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -1,5 +1,5 @@ name: minio-hs -version: 1.0.0 +version: 1.0.1 synopsis: A Minio Haskell Library for Amazon S3 compatible cloud storage. description: The Minio Haskell client library provides simple APIs to @@ -44,31 +44,29 @@ , Network.Minio.XmlGenerator , Network.Minio.XmlParser build-depends: base >= 4.7 && < 5 - , protolude >= 0.1.6 - , aeson - , base64-bytestring - , bytestring - , case-insensitive - , conduit - , conduit-extra - , containers - , cryptonite - , cryptonite-conduit - , data-default - , exceptions - , filepath - , http-client - , http-conduit - , http-types - , memory - , resourcet - , text - , text-format - , time - , transformers - , unliftio - , unliftio-core - , xml-conduit + , protolude >= 0.2 && < 0.3 + , aeson >= 1.2 + , base64-bytestring >= 1.0 + , bytestring >= 0.10 + , case-insensitive >= 1.2 + , conduit >= 1.3 + , conduit-extra >= 1.3 + , containers >= 0.5 + , cryptonite >= 0.25 + , cryptonite-conduit >= 0.2 + , data-default >= 0.7 + , filepath >= 1.4 + , http-client >= 0.5 + , http-conduit >= 2.3 + , http-types >= 0.12 + , memory >= 0.14 + , resourcet >= 1.2 + , text >= 1.2 + , time >= 1.8 + , transformers >= 0.5 + , unliftio >= 0.2 + , unliftio-core >= 0.1 + , xml-conduit >= 1.8 default-language: Haskell2010 default-extensions: BangPatterns , FlexibleContexts @@ -138,7 +136,6 @@ , cryptonite-conduit , data-default , directory - , exceptions , filepath , http-client , http-conduit @@ -152,7 +149,6 @@ , tasty-smallcheck , temporary , text - , text-format , time , transformers , unliftio @@ -179,7 +175,6 @@ , cryptonite-conduit , data-default , directory - , exceptions , http-client , http-conduit , http-types @@ -192,7 +187,6 @@ , tasty-smallcheck , temporary , text - , text-format , time , transformers , unliftio diff --git a/src/Lib/Prelude.hs b/src/Lib/Prelude.hs --- a/src/Lib/Prelude.hs +++ b/src/Lib/Prelude.hs @@ -17,29 +17,16 @@ module Lib.Prelude ( module Exports , both - - , format - , formatBS ) where -import Protolude as Exports - -import Data.Time as Exports (UTCTime(..), diffUTCTime) -import Control.Monad.Trans.Maybe as Exports (runMaybeT, MaybeT(..)) - -import Control.Monad.Catch as Exports (throwM, MonadThrow, MonadCatch) - -import Data.Text.Format as Exports (Shown(..)) -import qualified Data.Text.Format as TF -import Data.Text.Format.Params (Params) - -format :: Params ps => TF.Format -> ps -> Text -format f args = toS $ TF.format f args - -formatBS :: Params ps => TF.Format -> ps -> ByteString -formatBS f args = toS $ TF.format f args +import Protolude as Exports hiding (catch, catches, + throwIO, try) --- import Data.Tuple as Exports (uncurry) +import Control.Monad.Trans.Maybe as Exports (MaybeT (..), runMaybeT) +import Data.Time as Exports (UTCTime (..), + diffUTCTime) +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 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -28,18 +28,18 @@ , checkObjectNameValidity ) where -import qualified Data.Conduit as C -import Data.Conduit.Binary (sourceHandleRange) -import Data.Default (def) -import qualified Data.Map as Map -import qualified Data.Char as C -import qualified Data.Text as T -import qualified Data.ByteString as B +import qualified Data.ByteString as B +import qualified Data.Char as C +import qualified Data.Conduit as C +import Data.Conduit.Binary (sourceHandleRange) +import Data.Default (def) +import qualified Data.Map as Map +import qualified Data.Text as T -import Network.HTTP.Conduit (Response) -import qualified Network.HTTP.Conduit as NC -import qualified Network.HTTP.Types as HT -import Network.HTTP.Types.Header (hHost) +import Network.HTTP.Conduit (Response) +import qualified Network.HTTP.Conduit as NC +import qualified Network.HTTP.Types as HT +import Network.HTTP.Types.Header (hHost) import Lib.Prelude @@ -116,7 +116,7 @@ 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 @@ -128,9 +128,7 @@ -- otherwise compute sha256 | otherwise -> getPayloadSHA256Hash (riPayload ri) - let hostHeader = (hHost, formatBS "{}:{}" [connectHost ci, - show $ connectPort ci]) - + let hostHeader = (hHost, getHostAddr ci) newRi = ri { riPayloadHash = Just sha256Hash , riHeaders = hostHeader : sha256Header sha256Hash @@ -194,16 +192,16 @@ 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 --- a/src/Network/Minio/CopyObject.hs +++ b/src/Network/Minio/CopyObject.hs @@ -47,7 +47,7 @@ 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 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -20,17 +20,16 @@ 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 - import qualified Data.ByteString as B import Data.CaseInsensitive (mk) import Data.Default (Default (..)) import qualified Data.Map as Map import qualified Data.Text as T import Data.Time (defaultTimeLocale, formatTime) +import GHC.Show (Show (show)) import Network.HTTP.Client (defaultManagerSettings) import qualified Network.HTTP.Conduit as NC import Network.HTTP.Types (ByteRange, Header, Method, Query, @@ -38,8 +37,7 @@ import qualified Network.HTTP.Types as HT import Network.Minio.Errors import Text.XML - -import GHC.Show (Show (..)) +import qualified UnliftIO as U import Lib.Prelude @@ -99,6 +97,11 @@ instance Default ConnectInfo where def = ConnectInfo "localhost" 9000 "minio" "minio123" False "us-east-1" True +getHostAddr :: ConnectInfo -> ByteString +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.: -- @@ -508,8 +511,6 @@ , Monad , MonadIO , MonadReader MinioConn - , MonadThrow - , MonadCatch , MonadResource ) @@ -540,11 +541,11 @@ 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 --- a/src/Network/Minio/PresignedOperations.hs +++ b/src/Network/Minio/PresignedOperations.hs @@ -66,13 +66,12 @@ -> 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 let - host = formatBS "{}:{}" (connectHost ci, connectPort ci) - hostHeader = (hHost, host) + hostHeader = (hHost, getHostAddr ci) ri = def { riMethod = method , riBucket = bucket , riObject = object @@ -89,7 +88,8 @@ scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci return $ toS $ toLazyByteString $ - scheme <> byteString host <> byteString (getPathFromRI ri) <> queryStr + scheme <> byteString (getHostAddr ci) <> byteString (getPathFromRI ri) <> + queryStr -- | Generate a URL with authentication signature to PUT (upload) an -- object. Any extra headers if passed, are signed, and so they are @@ -272,10 +272,9 @@ -- compute POST upload URL bucket = Map.findWithDefault "" "bucket" formData scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci - host = formatBS "{}:{}" (connectHost ci, connectPort ci) region = connectRegion ci - url = toS $ toLazyByteString $ scheme <> byteString host <> + url = toS $ toLazyByteString $ scheme <> byteString (getHostAddr ci) <> byteString "/" <> byteString (toS bucket) <> byteString "/" return (url, formData) diff --git a/src/Network/Minio/PutObject.hs b/src/Network/Minio/PutObject.hs --- a/src/Network/Minio/PutObject.hs +++ b/src/Network/Minio/PutObject.hs @@ -70,7 +70,7 @@ 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 @@ -- 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 @@ (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 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -90,17 +90,17 @@ , 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 import Network.Minio.Errors @@ -150,7 +150,7 @@ 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 @@ 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 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 @@ 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 @@ let rheaders = NC.responseHeaders resp etag = getETagHeader rheaders maybe - (throwM MErrVETagHeaderNotFound) + (throwIO MErrVETagHeaderNotFound) (return . (partNumber, )) etag where params = [ @@ -280,8 +280,10 @@ ] srcInfoToHeaders :: SourceInfo -> [HT.Header] -srcInfoToHeaders srcInfo = ("x-amz-copy-source", encodeUtf8 $ format "/{}/{}" [srcBucket srcInfo, srcObject srcInfo]) : - rangeHdr ++ zip names values +srcInfoToHeaders srcInfo = ("x-amz-copy-source", + toS $ T.concat ["/", srcBucket srcInfo, + "/", srcObject srcInfo] + ) : rangeHdr ++ zip names values where names = ["x-amz-copy-source-if-match", "x-amz-copy-source-if-none-match", "x-amz-copy-source-if-unmodified-since", @@ -323,7 +325,7 @@ 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 @@ -412,7 +414,7 @@ size = getContentLength headers metadata = getMetadataMap headers - maybe (throwM MErrVInvalidObjectInfoResponse) return $ + maybe (throwIO MErrVInvalidObjectInfoResponse) return $ ObjectInfo <$> Just object <*> modTime <*> etag <*> size <*> Just metadata @@ -426,14 +428,14 @@ 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 --- 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.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.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 @@ -- 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 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 @@ 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 @@ 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 @@ 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 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -28,14 +28,13 @@ , 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 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 --- a/test/LiveServer.hs +++ b/test/LiveServer.hs @@ -19,7 +19,7 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck as QC -import qualified Control.Monad.Catch as MC +import Conduit (replicateC) import qualified Control.Monad.Trans.Resource as R import qualified Data.ByteString as BS import Data.Conduit (yield) @@ -436,7 +436,7 @@ 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 @@ -570,13 +570,13 @@ " 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 () @@ -589,7 +589,7 @@ 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 () @@ -600,7 +600,7 @@ 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 @@ -608,7 +608,7 @@ _ -> 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 @@ -616,7 +616,7 @@ _ -> 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 @@ -629,7 +629,7 @@ } 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 () @@ -704,7 +704,7 @@ 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)" @@ -730,14 +730,14 @@ 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 @@ -788,32 +788,46 @@ \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 () - let expectedPolicyJSON = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket\"],\"Sid\":\"\"},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::testbucket/*\"],\"Sid\":\"\"}]}" + 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 () - let expectedPolicyJSON' = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "\"],\"Sid\":\"\"},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "/*\"],\"Sid\":\"\"}]}" + let expectedPolicyJSON' = "{\"Version\":\"2012-10-17\",\"Statement\":[{\"Action\":[\"s3:GetBucketLocation\",\"s3:ListBucket\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "\"]},{\"Action\":[\"s3:GetObject\"],\"Effect\":\"Allow\",\"Principal\":{\"AWS\":[\"*\"]},\"Resource\":[\"arn:aws:s3:::" <> bucket <> "/*\"]}]}" step "set bucket policy" setBucketPolicy bucket expectedPolicyJSON' - step "verify if bucket policy was properly set" - policyJSON <- getBucketPolicy bucket - liftIO $ policyJSON @?= expectedPolicyJSON' + let obj = "myobject" + + step "verify bucket policy: (1) create `myobject`" + putObject bucket obj (replicateC 100 "c") Nothing def + + step "verify bucket policy: (2) get `myobject` anonymously" + connInfo <- asks mcConnInfo + let proto = bool "http://" "https://" $ connectIsSecure connInfo + url = BS.concat [proto, getHostAddr connInfo, "/", toS bucket, + "/", toS obj] + respE <- liftIO $ (fmap (Right . toS) $ NC.simpleHttp $ toS 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") + + deleteObject bucket obj step "delete bucket policy" setBucketPolicy bucket T.empty diff --git a/test/Network/Minio/API/Test.hs b/test/Network/Minio/API/Test.hs --- a/test/Network/Minio/API/Test.hs +++ b/test/Network/Minio/API/Test.hs @@ -19,13 +19,14 @@ , objectNameValidityTests ) where -import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty +import Test.Tasty.HUnit -import Lib.Prelude +import Lib.Prelude -import Network.Minio.API +import Network.Minio.API +assertBool' :: Bool -> Assertion assertBool' = assertBool "Test failed!" bucketNameValidityTests :: TestTree diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -19,16 +19,15 @@ 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 @@ , 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