From f9b1e7fc5020fc9c9f0928d2baca46719596b499 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Fri, 29 May 2015 17:16:36 +0200 Subject: [PATCH] Switch server interpretation to a datatype for efficiency. Instead of directly interpreting a server as a `RoutingApplication`, this change introduces the concept of a `Router`, which is a datatype with several constructors. In particular, the type of the `route` function changes from route :: Proxy layout -> Server layout -> RoutingApplication to route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router Most important in practice is the case of the `StaticRouter` constructor in `Router`. For choices between statically known paths, we can now use a lookup table to dispatch requests rather than trying each request individually. This brings down routing complexity of a common case from O(n) to O(log n). Another important change is that the handler that is passed down by `route` is no longer of type `Server layout`, but of type `IO (RouteResult (Server layout))`. This means that API constructs can "delay" checks and failure. For example, `ReqBody` does not have to fetch the request body and feed it to the handler immediately; it can instead record these actions in the handler that is passed down. The code will only be executed at a leaf / endpoint of the API. This is desired behaviour: We prefer to save work by doing all matching on static path components first. Furthermore, we get better error codes by doing so. --- servant-server/servant-server.cabal | 1 + servant-server/src/Servant/Server.hs | 2 +- servant-server/src/Servant/Server/Internal.hs | 624 ++++++++++-------- 3 files changed, 348 insertions(+), 279 deletions(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index c0a07c3b..bfb12f9b 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -43,6 +43,7 @@ library , aeson >= 0.7 && < 0.9 , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 , either >= 4.3 && < 4.5 , http-types >= 0.8 && < 0.9 , network-uri >= 2.6 && < 2.7 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 6e28d99e..8f60583a 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -108,7 +108,7 @@ import Servant.Server.Internal.ServantErr -- > main = Network.Wai.Handler.Warp.run 8080 app -- serve :: HasServer layout => Proxy layout -> Server layout -> Application -serve p server = toApplication (route p server) +serve p server = toApplication (runRouter (route p (return (RR (Right server))))) -- Documentation diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index e3282624..069aab78 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -14,7 +15,7 @@ module Servant.Server.Internal where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) +import Control.Applicative (Applicative, (<$>)) import Data.Monoid (Monoid, mappend, mempty) #endif import Control.Monad.Trans.Either (EitherT, runEitherT) @@ -22,6 +23,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.IORef (newIORef, readIORef, writeIORef) import Data.List (unfoldr) +import qualified Data.Map as M import Data.Maybe (catMaybes, fromMaybe) import Data.String (fromString) import Data.String.Conversions (cs, (<>)) @@ -52,6 +54,68 @@ import Servant.Common.Text (FromText, fromText) import Servant.Server.Internal.ServantErr +-- | Internal representation of a router. +data Router = + WithRequest (Request -> Router) + -- ^ current request is passed to the router + | StaticRouter (M.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 RoutingApplication + -- ^ to be used for routes that match an empty path + | Choice Router Router + -- ^ left-biased choice between two routers + +-- | Smart constructor for the choice between routers. +-- We currently optimize the following cases: +-- +-- * 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 (StaticRouter table) request respond = + case processedPathInfo request of + first : rest + | Just router <- M.lookup first table + -> let request' = request { pathInfo = rest } + in runRouter router request' respond + _ -> respond $ failWith NotFound +runRouter (DynamicRouter fun) request respond = + case processedPathInfo request of + first : rest + -> let request' = request { pathInfo = rest } + in runRouter (fun first) request' respond + _ -> respond $ failWith NotFound +runRouter (LeafRouter app) request respond = app request respond +runRouter (Choice r1 r2) request respond = + runRouter r1 request $ \ mResponse1 -> + if isMismatch mResponse1 + then runRouter r2 request $ \ mResponse2 -> + respond (mResponse1 <> mResponse2) + else respond mResponse1 + data ReqBodyState = Uncalled | Called !B.ByteString | Done !B.ByteString @@ -120,7 +184,33 @@ instance Monoid RouteMismatch where -- | A wrapper around @'Either' 'RouteMismatch' a@. newtype RouteResult a = RR { routeResult :: Either RouteMismatch a } - deriving (Eq, Show) + deriving (Eq, Show, Functor, Applicative) + +runAction :: IO (RouteResult (EitherT ServantErr IO a)) + -> (RouteResult Response -> IO r) + -> (a -> RouteResult Response) + -> IO r +runAction action respond k = do + r <- action + go r + where + go (RR (Right a)) = do + e <- runEitherT a + respond $ case e of + Right x -> k x + Left err -> succeedWith $ responseServantErr err + go (RR (Left err)) = respond $ failWith err + +feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b) +feedTo f x = (($ x) <$>) <$> f + +extractL :: RouteResult (a :<|> b) -> RouteResult a +extractL (RR (Right (a :<|> _))) = RR (Right a) +extractL (RR (Left err)) = RR (Left err) + +extractR :: RouteResult (a :<|> b) -> RouteResult b +extractR (RR (Right (_ :<|> b))) = RR (Right b) +extractR (RR (Left err)) = RR (Left err) failWith :: RouteMismatch -> RouteResult a failWith = RR . Left @@ -179,7 +269,7 @@ processedPathInfo r = class HasServer layout where type ServerT layout (m :: * -> *) :: * - route :: Proxy layout -> Server layout -> RoutingApplication + route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router type Server layout = ServerT layout (EitherT ServantErr IO) @@ -200,12 +290,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m - route Proxy (a :<|> b) request respond = - route pa a request $ \mResponse -> - if isMismatch mResponse - then route pb b request $ \mResponse' -> respond (mResponse <> mResponse') - else respond mResponse - + route Proxy server = choice (route pa (extractL <$> server)) + (route pb (extractR <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b @@ -235,15 +321,12 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) type ServerT (Capture capture a :> sublayout) m = a -> ServerT sublayout m - route Proxy subserver request respond = case processedPathInfo request of - (first : rest) - -> case captured captureProxy first of - Nothing -> respond $ failWith NotFound - Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{ - pathInfo = rest - } respond - _ -> respond $ failWith NotFound - + route Proxy subserver = + DynamicRouter $ \ first -> + route (Proxy :: Proxy sublayout) + (case captured captureProxy first of + Nothing -> return $ failWith NotFound + Just v -> feedTo subserver v) where captureProxy = Proxy :: Proxy (Capture capture a) @@ -267,20 +350,19 @@ instance type ServerT (Delete ctypes a) m = m a - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodDelete = do - e <- runEitherT action - respond $ case e of - Right output -> do - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> failWith UnsupportedMediaType - Just (contentT, body) -> succeedWith $ - responseLBS status200 [ ("Content-Type" , cs contentT)] body - Left err -> succeedWith $ responseServantErr err - | pathIsEmpty request && requestMethod request /= methodDelete = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodDelete = do + runAction action respond $ \ output -> do + let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status200 [ ("Content-Type" , cs contentT)] body + | pathIsEmpty request && requestMethod request /= methodDelete = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound instance #if MIN_VERSION_base(4,8,0) @@ -290,15 +372,15 @@ instance type ServerT (Delete ctypes ()) m = m () - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodDelete = do - e <- runEitherT action - respond . succeedWith $ case e of - Right () -> responseLBS noContent204 [] "" - Left err -> responseServantErr err - | pathIsEmpty request && requestMethod request /= methodDelete = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodDelete = do + runAction action respond $ \ () -> + succeedWith $ responseLBS noContent204 [] "" + | pathIsEmpty request && requestMethod request /= methodDelete = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- Add response headers instance @@ -310,21 +392,20 @@ instance type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v) - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodDelete = do - e <- runEitherT action - respond $ case e of - Right output -> do - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - headers = getHeaders output - case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of - Nothing -> failWith UnsupportedMediaType - Just (contentT, body) -> succeedWith $ - responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body - Left err -> succeedWith $ responseServantErr err - | pathIsEmpty request && requestMethod request /= methodDelete = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodDelete = do + runAction action respond $ \ output -> do + let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + headers = getHeaders output + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body + | pathIsEmpty request && requestMethod request /= methodDelete = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- | When implementing the handler for a 'Get' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' @@ -347,20 +428,19 @@ instance type ServerT (Get ctypes a) m = m a - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodGet = do - e <- runEitherT action - respond $ case e of - Right output -> do - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> failWith UnsupportedMediaType - Just (contentT, body) -> succeedWith $ - responseLBS ok200 [ ("Content-Type" , cs contentT)] body - Left err -> succeedWith $ responseServantErr err - | pathIsEmpty request && requestMethod request /= methodGet = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodGet = do + runAction action respond $ \ output -> do + let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS ok200 [ ("Content-Type" , cs contentT)] body + | pathIsEmpty request && requestMethod request /= methodGet = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- '()' ==> 204 No Content instance @@ -371,15 +451,15 @@ instance type ServerT (Get ctypes ()) m = m () - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodGet = do - e <- runEitherT action - respond . succeedWith $ case e of - Right () -> responseLBS noContent204 [] "" - Left err -> responseServantErr err - | pathIsEmpty request && requestMethod request /= methodGet = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodGet = do + runAction action respond $ \ () -> + succeedWith $ responseLBS noContent204 [] "" + | pathIsEmpty request && requestMethod request /= methodGet = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- Add response headers instance @@ -391,21 +471,20 @@ instance type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodGet = do - e <- runEitherT action - respond $ case e of - Right output -> do - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - headers = getHeaders output - case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of - Nothing -> failWith UnsupportedMediaType - Just (contentT, body) -> succeedWith $ - responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body - Left err -> succeedWith $ responseServantErr err - | pathIsEmpty request && requestMethod request /= methodGet = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodGet = do + runAction action respond $ \ output -> do + let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + headers = getHeaders output + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body + | pathIsEmpty request && requestMethod request /= methodGet = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -433,11 +512,10 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy subserver request respond = do + route Proxy subserver = WithRequest $ \ request -> let mheader = fromText . decodeUtf8 =<< lookup str (requestHeaders request) - route (Proxy :: Proxy sublayout) (subserver mheader) request respond - - where str = fromString $ symbolVal (Proxy :: Proxy sym) + in route (Proxy :: Proxy sublayout) (feedTo subserver mheader) + where str = fromString $ symbolVal (Proxy :: Proxy sym) -- | When implementing the handler for a 'Post' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' @@ -461,20 +539,19 @@ instance type ServerT (Post ctypes a) m = m a - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodPost = do - e <- runEitherT action - respond $ case e of - Right output -> do - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> failWith UnsupportedMediaType - Just (contentT, body) -> succeedWith $ - responseLBS status201 [ ("Content-Type" , cs contentT)] body - Left err -> succeedWith $ responseServantErr err - | pathIsEmpty request && requestMethod request /= methodPost = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPost = do + runAction action respond $ \ output -> do + let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status201 [ ("Content-Type" , cs contentT)] body + | pathIsEmpty request && requestMethod request /= methodPost = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound instance #if MIN_VERSION_base(4,8,0) @@ -484,15 +561,15 @@ instance type ServerT (Post ctypes ()) m = m () - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodPost = do - e <- runEitherT action - respond . succeedWith $ case e of - Right () -> responseLBS noContent204 [] "" - Left err -> responseServantErr err - | pathIsEmpty request && requestMethod request /= methodPost = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPost = do + runAction action respond $ \ () -> + succeedWith $ responseLBS noContent204 [] "" + | pathIsEmpty request && requestMethod request /= methodPost = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- Add response headers instance @@ -504,21 +581,20 @@ instance type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodPost = do - e <- runEitherT action - respond $ case e of - Right output -> do - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - headers = getHeaders output - case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of - Nothing -> failWith UnsupportedMediaType - Just (contentT, body) -> succeedWith $ - responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body - Left err -> succeedWith $ responseServantErr err - | pathIsEmpty request && requestMethod request /= methodPost = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPost = do + runAction action respond $ \ output -> do + let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + headers = getHeaders output + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body + | pathIsEmpty request && requestMethod request /= methodPost = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- | When implementing the handler for a 'Put' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' @@ -541,20 +617,19 @@ instance type ServerT (Put ctypes a) m = m a - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodPut = do - e <- runEitherT action - respond $ case e of - Right output -> do - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> failWith UnsupportedMediaType - Just (contentT, body) -> succeedWith $ - responseLBS status200 [ ("Content-Type" , cs contentT)] body - Left err -> succeedWith $ responseServantErr err - | pathIsEmpty request && requestMethod request /= methodPut = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPut = do + runAction action respond $ \ output -> do + let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status200 [ ("Content-Type" , cs contentT)] body + | pathIsEmpty request && requestMethod request /= methodPut = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound instance #if MIN_VERSION_base(4,8,0) @@ -564,15 +639,15 @@ instance type ServerT (Put ctypes ()) m = m () - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodPut = do - e <- runEitherT action - respond . succeedWith $ case e of - Right () -> responseLBS noContent204 [] "" - Left err -> responseServantErr err - | pathIsEmpty request && requestMethod request /= methodPut = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPut = do + runAction action respond $ \ () -> + succeedWith $ responseLBS noContent204 [] "" + | pathIsEmpty request && requestMethod request /= methodPut = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- Add response headers instance @@ -584,21 +659,20 @@ instance type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodPut = do - e <- runEitherT action - respond $ case e of - Right output -> do - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - headers = getHeaders output - case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of - Nothing -> failWith UnsupportedMediaType - Just (contentT, body) -> succeedWith $ - responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body - Left err -> succeedWith $ responseServantErr err - | pathIsEmpty request && requestMethod request /= methodPut = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPut = do + runAction action respond $ \ output -> do + let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + headers = getHeaders output + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body + | pathIsEmpty request && requestMethod request /= methodPut = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- | When implementing the handler for a 'Patch' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' @@ -619,20 +693,19 @@ instance type ServerT (Patch ctypes a) m = m a - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodPatch = do - e <- runEitherT action - respond $ case e of - Right output -> do - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> failWith UnsupportedMediaType - Just (contentT, body) -> succeedWith $ - responseLBS status200 [ ("Content-Type" , cs contentT)] body - Left err -> succeedWith $ responseServantErr err - | pathIsEmpty request && requestMethod request /= methodPatch = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPatch = do + runAction action respond $ \ output -> do + let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status200 [ ("Content-Type" , cs contentT)] body + | pathIsEmpty request && requestMethod request /= methodPatch = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound instance #if MIN_VERSION_base(4,8,0) @@ -642,15 +715,15 @@ instance type ServerT (Patch ctypes ()) m = m () - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodPatch = do - e <- runEitherT action - respond . succeedWith $ case e of - Right () -> responseLBS noContent204 [] "" - Left err -> responseServantErr err - | pathIsEmpty request && requestMethod request /= methodPatch = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPatch = do + runAction action respond $ \ () -> + succeedWith $ responseLBS noContent204 [] "" + | pathIsEmpty request && requestMethod request /= methodPatch = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- Add response headers instance @@ -662,21 +735,20 @@ instance type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) - route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodPatch = do - e <- runEitherT action - respond $ case e of - Right outpatch -> do - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - headers = getHeaders outpatch - case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of - Nothing -> failWith UnsupportedMediaType - Just (contentT, body) -> succeedWith $ - responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body - Left err -> succeedWith $ responseServantErr err - | pathIsEmpty request && requestMethod request /= methodPatch = - respond $ failWith WrongMethod - | otherwise = respond $ failWith NotFound + route Proxy action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == methodPatch = do + runAction action respond $ \ outpatch -> do + let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + headers = getHeaders outpatch + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body + | pathIsEmpty request && requestMethod request /= methodPatch = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -705,7 +777,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy subserver request respond = do + route Proxy subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of @@ -713,9 +785,7 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) Just Nothing -> Nothing -- param present with no value -> Nothing Just (Just v) -> fromText v -- if present, we try to convert to -- the right type - - route (Proxy :: Proxy sublayout) (subserver param) request respond - + in route (Proxy :: Proxy sublayout) (feedTo subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, @@ -743,16 +813,14 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m - route Proxy subserver request respond = do + route Proxy subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request -- if sym is "foo", we look for query string parameters -- named "foo" or "foo[]" and call fromText on the -- corresponding values parameters = filter looksLikeParam querytext values = catMaybes $ map (convert . snd) parameters - - route (Proxy :: Proxy sublayout) (subserver values) request respond - + in route (Proxy :: Proxy sublayout) (feedTo subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") convert Nothing = Nothing @@ -776,15 +844,13 @@ instance (KnownSymbol sym, HasServer sublayout) type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m - route Proxy subserver request respond = do + route Proxy subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of 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 - - route (Proxy :: Proxy sublayout) (subserver param) request respond - + in route (Proxy :: Proxy sublayout) (feedTo subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False @@ -819,16 +885,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) type ServerT (MatrixParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy subserver request respond = case parsePathInfo request of - (first : _) - -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first - param = case lookup paramname querytext of - Nothing -> Nothing -- param absent from the query string - Just Nothing -> Nothing -- param present with no value -> Nothing - Just (Just v) -> fromText v -- if present, we try to convert to - -- the right type - route (Proxy :: Proxy sublayout) (subserver param) request respond - _ -> route (Proxy :: Proxy sublayout) (subserver Nothing) request respond + route Proxy subserver = WithRequest $ \ request -> + case parsePathInfo request of + (first : _) + -> do let querytext = parseMatrixText . encodeUtf8 $ T.tail first + param = case lookup paramname querytext of + Nothing -> Nothing -- param absent from the query string + Just Nothing -> Nothing -- param present with no value -> Nothing + Just (Just v) -> fromText v -- if present, we try to convert to + -- the right type + route (Proxy :: Proxy sublayout) (feedTo subserver param) + _ -> route (Proxy :: Proxy sublayout) (feedTo subserver Nothing) where paramname = cs $ symbolVal (Proxy :: Proxy sym) @@ -857,16 +924,17 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout) type ServerT (MatrixParams sym a :> sublayout) m = [a] -> ServerT sublayout m - route Proxy subserver request respond = case parsePathInfo request of - (first : _) - -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first - -- if sym is "foo", we look for matrix parameters - -- named "foo" or "foo[]" and call fromText on the - -- corresponding values - parameters = filter looksLikeParam matrixtext - values = catMaybes $ map (convert . snd) parameters - route (Proxy :: Proxy sublayout) (subserver values) request respond - _ -> route (Proxy :: Proxy sublayout) (subserver []) request respond + route Proxy subserver = WithRequest $ \ request -> + case parsePathInfo request of + (first : _) + -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first + -- if sym is "foo", we look for matrix parameters + -- named "foo" or "foo[]" and call fromText on the + -- corresponding values + parameters = filter looksLikeParam matrixtext + values = catMaybes $ map (convert . snd) parameters + route (Proxy :: Proxy sublayout) (feedTo subserver values) + _ -> route (Proxy :: Proxy sublayout) (feedTo subserver []) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") @@ -891,17 +959,18 @@ instance (KnownSymbol sym, HasServer sublayout) type ServerT (MatrixFlag sym :> sublayout) m = Bool -> ServerT sublayout m - route Proxy subserver request respond = case parsePathInfo request of - (first : _) - -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first - param = case lookup paramname matrixtext of - 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 - - route (Proxy :: Proxy sublayout) (subserver param) request respond - - _ -> route (Proxy :: Proxy sublayout) (subserver False) request respond + route Proxy subserver = WithRequest $ \ request -> + case parsePathInfo request of + (first : _) + -> do let matrixtext = parseMatrixText . encodeUtf8 $ T.tail first + param = case lookup paramname matrixtext of + 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 + + route (Proxy :: Proxy sublayout) (feedTo subserver param) + + _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True @@ -919,8 +988,11 @@ instance HasServer Raw where type ServerT Raw m = Application - route Proxy rawApplication request respond = - rawApplication request (respond . succeedWith) + route Proxy rawApplication = LeafRouter $ \ request respond -> do + r <- rawApplication + case r of + RR (Left err) -> respond $ failWith err + RR (Right app) -> app request (respond . succeedWith) -- | If you use 'ReqBody' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -948,19 +1020,20 @@ instance ( AllCTUnrender list a, HasServer sublayout type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m - route Proxy subserver request respond = do - -- See HTTP RFC 2616, section 7.2.1 - -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 - -- See also "W3C Internet Media Type registration, consistency of use" - -- http://www.w3.org/2001/tag/2002/0129-mime - let contentTypeH = fromMaybe "application/octet-stream" - $ lookup hContentType $ requestHeaders request - mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) - <$> lazyRequestBody request - case mrqbody of - Nothing -> respond . failWith $ UnsupportedMediaType - Just (Left e) -> respond . failWith $ InvalidBody e - Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond + route Proxy subserver = WithRequest $ \ request -> + route (Proxy :: Proxy sublayout) $ do + -- See HTTP RFC 2616, section 7.2.1 + -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 + -- See also "W3C Internet Media Type registration, consistency of use" + -- http://www.w3.org/2001/tag/2002/0129-mime + let contentTypeH = fromMaybe "application/octet-stream" + $ lookup hContentType $ requestHeaders request + mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) + <$> lazyRequestBody request + case mrqbody of + Nothing -> return $ failWith $ UnsupportedMediaType + Just (Left e) -> return $ failWith $ InvalidBody e + Just (Right v) -> feedTo subserver v -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@. @@ -968,14 +1041,9 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout type ServerT (path :> sublayout) m = ServerT sublayout m - route Proxy subserver request respond = case processedPathInfo request of - (first : rest) - | first == cs (symbolVal proxyPath) - -> route (Proxy :: Proxy sublayout) subserver request{ - pathInfo = rest - } respond - _ -> respond $ failWith NotFound - + route Proxy subserver = StaticRouter $ + M.singleton (cs (symbolVal proxyPath)) + (route (Proxy :: Proxy sublayout) subserver) where proxyPath = Proxy :: Proxy path ct_wildcard :: B.ByteString