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/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/src/Servant/Client.hs b/src/Servant/Client.hs index 46887186..f6b097a8 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,9 +118,9 @@ 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 + 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 @@ -165,20 +164,20 @@ 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 + 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' -- 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 + 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 @@ -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..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 @@ -27,6 +27,30 @@ import System.IO.Unsafe import qualified Network.HTTP.Client as Client +data ServantError + = 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 { reqPath :: String , qs :: QueryText @@ -109,7 +133,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 +142,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) body 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 + performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` 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..f3fb67c3 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -5,9 +5,13 @@ {-# 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 +import qualified Control.Arrow as Arrow import Control.Concurrent import Control.Exception import Control.Monad.Trans.Either @@ -19,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 @@ -29,7 +34,6 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Servant.API -import Servant.API.ContentTypes import Servant.Client import Servant.Server @@ -58,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 @@ -110,21 +118,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 @@ -140,65 +148,82 @@ 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 - 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{..} <- runEitherT (getQueryParam (Just "bob") host) + responseStatus `shouldBe` Status 400 "bob not found" 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 - 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 - 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,20 +234,52 @@ 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{..} <- runEitherT (getResponse host) + 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 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 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 + 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, - HasClient api, Client api ~ (BaseUrl -> EitherT String IO ())) => + HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) => Proxy api -> WrappedApi