git.iko.soy/typeable/servant
on master help sign in
client: correctly handle exceptions on error status codes
commita9eeff14bdaf4f5ec540fd6d0168ed61e4c0a4f3 authorSönke Hahn <soenkehahn@gmail.com> dateThu 30 Oct 2014, 13:54 (12 years ago) parenta0c675f
7 files changed+111−65
compare with master
unifiedsplit
servant.cabal+1 src/Servant/API/Delete.hs+6−15 src/Servant/API/Get.hs+6−13 src/Servant/API/Post.hs+6−18 src/Servant/API/Put.hs+6−18 src/Servant/Utils/Client.hs+48 test/Servant/ClientSpec.hs+38−1
servant.cabal+1
@@ -29,6 +29,7 @@ library
2929 Servant.API.Raw
3030 Servant.API.Sub
3131 Servant.API.Alternative
32+ Servant.Utils.Client
3233 Servant.Utils.Text
3334 build-depends:
3435 base >=4.7 && <5
src/Servant/API/Delete.hs+6−15
@@ -1,24 +1,24 @@
11{-# LANGUAGE TypeFamilies #-}
22{-# LANGUAGE OverloadedStrings #-}
33{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE DeriveDataTypeable #-}
45module Servant.API.Delete where
56
6−import Control.Monad
7−import Control.Monad.IO.Class
87import Control.Monad.Trans.Either
98import Data.Proxy
109import Data.String.Conversions
10+import Data.Typeable
1111import Network.HTTP.Types
1212import Network.URI
1313import Network.Wai
1414import Servant.Client
1515import Servant.Docs
1616import Servant.Server
17−
18−import qualified Network.HTTP.Client as Client
17+import Servant.Utils.Client
1918
2019-- | Endpoint for DELETE requests.
2120data Delete
21+ deriving Typeable
2222
2323instance HasServer Delete where
2424 type Server Delete = EitherT (Int, String) IO ()
@@ -38,17 +38,8 @@ instance HasServer Delete where
3838instance HasClient Delete where
3939 type Client Delete = URIAuth -> EitherT String IO ()
4040
41− clientWithRoute Proxy req host = do
42− partialRequest <- liftIO $ reqToRequest req host
43−
44− let request = partialRequest { Client.method = methodDelete
45− }
46−
47− innerResponse <- liftIO . __withGlobalManager $ \ manager ->
48− Client.httpLbs request manager
49−
50− when (Client.responseStatus innerResponse /= status204) $
51− left ("HTTP DELETE request failed with status: " ++ show (Client.responseStatus innerResponse))
41+ clientWithRoute Proxy req host =
42+ performRequest methodDelete req 204 host
5243
5344instance HasDocs Delete where
5445 docsFor Proxy (endpoint, action) =
src/Servant/API/Get.hs+6−13
@@ -1,26 +1,26 @@
11{-# LANGUAGE TypeFamilies #-}
22{-# LANGUAGE OverloadedStrings #-}
33{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE DeriveDataTypeable #-}
45module Servant.API.Get where
56
6−import Control.Monad
7−import Control.Monad.IO.Class
87import Control.Monad.Trans.Either
98import Data.Aeson
109import Data.Proxy
1110import Data.String.Conversions
11+import Data.Typeable
1212import Network.HTTP.Types
1313import Network.URI
1414import Network.Wai
1515import Servant.Client
1616import Servant.Docs
1717import Servant.Server
18−
19−import qualified Network.HTTP.Client as Client
18+import Servant.Utils.Client
2019
2120-- | Endpoint for simple GET requests. The server doesn't receive any arguments
2221-- and serves the contained type as JSON.
2322data Get a
23+ deriving Typeable
2424
2525instance ToJSON result => HasServer (Get result) where
2626 type Server (Get result) = EitherT (Int, String) IO result
@@ -38,15 +38,8 @@ instance ToJSON result => HasServer (Get result) where
3838
3939instance FromJSON result => HasClient (Get result) where
4040 type Client (Get result) = URIAuth -> EitherT String IO result
41− clientWithRoute Proxy req host = do
42− innerRequest <- liftIO $ reqToRequest req host
43−
44− innerResponse <- liftIO $ __withGlobalManager $ \ manager ->
45− Client.httpLbs innerRequest manager
46− when (Client.responseStatus innerResponse /= ok200) $
47− left ("HTTP GET request failed with status: " ++ show (Client.responseStatus innerResponse))
48− maybe (left "HTTP GET request returned invalid json") return $
49− decode' (Client.responseBody innerResponse)
41+ clientWithRoute Proxy req host =
42+ performRequest methodGet req 200 host
5043
5144instance ToSample a => HasDocs (Get a) where
5245 docsFor Proxy (endpoint, action) =
src/Servant/API/Post.hs+6−18
@@ -1,27 +1,27 @@
11{-# LANGUAGE TypeFamilies #-}
22{-# LANGUAGE OverloadedStrings #-}
33{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE DeriveDataTypeable #-}
45module Servant.API.Post where
56
6−import Control.Monad
7−import Control.Monad.IO.Class
87import Control.Monad.Trans.Either
98import Data.Aeson
109import Data.Proxy
1110import Data.String.Conversions
11+import Data.Typeable
1212import Network.HTTP.Types
1313import Network.URI
1414import Network.Wai
1515import Servant.Client
1616import Servant.Docs
1717import Servant.Server
18−
19−import qualified Network.HTTP.Client as Client
18+import Servant.Utils.Client
2019
2120-- | Endpoint for POST requests. The type variable represents the type of the
2221-- response body (not the request body, use 'Servant.API.RQBody.RQBody' for
2322-- that).
2423data Post a
24+ deriving Typeable
2525
2626instance ToJSON a => HasServer (Post a) where
2727 type Server (Post a) = EitherT (Int, String) IO a
@@ -41,20 +41,8 @@ instance ToJSON a => HasServer (Post a) where
4141instance FromJSON a => HasClient (Post a) where
4242 type Client (Post a) = URIAuth -> EitherT String IO a
4343
44− clientWithRoute Proxy req uri = do
45− partialRequest <- liftIO $ reqToRequest req uri
46−
47− let request = partialRequest { Client.method = methodPost
48− }
49−
50− innerResponse <- liftIO . __withGlobalManager $ \ manager ->
51− Client.httpLbs request manager
52−
53− when (Client.responseStatus innerResponse /= status201) $
54− left ("HTTP POST request failed with status: " ++ show (Client.responseStatus innerResponse))
55−
56− maybe (left "HTTP POST request returned invalid json") return $
57− decode' (Client.responseBody innerResponse)
44+ clientWithRoute Proxy req uri =
45+ performRequest methodPost req 201 uri
5846
5947instance ToSample a => HasDocs (Post a) where
6048 docsFor Proxy (endpoint, action) =
src/Servant/API/Put.hs+6−18
@@ -1,25 +1,25 @@
11{-# LANGUAGE TypeFamilies #-}
22{-# LANGUAGE OverloadedStrings #-}
33{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE DeriveDataTypeable #-}
45module Servant.API.Put where
56
6−import Control.Monad
7−import Control.Monad.IO.Class
87import Control.Monad.Trans.Either
98import Data.Aeson
109import Data.Proxy
1110import Data.String.Conversions
11+import Data.Typeable
1212import Network.HTTP.Types
1313import Network.URI
1414import Network.Wai
1515import Servant.Client
1616import Servant.Docs
1717import Servant.Server
18−
19−import qualified Network.HTTP.Client as Client
18+import Servant.Utils.Client
2019
2120-- | Endpoint for PUT requests.
2221data Put a
22+ deriving Typeable
2323
2424instance ToJSON a => HasServer (Put a) where
2525 type Server (Put a) = EitherT (Int, String) IO a
@@ -40,20 +40,8 @@ instance ToJSON a => HasServer (Put a) where
4040instance FromJSON a => HasClient (Put a) where
4141 type Client (Put a) = URIAuth -> EitherT String IO a
4242
43− clientWithRoute Proxy req uri = do
44− partialRequest <- liftIO $ reqToRequest req uri
45−
46− let request = partialRequest { Client.method = methodPut
47− }
48−
49− innerResponse <- liftIO . __withGlobalManager $ \ manager ->
50− Client.httpLbs request manager
51−
52− when (Client.responseStatus innerResponse /= ok200) $
53− left ("HTTP PUT request failed with status: " ++ show (Client.responseStatus innerResponse))
54−
55− maybe (left "HTTP PUT request returned invalid json") return $
56− decode' (Client.responseBody innerResponse)
43+ clientWithRoute Proxy req host =
44+ performRequest methodPut req 200 host
5745
5846instance ToSample a => HasDocs (Put a) where
5947 docsFor Proxy (endpoint, action) =
src/Servant/Utils/Client.hsnew file+48
@@ -0,0 +1,48 @@
1+module Servant.Utils.Client where
2+
3+import Control.Applicative
4+import Control.Exception
5+import Control.Monad
6+import Control.Monad.IO.Class
7+import Control.Monad.Trans.Either
8+import Data.Aeson
9+import Data.String.Conversions
10+import Network.HTTP.Types
11+import Network.URI
12+import Servant.Client
13+
14+import qualified Network.HTTP.Client as Client
15+
16+performRequest :: FromJSON result =>
17+ Method -> Req -> Int -> URIAuth -> EitherT String IO result
18+performRequest method req wantedStatus host = do
19+ partialRequest <- liftIO $ reqToRequest req host
20+
21+ let request = partialRequest { Client.method = method
22+ }
23+
24+ eResponse <- liftIO $ __withGlobalManager $ \ manager ->
25+ catchStatusCodeException $
26+ Client.httpLbs request manager
27+ case eResponse of
28+ Left status ->
29+ left (requestString ++ " failed with status: " ++ showStatus status)
30+
31+ Right response -> do
32+ let status = Client.responseStatus response
33+ when (statusCode status /= wantedStatus) $
34+ left (requestString ++ " failed with status: " ++ showStatus status)
35+ result <- maybe (left (requestString ++ " returned invalid json")) return $
36+ decode' (Client.responseBody response)
37+ return result
38+ where
39+ requestString = "HTTP " ++ cs method ++ " request"
40+ showStatus (Status code message) =
41+ show code ++ " - " ++ cs message
42+
43+catchStatusCodeException :: IO a -> IO (Either Status a)
44+catchStatusCodeException action = catch (Right <$> action) $
45+ \ e -> case e of
46+ Client.StatusCodeException status _ _ ->
47+ return $ Left status
48+ e -> throwIO e
test/Servant/ClientSpec.hs+38−1
@@ -1,5 +1,7 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE TypeOperators #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE ViewPatterns #-}
35
46module Servant.ClientSpec where
57
@@ -7,6 +9,7 @@ import Control.Concurrent
79import Control.Exception
810import Control.Monad.Trans.Either
911import Data.Proxy
12+import Data.Typeable
1013import Network.Socket
1114import Network.URI
1215import Network.Wai
@@ -23,6 +26,7 @@ type Api =
2326 "get" :> Get Person
2427 :<|> "capture" :> Capture "name" String :> Get Person
2528 :<|> "body" :> ReqBody Person :> Post Person
29+ :<|> "param" :> QueryParam "name" String :> Get Person
2630api :: Proxy Api
2731api = Proxy
2832
@@ -31,6 +35,10 @@ server = serve api (
3135 return alice
3236 :<|> (\ name -> return $ Person name 0)
3337 :<|> return
38+ :<|> (\ name -> case name of
39+ Just "alice" -> return alice
40+ Just name -> left (400, name ++ " not found")
41+ Nothing -> left (400, "missing parameter"))
3442 )
3543
3644withServer :: (URIAuth -> IO a) -> IO a
@@ -39,7 +47,8 @@ withServer action = withWaiDaemon (return server) (action . mkHost "localhost")
3947getGet :: URIAuth -> EitherT String IO Person
4048getCapture :: String -> URIAuth -> EitherT String IO Person
4149getBody :: Person -> URIAuth -> EitherT String IO Person
42−(getGet :<|> getCapture :<|> getBody) = client api
50+getQueryParam :: Maybe String -> URIAuth -> EitherT String IO Person
51+(getGet :<|> getCapture :<|> getBody :<|> getQueryParam) = client api
4352
4453spec :: Spec
4554spec = do
@@ -53,6 +62,34 @@ spec = do
5362 let p = Person "Clara" 42
5463 runEitherT (getBody p host) `shouldReturn` Right p
5564
65+ it "Servant.API.QueryParam" $ withServer $ \ host -> do
66+ runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice
67+ Left result <- runEitherT (getQueryParam (Just "bob") host)
68+ result `shouldContain` "bob not found"
69+
70+ context "client correctly handles error status codes" $ do
71+ let test :: WrappedApi -> Spec
72+ test (WrappedApi api) =
73+ it (show (typeOf api)) $
74+ withWaiDaemon (return (serve api (left (500, "error message")))) $
75+ \ (mkHost "localhost" -> host) -> do
76+ let getResponse :: URIAuth -> EitherT String IO ()
77+ getResponse = client api
78+ Left result <- runEitherT (getResponse host)
79+ result `shouldContain` "error message"
80+ mapM_ test $
81+ (WrappedApi (Proxy :: Proxy Delete)) :
82+ (WrappedApi (Proxy :: Proxy (Get ()))) :
83+ (WrappedApi (Proxy :: Proxy (Post ()))) :
84+ (WrappedApi (Proxy :: Proxy (Put ()))) :
85+ []
86+
87+data WrappedApi where
88+ WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
89+ HasClient api, Client api ~ (URIAuth -> EitherT String IO ()),
90+ Typeable api) =>
91+ Proxy api -> WrappedApi
92+
5693
5794-- * utils
5895