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)