diff --git a/minio-hs.cabal b/minio-hs.cabal index cc1f8e2..88e66c2 100644 --- a/minio-hs.cabal +++ b/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 diff --git a/src/Network/Minio/API.hs b/src/Network/Minio/API.hs index 5f32c99..edad4b8 100644 --- a/src/Network/Minio/API.hs +++ b/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 diff --git a/src/Network/Minio/Data.hs b/src/Network/Minio/Data.hs index 02e5dd5..b64791c 100644 --- a/src/Network/Minio/Data.hs +++ b/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 diff --git a/src/Network/Minio/Utils.hs b/src/Network/Minio/Utils.hs index 94c0ad8..1ff1d35 100644 --- a/src/Network/Minio/Utils.hs +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs index a318a66..e906a88 100644 --- a/test/Spec.hs +++ b/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..."