f9b1e7f · typeable/servant

git.iko.soy/typeable/servant

Switch server interpretation to a datatype for efficiency.

Instead of directly interpreting a server as a `RoutingApplication`, this change introduces the concept of a `Router`, which is a datatype with several constructors. In particular, the type of the `route` function changes from route :: Proxy layout -> Server layout -> RoutingApplication to route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router Most important in practice is the case of the `StaticRouter` constructor in `Router`. For choices between statically known paths, we can now use a lookup table to dispatch requests rather than trying each request individually. This brings down routing complexity of a common case from O(n) to O(log n). Another important change is that the handler that is passed down by `route` is no longer of type `Server layout`, but of type `IO (RouteResult (Server layout))`. This means that API constructs can "delay" checks and failure. For example, `ReqBody` does not have to fetch the request body and feed it to the handler immediately; it can instead record these actions in the handler that is passed down. The code will only be executed at a leaf / endpoint of the API. This is desired behaviour: We prefer to save work by doing all matching on static path components first. Furthermore, we get better error codes by doing so.

commitf9b1e7fc5020fc9c9f0928d2baca46719596b499 authorAndres Loeh <andres@well-typed.com> dateFri 29 May 2015, 17:16 (11 years ago) parent0b32919

3 files changed+348−279

compare with master

unifiedsplit

servant-server/servant-server.cabal+1 servant-server/src/Servant/Server.hs+1−1 servant-server/src/Servant/Server/Internal.hs+346−278

servant-server/servant-server.cabal+1

@@ -43,6 +43,7 @@ library

4343 , aeson >= 0.7 && < 0.9

4444 , attoparsec >= 0.12 && < 0.14

4545 , bytestring >= 0.10 && < 0.11

46+ , containers >= 0.5 && < 0.6

4647 , either >= 4.3 && < 4.5

4748 , http-types >= 0.8 && < 0.9

4849 , network-uri >= 2.6 && < 2.7

servant-server/src/Servant/Server.hs+1−1

@@ -108,7 +108,7 @@ import Servant.Server.Internal.ServantErr

108108-- > main = Network.Wai.Handler.Warp.run 8080 app

109109--

110110serve :: HasServer layout => Proxy layout -> Server layout -> Application

111−serve p server = toApplication (route p server)

111+serve p server = toApplication (runRouter (route p (return (RR (Right server)))))

112112

113113

114114-- Documentation

servant-server/src/Servant/Server/Internal.hs+346−278

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

