diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,27 @@ +0.7 +--- + +* The `Router` type has been changed. Static router tables should now + be properly shared between requests, drastically increasing the + number of situations where servers will be able to route requests + efficiently. Functions `layout` and `layoutWithContext` have been + added to visualize the router layout for debugging purposes. Test + cases for expected router layouts have been added. +* If an endpoint is discovered to have a non-matching "accept header", + this is now a recoverable rather than a fatal failure, allowing + different endpoints for the same route, but with different content + types to be specified modularly. +* Export `throwError` from module `Servant` +* Add `Handler` type synonym + +0.6.1 +----- + +* If servers use the `BasicAuth` combinator and receive requests with missing or + invalid credentials, the resulting error responses (401 and 403) could be + overwritten by subsequent alternative routes. Now `BasicAuth` uses `FailFatal` + and the error responses can't be overwritten anymore. + 0.6 --- diff --git a/example/greet.hs b/example/greet.hs --- a/example/greet.hs +++ b/example/greet.hs @@ -44,7 +44,7 @@ -- There's one handler per endpoint, which, just like in the type -- that represents the API, are glued together using :<|>. -- --- Each handler runs in the 'ExceptT ServantErr IO' monad. +-- Each handler runs in the 'Handler' monad. server :: Server TestApi server = helloH :<|> postGreetH :<|> deleteGreetH diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.6.1 +version: 0.7 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them @@ -60,13 +60,13 @@ , mmorph >= 1 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 - , servant == 0.6.* + , servant == 0.7.* , split >= 0.2 && < 0.3 , string-conversions >= 0.3 && < 0.5 , system-filepath >= 0.4 && < 0.5 , filepath >= 1 , text >= 1.2 && < 1.3 - , transformers >= 0.3 && < 0.5 + , transformers >= 0.3 && < 0.6 , transformers-compat>= 0.4 , wai >= 3.0 && < 3.3 , wai-app-static >= 3.0 && < 3.2 diff --git a/src/Servant.hs b/src/Servant.hs --- a/src/Servant.hs +++ b/src/Servant.hs @@ -10,8 +10,10 @@ module Servant.Utils.StaticFiles, -- | Useful re-exports Proxy(..), + throwError ) where +import Control.Monad.Error.Class (throwError) import Data.Proxy import Servant.API import Servant.Server diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -17,7 +17,12 @@ , -- * Handlers for all standard combinators HasServer(..) , Server + , Handler + -- * Debugging the server layout + , layout + , layoutWithContext + -- * Enter -- $enterDoc @@ -93,6 +98,7 @@ ) where import Data.Proxy (Proxy) +import Data.Text (Text) import Network.Wai (Application) import Servant.Server.Internal import Servant.Server.Internal.Enter @@ -126,11 +132,68 @@ serveWithContext :: (HasServer layout context) => Proxy layout -> Context context -> Server layout -> Application -serveWithContext p context server = toApplication (runRouter (route p context d)) - where - d = Delayed r r r r (\ _ _ _ -> Route server) - r = return (Route ()) +serveWithContext p context server = + toApplication (runRouter (route p context (emptyDelayed (Route server)))) +-- | The function 'layout' produces a textual description of the internal +-- router layout for debugging purposes. Note that the router layout is +-- determined just by the API, not by the handlers. +-- +-- Example: +-- +-- For the following API +-- +-- > type API = +-- > "a" :> "d" :> Get '[JSON] () +-- > :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool +-- > :<|> "c" :> Put '[JSON] Bool +-- > :<|> "a" :> "e" :> Get '[JSON] Int +-- > :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool +-- > :<|> Raw +-- +-- we get the following output: +-- +-- > / +-- > ├─ a/ +-- > │ ├─ d/ +-- > │ │ └─• +-- > │ └─ e/ +-- > │ └─• +-- > ├─ b/ +-- > │ └─ / +-- > │ ├─• +-- > │ ┆ +-- > │ └─• +-- > ├─ c/ +-- > │ └─• +-- > ┆ +-- > └─ +-- +-- Explanation of symbols: +-- +-- [@├@] Normal lines reflect static branching via a table. +-- +-- [@a/@] Nodes reflect static path components. +-- +-- [@─•@] Leaves reflect endpoints. +-- +-- [@\/@] This is a delayed capture of a path component. +-- +-- [@\@] This is a part of the API we do not know anything about. +-- +-- [@┆@] Dashed lines suggest a dynamic choice between the part above +-- and below. If there is a success for fatal failure in the first part, +-- that one takes precedence. If both parts fail, the \"better\" error +-- code will be returned. +-- +layout :: (HasServer layout '[]) => Proxy layout -> Text +layout p = layoutWithContext p EmptyContext + +-- | Variant of 'layout' that takes an additional 'Context'. +layoutWithContext :: (HasServer layout context) + => Proxy layout -> Context context -> Text +layoutWithContext p context = + routerLayout (route p context (emptyDelayed (FailFatal err501))) -- Documentation diff --git a/src/Servant/Server/Experimental/Auth.hs b/src/Servant/Server/Experimental/Auth.hs --- a/src/Servant/Server/Experimental/Auth.hs +++ b/src/Servant/Server/Experimental/Auth.hs @@ -12,8 +12,8 @@ module Servant.Server.Experimental.Auth where -import Control.Monad.Trans.Except (ExceptT, - runExceptT) +import Control.Monad.Trans (liftIO) +import Control.Monad.Trans.Except (runExceptT) import Data.Proxy (Proxy (Proxy)) import Data.Typeable (Typeable) import GHC.Generics (Generic) @@ -25,10 +25,11 @@ HasServer, ServerT, getContextEntry, route) -import Servant.Server.Internal.Router (Router' (WithRequest)) -import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route), - addAuthCheck) -import Servant.Server.Internal.ServantErr (ServantErr) +import Servant.Server.Internal.RoutingApplication (addAuthCheck, + delayedFailFatal, + DelayedIO, + withRequest) +import Servant.Server.Internal.ServantErr (Handler) -- * General Auth @@ -42,11 +43,11 @@ -- -- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE newtype AuthHandler r usr = AuthHandler - { unAuthHandler :: r -> ExceptT ServantErr IO usr } + { unAuthHandler :: r -> Handler usr } deriving (Generic, Typeable) -- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE -mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr +mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr mkAuthHandler = AuthHandler -- | Known orphan instance. @@ -58,9 +59,10 @@ type ServerT (AuthProtect tag :> api) m = AuthServerData (AuthProtect tag) -> ServerT api m - route Proxy context subserver = WithRequest $ \ request -> - route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) + route Proxy context subserver = + route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck) where + authHandler :: Request -> Handler (AuthServerData (AuthProtect tag)) authHandler = unAuthHandler (getContextEntry context) - authCheck = fmap (either FailFatal Route) . runExceptT . authHandler - + authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag)) + authCheck = (>>= either delayedFailFatal return) . liftIO . runExceptT . authHandler diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -22,15 +22,13 @@ , module Servant.Server.Internal.ServantErr ) where -import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans (liftIO) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL -import qualified Data.Map as M import Data.Maybe (fromMaybe, mapMaybe) import Data.String (fromString) import Data.String.Conversions (cs, (<>)) -import Data.Text (Text) import Data.Typeable import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) @@ -38,7 +36,7 @@ import Network.Socket (SockAddr) import Network.Wai (Application, Request, Response, httpVersion, isSecure, - lazyRequestBody, pathInfo, + lazyRequestBody, rawQueryString, remoteHost, requestHeaders, requestMethod, responseLBS, vault) @@ -73,9 +71,13 @@ class HasServer layout context where type ServerT layout (m :: * -> *) :: * - route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router + route :: + Proxy layout + -> Context context + -> Delayed env (Server layout) + -> Router env -type Server layout = ServerT layout (ExceptT ServantErr IO) +type Server layout = ServerT layout Handler -- * Instances @@ -95,7 +97,7 @@ type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server)) - (route pb context ((\ (_ :<|> b) -> b) <$> server)) + (route pb context ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b @@ -114,7 +116,7 @@ -- > -- > server :: Server MyApi -- > server = getBook --- > where getBook :: Text -> ExceptT ServantErr IO Book +-- > where getBook :: Text -> Handler Book -- > getBook isbn = ... instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) => HasServer (Capture capture a :> sublayout) context where @@ -123,12 +125,12 @@ a -> ServerT sublayout m route Proxy context d = - DynamicRouter $ \ first -> + CaptureRouter $ route (Proxy :: Proxy sublayout) context - (addCapture d $ case parseUrlPieceMaybe first :: Maybe a of - Nothing -> return $ Fail err400 - Just v -> return $ Route v + (addCapture d $ \ txt -> case parseUrlPieceMaybe txt :: Maybe a of + Nothing -> delayedFail err400 + Just v -> return v ) allowedMethodHead :: Method -> Request -> Bool @@ -147,48 +149,51 @@ bdy = if allowedMethodHead method request then "" else body hdrs = (hContentType, cs contentT) : (fromMaybe [] headers) -methodCheck :: Method -> Request -> IO (RouteResult ()) +methodCheck :: Method -> Request -> DelayedIO () methodCheck method request - | allowedMethod method request = return $ Route () - | otherwise = return $ Fail err405 + | allowedMethod method request = return () + | otherwise = delayedFail err405 -acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ()) +-- This has switched between using 'Fail' and 'FailFatal' a number of +-- times. If the 'acceptCheck' is run after the body check (which would +-- be morally right), then we have to set this to 'FailFatal', because +-- the body check is not reversible, and therefore backtracking after the +-- body check is no longer an option. However, we now run the accept +-- check before the body check and can therefore afford to make it +-- recoverable. +acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO () acceptCheck proxy accH - | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route () - | otherwise = return $ FailFatal err406 + | canHandleAcceptH proxy (AcceptHeader accH) = return () + | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status - -> Delayed (ExceptT ServantErr IO a) - -> Router -methodRouter method proxy status action = LeafRouter route' + -> Delayed env (Handler a) + -> Router env +methodRouter method proxy status action = leafRouter route' where - route' request respond - | pathIsEmpty request = + route' env request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH - ) respond $ \ output -> do + ) env request respond $ \ output -> do let handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request - | otherwise = respond $ Fail err404 methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) => Method -> Proxy ctypes -> Status - -> Delayed (ExceptT ServantErr IO (Headers h v)) - -> Router -methodRouterHeaders method proxy status action = LeafRouter route' + -> Delayed env (Handler (Headers h v)) + -> Router env +methodRouterHeaders method proxy status action = leafRouter route' where - route' request respond - | pathIsEmpty request = + route' env request respond = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH - ) respond $ \ output -> do + ) env request respond $ \ output -> do let headers = getHeaders output handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just headers) request - | otherwise = respond $ Fail err404 instance OVERLAPPABLE_ ( AllCTRender ctypes a, ReflectMethod method, KnownNat status @@ -229,7 +234,7 @@ -- > -- > server :: Server MyApi -- > server = viewReferer --- > where viewReferer :: Referer -> ExceptT ServantErr IO referer +-- > where viewReferer :: Referer -> Handler referer -- > viewReferer referer = return referer instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) => HasServer (Header sym a :> sublayout) context where @@ -237,8 +242,8 @@ type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request -> - let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) + route Proxy context subserver = + let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req) in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) @@ -260,7 +265,7 @@ -- > -- > server :: Server MyApi -- > server = getBooksBy --- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book] +-- > where getBooksBy :: Maybe Text -> Handler [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) @@ -269,10 +274,10 @@ type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request -> - let querytext = parseQueryText $ rawQueryString request - param = - case lookup paramname querytext of + route Proxy context subserver = + let querytext r = parseQueryText $ rawQueryString r + param r = + case lookup paramname (querytext r) of Nothing -> Nothing -- param absent from the query string Just Nothing -> Nothing -- param present with no value -> Nothing Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to @@ -297,7 +302,7 @@ -- > -- > server :: Server MyApi -- > server = getBooksBy --- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book] +-- > where getBooksBy :: [Text] -> Handler [Book] -- > getBooksBy authors = ...return all books by these authors... instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) => HasServer (QueryParams sym a :> sublayout) context where @@ -305,13 +310,13 @@ type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request -> - let querytext = parseQueryText $ rawQueryString request + route Proxy context subserver = + let querytext r = parseQueryText $ rawQueryString r -- if sym is "foo", we look for query string parameters -- named "foo" or "foo[]" and call parseQueryParam on the -- corresponding values - parameters = filter looksLikeParam querytext - values = mapMaybe (convert . snd) parameters + parameters r = filter looksLikeParam (querytext r) + values r = mapMaybe (convert . snd) (parameters r) in route (Proxy :: Proxy sublayout) context (passToServer subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") @@ -328,7 +333,7 @@ -- > -- > server :: Server MyApi -- > server = getBooks --- > where getBooks :: Bool -> ExceptT ServantErr IO [Book] +-- > where getBooks :: Bool -> Handler [Book] -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... instance (KnownSymbol sym, HasServer sublayout context) => HasServer (QueryFlag sym :> sublayout) context where @@ -336,9 +341,9 @@ type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request -> - let querytext = parseQueryText $ rawQueryString request - param = case lookup paramname querytext of + route Proxy context subserver = + let querytext r = parseQueryText $ rawQueryString r + param r = case lookup paramname (querytext r) 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 @@ -359,8 +364,8 @@ type ServerT Raw m = Application - route Proxy _ rawApplication = LeafRouter $ \ request respond -> do - r <- runDelayed rawApplication + route Proxy _ rawApplication = RawRouter $ \ env request respond -> do + r <- runDelayed rawApplication env request case r of Route app -> app request (respond . Route) Fail a -> respond $ Fail a @@ -385,7 +390,7 @@ -- > -- > server :: Server MyApi -- > server = postBook --- > where postBook :: Book -> ExceptT ServantErr IO Book +-- > where postBook :: Book -> Handler Book -- > postBook book = ...insert into your db... instance ( AllCTUnrender list a, HasServer sublayout context ) => HasServer (ReqBody list a :> sublayout) context where @@ -393,10 +398,10 @@ type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m - route Proxy context subserver = WithRequest $ \ request -> - route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request)) + route Proxy context subserver = + route (Proxy :: Proxy sublayout) context (addBodyCheck subserver bodyCheck) where - bodyCheck request = do + bodyCheck = withRequest $ \ request -> 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" @@ -404,11 +409,11 @@ let contentTypeH = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders request mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) - <$> lazyRequestBody request + <$> liftIO (lazyRequestBody request) case mrqbody of - Nothing -> return $ FailFatal err415 - Just (Left e) -> return $ FailFatal err400 { errBody = cs e } - Just (Right v) -> return $ Route v + Nothing -> delayedFailFatal err415 + Just (Left e) -> delayedFailFatal err400 { errBody = cs e } + Just (Right v) -> return v -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@. @@ -416,36 +421,37 @@ type ServerT (path :> sublayout) m = ServerT sublayout m - route Proxy context subserver = StaticRouter $ - M.singleton (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) context subserver) + route Proxy context subserver = + pathRouter + (cs (symbolVal proxyPath)) + (route (Proxy :: Proxy sublayout) context subserver) where proxyPath = Proxy :: Proxy path instance HasServer api context => HasServer (RemoteHost :> api) context where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m - route Proxy context subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req) + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver remoteHost) instance HasServer api context => HasServer (IsSecure :> api) context where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m - route Proxy context subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) context (passToServer subserver $ secure req) + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver secure) where secure req = if isSecure req then Secure else NotSecure instance HasServer api context => HasServer (Vault :> api) context where type ServerT (Vault :> api) m = Vault -> ServerT api m - route Proxy context subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) context (passToServer subserver $ vault req) + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver vault) instance HasServer api context => HasServer (HttpVersion :> api) context where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m - route Proxy context subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req) + route Proxy context subserver = + route (Proxy :: Proxy api) context (passToServer subserver httpVersion) -- | Basic Authentication instance ( KnownSymbol realm @@ -456,20 +462,14 @@ type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m - route Proxy context subserver = WithRequest $ \ request -> - route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) + route Proxy context subserver = + route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck) where realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) basicAuthContext = getContextEntry context - authCheck req = runBasicAuth req realm basicAuthContext + authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext -- * helpers - -pathIsEmpty :: Request -> Bool -pathIsEmpty = go . pathInfo - where go [] = True - go [""] = True - go _ = False ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP diff --git a/src/Servant/Server/Internal/BasicAuth.hs b/src/Servant/Server/Internal/BasicAuth.hs --- a/src/Servant/Server/Internal/BasicAuth.hs +++ b/src/Servant/Server/Internal/BasicAuth.hs @@ -6,6 +6,7 @@ module Servant.Server.Internal.BasicAuth where import Control.Monad (guard) +import Control.Monad.Trans (liftIO) import qualified Data.ByteString as BS import Data.ByteString.Base64 (decodeLenient) import Data.Monoid ((<>)) @@ -57,13 +58,13 @@ -- | Run and check basic authentication, returning the appropriate http error per -- the spec. -runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr) +runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> DelayedIO usr runBasicAuth req realm (BasicAuthCheck ba) = case decodeBAHdr req of Nothing -> plzAuthenticate - Just e -> ba e >>= \res -> case res of + Just e -> liftIO (ba e) >>= \res -> case res of BadPassword -> plzAuthenticate NoSuchUser -> plzAuthenticate - Unauthorized -> return $ FailFatal err403 - Authorized usr -> return $ Route usr - where plzAuthenticate = return $ FailFatal err401 { errHeaders = [mkBAChallengerHdr realm] } + Unauthorized -> delayedFailFatal err403 + Authorized usr -> return usr + where plzAuthenticate = delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm] } diff --git a/src/Servant/Server/Internal/Router.hs b/src/Servant/Server/Internal/Router.hs --- a/src/Servant/Server/Internal/Router.hs +++ b/src/Servant/Server/Internal/Router.hs @@ -1,89 +1,196 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} module Servant.Server.Internal.Router where import Data.Map (Map) import qualified Data.Map as M +import Data.Monoid import Data.Text (Text) -import Network.Wai (Request, Response, pathInfo) +import qualified Data.Text as T +import Network.Wai (Response, pathInfo) import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -type Router = Router' RoutingApplication +type Router env = Router' env RoutingApplication -- | Internal representation of a router. -data Router' a = - WithRequest (Request -> Router) - -- ^ current request is passed to the router - | StaticRouter (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 a - -- ^ to be used for routes that match an empty path - | Choice Router Router +-- +-- The first argument describes an environment type that is +-- expected as extra input by the routers at the leaves. The +-- environment is filled while running the router, with path +-- components that can be used to process captures. +-- +data Router' env a = + StaticRouter (Map Text (Router' env a)) [env -> a] + -- ^ the map contains routers for subpaths (first path component used + -- for lookup and removed afterwards), the list contains handlers + -- for the empty path, to be tried in order + | CaptureRouter (Router' (Text, env) a) + -- ^ first path component is passed to the child router in its + -- environment and removed afterwards + | RawRouter (env -> a) + -- ^ to be used for routes we do not know anything about + | Choice (Router' env a) (Router' env a) -- ^ left-biased choice between two routers deriving Functor --- | Apply a transformation to the response of a `Router`. -tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router -tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) +-- | Smart constructor for a single static path component. +pathRouter :: Text -> Router' env a -> Router' env a +pathRouter t r = StaticRouter (M.singleton t r) [] +-- | Smart constructor for a leaf, i.e., a router that expects +-- the empty path. +-- +leafRouter :: (env -> a) -> Router' env a +leafRouter l = StaticRouter M.empty [l] + -- | Smart constructor for the choice between routers. -- We currently optimize the following cases: -- --- * Two static routers can be joined by joining their maps. +-- * Two static routers can be joined by joining their maps +-- and concatenating their leaf-lists. -- * 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 nodes can be reordered. -- -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 :: Router' env a -> Router' env a -> Router' env a +choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) = + StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2) +choice (CaptureRouter router1) (CaptureRouter router2) = + CaptureRouter (choice router1 router2) +choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3 choice router1 router2 = Choice router1 router2 +-- | Datatype used for representing and debugging the +-- structure of a router. Abstracts from the handlers +-- at the leaves. +-- +-- Two 'Router's can be structurally compared by computing +-- their 'RouterStructure' using 'routerStructure' and +-- then testing for equality, see 'sameStructure'. +-- +data RouterStructure = + StaticRouterStructure (Map Text RouterStructure) Int + | CaptureRouterStructure RouterStructure + | RawRouterStructure + | ChoiceStructure RouterStructure RouterStructure + deriving (Eq, Show) + +-- | Compute the structure of a router. +-- +-- Assumes that the request or text being passed +-- in 'WithRequest' or 'CaptureRouter' does not +-- affect the structure of the underlying tree. +-- +routerStructure :: Router' env a -> RouterStructure +routerStructure (StaticRouter m ls) = + StaticRouterStructure (fmap routerStructure m) (length ls) +routerStructure (CaptureRouter router) = + CaptureRouterStructure $ + routerStructure router +routerStructure (RawRouter _) = + RawRouterStructure +routerStructure (Choice r1 r2) = + ChoiceStructure + (routerStructure r1) + (routerStructure r2) + +-- | Compare the structure of two routers. +-- +sameStructure :: Router' env a -> Router' env b -> Bool +sameStructure r1 r2 = + routerStructure r1 == routerStructure r2 + +-- | Provide a textual representation of the +-- structure of a router. +-- +routerLayout :: Router' env a -> Text +routerLayout router = + T.unlines (["/"] ++ mkRouterLayout False (routerStructure router)) + where + mkRouterLayout :: Bool -> RouterStructure -> [Text] + mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n + mkRouterLayout c (CaptureRouterStructure r) = mkSubTree c "" (mkRouterLayout False r) + mkRouterLayout c RawRouterStructure = + if c then ["├─ "] else ["└─ "] + mkRouterLayout c (ChoiceStructure r1 r2) = + mkRouterLayout True r1 ++ ["┆"] ++ mkRouterLayout c r2 + + mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text] + mkSubTrees _ [] 0 = [] + mkSubTrees c [] n = + concat (replicate (n - 1) (mkLeaf True) ++ [mkLeaf c]) + mkSubTrees c [(t, r)] 0 = + mkSubTree c t (mkRouterLayout False r) + mkSubTrees c ((t, r) : trs) n = + mkSubTree True t (mkRouterLayout False r) ++ mkSubTrees c trs n + + mkLeaf :: Bool -> [Text] + mkLeaf True = ["├─•","┆"] + mkLeaf False = ["└─•"] + + mkSubTree :: Bool -> Text -> [Text] -> [Text] + mkSubTree True path children = ("├─ " <> path <> "/") : map ("│ " <>) children + mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children + +-- | Apply a transformation to the response of a `Router`. +tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env -> Router env +tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) + -- | 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 pathInfo request of - first : rest - | Just router <- M.lookup first table - -> let request' = request { pathInfo = rest } - in runRouter router request' respond - _ -> respond $ Fail err404 -runRouter (DynamicRouter fun) request respond = - case pathInfo request of - first : rest - -> let request' = request { pathInfo = rest } - in runRouter (fun first) request' respond - _ -> respond $ Fail err404 -runRouter (LeafRouter app) request respond = app request respond -runRouter (Choice r1 r2) request respond = - runRouter r1 request $ \ mResponse1 -> case mResponse1 of - Fail _ -> runRouter r2 request $ \ mResponse2 -> - respond (highestPri mResponse1 mResponse2) - _ -> respond mResponse1 - where - highestPri (Fail e1) (Fail e2) = - if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2) - then Fail e2 - else Fail e1 - highestPri (Fail _) y = y - highestPri x _ = x +runRouter :: Router () -> RoutingApplication +runRouter r = runRouterEnv r () +runRouterEnv :: Router env -> env -> RoutingApplication +runRouterEnv router env request respond = + case router of + StaticRouter table ls -> + case pathInfo request of + [] -> runChoice ls env request respond + -- This case is to handle trailing slashes. + [""] -> runChoice ls env request respond + first : rest | Just router' <- M.lookup first table + -> let request' = request { pathInfo = rest } + in runRouterEnv router' env request' respond + _ -> respond $ Fail err404 + CaptureRouter router' -> + case pathInfo request of + [] -> respond $ Fail err404 + -- This case is to handle trailing slashes. + [""] -> respond $ Fail err404 + first : rest + -> let request' = request { pathInfo = rest } + in runRouterEnv router' (first, env) request' respond + RawRouter app -> + app env request respond + Choice r1 r2 -> + runChoice [runRouterEnv r1, runRouterEnv r2] env request respond + +-- | Try a list of routing applications in order. +-- We stop as soon as one fails fatally or succeeds. +-- If all fail normally, we pick the "best" error. +-- +runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication +runChoice ls = + case ls of + [] -> \ _ _ respond -> respond (Fail err404) + [r] -> r + (r : rs) -> + \ env request respond -> + r env request $ \ response1 -> + case response1 of + Fail _ -> runChoice rs env request $ \ response2 -> + respond $ highestPri response1 response2 + _ -> respond response1 + where + highestPri (Fail e1) (Fail e2) = + if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2) + then Fail e2 + else Fail e1 + highestPri (Fail _) y = y + highestPri x _ = x -- Priority on HTTP codes. -- diff --git a/src/Servant/Server/Internal/RoutingApplication.hs b/src/Servant/Server/Internal/RoutingApplication.hs --- a/src/Servant/Server/Internal/RoutingApplication.hs +++ b/src/Servant/Server/Internal/RoutingApplication.hs @@ -8,7 +8,10 @@ {-# LANGUAGE StandaloneDeriving #-} module Servant.Server.Internal.RoutingApplication where -import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad (ap, liftM) +import Control.Monad.Trans (MonadIO(..)) +import Control.Monad.Trans.Except (runExceptT) +import Data.Text (Text) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () @@ -35,31 +38,6 @@ routingRespond (FailFatal err) = respond $ responseServantErr err routingRespond (Route v) = respond v --- We currently mix up the order in which we perform checks --- and the priority with which errors are reported. --- --- For example, we perform Capture checks prior to method checks, --- and therefore get 404 before 405. --- --- However, we also perform body checks prior to method checks --- now, and therefore get 415 before 405, which is wrong. --- --- If we delay Captures, but perform method checks eagerly, we --- end up potentially preferring 405 over 404, which is also bad. --- --- So in principle, we'd like: --- --- static routes (can cause 404) --- delayed captures (can cause 404) --- methods (can cause 405) --- authentication and authorization (can cause 401, 403) --- delayed body (can cause 415, 400) --- accept header (can cause 406) --- --- According to the HTTP decision diagram, the priority order --- between HTTP status codes is as follows: --- - -- | A 'Delayed' is a representation of a handler with scheduled -- delayed checks that can trigger errors. -- @@ -120,113 +98,139 @@ -- The accept header check can be performed as the final -- computation in this block. It can cause a 406. -- -data Delayed c where - Delayed :: { capturesD :: IO (RouteResult captures) - , methodD :: IO (RouteResult ()) - , authD :: IO (RouteResult auth) - , bodyD :: IO (RouteResult body) - , serverD :: (captures -> auth -> body -> RouteResult c) - } -> Delayed c +data Delayed env c where + Delayed :: { capturesD :: env -> DelayedIO captures + , methodD :: DelayedIO () + , authD :: DelayedIO auth + , bodyD :: DelayedIO body + , serverD :: captures -> auth -> body -> Request -> RouteResult c + } -> Delayed env c -instance Functor Delayed where - fmap f Delayed{..} - = Delayed { capturesD = capturesD - , methodD = methodD - , authD = authD - , bodyD = bodyD - , serverD = (fmap.fmap.fmap.fmap) f serverD - } -- Note [Existential Record Update] +instance Functor (Delayed env) where + fmap f Delayed{..} = + Delayed + { serverD = \ c a b req -> f <$> serverD c a b req + , .. + } -- Note [Existential Record Update] +-- | Computations used in a 'Delayed' can depend on the +-- incoming 'Request', may perform 'IO, and result in a +-- 'RouteResult, meaning they can either suceed, fail +-- (with the possibility to recover), or fail fatally. +-- +newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> IO (RouteResult a) } + +instance Functor DelayedIO where + fmap = liftM + +instance Applicative DelayedIO where + pure = return + (<*>) = ap + +instance Monad DelayedIO where + return x = DelayedIO (const $ return (Route x)) + DelayedIO m >>= f = + DelayedIO $ \ req -> do + r <- m req + case r of + Fail e -> return $ Fail e + FailFatal e -> return $ FailFatal e + Route a -> runDelayedIO (f a) req + +instance MonadIO DelayedIO where + liftIO m = DelayedIO (const $ Route <$> m) + +-- | A 'Delayed' without any stored checks. +emptyDelayed :: RouteResult a -> Delayed env a +emptyDelayed result = + Delayed (const r) r r r (\ _ _ _ _ -> result) + where + r = return () + +-- | Fail with the option to recover. +delayedFail :: ServantErr -> DelayedIO a +delayedFail err = DelayedIO (const $ return $ Fail err) + +-- | Fail fatally, i.e., without any option to recover. +delayedFailFatal :: ServantErr -> DelayedIO a +delayedFailFatal err = DelayedIO (const $ return $ FailFatal err) + +-- | Gain access to the incoming request. +withRequest :: (Request -> DelayedIO a) -> DelayedIO a +withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req) + -- | Add a capture to the end of the capture block. -addCapture :: Delayed (a -> b) - -> IO (RouteResult a) - -> Delayed b -addCapture Delayed{..} new - = Delayed { capturesD = combineRouteResults (,) capturesD new - , methodD = methodD - , authD = authD - , bodyD = bodyD - , serverD = \ (x, v) y z -> ($ v) <$> serverD x y z - } -- Note [Existential Record Update] +addCapture :: Delayed env (a -> b) + -> (Text -> DelayedIO a) + -> Delayed (Text, env) b +addCapture Delayed{..} new = + Delayed + { capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt + , serverD = \ (x, v) a b req -> ($ v) <$> serverD x a b req + , .. + } -- Note [Existential Record Update] -- | Add a method check to the end of the method block. -addMethodCheck :: Delayed a - -> IO (RouteResult ()) - -> Delayed a -addMethodCheck Delayed{..} new - = Delayed { capturesD = capturesD - , methodD = combineRouteResults const methodD new - , authD = authD - , bodyD = bodyD - , serverD = serverD - } -- Note [Existential Record Update] +addMethodCheck :: Delayed env a + -> DelayedIO () + -> Delayed env a +addMethodCheck Delayed{..} new = + Delayed + { methodD = methodD <* new + , .. + } -- Note [Existential Record Update] -- | Add an auth check to the end of the auth block. -addAuthCheck :: Delayed (a -> b) - -> IO (RouteResult a) - -> Delayed b -addAuthCheck Delayed{..} new - = Delayed { capturesD = capturesD - , methodD = methodD - , authD = combineRouteResults (,) authD new - , bodyD = bodyD - , serverD = \ x (y, v) z -> ($ v) <$> serverD x y z - } -- Note [Existential Record Update] +addAuthCheck :: Delayed env (a -> b) + -> DelayedIO a + -> Delayed env b +addAuthCheck Delayed{..} new = + Delayed + { authD = (,) <$> authD <*> new + , serverD = \ c (y, v) b req -> ($ v) <$> serverD c y b req + , .. + } -- Note [Existential Record Update] -- | Add a body check to the end of the body block. -addBodyCheck :: Delayed (a -> b) - -> IO (RouteResult a) - -> Delayed b -addBodyCheck Delayed{..} new - = Delayed { capturesD = capturesD - , methodD = methodD - , authD = authD - , bodyD = combineRouteResults (,) bodyD new - , serverD = \ x y (z, v) -> ($ v) <$> serverD x y z - } -- Note [Existential Record Update] +addBodyCheck :: Delayed env (a -> b) + -> DelayedIO a + -> Delayed env b +addBodyCheck Delayed{..} new = + Delayed + { bodyD = (,) <$> bodyD <*> new + , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req + , .. + } -- Note [Existential Record Update] --- | Add an accept header check to the end of the body block. --- The accept header check should occur after the body check, --- but this will be the case, because the accept header check --- is only scheduled by the method combinators. -addAcceptCheck :: Delayed a - -> IO (RouteResult ()) - -> Delayed a -addAcceptCheck Delayed{..} new - = Delayed { capturesD = capturesD - , methodD = methodD - , authD = authD - , bodyD = combineRouteResults const bodyD new - , serverD = serverD - } -- Note [Existential Record Update] +-- | Add an accept header check to the beginning of the body +-- block. There is a tradeoff here. In principle, we'd like +-- to take a bad body (400) response take precedence over a +-- failed accept check (406). BUT to allow streaming the body, +-- we cannot run the body check and then still backtrack. +-- We therefore do the accept check before the body check, +-- when we can still backtrack. There are other solutions to +-- this, but they'd be more complicated (such as delaying the +-- body check further so that it can still be run in a situation +-- where we'd otherwise report 406). +addAcceptCheck :: Delayed env a + -> DelayedIO () + -> Delayed env a +addAcceptCheck Delayed{..} new = + Delayed + { bodyD = new *> bodyD + , .. + } -- Note [Existential Record Update] -- | Many combinators extract information that is passed to -- the handler without the possibility of failure. In such a -- case, 'passToServer' can be used. -passToServer :: Delayed (a -> b) -> a -> Delayed b -passToServer d x = ($ x) <$> d - --- | The combination 'IO . RouteResult' is a monad, but we --- don't explicitly wrap it in a newtype in order to make it --- an instance. This is the '>>=' of that monad. --- --- We stop on the first error. -bindRouteResults :: IO (RouteResult a) -> (a -> IO (RouteResult b)) -> IO (RouteResult b) -bindRouteResults m f = do - r <- m - case r of - Fail e -> return $ Fail e - FailFatal e -> return $ FailFatal e - Route a -> f a - --- | Common special case of 'bindRouteResults', corresponding --- to 'liftM2'. -combineRouteResults :: (a -> b -> c) -> IO (RouteResult a) -> IO (RouteResult b) -> IO (RouteResult c) -combineRouteResults f m1 m2 = - m1 `bindRouteResults` \ a -> - m2 `bindRouteResults` \ b -> - return (Route (f a b)) +passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b +passToServer Delayed{..} x = + Delayed + { serverD = \ c a b req -> ($ x req) <$> serverD c a b req + , .. + } -- Note [Existential Record Update] -- | Run a delayed server. Performs all scheduled operations -- in order, and passes the results from the capture and body @@ -234,24 +238,29 @@ -- -- This should only be called once per request; otherwise the guarantees about -- effect and HTTP error ordering break down. -runDelayed :: Delayed a +runDelayed :: Delayed env a + -> env + -> Request -> IO (RouteResult a) -runDelayed Delayed{..} = - capturesD `bindRouteResults` \ c -> - methodD `bindRouteResults` \ _ -> - authD `bindRouteResults` \ a -> - bodyD `bindRouteResults` \ b -> - return (serverD c a b) +runDelayed Delayed{..} env = runDelayedIO $ do + c <- capturesD env + methodD + a <- authD + b <- bodyD + DelayedIO (\ req -> return $ serverD c a b req) -- | Runs a delayed server and the resulting action. -- Takes a continuation that lets us send a response. -- Also takes a continuation for how to turn the -- result of the delayed server into a response. -runAction :: Delayed (ExceptT ServantErr IO a) +runAction :: Delayed env (Handler a) + -> env + -> Request -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r -runAction action respond k = runDelayed action >>= go >>= respond +runAction action env req respond k = + runDelayed action env req >>= go >>= respond where go (Fail e) = return $ Fail e go (FailFatal e) = return $ FailFatal e diff --git a/src/Servant/Server/Internal/ServantErr.hs b/src/Servant/Server/Internal/ServantErr.hs --- a/src/Servant/Server/Internal/ServantErr.hs +++ b/src/Servant/Server/Internal/ServantErr.hs @@ -4,6 +4,7 @@ module Servant.Server.Internal.ServantErr where import Control.Exception (Exception) +import Control.Monad.Trans.Except (ExceptT) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import Data.Typeable (Typeable) @@ -18,6 +19,8 @@ instance Exception ServantErr +type Handler = ExceptT ServantErr IO + responseServantErr :: ServantErr -> Response responseServantErr ServantErr{..} = responseLBS status errHeaders errBody where @@ -27,7 +30,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err300 { errBody = "I can't choose." } -- err300 :: ServantErr @@ -41,7 +44,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err301 -- err301 :: ServantErr @@ -55,7 +58,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err302 -- err302 :: ServantErr @@ -69,7 +72,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err303 -- err303 :: ServantErr @@ -83,7 +86,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err304 -- err304 :: ServantErr @@ -97,7 +100,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err305 -- err305 :: ServantErr @@ -111,7 +114,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err307 -- err307 :: ServantErr @@ -125,7 +128,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err400 { errBody = "Your request makes no sense to me." } -- err400 :: ServantErr @@ -139,7 +142,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err401 { errBody = "Your credentials are invalid." } -- err401 :: ServantErr @@ -153,7 +156,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err402 { errBody = "You have 0 credits. Please give me $$$." } -- err402 :: ServantErr @@ -167,7 +170,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err403 { errBody = "Please login first." } -- err403 :: ServantErr @@ -181,7 +184,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } -- err404 :: ServantErr @@ -195,7 +198,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } -- err405 :: ServantErr @@ -209,7 +212,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err406 -- err406 :: ServantErr @@ -223,7 +226,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err407 -- err407 :: ServantErr @@ -237,7 +240,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } -- err409 :: ServantErr @@ -251,7 +254,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } -- err410 :: ServantErr @@ -265,7 +268,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr err411 -- err411 :: ServantErr @@ -279,7 +282,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } -- err412 :: ServantErr @@ -293,7 +296,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err413 { errBody = "Request exceeded 64k." } -- err413 :: ServantErr @@ -307,7 +310,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err414 { errBody = "Maximum length is 64." } -- err414 :: ServantErr @@ -321,7 +324,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err415 { errBody = "Supported media types: gif, png" } -- err415 :: ServantErr @@ -335,7 +338,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err416 { errBody = "Valid range is [0, 424242]." } -- err416 :: ServantErr @@ -349,7 +352,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err417 { errBody = "I found a quux in the request. This isn't going to work." } -- err417 :: ServantErr @@ -363,7 +366,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } -- err500 :: ServantErr @@ -377,7 +380,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err501 { errBody = "/v1/foo is not supported with quux in the request." } -- err501 :: ServantErr @@ -391,7 +394,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } -- err502 :: ServantErr @@ -405,7 +408,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err503 { errBody = "We're rewriting in PHP." } -- err503 :: ServantErr @@ -419,7 +422,7 @@ -- -- Example: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } -- err504 :: ServantErr @@ -433,7 +436,7 @@ -- -- Example usage: -- --- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler :: Handler () -- > failingHandler = throwErr $ err505 { errBody = "I support HTTP/4.0 only." } -- err505 :: ServantErr diff --git a/test/Servant/Server/ErrorSpec.hs b/test/Servant/Server/ErrorSpec.hs --- a/test/Servant/Server/ErrorSpec.hs +++ b/test/Servant/Server/ErrorSpec.hs @@ -53,6 +53,23 @@ errorOrderServer :: Server ErrorOrderApi errorOrderServer = \_ _ _ -> throwE err402 +-- On error priorities: +-- +-- We originally had +-- +-- 404, 405, 401, 415, 400, 406, 402 +-- +-- but we changed this to +-- +-- 404, 405, 401, 406, 415, 400, 402 +-- +-- for servant-0.7. +-- +-- This change is due to the body check being irreversible (to support +-- streaming). Any check done after the body check has to be made fatal, +-- breaking modularity. We've therefore moved the accept check before +-- the body check, to allow it being recoverable and modular, and this +-- goes along with promoting the error priority of 406. errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" $ @@ -86,17 +103,17 @@ request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 401 - it "has 415 as its fourth highest priority error" $ do + it "has 406 as its fourth highest priority error" $ do request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody + `shouldRespondWith` 406 + + it "has 415 as its fifth highest priority error" $ do + request goodMethod goodUrl [goodAuth, badContentType, goodAccept] badBody `shouldRespondWith` 415 - it "has 400 as its fifth highest priority error" $ do - request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody + it "has 400 as its sixth highest priority error" $ do + request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody `shouldRespondWith` 400 - - it "has 406 as its sixth highest priority error" $ do - request goodMethod goodUrl [goodAuth, goodContentType, badAccept] goodBody - `shouldRespondWith` 406 it "has handler-level errors as last priority" $ do request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody diff --git a/test/Servant/Server/Internal/EnterSpec.hs b/test/Servant/Server/Internal/EnterSpec.hs --- a/test/Servant/Server/Internal/EnterSpec.hs +++ b/test/Servant/Server/Internal/EnterSpec.hs @@ -34,7 +34,7 @@ readerServer' :: ServerT ReaderAPI (Reader String) readerServer' = return 1797 :<|> ask -fReader :: Reader String :~> ExceptT ServantErr IO +fReader :: Reader String :~> Handler fReader = generalizeNat C.. (runReaderTNat "hi") readerServer :: Server ReaderAPI diff --git a/test/Servant/Server/UsingContextSpec.hs b/test/Servant/Server/UsingContextSpec.hs --- a/test/Servant/Server/UsingContextSpec.hs +++ b/test/Servant/Server/UsingContextSpec.hs @@ -25,7 +25,7 @@ type OneEntryAPI = ExtractFromContext :> Get '[JSON] String -testServer :: String -> ExceptT ServantErr IO String +testServer :: String -> Handler String testServer s = return s oneEntryApp :: Application diff --git a/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/test/Servant/Server/UsingContextSpec/TestCombinators.hs --- a/test/Servant/Server/UsingContextSpec/TestCombinators.hs +++ b/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -20,7 +20,6 @@ import GHC.TypeLits import Servant -import Servant.Server.Internal.RoutingApplication data ExtractFromContext @@ -31,7 +30,7 @@ String -> ServerT subApi m route Proxy context delayed = - route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi)) + route subProxy context (fmap (inject context) delayed) where subProxy :: Proxy subApi subProxy = Proxy diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -13,11 +13,8 @@ module Servant.ServerSpec where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif import Control.Monad (forM_, when, unless) -import Control.Monad.Trans.Except (ExceptT, throwE) +import Control.Monad.Trans.Except (throwE) import Data.Aeson (FromJSON, ToJSON, decode', encode) import qualified Data.ByteString.Base64 as Base64 import Data.ByteString.Conversion () @@ -36,8 +33,7 @@ parseQuery) import Network.Wai (Application, Request, requestHeaders, pathInfo, queryString, rawQueryString, - responseBuilder, responseLBS) -import Network.Wai.Internal (Response (ResponseBuilder)) + responseLBS) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody, simpleHeaders, simpleStatus) @@ -52,8 +48,9 @@ Raw, RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI -import Servant.Server (ServantErr (..), Server, err401, err404, - serve, serveWithContext, Context((:.), EmptyContext)) +import Servant.Server (Server, Handler, err401, err403, + err404, serve, serveWithContext, + Context((:.), EmptyContext)) import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import qualified Test.Hspec.Wai as THW @@ -66,11 +63,6 @@ import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) -import Servant.Server.Internal.RoutingApplication - (toApplication, RouteResult(..)) -import Servant.Server.Internal.Router - (tweakResponse, runRouter, - Router, Router'(LeafRouter)) import Servant.Server.Internal.Context (NamedContext(..)) @@ -94,7 +86,6 @@ rawSpec alternativeSpec responseHeadersSpec - routerSpec miscCombinatorSpec basicAuthSpec genAuthSpec @@ -108,6 +99,9 @@ :<|> "noContent" :> Verb method status '[JSON] NoContent :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person) :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent) + :<|> "accept" :> ( Verb method status '[JSON] Person + :<|> Verb method status '[PlainText] String + ) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do @@ -116,6 +110,7 @@ :<|> return NoContent :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent) + :<|> (return alice :<|> return "B") get200 = Proxy :: Proxy (VerbApi 'GET 200) post210 = Proxy :: Proxy (VerbApi 'POST 210) put203 = Proxy :: Proxy (VerbApi 'PUT 203) @@ -170,6 +165,12 @@ [(hAccept, "application/json")] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status + unless (status `elem` [214, 215] || method == methodHead) $ + it "allows modular specification of supported content types" $ do + response <- THW.request method "/accept" [(hAccept, "text/plain")] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ simpleBody response `shouldBe` "B" + it "sets the Content-Type header" $ do response <- THW.request method "" [] "" liftIO $ simpleHeaders response `shouldContain` @@ -190,7 +191,7 @@ type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal captureApi :: Proxy CaptureApi captureApi = Proxy -captureServer :: Integer -> ExceptT ServantErr IO Animal +captureServer :: Integer -> Handler Animal captureServer legs = case legs of 4 -> return jerry 2 -> return tweety @@ -346,11 +347,11 @@ headerSpec :: Spec headerSpec = describe "Servant.API.Header" $ do - let expectsInt :: Maybe Int -> ExceptT ServantErr IO () + let expectsInt :: Maybe Int -> Handler () expectsInt (Just x) = when (x /= 5) $ error "Expected 5" expectsInt Nothing = error "Expected an int" - let expectsString :: Maybe String -> ExceptT ServantErr IO () + let expectsString :: Maybe String -> Handler () expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you" expectsString Nothing = error "Expected a string" @@ -484,28 +485,6 @@ -- }}} ------------------------------------------------------------------------------ --- * routerSpec {{{ ------------------------------------------------------------------------------- -routerSpec :: Spec -routerSpec = do - describe "Servant.Server.Internal.Router" $ do - let app' :: Application - app' = toApplication $ runRouter router' - - router', router :: Router - router' = tweakResponse (twk <$>) router - router = LeafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "") - - twk :: Response -> Response - twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b - twk b = b - - describe "tweakResponse" . with (return app') $ do - it "calls f on route result" $ do - get "" `shouldRespondWith` 202 - --- }}} ------------------------------------------------------------------------------- -- * miscCombinatorSpec {{{ ------------------------------------------------------------------------------ type MiscCombinatorsAPI @@ -606,11 +585,10 @@ genAuthContext :: Context '[AuthHandler Request ()] genAuthContext = - let authHandler = (\req -> - if elem ("Auth", "secret") (requestHeaders req) - then return () - else throwE err401 - ) + let authHandler = \req -> case lookup "Auth" (requestHeaders req) of + Just "secret" -> return () + Just _ -> throwE err403 + Nothing -> throwE err401 in mkAuthHandler authHandler :. EmptyContext genAuthSpec :: Spec @@ -621,6 +599,9 @@ context "Custom Auth Protection" $ do it "returns 401 when missing headers" $ do get "/auth" `shouldRespondWith` 401 + + it "returns 403 on wrong passwords" $ do + THW.request methodGet "/auth" [("Auth","wrong")] "" `shouldRespondWith` 403 it "returns 200 with the right header" $ do THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200