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) 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, -- | If you have a 'Delete' endpoint in your API,
-- the handler for this endpoint is meant to delete -- the handler for this endpoint is meant to delete
-- a resource. -- a resource.
@ -140,19 +190,7 @@ instance
type ServerT (Delete ctypes a) m = m a type ServerT (Delete ctypes a) m = m a
route Proxy action = LeafRouter route' route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
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 instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -162,15 +200,7 @@ instance
type ServerT (Delete ctypes ()) m = m () type ServerT (Delete ctypes ()) m = m ()
route Proxy action = LeafRouter route' route Proxy = methodRouterEmpty methodDelete
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 -- Add response headers
instance instance
@ -182,20 +212,7 @@ instance
type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v) type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
route Proxy action = LeafRouter route' route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
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, -- | When implementing the handler for a 'Get' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
@ -218,19 +235,7 @@ instance
type ServerT (Get ctypes a) m = m a type ServerT (Get ctypes a) m = m a
route Proxy action = LeafRouter route' route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
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 -- '()' ==> 204 No Content
instance instance
@ -241,15 +246,7 @@ instance
type ServerT (Get ctypes ()) m = m () type ServerT (Get ctypes ()) m = m ()
route Proxy action = LeafRouter route' route Proxy = methodRouterEmpty methodGet
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 -- Add response headers
instance instance
@ -261,20 +258,7 @@ instance
type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
route Proxy action = LeafRouter route' route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
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, -- | If you use 'Header' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -329,19 +313,7 @@ instance
type ServerT (Post ctypes a) m = m a type ServerT (Post ctypes a) m = m a
route Proxy action = LeafRouter route' route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
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 instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -351,15 +323,7 @@ instance
type ServerT (Post ctypes ()) m = m () type ServerT (Post ctypes ()) m = m ()
route Proxy action = LeafRouter route' route Proxy = methodRouterEmpty methodPost
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 -- Add response headers
instance instance
@ -371,20 +335,7 @@ instance
type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
route Proxy action = LeafRouter route' route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
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, -- | When implementing the handler for a 'Put' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
@ -407,19 +358,7 @@ instance
type ServerT (Put ctypes a) m = m a type ServerT (Put ctypes a) m = m a
route Proxy action = LeafRouter route' route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
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 instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -429,15 +368,7 @@ instance
type ServerT (Put ctypes ()) m = m () type ServerT (Put ctypes ()) m = m ()
route Proxy action = LeafRouter route' route Proxy = methodRouterEmpty methodPut
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 -- Add response headers
instance instance
@ -449,20 +380,7 @@ instance
type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
route Proxy action = LeafRouter route' route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
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, -- | When implementing the handler for a 'Patch' endpoint,
-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
@ -483,19 +401,7 @@ instance
type ServerT (Patch ctypes a) m = m a type ServerT (Patch ctypes a) m = m a
route Proxy action = LeafRouter route' route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
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 instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
@ -505,15 +411,7 @@ instance
type ServerT (Patch ctypes ()) m = m () type ServerT (Patch ctypes ()) m = m ()
route Proxy action = LeafRouter route' route Proxy = methodRouterEmpty methodPatch
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 -- Add response headers
instance instance
@ -525,20 +423,7 @@ instance
type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
route Proxy action = LeafRouter route' route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
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, -- | 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 -- 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 -- Note that the ordering of the constructors has great significance! It
-- determines the Ord instance and, consequently, the monoid instance. -- determines the Ord instance and, consequently, the monoid instance.
-- * Route mismatch
data RouteMismatch = data RouteMismatch =
NotFound -- ^ the usual "not found" error NotFound -- ^ the usual "not found" error
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error