22{-# LANGUAGE DataKinds #-}

33{-# LANGUAGE FlexibleContexts #-}

44{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

56{-# LANGUAGE OverloadedStrings #-}

67{-# LANGUAGE PolyKinds #-}

78{-# LANGUAGE ScopedTypeVariables #-}

@@ -14,7 +15,7 @@

1415module Servant.Server.Internal where

1516

1617#if !MIN_VERSION_base(4,8,0)

17−import Control.Applicative ((<$>))

18+import Control.Applicative (Applicative, (<$>))

1819import Data.Monoid (Monoid, mappend, mempty)

1920#endif

2021import Control.Monad.Trans.Either (EitherT, runEitherT)

@@ -22,6 +23,7 @@ import qualified Data.ByteString as B

2223import qualified Data.ByteString.Lazy as BL

2324import Data.IORef (newIORef, readIORef, writeIORef)

2425import Data.List (unfoldr)

26+import qualified Data.Map as M

2527import Data.Maybe (catMaybes, fromMaybe)

2628import Data.String (fromString)

2729import Data.String.Conversions (cs, (<>))

@@ -52,6 +54,68 @@ import Servant.Common.Text (FromText, fromText)

5254

5355import Servant.Server.Internal.ServantErr

5456

57+-- | Internal representation of a router.

58+data Router =

59+ WithRequest (Request -> Router)

60+ -- ^ current request is passed to the router

61+ | StaticRouter (M.Map Text Router)

62+ -- ^ first path component used for lookup and removed afterwards

63+ | DynamicRouter (Text -> Router)

64+ -- ^ first path component used for lookup and removed afterwards

65+ | LeafRouter RoutingApplication

66+ -- ^ to be used for routes that match an empty path

67+ | Choice Router Router

68+ -- ^ left-biased choice between two routers

69+

70+-- | Smart constructor for the choice between routers.

71+-- We currently optimize the following cases:

72+--

73+-- * Two static routers can be joined by joining their maps.

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

75+-- * Two 'WithRequest' routers can be joined by passing them

76+-- the same request and joining their codomains.

77+-- * A 'WithRequest' router can be joined with anything else by

78+-- passing the same request to both but ignoring it in the

79+-- component that does not need it.

80+--

81+choice :: Router -> Router -> Router

82+choice (StaticRouter table1) (StaticRouter table2) =

83+ StaticRouter (M.unionWith choice table1 table2)

84+choice (DynamicRouter fun1) (DynamicRouter fun2) =

85+ DynamicRouter (\ first -> choice (fun1 first) (fun2 first))

86+choice (WithRequest router1) (WithRequest router2) =

87+ WithRequest (\ request -> choice (router1 request) (router2 request))

88+choice (WithRequest router1) router2 =

89+ WithRequest (\ request -> choice (router1 request) router2)

90+choice router1 (WithRequest router2) =

91+ WithRequest (\ request -> choice router1 (router2 request))

92+choice router1 router2 = Choice router1 router2

93+

94+-- | Interpret a router as an application.

95+runRouter :: Router -> RoutingApplication

96+runRouter (WithRequest router) request respond =

97+ runRouter (router request) request respond

98+runRouter (StaticRouter table) request respond =

99+ case processedPathInfo request of

100+ first : rest

101+ | Just router <- M.lookup first table

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

103+ in runRouter router request' respond

104+ _ -> respond $ failWith NotFound

105+runRouter (DynamicRouter fun) request respond =

106+ case processedPathInfo request of

107+ first : rest

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

109+ in runRouter (fun first) request' respond

110+ _ -> respond $ failWith NotFound

111+runRouter (LeafRouter app) request respond = app request respond

112+runRouter (Choice r1 r2) request respond =

113+ runRouter r1 request $ \ mResponse1 ->

114+ if isMismatch mResponse1

115+ then runRouter r2 request $ \ mResponse2 ->

116+ respond (mResponse1 <> mResponse2)

117+ else respond mResponse1

118+

55119data ReqBodyState = Uncalled

56120 | Called !B.ByteString

57121 | Done !B.ByteString

@@ -120,7 +184,33 @@ instance Monoid RouteMismatch where

120184-- | A wrapper around @'Either' 'RouteMismatch' a@.

121185newtype RouteResult a =

122186 RR { routeResult :: Either RouteMismatch a }

123− deriving (Eq, Show)

187+ deriving (Eq, Show, Functor, Applicative)

188+

189+runAction :: IO (RouteResult (EitherT ServantErr IO a))

190+ -> (RouteResult Response -> IO r)

191+ -> (a -> RouteResult Response)

192+ -> IO r

193+runAction action respond k = do

194+ r <- action

195+ go r

196+ where

197+ go (RR (Right a)) = do

198+ e <- runEitherT a

199+ respond $ case e of

200+ Right x -> k x

201+ Left err -> succeedWith $ responseServantErr err

202+ go (RR (Left err)) = respond $ failWith err

203+

204+feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)

205+feedTo f x = (($ x) <$>) <$> f

206+

207+extractL :: RouteResult (a :<|> b) -> RouteResult a

208+extractL (RR (Right (a :<|> _))) = RR (Right a)

209+extractL (RR (Left err)) = RR (Left err)

210+

211+extractR :: RouteResult (a :<|> b) -> RouteResult b

212+extractR (RR (Right (_ :<|> b))) = RR (Right b)

213+extractR (RR (Left err)) = RR (Left err)

124214

125215failWith :: RouteMismatch -> RouteResult a

126216failWith = RR . Left

@@ -179,7 +269,7 @@ processedPathInfo r =

179269class HasServer layout where

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

181271

182− route :: Proxy layout -> Server layout -> RoutingApplication

272+ route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router

183273

184274type Server layout = ServerT layout (EitherT ServantErr IO)

185275

@@ -200,12 +290,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where

200290

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

202292

203− route Proxy (a :<|> b) request respond =

204− route pa a request $ \mResponse ->

205− if isMismatch mResponse

206− then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')

207− else respond mResponse

208−

293+ route Proxy server = choice (route pa (extractL <$> server))

294+ (route pb (extractR <$> server))

209295 where pa = Proxy :: Proxy a

210296 pb = Proxy :: Proxy b

211297

@@ -235,15 +321,12 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)

235321 type ServerT (Capture capture a :> sublayout) m =

236322 a -> ServerT sublayout m

237323

238− route Proxy subserver request respond = case processedPathInfo request of

239− (first : rest)

240− -> case captured captureProxy first of

241− Nothing -> respond $ failWith NotFound

242− Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{

243− pathInfo = rest

244− } respond

245− _ -> respond $ failWith NotFound

246−

324+ route Proxy subserver =

325+ DynamicRouter $ \ first ->

326+ route (Proxy :: Proxy sublayout)

327+ (case captured captureProxy first of

328+ Nothing -> return $ failWith NotFound

329+ Just v -> feedTo subserver v)

247330 where captureProxy = Proxy :: Proxy (Capture capture a)

248331

249332

@@ -267,20 +350,19 @@ instance

267350

268351 type ServerT (Delete ctypes a) m = m a

269352

270− route Proxy action request respond

271− | pathIsEmpty request && requestMethod request == methodDelete = do

272− e <- runEitherT action

273− respond $ case e of

274− Right output -> do

275− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

276− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

277− Nothing -> failWith UnsupportedMediaType

278− Just (contentT, body) -> succeedWith $

279− responseLBS status200 [ ("Content-Type" , cs contentT)] body

280− Left err -> succeedWith $ responseServantErr err

281− | pathIsEmpty request && requestMethod request /= methodDelete =

282− respond $ failWith WrongMethod

283− | otherwise = respond $ failWith NotFound

353+ route Proxy action = LeafRouter route'

354+ where

355+ route' request respond

356+ | pathIsEmpty request && requestMethod request == methodDelete = do

357+ runAction action respond $ \ output -> do

358+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

359+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

360+ Nothing -> failWith UnsupportedMediaType

361+ Just (contentT, body) -> succeedWith $

362+ responseLBS status200 [ ("Content-Type" , cs contentT)] body

363+ | pathIsEmpty request && requestMethod request /= methodDelete =

364+ respond $ failWith WrongMethod

365+ | otherwise = respond $ failWith NotFound

284366

285367instance

286368#if MIN_VERSION_base(4,8,0)

@@ -290,15 +372,15 @@ instance

290372

291373 type ServerT (Delete ctypes ()) m = m ()

292374

293− route Proxy action request respond

294− | pathIsEmpty request && requestMethod request == methodDelete = do

295− e <- runEitherT action

296− respond . succeedWith $ case e of

297− Right () -> responseLBS noContent204 [] ""

298− Left err -> responseServantErr err

299− | pathIsEmpty request && requestMethod request /= methodDelete =

300− respond $ failWith WrongMethod

301− | otherwise = respond $ failWith NotFound

375+ route Proxy action = LeafRouter route'

376+ where

377+ route' request respond

378+ | pathIsEmpty request && requestMethod request == methodDelete = do

379+ runAction action respond $ \ () ->

380+ succeedWith $ responseLBS noContent204 [] ""

381+ | pathIsEmpty request && requestMethod request /= methodDelete =

382+ respond $ failWith WrongMethod

383+ | otherwise = respond $ failWith NotFound

302384

303385-- Add response headers

304386instance

@@ -310,21 +392,20 @@ instance

310392

311393 type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)

312394

313− route Proxy action request respond

314− | pathIsEmpty request && requestMethod request == methodDelete = do

315− e <- runEitherT action

316− respond $ case e of

317− Right output -> do

318− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

319− headers = getHeaders output

320− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

321− Nothing -> failWith UnsupportedMediaType

322− Just (contentT, body) -> succeedWith $

323− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

324− Left err -> succeedWith $ responseServantErr err

325− | pathIsEmpty request && requestMethod request /= methodDelete =

326− respond $ failWith WrongMethod

327− | otherwise = respond $ failWith NotFound

395+ route Proxy action = LeafRouter route'

396+ where

397+ route' request respond

398+ | pathIsEmpty request && requestMethod request == methodDelete = do

399+ runAction action respond $ \ output -> do

400+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

401+ headers = getHeaders output

402+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

403+ Nothing -> failWith UnsupportedMediaType

404+ Just (contentT, body) -> succeedWith $

405+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

406+ | pathIsEmpty request && requestMethod request /= methodDelete =

407+ respond $ failWith WrongMethod

408+ | otherwise = respond $ failWith NotFound

328409

329410-- | When implementing the handler for a 'Get' endpoint,

330411-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'

@@ -347,20 +428,19 @@ instance

347428

348429 type ServerT (Get ctypes a) m = m a

349430

350− route Proxy action request respond

351− | pathIsEmpty request && requestMethod request == methodGet = do

352− e <- runEitherT action

353− respond $ case e of

354− Right output -> do

355− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

356− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

357− Nothing -> failWith UnsupportedMediaType

358− Just (contentT, body) -> succeedWith $

359− responseLBS ok200 [ ("Content-Type" , cs contentT)] body

360− Left err -> succeedWith $ responseServantErr err

361− | pathIsEmpty request && requestMethod request /= methodGet =

362− respond $ failWith WrongMethod

363− | otherwise = respond $ failWith NotFound

431+ route Proxy action = LeafRouter route'

432+ where

433+ route' request respond

434+ | pathIsEmpty request && requestMethod request == methodGet = do

435+ runAction action respond $ \ output -> do

436+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

437+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

438+ Nothing -> failWith UnsupportedMediaType

439+ Just (contentT, body) -> succeedWith $

440+ responseLBS ok200 [ ("Content-Type" , cs contentT)] body

441+ | pathIsEmpty request && requestMethod request /= methodGet =

442+ respond $ failWith WrongMethod

443+ | otherwise = respond $ failWith NotFound

364444

365445-- '()' ==> 204 No Content

366446instance

@@ -371,15 +451,15 @@ instance

371451

372452 type ServerT (Get ctypes ()) m = m ()

373453

374− route Proxy action request respond

375− | pathIsEmpty request && requestMethod request == methodGet = do

376− e <- runEitherT action

377− respond . succeedWith $ case e of

378− Right () -> responseLBS noContent204 [] ""

379− Left err -> responseServantErr err

380− | pathIsEmpty request && requestMethod request /= methodGet =

381− respond $ failWith WrongMethod

382− | otherwise = respond $ failWith NotFound

454+ route Proxy action = LeafRouter route'

455+ where

456+ route' request respond

457+ | pathIsEmpty request && requestMethod request == methodGet = do

458+ runAction action respond $ \ () ->

459+ succeedWith $ responseLBS noContent204 [] ""

460+ | pathIsEmpty request && requestMethod request /= methodGet =

461+ respond $ failWith WrongMethod

462+ | otherwise = respond $ failWith NotFound

383463

384464-- Add response headers

385465instance

@@ -391,21 +471,20 @@ instance

391471

392472 type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)

393473

394− route Proxy action request respond

395− | pathIsEmpty request && requestMethod request == methodGet = do

396− e <- runEitherT action

397− respond $ case e of

398− Right output -> do

399− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

400− headers = getHeaders output

401− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

402− Nothing -> failWith UnsupportedMediaType

403− Just (contentT, body) -> succeedWith $

404− responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body

405− Left err -> succeedWith $ responseServantErr err

406− | pathIsEmpty request && requestMethod request /= methodGet =

407− respond $ failWith WrongMethod

408− | otherwise = respond $ failWith NotFound

474+ route Proxy action = LeafRouter route'

475+ where

476+ route' request respond

477+ | pathIsEmpty request && requestMethod request == methodGet = do

478+ runAction action respond $ \ output -> do

479+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

480+ headers = getHeaders output

481+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

482+ Nothing -> failWith UnsupportedMediaType

483+ Just (contentT, body) -> succeedWith $

484+ responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body

485+ | pathIsEmpty request && requestMethod request /= methodGet =

486+ respond $ failWith WrongMethod

487+ | otherwise = respond $ failWith NotFound

409488

410489-- | If you use 'Header' in one of the endpoints for your API,

411490-- this automatically requires your server-side handler to be a function

@@ -433,11 +512,10 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

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

434513 Maybe a -> ServerT sublayout m

435514

436− route Proxy subserver request respond = do

515+ route Proxy subserver = WithRequest $ \ request ->

437516 let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request)

438− route (Proxy :: Proxy sublayout) (subserver mheader) request respond

439−

440− where str = fromString $ symbolVal (Proxy :: Proxy sym)

517+ in route (Proxy :: Proxy sublayout) (feedTo subserver mheader)

518+ where str = fromString $ symbolVal (Proxy :: Proxy sym)

441519

442520-- | When implementing the handler for a 'Post' endpoint,

443521-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

@@ -461,20 +539,19 @@ instance

461539

462540 type ServerT (Post ctypes a) m = m a

463541

464− route Proxy action request respond

465− | pathIsEmpty request && requestMethod request == methodPost = do

466− e <- runEitherT action

467− respond $ case e of

468− Right output -> do

469− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

470− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

471− Nothing -> failWith UnsupportedMediaType

472− Just (contentT, body) -> succeedWith $

473− responseLBS status201 [ ("Content-Type" , cs contentT)] body

474− Left err -> succeedWith $ responseServantErr err

475− | pathIsEmpty request && requestMethod request /= methodPost =

476− respond $ failWith WrongMethod

477− | otherwise = respond $ failWith NotFound

542+ route Proxy action = LeafRouter route'

543+ where

544+ route' request respond

545+ | pathIsEmpty request && requestMethod request == methodPost = do

546+ runAction action respond $ \ output -> do

547+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

548+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

549+ Nothing -> failWith UnsupportedMediaType

550+ Just (contentT, body) -> succeedWith $

551+ responseLBS status201 [ ("Content-Type" , cs contentT)] body

552+ | pathIsEmpty request && requestMethod request /= methodPost =

553+ respond $ failWith WrongMethod

554+ | otherwise = respond $ failWith NotFound

478555

479556instance

480557#if MIN_VERSION_base(4,8,0)

@@ -484,15 +561,15 @@ instance

484561

485562 type ServerT (Post ctypes ()) m = m ()

486563

487− route Proxy action request respond

488− | pathIsEmpty request && requestMethod request == methodPost = do

489− e <- runEitherT action

490− respond . succeedWith $ case e of

491− Right () -> responseLBS noContent204 [] ""

492− Left err -> responseServantErr err

493− | pathIsEmpty request && requestMethod request /= methodPost =

494− respond $ failWith WrongMethod

495− | otherwise = respond $ failWith NotFound

564+ route Proxy action = LeafRouter route'

565+ where

566+ route' request respond

567+ | pathIsEmpty request && requestMethod request == methodPost = do

568+ runAction action respond $ \ () ->

569+ succeedWith $ responseLBS noContent204 [] ""

570+ | pathIsEmpty request && requestMethod request /= methodPost =

571+ respond $ failWith WrongMethod

572+ | otherwise = respond $ failWith NotFound

496573

497574-- Add response headers

498575instance

@@ -504,21 +581,20 @@ instance

504581

505582 type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)

