2071042 · typeable/servant

git.iko.soy/typeable/servant

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

keep structured exceptions in `ConnectionError`

commit2071042ebb3632f93f33a1d397b075b19a8ca635 authorOleg Grenrus <oleg.grenrus@iki.fi> dateTue 5 Feb 2019, 14:40 (8 years ago) parentfdd1c73 9cc73f2

3 files changed+46−10

compare with master

unifiedsplit

servant-client-core/src/Servant/Client/Core/Internal/Request.hs+26−7 servant-client/src/Servant/Client/Internal/HttpClient.hs+1−1 servant-client/test/Servant/ClientSpec.hs+19−2

servant-client-core/src/Servant/Client/Core/Internal/Request.hs+26−7

@@ -17,6 +17,8 @@ import Prelude.Compat

1717

1818import Control.DeepSeq

1919 (NFData (..))

20+import Control.Exception

21+ (SomeException (..))

2022import Control.Monad.Catch

2123 (Exception)

2224import Data.Bifoldable

@@ -38,7 +40,7 @@ import Data.Text

3840import Data.Text.Encoding

3941 (encodeUtf8)

4042import Data.Typeable

41− (Typeable)

43+ (Typeable, typeOf)

4244import GHC.Generics

4345 (Generic)

4446import Network.HTTP.Media

@@ -66,19 +68,36 @@ data ServantError =

6668 -- | The content-type header is invalid

6769 | InvalidContentTypeHeader Response

6870 -- | There was a connection error, and no response was received

69− | ConnectionError Text

70− deriving (Eq, Show, Generic, Typeable)

71+ | ConnectionError SomeException

72+ deriving (Show, Generic, Typeable)

73+

74+instance Eq ServantError where

75+ FailureResponse req res == FailureResponse req' res' = req == req' && res == res'

76+ DecodeFailure t r == DecodeFailure t' r' = t == t' && r == r'

77+ UnsupportedContentType mt r == UnsupportedContentType mt' r' = mt == mt' && r == r'

78+ InvalidContentTypeHeader r == InvalidContentTypeHeader r' = r == r'

79+ ConnectionError exc == ConnectionError exc' = eqSomeException exc exc'

80+ where

81+ -- returns true, if type of exception is the same

82+ eqSomeException (SomeException a) (SomeException b) = typeOf a == typeOf b

83+

84+ -- prevent wild card blindness

85+ FailureResponse {} == _ = False

86+ DecodeFailure {} == _ = False

87+ UnsupportedContentType {} == _ = False

88+ InvalidContentTypeHeader {} == _ = False

89+ ConnectionError {} == _ = False

7190

7291instance Exception ServantError

7392

93+-- | Note: an exception in 'ConnectionError' might not be evaluated fully,

94+-- We only 'rnf' its 'show'ed value.

7495instance NFData ServantError where

7596 rnf (FailureResponse req res) = rnf req `seq` rnf res

7697 rnf (DecodeFailure err res) = rnf err `seq` rnf res

77− rnf (UnsupportedContentType mt' res) =

78− mediaTypeRnf mt' `seq`

79− rnf res

98+ rnf (UnsupportedContentType mt' res) = mediaTypeRnf mt' `seq` rnf res

8099 rnf (InvalidContentTypeHeader res) = rnf res

81− rnf (ConnectionError err) = rnf err

100+ rnf (ConnectionError err) = err `seq` rnf (show err)

82101

83102mediaTypeRnf :: MediaType -> ()

84103mediaTypeRnf mt =

servant-client/src/Servant/Client/Internal/HttpClient.hs+1−1

@@ -256,4 +256,4 @@ requestToClientRequest burl r = Client.defaultRequest

256256catchConnectionError :: IO a -> IO (Either ServantError a)

257257catchConnectionError action =

258258 catch (Right <$> action) $ \e ->

259− pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)

259+ pure . Left . ConnectionError $ SomeException (e :: Client.HttpException)

servant-client/test/Servant/ClientSpec.hs+19−2

@@ -12,6 +12,7 @@

1212{-# LANGUAGE RecordWildCards #-}

1313{-# LANGUAGE ScopedTypeVariables #-}

1414{-# LANGUAGE StandaloneDeriving #-}

15+{-# LANGUAGE TypeApplications #-}

1516{-# LANGUAGE TypeFamilies #-}

1617{-# LANGUAGE TypeOperators #-}

1718{-# LANGUAGE UndecidableInstances #-}

@@ -33,7 +34,7 @@ import Control.Concurrent.STM

3334import Control.Concurrent.STM.TVar

3435 (newTVar, readTVar)

3536import Control.Exception

36− (bracket)

37+ (bracket, fromException)

3738import Control.Monad.Error.Class

3839 (throwError)

3940import Data.Aeson

@@ -42,7 +43,7 @@ import Data.Char

4243import Data.Foldable

4344 (forM_, toList)

4445import Data.Maybe

45− (listToMaybe)

46+ (isJust, listToMaybe)

4647import Data.Monoid ()

4748import Data.Proxy

4849import Data.Semigroup

@@ -89,6 +90,7 @@ spec = describe "Servant.Client" $ do

8990 genAuthSpec

9091 genericClientSpec

9192 hoistClientSpec

93+ connectionErrorSpec

9294

9395-- * test data types

9496

@@ -531,6 +533,21 @@ hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp

531533 getInt `shouldReturn` 5

532534 postInt 5 `shouldReturn` 5

533535

536+-- * ConnectionError

537+type ConnectionErrorAPI = Get '[JSON] Int

538+

539+connectionErrorAPI :: Proxy ConnectionErrorAPI

540+connectionErrorAPI = Proxy

541+

542+connectionErrorSpec :: Spec

543+connectionErrorSpec = describe "Servant.Client.ServantError" $

544+ it "correctly catches ConnectionErrors when the HTTP request can't go through" $ do

545+ let getInt = client connectionErrorAPI

546+ let baseUrl' = BaseUrl Http "example.invalid" 80 ""

547+ let isHttpError (Left (ConnectionError e)) = isJust $ fromException @C.HttpException e

548+ isHttpError _ = False

549+ (isHttpError <$> runClient getInt baseUrl') `shouldReturn` True

550+

534551-- * utils

535552

536553startWaiApp :: Application -> IO (ThreadId, BaseUrl)