diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index e183b82e..c0b4299d 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -32,12 +32,12 @@ instance HasServer rest => HasServer (AuthProtected :> rest) where route Proxy a = WithRequest $ \ request -> route (Proxy :: Proxy rest) $ do case lookup "Cookie" (requestHeaders request) of - Nothing -> return $! failFatallyWith err401 { errBody = "Missing auth header" } + Nothing -> return $! FailFatal err401 { errBody = "Missing auth header" } Just v -> do authGranted <- isGoodCookie v if authGranted then a - else return $! failFatallyWith err403 { errBody = "Invalid cookie" } + else return $ FailFatal err403 { errBody = "Invalid cookie" } type PrivateAPI = Get '[JSON] [PrivateData] diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index eb46e994..f45823eb 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -5,6 +5,11 @@ HEAD * Drop `EitherT` in favor of `ExceptT` * Use `http-api-data` instead of `Servant.Common.Text` * Remove matrix params. +* Remove `RouteMismatch`. +* Redefined constructors of `RouteResult`. +* Add `failFatallyWith`. +* Make all (framework-generated) HTTP errors except 404 and 405 not try other + handlers. 0.4.1 ----- diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index eadd5174..f6781b66 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -103,7 +103,7 @@ import Servant.Server.Internal.Enter -- > main = Network.Wai.Handler.Warp.run 8080 app -- serve :: HasServer layout => Proxy layout -> Server layout -> Application -serve p server = toApplication (runRouter (route p (return (HandlerVal server)))) +serve p server = toApplication (runRouter (route p (return (Route server)))) -- Documentation diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 3d85eb81..6c717fa2 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} #if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE OverlappingInstances #-} #endif module Servant.Server.Internal @@ -26,9 +26,9 @@ import Control.Monad.Trans.Except (ExceptT) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Map as M -import Data.Maybe (mapMaybe, fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.String (fromString) -import Data.String.Conversions (cs, (<>), ConvertibleStrings) +import Data.String.Conversions (ConvertibleStrings, cs, (<>)) import Data.Text (Text) import Data.Typeable import GHC.TypeLits (KnownSymbol, symbolVal) @@ -47,8 +47,8 @@ import Servant.API ((:<|>) (..), (:>), Capture, import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..)) -import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders, - getHeaders) +import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, + getResponse) import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication @@ -114,7 +114,7 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) route Proxy subserver = DynamicRouter $ \ first -> case captured captureProxy first of - Nothing -> LeafRouter (\_ r -> r $ failWith err404) + Nothing -> LeafRouter (\_ r -> r $ Fail err404) Just v -> route (Proxy :: Proxy sublayout) (feedTo subserver v) where captureProxy = Proxy :: Proxy (Capture capture a) @@ -130,8 +130,8 @@ processMethodRouter :: forall a. ConvertibleStrings a B.ByteString -> Maybe [(HeaderName, B.ByteString)] -> Request -> RouteResult Response processMethodRouter handleA status method headers request = case handleA of - Nothing -> failFatallyWith err406 - Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy + Nothing -> FailFatal err406 + Just (contentT, body) -> Route $! responseLBS status hdrs bdy where bdy = if allowedMethodHead method request then "" else body hdrs = (hContentType, cs contentT) : (fromMaybe [] headers) @@ -149,8 +149,8 @@ methodRouter method proxy status action = LeafRouter route' handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request | pathIsEmpty request && requestMethod request /= method = - respond $ failWith err405 - | otherwise = respond $ failWith err404 + respond $ Fail err405 + | otherwise = respond $ Fail err404 methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) => Method -> Proxy ctypes -> Status @@ -166,8 +166,8 @@ methodRouterHeaders method proxy status action = LeafRouter route' handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just headers) request | pathIsEmpty request && requestMethod request /= method = - respond $ failWith err405 - | otherwise = respond $ failWith err404 + respond $ Fail err405 + | otherwise = respond $ Fail err404 methodRouterEmpty :: Method -> IO (RouteResult (ExceptT ServantErr IO ())) @@ -177,10 +177,10 @@ methodRouterEmpty method action = LeafRouter route' route' request respond | pathIsEmpty request && allowedMethod method request = do runAction action respond $ \ () -> - succeedWith $ responseLBS noContent204 [] "" + Route $! responseLBS noContent204 [] "" | pathIsEmpty request && requestMethod request /= method = - respond $ failWith err405 - | otherwise = respond $ failWith err404 + respond $ Fail err405 + | otherwise = respond $ Fail err404 -- | If you have a 'Delete' endpoint in your API, -- the handler for this endpoint is meant to delete @@ -557,9 +557,9 @@ instance HasServer Raw where route Proxy rawApplication = LeafRouter $ \ request respond -> do r <- rawApplication case r of - HandlerVal app -> app request (respond . succeedWith) - Retriable e -> respond $ failWith e - NonRetriable e -> respond $! failFatallyWith e + Route app -> app request (respond . Route) + Fail a -> respond $ Fail a + FailFatal e -> respond $ FailFatal e -- | If you use 'ReqBody' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -599,8 +599,8 @@ instance ( AllCTUnrender list a, HasServer sublayout mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) <$> lazyRequestBody request case mrqbody of - Nothing -> return $! failFatallyWith err415 - Just (Left e) -> return $! failFatallyWith err400 { errBody = cs e } + Nothing -> return $ FailFatal err415 + Just (Left e) -> return $ FailFatal err400 { errBody = cs e } Just (Right v) -> feedTo subserver v -- | Make sure the incoming request starts with @"/path"@, strip it and diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index e461133c..3914af0d 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -1,10 +1,9 @@ {-# LANGUAGE DeriveFunctor #-} - +{-# LANGUAGE CPP #-} 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 Servant.Server.Internal.ServantErr @@ -65,24 +64,23 @@ runRouter (StaticRouter table) request respond = | Just router <- M.lookup first table -> let request' = request { pathInfo = rest } in runRouter router request' respond - _ -> respond $ failWith err404 + _ -> 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 $ failWith err404 + _ -> respond $ Fail err404 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 (highestPri mResponse1 mResponse2) - else respond mResponse1 + runRouter r1 request $ \ mResponse1 -> case mResponse1 of + Fail _ -> runRouter r2 request $ \ mResponse2 -> + respond (highestPri mResponse1 mResponse2) + _ -> respond mResponse1 where - highestPri (Retriable r1) (Retriable r2) = - if errHTTPCode r1 == 404 && errHTTPCode r2 /= 404 - then (Retriable r2) - else (Retriable r1) - highestPri (Retriable _) y = y + highestPri (Fail e1) (Fail e2) = + if errHTTPCode e1 == 404 && errHTTPCode e2 /= 404 + then Fail e2 + else Fail e1 + highestPri (Fail _) y = y highestPri x _ = x diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 579ac0c3..f430fb2e 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Servant.Server.Internal.RoutingApplication where @@ -28,10 +27,10 @@ type RoutingApplication = -- | A wrapper around @'Either' 'RouteMismatch' a@. data RouteResult a = - Retriable ServantErr -- ^ Keep trying other paths. The @ServantErr@ + Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@ -- should only be 404 or 405. - | NonRetriable ServantErr -- ^ Stop trying. - | HandlerVal a + | FailFatal ServantErr -- ^ Don't other paths. + | Route a deriving (Eq, Show, Read, Functor) data ReqBodyState = Uncalled @@ -64,9 +63,9 @@ toApplication ra request respond = do ra request{ requestBody = memoReqBody } routingRespond where routingRespond :: RouteResult Response -> IO ResponseReceived - routingRespond (Retriable err) = respond $! responseServantErr err - routingRespond (NonRetriable err) = respond $! responseServantErr err - routingRespond (HandlerVal v) = respond v + routingRespond (Fail err) = respond $! responseServantErr err + routingRespond (FailFatal err) = respond $! responseServantErr err + routingRespond (Route v) = respond v runAction :: IO (RouteResult (ExceptT ServantErr IO a)) -> (RouteResult Response -> IO r) @@ -74,39 +73,23 @@ runAction :: IO (RouteResult (ExceptT ServantErr IO a)) -> IO r runAction action respond k = action >>= go >>= respond where - go (Retriable e) = return $! Retriable e - go (NonRetriable e) = return . succeedWith $! responseServantErr e - go (HandlerVal a) = do + go (Fail e) = return $ Fail e + go (FailFatal e) = return $ FailFatal e + go (Route a) = do e <- runExceptT a case e of - Left err -> return . succeedWith $! responseServantErr err + Left err -> return . Route $ responseServantErr err Right x -> return $! k x feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b) feedTo f x = (($ x) <$>) <$> f extractL :: RouteResult (a :<|> b) -> RouteResult a -extractL (HandlerVal (a :<|> _)) = HandlerVal a -extractL (Retriable x) = Retriable x -extractL (NonRetriable x) = NonRetriable x +extractL (Route (a :<|> _)) = Route a +extractL (Fail x) = Fail x +extractL (FailFatal x) = FailFatal x extractR :: RouteResult (a :<|> b) -> RouteResult b -extractR (HandlerVal (_ :<|> b)) = HandlerVal b -extractR (Retriable x) = Retriable x -extractR (NonRetriable x) = NonRetriable x - --- | Fail with a @ServantErr@, but keep trying other paths and. -failWith :: ServantErr -> RouteResult a -failWith = Retriable - --- | Fail with immediately @ServantErr@. -failFatallyWith :: ServantErr -> RouteResult a -failFatallyWith = NonRetriable - --- | Return a value, and don't try other paths. -succeedWith :: a -> RouteResult a -succeedWith = HandlerVal - -isMismatch :: RouteResult a -> Bool -isMismatch (Retriable _) = True -isMismatch _ = False +extractR (Route (_ :<|> b)) = Route b +extractR (Fail x) = Fail x +extractR (FailFatal x) = FailFatal x diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 30a8b41c..9a0bb2dd 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -6,32 +6,38 @@ module Servant.Server.ErrorSpec (spec) where import Data.Aeson (encode) -import qualified Data.ByteString.Lazy.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BCL +import qualified Data.ByteString.Char8 as BC import Data.Proxy import Network.HTTP.Types (hAccept, hContentType, methodGet, - methodPost) + methodPost, methodPut) import Test.Hspec import Test.Hspec.Wai import Servant --- 1) Check whether one or more endpoints have the right path. Otherwise return 404. --- 2) Check whether the one of those have the right method. Otherwise return --- 405. If so, pick the first. We've now commited to calling at most one handler. * --- 3) Check whether the Content-Type is known. Otherwise return 415. --- 4) Check whether that one deserializes the body. Otherwise return 400. If there --- was no Content-Type, try the first one of the API content-type list. --- 5) Check whether the request is authorized. Otherwise return a 401. --- 6) Check whether the request is forbidden. If so return 403. --- 7) Check whether the request has a known Accept. Otherwise return 406. --- 8) Check whether Accept-Language, Accept-Charset and Accept-Encoding exist and --- match. We can follow the webmachine order here. --- 9) Call the handler. Whatever it returns, we return. +-- The semantics of routing and handling requests should be as follows: +-- +-- 1) Check whether one or more endpoints have the right path. Otherwise +-- return 404. +-- 2) Check whether the one of those have the right method. Otherwise return +-- 405. If so, pick the first. We've now committed to calling at most one +-- handler. +-- 3) Check whether the Content-Type is known. Otherwise return 415. +-- 4) Check whether that one deserializes the body. Otherwise return 400. If +-- there was no Content-Type, try the first one of the API content-type list. +-- 5) Check whether the request is authorized. Otherwise return a 401. +-- 6) Check whether the request is forbidden. If so return 403. +-- 7) Check whether the request has a known Accept. Otherwise return 406. +-- 8) Check whether Accept-Language, Accept-Charset and Accept-Encoding +-- exist and match. We can follow the webmachine order here. +-- 9) Call the handler. Whatever it returns, we return. spec :: Spec spec = describe "HTTP Errors" $ do errorOrderSpec + prioErrorsSpec errorRetrySpec errorChoiceSpec @@ -83,6 +89,52 @@ errorOrderSpec = describe "HTTP error order" request goodMethod goodUrl [goodContentType, badAccept] goodBody `shouldRespondWith` 406 +type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer + +prioErrorsApi :: Proxy PrioErrorsApi +prioErrorsApi = Proxy + +-- Check whether matching continues even if a 'ReqBody' or similar construct +-- is encountered early in a path. We don't want to see a complaint about the +-- request body unless the path actually matches. +prioErrorsSpec :: Spec +prioErrorsSpec = describe "PrioErrors" $ do + let server = return + with (return $ serve prioErrorsApi server) $ do + let check (mdescr, method) path (cdescr, ctype, body) resp = + it fulldescr $ + Test.Hspec.Wai.request method path [(hContentType, ctype)] body + `shouldRespondWith` resp + where + fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr + ++ " " ++ (BC.unpack path) ++ " (" ++ cdescr ++ ")" + + get' = ("GET", methodGet) + put' = ("PUT", methodPut) + + txt = ("text" , "text/plain;charset=utf8" , "42" ) + ijson = ("invalid json", "application/json;charset=utf8", "invalid" ) + vjson = ("valid json" , "application/json;charset=utf8", encode (5 :: Int)) + + check get' "/" txt 404 + check get' "/bar" txt 404 + check get' "/foo" txt 415 + check put' "/" txt 404 + check put' "/bar" txt 404 + check put' "/foo" txt 405 + check get' "/" ijson 404 + check get' "/bar" ijson 404 + check get' "/foo" ijson 400 + check put' "/" ijson 404 + check put' "/bar" ijson 404 + check put' "/foo" ijson 405 + check get' "/" vjson 404 + check get' "/bar" vjson 404 + check get' "/foo" vjson 200 + check put' "/" vjson 404 + check put' "/bar" vjson 404 + check put' "/foo" vjson 405 + -- }}} ------------------------------------------------------------------------------ -- * Error Retry {{{ @@ -190,8 +242,10 @@ errorChoiceSpec = describe "Multiple handlers return errors" -- * Instances {{{ instance MimeUnrender PlainText Int where - mimeUnrender _ = Right . read . BC.unpack + mimeUnrender _ = Right . read . BCL.unpack instance MimeRender PlainText Int where - mimeRender _ = BC.pack . show + mimeRender _ = BCL.pack . show -- }}} +-- + diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index c9bf11ce..4ee65423 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -1,11 +1,20 @@ +<<<<<<< HEAD {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +======= +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +>>>>>>> Review fixes {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} +<<<<<<< HEAD {-# LANGUAGE FlexibleInstances #-} +======= +>>>>>>> Review fixes module Servant.ServerSpec where @@ -32,6 +41,16 @@ import Network.Wai (Application, Request, pathInfo, import Network.Wai.Internal (Response(ResponseBuilder)) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody) +import Servant.API ((:<|>) (..), (:>), Capture, Delete, + Get, Header (..), Headers, + HttpVersion, IsSecure (..), JSON, + MatrixFlag, MatrixParam, + MatrixParams, Patch, PlainText, + Post, Put, QueryFlag, QueryParam, + QueryParams, Raw, RemoteHost, + ReqBody, addHeader) +import Servant.Server (ServantErr (..), Server, err404, + serve) import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.Wai (get, liftIO, matchHeaders, matchStatus, post, request, @@ -96,7 +115,6 @@ spec = do headerSpec rawSpec unionSpec - prioErrorsSpec routerSpec responseHeadersSpec miscReqCombinatorsSpec @@ -526,55 +544,6 @@ responseHeadersSpec = describe "ResponseHeaders" $ do Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406 -type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer - -prioErrorsApi :: Proxy PrioErrorsApi -prioErrorsApi = Proxy - --- | Test the relative priority of error responses from the server. --- --- In particular, we check whether matching continues even if a 'ReqBody' --- or similar construct is encountered early in a path. We don't want to --- see a complaint about the request body unless the path actually matches. --- -prioErrorsSpec :: Spec -prioErrorsSpec = describe "PrioErrors" $ do - let server = return . age - with (return $ serve prioErrorsApi server) $ do - let check (mdescr, method) path (cdescr, ctype, body) resp = - it fulldescr $ - Test.Hspec.Wai.request method path [(hContentType, ctype)] body - `shouldRespondWith` resp - where - fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr - ++ " " ++ cs path ++ " (" ++ cdescr ++ ")" - - get' = ("GET", methodGet) - put' = ("PUT", methodPut) - - txt = ("text" , "text/plain;charset=utf8" , "42" ) - ijson = ("invalid json", "application/json;charset=utf8", "invalid" ) - vjson = ("valid json" , "application/json;charset=utf8", encode alice) - - check get' "/" txt 404 - check get' "/bar" txt 404 - check get' "/foo" txt 415 - check put' "/" txt 404 - check put' "/bar" txt 404 - check put' "/foo" txt 405 - check get' "/" ijson 404 - check get' "/bar" ijson 404 - check get' "/foo" ijson 400 - check put' "/" ijson 404 - check put' "/bar" ijson 404 - check put' "/foo" ijson 405 - check get' "/" vjson 404 - check get' "/bar" vjson 404 - check get' "/foo" vjson 200 - check put' "/" vjson 404 - check put' "/bar" vjson 404 - check put' "/foo" vjson 405 - routerSpec :: Spec routerSpec = do