From 31b12d4bf468b9fd46f5c4b797f8ef11d0894aba Mon Sep 17 00:00:00 2001 From: Andres Loeh Date: Mon, 1 Jun 2015 21:12:12 +0200 Subject: [PATCH] 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