minio-hs 1.0.0 → 1.0.1
raw patch · 14 files changed
+181/−181 lines, 14 filesdep −exceptionsdep −text-formatdep ~aesondep ~base64-bytestringdep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependencies removed: exceptions, text-format
Dependency ranges changed: aeson, base64-bytestring, bytestring, case-insensitive, conduit, conduit-extra, containers, cryptonite, cryptonite-conduit, data-default, filepath, http-client, http-conduit, http-types, memory, protolude, resourcet, text, time, transformers, unliftio, unliftio-core, xml-conduit
API changes (from Hackage documentation)
Files
- CHANGELOG.md +8/−0
- minio-hs.cabal +24/−30
- src/Lib/Prelude.hs +7/−20
- src/Network/Minio/API.hs +17/−19
- src/Network/Minio/CopyObject.hs +1/−1
- src/Network/Minio/Data.hs +12/−11
- src/Network/Minio/PresignedOperations.hs +5/−6
- src/Network/Minio/PutObject.hs +4/−4
- src/Network/Minio/S3API.hs +17/−15
- src/Network/Minio/Utils.hs +19/−21
- src/Network/Minio/XmlParser.hs +23/−24
- test/LiveServer.hs +34/−20
- test/Network/Minio/API/Test.hs +5/−4
- test/Network/Minio/XmlParser/Test.hs +5/−6
CHANGELOG.md view
@@ -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:
minio-hs.cabal view
@@ -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
src/Lib/Prelude.hs view
@@ -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)
src/Network/Minio/API.hs view
@@ -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
src/Network/Minio/CopyObject.hs view
@@ -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
src/Network/Minio/Data.hs view
@@ -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
src/Network/Minio/PresignedOperations.hs view
@@ -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)
src/Network/Minio/PutObject.hs view
@@ -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
src/Network/Minio/S3API.hs view
@@ -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
src/Network/Minio/Utils.hs view
@@ -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
src/Network/Minio/XmlParser.hs view
@@ -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"
test/LiveServer.hs view
@@ -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
test/Network/Minio/API/Test.hs view
@@ -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
test/Network/Minio/XmlParser/Test.hs view
@@ -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