506583

507− route Proxy action request respond

508− | pathIsEmpty request && requestMethod request == methodPost = do

509− e <- runEitherT action

510− respond $ case e of

511− Right output -> do

512− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

513− headers = getHeaders output

514− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

515− Nothing -> failWith UnsupportedMediaType

516− Just (contentT, body) -> succeedWith $

517− responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body

518− Left err -> succeedWith $ responseServantErr err

519− | pathIsEmpty request && requestMethod request /= methodPost =

520− respond $ failWith WrongMethod

521− | otherwise = respond $ failWith NotFound

584+ route Proxy action = LeafRouter route'

585+ where

586+ route' request respond

587+ | pathIsEmpty request && requestMethod request == methodPost = do

588+ runAction action respond $ \ output -> do

589+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

590+ headers = getHeaders output

591+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

592+ Nothing -> failWith UnsupportedMediaType

593+ Just (contentT, body) -> succeedWith $

594+ responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body

595+ | pathIsEmpty request && requestMethod request /= methodPost =

596+ respond $ failWith WrongMethod

597+ | otherwise = respond $ failWith NotFound

522598

523599-- | When implementing the handler for a 'Put' endpoint,

524600-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

@@ -541,20 +617,19 @@ instance

541617

542618 type ServerT (Put ctypes a) m = m a

