client: correctly handle exceptions on error status codes

servant.cabal

@@ -29,6 +29,7 @@ library
     Servant.API.Raw
     Servant.API.Sub
     Servant.API.Alternative
+    Servant.Utils.Client
     Servant.Utils.Text
   build-depends:
       base >=4.7 && <5

src/Servant/API/Delete.hs

@@ -1,24 +1,24 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 module Servant.API.Delete where
 
-import Control.Monad
-import Control.Monad.IO.Class
 import Control.Monad.Trans.Either
 import Data.Proxy
 import Data.String.Conversions
+import Data.Typeable
 import Network.HTTP.Types
 import Network.URI
 import Network.Wai
 import Servant.Client
 import Servant.Docs
 import Servant.Server
-
+import Servant.Utils.Client
-import qualified Network.HTTP.Client as Client
 
 -- | Endpoint for DELETE requests.
 data Delete
+  deriving Typeable
 
 instance HasServer Delete where
   type Server Delete = EitherT (Int, String) IO ()
@@ -38,17 +38,8 @@ instance HasServer Delete where
 instance HasClient Delete where
   type Client Delete = URIAuth -> EitherT String IO ()
 
-  clientWithRoute Proxy req host = do
+  clientWithRoute Proxy req host =
-    partialRequest <- liftIO $ reqToRequest req host
+    performRequest methodDelete req 204 host
-
-    let request = partialRequest { Client.method = methodDelete
-                                 }
-
-    innerResponse <- liftIO . __withGlobalManager $ \ manager ->
-      Client.httpLbs request manager
-
-    when (Client.responseStatus innerResponse /= status204) $
-      left ("HTTP DELETE request failed with status: " ++ show (Client.responseStatus innerResponse))
 
 instance HasDocs Delete where
   docsFor Proxy (endpoint, action) =

src/Servant/API/Get.hs

@@ -1,26 +1,26 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 module Servant.API.Get where
 
-import Control.Monad
-import Control.Monad.IO.Class
 import Control.Monad.Trans.Either
 import Data.Aeson
 import Data.Proxy
 import Data.String.Conversions
+import Data.Typeable
 import Network.HTTP.Types
 import Network.URI
 import Network.Wai
 import Servant.Client
 import Servant.Docs
 import Servant.Server
-
+import Servant.Utils.Client
-import qualified Network.HTTP.Client as Client
 
 -- | Endpoint for simple GET requests. The server doesn't receive any arguments
 -- and serves the contained type as JSON.
 data Get a
+  deriving Typeable
 
 instance ToJSON result => HasServer (Get result) where
   type Server (Get result) = EitherT (Int, String) IO result
@@ -38,15 +38,8 @@ instance ToJSON result => HasServer (Get result) where
 
 instance FromJSON result => HasClient (Get result) where
   type Client (Get result) = URIAuth -> EitherT String IO result
-  clientWithRoute Proxy req host = do
+  clientWithRoute Proxy req host =
-    innerRequest <- liftIO $ reqToRequest req host
+    performRequest methodGet req 200 host
-
-    innerResponse <- liftIO $ __withGlobalManager $ \ manager ->
-      Client.httpLbs innerRequest manager
-    when (Client.responseStatus innerResponse /= ok200) $
-      left ("HTTP GET request failed with status: " ++ show (Client.responseStatus innerResponse))
-    maybe (left "HTTP GET request returned invalid json") return $
-      decode' (Client.responseBody innerResponse)
 
 instance ToSample a => HasDocs (Get a) where
   docsFor Proxy (endpoint, action) =

src/Servant/API/Post.hs

@@ -1,27 +1,27 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 module Servant.API.Post where
 
-import Control.Monad
-import Control.Monad.IO.Class
 import Control.Monad.Trans.Either
 import Data.Aeson
 import Data.Proxy
 import Data.String.Conversions
+import Data.Typeable
 import Network.HTTP.Types
 import Network.URI
 import Network.Wai
 import Servant.Client
 import Servant.Docs
 import Servant.Server
-
+import Servant.Utils.Client
-import qualified Network.HTTP.Client as Client
 
 -- | Endpoint for POST requests. The type variable represents the type of the
 -- response body (not the request body, use 'Servant.API.RQBody.RQBody' for
 -- that).
 data Post a
+  deriving Typeable
 
 instance ToJSON a => HasServer (Post a) where
   type Server (Post a) = EitherT (Int, String) IO a
@@ -41,20 +41,8 @@ instance ToJSON a => HasServer (Post a) where
 instance FromJSON a => HasClient (Post a) where
   type Client (Post a) = URIAuth -> EitherT String IO a
 
-  clientWithRoute Proxy req uri = do
+  clientWithRoute Proxy req uri =
-    partialRequest <- liftIO $ reqToRequest req uri
+    performRequest methodPost req 201 uri
-
-    let request = partialRequest { Client.method = methodPost
-                                 }
-
-    innerResponse <- liftIO . __withGlobalManager $ \ manager ->
-      Client.httpLbs request manager
-
-    when (Client.responseStatus innerResponse /= status201) $
-      left ("HTTP POST request failed with status: " ++ show (Client.responseStatus innerResponse))
-
-    maybe (left "HTTP POST request returned invalid json") return $
-      decode' (Client.responseBody innerResponse)
 
 instance ToSample a => HasDocs (Post a) where
   docsFor Proxy (endpoint, action) =

src/Servant/API/Put.hs

@@ -1,25 +1,25 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 module Servant.API.Put where
 
-import Control.Monad
-import Control.Monad.IO.Class
 import Control.Monad.Trans.Either
 import Data.Aeson
 import Data.Proxy
 import Data.String.Conversions
