82a2c1f · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

keep structured exceptions in `ConnectionError`

82a2c1fClement Delafargue8 years ago

servant-client-core/src/Servant/Client/Core/Internal/Request.hs+22−6

compare with master

unifiedsplit

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

18import Control.DeepSeq

19 (NFData (..))

20+import Control.Exception

21+ (SomeException)

20import Control.Monad.Catch

22import Control.Monad.Catch

21 (Exception)

23 (Exception)

22import Data.Bifoldable

24import Data.Bifoldable

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

66 -- | The content-type header is invalid

68 -- | The content-type header is invalid

67 | InvalidContentTypeHeader Response

69 | InvalidContentTypeHeader Response

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

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

69− | ConnectionError Text

71+ | ConnectionError SomeException

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

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 _ == ConnectionError _ = True

80+

81+ -- prevent wild card blindness

82+ FailureResponse {} == _ = False

83+ DecodeFailure {} == _ = False

84+ UnsupportedContentType {} == _ = False

85+ InvalidContentTypeHeader {} == _ = False

86+ ConnectionError {} == _ = False

72instance Exception ServantError

88instance Exception ServantError

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

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

74instance NFData ServantError where

92instance NFData ServantError where

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

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

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

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

77− rnf (UnsupportedContentType mt' res) =

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

78− mediaTypeRnf mt' `seq`

79− rnf res

80 rnf (InvalidContentTypeHeader res) = rnf res

96 rnf (InvalidContentTypeHeader res) = rnf res

81− rnf (ConnectionError err) = rnf err

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

83mediaTypeRnf :: MediaType -> ()

99mediaTypeRnf :: MediaType -> ()

84mediaTypeRnf mt =

100mediaTypeRnf mt =

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

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

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

257catchConnectionError action =

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

12{-# LANGUAGE RecordWildCards #-}

13{-# LANGUAGE ScopedTypeVariables #-}

14{-# LANGUAGE StandaloneDeriving #-}

15+{-# LANGUAGE TypeApplications #-}

15{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeOperators #-}

17{-# LANGUAGE TypeOperators #-}

17{-# LANGUAGE UndecidableInstances #-}

18{-# LANGUAGE UndecidableInstances #-}

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

33import Control.Concurrent.STM.TVar

34import Control.Concurrent.STM.TVar

34 (newTVar, readTVar)

35 (newTVar, readTVar)

35import Control.Exception

36import Control.Exception

36− (bracket)

37+ (bracket, fromException)

37import Control.Monad.Error.Class

38import Control.Monad.Error.Class

38 (throwError)

39 (throwError)

39import Data.Aeson

40import Data.Aeson

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

42import Data.Foldable

43import Data.Foldable

43 (forM_, toList)

44 (forM_, toList)

44import Data.Maybe

45import Data.Maybe

45− (listToMaybe)

46+ (isJust, listToMaybe)

46import Data.Monoid ()

47import Data.Monoid ()

47import Data.Proxy

48import Data.Proxy

48import Data.Semigroup

49import Data.Semigroup

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

89 genAuthSpec

90 genAuthSpec

90 genericClientSpec

91 genericClientSpec

91 hoistClientSpec

92 hoistClientSpec

93+ connectionErrorSpec

93-- * test data types

95-- * test data types

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

531 getInt `shouldReturn` 5

533 getInt `shouldReturn` 5

532 postInt 5 `shouldReturn` 5

534 postInt 5 `shouldReturn` 5

533

535

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+

534-- * utils

551-- * utils

535

552

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

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