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.
This commit is contained in:
parent
0b3291970f
commit
f9b1e7fc50
3 changed files with 348 additions and 279 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue