Modify WithRequest to enable request manipulation

servant-server/src/Servant/Server/Internal.hs

@@ -236,7 +236,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
 
   route Proxy subserver = WithRequest $ \ request ->
     let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
-    in  route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
+    in  (request, route (Proxy :: Proxy sublayout) (passToServer subserver mheader))
     where str = fromString $ symbolVal (Proxy :: Proxy sym)
 
 -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
@@ -274,7 +274,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
             Just Nothing  -> Nothing -- param present with no value -> Nothing
             Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
                                         -- the right type
-    in route (Proxy :: Proxy sublayout) (passToServer subserver param)
+    in (request, route (Proxy :: Proxy sublayout) (passToServer subserver param))
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
 
 -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@@ -309,7 +309,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
         -- corresponding values
         parameters = filter looksLikeParam querytext
         values = mapMaybe (convert . snd) parameters
-    in  route (Proxy :: Proxy sublayout) (passToServer subserver values)
+    in  (request, route (Proxy :: Proxy sublayout) (passToServer subserver values))
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
           looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
           convert Nothing = Nothing
@@ -339,7 +339,7 @@ instance (KnownSymbol sym, HasServer sublayout)
           Just Nothing  -> True  -- param is there, with no value
           Just (Just v) -> examine v -- param with a value
           Nothing       -> False -- param not in the query string
-    in  route (Proxy :: Proxy sublayout) (passToServer subserver param)
+    in  (request, route (Proxy :: Proxy sublayout) (passToServer subserver param))
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
           examine v | v == "true" || v == "1" || v == "" = True
                     | otherwise = False
@@ -391,7 +391,7 @@ instance ( AllCTUnrender list a, HasServer sublayout
     a -> ServerT sublayout m
 
   route Proxy subserver = WithRequest $ \ request ->
-    route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request))
+    (request, route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request)))
     where
       bodyCheck request = do
         -- See HTTP RFC 2616, section 7.2.1
@@ -422,13 +422,13 @@ instance HasServer api => HasServer (RemoteHost :> api) where
   type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
 
   route Proxy subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req)
+    (req, route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req))
 
 instance HasServer api => HasServer (IsSecure :> api) where
   type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
 
   route Proxy subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) (passToServer subserver $ secure req)
+    (req, route (Proxy :: Proxy api) (passToServer subserver $ secure req))
 
     where secure req = if isSecure req then Secure else NotSecure
 
@@ -436,13 +436,13 @@ instance HasServer api => HasServer (Vault :> api) where
   type ServerT (Vault :> api) m = Vault -> ServerT api m
 
   route Proxy subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) (passToServer subserver $ vault req)
+    (req, route (Proxy :: Proxy api) (passToServer subserver $ vault req))
 
 instance HasServer api => HasServer (HttpVersion :> api) where
   type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
 
   route Proxy subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req)
+    (req, route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req))
 
 pathIsEmpty :: Request -> Bool
 pathIsEmpty = go . pathInfo

servant-server/src/Servant/Server/Internal/Router.hs

@@ -13,8 +13,8 @@ type Router = Router' RoutingApplication
 
 -- | Internal representation of a router.
 data Router' a =
-    WithRequest   (Request -> Router)
+    WithRequest   (Request -> (Request, Router))
-      -- ^ current request is passed to the router
+      -- ^ current request is passed to the router and can be changed
   | StaticRouter  (Map Text Router)
       -- ^ first path component used for lookup and removed afterwards
   | DynamicRouter (Text -> Router)
@@ -34,29 +34,20 @@ tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
 --
 --   * Two static routers can be joined by joining their maps.
 --   * 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 :: Router -> Router -> Router
 choice (StaticRouter table1) (StaticRouter table2) =
   StaticRouter (M.unionWith choice table1 table2)
 choice (DynamicRouter fun1)  (DynamicRouter fun2)  =
   DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
-choice (WithRequest router1) (WithRequest router2) =
-  WithRequest (\ request -> choice (router1 request) (router2 request))
-choice (WithRequest router1) router2 =
-  WithRequest (\ request -> choice (router1 request) router2)
-choice router1 (WithRequest router2) =
-  WithRequest (\ request -> choice router1 (router2 request))
 choice router1 router2 = Choice router1 router2
 
 -- | Interpret a router as an application.
 runRouter :: Router -> RoutingApplication
 runRouter (WithRequest router) request respond =
-  runRouter (router request) request respond
+  runRouter subRouter subRequest respond
+  where
+    (subRequest, subRouter) = router request
 runRouter (StaticRouter table) request respond =
   case pathInfo request of
     first : rest