543619

544− route Proxy action request respond

545− | pathIsEmpty request && requestMethod request == methodPut = do

546− e <- runEitherT action

547− respond $ case e of

548− Right output -> do

549− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

550− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

551− Nothing -> failWith UnsupportedMediaType

552− Just (contentT, body) -> succeedWith $

553− responseLBS status200 [ ("Content-Type" , cs contentT)] body

554− Left err -> succeedWith $ responseServantErr err

555− | pathIsEmpty request && requestMethod request /= methodPut =

556− respond $ failWith WrongMethod

557− | otherwise = respond $ failWith NotFound

620+ route Proxy action = LeafRouter route'

621+ where

622+ route' request respond

623+ | pathIsEmpty request && requestMethod request == methodPut = do

624+ runAction action respond $ \ output -> do

625+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

626+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

627+ Nothing -> failWith UnsupportedMediaType

628+ Just (contentT, body) -> succeedWith $

629+ responseLBS status200 [ ("Content-Type" , cs contentT)] body

630+ | pathIsEmpty request && requestMethod request /= methodPut =

631+ respond $ failWith WrongMethod

632+ | otherwise = respond $ failWith NotFound

558633

559634instance

560635#if MIN_VERSION_base(4,8,0)

@@ -564,15 +639,15 @@ instance

