keep structured exceptions in ConnectionError
fixes #807 Previously, there were two levels of `SomeException` (see #714). A test makes sure there is only one level of wrapping.
This commit is contained in:
parent
fdd1c7392b
commit
82a2c1f463
3 changed files with 42 additions and 9 deletions
|
@ -17,6 +17,8 @@ import Prelude.Compat
|
||||||
|
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
(NFData (..))
|
(NFData (..))
|
||||||
|
import Control.Exception
|
||||||
|
(SomeException)
|
||||||
import Control.Monad.Catch
|
import Control.Monad.Catch
|
||||||
(Exception)
|
(Exception)
|
||||||
import Data.Bifoldable
|
import Data.Bifoldable
|
||||||
|
@ -66,19 +68,33 @@ data ServantError =
|
||||||
-- | The content-type header is invalid
|
-- | The content-type header is invalid
|
||||||
| InvalidContentTypeHeader Response
|
| InvalidContentTypeHeader Response
|
||||||
-- | There was a connection error, and no response was received
|
-- | There was a connection error, and no response was received
|
||||||
| ConnectionError Text
|
| ConnectionError SomeException
|
||||||
deriving (Eq, Show, Generic, Typeable)
|
deriving (Show, Generic, Typeable)
|
||||||
|
|
||||||
|
instance Eq ServantError where
|
||||||
|
FailureResponse req res == FailureResponse req' res' = req == req' && res == res'
|
||||||
|
DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r'
|
||||||
|
UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'
|
||||||
|
InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r'
|
||||||
|
ConnectionError _ == ConnectionError _ = True
|
||||||
|
|
||||||
|
-- prevent wild card blindness
|
||||||
|
FailureResponse {} == _ = False
|
||||||
|
DecodeFailure {} == _ = False
|
||||||
|
UnsupportedContentType {} == _ = False
|
||||||
|
InvalidContentTypeHeader {} == _ = False
|
||||||
|
ConnectionError {} == _ = False
|
||||||
|
|
||||||
instance Exception ServantError
|
instance Exception ServantError
|
||||||
|
|
||||||
|
-- | Note: an exception in 'ConnectionError' might not be evaluated fully,
|
||||||
|
-- We only 'rnf' its 'show'ed value.
|
||||||
instance NFData ServantError where
|
instance NFData ServantError where
|
||||||
rnf (FailureResponse req res) = rnf req `seq` rnf res
|
rnf (FailureResponse req res) = rnf req `seq` rnf res
|
||||||
rnf (DecodeFailure err res) = rnf err `seq` rnf res
|
rnf (DecodeFailure err res) = rnf err `seq` rnf res
|
||||||
rnf (UnsupportedContentType mt' res) =
|
rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res
|
||||||
mediaTypeRnf mt' `seq`
|
|
||||||
rnf res
|
|
||||||
rnf (InvalidContentTypeHeader res) = rnf res
|
rnf (InvalidContentTypeHeader res) = rnf res
|
||||||
rnf (ConnectionError err) = rnf err
|
rnf (ConnectionError err) = err `seq` rnf (show err)
|
||||||
|
|
||||||
mediaTypeRnf :: MediaType -> ()
|
mediaTypeRnf :: MediaType -> ()
|
||||||
mediaTypeRnf mt =
|
mediaTypeRnf mt =
|
||||||
|
|
|
@ -256,4 +256,4 @@ requestToClientRequest burl r = Client.defaultRequest
|
||||||
catchConnectionError :: IO a -> IO (Either ServantError a)
|
catchConnectionError :: IO a -> IO (Either ServantError a)
|
||||||
catchConnectionError action =
|
catchConnectionError action =
|
||||||
catch (Right <$> action) $ \e ->
|
catch (Right <$> action) $ \e ->
|
||||||
pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)
|
pure . Left . ConnectionError $ SomeException (e :: Client.HttpException)
|
||||||
|
|
|
@ -12,6 +12,7 @@
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
@ -33,7 +34,7 @@ import Control.Concurrent.STM
|
||||||
import Control.Concurrent.STM.TVar
|
import Control.Concurrent.STM.TVar
|
||||||
(newTVar, readTVar)
|
(newTVar, readTVar)
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
(bracket)
|
(bracket, fromException)
|
||||||
import Control.Monad.Error.Class
|
import Control.Monad.Error.Class
|
||||||
(throwError)
|
(throwError)
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
|
@ -42,7 +43,7 @@ import Data.Char
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
(forM_, toList)
|
(forM_, toList)
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
(listToMaybe)
|
(isJust, listToMaybe)
|
||||||
import Data.Monoid ()
|
import Data.Monoid ()
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Data.Semigroup
|
import Data.Semigroup
|
||||||
|
@ -89,6 +90,7 @@ spec = describe "Servant.Client" $ do
|
||||||
genAuthSpec
|
genAuthSpec
|
||||||
genericClientSpec
|
genericClientSpec
|
||||||
hoistClientSpec
|
hoistClientSpec
|
||||||
|
connectionErrorSpec
|
||||||
|
|
||||||
-- * test data types
|
-- * test data types
|
||||||
|
|
||||||
|
@ -531,6 +533,21 @@ hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp
|
||||||
getInt `shouldReturn` 5
|
getInt `shouldReturn` 5
|
||||||
postInt 5 `shouldReturn` 5
|
postInt 5 `shouldReturn` 5
|
||||||
|
|
||||||
|
-- * ConnectionError
|
||||||
|
type ConnectionErrorAPI = Get '[JSON] Int
|
||||||
|
|
||||||
|
connectionErrorAPI :: Proxy ConnectionErrorAPI
|
||||||
|
connectionErrorAPI = Proxy
|
||||||
|
|
||||||
|
connectionErrorSpec :: Spec
|
||||||
|
connectionErrorSpec = describe "Servant.Client.ServantError" $
|
||||||
|
it "correctly catches ConnectionErrors when the HTTP request can't go through" $ do
|
||||||
|
let getInt = client connectionErrorAPI
|
||||||
|
let baseUrl' = BaseUrl Http "example.invalid" 80 ""
|
||||||
|
let isHttpError (Left (ConnectionError e)) = isJust $ fromException @C.HttpException e
|
||||||
|
isHttpError _ = False
|
||||||
|
(isHttpError <$> runClient getInt baseUrl') `shouldReturn` True
|
||||||
|
|
||||||
-- * utils
|
-- * utils
|
||||||
|
|
||||||
startWaiApp :: Application -> IO (ThreadId, BaseUrl)
|
startWaiApp :: Application -> IO (ThreadId, BaseUrl)
|
||||||
|
|
Loading…
Reference in a new issue