diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 730e96d5..d1ea0673 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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 diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index 6f4ebfbb..8e53c614 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/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) - -- ^ current request is passed to the router + WithRequest (Request -> (Request, 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