564639

565640 type ServerT (Put ctypes ()) m = m ()

566641

567− route Proxy action request respond

568− | pathIsEmpty request && requestMethod request == methodPut = do

569− e <- runEitherT action

570− respond . succeedWith $ case e of

571− Right () -> responseLBS noContent204 [] ""

572− Left err -> responseServantErr err

573− | pathIsEmpty request && requestMethod request /= methodPut =

574− respond $ failWith WrongMethod

575− | otherwise = respond $ failWith NotFound

642+ route Proxy action = LeafRouter route'

643+ where

644+ route' request respond

645+ | pathIsEmpty request && requestMethod request == methodPut = do

646+ runAction action respond $ \ () ->

647+ succeedWith $ responseLBS noContent204 [] ""

648+ | pathIsEmpty request && requestMethod request /= methodPut =

649+ respond $ failWith WrongMethod

650+ | otherwise = respond $ failWith NotFound

576651

577652-- Add response headers

578653instance

@@ -584,21 +659,20 @@ instance

584659

585660 type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)

586661

587− route Proxy action request respond

588− | pathIsEmpty request && requestMethod request == methodPut = do

589− e <- runEitherT action

590− respond $ case e of

591− Right output -> do

592− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

593− headers = getHeaders output

594− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

595− Nothing -> failWith UnsupportedMediaType

