client: correctly handle exceptions on error status codes

This commit is contained in:
Sönke Hahn 2014-10-30 13:54:00 +00:00
parent a0c675f603
commit a9eeff14bd
7 changed files with 111 additions and 65 deletions

View file

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

View file

@ -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 qualified Network.HTTP.Client as Client
import Servant.Utils.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
partialRequest <- liftIO $ reqToRequest req 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))
clientWithRoute Proxy req host =
performRequest methodDelete req 204 host
instance HasDocs Delete where
docsFor Proxy (endpoint, action) =

View file

@ -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 qualified Network.HTTP.Client as Client
import Servant.Utils.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
innerRequest <- liftIO $ reqToRequest req 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)
clientWithRoute Proxy req host =
performRequest methodGet req 200 host
instance ToSample a => HasDocs (Get a) where
docsFor Proxy (endpoint, action) =

View file

@ -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 qualified Network.HTTP.Client as Client
import Servant.Utils.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
partialRequest <- liftIO $ reqToRequest req 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)
clientWithRoute Proxy req uri =
performRequest methodPost req 201 uri
instance ToSample a => HasDocs (Post a) where
docsFor Proxy (endpoint, action) =

View file

@ -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 qualified Network.HTTP.Client as Client
import Servant.Utils.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
partialRequest <- liftIO $ reqToRequest req uri
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)
clientWithRoute Proxy req host =
performRequest methodPut req 200 host
instance ToSample a => HasDocs (Put a) where
docsFor Proxy (endpoint, action) =

View file

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

View file

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