From f9b1e7fc5020fc9c9f0928d2baca46719596b499 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Fri, 29 May 2015 17:16:36 +0200 Subject: [PATCH 1/5] 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 From 404bfdd89cc5d5949021341ad25d6126dcfdf39a Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Mon, 1 Jun 2015 10:24:09 +0200 Subject: [PATCH 2/5] Add test cases for the priority of error codes. Due to the delayed treatment of checks during the server interpretation, we now have the ability to produce "better" error codes for certain APIs. This change introduces test cases for some of these situations and their new, desired results. These tests would mostly fail with the old approach to routing. --- servant-server/test/Servant/ServerSpec.hs | 49 +++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 2689a4e2..ca604ae7 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -89,6 +89,7 @@ spec = do headerSpec rawSpec unionSpec + prioErrorsSpec errorsSpec responseHeadersSpec @@ -572,6 +573,54 @@ responseHeadersSpec = describe "ResponseHeaders" $ do Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 415 +type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer + +prioErrorsApi :: Proxy PrioErrorsApi +prioErrorsApi = Proxy + +-- | Test the relative priority of error responses from the server. +-- +-- In particular, we check whether matching continues even if a 'ReqBody' +-- or similar construct is encountered early in a path. We don't want to +-- see a complaint about the request body unless the path actually matches. +-- +prioErrorsSpec :: Spec +prioErrorsSpec = describe "PrioErrors" $ do + let server = return . age + with (return $ serve prioErrorsApi server) $ do + let check (mdescr, method) path (cdescr, ctype, body) resp = + it fulldescr $ + Test.Hspec.Wai.request method path [(hContentType, ctype)] body + `shouldRespondWith` resp + where + fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr + ++ " " ++ cs path ++ " (" ++ cdescr ++ ")" + + get' = ("GET", methodGet) + put' = ("PUT", methodPut) + + txt = ("text" , "text/plain;charset=utf8" , "42" ) + ijson = ("invalid json", "application/json;charset=utf8", "invalid" ) + vjson = ("valid json" , "application/json;charset=utf8", encode alice) + + check get' "/" txt 404 + check get' "/bar" txt 404 + check get' "/foo" txt 415 + check put' "/" txt 404 + check put' "/bar" txt 404 + check put' "/foo" txt 405 + check get' "/" ijson 404 + check get' "/bar" ijson 404 + check get' "/foo" ijson 400 + check put' "/" ijson 404 + check put' "/bar" ijson 404 + check put' "/foo" ijson 405 + check get' "/" vjson 404 + check get' "/bar" vjson 404 + check get' "/foo" vjson 200 + check put' "/" vjson 404 + check put' "/bar" vjson 404 + check put' "/foo" vjson 405 -- | Test server error functionality. errorsSpec :: Spec From e83397a1db504ee4195ee3f951c27588108e335d Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Mon, 1 Jun 2015 15:30:09 +0200 Subject: [PATCH 3/5] Fix the auth combinator example. This change adapt the auth combinator example to the new router code. In general, the server interpretation of user-written combinators will be affected by the new routing code. The change here also introduces a change in functionality: previously, wrong authentication triggered a "hard failure", whereas we now trigger a "soft failure", which is recoverable. For the simple example, this does not make a lot of difference. In general, I think having a soft failure is the right option to take here, although we want a more general story about the relative priorities of different error codes. --- .../auth-combinator/auth-combinator.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index c6373fe1..d1a11439 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -28,14 +28,15 @@ data AuthProtected instance HasServer rest => HasServer (AuthProtected :> rest) where type ServerT (AuthProtected :> rest) m = ServerT rest m - route Proxy a request respond = - case lookup "Cookie" (requestHeaders request) of - Nothing -> respond . succeedWith $ responseLBS status401 [] "Missing auth header." - Just v -> do - authGranted <- isGoodCookie v - if authGranted - then route (Proxy :: Proxy rest) a request respond - else respond . succeedWith $ responseLBS status403 [] "Invalid cookie." + route Proxy a = WithRequest $ \ request -> + route (Proxy :: Proxy rest) $ do + case lookup "Cookie" (requestHeaders request) of + Nothing -> return $ failWith $ HttpError status401 (Just "Missing auth header.") + Just v -> do + authGranted <- isGoodCookie v + if authGranted + then a + else return $ failWith $ HttpError status403 (Just "Invalid cookie.") type PrivateAPI = Get '[JSON] [PrivateData] From eb86a821059d9f6827972afe5155614b411d5138 Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Mon, 1 Jun 2015 19:38:51 +0200 Subject: [PATCH 4/5] Refactoring: one module per concept. The main `Server.Internal` module was getting a bit large for my taste. It now contains just the instances. All the administrative utilities are in their own dedicated modules. --- servant-server/servant-server.cabal | 5 +- servant-server/src/Servant/Server.hs | 1 - servant-server/src/Servant/Server/Internal.hs | 240 ++---------------- .../src/Servant/Server/Internal/PathInfo.hs | 38 +++ .../src/Servant/Server/Internal/Router.hs | 72 ++++++ .../Server/Internal/RoutingApplication.hs | 145 +++++++++++ servant-server/test/Servant/ServerSpec.hs | 3 +- 7 files changed, 276 insertions(+), 228 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/PathInfo.hs create mode 100644 servant-server/src/Servant/Server/Internal/Router.hs create mode 100644 servant-server/src/Servant/Server/Internal/RoutingApplication.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index bfb12f9b..00e5193f 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -35,8 +35,11 @@ library Servant Servant.Server Servant.Server.Internal - Servant.Server.Internal.ServantErr Servant.Server.Internal.Enter + Servant.Server.Internal.PathInfo + Servant.Server.Internal.Router + Servant.Server.Internal.RoutingApplication + Servant.Server.Internal.ServantErr Servant.Utils.StaticFiles build-depends: base >= 4.7 && < 5 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 8f60583a..fcf02f1a 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -81,7 +81,6 @@ import Data.Proxy (Proxy) import Network.Wai (Application) import Servant.Server.Internal import Servant.Server.Internal.Enter -import Servant.Server.Internal.ServantErr -- * Implementing Servers diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 069aab78..5d0f4025 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -12,17 +12,19 @@ {-# LANGUAGE OverlappingInstances #-} #endif -module Servant.Server.Internal where +module Servant.Server.Internal + ( module Servant.Server.Internal + , module Servant.Server.Internal.PathInfo + , module Servant.Server.Internal.Router + , module Servant.Server.Internal.RoutingApplication + , module Servant.Server.Internal.ServantErr + ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative, (<$>)) -import Data.Monoid (Monoid, mappend, mempty) +import Control.Applicative ((<$>)) #endif -import Control.Monad.Trans.Either (EitherT, runEitherT) +import Control.Monad.Trans.Either (EitherT) 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) @@ -33,12 +35,9 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Typeable import GHC.TypeLits (KnownSymbol, symbolVal) import Network.HTTP.Types hiding (Header, ResponseHeaders) -import Network.Wai (Application, Request, Response, - ResponseReceived, lazyRequestBody, - pathInfo, rawQueryString, - requestBody, requestHeaders, - requestMethod, responseLBS, - strictRequestBody) +import Network.Wai (Application, lazyRequestBody, + rawQueryString, requestHeaders, + requestMethod, responseLBS) import Servant.API ((:<|>) (..), (:>), Capture, Delete, Get, Header, MatrixFlag, MatrixParam, MatrixParams, @@ -52,220 +51,11 @@ import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders, getHeaders) import Servant.Common.Text (FromText, fromText) +import Servant.Server.Internal.PathInfo +import Servant.Server.Internal.Router +import Servant.Server.Internal.RoutingApplication 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 - - -toApplication :: RoutingApplication -> Application -toApplication ra request respond = do - reqBodyRef <- newIORef Uncalled - -- We may need to consume the requestBody more than once. In order to - -- maintain the illusion that 'requestBody' works as expected, - -- 'ReqBodyState' is introduced, and the complete body is memoized and - -- returned as many times as requested with empty "Done" marker chunks in - -- between. - -- See https://github.com/haskell-servant/servant/issues/3 - let memoReqBody = do - ior <- readIORef reqBodyRef - case ior of - Uncalled -> do - r <- BL.toStrict <$> strictRequestBody request - writeIORef reqBodyRef $ Done r - return r - Called bs -> do - writeIORef reqBodyRef $ Done bs - return bs - Done bs -> do - writeIORef reqBodyRef $ Called bs - return B.empty - - ra request{ requestBody = memoReqBody } (routingRespond . routeResult) - where - routingRespond :: Either RouteMismatch Response -> IO ResponseReceived - routingRespond (Left NotFound) = - respond $ responseLBS notFound404 [] "not found" - routingRespond (Left WrongMethod) = - respond $ responseLBS methodNotAllowed405 [] "method not allowed" - routingRespond (Left (InvalidBody err)) = - respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err - routingRespond (Left UnsupportedMediaType) = - respond $ responseLBS unsupportedMediaType415 [] "unsupported media type" - routingRespond (Left (HttpError status body)) = - respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body - routingRespond (Right response) = - respond response - --- Note that the ordering of the constructors has great significance! It --- determines the Ord instance and, consequently, the monoid instance. --- * Route mismatch -data RouteMismatch = - NotFound -- ^ the usual "not found" error - | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error - | UnsupportedMediaType -- ^ request body has unsupported media type - | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error - | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error. - deriving (Eq, Ord, Show) - -instance Monoid RouteMismatch where - mempty = NotFound - -- The following isn't great, since it picks @InvalidBody@ based on - -- alphabetical ordering, but any choice would be arbitrary. - -- - -- "As one judge said to the other, 'Be just and if you can't be just, be - -- arbitrary'" -- William Burroughs - mappend = max - - --- | A wrapper around @'Either' 'RouteMismatch' a@. -newtype RouteResult a = - RR { routeResult :: Either RouteMismatch a } - 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 - -succeedWith :: a -> RouteResult a -succeedWith = RR . Right - -isMismatch :: RouteResult a -> Bool -isMismatch (RR (Left _)) = True -isMismatch _ = False - --- | Like `null . pathInfo`, but works with redundant trailing slashes. -pathIsEmpty :: Request -> Bool -pathIsEmpty = f . processedPathInfo - where - f [] = True - f [""] = True - f _ = False - --- | If we get a `Right`, it has precedence over everything else. --- --- This in particular means that if we could get several 'Right's, --- only the first we encounter would be taken into account. -instance Monoid (RouteResult a) where - mempty = RR $ Left mempty - - RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y) - RR (Left _) `mappend` RR (Right y) = RR $ Right y - r `mappend` _ = r - -type RoutingApplication = - Request -- ^ the request, the field 'pathInfo' may be modified by url routing - -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived - -splitMatrixParameters :: Text -> (Text, Text) -splitMatrixParameters = T.break (== ';') - -parsePathInfo :: Request -> [Text] -parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo - where mergePairs = concat . unfoldr pairToList - pairToList [] = Nothing - pairToList ((a, b):xs) = Just ([a, b], xs) - --- | Returns a processed pathInfo from the request. --- --- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be --- processed, so routing works as intended. Therefor this function should be used to access --- the pathInfo for routing purposes. -processedPathInfo :: Request -> [Text] -processedPathInfo r = - case pinfo of - (x:xs) | T.head x == ';' -> xs - _ -> pinfo - where pinfo = parsePathInfo r - class HasServer layout where type ServerT layout (m :: * -> *) :: * diff --git a/servant-server/src/Servant/Server/Internal/PathInfo.hs b/servant-server/src/Servant/Server/Internal/PathInfo.hs new file mode 100644 index 00000000..0138f72e --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/PathInfo.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} +module Servant.Server.Internal.PathInfo where + +import Data.List (unfoldr) +import Data.Text (Text) +import qualified Data.Text as T +import Network.Wai (Request, pathInfo) + +-- | Like `null . pathInfo`, but works with redundant trailing slashes. +pathIsEmpty :: Request -> Bool +pathIsEmpty = f . processedPathInfo + where + f [] = True + f [""] = True + f _ = False + + +splitMatrixParameters :: Text -> (Text, Text) +splitMatrixParameters = T.break (== ';') + +parsePathInfo :: Request -> [Text] +parsePathInfo = filter (/= "") . mergePairs . map splitMatrixParameters . pathInfo + where mergePairs = concat . unfoldr pairToList + pairToList [] = Nothing + pairToList ((a, b):xs) = Just ([a, b], xs) + +-- | Returns a processed pathInfo from the request. +-- +-- In order to handle matrix parameters in the request correctly, the raw pathInfo needs to be +-- processed, so routing works as intended. Therefor this function should be used to access +-- the pathInfo for routing purposes. +processedPathInfo :: Request -> [Text] +processedPathInfo r = + case pinfo of + (x:xs) | T.head x == ';' -> xs + _ -> pinfo + where pinfo = parsePathInfo r + diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs new file mode 100644 index 00000000..2e0188e4 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -0,0 +1,72 @@ +module Servant.Server.Internal.Router where + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import Network.Wai (Request, pathInfo) +import Servant.Server.Internal.PathInfo +import Servant.Server.Internal.RoutingApplication + +-- | Internal representation of a router. +data Router = + WithRequest (Request -> Router) + -- ^ current request is passed to the router + | StaticRouter (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 + diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs new file mode 100644 index 00000000..2f2355fe --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Server.Internal.RoutingApplication where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative, (<$>)) +import Data.Monoid (Monoid, mappend, mempty) +#endif +import Control.Monad.Trans.Either (EitherT, runEitherT) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.String (fromString) +import Network.HTTP.Types hiding (Header, ResponseHeaders) +import Network.Wai (Application, Request, Response, + ResponseReceived, + requestBody, + responseLBS, + strictRequestBody) +import Servant.API ((:<|>) (..)) +import Servant.Server.Internal.ServantErr + +type RoutingApplication = + Request -- ^ the request, the field 'pathInfo' may be modified by url routing + -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived + +-- | A wrapper around @'Either' 'RouteMismatch' a@. +newtype RouteResult a = + RR { routeResult :: Either RouteMismatch a } + deriving (Eq, Show, Functor, Applicative) + +-- | If we get a `Right`, it has precedence over everything else. +-- +-- This in particular means that if we could get several 'Right's, +-- only the first we encounter would be taken into account. +instance Monoid (RouteResult a) where + mempty = RR $ Left mempty + + RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y) + RR (Left _) `mappend` RR (Right y) = RR $ Right y + r `mappend` _ = r + +-- Note that the ordering of the constructors has great significance! It +-- determines the Ord instance and, consequently, the monoid instance. +-- * Route mismatch +data RouteMismatch = + NotFound -- ^ the usual "not found" error + | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error + | UnsupportedMediaType -- ^ request body has unsupported media type + | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error + | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error. + deriving (Eq, Ord, Show) + +instance Monoid RouteMismatch where + mempty = NotFound + -- The following isn't great, since it picks @InvalidBody@ based on + -- alphabetical ordering, but any choice would be arbitrary. + -- + -- "As one judge said to the other, 'Be just and if you can't be just, be + -- arbitrary'" -- William Burroughs + mappend = max + +data ReqBodyState = Uncalled + | Called !B.ByteString + | Done !B.ByteString + +toApplication :: RoutingApplication -> Application +toApplication ra request respond = do + reqBodyRef <- newIORef Uncalled + -- We may need to consume the requestBody more than once. In order to + -- maintain the illusion that 'requestBody' works as expected, + -- 'ReqBodyState' is introduced, and the complete body is memoized and + -- returned as many times as requested with empty "Done" marker chunks in + -- between. + -- See https://github.com/haskell-servant/servant/issues/3 + let memoReqBody = do + ior <- readIORef reqBodyRef + case ior of + Uncalled -> do + r <- BL.toStrict <$> strictRequestBody request + writeIORef reqBodyRef $ Done r + return r + Called bs -> do + writeIORef reqBodyRef $ Done bs + return bs + Done bs -> do + writeIORef reqBodyRef $ Called bs + return B.empty + + ra request{ requestBody = memoReqBody } (routingRespond . routeResult) + where + routingRespond :: Either RouteMismatch Response -> IO ResponseReceived + routingRespond (Left NotFound) = + respond $ responseLBS notFound404 [] "not found" + routingRespond (Left WrongMethod) = + respond $ responseLBS methodNotAllowed405 [] "method not allowed" + routingRespond (Left (InvalidBody err)) = + respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err + routingRespond (Left UnsupportedMediaType) = + respond $ responseLBS unsupportedMediaType415 [] "unsupported media type" + routingRespond (Left (HttpError status body)) = + respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body + routingRespond (Right response) = + respond response + +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 + +succeedWith :: a -> RouteResult a +succeedWith = RR . Right + +isMismatch :: RouteResult a -> Bool +isMismatch (RR (Left _)) = True +isMismatch _ = False + diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index ca604ae7..00087d93 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -42,7 +42,8 @@ import Servant.API ((:<|>) (..), (:>), Post, Put, QueryFlag, QueryParam, QueryParams, Raw, ReqBody) import Servant.Server (Server, serve, ServantErr(..), err404) -import Servant.Server.Internal (RouteMismatch (..)) +import Servant.Server.Internal.RoutingApplication + (RouteMismatch (..)) -- * test data types From 31b12d4bf468b9fd46f5c4b797f8ef11d0894aba Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Mon, 1 Jun 2015 21:12:12 +0200 Subject: [PATCH 5/5] Refactoring: abstracting common parts of method handlers. This change makes an attempt of abstracting out some of the common functionality found in the handlers for the different request methods. There's still a bit of code duplication between the cases for headers and no headers and empty responses. But it's a significant relative improvement already. --- servant-server/src/Servant/Server/Internal.hs | 245 +++++------------- .../Server/Internal/RoutingApplication.hs | 1 - 2 files changed, 65 insertions(+), 181 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 5d0f4025..02c729f3 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -120,6 +120,56 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout) where captureProxy = Proxy :: Proxy (Capture capture a) +methodRouter :: (AllCTRender ctypes a) + => Method -> Proxy ctypes -> Status + -> IO (RouteResult (EitherT ServantErr IO a)) + -> Router +methodRouter method proxy status action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == method = do + runAction action respond $ \ output -> do + let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + case handleAcceptH proxy (AcceptHeader accH) output of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status [ ("Content-Type" , cs contentT)] body + | pathIsEmpty request && requestMethod request /= method = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + +methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) + => Method -> Proxy ctypes -> Status + -> IO (RouteResult (EitherT ServantErr IO (Headers h v))) + -> Router +methodRouterHeaders method proxy status action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == method = do + runAction action respond $ \ output -> do + let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + headers = getHeaders output + case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status ( ("Content-Type" , cs contentT) : headers) body + | pathIsEmpty request && requestMethod request /= method = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + +methodRouterEmpty :: Method + -> IO (RouteResult (EitherT ServantErr IO ())) + -> Router +methodRouterEmpty method action = LeafRouter route' + where + route' request respond + | pathIsEmpty request && requestMethod request == method = do + runAction action respond $ \ () -> + succeedWith $ responseLBS noContent204 [] "" + | pathIsEmpty request && requestMethod request /= method = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + -- | If you have a 'Delete' endpoint in your API, -- the handler for this endpoint is meant to delete -- a resource. @@ -140,19 +190,7 @@ instance type ServerT (Delete ctypes a) m = m a - 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 + route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200 instance #if MIN_VERSION_base(4,8,0) @@ -162,15 +200,7 @@ instance type ServerT (Delete ctypes ()) m = m () - 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 + route Proxy = methodRouterEmpty methodDelete -- Add response headers instance @@ -182,20 +212,7 @@ instance type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v) - 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 + route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200 -- | When implementing the handler for a 'Get' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' @@ -218,19 +235,7 @@ instance type ServerT (Get ctypes a) m = m a - 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 + route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200 -- '()' ==> 204 No Content instance @@ -241,15 +246,7 @@ instance type ServerT (Get ctypes ()) m = m () - 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 + route Proxy = methodRouterEmpty methodGet -- Add response headers instance @@ -261,20 +258,7 @@ instance type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) - 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 + route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200 -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -329,19 +313,7 @@ instance type ServerT (Post ctypes a) m = m a - 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 + route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201 instance #if MIN_VERSION_base(4,8,0) @@ -351,15 +323,7 @@ instance type ServerT (Post ctypes ()) m = m () - 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 + route Proxy = methodRouterEmpty methodPost -- Add response headers instance @@ -371,20 +335,7 @@ instance type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) - 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 + route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201 -- | When implementing the handler for a 'Put' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' @@ -407,19 +358,7 @@ instance type ServerT (Put ctypes a) m = m a - 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 + route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200 instance #if MIN_VERSION_base(4,8,0) @@ -429,15 +368,7 @@ instance type ServerT (Put ctypes ()) m = m () - 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 + route Proxy = methodRouterEmpty methodPut -- Add response headers instance @@ -449,20 +380,7 @@ instance type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) - 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 + route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200 -- | When implementing the handler for a 'Patch' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' @@ -483,19 +401,7 @@ instance type ServerT (Patch ctypes a) m = m a - 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 + route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200 instance #if MIN_VERSION_base(4,8,0) @@ -505,15 +411,7 @@ instance type ServerT (Patch ctypes ()) m = m () - 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 + route Proxy = methodRouterEmpty methodPatch -- Add response headers instance @@ -525,20 +423,7 @@ instance type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) - 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 + route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200 -- | 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 diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 2f2355fe..415fff2b 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -46,7 +46,6 @@ instance Monoid (RouteResult a) where -- Note that the ordering of the constructors has great significance! It -- determines the Ord instance and, consequently, the monoid instance. --- * Route mismatch data RouteMismatch = NotFound -- ^ the usual "not found" error | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error