eeva
/
servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Merge 363d142571 into 8f081bd9ad

This commit is contained in:
nbacquey 2022-11-21 14:13:28 -05:00 committed by GitHub
parent 8f081bd9ad 363d142571
commit 3930e4d86e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
13 changed files with 525 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
changelog.d/1561 Normal file
View File

@ -0,0 +1,33 @@
synopsis: New combinator to return routed path in response headers
prs: #1561
issues: #1553
description: {
This commit introduces a new type-level combinator, `WithRoutingHeader`.
It modifies the behaviour of the following sub-API, such that all endpoints of said API return an additional routing header in their response.
A routing header is a header that specifies which endpoint the incoming request was routed to.
Endpoint are designated by their path, in which `Capture'` and `CaptureAll` combinators are replaced by a capture hint.
This header can be used by downstream middlewares to gather information about individual endpoints, since in most cases
a routing header uniquely identifies a single endpoint.
Example:
```haskell
type MyApi =
WithRoutingHeader :> "by-id" :> Capture "id" Int :> Get '[JSON] Foo
-- GET /by-id/1234 will return a response with the following header:
-- ("Servant-Routed-Path", "/by-id/<id::Int>")
```
To achieve this, two refactorings were necessary:
* Introduce a type `RouterEnv env` to encapsulate the `env` type (as in `Router env a`), which contains a tuple-encoded list of url pieces parsed from the incoming request. This type makes it possible to pass more information throughout the routing process, and the computation of the `Delayed env c` associated with each request.
* Introduce a new kind of router, which only modifies the `RouterEnv`, and doesn't affect the routing process otherwise: `EnvRouter (RouterEnv env -> RouterEnv env) (Router' env a)`.
This new router is used when encountering the `WithRoutingHeader` combinator in an API, to notify the endpoints of the sub-API that they must produce a routing header (this behaviour is disabled by default).
This PR also introduces `Spec` tests for the `WithRoutingHeader` combinator, which showcase some of its possible uses.
}

3
servant-server/servant-server.cabal
View File

@ -46,6 +46,8 @@ library
Servant.Server.Internal.DelayedIO
Servant.Server.Internal.ErrorFormatter
Servant.Server.Internal.Handler
Servant.Server.Internal.Redirect
Servant.Server.Internal.RouterEnv
Servant.Server.Internal.RouteResult
Servant.Server.Internal.Router
Servant.Server.Internal.RoutingApplication
@ -142,6 +144,7 @@ test-suite spec
, base-compat
, base64-bytestring
, bytestring
, containers
, http-types
, mtl
, resourcet

48
servant-server/src/Servant/Server/Internal.hs
View File

@ -27,6 +27,7 @@ module Servant.Server.Internal
, module Servant.Server.Internal.ErrorFormatter
, module Servant.Server.Internal.Handler
, module Servant.Server.Internal.Router
, module Servant.Server.Internal.RouterEnv
, module Servant.Server.Internal.RouteResult
, module Servant.Server.Internal.RoutingApplication
, module Servant.Server.Internal.ServerError
@ -74,10 +75,10 @@ import Servant.API
CaptureAll, Description, EmptyAPI, Fragment,
FramingRender (..), FramingUnrender (..), FromSourceIO (..),
Header', If, IsSecure (..), NoContentVerb, QueryFlag,
QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
QueryParam', QueryParams, Raw, Redirect, ReflectMethod (reflectMethod),
RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
WithNamedContext, NamedRoutes)
WithNamedContext, WithRoutingHeader, NamedRoutes)
import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
import Servant.API.ContentTypes
(AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
@ -89,7 +90,7 @@ import Servant.API.Modifiers
import Servant.API.ResponseHeaders
(GetHeaders, Headers, getHeaders, getResponse)
import Servant.API.Status
(statusFromNat)
(Redirection, statusFromNat)
import qualified Servant.Types.SourceT as S
import Servant.API.TypeErrors
import Web.HttpApiData
@ -104,8 +105,10 @@ import Servant.Server.Internal.Delayed
import Servant.Server.Internal.DelayedIO
import Servant.Server.Internal.ErrorFormatter
import Servant.Server.Internal.Handler
import Servant.Server.Internal.Redirect
import Servant.Server.Internal.Router
import Servant.Server.Internal.RouteResult
import Servant.Server.Internal.RouterEnv
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServerError
@ -244,6 +247,40 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
-- | Using 'WithRoutingHeaders' in one of the endpoints for your API,
-- will automatically add routing headers to the response generated by the server.
--
-- @since 0.20
--
instance ( HasServer api context
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
)
=> HasServer (WithRoutingHeader :> api) context where
type ServerT (WithRoutingHeader :> api) m = ServerT api m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s
route _ context d =
EnvRouter enableRoutingHeaders $ route (Proxy :: Proxy api) context d
-- | TODO: Documentation
instance ( HasServer api context
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
, KnownSymbol location
, AllStatusesInClass Redirection api
)
=> HasServer (Redirect location :> api) context where
type ServerT (Redirect location :> api) m = ServerT api m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s
route _ context d =
EnvRouter
(withLocationHeader $ symbolVal $ Proxy @location)
(route (Proxy :: Proxy api) context d)
allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
@ -295,7 +332,10 @@ noContentRouter method status action = leafRouter route'
route' env request respond =
runAction (action `addMethodCheck` methodCheck method request)
env request respond $ \ _output ->
Route $ responseLBS status [] ""
let headers = if (shouldReturnRoutedPath env)
then [(hRoutedPathHeader, cs $ routedPathRepr env)]
else []
in Route $ responseLBS status headers ""
instance {-# OVERLAPPABLE #-}
( AllCTRender ctypes a, ReflectMethod method, KnownNat status

26
servant-server/src/Servant/Server/Internal/Delayed.hs
View File

@ -14,11 +14,15 @@ import Control.Monad.Reader
(ask)
import Control.Monad.Trans.Resource
(ResourceT, runResourceT)
import Data.String.Conversions
(cs)
import Network.Wai
(Request, Response)
(Request, Response, mapResponseHeaders)
import Servant.Server.Internal.DelayedIO
import Servant.Server.Internal.Handler
import Servant.Server.Internal.RouterEnv
(RouterEnv (..), hLocationHeader, hRoutedPathHeader, routedPathRepr)
import Servant.Server.Internal.RouteResult
import Servant.Server.Internal.ServerError
@ -228,12 +232,12 @@ passToServer Delayed{..} x =
-- This should only be called once per request; otherwise the guarantees about
-- effect and HTTP error ordering break down.
runDelayed :: Delayed env a
-> env
-> RouterEnv env
-> Request
-> ResourceT IO (RouteResult a)
runDelayed Delayed{..} env = runDelayedIO $ do
r <- ask
c <- capturesD env
c <- capturesD $ routerEnv env
methodD
a <- authD
acceptD
@ -248,7 +252,7 @@ runDelayed Delayed{..} env = runDelayedIO $ do
-- Also takes a continuation for how to turn the
-- result of the delayed server into a response.
runAction :: Delayed env (Handler a)
-> env
-> RouterEnv env
-> Request
-> (RouteResult Response -> IO r)
-> (a -> RouteResult Response)
@ -261,8 +265,18 @@ runAction action env req respond k = runResourceT $
go (Route a) = liftIO $ do
e <- runHandler a
case e of
Left err -> return . Route $ responseServerError err
Right x -> return $! k x
Left err -> return . Route . withRoutingHeaders $ responseServerError err
Right x -> return $! withHeaders <$> k x
withRoutingHeaders :: Response -> Response
withRoutingHeaders = if shouldReturnRoutedPath env
then mapResponseHeaders ((hRoutedPathHeader, cs $ routedPathRepr env) :)
else id
withLocationHeader :: Response -> Response
withLocationHeader = case locationHeader env of
Nothing -> id
Just location -> mapResponseHeaders ((hLocationHeader, cs location) :)
withHeaders :: Response -> Response
withHeaders = withLocationHeader . withRoutingHeaders
{- Note [Existential Record Update]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

53
servant-server/src/Servant/Server/Internal/Redirect.hs Normal file
View File

@ -0,0 +1,53 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Servant.Server.Internal.Redirect where
import Data.SOP.Constraint
(All)
import GHC.TypeLits
(Nat, ErrorMessage(..), TypeError)
import Servant.API
((:>), (:<|>), Raw, Statuses, Stream, UVerb, Verb)
import Servant.API.Status
(HasStatusClass, KnownStatusClass)
type family (as :: [k]) ++ (bs :: [k]) :: [k] where
'[] ++ bs = bs
(a ': as) ++ bs = a ': (as ++ bs)
-- | A type class to gather all statically declared HTTP status codes of an api
class HasApiStatuses a where
type ApiStatuses a :: [Nat]
instance HasApiStatuses (Verb method status ctypes a) where
type ApiStatuses (Verb _ status _ _) = '[status]
instance HasApiStatuses (Stream method status framing ctypes a) where
type ApiStatuses (Stream _ status _ _ _) = '[status]
instance HasApiStatuses (UVerb method ctypes as) where
type ApiStatuses (UVerb _ _ as) = Statuses as
instance HasApiStatuses Raw where
type ApiStatuses Raw = TypeError ('Text "cannot observe the HTTP statuses of a Raw API")
instance (HasApiStatuses api) => HasApiStatuses (api' :> api) where
type ApiStatuses (_ :> api) = ApiStatuses api
instance (HasApiStatuses api1, HasApiStatuses api2) => HasApiStatuses (api1 :<|> api2) where
type ApiStatuses (api1 :<|> api2) = (ApiStatuses api1) ++ (ApiStatuses api2)
-- | A type class to check that all statically declared HTTP status codes of an api
-- belong to the same status class, as defined by @KnownStatusClass@.
class AllStatusesInClass c api
instance ( HasApiStatuses api
, KnownStatusClass c
, All (HasStatusClass c) (ApiStatuses api)
) => AllStatusesInClass c api

47
servant-server/src/Servant/Server/Internal/Router.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Servant.Server.Internal.Router where
import Prelude ()
@ -17,29 +18,16 @@ import qualified Data.Map as M
import Data.Text
(Text)
import qualified Data.Text as T
import Data.Typeable
(TypeRep)
import Network.Wai
(Response, pathInfo)
import Servant.Server.Internal.ErrorFormatter
import Servant.Server.Internal.RouterEnv
import Servant.Server.Internal.RouteResult
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServerError
type Router env = Router' env RoutingApplication
data CaptureHint = CaptureHint
{ captureName :: Text
, captureType :: TypeRep
}
deriving (Show, Eq)
toCaptureTag :: CaptureHint -> Text
toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)
toCaptureTags :: [CaptureHint] -> Text
toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
-- | Internal representation of a router.
--
-- The first argument describes an environment type that is
@ -48,7 +36,7 @@ toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
-- components that can be used to process captures.
--
data Router' env a =
StaticRouter (Map Text (Router' env a)) [env -> a]
StaticRouter (Map Text (Router' env a)) [RouterEnv env -> a]
-- ^ the map contains routers for subpaths (first path component used
-- for lookup and removed afterwards), the list contains handlers
-- for the empty path, to be tried in order
@ -58,10 +46,13 @@ data Router' env a =
| CaptureAllRouter [CaptureHint] (Router' ([Text], env) a)
-- ^ all path components are passed to the child router in its
-- environment and are removed afterwards
| RawRouter (env -> a)
| RawRouter (RouterEnv env -> a)
-- ^ to be used for routes we do not know anything about
| Choice (Router' env a) (Router' env a)
-- ^ left-biased choice between two routers
| EnvRouter (RouterEnv env -> RouterEnv env) (Router' env a)
-- ^ modifies the environment, and passes it to the child router
-- @since 0.20
deriving Functor
-- | Smart constructor for a single static path component.
@ -71,7 +62,7 @@ pathRouter t r = StaticRouter (M.singleton t r) []
-- | Smart constructor for a leaf, i.e., a router that expects
-- the empty path.
--
leafRouter :: (env -> a) -> Router' env a
leafRouter :: (RouterEnv env -> a) -> Router' env a
leafRouter l = StaticRouter M.empty [l]
-- | Smart constructor for the choice between routers.
@ -126,6 +117,7 @@ routerStructure (Choice r1 r2) =
ChoiceStructure
(routerStructure r1)
(routerStructure r2)
routerStructure (EnvRouter _ r) = routerStructure r
-- | Compare the structure of two routers.
--
@ -172,9 +164,9 @@ tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
-- | Interpret a router as an application.
runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication
runRouter fmt r = runRouterEnv fmt r ()
runRouter fmt r = runRouterEnv fmt r $ emptyEnv ()
runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
runRouterEnv :: NotFoundErrorFormatter -> Router env -> RouterEnv env -> RoutingApplication
runRouterEnv fmt router env request respond =
case router of
StaticRouter table ls ->
@ -184,24 +176,31 @@ runRouterEnv fmt router env request respond =
[""] -> runChoice fmt ls env request respond
first : rest | Just router' <- M.lookup first table
-> let request' = request { pathInfo = rest }
in runRouterEnv fmt router' env request' respond
newEnv = appendPathPiece (StaticPiece first) env
in runRouterEnv fmt router' newEnv request' respond
_ -> respond $ Fail $ fmt request
CaptureRouter _ router' ->
CaptureRouter hints router' ->
case pathInfo request of
[] -> respond $ Fail $ fmt request
-- This case is to handle trailing slashes.
[""] -> respond $ Fail $ fmt request
first : rest
-> let request' = request { pathInfo = rest }
in runRouterEnv fmt router' (first, env) request' respond
CaptureAllRouter _ router' ->
newEnv = appendPathPiece (CapturePiece hints) env
newEnv' = ((first,) <$> newEnv)
in runRouterEnv fmt router' newEnv' request' respond
CaptureAllRouter hints router' ->
let segments = pathInfo request
request' = request { pathInfo = [] }
in runRouterEnv fmt router' (segments, env) request' respond
newEnv = appendPathPiece (CapturePiece hints) env
newEnv' = ((segments,) <$> newEnv)
in runRouterEnv fmt router' newEnv' request' respond
RawRouter app ->
app env request respond
Choice r1 r2 ->
runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond
EnvRouter f router' ->
runRouterEnv fmt router' (f env) request respond
-- | Try a list of routing applications in order.
-- We stop as soon as one fails fatally or succeeds.

77
servant-server/src/Servant/Server/Internal/RouterEnv.hs Normal file
View File

@ -0,0 +1,77 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | This module contains the `RouterEnv env` type and associated functions.
-- `RouterEnv env` encapsulates the `env` type (as in `Router env a`),
-- which contains a tuple-encoded list of url pieces parsed from the incoming request.
-- The encapsulation makes it possible to pass more information throughout
-- the routing process, and ultimately to the computation of the `Delayed env c`
-- associated with each request.
-- The type and functions have been designed to be extensible: it should remain easy
-- to add a new field to the record and manipulate it.
--
-- @since 0.20
--
module Servant.Server.Internal.RouterEnv where
import Data.Text
(Text)
import qualified Data.Text as T
import Data.Typeable
(TypeRep)
import Network.HTTP.Types.Header
(HeaderName)
data RouterEnv env = RouterEnv
{ locationHeader :: Maybe String
, routedPath :: [PathPiece]
, shouldReturnRoutedPath :: Bool
, routerEnv :: env
}
deriving Functor
emptyEnv :: a -> RouterEnv a
emptyEnv v = RouterEnv
{ locationHeader = Nothing
, routedPath = []
, shouldReturnRoutedPath = False
, routerEnv = v
}
enableRoutingHeaders :: RouterEnv env -> RouterEnv env
enableRoutingHeaders env = env { shouldReturnRoutedPath = True }
routedPathRepr :: RouterEnv env -> Text
routedPathRepr RouterEnv{routedPath = path} =
"/" <> T.intercalate "/" (map go $ reverse path)
where
go (StaticPiece p) = p
go (CapturePiece p) = toCaptureTags p
data PathPiece
= StaticPiece Text
| CapturePiece [CaptureHint]
appendPathPiece :: PathPiece -> RouterEnv a -> RouterEnv a
appendPathPiece p env@RouterEnv{..} = env { routedPath = p:routedPath }
data CaptureHint = CaptureHint
{ captureName :: Text
, captureType :: TypeRep
}
deriving (Show, Eq)
toCaptureTag :: CaptureHint -> Text
toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hint)
toCaptureTags :: [CaptureHint] -> Text
toCaptureTags hints = "<" <> T.intercalate "|" (map toCaptureTag hints) <> ">"
withLocationHeader :: String -> RouterEnv a -> RouterEnv a
withLocationHeader loc env = env { locationHeader = Just loc}
hRoutedPathHeader :: HeaderName
hRoutedPathHeader = "Servant-Routed-Path"
hLocationHeader :: HeaderName
hLocationHeader = "Location"

2
servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs
View File

@ -80,7 +80,7 @@ delayed body srv = Delayed
simpleRun :: Delayed () (Handler ())
-> IO ()
simpleRun d = fmap (either ignoreE id) . try $
runAction d () defaultRequest (\_ -> return ()) (\_ -> FailFatal err500)
runAction d (emptyEnv ()) defaultRequest (\_ -> return ()) (\_ -> FailFatal err500)
where ignoreE :: SomeException -> ()
ignoreE = const ()

166
servant-server/test/Servant/ServerSpec.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -25,6 +26,8 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import Data.Char
(toUpper)
import Data.Map
(fromList, notMember)
import Data.Maybe
(fromMaybe)
import Data.Proxy
@ -49,20 +52,21 @@ import Network.Wai.Test
import Servant.API
((:<|>) (..), (:>), AuthProtect, BasicAuth,
BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
Headers, HttpVersion, IsSecure (..), JSON, Lenient,
NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
UVerb, Union, Verb, WithStatus (..), addHeader)
Delete, EmptyAPI, Fragment, Get, GetNoContent,
HasStatus (StatusOf), Header, Headers, HttpVersion,
IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,
NoFraming, OctetStream, Patch, PlainText, Post, Put,
QueryFlag, QueryParam, QueryParams, Raw, Redirect, RemoteHost, ReqBody,
SourceIO, StdMethod (..), Stream, StreamGet, Strict, UVerb,
Union, Verb, WithRoutingHeader, WithStatus (..), addHeader)
import Servant.Server
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
emptyServer, err401, err403, err404, respond, serve,
emptyServer, err401, err403, err404, err500, respond, serve,
serveWithContext)
import Servant.Test.ComprehensiveAPI
import qualified Servant.Types.SourceT as S
import Test.Hspec
(Spec, context, describe, it, shouldBe, shouldContain)
(Spec, context, describe, it, shouldBe, shouldContain, shouldSatisfy)
import Test.Hspec.Wai
(get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
with, (<:>))
@ -103,6 +107,8 @@ spec = do
miscCombinatorSpec
basicAuthSpec
genAuthSpec
routedPathHeadersSpec
redirectionSpec
------------------------------------------------------------------------------
-- * verbSpec {{{
@ -842,6 +848,150 @@ genAuthSpec = do
it "plays nice with subsequent Raw endpoints" $ do
get "/foo" `shouldRespondWith` 418
-- }}}
------------------------------------------------------------------------------
-- * Routed path response headers {{{
------------------------------------------------------------------------------
type RoutedPathApi = WithRoutingHeader :>
( "content" :> Get '[JSON] Person
:<|> "noContent" :> GetNoContent
:<|> "header" :> Get '[JSON] (Headers '[Header "H" Int] Person)
:<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
:<|> "animal" :> ( Capture "legs" Int :> Get '[JSON] Animal
:<|> CaptureAll "legs" Int :> Get '[JSON] Animal
:<|> Capture "name" String :> Get '[JSON] Animal
)
) :<|> "withoutHeader" :> Get '[JSON] Person
routedPathApi :: Proxy RoutedPathApi
routedPathApi = Proxy
routedPathServer :: Server RoutedPathApi
routedPathServer =
( return alice
:<|> return NoContent
:<|> return (addHeader 5 alice)
:<|> return (S.source ["bytestring"])
:<|> (( \case
2 -> return tweety
4 -> return jerry
_ -> throwError err500
):<|>( \ legs -> case sum legs of
2 -> return tweety
4 -> return jerry
_ -> throwError err500
):<|>( \case
"tweety" -> return tweety
"jerry" -> return jerry
"bob" -> return beholder
_ -> throwError err404
))
) :<|> return alice
routedPathHeadersSpec :: Spec
routedPathHeadersSpec = do
describe "Server routing header" $ do
with (return $ serve routedPathApi routedPathServer) $ do
it "returns the routed path on verbs" $ do
response <- THW.request methodGet "/content" [] ""
liftIO $ simpleHeaders response `shouldContain`
[("Servant-Routed-Path", "/content")]
it "returns the routed path on noContent verbs" $ do
response <- THW.request methodGet "/noContent" [] ""
liftIO $ simpleHeaders response `shouldContain`
[("Servant-Routed-Path", "/noContent")]
it "returns the routed path on streams" $ do
response <- THW.request methodGet "/stream" [] ""
liftIO $ simpleHeaders response `shouldContain`
[("Servant-Routed-Path", "/stream")]
it "plays nice with manually added headers" $ do
response <- THW.request methodGet "/header" [] ""
liftIO $ do
simpleHeaders response `shouldContain` [("Servant-Routed-Path", "/header")]
simpleHeaders response `shouldContain` [("H", "5")]
it "abstracts captured values" $ do
response <- THW.request methodGet "/animal/4" [] ""
liftIO $ simpleHeaders response `shouldContain`
[("Servant-Routed-Path", "/animal/<legs::Int>")]
it "abstracts captured lists" $ do
response <- THW.request methodGet "/animal/1/1/0" [] ""
liftIO $ simpleHeaders response `shouldContain`
[("Servant-Routed-Path", "/animal/<legs::[Int]>")]
it "supports backtracking on routing errors" $ do
response <- THW.request methodGet "/animal/jerry" [] ""
liftIO $ simpleHeaders response `shouldContain`
[("Servant-Routed-Path", "/animal/<name::[Char]>")]
it "returns the routed path on a failing route" $ do
response <- THW.request methodGet "/animal/0" [] ""
liftIO $ simpleHeaders response `shouldContain`
[("Servant-Routed-Path", "/animal/<legs::Int>")]
it "is missing when no route matches" $ do
response <- THW.request methodGet "/wrongPath" [] ""
liftIO $ simpleHeaders response `shouldSatisfy`
(notMember "Servant-Routed-Path") . fromList
it "is missing when WithRoutingHeader is missing" $ do
response <- THW.request methodGet "/withoutHeader" [] ""
liftIO $ simpleHeaders response `shouldSatisfy`
(notMember "Servant-Routed-Path") . fromList
-- }}}
------------------------------------------------------------------------------
-- * Redirection {{{
------------------------------------------------------------------------------
type RedirectionApi
= "old-api" :> Redirect "/new-api" :>
( Verb 'GET 307 '[JSON] NoContent
:<|> Verb 'POST 307 '[JSON] NoContent
:<|> "sub-api" :> Redirect "/new-api/sub-api" :> Verb 'GET 301 '[JSON] NoContent
)
:<|> "new-api" :>
( Get '[JSON] Person
:<|> Post '[JSON] Person
:<|> "sub-api" :> Get '[JSON] Person
)
redirectionApi :: Proxy RedirectionApi
redirectionApi = Proxy
redirectionServer :: Server RedirectionApi
redirectionServer =
( return NoContent
:<|> return NoContent
:<|> return NoContent
) :<|>
( return alice
:<|> return alice
:<|> return alice
)
redirectionSpec :: Spec
redirectionSpec = do
describe "Redirect combinator" $ do
with (return $ serve redirectionApi redirectionServer) $ do
it "fills the Location header" $ do
response <- THW.request methodGet "/old-api" [] ""
liftIO $ simpleHeaders response `shouldContain`
[("Location", "/new-api")]
it "gets trumped by more specific redirections" $ do
response <- THW.request methodGet "/old-api/sub-api" [] ""
liftIO $ simpleHeaders response `shouldContain`
[("Location", "/new-api/sub-api")]
it "only fills Location header in nested apis" $ do
response <- THW.request methodGet "/new-api" [] ""
liftIO $ simpleHeaders response `shouldSatisfy`
(notMember "Location") . fromList
-- }}}
------------------------------------------------------------------------------
-- * UVerb {{{

1
servant/servant.cabal
View File

@ -38,6 +38,7 @@ library
Servant.API.Capture
Servant.API.ContentTypes
Servant.API.Description
Servant.API.Environment
Servant.API.Empty
Servant.API.Experimental.Auth
Servant.API.Fragment

4
servant/src/Servant/API.hs
View File

@ -7,6 +7,8 @@ module Servant.API (
-- | Type-level combinator for alternative endpoints: @':<|>'@
module Servant.API.Empty,
-- | Type-level combinator for an empty API: @'EmptyAPI'@
module Servant.API.Environment,
-- | Type-level combinators to modify the routing environment: @'WithRoutingHeader'@
module Servant.API.Modifiers,
-- | Type-level modifiers for 'QueryParam', 'Header' and 'ReqBody'.
@ -97,6 +99,8 @@ import Servant.API.Description
(Description, Summary)
import Servant.API.Empty
(EmptyAPI (..))
import Servant.API.Environment
(Redirect, WithRoutingHeader)
import Servant.API.Experimental.Auth
(AuthProtect)
import Servant.API.Fragment

60
servant/src/Servant/API/Environment.hs Normal file
View File

@ -0,0 +1,60 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | Define API combinator that modify the behaviour of the routing environment.
module Servant.API.Environment (Redirect, WithRoutingHeader) where
import GHC.TypeLits
(Symbol)
-- | Modify the behaviour of the following sub-API, such that all endpoint of said API
-- return an additional routing header in their response.
-- A routing header is a header that specifies which endpoint the incoming request was
-- routed to. Endpoint are designated by their path, in which @Capture@ combinators are
-- replaced by a capture hint.
-- This header can be used by downstream middlewares to gather information about
-- individual endpoints, since in most cases a routing header uniquely identifies a
-- single endpoint.
--
-- Example:
--
-- >>> type MyApi = WithRoutingHeader :> "by-id" :> Capture "id" Int :> Get '[JSON] Foo
-- >>> -- GET /by-id/1234 will return a response with the following header:
-- >>> -- ("Servant-Routed-Path", "/by-id/<id::Int>")
--
-- @since 0.20
--
data WithRoutingHeader
-- | Modify the behaviour of the following sub-API, such that all endpoints of said API
-- return a "Location" header, set to the value of @location@ type variable. An API using
-- the @Redirect@ combinator **does not typecheck** if any of the endpoints below the
-- combinator returns a status code outside the 3xx range, or if it is used to redirect
-- a @Raw@ API (because we cannot guarantee anything about them).
--
-- For instance, the following API doesn't have a @HasServer@ instance:
--
-- >>> type BadApi
-- >>> = "old-api" :> Redirect "/new-api" :> Get '[JSON] Foo
-- >>> :<|> "new-api" :> Get '[JSON] Foo
-- >>> -- @Get@ is an alias for @Verb 'GET 200@
--
-- Whereas this one does:
--
-- >>> type GoodApi
-- >>> = "old-api" :> Redirect "/new-api" :> Verb 'GET 301 '[JSON] Foo
-- >>> :<|> "new-api" :> Get '[JSON] Foo
-- >>> -- GET /old-api will return a response with status 301 and the following header:
-- >>> -- ("Location", "/new-api")
--
-- @since TODO
--
data Redirect (location :: Symbol)
-- $setup
-- >>> import Servant.API
-- >>> import Data.Aeson
-- >>> import Data.Text
-- >>> data Foo
-- >>> instance ToJSON Foo where { toJSON = undefined }

49
servant/src/Servant/API/Status.hs
View File

@ -1,10 +1,19 @@
{-# LANGUAGE DataKinds #-}
-- Flexible instances is necessary on GHC 8.4 and earlier
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Servant.API.Status where
import GHC.TypeLits (KnownNat, natVal)
import Data.Kind
(Constraint)
import GHC.TypeLits
(type (+), type (<=?), ErrorMessage(..), KnownNat, Nat, Symbol, TypeError, natVal)
import Network.HTTP.Types.Status
-- | Retrieve a known or unknown Status from a KnownNat
@ -158,3 +167,41 @@ instance KnownStatus 505 where
instance KnownStatus 511 where
statusVal _ = status511
-- | Witness that a type-level natural number corresponds to a class
-- of HTTP error codes
class KnownNat c => KnownStatusClass c where
type TextualClass c :: Symbol
type Informational = 100
instance KnownStatusClass Informational where
type TextualClass Informational = "Informational"
type Successful = 200
instance KnownStatusClass Successful where
type TextualClass Successful = "Successful"
type Redirection = 300
instance KnownStatusClass Redirection where
type TextualClass Redirection = "Redirection"
type ClientError = 400
instance KnownStatusClass ClientError where
type TextualClass ClientError = "ClientError"
type ServerError = 500
instance KnownStatusClass ServerError where
type TextualClass ServerError = "ServerError"
-- | Witness that a type-level status belongs to its given class.
-- Raises a custom error when it does not.
class (KnownStatus s, KnownStatusClass c) => HasStatusClass c s
type ClassCheck :: Bool -> Bool -> Nat -> Nat -> Constraint
type family ClassCheck a b c s where
ClassCheck 'True 'True _ _ = ()
ClassCheck _ _ c s = TypeError ('Text "HTTP status code " ':<>: 'ShowType s ':<>: 'Text " does not belong to class " ':<>: 'Text (TextualClass c))
instance ( KnownStatus s, KnownStatusClass c
, ClassCheck (c <=? s) (s <=? c + 99) c s
) => HasStatusClass c s