Add MonadBaseControl IO instance and catch HttpException

minio-hs.cabal

@@ -42,7 +42,9 @@ library
                      , http-client
                      , http-conduit
                      , http-types
+                     , lifted-base
                      , memory
+                     , monad-control
                      , resourcet
                      , text
                      , time
@@ -92,7 +94,9 @@ test-suite minio-hs-test
                      , http-client
                      , http-conduit
                      , http-types
+                     , lifted-base
                      , memory
+                     , monad-control
                      , resourcet
                      , tasty
                      , tasty-hunit

src/Network/Minio/API.hs

@@ -23,6 +23,7 @@ import           Lib.Prelude
 import           Network.Minio.Data
 import           Network.Minio.Data.Crypto
 import           Network.Minio.Sign.V4
+import Network.Minio.Utils
 
 -- runRequestDebug r mgr = do
 --   print $ "runRequestDebug"
@@ -72,18 +73,12 @@ buildRequest ri = do
     , NC.requestBody = rbody
     }
 
-isFailureStatus :: Response body -> Bool
-isFailureStatus resp = let s = HT.statusCode (NC.responseStatus resp)
-                       in not (s >= 200 && s < 300)
 
 executeRequest :: RequestInfo -> Minio (Response LByteString)
 executeRequest ri = do
   req <- buildRequest ri
   mgr <- asks mcConnManager
-  resp <- NC.httpLbs req mgr
-  if (isFailureStatus resp)
-    then throwError $ MErrService $ LBS.toStrict $ NC.responseBody resp
-    else return resp
+  httpLbs req mgr
 
 
 mkStreamRequest :: RequestInfo
@@ -91,11 +86,7 @@ mkStreamRequest :: RequestInfo
 mkStreamRequest ri = do
   req <- buildRequest ri
   mgr <- asks mcConnManager
-  resp <- NC.http req mgr
-  if (isFailureStatus resp)
-    then do errResp <- NC.lbsResponse resp
-            throwError $ MErrService $ LBS.toStrict $ NC.responseBody errResp
-    else return resp
+  http req mgr
 
 
 requestInfo :: Method -> Maybe Bucket -> Maybe Object

src/Network/Minio/Data.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}
 module Network.Minio.Data
   ( ConnectInfo(..)
   , RequestInfo(..)
@@ -24,8 +24,11 @@ import           Network.HTTP.Client (defaultManagerSettings, HttpException)
 import           Network.HTTP.Types (Method, Header, Query)
 import qualified Network.HTTP.Conduit as NC
 
-import Control.Monad.Trans.Resource (MonadThrow, MonadResource, ResourceT)
-import Control.Monad.Base (MonadBase(..))
+-- import Control.Monad.Trans.Resource (MonadThrow, MonadResource, ResourceT,
+--                                      MonadBaseControl(..))
+import Control.Monad.Trans.Resource
+import Control.Monad.Trans.Control
+import Control.Monad.Base
 
 import Text.XML
 
@@ -108,6 +111,11 @@ newtype Minio a = Minio {
     , MonadResource
     )
 
+instance MonadBaseControl IO Minio where
+  type StM Minio a = Either MinioErr a
+  liftBaseWith f = Minio $ liftBaseWith $ \q -> f (q . unMinio)
+  restoreM = Minio . restoreM
+
 -- MinioConn holds connection info and a connection pool
 data MinioConn = MinioConn {
     mcConnInfo :: ConnectInfo

src/Network/Minio/Utils.hs

@@ -2,11 +2,24 @@ module Network.Minio.Utils where
 
 import qualified Control.Monad.Trans.Resource as R
 import qualified System.IO as IO
+import qualified Network.HTTP.Conduit as NC
+import qualified Network.HTTP.Client as NClient
+import           Network.HTTP.Conduit (Response)
+import qualified Data.Conduit as C
+import qualified Data.ByteString.Lazy as LBS
+import qualified Network.HTTP.Types as HT
+import Control.Monad.Trans.Except (withExceptT, ExceptT(..), withExcept)
+import Control.Monad.Base (MonadBase(..))
+import qualified Control.Exception.Lifted as ExL
+
 
 import Lib.Prelude
 
 import Network.Minio.Data
 
+-- tryIO :: (MonadIO m, MonadError MinioErr m) => IO a -> m a
+-- tryIO act = either (throwError . MErrIO) return $ try act
+
 allocateReadFile :: (R.MonadResource m, MonadError MinioErr m)
                  => FilePath -> m (R.ReleaseKey, Handle)
 allocateReadFile fp = do
@@ -15,3 +28,34 @@ allocateReadFile fp = do
   where
     openReadFile f = runExceptT $ tryIO $ IO.openBinaryFile f IO.ReadMode
     cleanup = either (const $ return ()) IO.hClose
+
+
+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)
+        => NC.Request -> NC.Manager
+        -> m (NC.Response LByteString)
+httpLbs req mgr = do
+  respE <- liftIO $ try $ NClient.httpLbs req mgr
+  resp <- checkEither MErrHttp respE
+  unless (isSuccessStatus $ NC.responseStatus resp) $
+    throwError $ MErrService $ LBS.toStrict $ NC.responseBody resp
+  return resp
+
+-- http :: (MonadError MinioErr m, R.MonadResourceBase m, R.MonadResource m)
+--      => NC.Request -> NC.Manager
+--      -> m (Response (C.ResumableSource m ByteString))
+http :: NC.Request -> NC.Manager
+     -> Minio (Response (C.ResumableSource Minio ByteString))
+http req mgr = do
+  respE <- ExL.try $ NC.http req mgr
+  resp <- checkEither MErrHttp respE
+  unless (isSuccessStatus $ NC.responseStatus resp) $ do
+    lbsResp <- NC.lbsResponse resp
+    throwError $ MErrService $ LBS.toStrict $ NC.responseBody lbsResp
+  return resp

test/Spec.hs

@@ -56,6 +56,16 @@ unitTests = testGroup "Unit tests"
       step "Running test.."
       ret <- runResourceT $ runMinio mc $ getService
       isRight ret @? ("getService failure => " ++ show ret)
+  , testCaseSteps "Simple fGetObject works" $ \step -> do
+      step "Preparing..."
+
+      mc <- connect defaultConnectInfo
+
+      step "Running test.."
+      ret <- runResourceT $ runMinio mc $
+             fGetObject "testbucket" "lsb-release" "/tmp/out"
+      isRight ret @? ("fGetObject failure => " ++ show ret)
+
   , testCaseSteps "Simple putObject works" $ \step -> do
       step "Preparing..."