Refactor error types returned by the library

2017-01-31 13:05:13 +05:30 · 2017-01-31 13:05:13 +05:30 · f26fbc82a7
commit f26fbc82a7
parent 5f1ee7fc67
7 changed files with 118 additions and 90 deletions
--- 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
--- 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
--- 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) $
--- 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 = [
--- 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.
--- 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
--- 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 = [
      ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\
@ -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)