From 82a2c1f463200a4aa69079d87982b129f710c9bb Mon Sep 17 00:00:00 2001 From: Clement Delafargue Date: Thu, 31 Jan 2019 16:51:03 +0100 Subject: [PATCH 1/2] 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. --- .../Servant/Client/Core/Internal/Request.hs | 28 +++++++++++++++---- .../src/Servant/Client/Internal/HttpClient.hs | 2 +- servant-client/test/Servant/ClientSpec.hs | 21 ++++++++++++-- 3 files changed, 42 insertions(+), 9 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index 6a32eb9e..4bbde390 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -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 = diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index f489ed0f..9edc6dbf 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -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) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 96b4172c..a03fa44b 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -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) From 9cc73f29ff0c62bec31c1f70a365ca879654a19e Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 5 Feb 2019 12:58:35 +0200 Subject: [PATCH 2/2] Differentiate different exception types --- .../src/Servant/Client/Core/Internal/Request.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs index 4bbde390..ffa1c674 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/Request.hs @@ -18,7 +18,7 @@ import Prelude.Compat import Control.DeepSeq (NFData (..)) import Control.Exception - (SomeException) + (SomeException (..)) import Control.Monad.Catch (Exception) import Data.Bifoldable @@ -40,7 +40,7 @@ import Data.Text import Data.Text.Encoding (encodeUtf8) import Data.Typeable - (Typeable) + (Typeable, typeOf) import GHC.Generics (Generic) import Network.HTTP.Media @@ -76,7 +76,10 @@ instance Eq ServantError where 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 + ConnectionError exc == ConnectionError exc' = eqSomeException exc exc' + where + -- returns true, if type of exception is the same + eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b -- prevent wild card blindness FailureResponse {} == _ = False