Merge pull request #14 from haskell-servant/proper-errors
Use `ServantError` to report Errors instead of `String`
This commit is contained in:
commit
c08baabfdf
5 changed files with 152 additions and 74 deletions
|
@ -3,6 +3,7 @@
|
||||||
* Support content-type aware combinators and `Accept`/`Content-type` headers
|
* Support content-type aware combinators and `Accept`/`Content-type` headers
|
||||||
* Added a lot of tests
|
* Added a lot of tests
|
||||||
* Support multiple concurrent threads
|
* Support multiple concurrent threads
|
||||||
|
* Use `ServantError` to report Errors instead of `String`
|
||||||
|
|
||||||
0.2.2
|
0.2.2
|
||||||
-----
|
-----
|
||||||
|
|
|
@ -71,6 +71,7 @@ test-suite spec
|
||||||
, deepseq
|
, deepseq
|
||||||
, either
|
, either
|
||||||
, hspec == 2.*
|
, hspec == 2.*
|
||||||
|
, http-client
|
||||||
, http-media
|
, http-media
|
||||||
, http-types
|
, http-types
|
||||||
, network >= 2.6
|
, network >= 2.6
|
||||||
|
|
|
@ -11,12 +11,12 @@
|
||||||
module Servant.Client
|
module Servant.Client
|
||||||
( client
|
( client
|
||||||
, HasClient(..)
|
, HasClient(..)
|
||||||
|
, ServantError(..)
|
||||||
, module Servant.Common.BaseUrl
|
, module Servant.Common.BaseUrl
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Trans.Either
|
import Control.Monad.Trans.Either
|
||||||
import Data.Aeson
|
|
||||||
import Data.ByteString.Lazy (ByteString)
|
import Data.ByteString.Lazy (ByteString)
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
|
@ -29,7 +29,6 @@ import Servant.API
|
||||||
import Servant.API.ContentTypes
|
import Servant.API.ContentTypes
|
||||||
import Servant.Common.BaseUrl
|
import Servant.Common.BaseUrl
|
||||||
import Servant.Common.Req
|
import Servant.Common.Req
|
||||||
import Servant.Common.Text
|
|
||||||
|
|
||||||
-- * Accessing APIs as a Client
|
-- * 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
|
-- will just require an argument that specifies the scheme, host
|
||||||
-- and port to send the request to.
|
-- and port to send the request to.
|
||||||
instance HasClient Delete where
|
instance HasClient Delete where
|
||||||
type Client Delete = BaseUrl -> EitherT String IO ()
|
type Client Delete = BaseUrl -> EitherT ServantError IO ()
|
||||||
|
|
||||||
clientWithRoute Proxy req host =
|
clientWithRoute Proxy req host =
|
||||||
void $ performRequest H.methodDelete req (== 204) 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
|
-- will just require an argument that specifies the scheme, host
|
||||||
-- and port to send the request to.
|
-- and port to send the request to.
|
||||||
instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
|
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 =
|
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,
|
-- | If you use a 'Header' in one of your endpoints in your API,
|
||||||
-- the corresponding querying function will automatically take
|
-- 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
|
-- will just require an argument that specifies the scheme, host
|
||||||
-- and port to send the request to.
|
-- and port to send the request to.
|
||||||
instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
|
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 =
|
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
|
-- | If you have a 'Put' endpoint in your API, the client
|
||||||
-- side querying function that is created when calling 'client'
|
-- side querying function that is created when calling 'client'
|
||||||
-- will just require an argument that specifies the scheme, host
|
-- will just require an argument that specifies the scheme, host
|
||||||
-- and port to send the request to.
|
-- and port to send the request to.
|
||||||
instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
|
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 =
|
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,
|
-- | If you use a 'QueryParam' in one of your endpoints in your API,
|
||||||
-- the corresponding querying function will automatically take
|
-- 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
|
-- | 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'.
|
-- back the status code and the response body as a 'ByteString'.
|
||||||
instance HasClient Raw where
|
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 Raw -> Req -> Client Raw
|
||||||
clientWithRoute Proxy req httpMethod host =
|
clientWithRoute Proxy req httpMethod host =
|
||||||
|
|
|
@ -8,7 +8,7 @@ import Control.Monad
|
||||||
import Control.Monad.Catch (MonadThrow)
|
import Control.Monad.Catch (MonadThrow)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Trans.Either
|
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.IORef
|
||||||
import Data.String
|
import Data.String
|
||||||
import Data.String.Conversions
|
import Data.String.Conversions
|
||||||
|
@ -27,6 +27,30 @@ import System.IO.Unsafe
|
||||||
|
|
||||||
import qualified Network.HTTP.Client as Client
|
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
|
data Req = Req
|
||||||
{ reqPath :: String
|
{ reqPath :: String
|
||||||
, qs :: QueryText
|
, qs :: QueryText
|
||||||
|
@ -109,7 +133,7 @@ displayHttpRequest :: Method -> String
|
||||||
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
|
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
|
performRequest reqMethod req isWantedStatus reqHost = do
|
||||||
partialRequest <- liftIO $ reqToRequest req reqHost
|
partialRequest <- liftIO $ reqToRequest req reqHost
|
||||||
|
|
||||||
|
@ -118,43 +142,39 @@ performRequest reqMethod req isWantedStatus reqHost = do
|
||||||
}
|
}
|
||||||
|
|
||||||
eResponse <- liftIO $ __withGlobalManager $ \ manager ->
|
eResponse <- liftIO $ __withGlobalManager $ \ manager ->
|
||||||
catchStatusCodeException $
|
catchHttpException $
|
||||||
Client.httpLbs request manager
|
Client.httpLbs request manager
|
||||||
case eResponse of
|
case eResponse of
|
||||||
Left status ->
|
Left err ->
|
||||||
left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
|
left $ ConnectionError err
|
||||||
|
|
||||||
Right response -> do
|
Right response -> do
|
||||||
let status = Client.responseStatus response
|
let status = Client.responseStatus response
|
||||||
unless (isWantedStatus (statusCode status)) $
|
body = Client.responseBody response
|
||||||
left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
|
status_code = statusCode status
|
||||||
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
|
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
|
||||||
Nothing -> pure $ "application"//"octet-stream"
|
Nothing -> pure $ "application"//"octet-stream"
|
||||||
Just t -> case parseAccept t of
|
Just t -> case parseAccept t of
|
||||||
Nothing -> left $ "invalid Content-Type header: " <> cs t
|
Nothing -> left $ InvalidContentTypeHeader (cs t) body
|
||||||
Just t' -> pure t'
|
Just t' -> pure t'
|
||||||
return (statusCode status, Client.responseBody response, ct)
|
unless (isWantedStatus status_code) $
|
||||||
where
|
left $ FailureResponse status ct body
|
||||||
showStatus (Status code message) =
|
return (status_code, body, ct)
|
||||||
show code ++ " - " ++ cs message
|
|
||||||
|
|
||||||
performRequestCT :: MimeUnrender ct result =>
|
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
|
performRequestCT ct reqMethod req wantedStatus reqHost = do
|
||||||
let acceptCT = contentType ct
|
let acceptCT = contentType ct
|
||||||
(_status, respBody, respCT) <-
|
(_status, respBody, respCT) <-
|
||||||
performRequest reqMethod (req { reqAccept = [acceptCT] }) (== wantedStatus) reqHost
|
performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost
|
||||||
unless (matches respCT (acceptCT)) $
|
unless (matches respCT (acceptCT)) $
|
||||||
left $ "requested Content-Type " <> show acceptCT <> ", but got " <> show respCT
|
left $ UnsupportedContentType respCT respBody
|
||||||
either
|
either
|
||||||
(left . ((displayHttpRequest reqMethod ++ " returned invalid response of type" ++ show respCT) ++))
|
(left . (\s -> DecodeFailure s respCT respBody))
|
||||||
return
|
return
|
||||||
(fromByteString ct respBody)
|
(fromByteString ct respBody)
|
||||||
|
|
||||||
|
|
||||||
catchStatusCodeException :: IO a -> IO (Either Status a)
|
catchHttpException :: IO a -> IO (Either HttpException a)
|
||||||
catchStatusCodeException action =
|
catchHttpException action =
|
||||||
catch (Right <$> action) $ \e ->
|
catch (Right <$> action) (pure . Left)
|
||||||
case e of
|
|
||||||
Client.StatusCodeException status _ _ -> return $ Left status
|
|
||||||
exc -> throwIO exc
|
|
||||||
|
|
|
@ -5,9 +5,13 @@
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# OPTIONS_GHC -fcontext-stack=25 #-}
|
{-# OPTIONS_GHC -fcontext-stack=25 #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
module Servant.ClientSpec where
|
module Servant.ClientSpec where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import qualified Control.Arrow as Arrow
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad.Trans.Either
|
import Control.Monad.Trans.Either
|
||||||
|
@ -19,6 +23,7 @@ import Data.Monoid
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
|
import Network.HTTP.Client (HttpException(..))
|
||||||
import Network.HTTP.Media
|
import Network.HTTP.Media
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Network.Socket
|
import Network.Socket
|
||||||
|
@ -29,7 +34,6 @@ import Test.Hspec.QuickCheck
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
|
|
||||||
import Servant.API
|
import Servant.API
|
||||||
import Servant.API.ContentTypes
|
|
||||||
import Servant.Client
|
import Servant.Client
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
|
||||||
|
@ -58,6 +62,10 @@ instance FromFormUrlEncoded Person where
|
||||||
a <- lookupEither "age" xs
|
a <- lookupEither "age" xs
|
||||||
return $ Person (T.unpack n) (read $ T.unpack a)
|
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 = Person "Alice" 42
|
alice = Person "Alice" 42
|
||||||
|
@ -110,21 +118,21 @@ server = serve api (
|
||||||
withServer :: (BaseUrl -> IO a) -> IO a
|
withServer :: (BaseUrl -> IO a) -> IO a
|
||||||
withServer action = withWaiDaemon (return server) action
|
withServer action = withWaiDaemon (return server) action
|
||||||
|
|
||||||
getGet :: BaseUrl -> EitherT String IO Person
|
getGet :: BaseUrl -> EitherT ServantError IO Person
|
||||||
getDelete :: BaseUrl -> EitherT String IO ()
|
getDelete :: BaseUrl -> EitherT ServantError IO ()
|
||||||
getCapture :: String -> BaseUrl -> EitherT String IO Person
|
getCapture :: String -> BaseUrl -> EitherT ServantError IO Person
|
||||||
getBody :: Person -> BaseUrl -> EitherT String IO Person
|
getBody :: Person -> BaseUrl -> EitherT ServantError IO Person
|
||||||
getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person
|
getQueryParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
|
||||||
getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person]
|
getQueryParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
|
||||||
getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool
|
getQueryFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
|
||||||
getMatrixParam :: Maybe String -> BaseUrl -> EitherT String IO Person
|
getMatrixParam :: Maybe String -> BaseUrl -> EitherT ServantError IO Person
|
||||||
getMatrixParams :: [String] -> BaseUrl -> EitherT String IO [Person]
|
getMatrixParams :: [String] -> BaseUrl -> EitherT ServantError IO [Person]
|
||||||
getMatrixFlag :: Bool -> BaseUrl -> EitherT String IO Bool
|
getMatrixFlag :: Bool -> BaseUrl -> EitherT ServantError IO Bool
|
||||||
getRawSuccess :: Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType)
|
getRawSuccess :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType)
|
||||||
getRawFailure :: Method -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType)
|
getRawFailure :: Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType)
|
||||||
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
|
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
|
||||||
-> BaseUrl
|
-> BaseUrl
|
||||||
-> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])])
|
-> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])
|
||||||
( getGet
|
( getGet
|
||||||
:<|> getDelete
|
:<|> getDelete
|
||||||
:<|> getCapture
|
:<|> getCapture
|
||||||
|
@ -140,65 +148,82 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
|
||||||
:<|> getMultiple)
|
:<|> getMultiple)
|
||||||
= client api
|
= 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 :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
it "Servant.API.Get" $ withServer $ \ host -> 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
|
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
|
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
|
it "Servant.API.ReqBody" $ withServer $ \ host -> do
|
||||||
let p = Person "Clara" 42
|
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
|
it "Servant.API.QueryParam" $ withServer $ \ host -> do
|
||||||
runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice
|
Arrow.left show <$> runEitherT (getQueryParam (Just "alice") host) `shouldReturn` Right alice
|
||||||
Left result <- runEitherT (getQueryParam (Just "bob") host)
|
Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob") host)
|
||||||
result `shouldContain` "bob not found"
|
responseStatus `shouldBe` Status 400 "bob not found"
|
||||||
|
|
||||||
it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do
|
it "Servant.API.QueryParam.QueryParams" $ withServer $ \ host -> do
|
||||||
runEitherT (getQueryParams [] host) `shouldReturn` Right []
|
(Arrow.left show <$> runEitherT (getQueryParams [] host)) `shouldReturn` Right []
|
||||||
runEitherT (getQueryParams ["alice", "bob"] host)
|
(Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"] host))
|
||||||
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
||||||
|
|
||||||
context "Servant.API.QueryParam.QueryFlag" $
|
context "Servant.API.QueryParam.QueryFlag" $
|
||||||
forM_ [False, True] $ \ flag ->
|
forM_ [False, True] $ \ flag ->
|
||||||
it (show flag) $ withServer $ \ host -> do
|
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
|
it "Servant.API.MatrixParam" $ withServer $ \ host -> do
|
||||||
runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice
|
Arrow.left show <$> runEitherT (getMatrixParam (Just "alice") host) `shouldReturn` Right alice
|
||||||
Left result <- runEitherT (getMatrixParam (Just "bob") host)
|
Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob") host)
|
||||||
result `shouldContain` "bob not found"
|
responseStatus `shouldBe` Status 400 "bob not found"
|
||||||
|
|
||||||
it "Servant.API.MatrixParam.MatrixParams" $ withServer $ \ host -> do
|
it "Servant.API.MatrixParam.MatrixParams" $ withServer $ \ host -> do
|
||||||
runEitherT (getMatrixParams [] host) `shouldReturn` Right []
|
Arrow.left show <$> runEitherT (getMatrixParams [] host) `shouldReturn` Right []
|
||||||
runEitherT (getMatrixParams ["alice", "bob"] host)
|
Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"] host)
|
||||||
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
||||||
|
|
||||||
context "Servant.API.MatrixParam.MatrixFlag" $
|
context "Servant.API.MatrixParam.MatrixFlag" $
|
||||||
forM_ [False, True] $ \ flag ->
|
forM_ [False, True] $ \ flag ->
|
||||||
it (show flag) $ withServer $ \ host -> do
|
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
|
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
|
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
|
modifyMaxSuccess (const 20) $ do
|
||||||
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
|
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $
|
||||||
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
|
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
|
||||||
ioProperty $ do
|
ioProperty $ do
|
||||||
withServer $ \ host -> do
|
withServer $ \ host -> do
|
||||||
result <- runEitherT (getMultiple cap num flag body host)
|
result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body host)
|
||||||
return $
|
return $
|
||||||
result === Right (cap, num, flag, body)
|
result === Right (cap, num, flag, body)
|
||||||
|
|
||||||
|
@ -209,20 +234,52 @@ spec = do
|
||||||
it desc $
|
it desc $
|
||||||
withWaiDaemon (return (serve api (left (500, "error message")))) $
|
withWaiDaemon (return (serve api (left (500, "error message")))) $
|
||||||
\ host -> do
|
\ host -> do
|
||||||
let getResponse :: BaseUrl -> EitherT String IO ()
|
let getResponse :: BaseUrl -> EitherT ServantError IO ()
|
||||||
getResponse = client api
|
getResponse = client api
|
||||||
Left result <- runEitherT (getResponse host)
|
Left FailureResponse{..} <- runEitherT (getResponse host)
|
||||||
result `shouldContain` "error message"
|
responseStatus `shouldBe` (Status 500 "error message")
|
||||||
mapM_ test $
|
mapM_ test $
|
||||||
(WrappedApi (Proxy :: Proxy Delete), "Delete") :
|
(WrappedApi (Proxy :: Proxy Delete), "Delete") :
|
||||||
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Delete") :
|
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
|
||||||
(WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Delete") :
|
(WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") :
|
||||||
(WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Delete") :
|
(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
|
data WrappedApi where
|
||||||
WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
|
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
|
Proxy api -> WrappedApi
|
||||||
|
|
||||||
|
|
||||||
|
|
Loading…
Add table
Reference in a new issue