6ec4bdc · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Merge pull request #451 from kosmikus/show-router

6ec4bdcAndres Löh11 years ago

servant-server/CHANGELOG.md+9

compare with master

unifiedsplit

@@ -1,3 +1,12 @@

1+0.7

2+---

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

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

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

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

8+ cases for expected router layouts have been added.

10.6.1

100.6.1

2-----

11-----

servant-server/src/Servant/Server.hs+72

@@ -18,6 +18,10 @@ module Servant.Server

18 HasServer(..)

19 , Server

21+ -- * Debugging the server layout

22+ , layout

23+ , layoutWithContext

24+

21 -- * Enter

25 -- * Enter

22 -- $enterDoc

26 -- $enterDoc

@@ -93,6 +97,7 @@ module Servant.Server

93 ) where

97 ) where

95import Data.Proxy (Proxy)

99import Data.Proxy (Proxy)

100+import Data.Text (Text)

96import Network.Wai (Application)

101import Network.Wai (Application)

97import Servant.Server.Internal

102import Servant.Server.Internal

98import Servant.Server.Internal.Enter

103import Servant.Server.Internal.Enter

@@ -131,6 +136,73 @@ serveWithContext p context server = toApplication (runRouter (route p context d)

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

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

132 r = return (Route ())

137 r = return (Route ())

133

138

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

140+-- router layout for debugging purposes. Note that the router layout is

141+-- determined just by the API, not by the handlers.

142+--

143+-- This function makes certain assumptions about the well-behavedness of

144+-- the 'HasServer' instances of the combinators which should be ok for the

145+-- core servant constructions, but might not be satisfied for some other

146+-- combinators provided elsewhere. It is possible that the function may

147+-- crash for these.

148+--

149+-- Example:

150+--

151+-- For the following API

152+--

153+-- > type API =

154+-- > "a" :> "d" :> Get '[JSON] ()

155+-- > :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool

156+-- > :<|> "c" :> Put '[JSON] Bool

157+-- > :<|> "a" :> "e" :> Get '[JSON] Int

158+-- > :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool

159+-- > :<|> Raw

160+--

161+-- we get the following output:

162+--

163+-- > /

164+-- > ├─ a/

165+-- > │ ├─ d/

166+-- > │ │ └─•

167+-- > │ └─ e/

168+-- > │ └─•

169+-- > ├─ b/

170+-- > │ └─ <dyn>/

171+-- > │ ├─•

172+-- > │ ┆

173+-- > │ └─•

174+-- > ├─ c/

175+-- > │ └─•

176+-- > ┆

177+-- > └─ <raw>

178+--

179+-- Explanation of symbols:

180+--

181+-- [@├@] Normal lines reflect static branching via a table.

182+--

183+-- [@a/@] Nodes reflect static path components.

184+--

185+-- [@─•@] Leaves reflect endpoints.

186+--

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

188+--

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

190+--

191+-- [@┆@] Dashed lines suggest a dynamic choice between the part above

192+-- and below. If there is a success for fatal failure in the first part,

193+-- that one takes precedence. If both parts fail, the \"better\" error

194+-- code will be returned.

195+--

196+layout :: (HasServer layout '[]) => Proxy layout -> Text

197+layout p = layoutWithContext p EmptyContext

198+

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

200+layoutWithContext :: (HasServer layout context)

201+ => Proxy layout -> Context context -> Text

202+layoutWithContext p context = routerLayout (route p context d)

203+ where

204+ d = Delayed r r r r (\ _ _ _ -> FailFatal err501)

205+ r = return (Route ())

134

206

135-- Documentation

207-- Documentation

136

208

servant-server/src/Servant/Server/Internal.hs+10−21

@@ -26,11 +26,9 @@ import Control.Monad.Trans.Except (ExceptT)

26import qualified Data.ByteString as B

27import qualified Data.ByteString.Char8 as BC8

28import qualified Data.ByteString.Lazy as BL

29−import qualified Data.Map as M

30import Data.Maybe (fromMaybe, mapMaybe)

29import Data.Maybe (fromMaybe, mapMaybe)

31import Data.String (fromString)

30import Data.String (fromString)

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

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

33−import Data.Text (Text)

34import Data.Typeable

32import Data.Typeable

35import GHC.TypeLits (KnownNat, KnownSymbol, natVal,

33import GHC.TypeLits (KnownNat, KnownSymbol, natVal,

36 symbolVal)

34 symbolVal)

@@ -38,7 +36,7 @@ import Network.HTTP.Types hiding (Header, ResponseHeaders)

38import Network.Socket (SockAddr)

36import Network.Socket (SockAddr)

39import Network.Wai (Application, Request, Response,

37import Network.Wai (Application, Request, Response,

40 httpVersion, isSecure,

38 httpVersion, isSecure,

41− lazyRequestBody, pathInfo,

39+ lazyRequestBody,

42 rawQueryString, remoteHost,

40 rawQueryString, remoteHost,

43 requestHeaders, requestMethod,

41 requestHeaders, requestMethod,

44 responseLBS, vault)

42 responseLBS, vault)

@@ -161,26 +159,23 @@ methodRouter :: (AllCTRender ctypes a)

161 => Method -> Proxy ctypes -> Status

159 => Method -> Proxy ctypes -> Status

162 -> Delayed (ExceptT ServantErr IO a)

160 -> Delayed (ExceptT ServantErr IO a)

163 -> Router

161 -> Router

164−methodRouter method proxy status action = LeafRouter route'

162+methodRouter method proxy status action = leafRouter route'

165 where

163 where

166− route' request respond

164+ route' request respond =

167− | pathIsEmpty request =

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

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

169 in runAction (action `addMethodCheck` methodCheck method request

166 in runAction (action `addMethodCheck` methodCheck method request

170 `addAcceptCheck` acceptCheck proxy accH

167 `addAcceptCheck` acceptCheck proxy accH

171 ) respond $ \ output -> do

168 ) respond $ \ output -> do

172 let handleA = handleAcceptH proxy (AcceptHeader accH) output

169 let handleA = handleAcceptH proxy (AcceptHeader accH) output

173 processMethodRouter handleA status method Nothing request

170 processMethodRouter handleA status method Nothing request

174− | otherwise = respond $ Fail err404

175

171

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

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

177 => Method -> Proxy ctypes -> Status

173 => Method -> Proxy ctypes -> Status

178 -> Delayed (ExceptT ServantErr IO (Headers h v))

174 -> Delayed (ExceptT ServantErr IO (Headers h v))

179 -> Router

175 -> Router

180−methodRouterHeaders method proxy status action = LeafRouter route'

176+methodRouterHeaders method proxy status action = leafRouter route'

181 where

177 where

182− route' request respond

178+ route' request respond =

183− | pathIsEmpty request =

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

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

185 in runAction (action `addMethodCheck` methodCheck method request

180 in runAction (action `addMethodCheck` methodCheck method request

186 `addAcceptCheck` acceptCheck proxy accH

181 `addAcceptCheck` acceptCheck proxy accH

@@ -188,7 +183,6 @@ methodRouterHeaders method proxy status action = LeafRouter route'

188 let headers = getHeaders output

183 let headers = getHeaders output

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

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

190 processMethodRouter handleA status method (Just headers) request

185 processMethodRouter handleA status method (Just headers) request

191− | otherwise = respond $ Fail err404

192

186

193instance OVERLAPPABLE_

187instance OVERLAPPABLE_

194 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

188 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status

@@ -359,7 +353,7 @@ instance HasServer Raw context where

359

353

360 type ServerT Raw m = Application

354 type ServerT Raw m = Application

361

355

362− route Proxy _ rawApplication = LeafRouter $ \ request respond -> do

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

363 r <- runDelayed rawApplication

357 r <- runDelayed rawApplication

364 case r of

358 case r of

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

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

@@ -416,9 +410,10 @@ instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> s

416

410

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

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

418

412

419− route Proxy context subserver = StaticRouter $

413+ route Proxy context subserver =

414+ pathRouter

420− M.singleton (cs (symbolVal proxyPath))

415+ (cs (symbolVal proxyPath))

421− (route (Proxy :: Proxy sublayout) context subserver)

416+ (route (Proxy :: Proxy sublayout) context subserver)

422 where proxyPath = Proxy :: Proxy path

417 where proxyPath = Proxy :: Proxy path

423

418

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

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

@@ -465,12 +460,6 @@ instance ( KnownSymbol realm

465

460

466-- * helpers

461-- * helpers

467

462

468−pathIsEmpty :: Request -> Bool

469−pathIsEmpty = go . pathInfo

470− where go [] = True

471− go [""] = True

472− go _ = False

473−

474ct_wildcard :: B.ByteString

463ct_wildcard :: B.ByteString

475ct_wildcard = "*" <> "/" <> "*" -- Because CPP

464ct_wildcard = "*" <> "/" <> "*" -- Because CPP

476

465

servant-server/src/Servant/Server/Internal/Router.hs+140−30

@@ -1,10 +1,13 @@

1{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE CPP #-}

3+{-# LANGUAGE OverloadedStrings #-}

3module Servant.Server.Internal.Router where

4module Servant.Server.Internal.Router where

5import Data.Map (Map)

6import Data.Map (Map)

6import qualified Data.Map as M

7import qualified Data.Map as M

8+import Data.Monoid

7import Data.Text (Text)

9import Data.Text (Text)

10+import qualified Data.Text as T

8import Network.Wai (Request, Response, pathInfo)

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

9import Servant.Server.Internal.RoutingApplication

12import Servant.Server.Internal.RoutingApplication

10import Servant.Server.Internal.ServantErr

13import Servant.Server.Internal.ServantErr

@@ -13,36 +16,46 @@ type Router = Router' RoutingApplication

14-- | Internal representation of a router.

17-- | Internal representation of a router.

15data Router' a =

18data Router' a =

16− WithRequest (Request -> Router)

19+ WithRequest (Request -> Router' a)

17 -- ^ current request is passed to the router

20 -- ^ current request is passed to the router

18− | StaticRouter (Map Text Router)

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

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

19− -- ^ first path component used for lookup and removed afterwards

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

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

20− | DynamicRouter (Text -> Router)

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

21− -- ^ first path component used for lookup and removed afterwards

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

22− | LeafRouter a

27+ | RawRouter a

23− -- ^ to be used for routes that match an empty path

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

24− | Choice Router Router

29+ | Choice (Router' a) (Router' a)

25 -- ^ left-biased choice between two routers

30 -- ^ left-biased choice between two routers

26 deriving Functor

31 deriving Functor

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

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

29−tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router

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

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

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

36+

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

38+-- the empty path.

39+--

40+leafRouter :: a -> Router' a

41+leafRouter l = StaticRouter M.empty [l]

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

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

33-- We currently optimize the following cases:

44-- We currently optimize the following cases:

34--

45--

35−-- * Two static routers can be joined by joining their maps.

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

47+-- and concatenating their leaf-lists.

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

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

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

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

38-- the same request and joining their codomains.

50-- the same request and joining their codomains.

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

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

40-- passing the same request to both but ignoring it in the

52-- passing the same request to both but ignoring it in the

41-- component that does not need it.

53-- component that does not need it.

54+-- * Choice nodes can be reordered.

42--

55--

43choice :: Router -> Router -> Router

56choice :: Router -> Router -> Router

44−choice (StaticRouter table1) (StaticRouter table2) =

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

45− StaticRouter (M.unionWith choice table1 table2)

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

46choice (DynamicRouter fun1) (DynamicRouter fun2) =

59choice (DynamicRouter fun1) (DynamicRouter fun2) =

47 DynamicRouter (\ first -> choice (fun1 first) (fun2 first))

60 DynamicRouter (\ first -> choice (fun1 first) (fun2 first))

48choice (WithRequest router1) (WithRequest router2) =

61choice (WithRequest router1) (WithRequest router2) =

@@ -51,39 +64,136 @@ choice (WithRequest router1) router2 =

51 WithRequest (\ request -> choice (router1 request) router2)

64 WithRequest (\ request -> choice (router1 request) router2)

52choice router1 (WithRequest router2) =

65choice router1 (WithRequest router2) =

53 WithRequest (\ request -> choice router1 (router2 request))

66 WithRequest (\ request -> choice router1 (router2 request))

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

54choice router1 router2 = Choice router1 router2

68choice router1 router2 = Choice router1 router2

70+-- | Datatype used for representing and debugging the

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

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

73+-- the leaves.

74+--

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

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

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

78+--

79+data RouterStructure =

80+ WithRequestStructure RouterStructure

81+ | StaticRouterStructure (Map Text RouterStructure) Int

82+ | DynamicRouterStructure RouterStructure

83+ | RawRouterStructure

84+ | ChoiceStructure RouterStructure RouterStructure

85+ deriving (Eq, Show)

86+

87+-- | Compute the structure of a router.

88+--

89+-- Assumes that the request or text being passed

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

91+-- affect the structure of the underlying tree.

92+--

93+routerStructure :: Router' a -> RouterStructure

94+routerStructure (WithRequest f) =

95+ WithRequestStructure $

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

97+routerStructure (StaticRouter m ls) =

98+ StaticRouterStructure (fmap routerStructure m) (length ls)

99+routerStructure (DynamicRouter f) =

100+ DynamicRouterStructure $

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

102+routerStructure (RawRouter _) =

103+ RawRouterStructure

104+routerStructure (Choice r1 r2) =

105+ ChoiceStructure

106+ (routerStructure r1)

107+ (routerStructure r2)

108+

109+-- | Compare the structure of two routers.

110+--

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

112+sameStructure r1 r2 =

113+ routerStructure r1 == routerStructure r2

114+

115+-- | Provide a textual representation of the

116+-- structure of a router.

117+--

118+routerLayout :: Router' a -> Text

119+routerLayout router =

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

121+ where

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

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

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

125+ mkRouterLayout c (DynamicRouterStructure r) = mkSubTree c "<dyn>" (mkRouterLayout False r)

126+ mkRouterLayout c RawRouterStructure =

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

128+ mkRouterLayout c (ChoiceStructure r1 r2) =

129+ mkRouterLayout True r1 ++ ["┆"] ++ mkRouterLayout c r2

130+

131+ mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text]

132+ mkSubTrees _ [] 0 = []

133+ mkSubTrees c [] n =

134+ concat (replicate (n - 1) (mkLeaf True) ++ [mkLeaf c])

135+ mkSubTrees c [(t, r)] 0 =

136+ mkSubTree c t (mkRouterLayout False r)

137+ mkSubTrees c ((t, r) : trs) n =

138+ mkSubTree True t (mkRouterLayout False r) ++ mkSubTrees c trs n

139+

140+ mkLeaf :: Bool -> [Text]

141+ mkLeaf True = ["├─•","┆"]

142+ mkLeaf False = ["└─•"]

143+

144+ mkSubTree :: Bool -> Text -> [Text] -> [Text]

145+ mkSubTree True path children = ("├─ " <> path <> "/") : map ("│ " <>) children

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

147+

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

149+tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router

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

151+

56-- | Interpret a router as an application.

152-- | Interpret a router as an application.

57runRouter :: Router -> RoutingApplication

153runRouter :: Router -> RoutingApplication

58runRouter (WithRequest router) request respond =

154runRouter (WithRequest router) request respond =

59 runRouter (router request) request respond

155 runRouter (router request) request respond

60−runRouter (StaticRouter table) request respond =

156+runRouter (StaticRouter table ls) request respond =

61 case pathInfo request of

157 case pathInfo request of

62− first : rest

158+ [] -> runChoice ls request respond

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

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

63− | Just router <- M.lookup first table

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

64 -> let request' = request { pathInfo = rest }

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

65 in runRouter router request' respond

163 in runRouter router request' respond

66 _ -> respond $ Fail err404

164 _ -> respond $ Fail err404

67runRouter (DynamicRouter fun) request respond =

165runRouter (DynamicRouter fun) request respond =

68 case pathInfo request of

166 case pathInfo request of

167+ [] -> respond $ Fail err404

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

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

69 first : rest

170 first : rest

70 -> let request' = request { pathInfo = rest }

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

71 in runRouter (fun first) request' respond

172 in runRouter (fun first) request' respond

72− _ -> respond $ Fail err404

73−runRouter (LeafRouter app) request respond = app request respond

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

74runRouter (Choice r1 r2) request respond =

174runRouter (Choice r1 r2) request respond =

75− runRouter r1 request $ \ mResponse1 -> case mResponse1 of

76− Fail _ -> runRouter r2 request $ \ mResponse2 ->

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

77− respond (highestPri mResponse1 mResponse2)

78− _ -> respond mResponse1

79− where

80− highestPri (Fail e1) (Fail e2) =

81− if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)

82− then Fail e2

83− else Fail e1

84− highestPri (Fail _) y = y

85− highestPri x _ = x

176

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

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

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

180+--

181+runChoice :: [RoutingApplication] -> RoutingApplication

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

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

184+runChoice (r : rs) request respond =

185+ r request $ \ response1 ->

186+ case response1 of

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

188+ respond $ highestPri response1 response2

189+ _ -> respond response1

190+ where

191+ highestPri (Fail e1) (Fail e2) =

192+ if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)

193+ then Fail e2

194+ else Fail e1

195+ highestPri (Fail _) y = y

196+ highestPri x _ = x

197

88-- Priority on HTTP codes.

198-- Priority on HTTP codes.

89--

199--

servant-server/src/Servant/Server/Internal/RoutingApplication.hs−25

@@ -35,31 +35,6 @@ toApplication ra request respond = ra request routingRespond

35 routingRespond (FailFatal err) = respond $ responseServantErr err

36 routingRespond (Route v) = respond v

38−-- We currently mix up the order in which we perform checks

39−-- and the priority with which errors are reported.

40−--

41−-- For example, we perform Capture checks prior to method checks,

42−-- and therefore get 404 before 405.

43−--

44−-- However, we also perform body checks prior to method checks

45−-- now, and therefore get 415 before 405, which is wrong.

46−--

47−-- If we delay Captures, but perform method checks eagerly, we

48−-- end up potentially preferring 405 over 404, which is also bad.

49−--

50−-- So in principle, we'd like:

51−--

52−-- static routes (can cause 404)

53−-- delayed captures (can cause 404)

54−-- methods (can cause 405)

55−-- authentication and authorization (can cause 401, 403)

56−-- delayed body (can cause 415, 400)

57−-- accept header (can cause 406)

58−--

59−-- According to the HTTP decision diagram, the priority order

60−-- between HTTP status codes is as follows:

61−--

62−

63-- | A 'Delayed' is a representation of a handler with scheduled

38-- | A 'Delayed' is a representation of a handler with scheduled

64-- delayed checks that can trigger errors.

39-- delayed checks that can trigger errors.

65--

40--

servant-server/test/Servant/Server/RouterSpec.hsnew file+295

@@ -0,0 +1,295 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TypeOperators #-}

5+module Servant.Server.RouterSpec (spec) where

7+import Control.Monad (unless)

8+import Data.Proxy (Proxy(..))

9+import Data.Text (unpack)

10+import Network.HTTP.Types (Status (..))

11+import Network.Wai (Application, responseBuilder)

12+import Network.Wai.Internal (Response (ResponseBuilder))

13+import Test.Hspec

14+import Test.Hspec.Wai (get, shouldRespondWith, with)

15+import Servant.API

16+import Servant.Server

17+import Servant.Server.Internal

18+

19+spec = describe "Servant.Server.Internal.Router" $ do

20+ routerSpec

21+ distributivitySpec

22+

23+routerSpec :: Spec

24+routerSpec = do

25+ let app' :: Application

26+ app' = toApplication $ runRouter router'

27+

28+ router', router :: Router

29+ router' = tweakResponse (fmap twk) router

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

31+

32+ twk :: Response -> Response

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

34+ twk b = b

35+

36+ describe "tweakResponse" . with (return app') $ do

37+ it "calls f on route result" $ do

38+ get "" `shouldRespondWith` 202

39+

40+distributivitySpec :: Spec

41+distributivitySpec =

42+ describe "choice" $ do

43+ it "distributes endpoints through static paths" $ do

44+ endpoint `shouldHaveSameStructureAs` endpointRef

45+ it "distributes nested routes through static paths" $ do

46+ static `shouldHaveSameStructureAs` staticRef

47+ it "distributes nested routes through dynamic paths" $ do

48+ dynamic `shouldHaveSameStructureAs` dynamicRef

49+ it "properly reorders permuted static paths" $ do

50+ permute `shouldHaveSameStructureAs` permuteRef

51+ it "properly reorders permuted static paths in the presence of Raw in end" $ do

52+ permuteRawEnd `shouldHaveSameStructureAs` permuteRawEndRef

53+ it "properly reorders permuted static paths in the presence of Raw in beginning" $ do

54+ permuteRawBegin `shouldHaveSameStructureAs` permuteRawBeginRef

55+ it "properly reorders permuted static paths in the presence of Raw in middle" $ do

56+ permuteRawMiddle `shouldHaveSameStructureAs` permuteRawMiddleRef

57+ it "properly reorders permuted static paths in the presence of a root endpoint in end" $ do

58+ permuteEndEnd `shouldHaveSameStructureAs` permuteEndRef

59+ it "properly reorders permuted static paths in the presence of a root endpoint in beginning" $ do

60+ permuteEndBegin `shouldHaveSameStructureAs` permuteEndRef

61+ it "properly reorders permuted static paths in the presence of a root endpoint in middle" $ do

62+ permuteEndMiddle `shouldHaveSameStructureAs` permuteEndRef

63+ it "properly handles mixing static paths at different levels" $ do

64+ level `shouldHaveSameStructureAs` levelRef

65+

66+shouldHaveSameStructureAs ::

67+ (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation

68+shouldHaveSameStructureAs p1 p2 =

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

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

71+

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

73+makeTrivialRouter p = route p EmptyContext d

74+ where

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

76+ r = return (Route ())

77+

78+type End = Get '[JSON] ()

79+

80+-- The latter version looks more efficient,

81+-- but the former should be compiled to the

82+-- same layout:

83+

84+type Endpoint = "a" :> End :<|> "a" :> End

85+type EndpointRef = "a" :> (End :<|> End)

86+

87+endpoint :: Proxy Endpoint

88+endpoint = Proxy

89+

90+endpointRef :: Proxy EndpointRef

91+endpointRef = Proxy

92+

93+-- Again, the latter version looks more efficient,

94+-- but the former should be compiled to the same

95+-- layout:

96+

97+type Static = "a" :> "b" :> End :<|> "a" :> "c" :> End

98+type StaticRef = "a" :> ("b" :> End :<|> "c" :> End)

99+

100+static :: Proxy Static

101+static = Proxy

102+

103+staticRef :: Proxy StaticRef

104+staticRef = Proxy

105+

106+-- Even for dynamic path components, we expect the

107+-- router to simplify the layout, because captures

108+-- are delayed and only actually performed once

109+-- reaching an endpoint. So the former version and

110+-- the latter should be compiled to the same router

111+-- structure:

112+

113+type Dynamic =

114+ "a" :> Capture "foo" Int :> "b" :> End

115+ :<|> "a" :> Capture "bar" Bool :> "c" :> End

116+ :<|> "a" :> Capture "baz" Char :> "d" :> End

117+

118+type DynamicRef =

119+ "a" :> Capture "anything" () :>

120+ ("b" :> End :<|> "c" :> End :<|> "d" :> End)

121+

122+dynamic :: Proxy Dynamic

123+dynamic = Proxy

124+

125+dynamicRef :: Proxy DynamicRef

126+dynamicRef = Proxy

127+

128+-- A more complicated example of static route reordering.

129+-- All the permuted paths should be correctly grouped,

130+-- so both 'Permute' and 'PermuteRef' should compile to

131+-- the same layout:

132+

133+type Permute =

134+ "a" :> "b" :> "c" :> End

135+ :<|> "b" :> "a" :> "c" :> End

136+ :<|> "a" :> "c" :> "b" :> End

137+ :<|> "c" :> "a" :> "b" :> End

138+ :<|> "b" :> "c" :> "a" :> End

139+ :<|> "c" :> "b" :> "a" :> End

140+

141+type PermuteRef =

142+ "a" :> ( "b" :> "c" :> End

143+ :<|> "c" :> "b" :> End

144+ )

145+ :<|> "b" :> ( "a" :> "c" :> End

146+ :<|> "c" :> "a" :> End

147+ )

148+ :<|> "c" :> ( "a" :> "b" :> End

149+ :<|> "b" :> "a" :> End

150+ )

151+

152+permute :: Proxy Permute

153+permute = Proxy

154+

155+permuteRef :: Proxy PermuteRef

156+permuteRef = Proxy

157+

158+-- Adding a 'Raw' in one of the ends should have minimal

159+-- effect on the grouping.

160+

161+type PermuteRawEnd =

162+ "a" :> "b" :> "c" :> End

163+ :<|> "b" :> "a" :> "c" :> End

164+ :<|> "a" :> "c" :> "b" :> End

165+ :<|> "c" :> "a" :> "b" :> End

166+ :<|> "b" :> "c" :> "a" :> End

167+ :<|> "c" :> "b" :> "a" :> End

168+ :<|> Raw

169+

170+type PermuteRawEndRef = PermuteRef :<|> Raw

171+

172+type PermuteRawBegin =

173+ Raw

174+ :<|> "a" :> "b" :> "c" :> End

175+ :<|> "b" :> "a" :> "c" :> End

176+ :<|> "a" :> "c" :> "b" :> End

177+ :<|> "c" :> "a" :> "b" :> End

178+ :<|> "b" :> "c" :> "a" :> End

179+ :<|> "c" :> "b" :> "a" :> End

180+

181+type PermuteRawBeginRef = Raw :<|> PermuteRef

182+

183+permuteRawBegin :: Proxy PermuteRawBegin

184+permuteRawBegin = Proxy

185+

186+permuteRawBeginRef :: Proxy PermuteRawBeginRef

187+permuteRawBeginRef = Proxy

188+

189+permuteRawEnd :: Proxy PermuteRawEnd

190+permuteRawEnd = Proxy

191+

192+permuteRawEndRef :: Proxy PermuteRawEndRef

193+permuteRawEndRef = Proxy

194+

195+-- Adding a 'Raw' in the middle will disrupt grouping,

196+-- because we commute things past a 'Raw'. But the two

197+-- halves should still be grouped.

198+

199+type PermuteRawMiddle =

200+ "a" :> "b" :> "c" :> End

201+ :<|> "b" :> "a" :> "c" :> End

202+ :<|> "a" :> "c" :> "b" :> End

203+ :<|> Raw

204+ :<|> "c" :> "a" :> "b" :> End

205+ :<|> "b" :> "c" :> "a" :> End

206+ :<|> "c" :> "b" :> "a" :> End

207+

208+type PermuteRawMiddleRef =

209+ "a" :> ( "b" :> "c" :> End

210+ :<|> "c" :> "b" :> End

211+ )

212+ :<|> "b" :> "a" :> "c" :> End

213+ :<|> Raw

214+ :<|> "b" :> "c" :> "a" :> End

215+ :<|> "c" :> ( "a" :> "b" :> End

216+ :<|> "b" :> "a" :> End

217+ )

218+

219+permuteRawMiddle :: Proxy PermuteRawMiddle

220+permuteRawMiddle = Proxy

221+

222+permuteRawMiddleRef :: Proxy PermuteRawMiddleRef

223+permuteRawMiddleRef = Proxy

224+

225+-- Adding an endpoint at the top-level in various places

226+-- is also somewhat critical for grouping, but it should

227+-- not disrupt grouping at all, even if it is placed in

228+-- the middle.

229+

230+type PermuteEndEnd =

231+ "a" :> "b" :> "c" :> End

232+ :<|> "b" :> "a" :> "c" :> End

233+ :<|> "a" :> "c" :> "b" :> End

234+ :<|> "c" :> "a" :> "b" :> End

235+ :<|> "b" :> "c" :> "a" :> End

236+ :<|> "c" :> "b" :> "a" :> End

237+ :<|> End

238+

239+type PermuteEndBegin =

240+ End

241+ :<|> "a" :> "b" :> "c" :> End

242+ :<|> "b" :> "a" :> "c" :> End

243+ :<|> "a" :> "c" :> "b" :> End

244+ :<|> "c" :> "a" :> "b" :> End

245+ :<|> "b" :> "c" :> "a" :> End

246+ :<|> "c" :> "b" :> "a" :> End

247+

248+type PermuteEndMiddle =

249+ "a" :> "b" :> "c" :> End

250+ :<|> "b" :> "a" :> "c" :> End

251+ :<|> "a" :> "c" :> "b" :> End

252+ :<|> End

253+ :<|> "c" :> "a" :> "b" :> End

254+ :<|> "b" :> "c" :> "a" :> End

255+ :<|> "c" :> "b" :> "a" :> End

256+

257+type PermuteEndRef = PermuteRef :<|> End

258+

259+permuteEndEnd :: Proxy PermuteEndEnd

260+permuteEndEnd = Proxy

261+

262+permuteEndBegin :: Proxy PermuteEndBegin

263+permuteEndBegin = Proxy

264+

265+permuteEndMiddle :: Proxy PermuteEndMiddle

266+permuteEndMiddle = Proxy

267+

268+permuteEndRef :: Proxy PermuteEndRef

269+permuteEndRef = Proxy

270+

271+-- An API with routes on different nesting levels that

272+-- is composed out of different fragments should still

273+-- be reordered correctly.

274+

275+type LevelFragment1 =

276+ "a" :> "b" :> End

277+ :<|> "a" :> End

278+

279+type LevelFragment2 =

280+ "b" :> End

281+ :<|> "a" :> "c" :> End

282+ :<|> End

283+

284+type Level = LevelFragment1 :<|> LevelFragment2

285+

286+type LevelRef =

287+ "a" :> ("b" :> End :<|> "c" :> End :<|> End)

288+ :<|> "b" :> End

289+ :<|> End

290+

291+level :: Proxy Level

292+level = Proxy

293+

294+levelRef :: Proxy LevelRef

295+levelRef = Proxy

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

@@ -13,9 +13,6 @@

14module Servant.ServerSpec where

16−#if !MIN_VERSION_base(4,8,0)

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

18−#endif

19import Control.Monad (forM_, when, unless)

16import Control.Monad (forM_, when, unless)

20import Control.Monad.Trans.Except (ExceptT, throwE)

17import Control.Monad.Trans.Except (ExceptT, throwE)

21import Data.Aeson (FromJSON, ToJSON, decode', encode)

18import Data.Aeson (FromJSON, ToJSON, decode', encode)

@@ -36,8 +33,7 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType,

36 parseQuery)

33 parseQuery)

37import Network.Wai (Application, Request, requestHeaders, pathInfo,

34import Network.Wai (Application, Request, requestHeaders, pathInfo,

38 queryString, rawQueryString,

35 queryString, rawQueryString,

39− responseBuilder, responseLBS)

36+ responseLBS)

40−import Network.Wai.Internal (Response (ResponseBuilder))

41import Network.Wai.Test (defaultRequest, request,

37import Network.Wai.Test (defaultRequest, request,

42 runSession, simpleBody,

38 runSession, simpleBody,

43 simpleHeaders, simpleStatus)

39 simpleHeaders, simpleStatus)

@@ -66,11 +62,6 @@ import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthChec

66import Servant.Server.Experimental.Auth

62import Servant.Server.Experimental.Auth

67 (AuthHandler, AuthServerData,

63 (AuthHandler, AuthServerData,

68 mkAuthHandler)

64 mkAuthHandler)

69−import Servant.Server.Internal.RoutingApplication

70− (toApplication, RouteResult(..))

71−import Servant.Server.Internal.Router

72− (tweakResponse, runRouter,

73− Router, Router'(LeafRouter))

74import Servant.Server.Internal.Context

65import Servant.Server.Internal.Context

75 (NamedContext(..))

66 (NamedContext(..))

@@ -94,7 +85,6 @@ spec = do

94 rawSpec

85 rawSpec

95 alternativeSpec

86 alternativeSpec

96 responseHeadersSpec

87 responseHeadersSpec

97− routerSpec

98 miscCombinatorSpec

88 miscCombinatorSpec

99 basicAuthSpec

89 basicAuthSpec

100 genAuthSpec

90 genAuthSpec

@@ -482,28 +472,6 @@ responseHeadersSpec = describe "ResponseHeaders" $ do

482 THW.request method "" [(hAccept, "crazy/mime")] ""

472 THW.request method "" [(hAccept, "crazy/mime")] ""

483 `shouldRespondWith` 406

473 `shouldRespondWith` 406

484

474

485−-- }}}

486−------------------------------------------------------------------------------

487−-- * routerSpec {{{

488−------------------------------------------------------------------------------

489−routerSpec :: Spec

490−routerSpec = do

491− describe "Servant.Server.Internal.Router" $ do

492− let app' :: Application

493− app' = toApplication $ runRouter router'

494−

495− router', router :: Router

496− router' = tweakResponse (twk <$>) router

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

498−

499− twk :: Response -> Response

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

501− twk b = b

502−

503− describe "tweakResponse" . with (return app') $ do

504− it "calls f on route result" $ do

505− get "" `shouldRespondWith` 202

506−

507-- }}}

475-- }}}

508------------------------------------------------------------------------------

476------------------------------------------------------------------------------

509-- * miscCombinatorSpec {{{

477-- * miscCombinatorSpec {{{