15143cc · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Merge pull request #457 from kosmikus/fix-router-sharing

15143ccAndres Löh11 years ago

servant-server/CHANGELOG.md+5−4

compare with master

unifiedsplit

@@ -1,10 +1,11 @@

10.7

2---

4−* The `Router` type has been changed. There are now more situations where

4+* The `Router` type has been changed. Static router tables should now

5− servers will make use of static lookups to efficiently route the request

5+ be properly shared between requests, drastically increasing the

6+ number of situations where servers will be able to route requests

6− to the correct endpoint. Functions `layout` and `layoutWithContext` have

7+ efficiently. Functions `layout` and `layoutWithContext` have been

7− been added to visualize the router layout for debugging purposes. Test

8+ added to visualize the router layout for debugging purposes. Test

8 cases for expected router layouts have been added.

9 cases for expected router layouts have been added.

9* Export `throwError` from module `Servant`

10* Export `throwError` from module `Servant`

10* Add `Handler` type synonym

11* Add `Handler` type synonym

servant-server/src/Servant/Server.hs+6−16

@@ -132,21 +132,13 @@ serve p = serveWithContext p EmptyContext

132

133serveWithContext :: (HasServer layout context)

134 => Proxy layout -> Context context -> Server layout -> Application

135−serveWithContext p context server = toApplication (runRouter (route p context d))

135+serveWithContext p context server =

136− where

136+ toApplication (runRouter (route p context (emptyDelayed (Route server))))

137− d = Delayed r r r r (\ _ _ _ -> Route server)

138− r = return (Route ())

139

137

140-- | The function 'layout' produces a textual description of the internal

138-- | The function 'layout' produces a textual description of the internal

141-- router layout for debugging purposes. Note that the router layout is

139-- router layout for debugging purposes. Note that the router layout is

142-- determined just by the API, not by the handlers.

140-- determined just by the API, not by the handlers.

143--

141--

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

150-- Example:

142-- Example:

151--

143--

152-- For the following API

144-- For the following API

@@ -168,7 +160,7 @@ serveWithContext p context server = toApplication (runRouter (route p context d)

168-- > │ └─ e/

160-- > │ └─ e/

169-- > │ └─•

161-- > │ └─•

170-- > ├─ b/

162-- > ├─ b/

171−-- > │ └─ <dyn>/

163+-- > │ └─ <capture>/

172-- > │ ├─•

164-- > │ ├─•

173-- > │ ┆

165-- > │ ┆

174-- > │ └─•

166-- > │ └─•

@@ -185,7 +177,7 @@ serveWithContext p context server = toApplication (runRouter (route p context d)

185--

177--

186-- [@─•@] Leaves reflect endpoints.

178-- [@─•@] Leaves reflect endpoints.

187--

179--

188−-- [@\<dyn\>/@] This is a delayed capture of a path component.

180+-- [@\<capture\>/@] This is a delayed capture of a path component.

189--

181--

190-- [@\<raw\>@] This is a part of the API we do not know anything about.

182-- [@\<raw\>@] This is a part of the API we do not know anything about.

191--

183--

@@ -200,10 +192,8 @@ layout p = layoutWithContext p EmptyContext

200-- | Variant of 'layout' that takes an additional 'Context'.

192-- | Variant of 'layout' that takes an additional 'Context'.

201layoutWithContext :: (HasServer layout context)

193layoutWithContext :: (HasServer layout context)

202 => Proxy layout -> Context context -> Text

194 => Proxy layout -> Context context -> Text

203−layoutWithContext p context = routerLayout (route p context d)

195+layoutWithContext p context =

204− where

196+ routerLayout (route p context (emptyDelayed (FailFatal err501)))

205− d = Delayed r r r r (\ _ _ _ -> FailFatal err501)

206− r = return (Route ())

207

197

208-- Documentation

198-- Documentation

209

199

servant-server/src/Servant/Server/Experimental/Auth.hs+11−7

@@ -12,6 +12,7 @@

13module Servant.Server.Experimental.Auth where

15+import Control.Monad.Trans (liftIO)

15import Control.Monad.Trans.Except (runExceptT)

16import Control.Monad.Trans.Except (runExceptT)

16import Data.Proxy (Proxy (Proxy))

17import Data.Proxy (Proxy (Proxy))

17import Data.Typeable (Typeable)

18import Data.Typeable (Typeable)

@@ -24,10 +25,11 @@ import Servant.Server.Internal (HasContextEntry,

24 HasServer, ServerT,

25 HasServer, ServerT,

25 getContextEntry,

26 getContextEntry,

26 route)

27 route)

27−import Servant.Server.Internal.Router (Router' (WithRequest))

28+import Servant.Server.Internal.RoutingApplication (addAuthCheck,

28−import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route),

29+ delayedFailFatal,

29− addAuthCheck)

30+ DelayedIO,

31+ withRequest)

30−import Servant.Server.Internal.ServantErr (ServantErr, Handler)

32+import Servant.Server.Internal.ServantErr (Handler)

32-- * General Auth

34-- * General Auth

@@ -57,8 +59,10 @@ instance ( HasServer api context

57 type ServerT (AuthProtect tag :> api) m =

59 type ServerT (AuthProtect tag :> api) m =

58 AuthServerData (AuthProtect tag) -> ServerT api m

60 AuthServerData (AuthProtect tag) -> ServerT api m

60− route Proxy context subserver = WithRequest $ \ request ->

62+ route Proxy context subserver =

61− route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)

63+ route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck)

62 where

64 where

65+ authHandler :: Request -> Handler (AuthServerData (AuthProtect tag))

63 authHandler = unAuthHandler (getContextEntry context)

