82a2c1f · typeable/servant

git.iko.soy/typeable/servant

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.

commit82a2c1f463200a4aa69079d87982b129f710c9bb authorClement Delafargue <clement.delafargue@fretlink.com> dateThu 31 Jan 2019, 16:51 (8 years ago) parentfdd1c73

3 files changed+42−9

compare with master

unifiedsplit

servant-client-core/src/Servant/Client/Core/Internal/Request.hs+22−6 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+22−6

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

@@ -66,19 +68,33 @@ 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 _ == ConnectionError _ = True

80+

81+ -- prevent wild card blindness

82+ FailureResponse {} == _ = False

83+ DecodeFailure {} == _ = False

84+ UnsupportedContentType {} == _ = False

85+ InvalidContentTypeHeader {} == _ = False

86+ ConnectionError {} == _ = False

7187

7288instance Exception ServantError

7389

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

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

7492instance NFData ServantError where

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

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

77− rnf (UnsupportedContentType mt' res) =

78− mediaTypeRnf mt' `seq`

79− rnf res

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

8096 rnf (InvalidContentTypeHeader res) = rnf res

81− rnf (ConnectionError err) = rnf err

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

8298

8399mediaTypeRnf :: MediaType -> ()

84100mediaTypeRnf 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)