Cleanup errorspec description of routing, changelog.

Review fixes

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]
 

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

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

servant-server/src/Servant/Server/Internal.hs

@@ -1,15 +1,15 @@
-{-# LANGUAGE CPP                  #-}
+{-# LANGUAGE CPP                        #-}
-{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DataKinds                  #-}
-{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE PolyKinds            #-}
+{-# LANGUAGE PolyKinds                  #-}
-{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE TypeOperators        #-}
+{-# 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,
+import           Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
-                                              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
+  Nothing -> FailFatal err406
-  Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy
+  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
+          respond $ Fail err405
-      | otherwise = respond $ failWith err404
+      | 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
+          respond $ Fail err405
-      | otherwise = respond $ failWith err404
+      | 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
+          respond $ Fail err405
-      | otherwise = respond $ failWith err404
+      | 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)
+      Route app   -> app request (respond . Route)
-      Retriable  e    -> respond $ failWith e
+      Fail a      -> respond $ Fail a
-      NonRetriable e  -> respond $! failFatallyWith e
+      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
+        Nothing -> return $ FailFatal err415
-        Just (Left e) -> return $! failFatallyWith err400 { errBody = cs e }
+        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

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 ->
+  runRouter r1 request $ \ mResponse1 -> case mResponse1 of
-    if isMismatch mResponse1
+    Fail _ -> runRouter r2 request $ \ mResponse2 ->
-      then runRouter r2 request $ \ mResponse2 ->
+      respond (highestPri mResponse1 mResponse2)
-             respond (highestPri mResponse1 mResponse2)
+    _      -> respond mResponse1
-      else respond mResponse1
   where
-    highestPri (Retriable r1) (Retriable r2) =
+    highestPri (Fail e1) (Fail e2) =
-      if errHTTPCode r1 == 404 && errHTTPCode r2 /= 404
+      if errHTTPCode e1 == 404 && errHTTPCode e2 /= 404
-        then (Retriable r2)
+        then Fail e2
-        else (Retriable r1)
+        else Fail e1
-    highestPri (Retriable _) y = y
+    highestPri (Fail _) y = y
     highestPri x _ = x

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.
+  | FailFatal ServantErr      -- ^ Don't other paths.
-  | HandlerVal a
+  | 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 (Fail err)    = respond $! responseServantErr err
-  routingRespond (NonRetriable err) = respond $! responseServantErr err
+  routingRespond (FailFatal err) = respond $! responseServantErr err
-  routingRespond (HandlerVal v)     = respond v
+  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 (Fail  e)   = return $ Fail e
-    go (NonRetriable e) = return . succeedWith $! responseServantErr e
+    go (FailFatal e) = return $ FailFatal e
-    go (HandlerVal a)   = do
+    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 (Route (a :<|> _)) = Route a
-extractL (Retriable x)           = Retriable x
+extractL (Fail x)           = Fail x
-extractL (NonRetriable x)        = NonRetriable x
+extractL (FailFatal x)      = FailFatal x
 
 extractR :: RouteResult (a :<|> b) -> RouteResult b
-extractR (HandlerVal (_ :<|> b)) = HandlerVal b
+extractR (Route (_ :<|> b)) = Route b
-extractR (Retriable x)           = Retriable x
+extractR (Fail x)           = Fail x
-extractR (NonRetriable x)        = NonRetriable x
+extractR (FailFatal x)      = FailFatal 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

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.
+-- The semantics of routing and handling requests should be as follows:
--- 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. *
+--    1) Check whether one or more endpoints have the right path. Otherwise
--- 3) Check whether the Content-Type is known. Otherwise return 415.
+--    return 404.
--- 4) Check whether that one deserializes the body. Otherwise return 400. If there
+--    2) Check whether the one of those have the right method. Otherwise return
--- was no Content-Type, try the first one of the API content-type list.
+--    405. If so, pick the first. We've now committed to calling at most one
--- 5) Check whether the request is authorized. Otherwise return a 401.
+--    handler.
--- 6) Check whether the request is forbidden. If so return 403.
+--    3) Check whether the Content-Type is known. Otherwise return 415.
--- 7) Check whether the request has a known Accept. Otherwise return 406.
+--    4) Check whether that one deserializes the body. Otherwise return 400. If
--- 8) Check whether Accept-Language, Accept-Charset and Accept-Encoding exist and
+--    there was no Content-Type, try the first one of the API content-type list.
--- match. We can follow the webmachine order here.
+--    5) Check whether the request is authorized. Otherwise return a 401.
--- 9) Call the handler. Whatever it returns, we return.
+--    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
 -- }}}
+--
+

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