66 authHandler = unAuthHandler (getContextEntry context)

67+ authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag))

64− authCheck = fmap (either FailFatal Route) . runExceptT . authHandler

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

22 , module Servant.Server.Internal.ServantErr

23 ) where

25+import Control.Monad.Trans (liftIO)

25import qualified Data.ByteString as B

26import qualified Data.ByteString as B

26import qualified Data.ByteString.Char8 as BC8

27import qualified Data.ByteString.Char8 as BC8

27import qualified Data.ByteString.Lazy as BL

28import qualified Data.ByteString.Lazy as BL

@@ -70,7 +71,11 @@ import Servant.Server.Internal.ServantErr

70class HasServer layout context where

71class HasServer layout context where

71 type ServerT layout (m :: * -> *) :: *

72 type ServerT layout (m :: * -> *) :: *

74+ route ::

75+ Proxy layout

76+ -> Context context

73− route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router

77+ -> Delayed env (Server layout)

78+ -> Router env

75type Server layout = ServerT layout Handler

80type Server layout = ServerT layout Handler

@@ -92,7 +97,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont

92 type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m

97 type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m

94 route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server))

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

96 where pa = Proxy :: Proxy a

101 where pa = Proxy :: Proxy a

97 pb = Proxy :: Proxy b

102 pb = Proxy :: Proxy b

103

@@ -120,12 +125,12 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)

120 a -> ServerT sublayout m

125 a -> ServerT sublayout m

121

126

122 route Proxy context d =

127 route Proxy context d =

123− DynamicRouter $ \ first ->

128+ CaptureRouter $

124 route (Proxy :: Proxy sublayout)

129 route (Proxy :: Proxy sublayout)

125 context

130 context

126− (addCapture d $ case parseUrlPieceMaybe first :: Maybe a of

131+ (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of

127− Nothing -> return $ Fail err400

132+ Nothing -> delayedFail err400

128− Just v -> return $ Route v

133+ Just v -> return v

129 )

134 )

130

135

131allowedMethodHead :: Method -> Request -> Bool

136allowedMethodHead :: Method -> Request -> Bool

@@ -144,41 +149,41 @@ processMethodRouter handleA status method headers request = case handleA of

144 bdy = if allowedMethodHead method request then "" else body

149 bdy = if allowedMethodHead method request then "" else body

145 hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)

150 hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)

146

151

147−methodCheck :: Method -> Request -> IO (RouteResult ())

152+methodCheck :: Method -> Request -> DelayedIO ()

148methodCheck method request

153methodCheck method request

149− | allowedMethod method request = return $ Route ()

154+ | allowedMethod method request = return ()

150− | otherwise = return $ Fail err405

155+ | otherwise = delayedFail err405

151

156

152−acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())

157+acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()

153acceptCheck proxy accH

158acceptCheck proxy accH

154− | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()

159+ | canHandleAcceptH proxy (AcceptHeader accH) = return ()

155− | otherwise = return $ FailFatal err406

160+ | otherwise = delayedFailFatal err406

156

161

157methodRouter :: (AllCTRender ctypes a)

162methodRouter :: (AllCTRender ctypes a)

158 => Method -> Proxy ctypes -> Status

163 => Method -> Proxy ctypes -> Status

159− -> Delayed (Handler a)

164+ -> Delayed env (Handler a)

160− -> Router

165+ -> Router env

161methodRouter method proxy status action = leafRouter route'

166methodRouter method proxy status action = leafRouter route'

162 where

167 where

163− route' request respond =

168+ route' env request respond =

164 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

169 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

165 in runAction (action `addMethodCheck` methodCheck method request

170 in runAction (action `addMethodCheck` methodCheck method request

166 `addAcceptCheck` acceptCheck proxy accH

171 `addAcceptCheck` acceptCheck proxy accH

167− ) respond $ \ output -> do

172+ ) env request respond $ \ output -> do

168 let handleA = handleAcceptH proxy (AcceptHeader accH) output

173 let handleA = handleAcceptH proxy (AcceptHeader accH) output

169 processMethodRouter handleA status method Nothing request

174 processMethodRouter handleA status method Nothing request

170

175

171methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)

176methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)

172 => Method -> Proxy ctypes -> Status

177 => Method -> Proxy ctypes -> Status

173− -> Delayed (Handler (Headers h v))

178+ -> Delayed env (Handler (Headers h v))

174− -> Router

179+ -> Router env

175methodRouterHeaders method proxy status action = leafRouter route'

180methodRouterHeaders method proxy status action = leafRouter route'

176 where

181 where

177− route' request respond =

182+ route' env request respond =

178 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

183 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

179 in runAction (action `addMethodCheck` methodCheck method request

184 in runAction (action `addMethodCheck` methodCheck method request

180 `addAcceptCheck` acceptCheck proxy accH

185 `addAcceptCheck` acceptCheck proxy accH

181− ) respond $ \ output -> do

186+ ) env request respond $ \ output -> do

182 let headers = getHeaders output

187 let headers = getHeaders output

183 handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)

188 handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)

184 processMethodRouter handleA status method (Just headers) request

189 processMethodRouter handleA status method (Just headers) request

@@ -230,8 +235,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)

230 type ServerT (Header sym a :> sublayout) m =

235 type ServerT (Header sym a :> sublayout) m =

231 Maybe a -> ServerT sublayout m

236 Maybe a -> ServerT sublayout m

232

237

233− route Proxy context subserver = WithRequest $ \ request ->

238+ route Proxy context subserver =

234− let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)

239+ let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req)

235 in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader)

240 in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader)

236 where str = fromString $ symbolVal (Proxy :: Proxy sym)

