From 9be8693475bb9c2f27d49112d2c1fdb9abd7b648 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Mon, 14 Mar 2022 14:16:54 +0100 Subject: [PATCH 1/7] New combinator to return routed path in response headers This commit introduces a new type-level combinator, `WithRoutingHeader`. It modifies 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'` 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/") ``` 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). --- servant-server/servant-server.cabal | 1 + servant-server/src/Servant/Server/Internal.hs | 26 +++++++- .../src/Servant/Server/Internal/Delayed.hs | 20 ++++-- .../src/Servant/Server/Internal/Router.hs | 47 +++++++------- .../src/Servant/Server/Internal/RouterEnv.hs | 65 +++++++++++++++++++ .../Server/Internal/RoutingApplicationSpec.hs | 2 +- servant/servant.cabal | 1 + servant/src/Servant/API.hs | 4 ++ servant/src/Servant/API/Environment.hs | 29 +++++++++ 9 files changed, 162 insertions(+), 33 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/RouterEnv.hs create mode 100644 servant/src/Servant/API/Environment.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 2488ae748..782796105 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -46,6 +46,7 @@ library Servant.Server.Internal.DelayedIO Servant.Server.Internal.ErrorFormatter Servant.Server.Internal.Handler + Servant.Server.Internal.RouterEnv Servant.Server.Internal.RouteResult Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index a2b4f0339..5d2800fe9 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -26,6 +26,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 @@ -76,7 +77,7 @@ import Servant.API QueryParam', QueryParams, Raw, 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 (..), @@ -103,6 +104,7 @@ import Servant.Server.Internal.ErrorFormatter import Servant.Server.Internal.Handler 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 @@ -241,6 +243,23 @@ 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 + allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead @@ -292,7 +311,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 diff --git a/servant-server/src/Servant/Server/Internal/Delayed.hs b/servant-server/src/Servant/Server/Internal/Delayed.hs index 3ba895749..029d95ca0 100644 --- a/servant-server/src/Servant/Server/Internal/Delayed.hs +++ b/servant-server/src/Servant/Server/Internal/Delayed.hs @@ -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 (..), 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,12 @@ 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 $! withRoutingHeaders <$> k x + withRoutingHeaders :: Response -> Response + withRoutingHeaders = if shouldReturnRoutedPath env + then mapResponseHeaders ((hRoutedPathHeader, cs $ routedPathRepr env) :) + else id {- Note [Existential Record Update] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index 0a3391ce9..794ab400f 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -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. diff --git a/servant-server/src/Servant/Server/Internal/RouterEnv.hs b/servant-server/src/Servant/Server/Internal/RouterEnv.hs new file mode 100644 index 000000000..15c628fe5 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/RouterEnv.hs @@ -0,0 +1,65 @@ +{-# 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 + { routedPath :: [PathPiece] + , shouldReturnRoutedPath :: Bool + , routerEnv :: env + } + deriving Functor + +emptyEnv :: a -> RouterEnv a +emptyEnv v = RouterEnv [] False 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) <> ">" + +hRoutedPathHeader :: HeaderName +hRoutedPathHeader = "Servant-Routed-Path" diff --git a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs index 04443c9d8..87fab549f 100644 --- a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -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 () diff --git a/servant/servant.cabal b/servant/servant.cabal index 32b63feb8..d175bc376 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -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 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 22309dce9..2673dac4c 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -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 + (WithRoutingHeader) import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Fragment diff --git a/servant/src/Servant/API/Environment.hs b/servant/src/Servant/API/Environment.hs new file mode 100644 index 000000000..08e477d78 --- /dev/null +++ b/servant/src/Servant/API/Environment.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_HADDOCK not-home #-} +-- | Define API combinator that modify the behaviour of the routing environment. +module Servant.API.Environment (WithRoutingHeader) where + +-- | 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/") +-- +-- @since 0.20 +-- +data WithRoutingHeader + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Foo +-- >>> instance ToJSON Foo where { toJSON = undefined } From ca8d44eae91388843fde58b7e6d57c73adae4653 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 10 Mar 2022 15:57:24 +0100 Subject: [PATCH 2/7] Spec for `WithRoutingHeader` API combinator --- servant-server/servant-server.cabal | 1 + servant-server/test/Servant/ServerSpec.hs | 117 ++++++++++++++++++++-- 2 files changed, 110 insertions(+), 8 deletions(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 782796105..7ab77e69e 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -143,6 +143,7 @@ test-suite spec , base-compat , base64-bytestring , bytestring + , containers , http-types , mtl , resourcet diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 39e75cd4a..2b827d777 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -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, 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,7 @@ spec = do miscCombinatorSpec basicAuthSpec genAuthSpec + routedPathHeadersSpec ------------------------------------------------------------------------------ -- * verbSpec {{{ @@ -842,6 +847,102 @@ 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/")] + + it "abstracts captured lists" $ do + response <- THW.request methodGet "/animal/1/1/0" [] "" + liftIO $ simpleHeaders response `shouldContain` + [("Servant-Routed-Path", "/animal/")] + + it "supports backtracking on routing errors" $ do + response <- THW.request methodGet "/animal/jerry" [] "" + liftIO $ simpleHeaders response `shouldContain` + [("Servant-Routed-Path", "/animal/")] + + it "returns the routed path on a failing route" $ do + response <- THW.request methodGet "/animal/0" [] "" + liftIO $ simpleHeaders response `shouldContain` + [("Servant-Routed-Path", "/animal/")] + + 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 + -- }}} ------------------------------------------------------------------------------ -- * UVerb {{{ From 809c8ce79346d0fe4e6a93ebf660b92dfba263be Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Mon, 14 Mar 2022 15:51:31 +0100 Subject: [PATCH 3/7] Update changelog --- changelog.d/1561 | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 changelog.d/1561 diff --git a/changelog.d/1561 b/changelog.d/1561 new file mode 100644 index 000000000..cc6aea68a --- /dev/null +++ b/changelog.d/1561 @@ -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/") +``` + +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. + +} From e0d47c807a1368c7fb6c2dce27299d932ddb0134 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Tue, 29 Mar 2022 14:48:22 +0200 Subject: [PATCH 4/7] Add type classes for classes of HTTP status codes --- servant/src/Servant/API/Status.hs | 49 ++++++++++++++++++++++++++++++- 1 file changed, 48 insertions(+), 1 deletion(-) diff --git a/servant/src/Servant/API/Status.hs b/servant/src/Servant/API/Status.hs index 145f6dc35..5882576bc 100644 --- a/servant/src/Servant/API/Status.hs +++ b/servant/src/Servant/API/Status.hs @@ -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 From bfa854f20eec6213d93cb25e5da71771812f576d Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Tue, 29 Mar 2022 17:17:23 +0200 Subject: [PATCH 5/7] Move combinator + helpers for status checking --- servant-server/servant-server.cabal | 1 + .../src/Servant/Server/Internal/Redirect.hs | 53 +++++++++++++++++++ servant/src/Servant/API.hs | 2 +- servant/src/Servant/API/Environment.hs | 33 +++++++++++- 4 files changed, 87 insertions(+), 2 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/Redirect.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 7ab77e69e..d27cb7492 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -46,6 +46,7 @@ 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 diff --git a/servant-server/src/Servant/Server/Internal/Redirect.hs b/servant-server/src/Servant/Server/Internal/Redirect.hs new file mode 100644 index 000000000..ab196ed8c --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Redirect.hs @@ -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 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 2673dac4c..bd1f04700 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -100,7 +100,7 @@ import Servant.API.Description import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Environment - (WithRoutingHeader) + (Redirect, WithRoutingHeader) import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Fragment diff --git a/servant/src/Servant/API/Environment.hs b/servant/src/Servant/API/Environment.hs index 08e477d78..fcad0031f 100644 --- a/servant/src/Servant/API/Environment.hs +++ b/servant/src/Servant/API/Environment.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + {-# OPTIONS_HADDOCK not-home #-} -- | Define API combinator that modify the behaviour of the routing environment. -module Servant.API.Environment (WithRoutingHeader) where +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. @@ -21,6 +27,31 @@ module Servant.API.Environment (WithRoutingHeader) where -- 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 From 56f639b581660b13ced9ab06bf67e2d4142a3715 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Tue, 29 Mar 2022 17:52:03 +0200 Subject: [PATCH 6/7] Add HasServer instance for Redirect --- servant-server/src/Servant/Server/Internal.hs | 22 +++++++++++++++++-- .../src/Servant/Server/Internal/Delayed.hs | 10 +++++++-- .../src/Servant/Server/Internal/RouterEnv.hs | 16 ++++++++++++-- 3 files changed, 42 insertions(+), 6 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 5d2800fe9..b1e08de7c 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -74,7 +74,7 @@ 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, WithRoutingHeader, NamedRoutes) @@ -89,7 +89,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 @@ -102,6 +102,7 @@ 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 @@ -260,6 +261,23 @@ instance ( HasServer api context 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 diff --git a/servant-server/src/Servant/Server/Internal/Delayed.hs b/servant-server/src/Servant/Server/Internal/Delayed.hs index 029d95ca0..9f98f9676 100644 --- a/servant-server/src/Servant/Server/Internal/Delayed.hs +++ b/servant-server/src/Servant/Server/Internal/Delayed.hs @@ -22,7 +22,7 @@ import Network.Wai import Servant.Server.Internal.DelayedIO import Servant.Server.Internal.Handler import Servant.Server.Internal.RouterEnv - (RouterEnv (..), hRoutedPathHeader, routedPathRepr) + (RouterEnv (..), hLocationHeader, hRoutedPathHeader, routedPathRepr) import Servant.Server.Internal.RouteResult import Servant.Server.Internal.ServerError @@ -266,11 +266,17 @@ runAction action env req respond k = runResourceT $ e <- runHandler a case e of Left err -> return . Route . withRoutingHeaders $ responseServerError err - Right x -> return $! withRoutingHeaders <$> k x + 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/servant-server/src/Servant/Server/Internal/RouterEnv.hs b/servant-server/src/Servant/Server/Internal/RouterEnv.hs index 15c628fe5..6042ffeb3 100644 --- a/servant-server/src/Servant/Server/Internal/RouterEnv.hs +++ b/servant-server/src/Servant/Server/Internal/RouterEnv.hs @@ -23,14 +23,20 @@ import Network.HTTP.Types.Header (HeaderName) data RouterEnv env = RouterEnv - { routedPath :: [PathPiece] + { locationHeader :: Maybe String + , routedPath :: [PathPiece] , shouldReturnRoutedPath :: Bool , routerEnv :: env } deriving Functor emptyEnv :: a -> RouterEnv a -emptyEnv v = RouterEnv [] False v +emptyEnv v = RouterEnv + { locationHeader = Nothing + , routedPath = [] + , shouldReturnRoutedPath = False + , routerEnv = v + } enableRoutingHeaders :: RouterEnv env -> RouterEnv env enableRoutingHeaders env = env { shouldReturnRoutedPath = True } @@ -61,5 +67,11 @@ toCaptureTag hint = captureName hint <> "::" <> (T.pack . show) (captureType hin 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" From 363d14257134b35f6b4523d9c3a9fc6c96f52f2a Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Wed, 30 Mar 2022 17:04:38 +0200 Subject: [PATCH 7/7] Add Spec test for Redirect combinator --- servant-server/test/Servant/ServerSpec.hs | 51 ++++++++++++++++++++++- 1 file changed, 50 insertions(+), 1 deletion(-) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 2b827d777..36ccaa4c2 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -56,7 +56,7 @@ import Servant.API HasStatus (StatusOf), Header, Headers, HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post, Put, - QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, + QueryFlag, QueryParam, QueryParams, Raw, Redirect, RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, StreamGet, Strict, UVerb, Union, Verb, WithRoutingHeader, WithStatus (..), addHeader) import Servant.Server @@ -108,6 +108,7 @@ spec = do basicAuthSpec genAuthSpec routedPathHeadersSpec + redirectionSpec ------------------------------------------------------------------------------ -- * verbSpec {{{ @@ -943,6 +944,54 @@ routedPathHeadersSpec = do 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 {{{