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 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 =

View file

@ -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)

View file

@ -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)