241 where str = fromString $ symbolVal (Proxy :: Proxy sym)

237

242

@@ -262,10 +267,10 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)

262 type ServerT (QueryParam sym a :> sublayout) m =

267 type ServerT (QueryParam sym a :> sublayout) m =

263 Maybe a -> ServerT sublayout m

268 Maybe a -> ServerT sublayout m

264

269

265− route Proxy context subserver = WithRequest $ \ request ->

270+ route Proxy context subserver =

266− let querytext = parseQueryText $ rawQueryString request

271+ let querytext r = parseQueryText $ rawQueryString r

267− param =

272+ param r =

268− case lookup paramname querytext of

273+ case lookup paramname (querytext r) of

269 Nothing -> Nothing -- param absent from the query string

274 Nothing -> Nothing -- param absent from the query string

270 Just Nothing -> Nothing -- param present with no value -> Nothing

275 Just Nothing -> Nothing -- param present with no value -> Nothing

271 Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to

276 Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to

@@ -298,13 +303,13 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context)

298 type ServerT (QueryParams sym a :> sublayout) m =

303 type ServerT (QueryParams sym a :> sublayout) m =

299 [a] -> ServerT sublayout m

304 [a] -> ServerT sublayout m

300

305

301− route Proxy context subserver = WithRequest $ \ request ->

306+ route Proxy context subserver =

302− let querytext = parseQueryText $ rawQueryString request

307+ let querytext r = parseQueryText $ rawQueryString r

303 -- if sym is "foo", we look for query string parameters

308 -- if sym is "foo", we look for query string parameters

304 -- named "foo" or "foo[]" and call parseQueryParam on the

309 -- named "foo" or "foo[]" and call parseQueryParam on the

305 -- corresponding values

310 -- corresponding values

306− parameters = filter looksLikeParam querytext

311+ parameters r = filter looksLikeParam (querytext r)

307− values = mapMaybe (convert . snd) parameters

312+ values r = mapMaybe (convert . snd) (parameters r)

308 in route (Proxy :: Proxy sublayout) context (passToServer subserver values)

313 in route (Proxy :: Proxy sublayout) context (passToServer subserver values)

309 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

314 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

310 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")

315 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")

@@ -329,9 +334,9 @@ instance (KnownSymbol sym, HasServer sublayout context)

329 type ServerT (QueryFlag sym :> sublayout) m =

334 type ServerT (QueryFlag sym :> sublayout) m =

330 Bool -> ServerT sublayout m

335 Bool -> ServerT sublayout m

331

336

332− route Proxy context subserver = WithRequest $ \ request ->

337+ route Proxy context subserver =

333− let querytext = parseQueryText $ rawQueryString request

338+ let querytext r = parseQueryText $ rawQueryString r

334− param = case lookup paramname querytext of

339+ param r = case lookup paramname (querytext r) of

335 Just Nothing -> True -- param is there, with no value

340 Just Nothing -> True -- param is there, with no value

336 Just (Just v) -> examine v -- param with a value

341 Just (Just v) -> examine v -- param with a value

337 Nothing -> False -- param not in the query string

342 Nothing -> False -- param not in the query string

@@ -352,8 +357,8 @@ instance HasServer Raw context where

352

357

353 type ServerT Raw m = Application

358 type ServerT Raw m = Application

354

359

355− route Proxy _ rawApplication = RawRouter $ \ request respond -> do

360+ route Proxy _ rawApplication = RawRouter $ \ env request respond -> do

356− r <- runDelayed rawApplication

361+ r <- runDelayed rawApplication env request

357 case r of

362 case r of

358 Route app -> app request (respond . Route)

363 Route app -> app request (respond . Route)

359 Fail a -> respond $ Fail a

364 Fail a -> respond $ Fail a

@@ -386,10 +391,10 @@ instance ( AllCTUnrender list a, HasServer sublayout context

386 type ServerT (ReqBody list a :> sublayout) m =

391 type ServerT (ReqBody list a :> sublayout) m =

387 a -> ServerT sublayout m

392 a -> ServerT sublayout m

388

393

389− route Proxy context subserver = WithRequest $ \ request ->

394+ route Proxy context subserver =

390− route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request))

395+ route (Proxy :: Proxy sublayout) context (addBodyCheck subserver bodyCheck)

391 where

396 where

392− bodyCheck request = do

397+ bodyCheck = withRequest $ \ request -> do

393 -- See HTTP RFC 2616, section 7.2.1

398 -- See HTTP RFC 2616, section 7.2.1

394 -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1

399 -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1

395 -- See also "W3C Internet Media Type registration, consistency of use"

400 -- See also "W3C Internet Media Type registration, consistency of use"

@@ -397,11 +402,11 @@ instance ( AllCTUnrender list a, HasServer sublayout context

397 let contentTypeH = fromMaybe "application/octet-stream"

402 let contentTypeH = fromMaybe "application/octet-stream"

398 $ lookup hContentType $ requestHeaders request

403 $ lookup hContentType $ requestHeaders request

399 mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)

404 mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)

400− <$> lazyRequestBody request

405+ <$> liftIO (lazyRequestBody request)

401 case mrqbody of

406 case mrqbody of

402− Nothing -> return $ FailFatal err415

407+ Nothing -> delayedFailFatal err415

403− Just (Left e) -> return $ FailFatal err400 { errBody = cs e }

408+ Just (Left e) -> delayedFailFatal err400 { errBody = cs e }

404− Just (Right v) -> return $ Route v

409+ Just (Right v) -> return v

405

410

406-- | Make sure the incoming request starts with @"/path"@, strip it and

411-- | Make sure the incoming request starts with @"/path"@, strip it and

