From ba46ecc0a9cfba1ac2d5fd8286df8416f8a367ea Mon Sep 17 00:00:00 2001
From: Timo von Holtz <tvh@anchor.com.au>
Date: Thu, 5 Mar 2015 12:46:35 +1100
Subject: [PATCH] Use `ServantError` to report Errors instead of `String`

---
 CHANGELOG.md               |  1 +
 src/Servant/Client.hs      | 13 ++++----
 src/Servant/Common/Req.hs  | 44 ++++++++++++++------------
 test/Servant/ClientSpec.hs | 65 ++++++++++++++++++++------------------
 4 files changed, 65 insertions(+), 58 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 0d76c9d4..4fe8131d 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -3,6 +3,7 @@
 * Support content-type aware combinators and `Accept`/`Content-type` headers
 * Added a lot of tests
 * Support multiple concurrent threads
+* Use `ServantError` to report Errors instead of `String`
 
 0.2.2
 -----
diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs
index 46887186..4479223e 100644
--- a/src/Servant/Client.hs
+++ b/src/Servant/Client.hs
@@ -11,12 +11,12 @@
 module Servant.Client
   ( client
   , HasClient(..)
+  , ServantError(..)
   , module Servant.Common.BaseUrl
   ) where
 
 import Control.Monad
 import Control.Monad.Trans.Either
-import Data.Aeson
 import Data.ByteString.Lazy (ByteString)
 import Data.List
 import Data.Proxy
@@ -29,7 +29,6 @@ import Servant.API
 import Servant.API.ContentTypes
 import Servant.Common.BaseUrl
 import Servant.Common.Req
-import Servant.Common.Text
 
 -- * Accessing APIs as a Client
 
@@ -109,7 +108,7 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
 -- will just require an argument that specifies the scheme, host
 -- and port to send the request to.
 instance HasClient Delete where
-  type Client Delete = BaseUrl -> EitherT String IO ()
+  type Client Delete = BaseUrl -> EitherT ServantError IO ()
 
   clientWithRoute Proxy req host =
     void $ performRequest H.methodDelete req (== 204) host
@@ -119,7 +118,7 @@ instance HasClient Delete where
 -- will just require an argument that specifies the scheme, host
 -- and port to send the request to.
 instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
