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

keep structured exceptions in `ConnectionError`

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

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)

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)