407-- pass the rest of the request path to @sublayout@.

412-- pass the rest of the request path to @sublayout@.

@@ -418,28 +423,28 @@ instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> s

418instance HasServer api context => HasServer (RemoteHost :> api) context where

423instance HasServer api context => HasServer (RemoteHost :> api) context where

419 type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m

424 type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m

420

425

421− route Proxy context subserver = WithRequest $ \req ->

426+ route Proxy context subserver =

422− route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req)

427+ route (Proxy :: Proxy api) context (passToServer subserver remoteHost)

423

428

424instance HasServer api context => HasServer (IsSecure :> api) context where

429instance HasServer api context => HasServer (IsSecure :> api) context where

425 type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m

430 type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m

426

431

427− route Proxy context subserver = WithRequest $ \req ->

432+ route Proxy context subserver =

428− route (Proxy :: Proxy api) context (passToServer subserver $ secure req)

433+ route (Proxy :: Proxy api) context (passToServer subserver secure)

429

434

430 where secure req = if isSecure req then Secure else NotSecure

435 where secure req = if isSecure req then Secure else NotSecure

431

436

432instance HasServer api context => HasServer (Vault :> api) context where

437instance HasServer api context => HasServer (Vault :> api) context where

433 type ServerT (Vault :> api) m = Vault -> ServerT api m

438 type ServerT (Vault :> api) m = Vault -> ServerT api m

434

439

435− route Proxy context subserver = WithRequest $ \req ->

440+ route Proxy context subserver =

436− route (Proxy :: Proxy api) context (passToServer subserver $ vault req)

441+ route (Proxy :: Proxy api) context (passToServer subserver vault)

437

442

438instance HasServer api context => HasServer (HttpVersion :> api) context where

443instance HasServer api context => HasServer (HttpVersion :> api) context where

439 type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m

444 type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m

440

445

441− route Proxy context subserver = WithRequest $ \req ->

446+ route Proxy context subserver =

442− route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)

447+ route (Proxy :: Proxy api) context (passToServer subserver httpVersion)

443

448

444-- | Basic Authentication

449-- | Basic Authentication

445instance ( KnownSymbol realm

450instance ( KnownSymbol realm

@@ -450,12 +455,12 @@ instance ( KnownSymbol realm

450

455

451 type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m

456 type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m

452

457

453− route Proxy context subserver = WithRequest $ \ request ->

458+ route Proxy context subserver =

454− route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)

459+ route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck)

455 where

460 where

456 realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)

461 realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)

457 basicAuthContext = getContextEntry context

462 basicAuthContext = getContextEntry context

458− authCheck req = runBasicAuth req realm basicAuthContext

463+ authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext

459

464

460-- * helpers

465-- * helpers

461

466

servant-server/src/Servant/Server/Internal/BasicAuth.hs+6−5

@@ -6,6 +6,7 @@

6module Servant.Server.Internal.BasicAuth where

8import Control.Monad (guard)

9+import Control.Monad.Trans (liftIO)

9import qualified Data.ByteString as BS

10import qualified Data.ByteString as BS

10import Data.ByteString.Base64 (decodeLenient)

11import Data.ByteString.Base64 (decodeLenient)

11import Data.Monoid ((<>))

12import Data.Monoid ((<>))

@@ -57,13 +58,13 @@ decodeBAHdr req = do

58-- | Run and check basic authentication, returning the appropriate http error per

59-- | Run and check basic authentication, returning the appropriate http error per

59-- the spec.

60-- the spec.

60−runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr)

61+runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> DelayedIO usr

61runBasicAuth req realm (BasicAuthCheck ba) =

62runBasicAuth req realm (BasicAuthCheck ba) =

62 case decodeBAHdr req of

63 case decodeBAHdr req of

63 Nothing -> plzAuthenticate

64 Nothing -> plzAuthenticate

64− Just e -> ba e >>= \res -> case res of

65+ Just e -> liftIO (ba e) >>= \res -> case res of

65 BadPassword -> plzAuthenticate

66 BadPassword -> plzAuthenticate

66 NoSuchUser -> plzAuthenticate

67 NoSuchUser -> plzAuthenticate

67− Unauthorized -> return $ FailFatal err403

68+ Unauthorized -> delayedFailFatal err403

68− Authorized usr -> return $ Route usr

69+ Authorized usr -> return usr

69− where plzAuthenticate = return $ FailFatal err401 { errHeaders = [mkBAChallengerHdr realm] }

70+ where plzAuthenticate = delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm] }

servant-server/src/Servant/Server/Internal/Router.hs+74−77

@@ -1,5 +1,7 @@