596− Just (contentT, body) -> succeedWith $

597− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

598− Left err -> succeedWith $ responseServantErr err

599− | pathIsEmpty request && requestMethod request /= methodPut =

600− respond $ failWith WrongMethod

601− | otherwise = respond $ failWith NotFound

662+ route Proxy action = LeafRouter route'

663+ where

664+ route' request respond

665+ | pathIsEmpty request && requestMethod request == methodPut = do

666+ runAction action respond $ \ output -> do

667+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

668+ headers = getHeaders output

669+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of

670+ Nothing -> failWith UnsupportedMediaType

671+ Just (contentT, body) -> succeedWith $

672+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

673+ | pathIsEmpty request && requestMethod request /= methodPut =

674+ respond $ failWith WrongMethod

675+ | otherwise = respond $ failWith NotFound

602676

603677-- | When implementing the handler for a 'Patch' endpoint,

604678-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'

@@ -619,20 +693,19 @@ instance

619693

620694 type ServerT (Patch ctypes a) m = m a

621695

622− route Proxy action request respond

623− | pathIsEmpty request && requestMethod request == methodPatch = do

624− e <- runEitherT action

625− respond $ case e of

626− Right output -> do

627− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

628− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

629− Nothing -> failWith UnsupportedMediaType

630− Just (contentT, body) -> succeedWith $

631− responseLBS status200 [ ("Content-Type" , cs contentT)] body

632− Left err -> succeedWith $ responseServantErr err

633− | pathIsEmpty request && requestMethod request /= methodPatch =

634− respond $ failWith WrongMethod

635− | otherwise = respond $ failWith NotFound

696+ route Proxy action = LeafRouter route'

697+ where

698+ route' request respond

699+ | pathIsEmpty request && requestMethod request == methodPatch = do

700+ runAction action respond $ \ output -> do

701+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

702+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of

703+ Nothing -> failWith UnsupportedMediaType

704+ Just (contentT, body) -> succeedWith $

705+ responseLBS status200 [ ("Content-Type" , cs contentT)] body

706+ | pathIsEmpty request && requestMethod request /= methodPatch =

707+ respond $ failWith WrongMethod

708+ | otherwise = respond $ failWith NotFound

636709

637710instance

638711#if MIN_VERSION_base(4,8,0)

@@ -642,15 +715,15 @@ instance

642715

643716 type ServerT (Patch ctypes ()) m = m ()

644717

645− route Proxy action request respond

646− | pathIsEmpty request && requestMethod request == methodPatch = do

647− e <- runEitherT action

648− respond . succeedWith $ case e of

649− Right () -> responseLBS noContent204 [] ""

650− Left err -> responseServantErr err

651− | pathIsEmpty request && requestMethod request /= methodPatch =

652− respond $ failWith WrongMethod

653− | otherwise = respond $ failWith NotFound

718+ route Proxy action = LeafRouter route'

719+ where

720+ route' request respond

721+ | pathIsEmpty request && requestMethod request == methodPatch = do

722+ runAction action respond $ \ () ->

723+ succeedWith $ responseLBS noContent204 [] ""

724+ | pathIsEmpty request && requestMethod request /= methodPatch =

725+ respond $ failWith WrongMethod

726+ | otherwise = respond $ failWith NotFound

654727

655728-- Add response headers

656729instance

@@ -662,21 +735,20 @@ instance

662735

663736 type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)

664737

665− route Proxy action request respond

666− | pathIsEmpty request && requestMethod request == methodPatch = do

667− e <- runEitherT action

668− respond $ case e of

669− Right outpatch -> do

670− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

671− headers = getHeaders outpatch

672− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of

