git.iko.soy/typeable/servant
on master help sign in
Merge pull request #457 from kosmikus/fix-router-sharing

Fix router sharing

commit15143cc9008d3a861cfa2cd054f212da964fd9de authorAndres Löh <ksgithub@andres-loeh.de> dateTue 12 Apr 2016, 10:04 (11 years ago) parentd4c6f67b1a6d88
10 files changed+293−270
compare with master
unifiedsplit
servant-server/CHANGELOG.md+5−4 servant-server/src/Servant/Server.hs+6−16 servant-server/src/Servant/Server/Experimental/Auth.hs+11−7 servant-server/src/Servant/Server/Internal.hs+58−53 servant-server/src/Servant/Server/Internal/BasicAuth.hs+6−5 servant-server/src/Servant/Server/Internal/Router.hs+74−77 servant-server/src/Servant/Server/Internal/RoutingApplication.hs+126−98 servant-server/test/Servant/Server/RouterSpec.hs+5−7 servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs+1−2 servant-server/test/Servant/ServerSpec.hs+1−1
servant-server/CHANGELOG.md+5−4
@@ -1,10 +1,11 @@
110.7
22---
33
4−* The `Router` type has been changed. There are now more situations where
5− servers will make use of static lookups to efficiently route the request
6− to the correct endpoint. Functions `layout` and `layoutWithContext` have
7− been added to visualize the router layout for debugging purposes. Test
4+* The `Router` type has been changed. Static router tables should now
5+ be properly shared between requests, drastically increasing the
6+ number of situations where servers will be able to route requests
7+ efficiently. Functions `layout` and `layoutWithContext` have been
8+ added to visualize the router layout for debugging purposes. Test
89 cases for expected router layouts have been added.
910* Export `throwError` from module `Servant`
1011* Add `Handler` type synonym
servant-server/src/Servant/Server.hs+6−16
@@ -132,21 +132,13 @@ serve p = serveWithContext p EmptyContext
132132
133133serveWithContext :: (HasServer layout context)
134134 => Proxy layout -> Context context -> Server layout -> Application
135−serveWithContext p context server = toApplication (runRouter (route p context d))
136− where
137− d = Delayed r r r r (\ _ _ _ -> Route server)
138− r = return (Route ())
135+serveWithContext p context server =
136+ toApplication (runRouter (route p context (emptyDelayed (Route server))))
139137
140138-- | The function 'layout' produces a textual description of the internal
141139-- router layout for debugging purposes. Note that the router layout is
142140-- determined just by the API, not by the handlers.
143141--
144−-- This function makes certain assumptions about the well-behavedness of
145−-- the 'HasServer' instances of the combinators which should be ok for the
146−-- core servant constructions, but might not be satisfied for some other
147−-- combinators provided elsewhere. It is possible that the function may
148−-- crash for these.
149−--
150142-- Example:
151143--
152144-- For the following API
@@ -168,7 +160,7 @@ serveWithContext p context server = toApplication (runRouter (route p context d)
168160-- > │ └─ e/
169161-- > │ └─•
170162-- > ├─ b/
171−-- > │ └─ <dyn>/
163+-- > │ └─ <capture>/
172164-- > │ ├─•
173165-- > │ ┆
174166-- > │ └─•
@@ -185,7 +177,7 @@ serveWithContext p context server = toApplication (runRouter (route p context d)
185177--
186178-- [@─•@] Leaves reflect endpoints.
187179--
188−-- [@\<dyn\>/@] This is a delayed capture of a path component.
180+-- [@\<capture\>/@] This is a delayed capture of a path component.
189181--
190182-- [@\<raw\>@] This is a part of the API we do not know anything about.
191183--
@@ -200,10 +192,8 @@ layout p = layoutWithContext p EmptyContext
200192-- | Variant of 'layout' that takes an additional 'Context'.
201193layoutWithContext :: (HasServer layout context)
202194 => Proxy layout -> Context context -> Text
203−layoutWithContext p context = routerLayout (route p context d)
204− where
205− d = Delayed r r r r (\ _ _ _ -> FailFatal err501)
206− r = return (Route ())
195+layoutWithContext p context =
196+ routerLayout (route p context (emptyDelayed (FailFatal err501)))
207197
208198-- Documentation
209199
servant-server/src/Servant/Server/Experimental/Auth.hs+11−7
@@ -12,6 +12,7 @@
1212
1313module Servant.Server.Experimental.Auth where
1414
15+import Control.Monad.Trans (liftIO)
1516import Control.Monad.Trans.Except (runExceptT)
1617import Data.Proxy (Proxy (Proxy))
1718import Data.Typeable (Typeable)
@@ -24,10 +25,11 @@ import Servant.Server.Internal (HasContextEntry,
2425 HasServer, ServerT,
2526 getContextEntry,
2627 route)
27−import Servant.Server.Internal.Router (Router' (WithRequest))
28−import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route),
29− addAuthCheck)
30−import Servant.Server.Internal.ServantErr (ServantErr, Handler)
28+import Servant.Server.Internal.RoutingApplication (addAuthCheck,
29+ delayedFailFatal,
30+ DelayedIO,
31+ withRequest)
32+import Servant.Server.Internal.ServantErr (Handler)
3133
3234-- * General Auth
3335
@@ -57,8 +59,10 @@ instance ( HasServer api context
5759 type ServerT (AuthProtect tag :> api) m =
5860 AuthServerData (AuthProtect tag) -> ServerT api m
5961
60− route Proxy context subserver = WithRequest $ \ request ->
61− route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
62+ route Proxy context subserver =
63+ route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck)
6264 where
65+ authHandler :: Request -> Handler (AuthServerData (AuthProtect tag))
6366 authHandler = unAuthHandler (getContextEntry context)
64− authCheck = fmap (either FailFatal Route) . runExceptT . authHandler
67+ authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag))
68+ authCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . authHandler
servant-server/src/Servant/Server/Internal.hs+58−53
@@ -22,6 +22,7 @@ module Servant.Server.Internal
2222 , module Servant.Server.Internal.ServantErr
2323 ) where
2424
25+import Control.Monad.Trans (liftIO)
2526import qualified Data.ByteString as B
2627import qualified Data.ByteString.Char8 as BC8
2728import qualified Data.ByteString.Lazy as BL
@@ -70,7 +71,11 @@ import Servant.Server.Internal.ServantErr
7071class HasServer layout context where
7172 type ServerT layout (m :: * -> *) :: *
7273
73− route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router
74+ route ::
75+ Proxy layout
76+ -> Context context
77+ -> Delayed env (Server layout)
78+ -> Router env
7479
7580type Server layout = ServerT layout Handler
7681
@@ -92,7 +97,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
9297 type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
9398
9499 route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server))
95− (route pb context ((\ (_ :<|> b) -> b) <$> server))
100+ (route pb context ((\ (_ :<|> b) -> b) <$> server))
96101 where pa = Proxy :: Proxy a
97102 pb = Proxy :: Proxy b
98103
@@ -120,12 +125,12 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)
120125 a -> ServerT sublayout m
121126
122127 route Proxy context d =
123− DynamicRouter $ \ first ->
128+ CaptureRouter $
124129 route (Proxy :: Proxy sublayout)
125130 context
126− (addCapture d $ case parseUrlPieceMaybe first :: Maybe a of
127− Nothing -> return $ Fail err400
128− Just v -> return $ Route v
131+ (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of
132+ Nothing -> delayedFail err400
133+ Just v -> return v
129134 )
130135
131136allowedMethodHead :: Method -> Request -> Bool
@@ -144,41 +149,41 @@ processMethodRouter handleA status method headers request = case handleA of
144149 bdy = if allowedMethodHead method request then "" else body
145150 hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
146151
147−methodCheck :: Method -> Request -> IO (RouteResult ())
152+methodCheck :: Method -> Request -> DelayedIO ()
148153methodCheck method request
149− | allowedMethod method request = return $ Route ()
150− | otherwise = return $ Fail err405
154+ | allowedMethod method request = return ()
155+ | otherwise = delayedFail err405
151156
152−acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())
157+acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
153158acceptCheck proxy accH
154− | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()
155− | otherwise = return $ FailFatal err406
159+ | canHandleAcceptH proxy (AcceptHeader accH) = return ()
160+ | otherwise = delayedFailFatal err406
156161
157162methodRouter :: (AllCTRender ctypes a)
158163 => Method -> Proxy ctypes -> Status
159− -> Delayed (Handler a)
160− -> Router
164+ -> Delayed env (Handler a)
165+ -> Router env
161166methodRouter method proxy status action = leafRouter route'
162167 where
163− route' request respond =
168+ route' env request respond =
164169 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
165170 in runAction (action `addMethodCheck` methodCheck method request
166171 `addAcceptCheck` acceptCheck proxy accH
167− ) respond $ \ output -> do
172+ ) env request respond $ \ output -> do
168173 let handleA = handleAcceptH proxy (AcceptHeader accH) output
169174 processMethodRouter handleA status method Nothing request
170175
171176methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
172177 => Method -> Proxy ctypes -> Status
173− -> Delayed (Handler (Headers h v))
174− -> Router
178+ -> Delayed env (Handler (Headers h v))
179+ -> Router env
175180methodRouterHeaders method proxy status action = leafRouter route'
176181 where
177− route' request respond =
182+ route' env request respond =
178183 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
179184 in runAction (action `addMethodCheck` methodCheck method request
180185 `addAcceptCheck` acceptCheck proxy accH
181− ) respond $ \ output -> do
186+ ) env request respond $ \ output -> do
182187 let headers = getHeaders output
183188 handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
184189 processMethodRouter handleA status method (Just headers) request
@@ -230,8 +235,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
230235 type ServerT (Header sym a :> sublayout) m =
231236 Maybe a -> ServerT sublayout m
232237
233− route Proxy context subserver = WithRequest $ \ request ->
234− let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
238+ route Proxy context subserver =
239+ let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req)
235240 in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader)
236241 where str = fromString $ symbolVal (Proxy :: Proxy sym)
237242
@@ -262,10 +267,10 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
262267 type ServerT (QueryParam sym a :> sublayout) m =
263268 Maybe a -> ServerT sublayout m
264269
265− route Proxy context subserver = WithRequest $ \ request ->
266− let querytext = parseQueryText $ rawQueryString request
267− param =
268− case lookup paramname querytext of
270+ route Proxy context subserver =
271+ let querytext r = parseQueryText $ rawQueryString r
272+ param r =
273+ case lookup paramname (querytext r) of
269274 Nothing -> Nothing -- param absent from the query string
270275 Just Nothing -> Nothing -- param present with no value -> Nothing
271276 Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
@@ -298,13 +303,13 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)
298303 type ServerT (QueryParams sym a :> sublayout) m =
299304 [a] -> ServerT sublayout m
300305
301− route Proxy context subserver = WithRequest $ \ request ->
302− let querytext = parseQueryText $ rawQueryString request
306+ route Proxy context subserver =
307+ let querytext r = parseQueryText $ rawQueryString r
303308 -- if sym is "foo", we look for query string parameters
304309 -- named "foo" or "foo[]" and call parseQueryParam on the
305310 -- corresponding values
306− parameters = filter looksLikeParam querytext
307− values = mapMaybe (convert . snd) parameters
311+ parameters r = filter looksLikeParam (querytext r)
312+ values r = mapMaybe (convert . snd) (parameters r)
308313 in route (Proxy :: Proxy sublayout) context (passToServer subserver values)
309314 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
310315 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
@@ -329,9 +334,9 @@ instance (KnownSymbol sym, HasServer sublayout context)
329334 type ServerT (QueryFlag sym :> sublayout) m =
330335 Bool -> ServerT sublayout m
331336
332− route Proxy context subserver = WithRequest $ \ request ->
333− let querytext = parseQueryText $ rawQueryString request
334− param = case lookup paramname querytext of
337+ route Proxy context subserver =
338+ let querytext r = parseQueryText $ rawQueryString r
339+ param r = case lookup paramname (querytext r) of
335340 Just Nothing -> True -- param is there, with no value
336341 Just (Just v) -> examine v -- param with a value
337342 Nothing -> False -- param not in the query string
@@ -352,8 +357,8 @@ instance HasServer Raw context where
352357
353358 type ServerT Raw m = Application
354359
355− route Proxy _ rawApplication = RawRouter $ \ request respond -> do
356− r <- runDelayed rawApplication
360+ route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
361+ r <- runDelayed rawApplication env request
357362 case r of
358363 Route app -> app request (respond . Route)
359364 Fail a -> respond $ Fail a
@@ -386,10 +391,10 @@ instance ( AllCTUnrender list a, HasServer sublayout context
386391 type ServerT (ReqBody list a :> sublayout) m =
387392 a -> ServerT sublayout m
388393
389− route Proxy context subserver = WithRequest $ \ request ->
390− route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request))
394+ route Proxy context subserver =
395+ route (Proxy :: Proxy sublayout) context (addBodyCheck subserver bodyCheck)
391396 where
392− bodyCheck request = do
397+ bodyCheck = withRequest $ \ request -> do
393398 -- See HTTP RFC 2616, section 7.2.1
394399 -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
395400 -- See also "W3C Internet Media Type registration, consistency of use"
@@ -397,11 +402,11 @@ instance ( AllCTUnrender list a, HasServer sublayout context
397402 let contentTypeH = fromMaybe "application/octet-stream"
398403 $ lookup hContentType $ requestHeaders request
399404 mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
400− <$> lazyRequestBody request
405+ <$> liftIO (lazyRequestBody request)
401406 case mrqbody of
402− Nothing -> return $ FailFatal err415
403− Just (Left e) -> return $ FailFatal err400 { errBody = cs e }
404− Just (Right v) -> return $ Route v
407+ Nothing -> delayedFailFatal err415
408+ Just (Left e) -> delayedFailFatal err400 { errBody = cs e }
409+ Just (Right v) -> return v
405410
406411-- | Make sure the incoming request starts with @"/path"@, strip it and
407412-- pass the rest of the request path to @sublayout@.
@@ -418,28 +423,28 @@ instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> s
418423instance HasServer api context => HasServer (RemoteHost :> api) context where
419424 type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
420425
421− route Proxy context subserver = WithRequest $ \req ->
422− route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req)
426+ route Proxy context subserver =
427+ route (Proxy :: Proxy api) context (passToServer subserver remoteHost)
423428
424429instance HasServer api context => HasServer (IsSecure :> api) context where
425430 type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
426431
427− route Proxy context subserver = WithRequest $ \req ->
428− route (Proxy :: Proxy api) context (passToServer subserver $ secure req)
432+ route Proxy context subserver =
433+ route (Proxy :: Proxy api) context (passToServer subserver secure)
429434
430435 where secure req = if isSecure req then Secure else NotSecure
431436
432437instance HasServer api context => HasServer (Vault :> api) context where
433438 type ServerT (Vault :> api) m = Vault -> ServerT api m
434439
435− route Proxy context subserver = WithRequest $ \req ->
436− route (Proxy :: Proxy api) context (passToServer subserver $ vault req)
440+ route Proxy context subserver =
441+ route (Proxy :: Proxy api) context (passToServer subserver vault)
437442
438443instance HasServer api context => HasServer (HttpVersion :> api) context where
439444 type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
440445
441− route Proxy context subserver = WithRequest $ \req ->
442− route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)
446+ route Proxy context subserver =
447+ route (Proxy :: Proxy api) context (passToServer subserver httpVersion)
443448
444449-- | Basic Authentication
445450instance ( KnownSymbol realm
@@ -450,12 +455,12 @@ instance ( KnownSymbol realm
450455
451456 type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m
452457
453− route Proxy context subserver = WithRequest $ \ request ->
454− route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
458+ route Proxy context subserver =
459+ route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck)
455460 where
456461 realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
457462 basicAuthContext = getContextEntry context
458− authCheck req = runBasicAuth req realm basicAuthContext
463+ authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext
459464
460465-- * helpers
461466
servant-server/src/Servant/Server/Internal/BasicAuth.hs+6−5
@@ -6,6 +6,7 @@
66module Servant.Server.Internal.BasicAuth where
77
88import Control.Monad (guard)
9+import Control.Monad.Trans (liftIO)
910import qualified Data.ByteString as BS
1011import Data.ByteString.Base64 (decodeLenient)
1112import Data.Monoid ((<>))
@@ -57,13 +58,13 @@ decodeBAHdr req = do
5758
5859-- | Run and check basic authentication, returning the appropriate http error per
5960-- the spec.
60−runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr)
61+runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> DelayedIO usr
6162runBasicAuth req realm (BasicAuthCheck ba) =
6263 case decodeBAHdr req of
6364 Nothing -> plzAuthenticate
64− Just e -> ba e >>= \res -> case res of
65+ Just e -> liftIO (ba e) >>= \res -> case res of
6566 BadPassword -> plzAuthenticate
6667 NoSuchUser -> plzAuthenticate
67− Unauthorized -> return $ FailFatal err403
68− Authorized usr -> return $ Route usr
69− where plzAuthenticate = return $ FailFatal err401 { errHeaders = [mkBAChallengerHdr realm] }
68+ Unauthorized -> delayedFailFatal err403
69+ Authorized usr -> return usr
70+ where plzAuthenticate = delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm] }
servant-server/src/Servant/Server/Internal/Router.hs+74−77
@@ -1,5 +1,7 @@
11{-# LANGUAGE DeriveFunctor #-}
22{-# LANGUAGE CPP #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE KindSignatures #-}
35{-# LANGUAGE OverloadedStrings #-}
46module Servant.Server.Internal.Router where
57
@@ -8,36 +10,41 @@ import qualified Data.Map as M
810import Data.Monoid
911import Data.Text (Text)
1012import qualified Data.Text as T
11−import Network.Wai (Request, Response, pathInfo)
13+import Network.Wai (Response, pathInfo)
1214import Servant.Server.Internal.RoutingApplication
1315import Servant.Server.Internal.ServantErr
1416
15−type Router = Router' RoutingApplication
17+type Router env = Router' env RoutingApplication
1618
1719-- | Internal representation of a router.
18−data Router' a =
19− WithRequest (Request -> Router' a)
20− -- ^ current request is passed to the router
21− | StaticRouter (Map Text (Router' a)) [a]
20+--
21+-- The first argument describes an environment type that is
22+-- expected as extra input by the routers at the leaves. The
23+-- environment is filled while running the router, with path
24+-- components that can be used to process captures.
25+--
26+data Router' env a =
27+ StaticRouter (Map Text (Router' env a)) [env -> a]
2228 -- ^ the map contains routers for subpaths (first path component used
2329 -- for lookup and removed afterwards), the list contains handlers
2430 -- for the empty path, to be tried in order
25− | DynamicRouter (Text -> Router' a)
26− -- ^ first path component passed to the function and removed afterwards
27− | RawRouter a
31+ | CaptureRouter (Router' (Text, env) a)
32+ -- ^ first path component is passed to the child router in its
33+ -- environment and removed afterwards
34+ | RawRouter (env -> a)
2835 -- ^ to be used for routes we do not know anything about
29− | Choice (Router' a) (Router' a)
36+ | Choice (Router' env a) (Router' env a)
3037 -- ^ left-biased choice between two routers
3138 deriving Functor
3239
3340-- | Smart constructor for a single static path component.
34−pathRouter :: Text -> Router' a -> Router' a
41+pathRouter :: Text -> Router' env a -> Router' env a
3542pathRouter t r = StaticRouter (M.singleton t r) []
3643
3744-- | Smart constructor for a leaf, i.e., a router that expects
3845-- the empty path.
3946--
40−leafRouter :: a -> Router' a
47+leafRouter :: (env -> a) -> Router' env a
4148leafRouter l = StaticRouter M.empty [l]
4249
4350-- | Smart constructor for the choice between routers.
@@ -46,40 +53,27 @@ leafRouter l = StaticRouter M.empty [l]
4653-- * Two static routers can be joined by joining their maps
4754-- and concatenating their leaf-lists.
4855-- * Two dynamic routers can be joined by joining their codomains.
49−-- * Two 'WithRequest' routers can be joined by passing them
50−-- the same request and joining their codomains.
51−-- * A 'WithRequest' router can be joined with anything else by
52−-- passing the same request to both but ignoring it in the
53−-- component that does not need it.
5456-- * Choice nodes can be reordered.
5557--
56−choice :: Router -> Router -> Router
58+choice :: Router' env a -> Router' env a -> Router' env a
5759choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
5860 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
59−choice (DynamicRouter fun1) (DynamicRouter fun2) =
60− DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
61−choice (WithRequest router1) (WithRequest router2) =
62− WithRequest (\ request -> choice (router1 request) (router2 request))
63−choice (WithRequest router1) router2 =
64− WithRequest (\ request -> choice (router1 request) router2)
65−choice router1 (WithRequest router2) =
66− WithRequest (\ request -> choice router1 (router2 request))
61+choice (CaptureRouter router1) (CaptureRouter router2) =
62+ CaptureRouter (choice router1 router2)
6763choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
6864choice router1 router2 = Choice router1 router2
6965
7066-- | Datatype used for representing and debugging the
71−-- structure of a router. Abstracts from the functions
72−-- being used in the actual router and the handlers at
73−-- the leaves.
67+-- structure of a router. Abstracts from the handlers
68+-- at the leaves.
7469--
7570-- Two 'Router's can be structurally compared by computing
7671-- their 'RouterStructure' using 'routerStructure' and
7772-- then testing for equality, see 'sameStructure'.
7873--
7974data RouterStructure =
80− WithRequestStructure RouterStructure
81− | StaticRouterStructure (Map Text RouterStructure) Int
82− | DynamicRouterStructure RouterStructure
75+ StaticRouterStructure (Map Text RouterStructure) Int
76+ | CaptureRouterStructure RouterStructure
8377 | RawRouterStructure
8478 | ChoiceStructure RouterStructure RouterStructure
8579 deriving (Eq, Show)
@@ -87,18 +81,15 @@ data RouterStructure =
8781-- | Compute the structure of a router.
8882--
8983-- Assumes that the request or text being passed
90−-- in 'WithRequest' or 'DynamicRouter' does not
84+-- in 'WithRequest' or 'CaptureRouter' does not
9185-- affect the structure of the underlying tree.
9286--
93−routerStructure :: Router' a -> RouterStructure
94−routerStructure (WithRequest f) =
95− WithRequestStructure $
96− routerStructure (f (error "routerStructure: dummy request"))
87+routerStructure :: Router' env a -> RouterStructure
9788routerStructure (StaticRouter m ls) =
9889 StaticRouterStructure (fmap routerStructure m) (length ls)
99−routerStructure (DynamicRouter f) =
100− DynamicRouterStructure $
101− routerStructure (f (error "routerStructure: dummy text"))
90+routerStructure (CaptureRouter router) =
91+ CaptureRouterStructure $
92+ routerStructure router
10293routerStructure (RawRouter _) =
10394 RawRouterStructure
10495routerStructure (Choice r1 r2) =
@@ -108,21 +99,20 @@ routerStructure (Choice r1 r2) =
10899
109100-- | Compare the structure of two routers.
110101--
111−sameStructure :: Router' a -> Router' b -> Bool
102+sameStructure :: Router' env a -> Router' env b -> Bool
112103sameStructure r1 r2 =
113104 routerStructure r1 == routerStructure r2
114105
115106-- | Provide a textual representation of the
116107-- structure of a router.
117108--
118−routerLayout :: Router' a -> Text
109+routerLayout :: Router' env a -> Text
119110routerLayout router =
120111 T.unlines (["/"] ++ mkRouterLayout False (routerStructure router))
121112 where
122113 mkRouterLayout :: Bool -> RouterStructure -> [Text]
123− mkRouterLayout c (WithRequestStructure r) = mkRouterLayout c r
124114 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
125− mkRouterLayout c (DynamicRouterStructure r) = mkSubTree c "<dyn>" (mkRouterLayout False r)
115+ mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "<capture>" (mkRouterLayout False r)
126116 mkRouterLayout c RawRouterStructure =
127117 if c then ["├─ <raw>"] else ["└─ <raw>"]
128118 mkRouterLayout c (ChoiceStructure r1 r2) =
@@ -146,47 +136,54 @@ routerLayout router =
146136 mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children
147137
148138-- | Apply a transformation to the response of a `Router`.
149−tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router
139+tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env -> Router env
150140tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
151141
152142-- | Interpret a router as an application.
153−runRouter :: Router -> RoutingApplication
154−runRouter (WithRequest router) request respond =
155− runRouter (router request) request respond
156−runRouter (StaticRouter table ls) request respond =
157− case pathInfo request of
158− [] -> runChoice ls request respond
159− -- This case is to handle trailing slashes.
160− [""] -> runChoice ls request respond
161− first : rest | Just router <- M.lookup first table
162− -> let request' = request { pathInfo = rest }
163− in runRouter router request' respond
164− _ -> respond $ Fail err404
165−runRouter (DynamicRouter fun) request respond =
166− case pathInfo request of
167− [] -> respond $ Fail err404
168− -- This case is to handle trailing slashes.
169− [""] -> respond $ Fail err404
170− first : rest
171− -> let request' = request { pathInfo = rest }
172− in runRouter (fun first) request' respond
173−runRouter (RawRouter app) request respond = app request respond
174−runRouter (Choice r1 r2) request respond =
175− runChoice [runRouter r1, runRouter r2] request respond
143+runRouter :: Router () -> RoutingApplication
144+runRouter r = runRouterEnv r ()
145+
146+runRouterEnv :: Router env -> env -> RoutingApplication
147+runRouterEnv router env request respond =
148+ case router of
149+ StaticRouter table ls ->
150+ case pathInfo request of
151+ [] -> runChoice ls env request respond
152+ -- This case is to handle trailing slashes.
153+ [""] -> runChoice ls env request respond
154+ first : rest | Just router' <- M.lookup first table
155+ -> let request' = request { pathInfo = rest }
156+ in runRouterEnv router' env request' respond
157+ _ -> respond $ Fail err404
158+ CaptureRouter router' ->
159+ case pathInfo request of
160+ [] -> respond $ Fail err404
161+ -- This case is to handle trailing slashes.
162+ [""] -> respond $ Fail err404
163+ first : rest
164+ -> let request' = request { pathInfo = rest }
165+ in runRouterEnv router' (first, env) request' respond
166+ RawRouter app ->
167+ app env request respond
168+ Choice r1 r2 ->
169+ runChoice [runRouterEnv r1, runRouterEnv r2] env request respond
176170
177171-- | Try a list of routing applications in order.
178172-- We stop as soon as one fails fatally or succeeds.
179173-- If all fail normally, we pick the "best" error.
180174--
181−runChoice :: [RoutingApplication] -> RoutingApplication
182−runChoice [] _request respond = respond (Fail err404)
183−runChoice [r] request respond = r request respond
184−runChoice (r : rs) request respond =
185− r request $ \ response1 ->
186− case response1 of
187− Fail _ -> runChoice rs request $ \ response2 ->
188− respond $ highestPri response1 response2
189− _ -> respond response1
175+runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication
176+runChoice ls =
177+ case ls of
178+ [] -> \ _ _ respond -> respond (Fail err404)
179+ [r] -> r
180+ (r : rs) ->
181+ \ env request respond ->
182+ r env request $ \ response1 ->
183+ case response1 of
184+ Fail _ -> runChoice rs env request $ \ response2 ->
185+ respond $ highestPri response1 response2
186+ _ -> respond response1
190187 where
191188 highestPri (Fail e1) (Fail e2) =
192189 if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)
servant-server/src/Servant/Server/Internal/RoutingApplication.hs+126−98
@@ -8,7 +8,10 @@
88{-# LANGUAGE StandaloneDeriving #-}
99module Servant.Server.Internal.RoutingApplication where
1010
11+import Control.Monad (ap, liftM)
12+import Control.Monad.Trans (MonadIO(..))
1113import Control.Monad.Trans.Except (runExceptT)
14+import Data.Text (Text)
1215import Network.Wai (Application, Request,
1316 Response, ResponseReceived)
1417import Prelude ()
@@ -95,113 +98,133 @@ toApplication ra request respond = ra request routingRespond
9598-- The accept header check can be performed as the final
9699-- computation in this block. It can cause a 406.
97100--
98−data Delayed c where
99− Delayed :: { capturesD :: IO (RouteResult captures)
100− , methodD :: IO (RouteResult ())
101− , authD :: IO (RouteResult auth)
102− , bodyD :: IO (RouteResult body)
103− , serverD :: (captures -> auth -> body -> RouteResult c)
104− } -> Delayed c
105−
106−instance Functor Delayed where
107− fmap f Delayed{..}
108− = Delayed { capturesD = capturesD
109− , methodD = methodD
110− , authD = authD
111− , bodyD = bodyD
112− , serverD = (fmap.fmap.fmap.fmap) f serverD
113− } -- Note [Existential Record Update]
101+data Delayed env c where
102+ Delayed :: { capturesD :: env -> DelayedIO captures
103+ , methodD :: DelayedIO ()
104+ , authD :: DelayedIO auth
105+ , bodyD :: DelayedIO body
106+ , serverD :: captures -> auth -> body -> Request -> RouteResult c
107+ } -> Delayed env c
108+
109+instance Functor (Delayed env) where
110+ fmap f Delayed{..} =
111+ Delayed
112+ { serverD = \ c a b req -> f <$> serverD c a b req
113+ , ..
114+ } -- Note [Existential Record Update]
115+
116+-- | Computations used in a 'Delayed' can depend on the
117+-- incoming 'Request', may perform 'IO, and result in a
118+-- 'RouteResult, meaning they can either suceed, fail
119+-- (with the possibility to recover), or fail fatally.
120+--
121+newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> IO (RouteResult a) }
122+
123+instance Functor DelayedIO where
124+ fmap = liftM
125+
126+instance Applicative DelayedIO where
127+ pure = return
128+ (<*>) = ap
129+
130+instance Monad DelayedIO where
131+ return x = DelayedIO (const $ return (Route x))
132+ DelayedIO m >>= f =
133+ DelayedIO $ \ req -> do
134+ r <- m req
135+ case r of
136+ Fail e -> return $ Fail e
137+ FailFatal e -> return $ FailFatal e
138+ Route a -> runDelayedIO (f a) req
139+
140+instance MonadIO DelayedIO where
141+ liftIO m = DelayedIO (const $ Route <$> m)
142+
143+-- | A 'Delayed' without any stored checks.
144+emptyDelayed :: RouteResult a -> Delayed env a
145+emptyDelayed result =
146+ Delayed (const r) r r r (\ _ _ _ _ -> result)
147+ where
148+ r = return ()
149+
150+-- | Fail with the option to recover.
151+delayedFail :: ServantErr -> DelayedIO a
152+delayedFail err = DelayedIO (const $ return $ Fail err)
153+
154+-- | Fail fatally, i.e., without any option to recover.
155+delayedFailFatal :: ServantErr -> DelayedIO a
156+delayedFailFatal err = DelayedIO (const $ return $ FailFatal err)
157+
158+-- | Gain access to the incoming request.
159+withRequest :: (Request -> DelayedIO a) -> DelayedIO a
160+withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)
114161
115162-- | Add a capture to the end of the capture block.
116−addCapture :: Delayed (a -> b)
117− -> IO (RouteResult a)
118− -> Delayed b
119−addCapture Delayed{..} new
120− = Delayed { capturesD = combineRouteResults (,) capturesD new
121− , methodD = methodD
122− , authD = authD
123− , bodyD = bodyD
124− , serverD = \ (x, v) y z -> ($ v) <$> serverD x y z
125− } -- Note [Existential Record Update]
163+addCapture :: Delayed env (a -> b)
164+ -> (Text -> DelayedIO a)
165+ -> Delayed (Text, env) b
166+addCapture Delayed{..} new =
167+ Delayed
168+ { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
169+ , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req
170+ , ..
171+ } -- Note [Existential Record Update]
126172
127173-- | Add a method check to the end of the method block.
128−addMethodCheck :: Delayed a
129− -> IO (RouteResult ())
130− -> Delayed a
131−addMethodCheck Delayed{..} new
132− = Delayed { capturesD = capturesD
133− , methodD = combineRouteResults const methodD new
134− , authD = authD
135− , bodyD = bodyD
136− , serverD = serverD
137− } -- Note [Existential Record Update]
174+addMethodCheck :: Delayed env a
175+ -> DelayedIO ()
176+ -> Delayed env a
177+addMethodCheck Delayed{..} new =
178+ Delayed
179+ { methodD = methodD <* new
180+ , ..
181+ } -- Note [Existential Record Update]
138182
139183-- | Add an auth check to the end of the auth block.
140−addAuthCheck :: Delayed (a -> b)
141− -> IO (RouteResult a)
142− -> Delayed b
143−addAuthCheck Delayed{..} new
144− = Delayed { capturesD = capturesD
145− , methodD = methodD
146− , authD = combineRouteResults (,) authD new
147− , bodyD = bodyD
148− , serverD = \ x (y, v) z -> ($ v) <$> serverD x y z
149− } -- Note [Existential Record Update]
184+addAuthCheck :: Delayed env (a -> b)
185+ -> DelayedIO a
186+ -> Delayed env b
187+addAuthCheck Delayed{..} new =
188+ Delayed
189+ { authD = (,) <$> authD <*> new
190+ , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req
191+ , ..
192+ } -- Note [Existential Record Update]
150193
151194-- | Add a body check to the end of the body block.
152−addBodyCheck :: Delayed (a -> b)
153− -> IO (RouteResult a)
154− -> Delayed b
155−addBodyCheck Delayed{..} new
156− = Delayed { capturesD = capturesD
157− , methodD = methodD
158− , authD = authD
159− , bodyD = combineRouteResults (,) bodyD new
160− , serverD = \ x y (z, v) -> ($ v) <$> serverD x y z
161− } -- Note [Existential Record Update]
195+addBodyCheck :: Delayed env (a -> b)
196+ -> DelayedIO a
197+ -> Delayed env b
198+addBodyCheck Delayed{..} new =
199+ Delayed
200+ { bodyD = (,) <$> bodyD <*> new
201+ , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req
202+ , ..
203+ } -- Note [Existential Record Update]
162204
163205
164206-- | Add an accept header check to the end of the body block.
165207-- The accept header check should occur after the body check,
166208-- but this will be the case, because the accept header check
167209-- is only scheduled by the method combinators.
168−addAcceptCheck :: Delayed a
169− -> IO (RouteResult ())
170− -> Delayed a
171−addAcceptCheck Delayed{..} new
172− = Delayed { capturesD = capturesD
173− , methodD = methodD
174− , authD = authD
175− , bodyD = combineRouteResults const bodyD new
176− , serverD = serverD
177− } -- Note [Existential Record Update]
210+addAcceptCheck :: Delayed env a
211+ -> DelayedIO ()
212+ -> Delayed env a
213+addAcceptCheck Delayed{..} new =
214+ Delayed
215+ { bodyD = bodyD <* new
216+ , ..
217+ } -- Note [Existential Record Update]
178218
179219-- | Many combinators extract information that is passed to
180220-- the handler without the possibility of failure. In such a
181221-- case, 'passToServer' can be used.
182−passToServer :: Delayed (a -> b) -> a -> Delayed b
183−passToServer d x = ($ x) <$> d
184−
185−-- | The combination 'IO . RouteResult' is a monad, but we
186−-- don't explicitly wrap it in a newtype in order to make it
187−-- an instance. This is the '>>=' of that monad.
188−--
189−-- We stop on the first error.
190−bindRouteResults :: IO (RouteResult a) -> (a -> IO (RouteResult b)) -> IO (RouteResult b)
191−bindRouteResults m f = do
192− r <- m
193− case r of
194− Fail e -> return $ Fail e
195− FailFatal e -> return $ FailFatal e
196− Route a -> f a
197−
198−-- | Common special case of 'bindRouteResults', corresponding
199−-- to 'liftM2'.
200−combineRouteResults :: (a -> b -> c) -> IO (RouteResult a) -> IO (RouteResult b) -> IO (RouteResult c)
201−combineRouteResults f m1 m2 =
202− m1 `bindRouteResults` \ a ->
203− m2 `bindRouteResults` \ b ->
204− return (Route (f a b))
222+passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
223+passToServer Delayed{..} x =
224+ Delayed
225+ { serverD = \ c a b req -> ($ x req) <$> serverD c a b req
226+ , ..
227+ } -- Note [Existential Record Update]
205228
206229-- | Run a delayed server. Performs all scheduled operations
207230-- in order, and passes the results from the capture and body
@@ -209,24 +232,29 @@ combineRouteResults f m1 m2 =
209232--
210233-- This should only be called once per request; otherwise the guarantees about
211234-- effect and HTTP error ordering break down.
212−runDelayed :: Delayed a
235+runDelayed :: Delayed env a
236+ -> env
237+ -> Request
213238 -> IO (RouteResult a)
214−runDelayed Delayed{..} =
215− capturesD `bindRouteResults` \ c ->
216− methodD `bindRouteResults` \ _ ->
217− authD `bindRouteResults` \ a ->
218− bodyD `bindRouteResults` \ b ->
219− return (serverD c a b)
239+runDelayed Delayed{..} env = runDelayedIO $ do
240+ c <- capturesD env
241+ methodD
242+ a <- authD
243+ b <- bodyD
244+ DelayedIO (\ req -> return $ serverD c a b req)
220245
221246-- | Runs a delayed server and the resulting action.
222247-- Takes a continuation that lets us send a response.
223248-- Also takes a continuation for how to turn the
224249-- result of the delayed server into a response.
225−runAction :: Delayed (Handler a)
250+runAction :: Delayed env (Handler a)
251+ -> env
252+ -> Request
226253 -> (RouteResult Response -> IO r)
227254 -> (a -> RouteResult Response)
228255 -> IO r
229−runAction action respond k = runDelayed action >>= go >>= respond
256+runAction action env req respond k =
257+ runDelayed action env req >>= go >>= respond
230258 where
231259 go (Fail e) = return $ Fail e
232260 go (FailFatal e) = return $ FailFatal e
servant-server/test/Servant/Server/RouterSpec.hs+5−7
@@ -25,9 +25,9 @@ routerSpec = do
2525 let app' :: Application
2626 app' = toApplication $ runRouter router'
2727
28− router', router :: Router
28+ router', router :: Router ()
2929 router' = tweakResponse (fmap twk) router
30− router = leafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")
30+ router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")
3131
3232 twk :: Response -> Response
3333 twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
@@ -69,11 +69,9 @@ shouldHaveSameStructureAs p1 p2 =
6969 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $
7070 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))
7171
72−makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router
73−makeTrivialRouter p = route p EmptyContext d
74− where
75− d = Delayed r r r r (\ _ _ _ -> FailFatal err501)
76− r = return (Route ())
72+makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()
73+makeTrivialRouter p =
74+ route p EmptyContext (emptyDelayed (FailFatal err501))
7775
7876type End = Get '[JSON] ()
7977
servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs+1−2
@@ -20,7 +20,6 @@ module Servant.Server.UsingContextSpec.TestCombinators where
2020import GHC.TypeLits
2121
2222import Servant
23−import Servant.Server.Internal.RoutingApplication
2423
2524data ExtractFromContext
2625
@@ -31,7 +30,7 @@ instance (HasContextEntry context String, HasServer subApi context) =>
3130 String -> ServerT subApi m
3231
3332 route Proxy context delayed =
34− route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi))
33+ route subProxy context (fmap (inject context) delayed)
3534 where
3635 subProxy :: Proxy subApi
3736 subProxy = Proxy
servant-server/test/Servant/ServerSpec.hs+1−1
@@ -48,7 +48,7 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect,
4848 Raw, RemoteHost, ReqBody,
4949 StdMethod (..), Verb, addHeader)
5050import Servant.API.Internal.Test.ComprehensiveAPI
51−import Servant.Server (ServantErr (..), Server, Handler, err401, err403,
51+import Servant.Server (Server, Handler, err401, err403,
5252 err404, serve, serveWithContext,
5353 Context((:.), EmptyContext))
5454import Test.Hspec (Spec, context, describe, it,