diff --git a/examples/FileUploader.hs b/examples/FileUploader.hs index fff22f6..25bfeb3 100755 --- a/examples/FileUploader.hs +++ b/examples/FileUploader.hs @@ -62,7 +62,7 @@ main = do -- Make a bucket; catch bucket already exists exception if thrown. catch (makeBucket bucket Nothing) - (\(_ :: MError) -> liftIO $ putStrLn "Bucket already exists, proceeding with upload file.") + (\(_ :: MinioErr) -> liftIO $ putStrLn "Bucket already exists, proceeding with upload file.") -- Upload filepath to bucket; object is derived from filepath. fPutObject bucket object filepath diff --git a/examples/HeadObject.hs b/examples/HeadObject.hs new file mode 100755 index 0000000..cf73b1f --- /dev/null +++ b/examples/HeadObject.hs @@ -0,0 +1,43 @@ +#!/usr/bin/env stack +-- stack --resolver lts-6.27 runghc --package minio-hs + +-- +-- Minio Haskell SDK, (C) 2017 Minio, Inc. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. +-- + +{-# Language OverloadedStrings #-} +import Network.Minio.S3API +import Network.Minio + +import Prelude + +-- | The following example uses minio's play server at +-- https://play.minio.io:9000. The endpoint and associated +-- credentials are provided via the libary constant, +-- +-- > minioPlayCI :: ConnectInfo +-- + +main :: IO () +main = do + let + bucket = "test" + object = "passwd" + res <- runResourceT $ runMinio minioPlayCI $ do + headObject bucket object + + case res of + Left e -> putStrLn $ "headObject failed." ++ (show e) + Right objInfo -> putStrLn $ "headObject succeeded." ++ (show objInfo) diff --git a/examples/ListBuckets.hs b/examples/ListBuckets.hs index b9fd64e..3190028 100755 --- a/examples/ListBuckets.hs +++ b/examples/ListBuckets.hs @@ -18,9 +18,10 @@ -- {-# Language OverloadedStrings #-} -import Network.Minio +import Network.Minio -import Prelude +import Control.Monad.IO.Class (liftIO) +import Prelude -- | The following example uses minio's play server at -- https://play.minio.io:9000. The endpoint and associated @@ -34,6 +35,7 @@ import Prelude main :: IO () main = do firstRegionE <- runResourceT $ runMinio minioPlayCI $ do - buckets <- getService + buckets <- listBuckets + liftIO $ print $ "Top 5 buckets: " ++ (show $ take 5 buckets) getLocation $ biName $ head buckets print firstRegionE diff --git a/examples/PutObject.hs b/examples/PutObject.hs index d598486..d0afea4 100755 --- a/examples/PutObject.hs +++ b/examples/PutObject.hs @@ -35,11 +35,12 @@ main = do let bucket = "test" object = "obj" - mb15 = 15 * 1024 * 1024 + localFile = "/etc/lsb-release" + kb15 = 15 * 1024 -- Eg 1. Upload a stream of repeating "a" using putObject. res1 <- runResourceT $ runMinio minioPlayCI $ do - putObject bucket object (CC.repeat "a") (Just mb15) + putObject bucket object (CC.repeat "a") (Just kb15) case res1 of Left e -> putStrLn $ "putObject failed." ++ (show e) Right () -> putStrLn "putObject succeeded." @@ -47,7 +48,7 @@ main = do -- Eg 2. Upload a file using fPutObject. res2 <- runResourceT $ runMinio minioPlayCI $ do - fPutObject bucket object "path/to/local/file" + fPutObject bucket object localFile case res2 of Left e -> putStrLn $ "fPutObject failed." ++ (show e) Right () -> putStrLn "fPutObject succeeded." diff --git a/src/Network/Minio.hs b/src/Network/Minio.hs index cbfc2da..d42045e 100644 --- a/src/Network/Minio.hs +++ b/src/Network/Minio.hs @@ -34,7 +34,6 @@ module Network.Minio -- with an object storage service. , MinioErr(..) , MErrV(..) - , MError(..) -- * Data Types ---------------- diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index a786cd9..5d16e21 100644 --- a/src/Network/Minio/API.hs +++ b/src/Network/Minio/API.hs @@ -110,21 +110,18 @@ buildRequest ri = do Nothing -> return $ connectHost ci Just r -> if "amazonaws.com" `T.isSuffixOf` (connectHost ci) then maybe - (throwM $ ME $ ValidationError $ MErrVRegionNotSupported r) + (throwM $ MErrVRegionNotSupported r) return (Map.lookup r awsRegionMap) else return $ connectHost ci sha256Hash <- getPayloadSHA256Hash (riPayload ri) - let newRi = ri { - riPayloadHash = sha256Hash - , riHeaders = sha256Header sha256Hash : (riHeaders ri) - , riRegion = region - } - newCi = ci { - connectHost = regionHost - } + let newRi = ri { riPayloadHash = sha256Hash + , riHeaders = sha256Header sha256Hash : (riHeaders ri) + , riRegion = region + } + newCi = ci { connectHost = regionHost } reqHeaders <- liftIO $ signV4 newCi newRi diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 7797c6a..b3c455c 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -348,11 +348,16 @@ runMinio ci m = do conn <- liftIO $ connect ci flip evalStateT Map.empty . flip runReaderT conn . unMinio $ (m >>= (return . Right)) `MC.catches` - [MC.Handler handlerME, MC.Handler handlerHE, MC.Handler handlerFE] + [ MC.Handler handlerServiceErr + , MC.Handler handlerHE + , MC.Handler handlerFE + , MC.Handler handlerValidation + ] where - handlerME = return . Left . ME - handlerHE = return . Left . MEHttp - handlerFE = return . Left . MEFile + handlerServiceErr = return . Left . MErrService + handlerHE = return . Left . MErrHTTP + handlerFE = return . Left . MErrIO + handlerValidation = return . Left . MErrValidation s3Name :: Text -> Name s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing diff --git a/src/Network/Minio/Errors.hs b/src/Network/Minio/Errors.hs index f0ba615..d8355cd 100644 --- a/src/Network/Minio/Errors.hs +++ b/src/Network/Minio/Errors.hs @@ -34,20 +34,33 @@ data MErrV = MErrVSinglePUTSizeExceeded Int64 | MErrVInvalidSrcObjByteRange (Int64, Int64) | MErrVCopyObjSingleNoRangeAccepted | MErrVRegionNotSupported Text + | MErrXmlParse Text deriving (Show, Eq) +instance Exception MErrV + +-- | Errors returned by S3 compatible service +data ServiceErr = BucketAlreadyExists + | NoSuchBucket + deriving (Show, Eq) + +instance Exception ServiceErr + -- | Errors thrown by the library -data MinioErr = ME MError - | MEHttp NC.HttpException - | MEFile IOException +data MinioErr = MErrHTTP NC.HttpException + | MErrIO IOException + | MErrService ServiceErr + | MErrValidation MErrV deriving (Show) +instance Eq MinioErr where + MErrHTTP _ == MErrHTTP _ = True + MErrHTTP _ == _ = False + MErrIO _ == MErrIO _ = True + MErrIO _ == _ = False + MErrService a == MErrService b = a == b + MErrService _ == _ = False + MErrValidation a == MErrValidation b = a == b + MErrValidation _ == _ = False + instance Exception MinioErr - --- | Library internal errors -data MError = XMLParseError Text - | ResponseError (NC.Response LByteString) - | ValidationError MErrV - deriving (Show, Eq) - -instance Exception MError diff --git a/src/Network/Minio/PutObject.hs b/src/Network/Minio/PutObject.hs index 8339fce..771e012 100644 --- a/src/Network/Minio/PutObject.hs +++ b/src/Network/Minio/PutObject.hs @@ -52,10 +52,6 @@ maxObjectSize = 5 * 1024 * 1024 * oneMiB minPartSize :: Int64 minPartSize = 64 * oneMiB --- | max part of an object size is 5GiB -maxObjectPartSize :: Int64 -maxObjectPartSize = 5 * 1024 * oneMiB - oneMiB :: Int64 oneMiB = 1024 * 1024 @@ -99,8 +95,7 @@ putObjectInternal b o (ODFile fp sizeMay) = do Just size -> if | size <= 64 * oneMiB -> either throwM return =<< withNewHandle fp (\h -> putObjectSingle b o [] h 0 size) - | size > maxObjectSize -> throwM $ ValidationError $ - MErrVPutSizeExceeded size + | size > maxObjectSize -> throwM $ MErrVPutSizeExceeded size | isSeekable -> parallelMultipartUpload b o fp size | otherwise -> sequentialMultipartUpload b o (Just size) $ CB.sourceFile fp @@ -217,7 +212,7 @@ copyObjectInternal :: Bucket -> Object -> CopyPartSource copyObjectInternal b' o cps = do -- validate and extract the src bucket and object (srcBucket, srcObject) <- maybe - (throwM $ ValidationError $ MErrVInvalidSrcObjSpec $ cpSource cps) + (throwM $ MErrVInvalidSrcObjSpec $ cpSource cps) return $ cpsToObject cps -- get source object size with a head request @@ -227,7 +222,7 @@ copyObjectInternal b' o cps = do when (isJust (cpSourceRange cps) && or [fst range < 0, snd range < fst range, snd range >= fromIntegral srcSize]) $ - throwM $ ValidationError $ MErrVInvalidSrcObjByteRange range + throwM $ MErrVInvalidSrcObjByteRange range -- 1. If sz > 64MiB (minPartSize) use multipart copy, OR -- 2. If startOffset /= 0 use multipart copy diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index c6752f2..5cfab5a 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -122,7 +122,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 $ ValidationError $ MErrVSinglePUTSizeExceeded size + throwM $ MErrVSinglePUTSizeExceeded size -- content-length header is automatically set by library. resp <- executeRequest $ @@ -136,7 +136,7 @@ putObjectSingle bucket object headers h offset size = do let rheaders = NC.responseHeaders resp etag = getETagHeader rheaders maybe - (throwM $ ValidationError MErrVETagHeaderNotFound) + (throwM MErrVETagHeaderNotFound) return etag -- | List objects in a bucket matching prefix up to delimiter, @@ -200,7 +200,7 @@ putObjectPart bucket object uploadId partNumber headers payload = do let rheaders = NC.responseHeaders resp etag = getETagHeader rheaders maybe - (throwM $ ValidationError MErrVETagHeaderNotFound) + (throwM MErrVETagHeaderNotFound) (return . (partNumber, )) etag where params = [ @@ -236,7 +236,7 @@ copyObjectSingle :: Bucket -> Object -> CopyPartSource -> [HT.Header] copyObjectSingle bucket object cps headers = do -- validate that cpSourceRange is Nothing for this API. when (isJust $ cpSourceRange cps) $ - throwM $ ValidationError $ MErrVCopyObjSingleNoRangeAccepted + throwM MErrVCopyObjSingleNoRangeAccepted resp <- executeRequest $ def { riMethod = HT.methodPut , riBucket = Just bucket @@ -323,5 +323,5 @@ headObject bucket object = do etag = getETagHeader headers size = getContentLength headers - maybe (throwM $ ValidationError MErrVInvalidObjectInfoResponse) return $ + maybe (throwM MErrVInvalidObjectInfoResponse) return $ ObjectInfo <$> Just object <*> modTime <*> etag <*> size diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index 60423a2..8f34b9d 100644 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -25,6 +25,7 @@ import qualified Control.Monad.Trans.Resource as R import qualified Data.ByteString as B import qualified Data.Conduit as C +import Data.Default (Default(..)) import qualified Data.Text as T import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Read (decimal) @@ -52,7 +53,7 @@ allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m) => FilePath -> m (R.ReleaseKey, Handle) allocateReadFile fp = do (rk, hdlE) <- R.allocate (openReadFile fp) cleanup - either (throwM . MEFile) (return . (rk,)) hdlE + either (throwM . MErrIO) (return . (rk,)) hdlE where openReadFile f = ExL.try $ IO.openBinaryFile f IO.ReadMode cleanup = either (const $ return ()) IO.hClose @@ -82,7 +83,7 @@ isHandleSeekable h = do -- returned - both during file handle allocation and when the action -- is run. withNewHandle :: (R.MonadResourceBase m, R.MonadResource m, MonadCatch m) - => FilePath -> (Handle -> m a) -> m (Either MError a) + => FilePath -> (Handle -> m a) -> m (Either MinioErr a) withNewHandle fp fileAction = do -- opening a handle can throw MError exception. handleE <- MC.try $ allocateReadFile fp @@ -127,7 +128,7 @@ httpLbs req mgr = do respE <- liftIO $ tryHttpEx $ (NClient.httpLbs req mgr) resp <- either throwM return respE unless (isSuccessStatus $ NC.responseStatus resp) $ - throwM $ ResponseError resp + throwM $ MErrHTTP $ NC.StatusCodeException (NC.responseStatus resp) [] def return resp where tryHttpEx :: (IO (NC.Response LByteString)) @@ -141,12 +142,11 @@ http req mgr = do respE <- tryHttpEx $ NC.http req mgr resp <- either throwM return respE unless (isSuccessStatus $ NC.responseStatus resp) $ do - lbsResp <- NC.lbsResponse resp - throwM $ ResponseError lbsResp + throwM $ MErrHTTP $ NC.StatusCodeException (NC.responseStatus resp) [] def return resp where tryHttpEx :: (R.MonadResourceBase m) => (m a) - -> m (Either NC.HttpException a) + -> m (Either MinioErr a) tryHttpEx = ExL.try -- like mapConcurrently but with a limited number of concurrent diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index b18df59..9c947e2 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -46,12 +46,12 @@ uncurry4 f (a, b, c, d) = f a b c d -- | Parse time strings from XML parseS3XMLTime :: (MonadThrow m) => Text -> m UTCTime -parseS3XMLTime = either (throwM . XMLParseError) return +parseS3XMLTime = either (throwM . MErrXmlParse) return . parseTimeM True defaultTimeLocale s3TimeFormat . T.unpack parseDecimal :: (MonadThrow m, Integral a) => Text -> m a -parseDecimal numStr = either (throwM . XMLParseError . show) return $ fst <$> decimal numStr +parseDecimal numStr = either (throwM . MErrXmlParse . show) return $ fst <$> decimal numStr parseDecimals :: (MonadThrow m, Integral a) => [Text] -> m [a] parseDecimals numStr = forM numStr parseDecimal @@ -60,7 +60,7 @@ s3Elem :: Text -> Axis s3Elem = element . s3Name parseRoot :: (MonadThrow m) => LByteString -> m Cursor -parseRoot = either (throwM . XMLParseError . show) (return . fromDocument) +parseRoot = either (throwM . MErrXmlParse . show) (return . fromDocument) . parseLBS def -- | Parse the response XML of a list buckets call. diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs index 2ec7cc9..3e9c7b2 100644 --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -41,26 +41,26 @@ xmlParserTests = testGroup "XML Parser Tests" , testCase "Test parseCopyObjectResponse" testParseCopyObjectResponse ] -tryMError :: (MC.MonadCatch m) => m a -> m (Either MError a) -tryMError act = MC.try act +tryValidationErr :: (MC.MonadCatch m) => m a -> m (Either MErrV a) +tryValidationErr act = MC.try act -assertMError :: MError -> Assertion -assertMError e = assertFailure $ "Failed due to exception => " ++ show e +assertValidtionErr :: MErrV -> Assertion +assertValidtionErr e = assertFailure $ "Failed due to validation error => " ++ show e -eitherMError :: Either MError a -> (a -> Assertion) -> Assertion -eitherMError (Left e) _ = assertMError e -eitherMError (Right a) f = f a +eitherValidationErr :: Either MErrV a -> (a -> Assertion) -> Assertion +eitherValidationErr (Left e) _ = assertValidtionErr e +eitherValidationErr (Right a) f = f a testParseLocation :: Assertion testParseLocation = do -- 1. Test parsing of an invalid location constraint xml. - parseResE <- tryMError $ parseLocation "ClearlyInvalidXml" + parseResE <- tryValidationErr $ parseLocation "ClearlyInvalidXml" when (isRight parseResE) $ assertFailure $ "Parsing should have failed => " ++ show parseResE forM_ cases $ \(xmldata, expectedLocation) -> do - parseLocE <- tryMError $ parseLocation xmldata - either assertMError (@?= expectedLocation) parseLocE + parseLocE <- tryValidationErr $ parseLocation xmldata + either assertValidtionErr (@?= expectedLocation) parseLocE where cases = [ -- 2. Test parsing of a valid location xml. @@ -79,8 +79,8 @@ testParseLocation = do testParseNewMultipartUpload :: Assertion testParseNewMultipartUpload = do forM_ cases $ \(xmldata, expectedUploadId) -> do - parsedUploadIdE <- tryMError $ parseNewMultipartUpload xmldata - eitherMError parsedUploadIdE (@?= expectedUploadId) + parsedUploadIdE <- tryValidationErr $ parseNewMultipartUpload xmldata + eitherValidationErr parsedUploadIdE (@?= expectedUploadId) where cases = [ ("\ @@ -124,8 +124,8 @@ testParseListObjectsResult = do object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 - parsedListObjectsResult <- tryMError $ parseListObjectsResponse xmldata - eitherMError parsedListObjectsResult (@?= expectedListResult) + parsedListObjectsResult <- tryValidationErr $ parseListObjectsResponse xmldata + eitherValidationErr parsedListObjectsResult (@?= expectedListResult) testParseListIncompleteUploads :: Assertion testParseListIncompleteUploads = do @@ -166,8 +166,8 @@ testParseListIncompleteUploads = do initTime = UTCTime (fromGregorian 2010 11 26) 69857 prefixes = ["photos/", "videos/"] - parsedListUploadsResult <- tryMError $ parseListUploadsResponse xmldata - eitherMError parsedListUploadsResult (@?= expectedListResult) + parsedListUploadsResult <- tryValidationErr $ parseListUploadsResponse xmldata + eitherValidationErr parsedListUploadsResult (@?= expectedListResult) testParseCompleteMultipartUploadResponse :: Assertion @@ -183,7 +183,7 @@ testParseCompleteMultipartUploadResponse = do expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\"" parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata - eitherMError parsedETagE (@?= expectedETag) + eitherValidationErr parsedETagE (@?= expectedETag) testParseListPartsResponse :: Assertion testParseListPartsResponse = do @@ -227,7 +227,7 @@ testParseListPartsResponse = do modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10 parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata - eitherMError parsedListPartsResult (@?= expectedListResult) + eitherValidationErr parsedListPartsResult (@?= expectedListResult) testParseCopyObjectResponse :: Assertion testParseCopyObjectResponse = do @@ -249,4 +249,4 @@ testParseCopyObjectResponse = do forM_ cases $ \(xmldata, (etag, modTime)) -> do parseResult <- runExceptT $ parseCopyObjectResponse xmldata - eitherMError parseResult (@?= (etag, modTime)) + eitherValidationErr parseResult (@?= (etag, modTime))