b1a6d88 · typeable/servant

git.iko.soy/typeable/servant

Revise the Router type to allow proper sharing.

We've previously used functions in the Router type to provide information for subrouters. But this accesses the Requests too early, and breaks sharing of the router structure in general, causing the Router or large parts of the Router to be recomputed on every request. We now do not use functions anymore, and properly compute all static parts of the router first, and gain access to the request only in Delayed. This also turns the code used within Delayed into a proper monad now called DelayedIO, making some of the code using it a bit nicer.

commitb1a6d8884565f5d577f3b8f7378208c20f8b2417 authorAndres Loeh <andres@well-typed.com> dateSat 9 Apr 2016, 15:42 (11 years ago) parentd4c6f67

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---

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

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

@@ -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,