673− Nothing -> failWith UnsupportedMediaType

674− Just (contentT, body) -> succeedWith $

675− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

676− Left err -> succeedWith $ responseServantErr err

677− | pathIsEmpty request && requestMethod request /= methodPatch =

678− respond $ failWith WrongMethod

679− | otherwise = respond $ failWith NotFound

738+ route Proxy action = LeafRouter route'

739+ where

740+ route' request respond

741+ | pathIsEmpty request && requestMethod request == methodPatch = do

742+ runAction action respond $ \ outpatch -> do

743+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

744+ headers = getHeaders outpatch

745+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of

746+ Nothing -> failWith UnsupportedMediaType

747+ Just (contentT, body) -> succeedWith $

748+ responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body

749+ | pathIsEmpty request && requestMethod request /= methodPatch =

750+ respond $ failWith WrongMethod

751+ | otherwise = respond $ failWith NotFound

680752

681753-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

682754-- this automatically requires your server-side handler to be a function

@@ -705,7 +777,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

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

706778 Maybe a -> ServerT sublayout m

707779

708− route Proxy subserver request respond = do

780+ route Proxy subserver = WithRequest $ \ request ->

709781 let querytext = parseQueryText $ rawQueryString request

710782 param =

711783 case lookup paramname querytext of

@@ -713,9 +785,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

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

714786 Just (Just v) -> fromText v -- if present, we try to convert to

715787 -- the right type

716−

717− route (Proxy :: Proxy sublayout) (subserver param) request respond

718−

788+ in route (Proxy :: Proxy sublayout) (feedTo subserver param)

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

720790

721791-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,

@@ -743,16 +813,14 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

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

744814 [a] -> ServerT sublayout m

745815

746− route Proxy subserver request respond = do

816+ route Proxy subserver = WithRequest $ \ request ->

747817 let querytext = parseQueryText $ rawQueryString request

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

749819 -- named "foo" or "foo[]" and call fromText on the

750820 -- corresponding values

751821 parameters = filter looksLikeParam querytext

752822 values = catMaybes $ map (convert . snd) parameters

753−

754− route (Proxy :: Proxy sublayout) (subserver values) request respond

755−

823+ in route (Proxy :: Proxy sublayout) (feedTo subserver values)

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

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

758826 convert Nothing = Nothing

@@ -776,15 +844,13 @@ instance (KnownSymbol sym, HasServer sublayout)

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

777845 Bool -> ServerT sublayout m

778846

779− route Proxy subserver request respond = do

847+ route Proxy subserver = WithRequest $ \ request ->

780848 let querytext = parseQueryText $ rawQueryString request

781849 param = case lookup paramname querytext of

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

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

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

785−

786− route (Proxy :: Proxy sublayout) (subserver param) request respond

787−

853+ in route (Proxy :: Proxy sublayout) (feedTo subserver param)

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

789855 examine v | v == "true" || v == "1" || v == "" = True

790856 | otherwise = False

@@ -819,16 +885,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

819885 type ServerT (MatrixParam sym a :> sublayout) m =

820886 Maybe a -> ServerT sublayout m

821887

822− route Proxy subserver request respond = case parsePathInfo request of

823− (first : _)

824− -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first

825− param = case lookup paramname querytext of

826− Nothing -> Nothing -- param absent from the query string

827− Just Nothing -> Nothing -- param present with no value -> Nothing

828− Just (Just v) -> fromText v -- if present, we try to convert to

829− -- the right type

830− route (Proxy :: Proxy sublayout) (subserver param) request respond

831− _ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond

888+ route Proxy subserver = WithRequest $ \ request ->

889+ case parsePathInfo request of

890+ (first : _)

891+ -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first

892+ param = case lookup paramname querytext of

893+ Nothing -> Nothing -- param absent from the query string

894+ Just Nothing -> Nothing -- param present with no value -> Nothing

895+ Just (Just v) -> fromText v -- if present, we try to convert to

896+ -- the right type

897+ route (Proxy :: Proxy sublayout) (feedTo subserver param)

898+ _ -> route (Proxy :: Proxy sublayout) (feedTo subserver Nothing)

832899

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

834901

@@ -857,16 +924,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)

857924 type ServerT (MatrixParams sym a :> sublayout) m =

858925 [a] -> ServerT sublayout m

859926

860− route Proxy subserver request respond = case parsePathInfo request of

861− (first : _)

862− -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first

863− -- if sym is "foo", we look for matrix parameters

864− -- named "foo" or "foo[]" and call fromText on the

865− -- corresponding values

866− parameters = filter looksLikeParam matrixtext

