From ba46ecc0a9cfba1ac2d5fd8286df8416f8a367ea Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Thu, 5 Mar 2015 12:46:35 +1100 Subject: [PATCH 1/6] 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 From 8015906b53816d004a59f24d53f3797d3e3e96a3 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Mon, 9 Mar 2015 08:37:09 +1100 Subject: [PATCH 2/6] Record accessors for ServantError --- src/Servant/Common/Req.hs | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index 7405e5cd..d97109c2 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -28,11 +28,27 @@ 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 + = FailureResponse + { responseStatus :: Status + , responseContentType :: MediaType + , responseBody :: ByteString + } + | DecodeFailure + { decodeError :: String + , responseContentType :: MediaType + , responseBody :: ByteString + } + | UnsupportedContentType + { responseContentType :: MediaType + , responseBody :: ByteString + } + | ConnectionError + { connectionError :: HttpException + } + | InvalidContentTypeHeader + { responseContentTypeHeader :: ByteString + , responseBody :: ByteString + } deriving (Show) data Req = Req @@ -139,7 +155,7 @@ performRequest reqMethod req isWantedStatus reqHost = do ct <- case lookup "Content-Type" $ Client.responseHeaders response of Nothing -> pure $ "application"//"octet-stream" Just t -> case parseAccept t of - Nothing -> left . InvalidContentTypeHeader . cs $ t + Nothing -> left $ InvalidContentTypeHeader (cs t) body Just t' -> pure t' unless (isWantedStatus status_code) $ left $ FailureResponse status ct body From fe6962d0b955cf0b850b0622ce1dd814dcd4d95b Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Mon, 9 Mar 2015 08:46:57 +1100 Subject: [PATCH 3/6] Adjust existing tests for change in error type --- test/Servant/ClientSpec.hs | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index 51abeacc..812d10c4 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -157,9 +157,9 @@ spec = do (Arrow.left show <$> runEitherT (getBody p host)) `shouldReturn` Right p it "Servant.API.QueryParam" $ withServer $ \ host -> do - (Arrow.left show <$> runEitherT (getQueryParam (Just "alice") host)) `shouldReturn` Right alice - Left (FailureResponse s _ _) <- runEitherT (getQueryParam (Just "bob") host) - statusCode s `shouldBe` 400 + Arrow.left show <$> runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice + Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob") host) + responseStatus `shouldBe` Status 400 "bob not found" it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do (Arrow.left show <$> runEitherT (getQueryParams [] host)) `shouldReturn` Right [] @@ -171,22 +171,20 @@ spec = do it (show flag) $ withServer $ \ host -> do (Arrow.left show <$> runEitherT (getQueryFlag flag host)) `shouldReturn` Right flag -{- it "Servant.API.MatrixParam" $ withServer $ \ host -> do - runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice - Left result <- runEitherT (getMatrixParam (Just "bob") host) - result `shouldContain` "bob not found" + Arrow.left show <$> runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice + Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob") host) + responseStatus `shouldBe` Status 400 "bob not found" it "Servant.API.MatrixParam.MatrixParams" $ withServer $ \ host -> do - runEitherT (getMatrixParams [] host) `shouldReturn` Right [] - runEitherT (getMatrixParams ["alice", "bob"] host) + Arrow.left show <$> runEitherT (getMatrixParams [] host) `shouldReturn` Right [] + Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"] host) `shouldReturn` Right [Person "alice" 0, Person "bob" 1] context "Servant.API.MatrixParam.MatrixFlag" $ forM_ [False, True] $ \ flag -> it (show flag) $ withServer $ \ host -> do - runEitherT (getMatrixFlag flag host) `shouldReturn` Right flag --} + Arrow.left show <$> runEitherT (getMatrixFlag flag host) `shouldReturn` Right flag it "Servant.API.Raw on success" $ withServer $ \ host -> do (Arrow.left show <$> runEitherT (getRawSuccess methodGet host)) @@ -214,8 +212,8 @@ spec = do \ host -> do let getResponse :: BaseUrl -> EitherT ServantError IO () getResponse = client api - Left (FailureResponse status _ _) <- runEitherT (getResponse host) - status `shouldBe` (Status 500 "error message") + Left FailureResponse{..} <- runEitherT (getResponse host) + responseStatus `shouldBe` (Status 500 "error message") mapM_ test $ (WrappedApi (Proxy :: Proxy Delete), "Delete") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Delete") : From 23311a8f5dec64b49e2caf50d58fbaa65efc8f3a Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Mon, 9 Mar 2015 09:59:40 +1100 Subject: [PATCH 4/6] Some tests for errors --- servant-client.cabal | 1 + test/Servant/ClientSpec.hs | 42 +++++++++++++++++++++++++++++++++++--- 2 files changed, 40 insertions(+), 3 deletions(-) diff --git a/servant-client.cabal b/servant-client.cabal index 77b832b7..b743e1a5 100644 --- a/servant-client.cabal +++ b/servant-client.cabal @@ -71,6 +71,7 @@ test-suite spec , deepseq , either , hspec == 2.* + , http-client , http-media , http-types , network >= 2.6 diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index 812d10c4..b843de4c 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -5,7 +5,9 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fcontext-stack=25 #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.ClientSpec where import Control.Applicative @@ -21,6 +23,7 @@ import Data.Monoid import Data.Proxy import qualified Data.Text as T import GHC.Generics +import Network.HTTP.Client (HttpException(..)) import Network.HTTP.Media import Network.HTTP.Types import Network.Socket @@ -59,6 +62,10 @@ instance FromFormUrlEncoded Person where a <- lookupEither "age" xs return $ Person (T.unpack n) (read $ T.unpack a) +deriving instance Eq ServantError + +instance Eq HttpException where + a == b = show a == show b alice :: Person alice = Person "Alice" 42 @@ -111,6 +118,19 @@ server = serve api ( withServer :: (BaseUrl -> IO a) -> IO a withServer action = withWaiDaemon (return server) action +type FailApi = + "get" :> Get '[FormUrlEncoded] Person +failApi :: Proxy FailApi +failApi = Proxy + +failServer :: Application +failServer = serve failApi ( + return alice + ) + +withFailServer :: (BaseUrl -> IO a) -> IO a +withFailServer action = withWaiDaemon (return failServer) action + getGet :: BaseUrl -> EitherT ServantError IO Person getDelete :: BaseUrl -> EitherT ServantError IO () getCapture :: String -> BaseUrl -> EitherT ServantError IO Person @@ -216,11 +236,27 @@ spec = do responseStatus `shouldBe` (Status 500 "error message") mapM_ test $ (WrappedApi (Proxy :: Proxy Delete), "Delete") : - (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Delete") : - (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Delete") : - (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Delete") : + (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : + (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") : + (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") : [] + context "client returns errors appropriately" $ do + it "reports connection errors" $ do + Right host <- return $ parseBaseUrl "127.0.0.1:987654" + Left (ConnectionError (FailedConnectionException2 "127.0.0.1" 987654 False _)) <- runEitherT (getGet host) + return () + it "reports non-success responses" $ withFailServer $ \ host -> do + Left res <- runEitherT (getDelete host) + case res of + FailureResponse (Status 404 "Not Found") _ _ -> return () + _ -> fail $ "expected 404 response, but got " <> show res + it "reports unsupported content types" $ withFailServer $ \ host -> do + Left res <- runEitherT (getGet host) + case res of + FailureResponse (Status 404 "Not Found") _ _ -> return () + _ -> fail $ "expected 404 response, but got " <> show res + data WrappedApi where WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a, HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) => From 07d84d019c37a2bca97edf5b0ddebc25540c9340 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Mon, 9 Mar 2015 14:38:32 +1100 Subject: [PATCH 5/6] Tests for all reported errors --- test/Servant/ClientSpec.hs | 62 +++++++++++++++++++++++++------------- 1 file changed, 41 insertions(+), 21 deletions(-) diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index b843de4c..f3fb67c3 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -118,19 +118,6 @@ server = serve api ( withServer :: (BaseUrl -> IO a) -> IO a withServer action = withWaiDaemon (return server) action -type FailApi = - "get" :> Get '[FormUrlEncoded] Person -failApi :: Proxy FailApi -failApi = Proxy - -failServer :: Application -failServer = serve failApi ( - return alice - ) - -withFailServer :: (BaseUrl -> IO a) -> IO a -withFailServer action = withWaiDaemon (return failServer) action - getGet :: BaseUrl -> EitherT ServantError IO Person getDelete :: BaseUrl -> EitherT ServantError IO () getCapture :: String -> BaseUrl -> EitherT ServantError IO Person @@ -161,6 +148,23 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] :<|> getMultiple) = client api +type FailApi = + "get" :> Raw + :<|> "capture" :> Capture "name" String :> Raw + :<|> "body" :> Raw +failApi :: Proxy FailApi +failApi = Proxy + +failServer :: Application +failServer = serve failApi ( + (\ _request respond -> respond $ responseLBS ok200 [] "") + :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "") + :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") + ) + +withFailServer :: (BaseUrl -> IO a) -> IO a +withFailServer action = withWaiDaemon (return failServer) action + spec :: Spec spec = do it "Servant.API.Get" $ withServer $ \ host -> do @@ -242,20 +246,36 @@ spec = do [] context "client returns errors appropriately" $ do - it "reports connection errors" $ do - Right host <- return $ parseBaseUrl "127.0.0.1:987654" - Left (ConnectionError (FailedConnectionException2 "127.0.0.1" 987654 False _)) <- runEitherT (getGet host) - return () - it "reports non-success responses" $ withFailServer $ \ host -> do + it "reports FailureResponse" $ withFailServer $ \ host -> do Left res <- runEitherT (getDelete host) case res of FailureResponse (Status 404 "Not Found") _ _ -> return () _ -> fail $ "expected 404 response, but got " <> show res - it "reports unsupported content types" $ withFailServer $ \ host -> do + + it "reports DecodeFailure" $ withFailServer $ \ host -> do + Left res <- runEitherT (getCapture "foo" host) + case res of + DecodeFailure _ ("application/json") _ -> return () + _ -> fail $ "expected DecodeFailure, but got " <> show res + + it "reports ConnectionError" $ do + Right host <- return $ parseBaseUrl "127.0.0.1:987654" Left res <- runEitherT (getGet host) case res of - FailureResponse (Status 404 "Not Found") _ _ -> return () - _ -> fail $ "expected 404 response, but got " <> show res + ConnectionError (FailedConnectionException2 "127.0.0.1" 987654 False _) -> return () + _ -> fail $ "expected ConnectionError, but got " <> show res + + it "reports UnsupportedContentType" $ withFailServer $ \ host -> do + Left res <- runEitherT (getGet host) + case res of + UnsupportedContentType ("application/octet-stream") _ -> return () + _ -> fail $ "expected UnsupportedContentType, but got " <> show res + + it "reports InvalidContentTypeHeader" $ withFailServer $ \ host -> do + Left res <- runEitherT (getBody alice host) + case res of + InvalidContentTypeHeader "fooooo" _ -> return () + _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a, From 74b5bc400c60db477ab9bc11cf7993ed07b8cde0 Mon Sep 17 00:00:00 2001 From: Timo von Holtz Date: Mon, 9 Mar 2015 17:04:31 +1100 Subject: [PATCH 6/6] Allow more response codes without failing --- src/Servant/Client.hs | 6 +++--- src/Servant/Common/Req.hs | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs index 4479223e..f6b097a8 100644 --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -120,7 +120,7 @@ instance HasClient Delete where instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where type Client (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result clientWithRoute Proxy req host = - performRequestCT (Proxy :: Proxy ct) H.methodGet req 200 host + performRequestCT (Proxy :: Proxy ct) H.methodGet req [200] host -- | If you use a 'Header' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -167,7 +167,7 @@ instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where type Client (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a clientWithRoute Proxy req uri = - performRequestCT (Proxy :: Proxy ct) H.methodPost req 201 uri + performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri -- | If you have a 'Put' endpoint in your API, the client -- side querying function that is created when calling 'client' @@ -177,7 +177,7 @@ instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where type Client (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a clientWithRoute Proxy req host = - performRequestCT (Proxy :: Proxy ct) H.methodPut req 200 host + performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs index d97109c2..03e6b71b 100644 --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -8,7 +8,7 @@ import Control.Monad import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class import Control.Monad.Trans.Either -import Data.ByteString.Lazy hiding (pack, filter, map, null) +import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) import Data.IORef import Data.String import Data.String.Conversions @@ -162,11 +162,11 @@ performRequest reqMethod req isWantedStatus reqHost = do return (status_code, body, ct) performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req -> Int -> BaseUrl -> EitherT ServantError 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 + performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost unless (matches respCT (acceptCT)) $ left $ UnsupportedContentType respCT respBody either