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

Cleanup errorspec description of routing, changelog.

Browse source 
Review fixes
This commit is contained in:
Julian K. Arni 2015-09-15 11:37:17 +02:00
parent a3b5652ab9
commit ccadba81ec
8 changed files with 154 additions and 145 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
servant-examples/auth-combinator/auth-combinator.hs
View file

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

5
servant-server/CHANGELOG.md
View file

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

2
servant-server/src/Servant/Server.hs
View file

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

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

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

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

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

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

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

86
servant-server/test/Servant/Server/ErrorSpec.hs
View file

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

69
servant-server/test/Servant/ServerSpec.hs
View file

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