+import Data.Typeable
 import Network.HTTP.Types
 import Network.URI
 import Network.Wai
 import Servant.Client
 import Servant.Docs
 import Servant.Server
-
+import Servant.Utils.Client
-import qualified Network.HTTP.Client as Client
 
 -- | Endpoint for PUT requests.
 data Put a
+  deriving Typeable
 
 instance ToJSON a => HasServer (Put a) where
   type Server (Put a) = EitherT (Int, String) IO a
@@ -40,20 +40,8 @@ instance ToJSON a => HasServer (Put a) where
 instance FromJSON a => HasClient (Put a) where
   type Client (Put a) = URIAuth -> EitherT String IO a
 
-  clientWithRoute Proxy req uri = do
+  clientWithRoute Proxy req host =
-    partialRequest <- liftIO $ reqToRequest req uri
+    performRequest methodPut req 200 host
-
-    let request = partialRequest { Client.method = methodPut
-                                 }
-
-    innerResponse <- liftIO . __withGlobalManager $ \ manager ->
-      Client.httpLbs request manager
-
-    when (Client.responseStatus innerResponse /= ok200) $
-      left ("HTTP PUT request failed with status: " ++ show (Client.responseStatus innerResponse))
-
-    maybe (left "HTTP PUT request returned invalid json") return $
-      decode' (Client.responseBody innerResponse)
 
 instance ToSample a => HasDocs (Put a) where
   docsFor Proxy (endpoint, action) =

src/Servant/Utils/Client.hs

@@ -0,0 +1,48 @@
+module Servant.Utils.Client where
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Either
+import Data.Aeson
+import Data.String.Conversions
+import Network.HTTP.Types
+import Network.URI
+import Servant.Client
+
+import qualified Network.HTTP.Client as Client
+
+performRequest :: FromJSON result =>
+  Method -> Req -> Int -> URIAuth -> EitherT String IO result
+performRequest method req wantedStatus host = do
+  partialRequest <- liftIO $ reqToRequest req host
+
+  let request = partialRequest { Client.method = method
+                               }
+
+  eResponse <- liftIO $ __withGlobalManager $ \ manager ->
+    catchStatusCodeException $
+    Client.httpLbs request manager
+  case eResponse of
+    Left status ->
+      left (requestString ++ " failed with status: " ++ showStatus status)
+
+    Right response -> do
+      let status = Client.responseStatus response
+      when (statusCode status /= wantedStatus) $
+        left (requestString ++ " failed with status: " ++ showStatus status)
+      result <- maybe (left (requestString ++ " returned invalid json")) return $
+        decode' (Client.responseBody response)
+      return result
+  where
+    requestString = "HTTP " ++ cs method ++ " request"
+    showStatus (Status code message) =
+      show code ++ " - " ++ cs message
+
+catchStatusCodeException :: IO a -> IO (Either Status a)
+catchStatusCodeException action = catch (Right <$> action) $
+  \ e -> case e of
+    Client.StatusCodeException status _ _ ->
+      return $ Left status
+    e -> throwIO e

test/Servant/ClientSpec.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Servant.ClientSpec where
 
@@ -7,6 +9,7 @@ import Control.Concurrent
 import Control.Exception
 import Control.Monad.Trans.Either
 import Data.Proxy
+import Data.Typeable
 import Network.Socket
 import Network.URI
 import Network.Wai
@@ -23,6 +26,7 @@ type Api =
        "get" :> Get Person
   :<|> "capture" :> Capture "name" String :> Get Person
   :<|> "body" :> ReqBody Person :> Post Person
+  :<|> "param" :> QueryParam "name" String :> Get Person
 api :: Proxy Api
 api = Proxy
 
@@ -31,6 +35,10 @@ server = serve api (
        return alice
   :<|> (\ name -> return $ Person name 0)
   :<|> return
+  :<|> (\ name -> case name of
+                   Just "alice" -> return alice
+                   Just name -> left (400, name ++ " not found")
+                   Nothing -> left (400, "missing parameter"))
  )
 
 withServer :: (URIAuth -> IO a) -> IO a
@@ -39,7 +47,8 @@ withServer action = withWaiDaemon (return server) (action . mkHost "localhost")
 getGet :: URIAuth -> EitherT String IO Person
 getCapture :: String -> URIAuth -> EitherT String IO Person
 getBody :: Person -> URIAuth -> EitherT String IO Person
-(getGet :<|> getCapture :<|> getBody) = client api
+getQueryParam :: Maybe String -> URIAuth -> EitherT String IO Person
+(getGet :<|> getCapture :<|> getBody :<|> getQueryParam) = client api
 
 spec :: Spec
 spec = do
@@ -53,6 +62,34 @@ spec = do
     let p = Person "Clara" 42
     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"
+
+  context "client correctly handles error status codes" $ do
+    let test :: WrappedApi -> Spec
+        test (WrappedApi api) =
+          it (show (typeOf api)) $
+          withWaiDaemon (return (serve api (left (500, "error message")))) $
+          \ (mkHost "localhost" -> host) -> do
+            let getResponse :: URIAuth -> EitherT String IO ()
+                getResponse = client api
+            Left result <- runEitherT (getResponse host)
+            result `shouldContain` "error message"
+    mapM_ test $
+      (WrappedApi (Proxy :: Proxy Delete)) :
+      (WrappedApi (Proxy :: Proxy (Get ()))) :
+      (WrappedApi (Proxy :: Proxy (Post ()))) :
+      (WrappedApi (Proxy :: Proxy (Put ()))) :
+      []
+
+data WrappedApi where
+  WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
+                 HasClient api, Client api ~ (URIAuth -> EitherT String IO ()),
+                 Typeable api) =>
+    Proxy api -> WrappedApi
+
 
 -- * utils