Refactor error handling and fix most warnings
This commit is contained in:
parent
c9f6d666db
commit
a7e70b9031
@ -25,7 +25,7 @@ import System.FilePath
|
||||
import qualified Data.Conduit as C
|
||||
import qualified Data.Conduit.Binary as CB
|
||||
|
||||
import Lib.Prelude
|
||||
-- import Lib.Prelude
|
||||
|
||||
import Network.Minio.Data
|
||||
import Network.Minio.S3API
|
||||
|
||||
@ -13,6 +13,7 @@ import qualified Network.HTTP.Types as HT
|
||||
import Network.HTTP.Conduit (Response)
|
||||
import qualified Network.HTTP.Conduit as NC
|
||||
import Network.HTTP.Types (Method, Header, Query)
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import Lib.Prelude
|
||||
|
||||
@ -59,19 +60,31 @@ buildRequest ri = do
|
||||
, NC.requestBody = NC.RequestBodyBS pload
|
||||
}
|
||||
|
||||
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
|
||||
NC.httpLbs req mgr
|
||||
resp <- NC.httpLbs req mgr
|
||||
if (isFailureStatus resp)
|
||||
then throwError $ MErrService $ LBS.toStrict $ NC.responseBody resp
|
||||
else return resp
|
||||
|
||||
|
||||
mkStreamRequest :: RequestInfo
|
||||
-> Minio (Response (C.ResumableSource Minio ByteString))
|
||||
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
|
||||
|
||||
NC.http req mgr
|
||||
|
||||
requestInfo :: Method -> Maybe Bucket -> Maybe Object
|
||||
-> Query -> [Header] -> Payload
|
||||
|
||||
@ -15,18 +15,16 @@ module Network.Minio.Data
|
||||
, runMinio
|
||||
, defaultConnectInfo
|
||||
, connect
|
||||
, Payload(..)
|
||||
, Payload
|
||||
, s3Name
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Conduit as C
|
||||
import Network.HTTP.Client (defaultManagerSettings, HttpException)
|
||||
import Network.HTTP.Types (Method, Header, Query, Status)
|
||||
import Network.HTTP.Types (Method, Header, Query)
|
||||
import qualified Network.HTTP.Conduit as NC
|
||||
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Control.Monad.Trans.Resource (MonadThrow, MonadResource, ResourceT, ResIO)
|
||||
import Control.Monad.Trans.Resource (MonadThrow, MonadResource, ResourceT)
|
||||
import Control.Monad.Base (MonadBase(..))
|
||||
|
||||
import Text.XML
|
||||
@ -79,9 +77,10 @@ getPathFromRI ri = B.concat $ parts
|
||||
getRegionFromRI :: RequestInfo -> Text
|
||||
getRegionFromRI ri = maybe "us-east-1" identity (riRegion ri)
|
||||
|
||||
data MinioErr = MErrMsg ByteString
|
||||
| MErrHttp HttpException
|
||||
| MErrXml ByteString
|
||||
data MinioErr = MErrMsg ByteString -- generic
|
||||
| MErrHttp HttpException -- http exceptions
|
||||
| MErrXml ByteString -- XML parsing/generation errors
|
||||
| MErrService ByteString -- error response from service
|
||||
deriving (Show)
|
||||
|
||||
newtype Minio a = Minio {
|
||||
|
||||
@ -13,16 +13,12 @@ import qualified Data.Conduit as C
|
||||
|
||||
import Lib.Prelude
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import Network.Minio.Data
|
||||
import Network.Minio.API
|
||||
import Network.Minio.XmlParser
|
||||
import Network.Minio.XmlGenerator
|
||||
|
||||
status204 :: HT.Status
|
||||
status204 = HT.Status{ HT.statusCode = 204, HT.statusMessage = "No Content" }
|
||||
|
||||
getService :: Minio [BucketInfo]
|
||||
getService = do
|
||||
resp <- executeRequest $
|
||||
@ -40,37 +36,23 @@ getObject :: Bucket -> Object -> HT.Query -> [HT.Header]
|
||||
-> Minio ([HT.Header], C.ResumableSource Minio ByteString)
|
||||
getObject bucket object queryParams headers = do
|
||||
resp <- mkStreamRequest reqInfo
|
||||
let httpStatusCode = HT.statusCode $ NC.responseStatus resp
|
||||
if httpStatusCode >= 200 && httpStatusCode < 300
|
||||
then return $ (NC.responseHeaders resp, NC.responseBody resp)
|
||||
else do errMsg <- NC.lbsResponse resp
|
||||
throwError $ MErrXml $ LBS.toStrict $ NC.responseBody errMsg
|
||||
return $ (NC.responseHeaders resp, NC.responseBody resp)
|
||||
where
|
||||
reqInfo = requestInfo HT.methodGet (Just bucket) (Just object)
|
||||
queryParams headers Nothing
|
||||
|
||||
putBucket :: Bucket -> Location -> Minio ()
|
||||
putBucket bucket location = do
|
||||
resp <- executeRequest $
|
||||
void $ executeRequest $
|
||||
requestInfo HT.methodPut (Just bucket) Nothing [] [] $
|
||||
Just $ mkCreateBucketConfig bucket location
|
||||
|
||||
let httpStatus = NC.responseStatus resp
|
||||
when (httpStatus /= HT.ok200) $
|
||||
throwError $ MErrXml $ LBS.toStrict $ NC.responseBody resp
|
||||
|
||||
deleteBucket :: Bucket -> Minio ()
|
||||
deleteBucket bucket = do
|
||||
resp <- executeRequest $
|
||||
void $ executeRequest $
|
||||
requestInfo HT.methodDelete (Just bucket) Nothing [] [] Nothing
|
||||
let httpStatus = NC.responseStatus resp
|
||||
when (httpStatus /= status204) $
|
||||
throwError $ MErrXml $ LBS.toStrict $ NC.responseBody resp
|
||||
|
||||
deleteObject :: Bucket -> Object -> Minio ()
|
||||
deleteObject bucket object = do
|
||||
resp <- executeRequest $
|
||||
void $ executeRequest $
|
||||
requestInfo HT.methodDelete (Just bucket) (Just object) [] [] Nothing
|
||||
let httpStatus = NC.responseStatus resp
|
||||
when (httpStatus /= status204) $
|
||||
throwError $ MErrXml $ LBS.toStrict $ NC.responseBody resp
|
||||
|
||||
Loading…
Reference in New Issue
Block a user