Use own throw/catch
This commit is contained in:
parent
49d5067e22
commit
1a67d93c60
4 changed files with 14 additions and 9 deletions
|
@ -17,7 +17,6 @@ module Servant.Client.Core.Internal.HasClient where
|
|||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Monad.Error.Class (throwError)
|
||||
import Data.Foldable (toList)
|
||||
import Data.List (foldl')
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
|
@ -225,7 +224,7 @@ instance OVERLAPPING_
|
|||
, requestAccept = fromList $ toList accept
|
||||
}
|
||||
case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of
|
||||
Left err -> throwError $ DecodeFailure (pack err) response
|
||||
Left err -> throwServantError $ DecodeFailure (pack err) response
|
||||
Right val -> return $ Headers
|
||||
{ getResponse = val
|
||||
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
@ -13,6 +13,7 @@ module Servant.Client.Core.Internal.Request where
|
|||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Monad.Catch (Exception)
|
||||
import qualified Data.ByteString.Builder as Builder
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Semigroup ((<>))
|
||||
|
@ -44,6 +45,8 @@ data ServantError =
|
|||
| ConnectionError Text
|
||||
deriving (Eq, Show, Generic, Typeable)
|
||||
|
||||
instance Exception ServantError
|
||||
|
||||
data RequestF a = Request
|
||||
{ requestPath :: a
|
||||
, requestQueryString :: Seq.Seq QueryItem
|
||||
|
|
|
@ -6,11 +6,10 @@
|
|||
-- | Types for possible backends to run client-side `Request` queries
|
||||
module Servant.Client.Core.Internal.RunClient where
|
||||
|
||||
import Prelude.Compat
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.Error.Class (MonadError, throwError)
|
||||
import Data.Foldable (toList)
|
||||
import Data.Proxy (Proxy)
|
||||
import qualified Data.Text as T
|
||||
|
@ -22,16 +21,18 @@ import Servant.API (MimeUnrender,
|
|||
import Servant.Client.Core.Internal.Request (Request, Response (..),
|
||||
ServantError (..))
|
||||
|
||||
class (MonadError ServantError m) => RunClient m where
|
||||
class (Monad m) => RunClient m where
|
||||
-- | How to make a request.
|
||||
runRequest :: Request -> m Response
|
||||
throwServantError :: ServantError -> m a
|
||||
catchServantError :: m a -> (ServantError -> m a) -> m a
|
||||
|
||||
checkContentTypeHeader :: RunClient m => Response -> m MediaType
|
||||
checkContentTypeHeader response =
|
||||
case lookup "Content-Type" $ toList $ responseHeaders response of
|
||||
Nothing -> return $ "application"//"octet-stream"
|
||||
Just t -> case parseAccept t of
|
||||
Nothing -> throwError $ InvalidContentTypeHeader response
|
||||
Nothing -> throwServantError $ InvalidContentTypeHeader response
|
||||
Just t' -> return t'
|
||||
|
||||
decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
|
||||
|
@ -39,9 +40,9 @@ decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
|
|||
decodedAs response contentType = do
|
||||
responseContentType <- checkContentTypeHeader response
|
||||
unless (any (matches responseContentType) accept) $
|
||||
throwError $ UnsupportedContentType responseContentType response
|
||||
throwServantError $ UnsupportedContentType responseContentType response
|
||||
case mimeUnrender contentType $ responseBody response of
|
||||
Left err -> throwError $ DecodeFailure (T.pack err) response
|
||||
Left err -> throwServantError $ DecodeFailure (T.pack err) response
|
||||
Right val -> return val
|
||||
where
|
||||
accept = toList $ contentTypes contentType
|
||||
|
|
|
@ -88,6 +88,8 @@ instance Alt ClientM where
|
|||
|
||||
instance RunClient ClientM where
|
||||
runRequest = performRequest
|
||||
throwServantError = throwError
|
||||
catchServantError = catchError
|
||||
|
||||
instance ClientLike (ClientM a) (ClientM a) where
|
||||
mkClient = id
|
||||
|
|
Loading…
Reference in a new issue