1{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE CPP #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE KindSignatures #-}

3{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE OverloadedStrings #-}

4module Servant.Server.Internal.Router where

6module Servant.Server.Internal.Router where

@@ -8,36 +10,41 @@ import qualified Data.Map as M

8import Data.Monoid

10import Data.Monoid

9import Data.Text (Text)

11import Data.Text (Text)

10import qualified Data.Text as T

12import qualified Data.Text as T

11−import Network.Wai (Request, Response, pathInfo)

13+import Network.Wai (Response, pathInfo)

12import Servant.Server.Internal.RoutingApplication

14import Servant.Server.Internal.RoutingApplication

13import Servant.Server.Internal.ServantErr

15import Servant.Server.Internal.ServantErr

15−type Router = Router' RoutingApplication

17+type Router env = Router' env RoutingApplication

17-- | Internal representation of a router.

19-- | Internal representation of a router.

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

18−data Router' a =

26+data Router' env a =

19− WithRequest (Request -> Router' a)

20− -- ^ current request is passed to the router

21− | StaticRouter (Map Text (Router' a)) [a]

27+ StaticRouter (Map Text (Router' env a)) [env -> a]

22 -- ^ the map contains routers for subpaths (first path component used

28 -- ^ the map contains routers for subpaths (first path component used

23 -- for lookup and removed afterwards), the list contains handlers

29 -- for lookup and removed afterwards), the list contains handlers

24 -- for the empty path, to be tried in order

30 -- for the empty path, to be tried in order

25− | DynamicRouter (Text -> Router' a)

31+ | CaptureRouter (Router' (Text, env) a)

26− -- ^ first path component passed to the function and removed afterwards

32+ -- ^ first path component is passed to the child router in its

33+ -- environment and removed afterwards

27− | RawRouter a

34+ | RawRouter (env -> a)

28 -- ^ to be used for routes we do not know anything about

35 -- ^ 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)

30 -- ^ left-biased choice between two routers

37 -- ^ left-biased choice between two routers

31 deriving Functor

38 deriving Functor

33-- | Smart constructor for a single static path component.

40-- | Smart constructor for a single static path component.

34−pathRouter :: Text -> Router' a -> Router' a

41+pathRouter :: Text -> Router' env a -> Router' env a

35pathRouter t r = StaticRouter (M.singleton t r) []

42pathRouter t r = StaticRouter (M.singleton t r) []

37-- | Smart constructor for a leaf, i.e., a router that expects

44-- | Smart constructor for a leaf, i.e., a router that expects

38-- the empty path.

45-- the empty path.

39--

46--

40−leafRouter :: a -> Router' a

47+leafRouter :: (env -> a) -> Router' env a

41leafRouter l = StaticRouter M.empty [l]

48leafRouter l = StaticRouter M.empty [l]

43-- | Smart constructor for the choice between routers.

50-- | Smart constructor for the choice between routers.

@@ -46,40 +53,27 @@ leafRouter l = StaticRouter M.empty [l]

46-- * Two static routers can be joined by joining their maps

53-- * Two static routers can be joined by joining their maps

47-- and concatenating their leaf-lists.

54-- and concatenating their leaf-lists.

48-- * Two dynamic routers can be joined by joining their codomains.

55-- * 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.

54-- * Choice nodes can be reordered.

56-- * Choice nodes can be reordered.

55--

57--

56−choice :: Router -> Router -> Router

58+choice :: Router' env a -> Router' env a -> Router' env a

57choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =

59choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =

58 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)

60 StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)

59−choice (DynamicRouter fun1) (DynamicRouter fun2) =

61+choice (CaptureRouter router1) (CaptureRouter router2) =

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

62+ CaptureRouter (choice router1 router2)

67choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3

63choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3

68choice router1 router2 = Choice router1 router2

64choice router1 router2 = Choice router1 router2

70-- | Datatype used for representing and debugging the

66-- | Datatype used for representing and debugging the

71−-- structure of a router. Abstracts from the functions

67+-- structure of a router. Abstracts from the handlers

72−-- being used in the actual router and the handlers at

73−-- the leaves.

68+-- at the leaves.

74--

69--

75-- Two 'Router's can be structurally compared by computing

70-- Two 'Router's can be structurally compared by computing

76-- their 'RouterStructure' using 'routerStructure' and

71-- their 'RouterStructure' using 'routerStructure' and

77-- then testing for equality, see 'sameStructure'.

72-- then testing for equality, see 'sameStructure'.

78--

73--

79data RouterStructure =

74data RouterStructure =

80− WithRequestStructure RouterStructure

81− | StaticRouterStructure (Map Text RouterStructure) Int

75+ StaticRouterStructure (Map Text RouterStructure) Int

82− | DynamicRouterStructure RouterStructure

76+ | CaptureRouterStructure RouterStructure

83 | RawRouterStructure

77 | RawRouterStructure

84 | ChoiceStructure RouterStructure RouterStructure

78 | ChoiceStructure RouterStructure RouterStructure

85 deriving (Eq, Show)

79 deriving (Eq, Show)

@@ -87,18 +81,15 @@ data RouterStructure =

87-- | Compute the structure of a router.

81-- | Compute the structure of a router.

88--

82--

89-- Assumes that the request or text being passed

83-- Assumes that the request or text being passed

90−-- in 'WithRequest' or 'DynamicRouter' does not

84+-- in 'WithRequest' or 'CaptureRouter' does not

91-- affect the structure of the underlying tree.

85-- affect the structure of the underlying tree.

92--

86--

93−routerStructure :: Router' a -> RouterStructure

87+routerStructure :: Router' env a -> RouterStructure

94−routerStructure (WithRequest f) =

95− WithRequestStructure $

96− routerStructure (f (error "routerStructure: dummy request"))

97routerStructure (StaticRouter m ls) =

88routerStructure (StaticRouter m ls) =

98 StaticRouterStructure (fmap routerStructure m) (length ls)

89 StaticRouterStructure (fmap routerStructure m) (length ls)

99−routerStructure (DynamicRouter f) =

90+routerStructure (CaptureRouter router) =

100− DynamicRouterStructure $

91+ CaptureRouterStructure $

101− routerStructure (f (error "routerStructure: dummy text"))

92+ routerStructure router

102routerStructure (RawRouter _) =

93routerStructure (RawRouter _) =

103 RawRouterStructure

94 RawRouterStructure

104routerStructure (Choice r1 r2) =

95routerStructure (Choice r1 r2) =

@@ -108,21 +99,20 @@ routerStructure (Choice r1 r2) =

108

109-- | Compare the structure of two routers.

100-- | Compare the structure of two routers.

110--

101--

111−sameStructure :: Router' a -> Router' b -> Bool

102+sameStructure :: Router' env a -> Router' env b -> Bool

112sameStructure r1 r2 =

103sameStructure r1 r2 =

113 routerStructure r1 == routerStructure r2

104 routerStructure r1 == routerStructure r2

114

105

115-- | Provide a textual representation of the

106-- | Provide a textual representation of the

116-- structure of a router.

107-- structure of a router.

117--

108--

118−routerLayout :: Router' a -> Text

109+routerLayout :: Router' env a -> Text

119routerLayout router =

110routerLayout router =

120 T.unlines (["/"] ++ mkRouterLayout False (routerStructure router))

111 T.unlines (["/"] ++ mkRouterLayout False (routerStructure router))

121 where

112 where

122 mkRouterLayout :: Bool -> RouterStructure -> [Text]

113 mkRouterLayout :: Bool -> RouterStructure -> [Text]

123− mkRouterLayout c (WithRequestStructure r) = mkRouterLayout c r

124 mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n

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

126 mkRouterLayout c RawRouterStructure =

116 mkRouterLayout c RawRouterStructure =

127 if c then ["├─ <raw>"] else ["└─ <raw>"]

117 if c then ["├─ <raw>"] else ["└─ <raw>"]

128 mkRouterLayout c (ChoiceStructure r1 r2) =

118 mkRouterLayout c (ChoiceStructure r1 r2) =

@@ -146,47 +136,54 @@ routerLayout router =

146 mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children

136 mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children

147

137

148-- | Apply a transformation to the response of a `Router`.

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

150tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))

140tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))

151

141

152-- | Interpret a router as an application.

142-- | Interpret a router as an application.

153−runRouter :: Router -> RoutingApplication

143+runRouter :: Router () -> RoutingApplication

154−runRouter (WithRequest router) request respond =

144+runRouter r = runRouterEnv r ()

145+

146+runRouterEnv :: Router env -> env -> RoutingApplication

155− runRouter (router request) request respond

147+runRouterEnv router env request respond =

148+ case router of

156−runRouter (StaticRouter table ls) request respond =

149+ StaticRouter table ls ->

157− case pathInfo request of

150+ case pathInfo request of

158− [] -> runChoice ls request respond

151+ [] -> runChoice ls env request respond

159− -- This case is to handle trailing slashes.

152+ -- This case is to handle trailing slashes.

160− [""] -> runChoice ls request respond

153+ [""] -> runChoice ls env request respond

161− first : rest | Just router <- M.lookup first table

154+ first : rest | Just router' <- M.lookup first table

162− -> let request' = request { pathInfo = rest }

155+ -> let request' = request { pathInfo = rest }

163− in runRouter router request' respond

156+ in runRouterEnv router' env request' respond

164− _ -> respond $ Fail err404

157+ _ -> respond $ Fail err404

165−runRouter (DynamicRouter fun) request respond =

158+ CaptureRouter router' ->

166− case pathInfo request of

159+ case pathInfo request of

167− [] -> respond $ Fail err404

160+ [] -> respond $ Fail err404

168− -- This case is to handle trailing slashes.

161+ -- This case is to handle trailing slashes.

169− [""] -> respond $ Fail err404

162+ [""] -> respond $ Fail err404

170− first : rest

163+ first : rest

171− -> let request' = request { pathInfo = rest }

164+ -> let request' = request { pathInfo = rest }

172− in runRouter (fun first) request' respond

165+ in runRouterEnv router' (first, env) request' respond

173−runRouter (RawRouter app) request respond = app request respond

166+ RawRouter app ->

167+ app env request respond

174−runRouter (Choice r1 r2) request respond =

168+ Choice r1 r2 ->

175− runChoice [runRouter r1, runRouter r2] request respond

169+ runChoice [runRouterEnv r1, runRouterEnv r2] env request respond

176

170

177-- | Try a list of routing applications in order.

171-- | Try a list of routing applications in order.

178-- We stop as soon as one fails fatally or succeeds.

172-- We stop as soon as one fails fatally or succeeds.

179-- If all fail normally, we pick the "best" error.

173-- If all fail normally, we pick the "best" error.

180--

174--

181−runChoice :: [RoutingApplication] -> RoutingApplication

175+runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication

176+runChoice ls =

177+ case ls of

182−runChoice [] _request respond = respond (Fail err404)

178+ [] -> \ _ _ respond -> respond (Fail err404)

183−runChoice [r] request respond = r request respond

179+ [r] -> r

180+ (r : rs) ->

184−runChoice (r : rs) request respond =

181+ \ env request respond ->

185− r request $ \ response1 ->

182+ r env request $ \ response1 ->

186− case response1 of

183+ case response1 of

187− Fail _ -> runChoice rs request $ \ response2 ->

184+ Fail _ -> runChoice rs env request $ \ response2 ->

188− respond $ highestPri response1 response2

185+ respond $ highestPri response1 response2

189− _ -> respond response1

186+ _ -> respond response1

190 where

187 where

191 highestPri (Fail e1) (Fail e2) =

188 highestPri (Fail e1) (Fail e2) =

192 if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)

189 if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+126−98

@@ -8,7 +8,10 @@

8{-# LANGUAGE StandaloneDeriving #-}

9module Servant.Server.Internal.RoutingApplication where

11+import Control.Monad (ap, liftM)

12+import Control.Monad.Trans (MonadIO(..))

11import Control.Monad.Trans.Except (runExceptT)

13import Control.Monad.Trans.Except (runExceptT)

14+import Data.Text (Text)

12import Network.Wai (Application, Request,

15import Network.Wai (Application, Request,

13 Response, ResponseReceived)

16 Response, ResponseReceived)

14import Prelude ()

17import Prelude ()

@@ -95,113 +98,133 @@ toApplication ra request respond = ra request routingRespond

95-- The accept header check can be performed as the final

98-- The accept header check can be performed as the final

96-- computation in this block. It can cause a 406.

99-- computation in this block. It can cause a 406.

97--

100--

98−data Delayed c where

101+data Delayed env c where

99− Delayed :: { capturesD :: IO (RouteResult captures)

102+ Delayed :: { capturesD :: env -> DelayedIO captures

100− , methodD :: IO (RouteResult ())

103+ , methodD :: DelayedIO ()

101− , authD :: IO (RouteResult auth)

104+ , authD :: DelayedIO auth

102− , bodyD :: IO (RouteResult body)

105+ , bodyD :: DelayedIO body

103− , serverD :: (captures -> auth -> body -> RouteResult c)

106+ , serverD :: captures -> auth -> body -> Request -> RouteResult c

104− } -> Delayed c

107+ } -> Delayed env c

105−

108+

106−instance Functor Delayed where

109+instance Functor (Delayed env) where

107− fmap f Delayed{..}

110+ fmap f Delayed{..} =

108− = Delayed { capturesD = capturesD

111+ Delayed

109− , methodD = methodD

112+ { serverD = \ c a b req -> f <$> serverD c a b req

110− , authD = authD

113+ , ..

111− , bodyD = bodyD

112− , serverD = (fmap.fmap.fmap.fmap) f serverD

113− } -- Note [Existential Record Update]

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)

114

161

115-- | Add a capture to the end of the capture block.

162-- | Add a capture to the end of the capture block.

116−addCapture :: Delayed (a -> b)

163+addCapture :: Delayed env (a -> b)

117− -> IO (RouteResult a)

164+ -> (Text -> DelayedIO a)

118− -> Delayed b

165+ -> Delayed (Text, env) b

119−addCapture Delayed{..} new

166+addCapture Delayed{..} new =

120− = Delayed { capturesD = combineRouteResults (,) capturesD new

167+ Delayed

121− , methodD = methodD

168+ { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt

122− , authD = authD

123− , bodyD = bodyD

124− , serverD = \ (x, v) y z -> ($ v) <$> serverD x y z

169+ , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req

170+ , ..

125− } -- Note [Existential Record Update]

171+ } -- Note [Existential Record Update]

126

172

127-- | Add a method check to the end of the method block.

173-- | Add a method check to the end of the method block.

128−addMethodCheck :: Delayed a

174+addMethodCheck :: Delayed env a

129− -> IO (RouteResult ())

175+ -> DelayedIO ()

130− -> Delayed a

176+ -> Delayed env a

131−addMethodCheck Delayed{..} new

177+addMethodCheck Delayed{..} new =

132− = Delayed { capturesD = capturesD

178+ Delayed

133− , methodD = combineRouteResults const methodD new

179+ { methodD = methodD <* new

134− , authD = authD

180+ , ..

135− , bodyD = bodyD

136− , serverD = serverD

137− } -- Note [Existential Record Update]

181+ } -- Note [Existential Record Update]

138

182

139-- | Add an auth check to the end of the auth block.

183-- | Add an auth check to the end of the auth block.

140−addAuthCheck :: Delayed (a -> b)

184+addAuthCheck :: Delayed env (a -> b)

141− -> IO (RouteResult a)

185+ -> DelayedIO a

142− -> Delayed b

186+ -> Delayed env b

143−addAuthCheck Delayed{..} new

187+addAuthCheck Delayed{..} new =

144− = Delayed { capturesD = capturesD

188+ Delayed

145− , methodD = methodD

189+ { authD = (,) <$> authD <*> new

146− , authD = combineRouteResults (,) authD new

147− , bodyD = bodyD

148− , serverD = \ x (y, v) z -> ($ v) <$> serverD x y z

190+ , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req

191+ , ..

149− } -- Note [Existential Record Update]

192+ } -- Note [Existential Record Update]

150

193

151-- | Add a body check to the end of the body block.

194-- | Add a body check to the end of the body block.

152−addBodyCheck :: Delayed (a -> b)

195+addBodyCheck :: Delayed env (a -> b)

153− -> IO (RouteResult a)

196+ -> DelayedIO a

154− -> Delayed b

197+ -> Delayed env b

155−addBodyCheck Delayed{..} new

198+addBodyCheck Delayed{..} new =

156− = Delayed { capturesD = capturesD

199+ Delayed

157− , methodD = methodD

158− , authD = authD

159− , bodyD = combineRouteResults (,) bodyD new

200+ { bodyD = (,) <$> bodyD <*> new

160− , serverD = \ x y (z, v) -> ($ v) <$> serverD x y z

201+ , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req

202+ , ..

161− } -- Note [Existential Record Update]

203+ } -- Note [Existential Record Update]

162

204

163

205

164-- | Add an accept header check to the end of the body block.

206-- | Add an accept header check to the end of the body block.

165-- The accept header check should occur after the body check,

207-- The accept header check should occur after the body check,

166-- but this will be the case, because the accept header check

208-- but this will be the case, because the accept header check

167-- is only scheduled by the method combinators.

209-- is only scheduled by the method combinators.

168−addAcceptCheck :: Delayed a

210+addAcceptCheck :: Delayed env a

169− -> IO (RouteResult ())

211+ -> DelayedIO ()

170− -> Delayed a

212+ -> Delayed env a

171−addAcceptCheck Delayed{..} new

213+addAcceptCheck Delayed{..} new =

172− = Delayed { capturesD = capturesD

214+ Delayed

173− , methodD = methodD

215+ { bodyD = bodyD <* new

174− , authD = authD

216+ , ..

175− , bodyD = combineRouteResults const bodyD new

176− , serverD = serverD

177− } -- Note [Existential Record Update]

217+ } -- Note [Existential Record Update]

178

218

179-- | Many combinators extract information that is passed to

219-- | Many combinators extract information that is passed to

180-- the handler without the possibility of failure. In such a

220-- the handler without the possibility of failure. In such a

181-- case, 'passToServer' can be used.

221-- case, 'passToServer' can be used.

182−passToServer :: Delayed (a -> b) -> a -> Delayed b

222+passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b

183−passToServer d x = ($ x) <$> d

223+passToServer Delayed{..} x =

184−

224+ Delayed

185−-- | The combination 'IO . RouteResult' is a monad, but we

225+ { serverD = \ c a b req -> ($ x req) <$> serverD c a b req

186−-- don't explicitly wrap it in a newtype in order to make it

226+ , ..

187−-- an instance. This is the '>>=' of that monad.

227+ } -- Note [Existential Record Update]

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

205

228

206-- | Run a delayed server. Performs all scheduled operations

229-- | Run a delayed server. Performs all scheduled operations

207-- in order, and passes the results from the capture and body

230-- in order, and passes the results from the capture and body

@@ -209,24 +232,29 @@ combineRouteResults f m1 m2 =

209--

232--

210-- This should only be called once per request; otherwise the guarantees about

233-- This should only be called once per request; otherwise the guarantees about

211-- effect and HTTP error ordering break down.

234-- effect and HTTP error ordering break down.

212−runDelayed :: Delayed a

235+runDelayed :: Delayed env a

236+ -> env

237+ -> Request

213 -> IO (RouteResult a)

238 -> IO (RouteResult a)

214−runDelayed Delayed{..} =

239+runDelayed Delayed{..} env = runDelayedIO $ do

215− capturesD `bindRouteResults` \ c ->

240+ c <- capturesD env

216− methodD `bindRouteResults` \ _ ->

241+ methodD

217− authD `bindRouteResults` \ a ->

242+ a <- authD

218− bodyD `bindRouteResults` \ b ->

243+ b <- bodyD

219− return (serverD c a b)

244+ DelayedIO (\ req -> return $ serverD c a b req)

220

245

221-- | Runs a delayed server and the resulting action.

246-- | Runs a delayed server and the resulting action.

222-- Takes a continuation that lets us send a response.

247-- Takes a continuation that lets us send a response.

223-- Also takes a continuation for how to turn the

248-- Also takes a continuation for how to turn the

224-- result of the delayed server into a response.

249-- result of the delayed server into a response.

225−runAction :: Delayed (Handler a)

250+runAction :: Delayed env (Handler a)

251+ -> env

252+ -> Request

226 -> (RouteResult Response -> IO r)

253 -> (RouteResult Response -> IO r)

227 -> (a -> RouteResult Response)

254 -> (a -> RouteResult Response)

228 -> IO r

255 -> IO r

256+runAction action env req respond k =

229−runAction action respond k = runDelayed action >>= go >>= respond

257+ runDelayed action env req >>= go >>= respond

230 where

258 where

231 go (Fail e) = return $ Fail e

259 go (Fail e) = return $ Fail e

232 go (FailFatal e) = return $ FailFatal e

260 go (FailFatal e) = return $ FailFatal e

servant-server/test/Servant/Server/RouterSpec.hs+5−7

@@ -25,9 +25,9 @@ routerSpec = do

25 let app' :: Application

26 app' = toApplication $ runRouter router'

28− router', router :: Router

28+ router', router :: Router ()

29 router' = tweakResponse (fmap twk) router

30− router = leafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")

30+ router = leafRouter $ \_ _ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")

32 twk :: Response -> Response

33 twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b

@@ -69,11 +69,9 @@ shouldHaveSameStructureAs p1 p2 =

69 unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $

70 expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))