-  type Client (Get (ct ': cts) result) = BaseUrl -> EitherT String IO result
+  type Client (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
   clientWithRoute Proxy req host =
     performRequestCT (Proxy :: Proxy ct) H.methodGet req 200 host
 
@@ -165,7 +164,7 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
 -- will just require an argument that specifies the scheme, host
 -- and port to send the request to.
 instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
-  type Client (Post (ct ': cts) a) = BaseUrl -> EitherT String IO a
+  type Client (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
 
   clientWithRoute Proxy req uri =
     performRequestCT (Proxy :: Proxy ct) H.methodPost req 201 uri
@@ -175,7 +174,7 @@ instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
 -- will just require an argument that specifies the scheme, host
 -- and port to send the request to.
 instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
-  type Client (Put (ct ': cts) a) = BaseUrl -> EitherT String IO a
+  type Client (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
 
   clientWithRoute Proxy req host =
     performRequestCT (Proxy :: Proxy ct) H.methodPut req 200 host
@@ -414,7 +413,7 @@ instance (KnownSymbol sym, HasClient sublayout)
 -- | Pick a 'Method' and specify where the server you want to query is. You get
 -- back the status code and the response body as a 'ByteString'.
 instance HasClient Raw where
-  type Client Raw = H.Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType)
+  type Client Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType)
 
   clientWithRoute :: Proxy Raw -> Req -> Client Raw
   clientWithRoute Proxy req httpMethod host =
diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs
index 3f27469c..7405e5cd 100644
--- a/src/Servant/Common/Req.hs
+++ b/src/Servant/Common/Req.hs
@@ -27,6 +27,14 @@ import System.IO.Unsafe
 
 import qualified Network.HTTP.Client as Client
 
+data ServantError
+  = FailureResponse Status MediaType ByteString
+  | DecodeFailure String MediaType ByteString
+  | UnsupportedContentType MediaType ByteString
+  | ConnectionError HttpException
+  | InvalidContentTypeHeader String
+  deriving (Show)
+
 data Req = Req
   { reqPath   :: String
   , qs        :: QueryText
@@ -109,7 +117,7 @@ displayHttpRequest :: Method -> String
 displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
 
 
-performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType)
+performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType)
 performRequest reqMethod req isWantedStatus reqHost = do
   partialRequest <- liftIO $ reqToRequest req reqHost
 
@@ -118,43 +126,39 @@ performRequest reqMethod req isWantedStatus reqHost = do
                                }
 
   eResponse <- liftIO $ __withGlobalManager $ \ manager ->
-    catchStatusCodeException $
+    catchHttpException $
     Client.httpLbs request manager
   case eResponse of
-    Left status ->
-      left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
+    Left err ->
+      left $ ConnectionError err
 
     Right response -> do
       let status = Client.responseStatus response
-      unless (isWantedStatus (statusCode status)) $
-        left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
+          body = Client.responseBody response
+          status_code = statusCode status
       ct <- case lookup "Content-Type" $ Client.responseHeaders response of
                  Nothing -> pure $ "application"//"octet-stream"
                  Just t -> case parseAccept t of
-                   Nothing -> left $ "invalid Content-Type header: " <> cs t
+                   Nothing -> left . InvalidContentTypeHeader . cs $ t
                    Just t' -> pure t'
-      return (statusCode status, Client.responseBody response, ct)
-  where
-    showStatus (Status code message) =
-      show code ++ " - " ++ cs message
+      unless (isWantedStatus status_code) $
+        left $ FailureResponse status ct body
+      return (status_code, body, ct)
 
 performRequestCT :: MimeUnrender ct result =>
-  Proxy ct -> Method -> Req -> Int -> BaseUrl -> EitherT String IO result
+  Proxy ct -> Method -> Req -> Int -> BaseUrl -> EitherT ServantError IO result
 performRequestCT ct reqMethod req wantedStatus reqHost = do
   let acceptCT = contentType ct
   (_status, respBody, respCT) <-
     performRequest reqMethod (req { reqAccept = [acceptCT] }) (== wantedStatus) reqHost
   unless (matches respCT (acceptCT)) $
-    left $ "requested Content-Type " <> show acceptCT <> ", but got " <> show respCT
+    left $ UnsupportedContentType respCT respBody
   either
-    (left . ((displayHttpRequest reqMethod ++ " returned invalid response of type" ++ show respCT) ++))
+    (left . (\s -> DecodeFailure s respCT respBody))
     return
     (fromByteString ct respBody)
 
 
-catchStatusCodeException :: IO a -> IO (Either Status a)
-catchStatusCodeException action =
-  catch (Right <$> action) $ \e ->
-    case e of
-      Client.StatusCodeException status _ _ -> return $ Left status
-      exc -> throwIO exc
+catchHttpException :: IO a -> IO (Either HttpException a)
+catchHttpException action =
+  catch (Right <$> action) (pure . Left)
diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs
index 063c6345..51abeacc 100644
--- a/test/Servant/ClientSpec.hs
+++ b/test/Servant/ClientSpec.hs
@@ -8,6 +8,8 @@
 {-# OPTIONS_GHC -fcontext-stack=25 #-}
 module Servant.ClientSpec where
 
+import Control.Applicative
+import qualified Control.Arrow as Arrow
 import Control.Concurrent
 import Control.Exception
 import Control.Monad.Trans.Either
@@ -29,7 +31,6 @@ import Test.Hspec.QuickCheck
 import Test.QuickCheck
 
 import Servant.API
-import Servant.API.ContentTypes
 import Servant.Client
 import Servant.Server
 
@@ -110,21 +111,21 @@ server = serve api (
 withServer :: (BaseUrl -> IO a) -> IO a
 withServer action = withWaiDaemon (return server) action
 
-getGet :: BaseUrl -> EitherT String IO Person
-getDelete :: BaseUrl -> EitherT String IO ()
-getCapture :: String -> BaseUrl -> EitherT String IO Person
-getBody :: Person -> BaseUrl -> EitherT String IO Person
-getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person
-getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person]
-getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool
-getMatrixParam :: Maybe String -> BaseUrl -> EitherT String IO Person
-getMatrixParams :: [String] -> BaseUrl -> EitherT String IO [Person]
-getMatrixFlag :: Bool -> BaseUrl -> EitherT String IO Bool
-getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType)
-getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType)
+getGet :: BaseUrl -> EitherT ServantError IO Person
+getDelete :: BaseUrl -> EitherT ServantError IO ()
+getCapture :: String -> BaseUrl -> EitherT ServantError IO Person
+getBody :: Person -> BaseUrl -> EitherT ServantError IO Person
+getQueryParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
+getQueryParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
+getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
+getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
+getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
+getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
+getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType)
+getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType)
 getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
   -> BaseUrl
-  -> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])])
+  -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
 (     getGet
  :<|> getDelete
  :<|> getCapture
@@ -143,32 +144,32 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
 spec :: Spec
 spec = do
   it "Servant.API.Get" $ withServer $ \ host -> do
-    runEitherT (getGet host) `shouldReturn` Right alice
+    (Arrow.left show <$> runEitherT (getGet host)) `shouldReturn` Right alice
 
   it "Servant.API.Delete" $ withServer $ \ host -> do
-    runEitherT (getDelete host) `shouldReturn` Right ()
+    (Arrow.left show <$> runEitherT (getDelete host)) `shouldReturn` Right ()
 
   it "Servant.API.Capture" $ withServer $ \ host -> do
-    runEitherT (getCapture "Paula" host) `shouldReturn` Right (Person "Paula" 0)
+    (Arrow.left show <$> runEitherT (getCapture "Paula" host)) `shouldReturn` Right (Person "Paula" 0)
 
   it "Servant.API.ReqBody" $ withServer $ \ host -> do
     let p = Person "Clara" 42
-    runEitherT (getBody p host) `shouldReturn` Right p
+    (Arrow.left show <$> runEitherT (getBody p host)) `shouldReturn` Right p
 
   it "Servant.API.QueryParam" $ withServer $ \ host -> do
-    runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice
-    Left result <- runEitherT (getQueryParam (Just "bob") host)
-    result `shouldContain` "bob not found"
+    (Arrow.left show <$> runEitherT (getQueryParam (Just "alice") host)) `shouldReturn` Right alice
+    Left (FailureResponse s _ _) <- runEitherT (getQueryParam (Just "bob") host)
+    statusCode s `shouldBe` 400
 
   it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do
-    runEitherT (getQueryParams [] host) `shouldReturn` Right []
-    runEitherT (getQueryParams ["alice", "bob"] host)
+    (Arrow.left show <$> runEitherT (getQueryParams [] host)) `shouldReturn` Right []
+    (Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"] host))
       `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
 
   context "Servant.API.QueryParam.QueryFlag" $
     forM_ [False, True] $ \ flag ->
     it (show flag) $ withServer $ \ host -> do
-      runEitherT (getQueryFlag flag host) `shouldReturn` Right flag
+      (Arrow.left show <$> runEitherT (getQueryFlag flag host)) `shouldReturn` Right flag
 
 {-
   it "Servant.API.MatrixParam" $ withServer $ \ host -> do
@@ -188,17 +189,19 @@ spec = do
 -}
 
   it "Servant.API.Raw on success" $ withServer $ \ host -> do
-    runEitherT (getRawSuccess methodGet host) `shouldReturn` Right (200, "rawSuccess", "application"//"octet-stream")
+    (Arrow.left show <$> runEitherT (getRawSuccess methodGet host))
+      `shouldReturn` Right (200, "rawSuccess", "application"//"octet-stream")
 
   it "Servant.API.Raw on failure" $ withServer $ \ host -> do
-    runEitherT (getRawFailure methodGet host) `shouldReturn` Right (400, "rawFailure", "application"//"octet-stream")
+    (Arrow.left show <$> runEitherT (getRawFailure methodGet host))
+      `shouldReturn` Right (400, "rawFailure", "application"//"octet-stream")
 
   modifyMaxSuccess (const 20) $ do
     it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
       property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
         ioProperty $ do
           withServer $ \ host -> do
-            result <- runEitherT (getMultiple cap num flag body host)
+            result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body host)
             return $
               result === Right (cap, num, flag, body)
 
@@ -209,10 +212,10 @@ spec = do
           it desc $
           withWaiDaemon (return (serve api (left (500, "error message")))) $
           \ host -> do
-            let getResponse :: BaseUrl -> EitherT String IO ()
+            let getResponse :: BaseUrl -> EitherT ServantError IO ()
                 getResponse = client api
-            Left result <- runEitherT (getResponse host)
-            result `shouldContain` "error message"
+            Left (FailureResponse status _ _) <- runEitherT (getResponse host)
+            status `shouldBe` (Status 500 "error message")
     mapM_ test $
       (WrappedApi (Proxy :: Proxy Delete), "Delete") :
       (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Delete") :
@@ -222,7 +225,7 @@ spec = do
 
 data WrappedApi where
   WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
-                 HasClient api, Client api ~ (BaseUrl -> EitherT String IO ())) =>
+                 HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
     Proxy api -> WrappedApi