From 8c778825c71dd6a5d594fada9f855d47a3897f58 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Thu, 7 Apr 2016 13:45:15 +0200 Subject: [PATCH] Improvements and visualization of router structure. * Improves how Routers are built, in particular via the `choice` smart constructors. Static lookups are now used more often. * We now have test cases making sure that certain routers have the same structure. * The router structure can now be visualized for debugging purposes as a tree. The new functions `layout` and `layoutWithContext` do this. --- servant-server/CHANGELOG.md | 9 + servant-server/src/Servant/Server.hs | 72 +++++ servant-server/src/Servant/Server/Internal.hs | 31 +- .../src/Servant/Server/Internal/Router.hs | 170 ++++++++-- .../Server/Internal/RoutingApplication.hs | 25 -- .../test/Servant/Server/RouterSpec.hs | 295 ++++++++++++++++++ servant-server/test/Servant/ServerSpec.hs | 34 +- 7 files changed, 527 insertions(+), 109 deletions(-) create mode 100644 servant-server/test/Servant/Server/RouterSpec.hs diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 67db6cd0..173a84b9 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,3 +1,12 @@ +0.7 +--- + +* The `Router` type has been changed. There are now more situations where + servers will make use of static lookups to efficiently route the request + to the correct endpoint. Functions `layout` and `layoutWithContext` have + been added to visualize the router layout for debugging purposes. Test + cases for expected router layouts have been added. + 0.6.1 ----- diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 8eff9c66..54797c6b 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -18,6 +18,10 @@ module Servant.Server HasServer(..) , Server + -- * Debugging the server layout + , layout + , layoutWithContext + -- * Enter -- $enterDoc @@ -93,6 +97,7 @@ module Servant.Server ) where import Data.Proxy (Proxy) +import Data.Text (Text) import Network.Wai (Application) import Servant.Server.Internal import Servant.Server.Internal.Enter @@ -131,6 +136,73 @@ serveWithContext p context server = toApplication (runRouter (route p context d) d = Delayed r r r r (\ _ _ _ -> Route server) r = return (Route ()) +-- | The function 'layout' produces a textual description of the internal +-- router layout for debugging purposes. Note that the router layout is +-- determined just by the API, not by the handlers. +-- +-- This function makes certain assumptions about the well-behavedness of +-- the 'HasServer' instances of the combinators which should be ok for the +-- core servant constructions, but might not be satisfied for some other +-- combinators provided elsewhere. It is possible that the function may +-- crash for these. +-- +-- Example: +-- +-- For the following API +-- +-- > type API = +-- > "a" :> "d" :> Get '[JSON] () +-- > :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool +-- > :<|> "c" :> Put '[JSON] Bool +-- > :<|> "a" :> "e" :> Get '[JSON] Int +-- > :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool +-- > :<|> Raw +-- +-- we get the following output: +-- +-- > / +-- > ├─ a/ +-- > │ ├─ d/ +-- > │ │ └─• +-- > │ └─ e/ +-- > │ └─• +-- > ├─ b/ +-- > │ └─ / +-- > │ ├─• +-- > │ ┆ +-- > │ └─• +-- > ├─ c/ +-- > │ └─• +-- > ┆ +-- > └─ +-- +-- Explanation of symbols: +-- +-- [@├@] Normal lines reflect static branching via a table. +-- +-- [@a/@] Nodes reflect static path components. +-- +-- [@─•@] Leaves reflect endpoints. +-- +-- [@\/@] This is a delayed capture of a path component. +-- +-- [@\@] This is a part of the API we do not know anything about. +-- +-- [@┆@] Dashed lines suggest a dynamic choice between the part above +-- and below. If there is a success for fatal failure in the first part, +-- that one takes precedence. If both parts fail, the \"better\" error +-- code will be returned. +-- +layout :: (HasServer layout '[]) => Proxy layout -> Text +layout p = layoutWithContext p EmptyContext + +-- | Variant of 'layout' that takes an additional 'Context'. +layoutWithContext :: (HasServer layout context) + => Proxy layout -> Context context -> Text +layoutWithContext p context = routerLayout (route p context d) + where + d = Delayed r r r r (\ _ _ _ -> FailFatal err501) + r = return (Route ()) -- Documentation diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 1733f246..dbf89dd2 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -26,11 +26,9 @@ import Control.Monad.Trans.Except (ExceptT) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL -import qualified Data.Map as M import Data.Maybe (fromMaybe, mapMaybe) import Data.String (fromString) import Data.String.Conversions (cs, (<>)) -import Data.Text (Text) import Data.Typeable import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) @@ -38,7 +36,7 @@ import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.Socket (SockAddr) import Network.Wai (Application, Request, Response, httpVersion, isSecure, - lazyRequestBody, pathInfo, + lazyRequestBody, rawQueryString, remoteHost, requestHeaders, requestMethod, responseLBS, vault) @@ -161,26 +159,23 @@ methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status -> Delayed (ExceptT ServantErr IO a) -> Router -methodRouter method proxy status action = LeafRouter route' +methodRouter method proxy status action = leafRouter route' where - route' request respond - | pathIsEmpty request = + route' request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) respond $ \ output -> do let handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request - | otherwise = respond $ Fail err404 methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) => Method -> Proxy ctypes -> Status -> Delayed (ExceptT ServantErr IO (Headers h v)) -> Router -methodRouterHeaders method proxy status action = LeafRouter route' +methodRouterHeaders method proxy status action = leafRouter route' where - route' request respond - | pathIsEmpty request = + route' request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH @@ -188,7 +183,6 @@ methodRouterHeaders method proxy status action = LeafRouter route' let headers = getHeaders output handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just headers) request - | otherwise = respond $ Fail err404 instance OVERLAPPABLE_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status @@ -359,7 +353,7 @@ instance HasServer Raw context where type ServerT Raw m = Application - route Proxy _ rawApplication = LeafRouter $ \ request respond -> do + route Proxy _ rawApplication = RawRouter $ \ request respond -> do r <- runDelayed rawApplication case r of Route app -> app request (respond . Route) @@ -416,9 +410,10 @@ instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> s type ServerT (path :> sublayout) m = ServerT sublayout m - route Proxy context subserver = StaticRouter $ - M.singleton (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) context subserver) + route Proxy context subserver = + pathRouter + (cs (symbolVal proxyPath)) + (route (Proxy :: Proxy sublayout) context subserver) where proxyPath = Proxy :: Proxy path instance HasServer api context => HasServer (RemoteHost :> api) context where @@ -465,12 +460,6 @@ instance ( KnownSymbol realm -- * helpers -pathIsEmpty :: Request -> Bool -pathIsEmpty = go . pathInfo - where go [] = True - go [""] = True - go _ = False - ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index 6f4ebfbb..04b661a3 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -1,10 +1,13 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where import Data.Map (Map) import qualified Data.Map as M +import Data.Monoid import Data.Text (Text) +import qualified Data.Text as T import Network.Wai (Request, Response, pathInfo) import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr @@ -13,36 +16,46 @@ type Router = Router' RoutingApplication -- | Internal representation of a router. data Router' a = - WithRequest (Request -> Router) + WithRequest (Request -> Router' a) -- ^ current request is passed to the router - | StaticRouter (Map Text Router) - -- ^ first path component used for lookup and removed afterwards - | DynamicRouter (Text -> Router) - -- ^ first path component used for lookup and removed afterwards - | LeafRouter a - -- ^ to be used for routes that match an empty path - | Choice Router Router + | StaticRouter (Map Text (Router' a)) [a] + -- ^ the map contains routers for subpaths (first path component used + -- for lookup and removed afterwards), the list contains handlers + -- for the empty path, to be tried in order + | DynamicRouter (Text -> Router' a) + -- ^ first path component passed to the function and removed afterwards + | RawRouter a + -- ^ to be used for routes we do not know anything about + | Choice (Router' a) (Router' a) -- ^ left-biased choice between two routers deriving Functor --- | Apply a transformation to the response of a `Router`. -tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router -tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) +-- | Smart constructor for a single static path component. +pathRouter :: Text -> Router' a -> Router' a +pathRouter t r = StaticRouter (M.singleton t r) [] + +-- | Smart constructor for a leaf, i.e., a router that expects +-- the empty path. +-- +leafRouter :: a -> Router' a +leafRouter l = StaticRouter M.empty [l] -- | Smart constructor for the choice between routers. -- We currently optimize the following cases: -- --- * Two static routers can be joined by joining their maps. +-- * Two static routers can be joined by joining their maps +-- and concatenating their leaf-lists. -- * Two dynamic routers can be joined by joining their codomains. -- * Two 'WithRequest' routers can be joined by passing them -- the same request and joining their codomains. -- * A 'WithRequest' router can be joined with anything else by -- passing the same request to both but ignoring it in the -- component that does not need it. +-- * Choice nodes can be reordered. -- choice :: Router -> Router -> Router -choice (StaticRouter table1) (StaticRouter table2) = - StaticRouter (M.unionWith choice table1 table2) +choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) = + StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2) choice (DynamicRouter fun1) (DynamicRouter fun2) = DynamicRouter (\ first -> choice (fun1 first) (fun2 first)) choice (WithRequest router1) (WithRequest router2) = @@ -51,39 +64,136 @@ choice (WithRequest router1) router2 = WithRequest (\ request -> choice (router1 request) router2) choice router1 (WithRequest router2) = WithRequest (\ request -> choice router1 (router2 request)) +choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3 choice router1 router2 = Choice router1 router2 +-- | Datatype used for representing and debugging the +-- structure of a router. Abstracts from the functions +-- being used in the actual router and the handlers at +-- the leaves. +-- +-- Two 'Router's can be structurally compared by computing +-- their 'RouterStructure' using 'routerStructure' and +-- then testing for equality, see 'sameStructure'. +-- +data RouterStructure = + WithRequestStructure RouterStructure + | StaticRouterStructure (Map Text RouterStructure) Int + | DynamicRouterStructure RouterStructure + | RawRouterStructure + | ChoiceStructure RouterStructure RouterStructure + deriving (Eq, Show) + +-- | Compute the structure of a router. +-- +-- Assumes that the request or text being passed +-- in 'WithRequest' or 'DynamicRouter' does not +-- affect the structure of the underlying tree. +-- +routerStructure :: Router' a -> RouterStructure +routerStructure (WithRequest f) = + WithRequestStructure $ + routerStructure (f (error "routerStructure: dummy request")) +routerStructure (StaticRouter m ls) = + StaticRouterStructure (fmap routerStructure m) (length ls) +routerStructure (DynamicRouter f) = + DynamicRouterStructure $ + routerStructure (f (error "routerStructure: dummy text")) +routerStructure (RawRouter _) = + RawRouterStructure +routerStructure (Choice r1 r2) = + ChoiceStructure + (routerStructure r1) + (routerStructure r2) + +-- | Compare the structure of two routers. +-- +sameStructure :: Router' a -> Router' b -> Bool +sameStructure r1 r2 = + routerStructure r1 == routerStructure r2 + +-- | Provide a textual representation of the +-- structure of a router. +-- +routerLayout :: Router' a -> Text +routerLayout router = + T.unlines (["/"] ++ mkRouterLayout False (routerStructure router)) + where + mkRouterLayout :: Bool -> RouterStructure -> [Text] + mkRouterLayout c (WithRequestStructure r) = mkRouterLayout c r + mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n + mkRouterLayout c (DynamicRouterStructure r) = mkSubTree c "" (mkRouterLayout False r) + mkRouterLayout c RawRouterStructure = + if c then ["├─ "] else ["└─ "] + mkRouterLayout c (ChoiceStructure r1 r2) = + mkRouterLayout True r1 ++ ["┆"] ++ mkRouterLayout c r2 + + mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text] + mkSubTrees _ [] 0 = [] + mkSubTrees c [] n = + concat (replicate (n - 1) (mkLeaf True) ++ [mkLeaf c]) + mkSubTrees c [(t, r)] 0 = + mkSubTree c t (mkRouterLayout False r) + mkSubTrees c ((t, r) : trs) n = + mkSubTree True t (mkRouterLayout False r) ++ mkSubTrees c trs n + + mkLeaf :: Bool -> [Text] + mkLeaf True = ["├─•","┆"] + mkLeaf False = ["└─•"] + + mkSubTree :: Bool -> Text -> [Text] -> [Text] + mkSubTree True path children = ("├─ " <> path <> "/") : map ("│ " <>) children + mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children + +-- | Apply a transformation to the response of a `Router`. +tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router +tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) + -- | Interpret a router as an application. runRouter :: Router -> RoutingApplication runRouter (WithRequest router) request respond = runRouter (router request) request respond -runRouter (StaticRouter table) request respond = +runRouter (StaticRouter table ls) request respond = case pathInfo request of - first : rest - | Just router <- M.lookup first table + [] -> runChoice ls request respond + -- This case is to handle trailing slashes. + [""] -> runChoice ls request respond + first : rest | Just router <- M.lookup first table -> let request' = request { pathInfo = rest } in runRouter router request' respond _ -> respond $ Fail err404 runRouter (DynamicRouter fun) request respond = case pathInfo request of + [] -> respond $ Fail err404 + -- This case is to handle trailing slashes. + [""] -> respond $ Fail err404 first : rest -> let request' = request { pathInfo = rest } in runRouter (fun first) request' respond - _ -> respond $ Fail err404 -runRouter (LeafRouter app) request respond = app request respond +runRouter (RawRouter app) request respond = app request respond runRouter (Choice r1 r2) request respond = - runRouter r1 request $ \ mResponse1 -> case mResponse1 of - Fail _ -> runRouter r2 request $ \ mResponse2 -> - respond (highestPri mResponse1 mResponse2) - _ -> respond mResponse1 - where - highestPri (Fail e1) (Fail e2) = - if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2) - then Fail e2 - else Fail e1 - highestPri (Fail _) y = y - highestPri x _ = x + runChoice [runRouter r1, runRouter r2] request respond +-- | Try a list of routing applications in order. +-- We stop as soon as one fails fatally or succeeds. +-- If all fail normally, we pick the "best" error. +-- +runChoice :: [RoutingApplication] -> RoutingApplication +runChoice [] _request respond = respond (Fail err404) +runChoice [r] request respond = r request respond +runChoice (r : rs) request respond = + r request $ \ response1 -> + case response1 of + Fail _ -> runChoice rs request $ \ response2 -> + respond $ highestPri response1 response2 + _ -> respond response1 + where + highestPri (Fail e1) (Fail e2) = + if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2) + then Fail e2 + else Fail e1 + highestPri (Fail _) y = y + highestPri x _ = x -- Priority on HTTP codes. -- diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 7d0c4341..56754c1f 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -35,31 +35,6 @@ toApplication ra request respond = ra request routingRespond routingRespond (FailFatal err) = respond $ responseServantErr err routingRespond (Route v) = respond v --- We currently mix up the order in which we perform checks --- and the priority with which errors are reported. --- --- For example, we perform Capture checks prior to method checks, --- and therefore get 404 before 405. --- --- However, we also perform body checks prior to method checks --- now, and therefore get 415 before 405, which is wrong. --- --- If we delay Captures, but perform method checks eagerly, we --- end up potentially preferring 405 over 404, which is also bad. --- --- So in principle, we'd like: --- --- static routes (can cause 404) --- delayed captures (can cause 404) --- methods (can cause 405) --- authentication and authorization (can cause 401, 403) --- delayed body (can cause 415, 400) --- accept header (can cause 406) --- --- According to the HTTP decision diagram, the priority order --- between HTTP status codes is as follows: --- - -- | A 'Delayed' is a representation of a handler with scheduled -- delayed checks that can trigger errors. -- diff --git a/servant-server/test/Servant/Server/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs new file mode 100644 index 00000000..7ebd1a75 --- /dev/null +++ b/servant-server/test/Servant/Server/RouterSpec.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Server.RouterSpec (spec) where + +import Control.Monad (unless) +import Data.Proxy (Proxy(..)) +import Data.Text (unpack) +import Network.HTTP.Types (Status (..)) +import Network.Wai (Application, responseBuilder) +import Network.Wai.Internal (Response (ResponseBuilder)) +import Test.Hspec +import Test.Hspec.Wai (get, shouldRespondWith, with) +import Servant.API +import Servant.Server +import Servant.Server.Internal + +spec = describe "Servant.Server.Internal.Router" $ do + routerSpec + distributivitySpec + +routerSpec :: Spec +routerSpec = do + let app' :: Application + app' = toApplication $ runRouter router' + + router', router :: Router + router' = tweakResponse (fmap twk) router + router = leafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") + + twk :: Response -> Response + twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b + twk b = b + + describe "tweakResponse" . with (return app') $ do + it "calls f on route result" $ do + get "" `shouldRespondWith` 202 + +distributivitySpec :: Spec +distributivitySpec = + describe "choice" $ do + it "distributes endpoints through static paths" $ do + endpoint `shouldHaveSameStructureAs` endpointRef + it "distributes nested routes through static paths" $ do + static `shouldHaveSameStructureAs` staticRef + it "distributes nested routes through dynamic paths" $ do + dynamic `shouldHaveSameStructureAs` dynamicRef + it "properly reorders permuted static paths" $ do + permute `shouldHaveSameStructureAs` permuteRef + it "properly reorders permuted static paths in the presence of Raw in end" $ do + permuteRawEnd `shouldHaveSameStructureAs` permuteRawEndRef + it "properly reorders permuted static paths in the presence of Raw in beginning" $ do + permuteRawBegin `shouldHaveSameStructureAs` permuteRawBeginRef + it "properly reorders permuted static paths in the presence of Raw in middle" $ do + permuteRawMiddle `shouldHaveSameStructureAs` permuteRawMiddleRef + it "properly reorders permuted static paths in the presence of a root endpoint in end" $ do + permuteEndEnd `shouldHaveSameStructureAs` permuteEndRef + it "properly reorders permuted static paths in the presence of a root endpoint in beginning" $ do + permuteEndBegin `shouldHaveSameStructureAs` permuteEndRef + it "properly reorders permuted static paths in the presence of a root endpoint in middle" $ do + permuteEndMiddle `shouldHaveSameStructureAs` permuteEndRef + it "properly handles mixing static paths at different levels" $ do + level `shouldHaveSameStructureAs` levelRef + +shouldHaveSameStructureAs :: + (HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation +shouldHaveSameStructureAs p1 p2 = + unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $ + expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1)) + +makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router +makeTrivialRouter p = route p EmptyContext d + where + d = Delayed r r r r (\ _ _ _ -> FailFatal err501) + r = return (Route ()) + +type End = Get '[JSON] () + +-- The latter version looks more efficient, +-- but the former should be compiled to the +-- same layout: + +type Endpoint = "a" :> End :<|> "a" :> End +type EndpointRef = "a" :> (End :<|> End) + +endpoint :: Proxy Endpoint +endpoint = Proxy + +endpointRef :: Proxy EndpointRef +endpointRef = Proxy + +-- Again, the latter version looks more efficient, +-- but the former should be compiled to the same +-- layout: + +type Static = "a" :> "b" :> End :<|> "a" :> "c" :> End +type StaticRef = "a" :> ("b" :> End :<|> "c" :> End) + +static :: Proxy Static +static = Proxy + +staticRef :: Proxy StaticRef +staticRef = Proxy + +-- Even for dynamic path components, we expect the +-- router to simplify the layout, because captures +-- are delayed and only actually performed once +-- reaching an endpoint. So the former version and +-- the latter should be compiled to the same router +-- structure: + +type Dynamic = + "a" :> Capture "foo" Int :> "b" :> End + :<|> "a" :> Capture "bar" Bool :> "c" :> End + :<|> "a" :> Capture "baz" Char :> "d" :> End + +type DynamicRef = + "a" :> Capture "anything" () :> + ("b" :> End :<|> "c" :> End :<|> "d" :> End) + +dynamic :: Proxy Dynamic +dynamic = Proxy + +dynamicRef :: Proxy DynamicRef +dynamicRef = Proxy + +-- A more complicated example of static route reordering. +-- All the permuted paths should be correctly grouped, +-- so both 'Permute' and 'PermuteRef' should compile to +-- the same layout: + +type Permute = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteRef = + "a" :> ( "b" :> "c" :> End + :<|> "c" :> "b" :> End + ) + :<|> "b" :> ( "a" :> "c" :> End + :<|> "c" :> "a" :> End + ) + :<|> "c" :> ( "a" :> "b" :> End + :<|> "b" :> "a" :> End + ) + +permute :: Proxy Permute +permute = Proxy + +permuteRef :: Proxy PermuteRef +permuteRef = Proxy + +-- Adding a 'Raw' in one of the ends should have minimal +-- effect on the grouping. + +type PermuteRawEnd = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + :<|> Raw + +type PermuteRawEndRef = PermuteRef :<|> Raw + +type PermuteRawBegin = + Raw + :<|> "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteRawBeginRef = Raw :<|> PermuteRef + +permuteRawBegin :: Proxy PermuteRawBegin +permuteRawBegin = Proxy + +permuteRawBeginRef :: Proxy PermuteRawBeginRef +permuteRawBeginRef = Proxy + +permuteRawEnd :: Proxy PermuteRawEnd +permuteRawEnd = Proxy + +permuteRawEndRef :: Proxy PermuteRawEndRef +permuteRawEndRef = Proxy + +-- Adding a 'Raw' in the middle will disrupt grouping, +-- because we commute things past a 'Raw'. But the two +-- halves should still be grouped. + +type PermuteRawMiddle = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> Raw + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteRawMiddleRef = + "a" :> ( "b" :> "c" :> End + :<|> "c" :> "b" :> End + ) + :<|> "b" :> "a" :> "c" :> End + :<|> Raw + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> ( "a" :> "b" :> End + :<|> "b" :> "a" :> End + ) + +permuteRawMiddle :: Proxy PermuteRawMiddle +permuteRawMiddle = Proxy + +permuteRawMiddleRef :: Proxy PermuteRawMiddleRef +permuteRawMiddleRef = Proxy + +-- Adding an endpoint at the top-level in various places +-- is also somewhat critical for grouping, but it should +-- not disrupt grouping at all, even if it is placed in +-- the middle. + +type PermuteEndEnd = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + :<|> End + +type PermuteEndBegin = + End + :<|> "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteEndMiddle = + "a" :> "b" :> "c" :> End + :<|> "b" :> "a" :> "c" :> End + :<|> "a" :> "c" :> "b" :> End + :<|> End + :<|> "c" :> "a" :> "b" :> End + :<|> "b" :> "c" :> "a" :> End + :<|> "c" :> "b" :> "a" :> End + +type PermuteEndRef = PermuteRef :<|> End + +permuteEndEnd :: Proxy PermuteEndEnd +permuteEndEnd = Proxy + +permuteEndBegin :: Proxy PermuteEndBegin +permuteEndBegin = Proxy + +permuteEndMiddle :: Proxy PermuteEndMiddle +permuteEndMiddle = Proxy + +permuteEndRef :: Proxy PermuteEndRef +permuteEndRef = Proxy + +-- An API with routes on different nesting levels that +-- is composed out of different fragments should still +-- be reordered correctly. + +type LevelFragment1 = + "a" :> "b" :> End + :<|> "a" :> End + +type LevelFragment2 = + "b" :> End + :<|> "a" :> "c" :> End + :<|> End + +type Level = LevelFragment1 :<|> LevelFragment2 + +type LevelRef = + "a" :> ("b" :> End :<|> "c" :> End :<|> End) + :<|> "b" :> End + :<|> End + +level :: Proxy Level +level = Proxy + +levelRef :: Proxy LevelRef +levelRef = Proxy diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 942484b1..d210ca55 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -13,9 +13,6 @@ module Servant.ServerSpec where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif import Control.Monad (forM_, when, unless) import Control.Monad.Trans.Except (ExceptT, throwE) import Data.Aeson (FromJSON, ToJSON, decode', encode) @@ -36,8 +33,7 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType, parseQuery) import Network.Wai (Application, Request, requestHeaders, pathInfo, queryString, rawQueryString, - responseBuilder, responseLBS) -import Network.Wai.Internal (Response (ResponseBuilder)) + responseLBS) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody, simpleHeaders, simpleStatus) @@ -66,11 +62,6 @@ import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthChec import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) -import Servant.Server.Internal.RoutingApplication - (toApplication, RouteResult(..)) -import Servant.Server.Internal.Router - (tweakResponse, runRouter, - Router, Router'(LeafRouter)) import Servant.Server.Internal.Context (NamedContext(..)) @@ -94,7 +85,6 @@ spec = do rawSpec alternativeSpec responseHeadersSpec - routerSpec miscCombinatorSpec basicAuthSpec genAuthSpec @@ -482,28 +472,6 @@ responseHeadersSpec = describe "ResponseHeaders" $ do THW.request method "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406 --- }}} ------------------------------------------------------------------------------- --- * routerSpec {{{ ------------------------------------------------------------------------------- -routerSpec :: Spec -routerSpec = do - describe "Servant.Server.Internal.Router" $ do - let app' :: Application - app' = toApplication $ runRouter router' - - router', router :: Router - router' = tweakResponse (twk <$>) router - router = LeafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") - - twk :: Response -> Response - twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b - twk b = b - - describe "tweakResponse" . with (return app') $ do - it "calls f on route result" $ do - get "" `shouldRespondWith` 202 - -- }}} ------------------------------------------------------------------------------ -- * miscCombinatorSpec {{{