72−makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router

72+makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()

73−makeTrivialRouter p = route p EmptyContext d

73+makeTrivialRouter p =

74− where

75− d = Delayed r r r r (\ _ _ _ -> FailFatal err501)

74+ route p EmptyContext (emptyDelayed (FailFatal err501))

76− r = return (Route ())

78type End = Get '[JSON] ()

76type End = Get '[JSON] ()

servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs+1−2

@@ -20,7 +20,6 @@ module Servant.Server.UsingContextSpec.TestCombinators where

20import GHC.TypeLits

22import Servant

23−import Servant.Server.Internal.RoutingApplication

25data ExtractFromContext

24data ExtractFromContext

@@ -31,7 +30,7 @@ instance (HasContextEntry context String, HasServer subApi context) =>

31 String -> ServerT subApi m

30 String -> ServerT subApi m

33 route Proxy context delayed =

32 route Proxy context delayed =

34− route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi))

33+ route subProxy context (fmap (inject context) delayed)

35 where

34 where

36 subProxy :: Proxy subApi

35 subProxy :: Proxy subApi

37 subProxy = Proxy

36 subProxy = Proxy

servant-server/test/Servant/ServerSpec.hs+1−1

@@ -48,7 +48,7 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect,

48 Raw, RemoteHost, ReqBody,

49 StdMethod (..), Verb, addHeader)

50import Servant.API.Internal.Test.ComprehensiveAPI

51−import Servant.Server (ServantErr (..), Server, Handler, err401, err403,

51+import Servant.Server (Server, Handler, err401, err403,

52 err404, serve, serveWithContext,

53 Context((:.), EmptyContext))

54import Test.Hspec (Spec, context, describe, it,