Derive HasClient good response status from Verb status (#1469)
This commit is contained in:
parent
cb294aa2b3
commit
29d2553e74
12 changed files with 156 additions and 44 deletions
11
changelog.d/1469
Normal file
11
changelog.d/1469
Normal file
|
@ -0,0 +1,11 @@
|
||||||
|
synopsis: Derive HasClient good response status from Verb status
|
||||||
|
prs: #1469
|
||||||
|
description: {
|
||||||
|
`HasClient` instances for the `Verb` datatype use `runRequest` in
|
||||||
|
`clientWithRoute` definitions.
|
||||||
|
This means that a request performed with `runClientM` will be successful if and
|
||||||
|
only if the endpoint specify a response status code >=200 and <300.
|
||||||
|
This change replaces `runRequest` with `runRequestAcceptStatus` in `Verb`
|
||||||
|
instances for the `HasClient` class, deriving the good response status from
|
||||||
|
the `Verb` status.
|
||||||
|
}
|
|
@ -65,7 +65,7 @@ import Data.Text
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
(Proxy (Proxy))
|
(Proxy (Proxy))
|
||||||
import GHC.TypeLits
|
import GHC.TypeLits
|
||||||
(KnownSymbol, symbolVal)
|
(KnownNat, KnownSymbol, symbolVal)
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
(Status)
|
(Status)
|
||||||
import qualified Network.HTTP.Types as H
|
import qualified Network.HTTP.Types as H
|
||||||
|
@ -86,6 +86,8 @@ import Servant.API.Generic
|
||||||
, GenericServant, toServant, fromServant)
|
, GenericServant, toServant, fromServant)
|
||||||
import Servant.API.ContentTypes
|
import Servant.API.ContentTypes
|
||||||
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
|
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
|
||||||
|
import Servant.API.Status
|
||||||
|
(statusFromNat)
|
||||||
import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
|
import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
|
||||||
import Servant.API.Modifiers
|
import Servant.API.Modifiers
|
||||||
(FoldRequired, RequiredArgument, foldRequiredArgument)
|
(FoldRequired, RequiredArgument, foldRequiredArgument)
|
||||||
|
@ -250,10 +252,11 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
|
||||||
instance {-# OVERLAPPABLE #-}
|
instance {-# OVERLAPPABLE #-}
|
||||||
-- Note [Non-Empty Content Types]
|
-- Note [Non-Empty Content Types]
|
||||||
( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
|
( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
|
||||||
|
, KnownNat status
|
||||||
) => HasClient m (Verb method status cts' a) where
|
) => HasClient m (Verb method status cts' a) where
|
||||||
type Client m (Verb method status cts' a) = m a
|
type Client m (Verb method status cts' a) = m a
|
||||||
clientWithRoute _pm Proxy req = do
|
clientWithRoute _pm Proxy req = do
|
||||||
response <- runRequest req
|
response <- runRequestAcceptStatus (Just [status]) req
|
||||||
{ requestAccept = fromList $ toList accept
|
{ requestAccept = fromList $ toList accept
|
||||||
, requestMethod = method
|
, requestMethod = method
|
||||||
}
|
}
|
||||||
|
@ -261,18 +264,20 @@ instance {-# OVERLAPPABLE #-}
|
||||||
where
|
where
|
||||||
accept = contentTypes (Proxy :: Proxy ct)
|
accept = contentTypes (Proxy :: Proxy ct)
|
||||||
method = reflectMethod (Proxy :: Proxy method)
|
method = reflectMethod (Proxy :: Proxy method)
|
||||||
|
status = statusFromNat (Proxy :: Proxy status)
|
||||||
|
|
||||||
hoistClientMonad _ _ f ma = f ma
|
hoistClientMonad _ _ f ma = f ma
|
||||||
|
|
||||||
instance {-# OVERLAPPING #-}
|
instance {-# OVERLAPPING #-}
|
||||||
( RunClient m, ReflectMethod method
|
( RunClient m, ReflectMethod method, KnownNat status
|
||||||
) => HasClient m (Verb method status cts NoContent) where
|
) => HasClient m (Verb method status cts NoContent) where
|
||||||
type Client m (Verb method status cts NoContent)
|
type Client m (Verb method status cts NoContent)
|
||||||
= m NoContent
|
= m NoContent
|
||||||
clientWithRoute _pm Proxy req = do
|
clientWithRoute _pm Proxy req = do
|
||||||
_response <- runRequest req { requestMethod = method }
|
_response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
|
||||||
return NoContent
|
return NoContent
|
||||||
where method = reflectMethod (Proxy :: Proxy method)
|
where method = reflectMethod (Proxy :: Proxy method)
|
||||||
|
status = statusFromNat (Proxy :: Proxy status)
|
||||||
|
|
||||||
hoistClientMonad _ _ f ma = f ma
|
hoistClientMonad _ _ f ma = f ma
|
||||||
|
|
||||||
|
@ -289,13 +294,13 @@ instance (RunClient m, ReflectMethod method) =>
|
||||||
|
|
||||||
instance {-# OVERLAPPING #-}
|
instance {-# OVERLAPPING #-}
|
||||||
-- Note [Non-Empty Content Types]
|
-- Note [Non-Empty Content Types]
|
||||||
( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
|
( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
|
||||||
, ReflectMethod method, cts' ~ (ct ': cts)
|
, ReflectMethod method, cts' ~ (ct ': cts)
|
||||||
) => HasClient m (Verb method status cts' (Headers ls a)) where
|
) => HasClient m (Verb method status cts' (Headers ls a)) where
|
||||||
type Client m (Verb method status cts' (Headers ls a))
|
type Client m (Verb method status cts' (Headers ls a))
|
||||||
= m (Headers ls a)
|
= m (Headers ls a)
|
||||||
clientWithRoute _pm Proxy req = do
|
clientWithRoute _pm Proxy req = do
|
||||||
response <- runRequest req
|
response <- runRequestAcceptStatus (Just [status]) req
|
||||||
{ requestMethod = method
|
{ requestMethod = method
|
||||||
, requestAccept = fromList $ toList accept
|
, requestAccept = fromList $ toList accept
|
||||||
}
|
}
|
||||||
|
@ -303,22 +308,26 @@ instance {-# OVERLAPPING #-}
|
||||||
return $ Headers { getResponse = val
|
return $ Headers { getResponse = val
|
||||||
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
|
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
|
||||||
}
|
}
|
||||||
where method = reflectMethod (Proxy :: Proxy method)
|
where
|
||||||
accept = contentTypes (Proxy :: Proxy ct)
|
method = reflectMethod (Proxy :: Proxy method)
|
||||||
|
accept = contentTypes (Proxy :: Proxy ct)
|
||||||
|
status = statusFromNat (Proxy :: Proxy status)
|
||||||
|
|
||||||
hoistClientMonad _ _ f ma = f ma
|
hoistClientMonad _ _ f ma = f ma
|
||||||
|
|
||||||
instance {-# OVERLAPPING #-}
|
instance {-# OVERLAPPING #-}
|
||||||
( RunClient m, BuildHeadersTo ls, ReflectMethod method
|
( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
|
||||||
) => HasClient m (Verb method status cts (Headers ls NoContent)) where
|
) => HasClient m (Verb method status cts (Headers ls NoContent)) where
|
||||||
type Client m (Verb method status cts (Headers ls NoContent))
|
type Client m (Verb method status cts (Headers ls NoContent))
|
||||||
= m (Headers ls NoContent)
|
= m (Headers ls NoContent)
|
||||||
clientWithRoute _pm Proxy req = do
|
clientWithRoute _pm Proxy req = do
|
||||||
let method = reflectMethod (Proxy :: Proxy method)
|
response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
|
||||||
response <- runRequest req { requestMethod = method }
|
|
||||||
return $ Headers { getResponse = NoContent
|
return $ Headers { getResponse = NoContent
|
||||||
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
|
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
|
||||||
}
|
}
|
||||||
|
where
|
||||||
|
method = reflectMethod (Proxy :: Proxy method)
|
||||||
|
status = statusFromNat (Proxy :: Proxy status)
|
||||||
|
|
||||||
hoistClientMonad _ _ f ma = f ma
|
hoistClientMonad _ _ f ma = f ma
|
||||||
|
|
||||||
|
|
|
@ -89,6 +89,7 @@ test-suite spec
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
Servant.BasicAuthSpec
|
Servant.BasicAuthSpec
|
||||||
|
Servant.BrokenSpec
|
||||||
Servant.ClientTestUtils
|
Servant.ClientTestUtils
|
||||||
Servant.ConnectionErrorSpec
|
Servant.ConnectionErrorSpec
|
||||||
Servant.FailSpec
|
Servant.FailSpec
|
||||||
|
|
|
@ -63,7 +63,7 @@ import GHC.Generics
|
||||||
import Network.HTTP.Media
|
import Network.HTTP.Media
|
||||||
(renderHeader)
|
(renderHeader)
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
(hContentType, renderQuery, statusCode, urlEncode, Status)
|
(hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)
|
||||||
import Servant.Client.Core
|
import Servant.Client.Core
|
||||||
|
|
||||||
import qualified Network.HTTP.Client as Client
|
import qualified Network.HTTP.Client as Client
|
||||||
|
@ -179,10 +179,9 @@ performRequest acceptStatus req = do
|
||||||
|
|
||||||
response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
|
response <- maybe (requestWithoutCookieJar m request) (requestWithCookieJar m request) cookieJar'
|
||||||
let status = Client.responseStatus response
|
let status = Client.responseStatus response
|
||||||
status_code = statusCode status
|
|
||||||
ourResponse = clientResponseToResponse id response
|
ourResponse = clientResponseToResponse id response
|
||||||
goodStatus = case acceptStatus of
|
goodStatus = case acceptStatus of
|
||||||
Nothing -> status_code >= 200 && status_code < 300
|
Nothing -> statusIsSuccessful status
|
||||||
Just good -> status `elem` good
|
Just good -> status `elem` good
|
||||||
unless goodStatus $ do
|
unless goodStatus $ do
|
||||||
throwError $ mkFailureResponse burl req ourResponse
|
throwError $ mkFailureResponse burl req ourResponse
|
||||||
|
|
|
@ -47,7 +47,7 @@ import Data.Time.Clock
|
||||||
(getCurrentTime)
|
(getCurrentTime)
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
(Status, statusCode)
|
(Status, statusIsSuccessful)
|
||||||
|
|
||||||
import qualified Network.HTTP.Client as Client
|
import qualified Network.HTTP.Client as Client
|
||||||
|
|
||||||
|
@ -163,10 +163,9 @@ performRequest acceptStatus req = do
|
||||||
now' <- getCurrentTime
|
now' <- getCurrentTime
|
||||||
atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
|
atomically $ modifyTVar' cj (fst . Client.updateCookieJar response request now')
|
||||||
let status = Client.responseStatus response
|
let status = Client.responseStatus response
|
||||||
status_code = statusCode status
|
|
||||||
ourResponse = clientResponseToResponse id response
|
ourResponse = clientResponseToResponse id response
|
||||||
goodStatus = case acceptStatus of
|
goodStatus = case acceptStatus of
|
||||||
Nothing -> status_code >= 200 && status_code < 300
|
Nothing -> statusIsSuccessful status
|
||||||
Just good -> status `elem` good
|
Just good -> status `elem` good
|
||||||
unless goodStatus $ do
|
unless goodStatus $ do
|
||||||
throwError $ mkFailureResponse burl req ourResponse
|
throwError $ mkFailureResponse burl req ourResponse
|
||||||
|
@ -182,10 +181,9 @@ performWithStreamingRequest req k = do
|
||||||
ClientM $ lift $ lift $ Codensity $ \k1 ->
|
ClientM $ lift $ lift $ Codensity $ \k1 ->
|
||||||
Client.withResponse request m $ \res -> do
|
Client.withResponse request m $ \res -> do
|
||||||
let status = Client.responseStatus res
|
let status = Client.responseStatus res
|
||||||
status_code = statusCode status
|
|
||||||
|
|
||||||
-- we throw FailureResponse in IO :(
|
-- we throw FailureResponse in IO :(
|
||||||
unless (status_code >= 200 && status_code < 300) $ do
|
unless (statusIsSuccessful status) $ do
|
||||||
b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
|
b <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
|
||||||
throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
|
throwIO $ mkFailureResponse burl req (clientResponseToResponse (const b) res)
|
||||||
|
|
||||||
|
|
71
servant-client/test/Servant/BrokenSpec.hs
Normal file
71
servant-client/test/Servant/BrokenSpec.hs
Normal file
|
@ -0,0 +1,71 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||||
|
|
||||||
|
module Servant.BrokenSpec (spec) where
|
||||||
|
|
||||||
|
import Prelude ()
|
||||||
|
import Prelude.Compat
|
||||||
|
|
||||||
|
import Data.Monoid ()
|
||||||
|
import Data.Proxy
|
||||||
|
import qualified Network.HTTP.Types as HTTP
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
|
import Servant.API
|
||||||
|
((:<|>) ((:<|>)), (:>), JSON, Verb, Get, StdMethod (GET))
|
||||||
|
import Servant.Client
|
||||||
|
import Servant.ClientTestUtils
|
||||||
|
import Servant.Server
|
||||||
|
|
||||||
|
-- * api for testing inconsistencies between client and server
|
||||||
|
|
||||||
|
type Get201 = Verb 'GET 201
|
||||||
|
type Get301 = Verb 'GET 301
|
||||||
|
|
||||||
|
type BrokenAPI =
|
||||||
|
-- the server should respond with 200, but returns 201
|
||||||
|
"get200" :> Get201 '[JSON] ()
|
||||||
|
-- the server should respond with 307, but returns 301
|
||||||
|
:<|> "get307" :> Get301 '[JSON] ()
|
||||||
|
|
||||||
|
brokenApi :: Proxy BrokenAPI
|
||||||
|
brokenApi = Proxy
|
||||||
|
|
||||||
|
brokenServer :: Application
|
||||||
|
brokenServer = serve brokenApi (pure () :<|> pure ())
|
||||||
|
|
||||||
|
type PublicAPI =
|
||||||
|
-- the client expects 200
|
||||||
|
"get200" :> Get '[JSON] ()
|
||||||
|
-- the client expects 307
|
||||||
|
:<|> "get307" :> Get307 '[JSON] ()
|
||||||
|
|
||||||
|
publicApi :: Proxy PublicAPI
|
||||||
|
publicApi = Proxy
|
||||||
|
|
||||||
|
get200Client :: ClientM ()
|
||||||
|
get307Client :: ClientM ()
|
||||||
|
get200Client :<|> get307Client = client publicApi
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = describe "Servant.BrokenSpec" $ do
|
||||||
|
brokenSpec
|
||||||
|
|
||||||
|
brokenSpec :: Spec
|
||||||
|
brokenSpec = beforeAll (startWaiApp brokenServer) $ afterAll endWaiApp $ do
|
||||||
|
context "client returns errors for inconsistencies between client and server api" $ do
|
||||||
|
it "reports FailureResponse with wrong 2xx status code" $ \(_, baseUrl) -> do
|
||||||
|
res <- runClient get200Client baseUrl
|
||||||
|
case res of
|
||||||
|
Left (FailureResponse _ r) | responseStatusCode r == HTTP.status201 -> return ()
|
||||||
|
_ -> fail $ "expected 201 broken response, but got " <> show res
|
||||||
|
|
||||||
|
it "reports FailureResponse with wrong 3xx status code" $ \(_, baseUrl) -> do
|
||||||
|
res <- runClient get307Client baseUrl
|
||||||
|
case res of
|
||||||
|
Left (FailureResponse _ r) | responseStatusCode r == HTTP.status301 -> return ()
|
||||||
|
_ -> fail $ "expected 301 broken response, but got " <> show res
|
|
@ -64,7 +64,7 @@ import Servant.API
|
||||||
JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
|
JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender),
|
||||||
NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
|
NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam,
|
||||||
QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
|
QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union,
|
||||||
WithStatus (WithStatus), NamedRoutes, addHeader)
|
Verb, WithStatus (WithStatus), NamedRoutes, addHeader)
|
||||||
import Servant.API.Generic ((:-))
|
import Servant.API.Generic ((:-))
|
||||||
import Servant.Client
|
import Servant.Client
|
||||||
import qualified Servant.Client.Core.Auth as Auth
|
import qualified Servant.Client.Core.Auth as Auth
|
||||||
|
@ -118,9 +118,16 @@ data OtherRoutes mode = OtherRoutes
|
||||||
{ something :: mode :- "something" :> Get '[JSON] [String]
|
{ something :: mode :- "something" :> Get '[JSON] [String]
|
||||||
} deriving Generic
|
} deriving Generic
|
||||||
|
|
||||||
|
-- Get for HTTP 307 Temporary Redirect
|
||||||
|
type Get307 = Verb 'GET 307
|
||||||
|
|
||||||
type Api =
|
type Api =
|
||||||
Get '[JSON] Person
|
Get '[JSON] Person
|
||||||
:<|> "get" :> Get '[JSON] Person
|
:<|> "get" :> Get '[JSON] Person
|
||||||
|
-- This endpoint returns a response with status code 307 Temporary Redirect,
|
||||||
|
-- different from the ones in the 2xx successful class, to test derivation
|
||||||
|
-- of clients' api.
|
||||||
|
:<|> "get307" :> Get307 '[PlainText] Text
|
||||||
:<|> "deleteEmpty" :> DeleteNoContent
|
:<|> "deleteEmpty" :> DeleteNoContent
|
||||||
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
|
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
|
||||||
:<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
|
:<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
|
||||||
|
@ -154,12 +161,12 @@ type Api =
|
||||||
:<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
|
:<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
|
||||||
:<|> NamedRoutes RecordRoutes
|
:<|> NamedRoutes RecordRoutes
|
||||||
|
|
||||||
|
|
||||||
api :: Proxy Api
|
api :: Proxy Api
|
||||||
api = Proxy
|
api = Proxy
|
||||||
|
|
||||||
getRoot :: ClientM Person
|
getRoot :: ClientM Person
|
||||||
getGet :: ClientM Person
|
getGet :: ClientM Person
|
||||||
|
getGet307 :: ClientM Text
|
||||||
getDeleteEmpty :: ClientM NoContent
|
getDeleteEmpty :: ClientM NoContent
|
||||||
getCapture :: String -> ClientM Person
|
getCapture :: String -> ClientM Person
|
||||||
getCaptureAll :: [String] -> ClientM [Person]
|
getCaptureAll :: [String] -> ClientM [Person]
|
||||||
|
@ -186,6 +193,7 @@ recordRoutes :: RecordRoutes (AsClientT ClientM)
|
||||||
|
|
||||||
getRoot
|
getRoot
|
||||||
:<|> getGet
|
:<|> getGet
|
||||||
|
:<|> getGet307
|
||||||
:<|> getDeleteEmpty
|
:<|> getDeleteEmpty
|
||||||
:<|> getCapture
|
:<|> getCapture
|
||||||
:<|> getCaptureAll
|
:<|> getCaptureAll
|
||||||
|
@ -212,6 +220,7 @@ server :: Application
|
||||||
server = serve api (
|
server = serve api (
|
||||||
return carol
|
return carol
|
||||||
:<|> return alice
|
:<|> return alice
|
||||||
|
:<|> return "redirecting"
|
||||||
:<|> return NoContent
|
:<|> return NoContent
|
||||||
:<|> (\ name -> return $ Person name 0)
|
:<|> (\ name -> return $ Person name 0)
|
||||||
:<|> (\ names -> return (zipWith Person names [0..]))
|
:<|> (\ names -> return (zipWith Person names [0..]))
|
||||||
|
@ -252,6 +261,8 @@ server = serve api (
|
||||||
}
|
}
|
||||||
)
|
)
|
||||||
|
|
||||||
|
-- * api for testing failures
|
||||||
|
|
||||||
type FailApi =
|
type FailApi =
|
||||||
"get" :> Raw
|
"get" :> Raw
|
||||||
:<|> "capture" :> Capture "name" String :> Raw
|
:<|> "capture" :> Capture "name" String :> Raw
|
||||||
|
@ -266,7 +277,7 @@ failServer = serve failApi (
|
||||||
:<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
|
:<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
|
||||||
:<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
|
:<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
|
||||||
:<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
|
:<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "")
|
||||||
)
|
)
|
||||||
|
|
||||||
-- * basic auth stuff
|
-- * basic auth stuff
|
||||||
|
|
||||||
|
|
|
@ -38,14 +38,14 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
|
||||||
|
|
||||||
context "client returns errors appropriately" $ do
|
context "client returns errors appropriately" $ do
|
||||||
it "reports FailureResponse" $ \(_, baseUrl) -> do
|
it "reports FailureResponse" $ \(_, baseUrl) -> do
|
||||||
let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
|
let (_ :<|> _ :<|> _ :<|> getDeleteEmpty :<|> _) = client api
|
||||||
Left res <- runClient getDeleteEmpty baseUrl
|
Left res <- runClient getDeleteEmpty baseUrl
|
||||||
case res of
|
case res of
|
||||||
FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
|
FailureResponse _ r | responseStatusCode r == HTTP.status404 -> return ()
|
||||||
_ -> fail $ "expected 404 response, but got " <> show res
|
_ -> fail $ "expected 404 response, but got " <> show res
|
||||||
|
|
||||||
it "reports DecodeFailure" $ \(_, baseUrl) -> do
|
it "reports DecodeFailure" $ \(_, baseUrl) -> do
|
||||||
let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
|
let (_ :<|> _ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api
|
||||||
Left res <- runClient (getCapture "foo") baseUrl
|
Left res <- runClient (getCapture "foo") baseUrl
|
||||||
case res of
|
case res of
|
||||||
DecodeFailure _ _ -> return ()
|
DecodeFailure _ _ -> return ()
|
||||||
|
@ -72,7 +72,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
|
||||||
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
|
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
|
||||||
|
|
||||||
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
|
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
|
||||||
let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
|
let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
|
||||||
Left res <- runClient (getBody alice) baseUrl
|
Left res <- runClient (getBody alice) baseUrl
|
||||||
case res of
|
case res of
|
||||||
InvalidContentTypeHeader _ -> return ()
|
InvalidContentTypeHeader _ -> return ()
|
||||||
|
|
|
@ -59,11 +59,15 @@ spec = describe "Servant.SuccessSpec" $ do
|
||||||
|
|
||||||
successSpec :: Spec
|
successSpec :: Spec
|
||||||
successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
||||||
it "Servant.API.Get root" $ \(_, baseUrl) -> do
|
describe "Servant.API.Get" $ do
|
||||||
left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
|
it "get root endpoint" $ \(_, baseUrl) -> do
|
||||||
|
left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
|
||||||
|
|
||||||
it "Servant.API.Get" $ \(_, baseUrl) -> do
|
it "get simple endpoint" $ \(_, baseUrl) -> do
|
||||||
left show <$> runClient getGet baseUrl `shouldReturn` Right alice
|
left show <$> runClient getGet baseUrl `shouldReturn` Right alice
|
||||||
|
|
||||||
|
it "get redirection endpoint" $ \(_, baseUrl) -> do
|
||||||
|
left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting"
|
||||||
|
|
||||||
describe "Servant.API.Delete" $ do
|
describe "Servant.API.Delete" $ do
|
||||||
it "allows empty content type" $ \(_, baseUrl) -> do
|
it "allows empty content type" $ \(_, baseUrl) -> do
|
||||||
|
@ -111,6 +115,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
||||||
|
|
||||||
it "Servant.API.Fragment" $ \(_, baseUrl) -> do
|
it "Servant.API.Fragment" $ \(_, baseUrl) -> do
|
||||||
left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
|
left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
|
||||||
|
|
||||||
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
|
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
|
||||||
res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
|
res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
|
||||||
case res of
|
case res of
|
||||||
|
@ -156,7 +161,7 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
||||||
-- In proper situation, extra headers should probably be visible in API type.
|
-- In proper situation, extra headers should probably be visible in API type.
|
||||||
-- However, testing for response timeout is difficult, so we test with something which is easy to observe
|
-- However, testing for response timeout is difficult, so we test with something which is easy to observe
|
||||||
let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }
|
let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }
|
||||||
let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
|
clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
|
||||||
res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
|
res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
|
||||||
case res of
|
case res of
|
||||||
Left e ->
|
Left e ->
|
||||||
|
|
|
@ -57,7 +57,7 @@ import GHC.Generics
|
||||||
import Network.HTTP.Media
|
import Network.HTTP.Media
|
||||||
(renderHeader)
|
(renderHeader)
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
(Status (..), hContentType, http11, renderQuery)
|
(Status (..), hContentType, http11, renderQuery, statusIsSuccessful)
|
||||||
import Servant.Client.Core
|
import Servant.Client.Core
|
||||||
|
|
||||||
import qualified Network.Http.Client as Client
|
import qualified Network.Http.Client as Client
|
||||||
|
@ -160,12 +160,12 @@ performRequest acceptStatus req = do
|
||||||
x <- ClientM $ lift $ lift $ Codensity $ \k -> do
|
x <- ClientM $ lift $ lift $ Codensity $ \k -> do
|
||||||
Client.sendRequest conn req' body
|
Client.sendRequest conn req' body
|
||||||
Client.receiveResponse conn $ \res' body' -> do
|
Client.receiveResponse conn $ \res' body' -> do
|
||||||
let sc = Client.getStatusCode res'
|
let status = toEnum $ Client.getStatusCode res'
|
||||||
lbs <- BSL.fromChunks <$> Streams.toList body'
|
lbs <- BSL.fromChunks <$> Streams.toList body'
|
||||||
let res'' = clientResponseToResponse res' lbs
|
let res'' = clientResponseToResponse res' lbs
|
||||||
goodStatus = case acceptStatus of
|
goodStatus = case acceptStatus of
|
||||||
Nothing -> sc >= 200 && sc < 300
|
Nothing -> statusIsSuccessful status
|
||||||
Just good -> sc `elem` (statusCode <$> good)
|
Just good -> status `elem` good
|
||||||
if goodStatus
|
if goodStatus
|
||||||
then k (Right res'')
|
then k (Right res'')
|
||||||
else k (Left (mkFailureResponse burl req res''))
|
else k (Left (mkFailureResponse burl req res''))
|
||||||
|
@ -180,8 +180,8 @@ performWithStreamingRequest req k = do
|
||||||
Client.sendRequest conn req' body
|
Client.sendRequest conn req' body
|
||||||
Client.receiveResponseRaw conn $ \res' body' -> do
|
Client.receiveResponseRaw conn $ \res' body' -> do
|
||||||
-- check status code
|
-- check status code
|
||||||
let sc = Client.getStatusCode res'
|
let status = toEnum $ Client.getStatusCode res'
|
||||||
unless (sc >= 200 && sc < 300) $ do
|
unless (statusIsSuccessful status) $ do
|
||||||
lbs <- BSL.fromChunks <$> Streams.toList body'
|
lbs <- BSL.fromChunks <$> Streams.toList body'
|
||||||
throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
|
throwIO $ mkFailureResponse burl req (clientResponseToResponse res' lbs)
|
||||||
|
|
||||||
|
|
|
@ -56,7 +56,7 @@ import qualified Data.Text as T
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import GHC.TypeLits
|
import GHC.TypeLits
|
||||||
(KnownNat, KnownSymbol, natVal, symbolVal)
|
(KnownNat, KnownSymbol, symbolVal)
|
||||||
import qualified Network.HTTP.Media as NHM
|
import qualified Network.HTTP.Media as NHM
|
||||||
import Network.HTTP.Types hiding
|
import Network.HTTP.Types hiding
|
||||||
(Header, ResponseHeaders)
|
(Header, ResponseHeaders)
|
||||||
|
@ -87,6 +87,8 @@ import Servant.API.Modifiers
|
||||||
unfoldRequestArgument)
|
unfoldRequestArgument)
|
||||||
import Servant.API.ResponseHeaders
|
import Servant.API.ResponseHeaders
|
||||||
(GetHeaders, Headers, getHeaders, getResponse)
|
(GetHeaders, Headers, getHeaders, getResponse)
|
||||||
|
import Servant.API.Status
|
||||||
|
(statusFromNat)
|
||||||
import qualified Servant.Types.SourceT as S
|
import qualified Servant.Types.SourceT as S
|
||||||
import Web.HttpApiData
|
import Web.HttpApiData
|
||||||
(FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
|
(FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
|
||||||
|
@ -298,7 +300,7 @@ instance {-# OVERLAPPABLE #-}
|
||||||
|
|
||||||
route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
|
route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
|
||||||
where method = reflectMethod (Proxy :: Proxy method)
|
where method = reflectMethod (Proxy :: Proxy method)
|
||||||
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
status = statusFromNat (Proxy :: Proxy status)
|
||||||
|
|
||||||
instance {-# OVERLAPPING #-}
|
instance {-# OVERLAPPING #-}
|
||||||
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
|
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
|
||||||
|
@ -310,7 +312,7 @@ instance {-# OVERLAPPING #-}
|
||||||
|
|
||||||
route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
|
route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
|
||||||
where method = reflectMethod (Proxy :: Proxy method)
|
where method = reflectMethod (Proxy :: Proxy method)
|
||||||
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
status = statusFromNat (Proxy :: Proxy status)
|
||||||
|
|
||||||
instance (ReflectMethod method) =>
|
instance (ReflectMethod method) =>
|
||||||
HasServer (NoContentVerb method) context where
|
HasServer (NoContentVerb method) context where
|
||||||
|
@ -331,7 +333,7 @@ instance {-# OVERLAPPABLE #-}
|
||||||
|
|
||||||
route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
|
route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
|
||||||
where method = reflectMethod (Proxy :: Proxy method)
|
where method = reflectMethod (Proxy :: Proxy method)
|
||||||
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
status = statusFromNat (Proxy :: Proxy status)
|
||||||
|
|
||||||
|
|
||||||
instance {-# OVERLAPPING #-}
|
instance {-# OVERLAPPING #-}
|
||||||
|
@ -345,7 +347,7 @@ instance {-# OVERLAPPING #-}
|
||||||
|
|
||||||
route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
|
route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
|
||||||
where method = reflectMethod (Proxy :: Proxy method)
|
where method = reflectMethod (Proxy :: Proxy method)
|
||||||
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
status = statusFromNat (Proxy :: Proxy status)
|
||||||
|
|
||||||
|
|
||||||
streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
|
streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
|
||||||
|
|
|
@ -1,10 +1,15 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
-- Flexible instances is necessary on GHC 8.4 and earlier
|
-- Flexible instances is necessary on GHC 8.4 and earlier
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
module Servant.API.Status where
|
module Servant.API.Status where
|
||||||
|
|
||||||
|
import GHC.TypeLits (KnownNat, natVal)
|
||||||
import Network.HTTP.Types.Status
|
import Network.HTTP.Types.Status
|
||||||
import GHC.TypeLits
|
|
||||||
|
-- | Retrieve a known or unknown Status from a KnownNat
|
||||||
|
statusFromNat :: forall a proxy. KnownNat a => proxy a -> Status
|
||||||
|
statusFromNat = toEnum . fromInteger . natVal
|
||||||
|
|
||||||
-- | Witness that a type-level natural number corresponds to a HTTP status code
|
-- | Witness that a type-level natural number corresponds to a HTTP status code
|
||||||
class KnownNat n => KnownStatus n where
|
class KnownNat n => KnownStatus n where
|
||||||
|
|
Loading…
Reference in a new issue