Use ServantError to report Errors instead of String
This commit is contained in:
Timo von Holtz
parent
83aff1495b
commit
ba46ecc0a9
|
|
@ -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
|
||||
-----
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user