From f26fbc82a7ef644de2f0d1f474e360919004730a Mon Sep 17 00:00:00 2001 From: Aditya Manthramurthy Date: Tue, 31 Jan 2017 13:05:13 +0530 Subject: [PATCH] Refactor error types returned by the library --- minio-hs.cabal | 3 ++ src/Network/Minio/Data.hs | 61 +++++++++++++++++---------- src/Network/Minio/PutObject.hs | 2 +- src/Network/Minio/S3API.hs | 7 ++-- src/Network/Minio/Utils.hs | 44 +++++++++++--------- src/Network/Minio/XmlParser.hs | 29 ++++++------- test/Network/Minio/XmlParser/Test.hs | 62 ++++++++++++++-------------- 7 files changed, 118 insertions(+), 90 deletions(-) diff --git a/minio-hs.cabal b/minio-hs.cabal index e1307cc..56e3eec 100644 --- a/minio-hs.cabal +++ b/minio-hs.cabal @@ -41,6 +41,7 @@ library , cryptonite , cryptonite-conduit , data-default + , exceptions , filepath , http-client , http-conduit @@ -83,6 +84,7 @@ test-suite minio-hs-test , cryptonite , cryptonite-conduit , data-default + , exceptions , filepath , http-client , http-conduit @@ -110,6 +112,7 @@ test-suite minio-hs-test , NoImplicitPrelude , MultiParamTypeClasses , MultiWayIf + , ScopedTypeVariables , RankNTypes , TupleSections , TypeFamilies diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index acf5f84..918e202 100644 --- a/src/Network/Minio/Data.hs +++ b/src/Network/Minio/Data.hs @@ -2,6 +2,7 @@ module Network.Minio.Data where import Control.Monad.Base +import qualified Control.Monad.Catch as MC import Control.Monad.Trans.Control import Control.Monad.Trans.Resource import qualified Data.ByteString as B @@ -149,25 +150,8 @@ getPathFromRI ri = B.concat $ parts getRegionFromRI :: RequestInfo -> Text getRegionFromRI ri = maybe "us-east-1" identity (riRegion ri) --- | Various validation errors -data MErrV = MErrVSinglePUTSizeExceeded Int64 - | MErrVPutSizeExceeded Int64 - | MErrVETagHeaderNotFound - deriving (Show) - --- | --- Minio Error data type for various errors/exceptions caught and --- returned. -data MinioErr = MErrMsg ByteString -- generic - | MErrHttp HttpException -- http exceptions - | MErrXml ByteString -- XML parsing/generation errors - | MErrService ByteString -- error response from service - | MErrValidation MErrV -- client-side validation errors - | MErrIO IOException -- exceptions while working with files - deriving (Show) - newtype Minio a = Minio { - unMinio :: ReaderT MinioConn (ExceptT MinioErr (ResourceT IO)) a + unMinio :: ReaderT MinioConn (ResourceT IO) a } deriving ( Functor @@ -175,14 +159,14 @@ newtype Minio a = Minio { , Monad , MonadIO , MonadReader MinioConn - , MonadError MinioErr , MonadThrow + , MC.MonadCatch , MonadBase IO , MonadResource ) instance MonadBaseControl IO Minio where - type StM Minio a = Either MinioErr a + type StM Minio a = a liftBaseWith f = Minio $ liftBaseWith $ \q -> f (q . unMinio) restoreM = Minio . restoreM @@ -203,7 +187,42 @@ connect ci = do runMinio :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a) runMinio ci m = do conn <- liftIO $ connect ci - runExceptT . flip runReaderT conn . unMinio $ m + flip runReaderT conn . unMinio $ + (m >>= (return . Right)) + `MC.catch` handlerME + `MC.catch` handlerHE + `MC.catch` handlerFE + where + handlerME = return . Left . ME + handlerHE = return . Left . MEHttp + handlerFE = return . Left . MEFile + + s3Name :: Text -> Name s3Name s = Name s (Just "http://s3.amazonaws.com/doc/2006-03-01/") Nothing + +--------------------------------- +-- Errors +--------------------------------- +-- | Various validation errors +data MErrV = MErrVSinglePUTSizeExceeded Int64 + | MErrVPutSizeExceeded Int64 + | MErrVETagHeaderNotFound + deriving (Show, Eq) + +-- | Errors thrown by the library +data MinioErr = ME MError + | MEHttp HttpException + | MEFile IOException + deriving (Show) + +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 3b27864..f34a8fe 100644 --- a/src/Network/Minio/PutObject.hs +++ b/src/Network/Minio/PutObject.hs @@ -66,7 +66,7 @@ putObject b o (ODFile fp sizeMay) = do etag <- putObjectSingle b o [] h 0 size R.release rKey return etag - | size > maxObjectSize -> throwError $ MErrValidation $ + | size > maxObjectSize -> R.throwM $ ValidationError $ MErrVPutSizeExceeded size | isSeekable -> parallelMultipartUpload b o fp size | otherwise -> sequentialMultipartUpload b o (Just size) $ diff --git a/src/Network/Minio/S3API.hs b/src/Network/Minio/S3API.hs index 441bd0e..2178824 100644 --- a/src/Network/Minio/S3API.hs +++ b/src/Network/Minio/S3API.hs @@ -35,6 +35,7 @@ module Network.Minio.S3API ) where +import Control.Monad.Trans.Resource import qualified Data.Conduit as C import Data.Default (def) import qualified Network.HTTP.Conduit as NC @@ -96,7 +97,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) $ - throwError $ MErrValidation $ MErrVSinglePUTSizeExceeded size + throwM $ ValidationError $ MErrVSinglePUTSizeExceeded size -- content-length header is automatically set by library. resp <- executeRequest $ @@ -110,7 +111,7 @@ putObjectSingle bucket object headers h offset size = do let rheaders = NC.responseHeaders resp etag = getETagHeader rheaders maybe - (throwError $ MErrValidation MErrVETagHeaderNotFound) + (throwM $ ValidationError MErrVETagHeaderNotFound) return etag @@ -176,7 +177,7 @@ putObjectPart bucket object uploadId partNumber headers payload = do let rheaders = NC.responseHeaders resp etag = getETagHeader rheaders maybe - (throwError $ MErrValidation MErrVETagHeaderNotFound) + (throwM $ ValidationError MErrVETagHeaderNotFound) (return . PartInfo partNumber) etag where params = [ diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index c92a820..ce6b36c 100644 --- a/src/Network/Minio/Utils.hs +++ b/src/Network/Minio/Utils.hs @@ -3,9 +3,10 @@ module Network.Minio.Utils where import qualified Control.Concurrent.Async.Lifted as A import qualified Control.Concurrent.QSem as Q import qualified Control.Exception.Lifted as ExL +import Control.Monad.Catch (throwM) +import qualified Control.Monad.Catch as MC import Control.Monad.Trans.Control (liftBaseOp_, StM) import qualified Control.Monad.Trans.Resource as R -import qualified Data.ByteString.Lazy as LBS import qualified Data.Conduit as C import Data.Text.Encoding.Error (lenientDecode) import qualified Network.HTTP.Client as NClient @@ -18,26 +19,27 @@ import Lib.Prelude import Network.Minio.Data -allocateReadFile :: (R.MonadResource m, MonadError MinioErr m) +allocateReadFile :: (R.MonadResource m, R.MonadResourceBase m) => FilePath -> m (R.ReleaseKey, Handle) allocateReadFile fp = do (rk, hdlE) <- R.allocate (openReadFile fp) cleanup - either (throwError . MErrIO) (return . (rk,)) hdlE + either (MC.throwM . MEFile) (return . (rk,)) hdlE where openReadFile f = ExL.try $ IO.openBinaryFile f IO.ReadMode cleanup = either (const $ return ()) IO.hClose -getFileSize :: (R.MonadResourceBase m, R.MonadResource m, MonadError MinioErr m) +getFileSize :: (R.MonadResourceBase m, R.MonadResource m) => Handle -> m (Either IOException Int64) getFileSize h = ExL.try $ liftIO $ fromIntegral <$> IO.hFileSize h -isFileSeekable :: (R.MonadResource m, MonadError MinioErr m) +isFileSeekable :: (R.MonadResource m, R.MonadResourceBase m) => FilePath -> m Bool isFileSeekable fp = do (rKey, h) <- allocateReadFile fp - isSeekable <- liftIO $ IO.hIsSeekable h + resE <- liftIO $ try $ IO.hIsSeekable h R.release rKey - return isSeekable + either (MC.throwM . MEFile) return resE + lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString lookupHeader hdr = headMay . map snd . filter (\(h, _) -> h == hdr) @@ -52,30 +54,34 @@ isSuccessStatus :: HT.Status -> Bool isSuccessStatus sts = let s = HT.statusCode sts in (s >= 200 && s < 300) -checkEither :: (Monad m, MonadError MinioErr m) - => (e -> MinioErr) -> (Either e a) -> m a -checkEither f = either (throwError . f) return - -httpLbs :: (MonadError MinioErr m, MonadIO m) +httpLbs :: (R.MonadThrow m, MonadIO m) => NC.Request -> NC.Manager -> m (NC.Response LByteString) httpLbs req mgr = do - respE <- liftIO $ try $ NClient.httpLbs req mgr - resp <- checkEither MErrHttp respE + respE <- liftIO $ tryHttpEx $ (NClient.httpLbs req mgr) + resp <- either throwM return respE unless (isSuccessStatus $ NC.responseStatus resp) $ - throwError $ MErrService $ LBS.toStrict $ NC.responseBody resp + throwM $ ResponseError resp return resp + where + tryHttpEx :: (IO (NC.Response LByteString)) + -> IO (Either NC.HttpException (NC.Response LByteString)) + tryHttpEx = try -http :: (MonadError MinioErr m, R.MonadResourceBase m, R.MonadResource m) +http :: (R.MonadResourceBase m, R.MonadResource m) => NC.Request -> NC.Manager -> m (Response (C.ResumableSource m ByteString)) http req mgr = do - respE <- ExL.try $ NC.http req mgr - resp <- checkEither MErrHttp respE + respE <- tryHttpEx $ NC.http req mgr + resp <- either throwM return respE unless (isSuccessStatus $ NC.responseStatus resp) $ do lbsResp <- NC.lbsResponse resp - throwError $ MErrService $ LBS.toStrict $ NC.responseBody lbsResp + throwM $ ResponseError lbsResp return resp + where + tryHttpEx :: (R.MonadResourceBase m) => (m a) + -> m (Either NC.HttpException a) + tryHttpEx = ExL.try -- like mapConcurrently but with a limited number of concurrent -- threads. diff --git a/src/Network/Minio/XmlParser.hs b/src/Network/Minio/XmlParser.hs index 5042dd0..5b74e2f 100644 --- a/src/Network/Minio/XmlParser.hs +++ b/src/Network/Minio/XmlParser.hs @@ -8,7 +8,8 @@ module Network.Minio.XmlParser , parseListPartsResponse ) where -import Data.List (zip3, zip4) +import Control.Monad.Trans.Resource +import Data.List (zip3, zip4) import qualified Data.Text as T import Data.Text.Read (decimal) import Data.Time @@ -32,24 +33,24 @@ s3TimeFormat :: [Char] s3TimeFormat = iso8601DateFormat $ Just "%T%QZ" -- | Parse time strings from XML -parseS3XMLTime :: (MonadError MinioErr m) => Text -> m UTCTime -parseS3XMLTime = either (throwError . MErrXml) return +parseS3XMLTime :: (MonadThrow m) => Text -> m UTCTime +parseS3XMLTime = either (throwM . XMLParseError) return . parseTimeM True defaultTimeLocale s3TimeFormat . T.unpack -parseDecimals :: (MonadError MinioErr m, Integral a) => [Text] -> m [a] +parseDecimals :: (MonadThrow m, Integral a) => [Text] -> m [a] parseDecimals numStr = forM numStr $ \str -> - either (throwError . MErrXml . show) return $ fst <$> decimal str + either (throwM . XMLParseError . show) return $ fst <$> decimal str s3Elem :: Text -> Axis s3Elem = element . s3Name -parseRoot :: (MonadError MinioErr m) => LByteString -> m Cursor -parseRoot = either (throwError . MErrXml . show) (return . fromDocument) +parseRoot :: (MonadThrow m) => LByteString -> m Cursor +parseRoot = either (throwM . XMLParseError . show) (return . fromDocument) . parseLBS def -- | Parse the response XML of a list buckets call. -parseListBuckets :: (MonadError MinioErr m) => LByteString -> m [BucketInfo] +parseListBuckets :: (MonadThrow m) => LByteString -> m [BucketInfo] parseListBuckets xmldata = do r <- parseRoot xmldata let @@ -60,27 +61,27 @@ parseListBuckets xmldata = do return $ map (\(n, t) -> BucketInfo n t) $ zip names times -- | Parse the response XML of a location request. -parseLocation :: (MonadError MinioErr m) => LByteString -> m Region +parseLocation :: (MonadThrow m) => LByteString -> m Region parseLocation xmldata = do r <- parseRoot xmldata return $ T.concat $ r $/ content -- | Parse the response XML of an newMultipartUpload call. -parseNewMultipartUpload :: (MonadError MinioErr m) +parseNewMultipartUpload :: (MonadThrow m) => LByteString -> m UploadId parseNewMultipartUpload xmldata = do r <- parseRoot xmldata return $ T.concat $ r $// element (s3Name "UploadId") &/ content -- | Parse the response XML of completeMultipartUpload call. -parseCompleteMultipartUploadResponse :: (MonadError MinioErr m) +parseCompleteMultipartUploadResponse :: (MonadThrow m) => LByteString -> m ETag parseCompleteMultipartUploadResponse xmldata = do r <- parseRoot xmldata return $ T.concat $ r $// s3Elem "ETag" &/ content -- | Parse the response XML of a list objects call. -parseListObjectsResponse :: (MonadError MinioErr m) +parseListObjectsResponse :: (MonadThrow m) => LByteString -> m ListObjectsResult parseListObjectsResponse xmldata = do r <- parseRoot xmldata @@ -106,7 +107,7 @@ parseListObjectsResponse xmldata = do return $ ListObjectsResult hasMore nextToken objects prefixes -- | Parse the response XML of a list incomplete multipart upload call. -parseListUploadsResponse :: (MonadError MinioErr m) +parseListUploadsResponse :: (MonadThrow m) => LByteString -> m ListUploadsResult parseListUploadsResponse xmldata = do r <- parseRoot xmldata @@ -126,7 +127,7 @@ parseListUploadsResponse xmldata = do return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes -parseListPartsResponse :: (MonadError MinioErr m) +parseListPartsResponse :: (MonadThrow m) => LByteString -> m ListPartsResult parseListPartsResponse xmldata = do r <- parseRoot xmldata diff --git a/test/Network/Minio/XmlParser/Test.hs b/test/Network/Minio/XmlParser/Test.hs index d060b6d..b1058f3 100644 --- a/test/Network/Minio/XmlParser/Test.hs +++ b/test/Network/Minio/XmlParser/Test.hs @@ -3,14 +3,15 @@ module Network.Minio.XmlParser.Test xmlParserTests ) where -import Test.Tasty -import Test.Tasty.HUnit -import Data.Time (fromGregorian, UTCTime(..)) +import qualified Control.Monad.Catch as MC +import Data.Time (fromGregorian, UTCTime(..)) +import Test.Tasty +import Test.Tasty.HUnit -import Lib.Prelude +import Lib.Prelude -import Network.Minio.Data -import Network.Minio.XmlParser +import Network.Minio.Data +import Network.Minio.XmlParser xmlParserTests :: TestTree xmlParserTests = testGroup "XML Parser Tests" @@ -22,19 +23,26 @@ xmlParserTests = testGroup "XML Parser Tests" , testCase "Test parseListPartsResponse" testParseListPartsResponse ] +tryMError :: (MC.MonadCatch m) => m a -> m (Either MError a) +tryMError act = MC.try act + +assertMError :: MError -> Assertion +assertMError e = assertFailure $ "Failed due to exception => " ++ show e + +eitherMError :: Either MError a -> (a -> Assertion) -> Assertion +eitherMError (Left e) _ = assertMError e +eitherMError (Right a) f = f a + testParseLocation :: Assertion testParseLocation = do -- 1. Test parsing of an invalid location constraint xml. - parsedLocationE <- runExceptT $ parseLocation "ClearlyInvalidXml" - case parsedLocationE of - Right _ -> assertFailure $ "Parsing should have failed => " ++ show parsedLocationE - Left _ -> return () + parseResE <- tryMError $ parseLocation "ClearlyInvalidXml" + when (isRight parseResE) $ + assertFailure $ "Parsing should have failed => " ++ show parseResE forM_ cases $ \(xmldata, expectedLocation) -> do - parsedLocationE1 <- runExceptT $ parseLocation xmldata - case parsedLocationE1 of - Right parsedLocation -> parsedLocation @?= expectedLocation - _ -> assertFailure $ "Parsing failed => " ++ show parsedLocationE1 + parseLocE <- tryMError $ parseLocation xmldata + either assertMError (@?= expectedLocation) parseLocE where cases = [ -- 2. Test parsing of a valid location xml. @@ -53,10 +61,8 @@ testParseLocation = do testParseNewMultipartUpload :: Assertion testParseNewMultipartUpload = do forM_ cases $ \(xmldata, expectedUploadId) -> do - parsedUploadIdE <- runExceptT $ parseNewMultipartUpload xmldata - case parsedUploadIdE of - Right upId -> upId @?= expectedUploadId - _ -> assertFailure $ "Parsing failed => " ++ show parsedUploadIdE + parsedUploadIdE <- tryMError $ parseNewMultipartUpload xmldata + eitherMError parsedUploadIdE (@?= expectedUploadId) where cases = [ ("\ @@ -100,10 +106,8 @@ testParseListObjectsResult = do object1 = ObjectInfo "my-image.jpg" modifiedTime1 "\"fba9dede5f27731c9771645a39863328\"" 434234 modifiedTime1 = flip UTCTime 64230 $ fromGregorian 2009 10 12 - parsedListObjectsResult <- runExceptT $ parseListObjectsResponse xmldata - case parsedListObjectsResult of - Right listObjectsResult -> listObjectsResult @?= expectedListResult - _ -> assertFailure $ "Parsing failed => " ++ show parsedListObjectsResult + parsedListObjectsResult <- tryMError $ parseListObjectsResponse xmldata + eitherMError parsedListObjectsResult (@?= expectedListResult) testParseListIncompleteUploads :: Assertion testParseListIncompleteUploads = do @@ -144,10 +148,8 @@ testParseListIncompleteUploads = do initTime = UTCTime (fromGregorian 2010 11 26) 69857 prefixes = ["photos/", "videos/"] - parsedListUploadsResult <- runExceptT $ parseListUploadsResponse xmldata - case parsedListUploadsResult of - Right listUploadsResult -> listUploadsResult @?= expectedListResult - _ -> assertFailure $ "Parsing failed => " ++ show parsedListUploadsResult + parsedListUploadsResult <- tryMError $ parseListUploadsResponse xmldata + eitherMError parsedListUploadsResult (@?= expectedListResult) testParseCompleteMultipartUploadResponse :: Assertion @@ -163,9 +165,7 @@ testParseCompleteMultipartUploadResponse = do expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\"" parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata - case parsedETagE of - Right actualETag -> actualETag @?= expectedETag - _ -> assertFailure $ "Parsing failed => " ++ show parsedETagE + eitherMError parsedETagE (@?= expectedETag) testParseListPartsResponse :: Assertion testParseListPartsResponse = do @@ -209,6 +209,4 @@ testParseListPartsResponse = do modifiedTime2 = flip UTCTime 74913 $ fromGregorian 2010 11 10 parsedListPartsResult <- runExceptT $ parseListPartsResponse xmldata - case parsedListPartsResult of - Right listPartsResult -> listPartsResult @?= expectedListResult - _ -> assertFailure $ "Parsing failed => " ++ show parsedListPartsResult + eitherMError parsedListPartsResult (@?= expectedListResult)