867− values = catMaybes $ map (convert . snd) parameters

868− route (Proxy :: Proxy sublayout) (subserver values) request respond

869− _ -> route (Proxy :: Proxy sublayout) (subserver []) request respond

927+ route Proxy subserver = WithRequest $ \ request ->

928+ case parsePathInfo request of

929+ (first : _)

930+ -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first

931+ -- if sym is "foo", we look for matrix parameters

932+ -- named "foo" or "foo[]" and call fromText on the

933+ -- corresponding values

934+ parameters = filter looksLikeParam matrixtext

935+ values = catMaybes $ map (convert . snd) parameters

936+ route (Proxy :: Proxy sublayout) (feedTo subserver values)

937+ _ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])

870938

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

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

@@ -891,17 +959,18 @@ instance (KnownSymbol sym, HasServer sublayout)

891959 type ServerT (MatrixFlag sym :> sublayout) m =

892960 Bool -> ServerT sublayout m

893961

894− route Proxy subserver request respond = case parsePathInfo request of

895− (first : _)

896− -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first

897− param = case lookup paramname matrixtext of

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

899− Just (Just v) -> examine v -- param with a value

900− Nothing -> False -- param not in the query string

901−

902− route (Proxy :: Proxy sublayout) (subserver param) request respond

903−

904− _ -> route (Proxy :: Proxy sublayout) (subserver False) request respond

962+ route Proxy subserver = WithRequest $ \ request ->

963+ case parsePathInfo request of

964+ (first : _)

965+ -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first

966+ param = case lookup paramname matrixtext of

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

968+ Just (Just v) -> examine v -- param with a value

969+ Nothing -> False -- param not in the query string

970+

971+ route (Proxy :: Proxy sublayout) (feedTo subserver param)

972+

973+ _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)

905974

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

907976 examine v | v == "true" || v == "1" || v == "" = True

@@ -919,8 +988,11 @@ instance HasServer Raw where

919988

920989 type ServerT Raw m = Application

921990

922− route Proxy rawApplication request respond =

923− rawApplication request (respond . succeedWith)

991+ route Proxy rawApplication = LeafRouter $ \ request respond -> do

992+ r <- rawApplication

993+ case r of

994+ RR (Left err) -> respond $ failWith err

995+ RR (Right app) -> app request (respond . succeedWith)

924996

925997-- | If you use 'ReqBody' in one of the endpoints for your API,

926998-- this automatically requires your server-side handler to be a function

@@ -948,19 +1020,20 @@ instance ( AllCTUnrender list a, HasServer sublayout

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

9491021 a -> ServerT sublayout m

9501022

951− route Proxy subserver request respond = do

952− -- See HTTP RFC 2616, section 7.2.1

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

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

955− -- http://www.w3.org/2001/tag/2002/0129-mime

956− let contentTypeH = fromMaybe "application/octet-stream"

957− $ lookup hContentType $ requestHeaders request

958− mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)

959− <$> lazyRequestBody request

960− case mrqbody of

961− Nothing -> respond . failWith $ UnsupportedMediaType

962− Just (Left e) -> respond . failWith $ InvalidBody e

963− Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond

1023+ route Proxy subserver = WithRequest $ \ request ->

1024+ route (Proxy :: Proxy sublayout) $ do

1025+ -- See HTTP RFC 2616, section 7.2.1

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

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

1028+ -- http://www.w3.org/2001/tag/2002/0129-mime

1029+ let contentTypeH = fromMaybe "application/octet-stream"

1030+ $ lookup hContentType $ requestHeaders request

1031+ mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)

1032+ <$> lazyRequestBody request

1033+ case mrqbody of

1034+ Nothing -> return $ failWith $ UnsupportedMediaType

1035+ Just (Left e) -> return $ failWith $ InvalidBody e

1036+ Just (Right v) -> feedTo subserver v

9641037

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

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

@@ -968,14 +1041,9 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout

9681041

9691042 type ServerT (path :> sublayout) m = ServerT sublayout m

9701043

971− route Proxy subserver request respond = case processedPathInfo request of

972− (first : rest)

973− | first == cs (symbolVal proxyPath)

974− -> route (Proxy :: Proxy sublayout) subserver request{

975− pathInfo = rest

976− } respond

977− _ -> respond $ failWith NotFound

978−

1044+ route Proxy subserver = StaticRouter $

1045+ M.singleton (cs (symbolVal proxyPath))

1046+ (route (Proxy :: Proxy sublayout) subserver)

9791047 where proxyPath = Proxy :: Proxy path

9801048

9811049ct_wildcard :: B.ByteString