Merge pull request #1115 from phadej/1113-structured-connecition-error

keep structured exceptions in `ConnectionError`
This commit is contained in:
Oleg Grenrus 2019-02-05 14:40:02 +02:00 committed by GitHub
commit 2071042ebb
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
3 changed files with 46 additions and 10 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
@ -38,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
@ -66,19 +68,36 @@ 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 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
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)