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.
2015-06-01 21:12:12 +02:00 · 2015-06-01 21:12:12 +02:00 · 31b12d4bf4
commit 31b12d4bf4
parent eb86a82105
2 changed files with 65 additions and 181 deletions
--- 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
--- 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