eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Refactoring: abstracting common parts of method handlers.

Browse source 
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.
This commit is contained in:
Andres Loeh 2015-06-01 21:12:12 +02:00
parent eb86a82105
commit 31b12d4bf4
2 changed files with 65 additions and 181 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

245
servant-server/src/Servant/Server/Internal.hs
View file

@ -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

1
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file

@ -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