Merge pull request #451 from kosmikus/show-router

Improvements of router merging, visualization and testing

Author: kosmikus

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,19 +26,17 @@ 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)
 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,34 +159,30 @@ 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
                        ) respond $ \ output -> do
                 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