Merge pull request #451 from kosmikus/show-router

Improvements of router merging, visualization and testing

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

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/
+-- > │  └─ <dyn>/
+-- > │     ├─•
+-- > │     ┆
+-- > │     └─•
+-- > ├─ c/
+-- > │  └─•
+-- > ┆
+-- > └─ <raw>
+--
+-- Explanation of symbols:
+--
+-- [@├@] Normal lines reflect static branching via a table.
+--
+-- [@a/@] Nodes reflect static path components.
+--
+-- [@─•@] Leaves reflect endpoints.
+--
+-- [@\<dyn\>/@] This is a delayed capture of a path component.
+--
+-- [@\<raw\>@] 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
 

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
+    route' request respond =
-      | pathIsEmpty request =
           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
+    route' request respond =
-      | pathIsEmpty request =
           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,8 +410,9 @@ instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> s
 
   type ServerT (path :> sublayout) m = ServerT sublayout m
 
-  route Proxy context subserver = StaticRouter $
+  route Proxy context subserver =
-    M.singleton (cs (symbolVal proxyPath))
+    pathRouter
+      (cs (symbolVal proxyPath))
       (route (Proxy :: Proxy sublayout) context subserver)
     where proxyPath = Proxy :: Proxy path
 
@@ -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
 

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)
+  | StaticRouter  (Map Text (Router' a)) [a]
-      -- ^ first path component used for lookup and removed afterwards
+      -- ^ the map contains routers for subpaths (first path component used
-  | DynamicRouter (Text -> Router)
+      --   for lookup and removed afterwards), the list contains handlers
-      -- ^ first path component used for lookup and removed afterwards
+      --   for the empty path, to be tried in order
-  | LeafRouter    a
+  | DynamicRouter (Text -> Router' a)
-      -- ^ to be used for routes that match an empty path
+      -- ^ first path component passed to the function and removed afterwards
-  | Choice        Router Router
+  | 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`.
+-- | Smart constructor for a single static path component.
-tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router
+pathRouter :: Text -> Router' a -> Router' a
-tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
+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) =
+choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
-  StaticRouter (M.unionWith choice table1 table2)
+  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,31 +64,129 @@ 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 "<dyn>" (mkRouterLayout False r)
+    mkRouterLayout c  RawRouterStructure         =
+      if c then ["├─ <raw>"] else ["└─ <raw>"]
+    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
+    []   -> runChoice ls request respond
-      | Just router <- M.lookup first table
+    -- 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 (RawRouter app)      request respond = app request respond
-runRouter (LeafRouter app)     request respond = app request respond
 runRouter (Choice r1 r2)       request respond =
-  runRouter r1 request $ \ mResponse1 -> case mResponse1 of
+  runChoice [runRouter r1, runRouter r2] request respond
-    Fail _ -> runRouter r2 request $ \ mResponse2 ->
+
-      respond (highestPri mResponse1 mResponse2)
+-- | Try a list of routing applications in order.
-    _      -> respond mResponse1
+-- 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)
@@ -84,7 +195,6 @@ runRouter (Choice r1 r2)       request respond =
     highestPri (Fail _) y = y
     highestPri x _ = x
 
-
 -- Priority on HTTP codes.
 --
 -- It just so happens that 404 < 405 < 406 as far as

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

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

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)
+                                             responseLBS)
-import           Network.Wai.Internal       (Response (ResponseBuilder))
 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 {{{