Refactor error types returned by the library

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

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

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) $

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 = [

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)
+httpLbs :: (R.MonadThrow m, MonadIO m)
-            => (e -> MinioErr) -> (Either e a) -> m a
-checkEither f = either (throwError . f) return
-
-httpLbs :: (MonadError MinioErr m, MonadIO m)
         => NC.Request -> NC.Manager
         -> m (NC.Response LByteString)
 httpLbs req mgr = do
-  respE <- liftIO $ try $ NClient.httpLbs req mgr
+  respE <- liftIO $ tryHttpEx $ (NClient.httpLbs req mgr)
-  resp <- checkEither MErrHttp respE
+  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
+  respE <- tryHttpEx $ NC.http req mgr
-  resp <- checkEither MErrHttp respE
+  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.

src/Network/Minio/XmlParser.hs

@@ -8,6 +8,7 @@ module Network.Minio.XmlParser
   , parseListPartsResponse
   ) where
 
+import           Control.Monad.Trans.Resource
 import           Data.List (zip3, zip4)
 import qualified Data.Text as T
 import           Data.Text.Read (decimal)
@@ -32,24 +33,24 @@ s3TimeFormat :: [Char]
 s3TimeFormat = iso8601DateFormat $ Just "%T%QZ"
 
 -- | Parse time strings from XML
-parseS3XMLTime :: (MonadError MinioErr m) => Text -> m UTCTime
+parseS3XMLTime :: (MonadThrow m) => Text -> m UTCTime
-parseS3XMLTime = either (throwError . MErrXml) return
+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 :: (MonadThrow m) => LByteString -> m Cursor
-parseRoot = either (throwError . MErrXml . show) (return . fromDocument)
+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

test/Network/Minio/XmlParser/Test.hs

@@ -3,9 +3,10 @@ module Network.Minio.XmlParser.Test
     xmlParserTests
   ) where
 
+import qualified Control.Monad.Catch as MC
+import           Data.Time (fromGregorian, UTCTime(..))
 import           Test.Tasty
 import           Test.Tasty.HUnit
-import Data.Time (fromGregorian, UTCTime(..))
 
 import           Lib.Prelude
 
@@ -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"
+  parseResE <- tryMError $ parseLocation "ClearlyInvalidXml"
-  case parsedLocationE of
+  when (isRight parseResE) $
-    Right _ -> assertFailure $ "Parsing should have failed => " ++ show parsedLocationE
+    assertFailure $ "Parsing should have failed => " ++ show parseResE
-    Left _ -> return ()
 
   forM_ cases $ \(xmldata, expectedLocation) -> do
-    parsedLocationE1 <- runExceptT $ parseLocation xmldata
+    parseLocE <- tryMError $ parseLocation xmldata
-    case parsedLocationE1 of
+    either assertMError (@?= expectedLocation) parseLocE
-      Right parsedLocation -> parsedLocation @?= expectedLocation
-      _ -> assertFailure $ "Parsing failed => " ++ show parsedLocationE1
   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
+    parsedUploadIdE <- tryMError $ parseNewMultipartUpload xmldata
-    case parsedUploadIdE of
+    eitherMError parsedUploadIdE (@?= expectedUploadId)
-      Right upId -> upId @?= expectedUploadId
-      _ -> assertFailure $ "Parsing failed => " ++ show parsedUploadIdE
   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
+  parsedListObjectsResult <- tryMError $ parseListObjectsResponse xmldata
-  case parsedListObjectsResult of
+  eitherMError parsedListObjectsResult (@?= expectedListResult)
-    Right listObjectsResult -> listObjectsResult @?= expectedListResult
-    _ -> assertFailure $ "Parsing failed => " ++ show parsedListObjectsResult
 
 testParseListIncompleteUploads :: Assertion
 testParseListIncompleteUploads = do
@@ -144,10 +148,8 @@ testParseListIncompleteUploads = do
     initTime = UTCTime (fromGregorian 2010 11 26) 69857
     prefixes = ["photos/", "videos/"]
 
-  parsedListUploadsResult <- runExceptT $ parseListUploadsResponse xmldata
+  parsedListUploadsResult <- tryMError $ parseListUploadsResponse xmldata
-  case parsedListUploadsResult of
+  eitherMError parsedListUploadsResult (@?= expectedListResult)
-    Right listUploadsResult -> listUploadsResult @?= expectedListResult
-    _ -> assertFailure $ "Parsing failed => " ++ show parsedListUploadsResult
 
 
 testParseCompleteMultipartUploadResponse :: Assertion
@@ -163,9 +165,7 @@ testParseCompleteMultipartUploadResponse = do
     expectedETag = "\"3858f62230ac3c915f300c664312c11f-9\""
 
   parsedETagE <- runExceptT $ parseCompleteMultipartUploadResponse xmldata
-  case parsedETagE of
+  eitherMError parsedETagE (@?= expectedETag)
-    Right actualETag -> actualETag @?= expectedETag
-    _ -> assertFailure $ "Parsing failed => " ++ show parsedETagE
 
 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
+  eitherMError parsedListPartsResult (@?= expectedListResult)
-    Right listPartsResult -> listPartsResult @?= expectedListResult
-    _ -> assertFailure $ "Parsing failed => " ++ show parsedListPartsResult