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:
Clement Delafargue 2019-01-31 16:51:03 +01:00 committed by Oleg Grenrus
parent fdd1c7392b
commit 82a2c1f463
3 changed files with 42 additions and 9 deletions

View file

@ -17,6 +17,8 @@ import Prelude.Compat
import Control.DeepSeq
(NFData (..))
import Control.Exception
(SomeException)
import Control.Monad.Catch
(Exception)
import Data.Bifoldable
@ -66,19 +68,33 @@ data ServantError =
-- | The content-type header is invalid
| InvalidContentTypeHeader Response
-- | There was a connection error, and no response was received
| ConnectionError Text
deriving (Eq, Show, Generic, Typeable)
| ConnectionError SomeException
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
-- | Note: an exception in 'ConnectionError' might not be evaluated fully,
-- We only 'rnf' its 'show'ed value.
instance NFData ServantError where
rnf (FailureResponse req res) = rnf req `seq` rnf res
rnf (DecodeFailure err res) = rnf err `seq` rnf res
rnf (UnsupportedContentType mt' res) =
mediaTypeRnf mt' `seq`
rnf res
rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res
rnf (InvalidContentTypeHeader res) = rnf res
rnf (ConnectionError err) = rnf err
rnf (ConnectionError err) = err `seq` rnf (show err)
mediaTypeRnf :: MediaType -> ()
mediaTypeRnf mt =

View file

@ -256,4 +256,4 @@ requestToClientRequest burl r = Client.defaultRequest
catchConnectionError :: IO a -> IO (Either ServantError a)
catchConnectionError action =
catch (Right <$> action) $ \e ->
pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)
pure . Left . ConnectionError $ SomeException (e :: Client.HttpException)

View file

@ -12,6 +12,7 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
@ -33,7 +34,7 @@ import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
(newTVar, readTVar)
import Control.Exception
(bracket)
(bracket, fromException)
import Control.Monad.Error.Class
(throwError)
import Data.Aeson
@ -42,7 +43,7 @@ import Data.Char
import Data.Foldable
(forM_, toList)
import Data.Maybe
(listToMaybe)
(isJust, listToMaybe)
import Data.Monoid ()
import Data.Proxy
import Data.Semigroup
@ -89,6 +90,7 @@ spec = describe "Servant.Client" $ do
genAuthSpec
genericClientSpec
hoistClientSpec
connectionErrorSpec
-- * test data types
@ -531,6 +533,21 @@ hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp
getInt `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
startWaiApp :: Application -> IO (ThreadId, BaseUrl)