From 9c62a3b150eca9185c029ef72eb875da789ae4d8 Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Wed, 9 Sep 2015 13:29:52 -0700
Subject: [PATCH 1/6] Error order tests

---
 .../test/Servant/Server/ErrorSpec.hs          | 78 +++++++++++++++++++
 1 file changed, 78 insertions(+)
 create mode 100644 servant-server/test/Servant/Server/ErrorSpec.hs

diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs
new file mode 100644
index 00000000..eaefe761
--- /dev/null
+++ b/servant-server/test/Servant/Server/ErrorSpec.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+module Servant.Server.ErrorSpec (spec) where
+
+import Test.Hspec
+import Data.Proxy
+import Test.Hspec.Wai (request, with, shouldRespondWith)
+import Network.HTTP.Types (methodGet, methodPost)
+import Data.Aeson (encode)
+
+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.
+
+spec :: Spec
+spec = do
+    errorOrder
+
+
+type ErrorOrderApi = "home"
+                  :> ReqBody '[JSON] Int
+                  :> Capture "t" Int
+                  :> Post '[JSON] Int
+
+errorOrderApi :: Proxy ErrorOrderApi
+errorOrderApi = Proxy
+
+errorOrderServer :: Server ErrorOrderApi
+errorOrderServer = \_ _ -> return 10
+
+errorOrder :: Spec
+errorOrder = describe "HTTP error order"
+           $ with (return $ serve errorOrderApi errorOrderServer) $ do
+    let badContentType  = ("Content-Type", "text/plain")
+        badAccept       = ("Accept", "text/plain")
+        badMethod       = methodGet
+        badUrl          = "home/nonexistent"
+        badBody         = "nonsense"
+        goodContentType = ("Content-Type", "application/json")
+        goodAccept      = ("Accept", "application/json")
+        goodMethod      = methodPost
+        goodUrl         = "home/5"
+        goodBody        = encode (5 :: Int)
+
+    it "has 404 as its highest priority error" $ do
+        request badMethod badUrl [badContentType, badAccept] badBody
+            `shouldRespondWith` 404
+
+    it "has 405 as its second highest priority error" $ do
+        request badMethod goodUrl [badContentType, badAccept] badBody
+            `shouldRespondWith` 405
+
+    it "has 415 as its third highest priority error" $ do
+        request goodMethod goodUrl [badContentType, badAccept] badBody
+            `shouldRespondWith` 415
+
+    it "has 400 as its fourth highest priority error" $ do
+        request goodMethod goodUrl [goodContentType, badAccept] badBody
+            `shouldRespondWith` 400
+
+    it "has 406 as its fifth highest priority error" $ do
+        request goodMethod goodUrl [goodContentType, badAccept] goodBody
+            `shouldRespondWith` 406
+
+

From 153de01a629077e2e668078b3fa4dfaca4079ae0 Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Wed, 9 Sep 2015 14:17:17 -0700
Subject: [PATCH 2/6] Error retry tests

        Mime[Un]Render instances for PlainText String
        pragmas and formatting
---
 .../test/Servant/Server/ErrorSpec.hs          | 147 +++++++++++++-----
 servant/CHANGELOG.md                          |   1 +
 servant/src/Servant/API/ContentTypes.hs       |   9 ++
 3 files changed, 121 insertions(+), 36 deletions(-)

diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs
index eaefe761..008642b7 100644
--- a/servant-server/test/Servant/Server/ErrorSpec.hs
+++ b/servant-server/test/Servant/Server/ErrorSpec.hs
@@ -1,15 +1,19 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Servant.Server.ErrorSpec (spec) where
 
-import Test.Hspec
-import Data.Proxy
-import Test.Hspec.Wai (request, with, shouldRespondWith)
-import Network.HTTP.Types (methodGet, methodPost)
-import Data.Aeson (encode)
+import           Data.Aeson                 (encode)
+import qualified Data.ByteString.Lazy.Char8 as BC
+import           Control.Monad.Trans.Either (left)
+import           Data.Proxy
+import           Network.HTTP.Types         (methodGet, methodPost)
+import           Test.Hspec
+import           Test.Hspec.Wai
 
-import Servant
+import           Servant
 
 
 -- 1) Check whether one or more endpoints have the right path. Otherwise return 404.
@@ -26,9 +30,12 @@ import Servant
 -- 9) Call the handler. Whatever it returns, we return.
 
 spec :: Spec
-spec = do
+spec = describe "HTTP Errors" $ do
     errorOrder
+    errorRetry
 
+------------------------------------------------------------------------------
+-- * Error Order {{{
 
 type ErrorOrderApi = "home"
                   :> ReqBody '[JSON] Int
@@ -39,40 +46,108 @@ errorOrderApi :: Proxy ErrorOrderApi
 errorOrderApi = Proxy
 
 errorOrderServer :: Server ErrorOrderApi
-errorOrderServer = \_ _ -> return 10
+errorOrderServer = \_ _ -> left err402
 
 errorOrder :: Spec
 errorOrder = describe "HTTP error order"
            $ with (return $ serve errorOrderApi errorOrderServer) $ do
-    let badContentType  = ("Content-Type", "text/plain")
-        badAccept       = ("Accept", "text/plain")
-        badMethod       = methodGet
-        badUrl          = "home/nonexistent"
-        badBody         = "nonsense"
-        goodContentType = ("Content-Type", "application/json")
-        goodAccept      = ("Accept", "application/json")
-        goodMethod      = methodPost
-        goodUrl         = "home/5"
-        goodBody        = encode (5 :: Int)
+  let badContentType  = ("Content-Type", "text/plain")
+      badAccept       = ("Accept", "text/plain")
+      badMethod       = methodGet
+      badUrl          = "home/nonexistent"
+      badBody         = "nonsense"
+      goodContentType = ("Content-Type", "application/json")
+      goodAccept      = ("Accept", "application/json")
+      goodMethod      = methodPost
+      goodUrl         = "home/5"
+      goodBody        = encode (5 :: Int)
 
-    it "has 404 as its highest priority error" $ do
-        request badMethod badUrl [badContentType, badAccept] badBody
-            `shouldRespondWith` 404
+  it "has 404 as its highest priority error" $ do
+    request badMethod badUrl [badContentType, badAccept] badBody
+      `shouldRespondWith` 404
 
-    it "has 405 as its second highest priority error" $ do
-        request badMethod goodUrl [badContentType, badAccept] badBody
-            `shouldRespondWith` 405
+  it "has 405 as its second highest priority error" $ do
+    request badMethod goodUrl [badContentType, badAccept] badBody
+      `shouldRespondWith` 405
 
-    it "has 415 as its third highest priority error" $ do
-        request goodMethod goodUrl [badContentType, badAccept] badBody
-            `shouldRespondWith` 415
+  it "has 415 as its third highest priority error" $ do
+    request goodMethod goodUrl [badContentType, badAccept] badBody
+      `shouldRespondWith` 415
 
-    it "has 400 as its fourth highest priority error" $ do
-        request goodMethod goodUrl [goodContentType, badAccept] badBody
-            `shouldRespondWith` 400
+  it "has 400 as its fourth highest priority error" $ do
+    request goodMethod goodUrl [goodContentType, badAccept] badBody
+      `shouldRespondWith` 400
 
-    it "has 406 as its fifth highest priority error" $ do
-        request goodMethod goodUrl [goodContentType, badAccept] goodBody
-            `shouldRespondWith` 406
+  it "has 406 as its fifth highest priority error" $ do
+    request goodMethod goodUrl [goodContentType, badAccept] goodBody
+      `shouldRespondWith` 406
 
+  it "returns handler errors as its lower priority errors" $ do
+    request goodMethod goodUrl [goodContentType, goodAccept] goodBody
+      `shouldRespondWith` 402
 
+-- }}}
+------------------------------------------------------------------------------
+-- * Error Retry {{{
+
+type ErrorRetryApi
+     = "a" :> ReqBody '[JSON] Int      :> Post '[JSON] Int                -- 0
+  :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int                -- 1
+  :<|> "a" :> ReqBody '[JSON] Int      :> Post '[PlainText] Int           -- 2
+  :<|> "a" :> ReqBody '[JSON] String   :> Post '[JSON] Int                -- 3
+  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 4
+  :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 5
+  :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 6
+
+errorRetryApi :: Proxy ErrorRetryApi
+errorRetryApi = Proxy
+
+errorRetryServer :: Server ErrorRetryApi
+errorRetryServer
+     = (\_ -> return 0)
+  :<|> (\_ -> return 1)
+  :<|> (\_ -> return 2)
+  :<|> (\_ -> return 3)
+  :<|> (\_ -> return 4)
+  :<|> (\_ -> return 5)
+  :<|> (\_ -> return 6)
+
+errorRetry :: Spec
+errorRetry = describe "Handler search"
+           $ with (return $ serve errorRetryApi errorRetryServer) $ do
+  let plainCT     = ("Content-Type", "text/plain")
+      plainAccept = ("Accept", "text/plain")
+      jsonCT      = ("Content-Type", "application/json")
+      jsonAccept  = ("Accept", "application/json")
+      jsonBody    = encode (1797 :: Int)
+
+  it "should continue when URLs don't match" $ do
+    request methodPost "" [jsonCT, jsonAccept] jsonBody
+     `shouldRespondWith` 201 { matchBody = Just $ encode (5 :: Int) }
+
+  it "should continue when methods don't match" $ do
+    request methodGet "a" [jsonCT, jsonAccept] jsonBody
+     `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }
+
+  it "should not continue when Content-Types don't match" $ do
+    request methodPost "a" [plainCT, jsonAccept] jsonBody
+     `shouldRespondWith` 415
+
+  it "should not continue when body can't be deserialized" $ do
+    request methodPost "a" [jsonCT, jsonAccept] (encode ("nonsense" :: String))
+     `shouldRespondWith` 400
+
+  it "should not continue when Accepts don't match" $ do
+    request methodPost "a" [jsonCT, plainAccept] jsonBody
+     `shouldRespondWith` 406
+
+-- }}}
+------------------------------------------------------------------------------
+-- * Instances {{{
+
+instance MimeUnrender PlainText Int where
+    mimeUnrender _ = Right . read . BC.unpack
+
+instance MimeRender PlainText Int where
+    mimeRender _ = BC.pack . show
+-- }}}
diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md
index 012866f6..ddbe1a90 100644
--- a/servant/CHANGELOG.md
+++ b/servant/CHANGELOG.md
@@ -6,6 +6,7 @@ HEAD
 * Add more instances for (:<|>)
 * Use `http-api-data` instead of `Servant.Common.Text`
 * Remove matrix params.
+* Add PlainText String MimeRender and MimeUnrender instances.
 
 0.4.2
 -----
diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs
index cf882dfc..db8eb61e 100644
--- a/servant/src/Servant/API/ContentTypes.hs
+++ b/servant/src/Servant/API/ContentTypes.hs
@@ -80,6 +80,7 @@ import qualified Data.ByteString                  as BS
 import           Data.ByteString.Lazy             (ByteString, fromStrict,
                                                    toStrict)
 import qualified Data.ByteString.Lazy             as B
+import qualified Data.ByteString.Lazy.Char8       as BC
 import           Data.Monoid
 import           Data.String.Conversions          (cs)
 import qualified Data.Text                        as TextS
@@ -279,6 +280,10 @@ instance MimeRender PlainText TextL.Text where
 instance MimeRender PlainText TextS.Text where
     mimeRender _ = fromStrict . TextS.encodeUtf8
 
+-- | @BC.pack@
+instance MimeRender PlainText String where
+    mimeRender _ = BC.pack
+
 -- | @id@
 instance MimeRender OctetStream ByteString where
     mimeRender _ = id
@@ -328,6 +333,10 @@ instance MimeUnrender PlainText TextL.Text where
 instance MimeUnrender PlainText TextS.Text where
     mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict
 
+-- | @Right . BC.unpack@
+instance MimeUnrender PlainText String where
+    mimeUnrender _ = Right . BC.unpack
+
 -- | @Right . id@
 instance MimeUnrender OctetStream ByteString where
     mimeUnrender _ = Right . id

From a3b5652ab9604759a62ecc5e07f02a35566a359c Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Wed, 9 Sep 2015 23:49:19 -0700
Subject: [PATCH 3/6] Refactor RouteResult.

        Fix rerouting tests
        Fix 405 > 404 issue with Capture.
        Remove ServantErrWithPriority and Monoid instance
        More tests
        Update auth-combinator for routing changes
---
 .../auth-combinator/auth-combinator.hs        |   5 +-
 servant-server/src/Servant/Server.hs          |   2 +-
 servant-server/src/Servant/Server/Internal.hs |  32 ++---
 .../src/Servant/Server/Internal/Router.hs     |  15 ++-
 .../Server/Internal/RoutingApplication.hs     | 109 ++++++------------
 .../src/Servant/Server/Internal/ServantErr.hs |   2 +-
 .../test/Servant/Server/ErrorSpec.hs          |  94 +++++++++++----
 servant-server/test/Servant/ServerSpec.hs     |  67 ++---------
 servant/test/Servant/API/ContentTypesSpec.hs  |  15 +++
 9 files changed, 165 insertions(+), 176 deletions(-)

diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs
index c82510f3..e183b82e 100644
--- a/servant-examples/auth-combinator/auth-combinator.hs
+++ b/servant-examples/auth-combinator/auth-combinator.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
+
 import           Data.Aeson
 import           Data.ByteString          (ByteString)
 import           Data.Text                (Text)
@@ -31,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 $ failWith $ HttpError status401 (Just "Missing auth header.")
+        Nothing -> return $! failFatallyWith err401 { errBody = "Missing auth header" }
         Just v  -> do
           authGranted <- isGoodCookie v
           if authGranted
             then a
-            else return $ failWith $ HttpError status403 (Just "Invalid cookie.")
+            else return $! failFatallyWith err403 { errBody = "Invalid cookie" }
 
 type PrivateAPI = Get '[JSON] [PrivateData]
 
diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs
index 2a886683..eadd5174 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 (RR (Right server)))))
+serve p server = toApplication (runRouter (route p (return (HandlerVal server))))
 
 
 -- Documentation
diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
index c5e1cf70..3d85eb81 100644
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@@ -113,11 +113,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
      a -> ServerT sublayout m
 
   route Proxy subserver =
-    DynamicRouter $ \ first ->
-      route (Proxy :: Proxy sublayout)
-            (case captured captureProxy first of
-               Nothing  -> return $ failWith NotFound
-               Just v   -> feedTo subserver v)
+    DynamicRouter $ \ first -> case captured captureProxy first of
+       Nothing  -> LeafRouter (\_ r -> r $ failWith err404)
+       Just v   -> route (Proxy :: Proxy sublayout) (feedTo subserver v)
+
     where captureProxy = Proxy :: Proxy (Capture capture a)
 
 allowedMethodHead :: Method -> Request -> Bool
@@ -131,7 +130,7 @@ processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
                     -> Maybe [(HeaderName, B.ByteString)]
                     -> Request -> RouteResult Response
 processMethodRouter handleA status method headers request = case handleA of
-  Nothing -> failWith UnsupportedMediaType
+  Nothing -> failFatallyWith err406
   Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy
     where
       bdy = if allowedMethodHead method request then "" else body
@@ -150,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 WrongMethod
-      | otherwise = respond $ failWith NotFound
+          respond $ failWith err405
+      | otherwise = respond $ failWith err404
 
 methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
                     => Method -> Proxy ctypes -> Status
@@ -167,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 WrongMethod
-      | otherwise = respond $ failWith NotFound
+          respond $ failWith err405
+      | otherwise = respond $ failWith err404
 
 methodRouterEmpty :: Method
                   -> IO (RouteResult (ExceptT ServantErr IO ()))
@@ -180,8 +179,8 @@ methodRouterEmpty method action = LeafRouter route'
           runAction action respond $ \ () ->
             succeedWith $ responseLBS noContent204 [] ""
       | pathIsEmpty request && requestMethod request /= method =
-          respond $ failWith WrongMethod
-      | otherwise = respond $ failWith NotFound
+          respond $ failWith err405
+      | otherwise = respond $ failWith err404
 
 -- | If you have a 'Delete' endpoint in your API,
 -- the handler for this endpoint is meant to delete
@@ -558,8 +557,9 @@ instance HasServer Raw where
   route Proxy rawApplication = LeafRouter $ \ request respond -> do
     r <- rawApplication
     case r of
-      RR (Left err)  -> respond $ failWith err
-      RR (Right app) -> app request (respond . succeedWith)
+      HandlerVal app  -> app request (respond . succeedWith)
+      Retriable  e    -> respond $ failWith e
+      NonRetriable e  -> respond $! failFatallyWith 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 $ failWith $ UnsupportedMediaType
-        Just (Left e) -> return $ failWith $ InvalidBody e
+        Nothing -> return $! failFatallyWith err415
+        Just (Left e) -> return $! failFatallyWith 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 6d41d6cd..e461133c 100644
--- a/servant-server/src/Servant/Server/Internal/Router.hs
+++ b/servant-server/src/Servant/Server/Internal/Router.hs
@@ -7,6 +7,8 @@ import qualified Data.Map                                   as M
 import           Data.Monoid                                ((<>))
 import           Data.Text                                  (Text)
 import           Network.Wai                                (Request, Response, pathInfo)
+import           Servant.Server.Internal.ServantErr
+import           Servant.Server.Internal.PathInfo
 import           Servant.Server.Internal.RoutingApplication
 
 type Router = Router' RoutingApplication
@@ -63,17 +65,24 @@ runRouter (StaticRouter table) request respond =
       | Just router <- M.lookup first table
       -> let request' = request { pathInfo = rest }
          in  runRouter router request' respond
-    _ -> respond $ failWith NotFound
+    _ -> respond $ failWith 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 NotFound
+    _ -> respond $ failWith 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 (mResponse1 <> mResponse2)
+             respond (highestPri mResponse1 mResponse2)
       else 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 x _ = x
diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
index 117ac97c..579ac0c3 100644
--- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
+++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                        #-}
+{-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TypeOperators              #-}
@@ -6,21 +7,17 @@ module Servant.Server.Internal.RoutingApplication where
 
 #if !MIN_VERSION_base(4,8,0)
 import           Control.Applicative                (Applicative, (<$>))
-import           Data.Monoid                        (Monoid, mappend, mempty)
+import           Data.Monoid                        (Monoid, mappend, mempty,
+                                                     (<>))
 #endif
 import           Control.Monad.Trans.Except         (ExceptT, runExceptT)
 import qualified Data.ByteString                    as B
 import qualified Data.ByteString.Lazy               as BL
 import           Data.IORef                         (newIORef, readIORef,
                                                      writeIORef)
-import           Data.Maybe                         (fromMaybe)
-import           Data.Monoid                        ((<>))
-import           Data.String                        (fromString)
-import           Network.HTTP.Types                 hiding (Header,
-                                                     ResponseHeaders)
 import           Network.Wai                        (Application, Request,
                                                      Response, ResponseReceived,
-                                                     requestBody, responseLBS,
+                                                     requestBody,
                                                      strictRequestBody)
 import           Servant.API                        ((:<|>) (..))
 import           Servant.Server.Internal.ServantErr
@@ -30,39 +27,12 @@ type RoutingApplication =
   -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
 
 -- | A wrapper around @'Either' 'RouteMismatch' a@.
-newtype RouteResult a =
-  RR { routeResult :: Either RouteMismatch a }
-  deriving (Eq, Show, Functor, Applicative)
-
--- | If we get a `Right`, it has precedence over everything else.
---
--- This in particular means that if we could get several 'Right's,
--- only the first we encounter would be taken into account.
-instance Monoid (RouteResult a) where
-  mempty = RR $ Left mempty
-
-  RR (Left x)  `mappend` RR (Left y)  = RR $ Left (x <> y)
-  RR (Left _)  `mappend` RR (Right y) = RR $ Right y
-  r            `mappend` _            = r
-
--- Note that the ordering of the constructors has great significance! It
--- determines the Ord instance and, consequently, the monoid instance.
-data RouteMismatch =
-    NotFound           -- ^ the usual "not found" error
-  | WrongMethod        -- ^ a more informative "you just got the HTTP method wrong" error
-  | UnsupportedMediaType -- ^ request body has unsupported media type
-  | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
-  | HttpError Status (Maybe BL.ByteString)  -- ^ an even even more informative arbitrary HTTP response code error.
-  deriving (Eq, Ord, Show)
-
-instance Monoid RouteMismatch where
-  mempty = NotFound
-  -- The following isn't great, since it picks @InvalidBody@ based on
-  -- alphabetical ordering, but any choice would be arbitrary.
-  --
-  -- "As one judge said to the other, 'Be just and if you can't be just, be
-  -- arbitrary'" -- William Burroughs
-  mappend = max
+data RouteResult a =
+    Retriable ServantErr      -- ^ Keep trying other paths. The @ServantErr@
+                              -- should only be 404 or 405.
+  | NonRetriable ServantErr   -- ^ Stop trying.
+  | HandlerVal a
+  deriving (Eq, Show, Read, Functor)
 
 data ReqBodyState = Uncalled
                   | Called !B.ByteString
@@ -91,55 +61,52 @@ toApplication ra request respond = do
                 writeIORef reqBodyRef $ Called bs
                 return B.empty
 
-  ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
+  ra request{ requestBody = memoReqBody } routingRespond
  where
-  routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
-  routingRespond (Left NotFound) =
-    respond $ responseLBS notFound404 [] "not found"
-  routingRespond (Left WrongMethod) =
-    respond $ responseLBS methodNotAllowed405 [] "method not allowed"
-  routingRespond (Left (InvalidBody err)) =
-    respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
-  routingRespond (Left UnsupportedMediaType) =
-    respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
-  routingRespond (Left (HttpError status body)) =
-    respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
-  routingRespond (Right response) =
-    respond response
+  routingRespond :: RouteResult Response -> IO ResponseReceived
+  routingRespond (Retriable err)    = respond $! responseServantErr err
+  routingRespond (NonRetriable err) = respond $! responseServantErr err
+  routingRespond (HandlerVal v)     = respond v
 
 runAction :: IO (RouteResult (ExceptT ServantErr IO a))
           -> (RouteResult Response -> IO r)
           -> (a -> RouteResult Response)
           -> IO r
-runAction action respond k = do
-  r <- action
-  go r
+runAction action respond k = action >>= go >>= respond
   where
-    go (RR (Right a))  = do
+    go (Retriable  e)   = return $! Retriable e
+    go (NonRetriable e) = return . succeedWith $! responseServantErr e
+    go (HandlerVal a)   = do
       e <- runExceptT a
-      respond $ case e of
-        Right x  -> k x
-        Left err -> succeedWith $ responseServantErr err
-    go (RR (Left err)) = respond $ failWith err
+      case e of
+        Left err -> return . succeedWith $! 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 (RR (Right (a :<|> _))) = RR (Right a)
-extractL (RR (Left err))         = RR (Left err)
+extractL (HandlerVal (a :<|> _)) = HandlerVal a
+extractL (Retriable x)           = Retriable x
+extractL (NonRetriable x)        = NonRetriable x
 
 extractR :: RouteResult (a :<|> b) -> RouteResult b
-extractR (RR (Right (_ :<|> b))) = RR (Right b)
-extractR (RR (Left err))         = RR (Left err)
+extractR (HandlerVal (_ :<|> b)) = HandlerVal b
+extractR (Retriable x)           = Retriable x
+extractR (NonRetriable x)        = NonRetriable x
 
-failWith :: RouteMismatch -> RouteResult a
-failWith = RR . Left
+-- | 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 = RR . Right
+succeedWith = HandlerVal
 
 isMismatch :: RouteResult a -> Bool
-isMismatch (RR (Left _)) = True
+isMismatch (Retriable _) = True
 isMismatch _             = False
-
diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs
index a308022e..6cfa3e90 100644
--- a/servant-server/src/Servant/Server/Internal/ServantErr.hs
+++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs
@@ -11,7 +11,7 @@ data ServantErr = ServantErr { errHTTPCode     :: Int
                              , errReasonPhrase :: String
                              , errBody         :: LBS.ByteString
                              , errHeaders      :: [HTTP.Header]
-                             } deriving (Show, Eq)
+                             } deriving (Show, Eq, Read)
 
 responseServantErr :: ServantErr -> Response
 responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs
index 008642b7..30a8b41c 100644
--- a/servant-server/test/Servant/Server/ErrorSpec.hs
+++ b/servant-server/test/Servant/Server/ErrorSpec.hs
@@ -7,9 +7,9 @@ module Servant.Server.ErrorSpec (spec) where
 
 import           Data.Aeson                 (encode)
 import qualified Data.ByteString.Lazy.Char8 as BC
-import           Control.Monad.Trans.Either (left)
 import           Data.Proxy
-import           Network.HTTP.Types         (methodGet, methodPost)
+import           Network.HTTP.Types         (hAccept, hContentType, methodGet,
+                                             methodPost)
 import           Test.Hspec
 import           Test.Hspec.Wai
 
@@ -31,8 +31,9 @@ import           Servant
 
 spec :: Spec
 spec = describe "HTTP Errors" $ do
-    errorOrder
-    errorRetry
+    errorOrderSpec
+    errorRetrySpec
+    errorChoiceSpec
 
 ------------------------------------------------------------------------------
 -- * Error Order {{{
@@ -42,24 +43,24 @@ type ErrorOrderApi = "home"
                   :> Capture "t" Int
                   :> Post '[JSON] Int
 
+
 errorOrderApi :: Proxy ErrorOrderApi
 errorOrderApi = Proxy
 
 errorOrderServer :: Server ErrorOrderApi
-errorOrderServer = \_ _ -> left err402
+errorOrderServer = \_ _ -> return 5
 
-errorOrder :: Spec
-errorOrder = describe "HTTP error order"
+errorOrderSpec :: Spec
+errorOrderSpec = describe "HTTP error order"
            $ with (return $ serve errorOrderApi errorOrderServer) $ do
-  let badContentType  = ("Content-Type", "text/plain")
-      badAccept       = ("Accept", "text/plain")
+  let badContentType  = (hContentType, "text/plain")
+      badAccept       = (hAccept, "text/plain")
       badMethod       = methodGet
       badUrl          = "home/nonexistent"
       badBody         = "nonsense"
-      goodContentType = ("Content-Type", "application/json")
-      goodAccept      = ("Accept", "application/json")
+      goodContentType = (hContentType, "application/json")
       goodMethod      = methodPost
-      goodUrl         = "home/5"
+      goodUrl         = "home/2"
       goodBody        = encode (5 :: Int)
 
   it "has 404 as its highest priority error" $ do
@@ -82,10 +83,6 @@ errorOrder = describe "HTTP error order"
     request goodMethod goodUrl [goodContentType, badAccept] goodBody
       `shouldRespondWith` 406
 
-  it "returns handler errors as its lower priority errors" $ do
-    request goodMethod goodUrl [goodContentType, goodAccept] goodBody
-      `shouldRespondWith` 402
-
 -- }}}
 ------------------------------------------------------------------------------
 -- * Error Retry {{{
@@ -95,9 +92,10 @@ type ErrorRetryApi
   :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int                -- 1
   :<|> "a" :> ReqBody '[JSON] Int      :> Post '[PlainText] Int           -- 2
   :<|> "a" :> ReqBody '[JSON] String   :> Post '[JSON] Int                -- 3
-  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 4
-  :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 5
+  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 4
+  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 5
   :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 6
+  :<|>        ReqBody '[JSON] Int      :> Post '[JSON] Int                -- 7
 
 errorRetryApi :: Proxy ErrorRetryApi
 errorRetryApi = Proxy
@@ -111,19 +109,21 @@ errorRetryServer
   :<|> (\_ -> return 4)
   :<|> (\_ -> return 5)
   :<|> (\_ -> return 6)
+  :<|> (\_ -> return 7)
 
-errorRetry :: Spec
-errorRetry = describe "Handler search"
+errorRetrySpec :: Spec
+errorRetrySpec = describe "Handler search"
            $ with (return $ serve errorRetryApi errorRetryServer) $ do
-  let plainCT     = ("Content-Type", "text/plain")
-      plainAccept = ("Accept", "text/plain")
-      jsonCT      = ("Content-Type", "application/json")
-      jsonAccept  = ("Accept", "application/json")
+
+  let plainCT     = (hContentType, "text/plain")
+      plainAccept = (hAccept, "text/plain")
+      jsonCT      = (hContentType, "application/json")
+      jsonAccept  = (hAccept, "application/json")
       jsonBody    = encode (1797 :: Int)
 
   it "should continue when URLs don't match" $ do
     request methodPost "" [jsonCT, jsonAccept] jsonBody
-     `shouldRespondWith` 201 { matchBody = Just $ encode (5 :: Int) }
+     `shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) }
 
   it "should continue when methods don't match" $ do
     request methodGet "a" [jsonCT, jsonAccept] jsonBody
@@ -141,6 +141,50 @@ errorRetry = describe "Handler search"
     request methodPost "a" [jsonCT, plainAccept] jsonBody
      `shouldRespondWith` 406
 
+-- }}}
+------------------------------------------------------------------------------
+-- * Error Choice {{{
+
+type ErrorChoiceApi
+     = "path0" :> Get '[JSON] Int                                     -- 0
+  :<|> "path1" :> Post '[JSON] Int                                    -- 1
+  :<|> "path2" :> Post '[PlainText] Int                               -- 2
+  :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int        -- 3
+  :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int  -- 4
+             :<|>  ReqBody '[PlainText] Int :> Post '[JSON] Int)      -- 5
+
+errorChoiceApi :: Proxy ErrorChoiceApi
+errorChoiceApi = Proxy
+
+errorChoiceServer :: Server ErrorChoiceApi
+errorChoiceServer = return 0
+               :<|> return 1
+               :<|> return 2
+               :<|> (\_ -> return 3)
+               :<|> (\_ -> return 4)
+               :<|> (\_ -> return 5)
+
+
+errorChoiceSpec :: Spec
+errorChoiceSpec = describe "Multiple handlers return errors"
+                $ with (return $ serve errorChoiceApi errorChoiceServer) $ do
+
+  it "should respond with 404 if no path matches" $ do
+    request methodGet "" [] "" `shouldRespondWith` 404
+
+  it "should respond with 405 if a path but not method matches" $ do
+    request methodGet "path2" [] "" `shouldRespondWith` 405
+
+  it "should respond with the corresponding error if path and method match" $ do
+    request methodPost "path3" [(hContentType, "text/plain;charset=utf-8")] ""
+      `shouldRespondWith` 415
+    request methodPost "path3" [(hContentType, "application/json")] ""
+      `shouldRespondWith` 400
+    request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"),
+                                (hAccept, "application/json")] ""
+      `shouldRespondWith` 406
+
+
 -- }}}
 ------------------------------------------------------------------------------
 -- * Instances {{{
diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs
index 9926dea5..c9bf11ce 100644
--- a/servant-server/test/Servant/ServerSpec.hs
+++ b/servant-server/test/Servant/ServerSpec.hs
@@ -17,7 +17,6 @@ import           Control.Monad.Trans.Except (ExceptT, throwE)
 import           Data.Aeson                 (FromJSON, ToJSON, decode', encode)
 import           Data.ByteString.Conversion ()
 import           Data.Char                  (toUpper)
-import           Data.Monoid                ((<>))
 import           Data.Proxy                 (Proxy (Proxy))
 import           Data.String                (fromString)
 import           Data.String.Conversions    (cs)
@@ -26,8 +25,7 @@ import           GHC.Generics               (Generic)
 import           Network.HTTP.Types         (hAccept, hContentType,
                                              methodDelete, methodGet, methodHead,
                                              methodPatch, methodPost, methodPut,
-                                             ok200, parseQuery, status409,
-                                             Status(..))
+                                             ok200, parseQuery, Status(..))
 import           Network.Wai                (Application, Request, pathInfo,
                                              queryString, rawQueryString,
                                              responseLBS, responseBuilder)
@@ -99,7 +97,6 @@ spec = do
   rawSpec
   unionSpec
   prioErrorsSpec
-  errorsSpec
   routerSpec
   responseHeadersSpec
   miscReqCombinatorsSpec
@@ -158,9 +155,9 @@ getSpec = do
       it "returns 204 if the type is '()'" $ do
         get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }
 
-      it "returns 415 if the Accept header is not supported" $ do
+      it "returns 406 if the Accept header is not supported" $ do
         Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
-          `shouldRespondWith` 415
+          `shouldRespondWith` 406
 
 
 headSpec :: Spec
@@ -186,9 +183,9 @@ headSpec = do
         response <- Test.Hspec.Wai.request methodHead "/empty" [] ""
         return response `shouldRespondWith` ""{ matchStatus = 204 }
 
-      it "returns 415 if the Accept header is not supported" $ do
+      it "returns 406 if the Accept header is not supported" $ do
         Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
-          `shouldRespondWith` 415
+          `shouldRespondWith` 406
 
 
 type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
@@ -311,7 +308,7 @@ postSpec = do
       it "returns 204 if the type is '()'" $ do
         post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
 
-      it "responds with 415 if the requested media type is unsupported" $ do
+      it "responds with 415 if the request body media type is unsupported" $ do
         let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
                                                             , "application/nonsense")]
         post'' "/" "anything at all" `shouldRespondWith` 415
@@ -353,7 +350,7 @@ putSpec = do
       it "returns 204 if the type is '()'" $ do
         put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
 
-      it "responds with 415 if the requested media type is unsupported" $ do
+      it "responds with 415 if the request body media type is unsupported" $ do
         let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
                                                             , "application/nonsense")]
         put'' "/" "anything at all" `shouldRespondWith` 415
@@ -395,7 +392,7 @@ patchSpec = do
       it "returns 204 if the type is '()'" $ do
         patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
 
-      it "responds with 415 if the requested media type is unsupported" $ do
+      it "responds with 415 if the request body media type is unsupported" $ do
         let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
                                                             , "application/nonsense")]
         patch'' "/" "anything at all" `shouldRespondWith` 415
@@ -524,10 +521,10 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
         Test.Hspec.Wai.request method "blahblah" [] ""
           `shouldRespondWith` 404
 
-    it "returns 415 if the Accept header is not supported" $
+    it "returns 406 if the Accept header is not supported" $
       forM_ methods $ \(method,_) ->
         Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
-          `shouldRespondWith` 415
+          `shouldRespondWith` 406
 
 type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer
 
@@ -578,50 +575,6 @@ prioErrorsSpec = describe "PrioErrors" $ do
     check put' "/bar" vjson 404
     check put' "/foo" vjson 405
 
--- | Test server error functionality.
-errorsSpec :: Spec
-errorsSpec = do
-  let he = HttpError status409 (Just "A custom error")
-  let ib = InvalidBody "The body is invalid"
-  let wm = WrongMethod
-  let nf = NotFound
-
-  describe "Servant.Server.Internal.RouteMismatch" $ do
-    it "HttpError > *" $ do
-      ib <> he `shouldBe` he
-      wm <> he `shouldBe` he
-      nf <> he `shouldBe` he
-
-      he <> ib `shouldBe` he
-      he <> wm `shouldBe` he
-      he <> nf `shouldBe` he
-
-    it "HE > InvalidBody > (WM,NF)" $ do
-      he <> ib `shouldBe` he
-      wm <> ib `shouldBe` ib
-      nf <> ib `shouldBe` ib
-
-      ib <> he `shouldBe` he
-      ib <> wm `shouldBe` ib
-      ib <> nf `shouldBe` ib
-
-    it "HE > IB > WrongMethod > NF" $ do
-      he <> wm `shouldBe` he
-      ib <> wm `shouldBe` ib
-      nf <> wm `shouldBe` wm
-
-      wm <> he `shouldBe` he
-      wm <> ib `shouldBe` ib
-      wm <> nf `shouldBe` wm
-
-    it "* > NotFound" $ do
-      he <> nf `shouldBe` he
-      ib <> nf `shouldBe` ib
-      wm <> nf `shouldBe` wm
-
-      nf <> he `shouldBe` he
-      nf <> ib `shouldBe` ib
-      nf <> wm `shouldBe` wm
 
 routerSpec :: Spec
 routerSpec = do
diff --git a/servant/test/Servant/API/ContentTypesSpec.hs b/servant/test/Servant/API/ContentTypesSpec.hs
index 76faea67..062b6b2b 100644
--- a/servant/test/Servant/API/ContentTypesSpec.hs
+++ b/servant/test/Servant/API/ContentTypesSpec.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE PolyKinds             #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Servant.API.ContentTypesSpec where
 
@@ -34,6 +35,20 @@ import           Servant.API.ContentTypes
 spec :: Spec
 spec = describe "Servant.API.ContentTypes" $ do
 
+    describe "handleAcceptH" $ do
+        let p = Proxy :: Proxy '[PlainText]
+
+        it "matches any charset if none were provided" $ do
+            let without = handleAcceptH p (AcceptHeader "text/plain")
+                with    = handleAcceptH p (AcceptHeader "text/plain;charset=utf-8")
+                wisdom  = "ubi sub ubi" :: String
+            without wisdom `shouldBe` with wisdom
+
+        it "does not match non utf-8 charsets" $  do
+            let badCharset = handleAcceptH p (AcceptHeader "text/plain;charset=whoknows")
+                s          = "cheese" :: String
+            badCharset s `shouldBe` Nothing
+
     describe "The JSON Content-Type type" $ do
         let p = Proxy :: Proxy JSON
 

From ccadba81ec85222b19b4c3555bf0ecebd464762d Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Tue, 15 Sep 2015 11:37:17 +0200
Subject: [PATCH 4/6] Cleanup errorspec description of routing, changelog.

        Review fixes
---
 .../auth-combinator/auth-combinator.hs        |  4 +-
 servant-server/CHANGELOG.md                   |  5 ++
 servant-server/src/Servant/Server.hs          |  2 +-
 servant-server/src/Servant/Server/Internal.hs | 58 ++++++-------
 .../src/Servant/Server/Internal/Router.hs     | 26 +++---
 .../Server/Internal/RoutingApplication.hs     | 49 ++++-------
 .../test/Servant/Server/ErrorSpec.hs          | 86 +++++++++++++++----
 servant-server/test/Servant/ServerSpec.hs     | 69 ++++-----------
 8 files changed, 154 insertions(+), 145 deletions(-)

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

From 1398d1f5e1584340d2c0f027892ff4321b06446d Mon Sep 17 00:00:00 2001
From: Andres Loeh <andres@well-typed.com>
Date: Wed, 16 Sep 2015 22:07:55 +0200
Subject: [PATCH 5/6] More systematic approach to delayed checks.

This introduces a `Delayed` type in `RoutingApplication.hs` that
contains a handler together with delayed checks. There are several
blocks of delayed checks, so that we can ultimately execute them in the
order we desire.

The process is documented in more detail in `RoutingApplication.hs`.
---
 servant-docs/src/Servant/Docs/Internal.hs     |  53 ++---
 .../auth-combinator/auth-combinator.hs        |  20 +-
 servant-server/servant-server.cabal           |   1 +
 servant-server/src/Servant/Server.hs          |   5 +-
 servant-server/src/Servant/Server/Internal.hs | 127 ++++++-----
 .../src/Servant/Server/Internal/Router.hs     |  24 ++-
 .../Server/Internal/RoutingApplication.hs     | 203 ++++++++++++++++--
 .../test/Servant/Server/ErrorSpec.hs          |  35 ++-
 servant-server/test/Servant/ServerSpec.hs     |  21 +-
 servant/src/Servant/API/ContentTypes.hs       |  25 ++-
 10 files changed, 342 insertions(+), 172 deletions(-)

diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs
index 53ae472d..33cb86a0 100644
--- a/servant-docs/src/Servant/Docs/Internal.hs
+++ b/servant-docs/src/Servant/Docs/Internal.hs
@@ -496,19 +496,6 @@ sampleByteStrings ctypes@Proxy Proxy =
         enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
     in concatMap enc samples'
 
--- | Generate a list of 'MediaType' values describing the content types
--- accepted by an API component.
-class SupportedTypes (list :: [*]) where
-    supportedTypes :: Proxy list -> [M.MediaType]
-
-instance SupportedTypes '[] where
-    supportedTypes Proxy = []
-
-instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest)
-  where
-    supportedTypes Proxy =
-        contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest)
-
 -- | The class that helps us automatically get documentation
 --   for GET parameters.
 --
@@ -709,14 +696,14 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPABLe #-}
 #endif
-        (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+        (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
     => HasDocs (Delete cts a) where
   docsFor Proxy (endpoint, action) DocOptions{..} =
     single endpoint' action'
 
     where endpoint' = endpoint & method .~ DocDELETE
           action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
-                           & response.respTypes .~ supportedTypes t
+                           & response.respTypes .~ allMime t
           t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
@@ -724,7 +711,7 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-        (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts
+        (ToSample a, IsNonEmpty cts, AllMimeRender cts a
          , AllHeaderSamples ls , GetHeaders (HList ls) )
     => HasDocs (Delete cts (Headers ls a)) where
   docsFor Proxy (endpoint, action) DocOptions{..} =
@@ -733,7 +720,7 @@ instance
     where hdrs = allHeaderToSample (Proxy :: Proxy ls)
           endpoint' = endpoint & method .~ DocDELETE
           action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
-                           & response.respTypes .~ supportedTypes t
+                           & response.respTypes .~ allMime t
                            & response.respHeaders .~ hdrs
           t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
@@ -742,14 +729,14 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPABLe #-}
 #endif
-        (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+        (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
     => HasDocs (Get cts a) where
   docsFor Proxy (endpoint, action) DocOptions{..} =
     single endpoint' action'
 
     where endpoint' = endpoint & method .~ DocGET
           action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
-                           & response.respTypes .~ supportedTypes t
+                           & response.respTypes .~ allMime t
           t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
@@ -757,7 +744,7 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-        (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts
+        (ToSample a, IsNonEmpty cts, AllMimeRender cts a
          , AllHeaderSamples ls , GetHeaders (HList ls) )
     => HasDocs (Get cts (Headers ls a)) where
   docsFor Proxy (endpoint, action) DocOptions{..} =
@@ -766,7 +753,7 @@ instance
     where hdrs = allHeaderToSample (Proxy :: Proxy ls)
           endpoint' = endpoint & method .~ DocGET
           action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
-                           & response.respTypes .~ supportedTypes t
+                           & response.respTypes .~ allMime t
                            & response.respHeaders .~ hdrs
           t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
@@ -784,14 +771,14 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPABLE #-}
 #endif
-        (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+        (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
     => HasDocs (Post cts a) where
   docsFor Proxy (endpoint, action) DocOptions{..} =
     single endpoint' action'
 
     where endpoint' = endpoint & method .~ DocPOST
           action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
-                           & response.respTypes .~ supportedTypes t
+                           & response.respTypes .~ allMime t
                            & response.respStatus .~ 201
           t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
@@ -800,7 +787,7 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-         (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts
+         (ToSample a, IsNonEmpty cts, AllMimeRender cts a
          , AllHeaderSamples ls , GetHeaders (HList ls) )
     => HasDocs (Post cts (Headers ls a)) where
   docsFor Proxy (endpoint, action) DocOptions{..} =
@@ -809,7 +796,7 @@ instance
     where hdrs = allHeaderToSample (Proxy :: Proxy ls)
           endpoint' = endpoint & method .~ DocPOST
           action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
-                           & response.respTypes .~ supportedTypes t
+                           & response.respTypes .~ allMime t
                            & response.respStatus .~ 201
                            & response.respHeaders .~ hdrs
           t = Proxy :: Proxy cts
@@ -819,14 +806,14 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPABLE #-}
 #endif
-        (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
+        (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
     => HasDocs (Put cts a) where
   docsFor Proxy (endpoint, action) DocOptions{..} =
     single endpoint' action'
 
     where endpoint' = endpoint & method .~ DocPUT
           action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
-                           & response.respTypes .~ supportedTypes t
+                           & response.respTypes .~ allMime t
                            & response.respStatus .~ 200
           t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
@@ -835,8 +822,8 @@ instance
 #if MIN_VERSION_base(4,8,0)
          {-# OVERLAPPING #-}
 #endif
-        (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts
-         , AllHeaderSamples ls , GetHeaders (HList ls) )
+        ( ToSample a, IsNonEmpty cts, AllMimeRender cts a,
+          AllHeaderSamples ls , GetHeaders (HList ls) )
     => HasDocs (Put cts (Headers ls a)) where
   docsFor Proxy (endpoint, action) DocOptions{..} =
     single endpoint' action'
@@ -844,7 +831,7 @@ instance
     where hdrs = allHeaderToSample (Proxy :: Proxy ls)
           endpoint' = endpoint & method .~ DocPUT
           action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
-                           & response.respTypes .~ supportedTypes t
+                           & response.respTypes .~ allMime t
                            & response.respStatus .~ 200
                            & response.respHeaders .~ hdrs
           t = Proxy :: Proxy cts
@@ -890,8 +877,7 @@ instance HasDocs Raw where
 -- example data. However, there's no reason to believe that the instances of
 -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
 -- both are even defined) for any particular type.
-instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout
-         , SupportedTypes cts)
+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
       => HasDocs (ReqBody cts a :> sublayout) where
 
   docsFor Proxy (endpoint, action) =
@@ -899,7 +885,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout
 
     where sublayoutP = Proxy :: Proxy sublayout
           action' = action & rqbody .~ sampleByteString t p
-                           & rqtypes .~ supportedTypes t
+                           & rqtypes .~ allMime t
           t = Proxy :: Proxy cts
           p = Proxy :: Proxy a
 
@@ -957,4 +943,3 @@ instance ToSample a => ToSample (Product a)
 instance ToSample a => ToSample (First a)
 instance ToSample a => ToSample (Last a)
 instance ToSample a => ToSample (Dual a)
-
diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs
index c0b4299d..ec152782 100644
--- a/servant-examples/auth-combinator/auth-combinator.hs
+++ b/servant-examples/auth-combinator/auth-combinator.hs
@@ -10,7 +10,6 @@ import           Data.Aeson
 import           Data.ByteString          (ByteString)
 import           Data.Text                (Text)
 import           GHC.Generics
-import           Network.HTTP.Types
 import           Network.Wai
 import           Network.Wai.Handler.Warp
 import           Servant
@@ -29,15 +28,16 @@ data AuthProtected
 instance HasServer rest => HasServer (AuthProtected :> rest) where
   type ServerT (AuthProtected :> rest) m = ServerT rest m
 
-  route Proxy a = WithRequest $ \ request ->
-    route (Proxy :: Proxy rest) $ do
-      case lookup "Cookie" (requestHeaders request) of
-        Nothing -> return $! FailFatal err401 { errBody = "Missing auth header" }
-        Just v  -> do
-          authGranted <- isGoodCookie v
-          if authGranted
-            then a
-            else return $ FailFatal err403 { errBody = "Invalid cookie" }
+  route Proxy subserver = WithRequest $ \ request ->
+    route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request
+      where
+        cookieCheck req = case lookup "Cookie" (requestHeaders req) of
+            Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }
+            Just v  -> do
+              authGranted <- isGoodCookie v
+              if authGranted
+                then return $ Route ()
+                else return $ FailFatal err403 { errBody = "Invalid cookie" }
 
 type PrivateAPI = Get '[JSON] [PrivateData]
 
diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal
index 1a7335d3..9b69d9c4 100644
--- a/servant-server/servant-server.cabal
+++ b/servant-server/servant-server.cabal
@@ -108,6 +108,7 @@ test-suite spec
     , network >= 2.6
     , QuickCheck
     , parsec
+    , safe
     , servant
     , servant-server
     , string-conversions
diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs
index f6781b66..a26941ea 100644
--- a/servant-server/src/Servant/Server.hs
+++ b/servant-server/src/Servant/Server.hs
@@ -103,7 +103,10 @@ 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 (Route server))))
+serve p server = toApplication (runRouter (route p d))
+  where
+    d = Delayed r r r (\ _ _ -> Route server)
+    r = return (Route ())
 
 
 -- Documentation
diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
index 6c717fa2..4200d052 100644
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@@ -46,7 +46,9 @@ import           Servant.API                 ((:<|>) (..), (:>), Capture,
                                               Raw, RemoteHost, ReqBody, Vault)
 import           Servant.API.ContentTypes    (AcceptHeader (..),
                                               AllCTRender (..),
-                                              AllCTUnrender (..))
+                                              AllCTUnrender (..),
+                                              AllMime,
+                                              canHandleAcceptH)
 import           Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
                                               getResponse)
 
@@ -60,7 +62,7 @@ import           Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe,
 class HasServer layout where
   type ServerT layout (m :: * -> *) :: *
 
-  route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router
+  route :: Proxy layout -> Delayed (Server layout) -> Router
 
 type Server layout = ServerT layout (ExceptT ServantErr IO)
 
@@ -81,8 +83,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
 
   type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
 
-  route Proxy server = choice (route pa (extractL <$> server))
-                              (route pb (extractR <$> server))
+  route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server))
+                              (route pb ((\ (_ :<|> b) -> b) <$> server))
     where pa = Proxy :: Proxy a
           pb = Proxy :: Proxy b
 
@@ -112,12 +114,15 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
   type ServerT (Capture capture a :> sublayout) m =
      a -> ServerT sublayout m
 
-  route Proxy subserver =
-    DynamicRouter $ \ first -> case captured captureProxy first of
-       Nothing  -> LeafRouter (\_ r -> r $ Fail err404)
-       Just v   -> route (Proxy :: Proxy sublayout) (feedTo subserver v)
-
-    where captureProxy = Proxy :: Proxy (Capture capture a)
+  route Proxy d =
+    DynamicRouter $ \ first ->
+        route (Proxy :: Proxy sublayout)
+              (addCapture d $ case captured captureProxy first of
+                 Nothing -> return $ Fail err404
+                 Just v  -> return $ Route v
+              )
+    where
+      captureProxy = Proxy :: Proxy (Capture capture a)
 
 allowedMethodHead :: Method -> Request -> Bool
 allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
@@ -130,56 +135,64 @@ processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
                     -> Maybe [(HeaderName, B.ByteString)]
                     -> Request -> RouteResult Response
 processMethodRouter handleA status method headers request = case handleA of
-  Nothing -> FailFatal err406
-  Just (contentT, body) -> Route $! responseLBS status hdrs bdy
+  Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
+  Just (contentT, body) -> Route $ responseLBS status hdrs bdy
     where
       bdy = if allowedMethodHead method request then "" else body
       hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
 
+methodCheck :: Method -> Request -> IO (RouteResult ())
+methodCheck method request
+  | allowedMethod method request = return $ Route ()
+  | otherwise                    = return $ Fail err405
+
+acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())
+acceptCheck proxy accH
+  | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()
+  | otherwise                                  = return $ Fail err406
+
 methodRouter :: (AllCTRender ctypes a)
              => Method -> Proxy ctypes -> Status
-             -> IO (RouteResult (ExceptT ServantErr IO a))
+             -> Delayed (ExceptT ServantErr IO a)
              -> Router
 methodRouter method proxy status action = LeafRouter route'
   where
     route' request respond
-      | pathIsEmpty request && allowedMethod method request = do
-          runAction action respond $ \ output -> do
-            let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-                handleA = handleAcceptH proxy (AcceptHeader accH) output
-            processMethodRouter handleA status method Nothing request
-      | pathIsEmpty request && requestMethod request /= method =
-          respond $ Fail err405
+      | pathIsEmpty request =
+          let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
+          in runAction (action `addMethodCheck` methodCheck method request
+                               `addAcceptCheck` acceptCheck proxy  accH
+                       ) 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
-                    -> IO (RouteResult (ExceptT ServantErr IO (Headers h v)))
+                    -> Delayed (ExceptT ServantErr IO (Headers h v))
                     -> Router
 methodRouterHeaders method proxy status action = LeafRouter route'
   where
     route' request respond
-      | pathIsEmpty request && allowedMethod method request = do
-        runAction action respond $ \ output -> do
-          let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
-              headers = getHeaders output
-              handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
-          processMethodRouter handleA status method (Just headers) request
-      | pathIsEmpty request && requestMethod request /= method =
-          respond $ Fail err405
+      | pathIsEmpty request =
+          let accH    = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
+          in runAction (action `addMethodCheck` methodCheck method request
+                               `addAcceptCheck` acceptCheck proxy  accH
+                       ) 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
 
 methodRouterEmpty :: Method
-                  -> IO (RouteResult (ExceptT ServantErr IO ()))
+                  -> Delayed (ExceptT ServantErr IO ())
                   -> Router
 methodRouterEmpty method action = LeafRouter route'
   where
     route' request respond
-      | pathIsEmpty request && allowedMethod method request = do
-          runAction action respond $ \ () ->
+      | pathIsEmpty request = do
+          runAction (addMethodCheck action (methodCheck method request)) respond $ \ () ->
             Route $! responseLBS noContent204 [] ""
-      | pathIsEmpty request && requestMethod request /= method =
-          respond $ Fail err405
       | otherwise = respond $ Fail err404
 
 -- | If you have a 'Delete' endpoint in your API,
@@ -300,7 +313,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
 
   route Proxy subserver = WithRequest $ \ request ->
     let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
-    in  route (Proxy :: Proxy sublayout) (feedTo subserver mheader)
+    in  route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
     where str = fromString $ symbolVal (Proxy :: Proxy sym)
 
 -- | When implementing the handler for a 'Post' endpoint,
@@ -472,7 +485,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
             Just Nothing  -> Nothing -- param present with no value -> Nothing
             Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
                                         -- the right type
-    in route (Proxy :: Proxy sublayout) (feedTo subserver param)
+    in route (Proxy :: Proxy sublayout) (passToServer subserver param)
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
 
 -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
@@ -507,7 +520,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
         -- corresponding values
         parameters = filter looksLikeParam querytext
         values = mapMaybe (convert . snd) parameters
-    in  route (Proxy :: Proxy sublayout) (feedTo subserver values)
+    in  route (Proxy :: Proxy sublayout) (passToServer subserver values)
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
           looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
           convert Nothing = Nothing
@@ -537,7 +550,7 @@ instance (KnownSymbol sym, HasServer sublayout)
           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
-    in  route (Proxy :: Proxy sublayout) (feedTo subserver param)
+    in  route (Proxy :: Proxy sublayout) (passToServer subserver param)
     where paramname = cs $ symbolVal (Proxy :: Proxy sym)
           examine v | v == "true" || v == "1" || v == "" = True
                     | otherwise = False
@@ -555,7 +568,7 @@ instance HasServer Raw where
   type ServerT Raw m = Application
 
   route Proxy rawApplication = LeafRouter $ \ request respond -> do
-    r <- rawApplication
+    r <- runDelayed rawApplication
     case r of
       Route app   -> app request (respond . Route)
       Fail a      -> respond $ Fail a
@@ -589,19 +602,21 @@ instance ( AllCTUnrender list a, HasServer sublayout
     a -> ServerT sublayout m
 
   route Proxy subserver = WithRequest $ \ request ->
-    route (Proxy :: Proxy sublayout) $ do
-      -- See HTTP RFC 2616, section 7.2.1
-      -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
-      -- See also "W3C Internet Media Type registration, consistency of use"
-      -- http://www.w3.org/2001/tag/2002/0129-mime
-      let contentTypeH = fromMaybe "application/octet-stream"
-                       $ lookup hContentType $ requestHeaders request
-      mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
-             <$> lazyRequestBody request
-      case mrqbody of
-        Nothing -> return $ FailFatal err415
-        Just (Left e) -> return $ FailFatal err400 { errBody = cs e }
-        Just (Right v) -> feedTo subserver v
+    route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request))
+    where
+      bodyCheck 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"
+        -- http://www.w3.org/2001/tag/2002/0129-mime
+        let contentTypeH = fromMaybe "application/octet-stream"
+                         $ lookup hContentType $ requestHeaders request
+        mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
+               <$> lazyRequestBody request
+        case mrqbody of
+          Nothing        -> return $ FailFatal err415
+          Just (Left e)  -> return $ FailFatal err400 { errBody = cs e }
+          Just (Right v) -> return $ Route v
 
 -- | Make sure the incoming request starts with @"/path"@, strip it and
 -- pass the rest of the request path to @sublayout@.
@@ -618,13 +633,13 @@ instance HasServer api => HasServer (RemoteHost :> api) where
   type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
 
   route Proxy subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) (feedTo subserver $ remoteHost req)
+    route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req)
 
 instance HasServer api => HasServer (IsSecure :> api) where
   type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
 
   route Proxy subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) (feedTo subserver $ secure req)
+    route (Proxy :: Proxy api) (passToServer subserver $ secure req)
 
     where secure req = if isSecure req then Secure else NotSecure
 
@@ -632,13 +647,13 @@ instance HasServer api => HasServer (Vault :> api) where
   type ServerT (Vault :> api) m = Vault -> ServerT api m
 
   route Proxy subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) (feedTo subserver $ vault req)
+    route (Proxy :: Proxy api) (passToServer subserver $ vault req)
 
 instance HasServer api => HasServer (HttpVersion :> api) where
   type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
 
   route Proxy subserver = WithRequest $ \req ->
-    route (Proxy :: Proxy api) (feedTo subserver $ httpVersion req)
+    route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req)
 
 pathIsEmpty :: Request -> Bool
 pathIsEmpty = go . pathInfo
diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs
index 3914af0d..63b05c05 100644
--- a/servant-server/src/Servant/Server/Internal/Router.hs
+++ b/servant-server/src/Servant/Server/Internal/Router.hs
@@ -6,9 +6,9 @@ import           Data.Map                                   (Map)
 import qualified Data.Map                                   as M
 import           Data.Text                                  (Text)
 import           Network.Wai                                (Request, Response, pathInfo)
-import           Servant.Server.Internal.ServantErr
 import           Servant.Server.Internal.PathInfo
 import           Servant.Server.Internal.RoutingApplication
+import           Servant.Server.Internal.ServantErr
 
 type Router = Router' RoutingApplication
 
@@ -77,10 +77,18 @@ runRouter (Choice r1 r2)       request respond =
     Fail _ -> runRouter r2 request $ \ mResponse2 ->
       respond (highestPri mResponse1 mResponse2)
     _      -> respond mResponse1
-  where
-    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
+   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.
+--
+-- It just so happens that 404 < 405 < 406 as far as
+-- we are concerned here, so we can use (<).
+worseHTTPCode :: Int -> Int -> Bool
+worseHTTPCode = (<)
diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
index f430fb2e..cc3f5965 100644
--- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
+++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
@@ -2,6 +2,9 @@
 {-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE StandaloneDeriving         #-}
 module Servant.Server.Internal.RoutingApplication where
 
 #if !MIN_VERSION_base(4,8,0)
@@ -18,19 +21,18 @@ import           Network.Wai                        (Application, Request,
                                                      Response, ResponseReceived,
                                                      requestBody,
                                                      strictRequestBody)
-import           Servant.API                        ((:<|>) (..))
 import           Servant.Server.Internal.ServantErr
 
 type RoutingApplication =
      Request -- ^ the request, the field 'pathInfo' may be modified by url routing
   -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
 
--- | A wrapper around @'Either' 'RouteMismatch' a@.
+-- | The result of matching against a path in the route tree.
 data RouteResult a =
     Fail ServantErr           -- ^ Keep trying other paths. The @ServantErr@
-                              -- should only be 404 or 405.
-  | FailFatal ServantErr      -- ^ Don't other paths.
-  | Route a
+                              -- should only be 404, 405 or 406.
+  | FailFatal !ServantErr     -- ^ Don't try other paths.
+  | Route !a
   deriving (Eq, Show, Read, Functor)
 
 data ReqBodyState = Uncalled
@@ -63,15 +65,183 @@ toApplication ra request respond = do
   ra request{ requestBody = memoReqBody } routingRespond
  where
   routingRespond :: RouteResult Response -> IO ResponseReceived
-  routingRespond (Fail err)    = respond $! responseServantErr err
-  routingRespond (FailFatal err) = respond $! responseServantErr err
-  routingRespond (Route 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))
+-- TODO: The above may not be quite right yet.
+--
+-- 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, whcih is also bad.
+--
+-- So in principle, we'd like:
+--
+-- static routes (can cause 404)
+-- delayed captures (can cause 404)
+-- methods (can cause 405)
+-- 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.
+--
+-- Why would we want to delay checks?
+--
+-- There are two reasons:
+--
+-- 1. Currently, the order in which we perform checks coincides
+-- with the error we will generate. This is because during checks,
+-- once an error occurs, we do not perform any subsequent checks,
+-- but rather return this error.
+--
+-- This is not a necessity: we could continue doing other checks,
+-- and choose the preferred error. However, that would in general
+-- mean more checking, which leads us to the other reason.
+--
+-- 2. We really want to avoid doing certain checks too early. For
+-- example, captures involve parsing, and are much more costly
+-- than static route matches. In particular, if several paths
+-- contain the "same" capture, we'd like as much as possible to
+-- avoid trying the same parse many times. Also tricky is the
+-- request body. Again, this involves parsing, but also, WAI makes
+-- obtaining the request body a side-effecting operation. We
+-- could/can work around this by manually caching the request body,
+-- but we'd rather keep the number of times we actually try to
+-- decode the request body to an absolute minimum.
+--
+-- We prefer to have the following relative priorities of error
+-- codes:
+--
+-- @
+-- 404
+-- 405 (bad method)
+-- 401 (unauthorized)
+-- 415 (unsupported media type)
+-- 400 (bad request)
+-- 406 (not acceptable)
+-- @
+--
+-- Therefore, while routing, we delay most checks so that they
+-- will ultimately occur in the right order.
+--
+-- A 'Delayed' contains three delayed blocks of tests, and
+-- the actual handler:
+--
+-- 1. Delayed captures. These can actually cause 404, and
+-- while they're costly, they should be done first among the
+-- delayed checks (at least as long as we do not decouple the
+-- check order from the error reporting, see above). Delayed
+-- captures can provide inputs to the actual handler.
+--
+-- 2. Method check(s). This can cause a 405. On success,
+-- it does not provide an input for the handler. Method checks
+-- are comparatively cheap.
+--
+-- 3. Body and accept header checks. The request body check can
+-- cause both 400 and 415. This provides an input to the handler.
+-- The accept header check can be performed as the final
+-- computation in this block. It can cause a 406.
+--
+data Delayed :: * -> * where
+  Delayed :: IO (RouteResult a)
+          -> IO (RouteResult ())
+          -> IO (RouteResult b)
+          -> (a -> b -> RouteResult c)
+          -> Delayed c
+
+deriving instance Functor Delayed
+
+-- | Add a capture to the end of the capture block.
+addCapture :: Delayed (a -> b)
+           -> IO (RouteResult a)
+           -> Delayed b
+addCapture (Delayed captures method body server) new =
+  Delayed (combineRouteResults (,) captures new) method body (\ (x, v) y -> ($ v) <$> server x y)
+
+-- | Add a method check to the end of the method block.
+addMethodCheck :: Delayed a
+               -> IO (RouteResult ())
+               -> Delayed a
+addMethodCheck (Delayed captures method body server) new =
+  Delayed captures (combineRouteResults const method new) body server
+
+-- | Add a body check to the end of the body block.
+addBodyCheck :: Delayed (a -> b)
+             -> IO (RouteResult a)
+             -> Delayed b
+addBodyCheck (Delayed captures method body server) new =
+  Delayed captures method (combineRouteResults (,) body new) (\ x (y, v) -> ($ v) <$> server x y)
+
+-- | 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 captures method body server) new =
+  Delayed captures method (combineRouteResults const body new) server
+
+-- | 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))
+
+-- | Run a delayed server. Performs all scheduled operations
+-- in order, and passes the results from the capture and body
+-- blocks on to the actual handler.
+runDelayed :: Delayed a
+           -> IO (RouteResult a)
+runDelayed (Delayed captures method body server) =
+  captures `bindRouteResults` \ c ->
+  method   `bindRouteResults` \ _ ->
+  body     `bindRouteResults` \ b ->
+  return (server c b)
+
+-- | 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)
           -> (RouteResult Response -> IO r)
           -> (a -> RouteResult Response)
           -> IO r
-runAction action respond k = action >>= go >>= respond
+runAction action respond k = runDelayed action >>= go >>= respond
   where
     go (Fail  e)   = return $ Fail e
     go (FailFatal e) = return $ FailFatal e
@@ -80,16 +250,3 @@ runAction action respond k = action >>= go >>= respond
       case e of
         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 (Route (a :<|> _)) = Route a
-extractL (Fail x)           = Fail x
-extractL (FailFatal x)      = FailFatal x
-
-extractR :: RouteResult (a :<|> b) -> RouteResult b
-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 9a0bb2dd..60212a4a 100644
--- a/servant-server/test/Servant/Server/ErrorSpec.hs
+++ b/servant-server/test/Servant/Server/ErrorSpec.hs
@@ -5,12 +5,14 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Servant.Server.ErrorSpec (spec) where
 
+import           Control.Monad.Trans.Except (throwE)
 import           Data.Aeson                 (encode)
-import qualified Data.ByteString.Lazy.Char8 as BCL
 import qualified Data.ByteString.Char8      as BC
+import qualified Data.ByteString.Lazy.Char8 as BCL
 import           Data.Proxy
 import           Network.HTTP.Types         (hAccept, hContentType, methodGet,
                                              methodPost, methodPut)
+import           Safe                       (readMay)
 import           Test.Hspec
 import           Test.Hspec.Wai
 
@@ -54,7 +56,7 @@ errorOrderApi :: Proxy ErrorOrderApi
 errorOrderApi = Proxy
 
 errorOrderServer :: Server ErrorOrderApi
-errorOrderServer = \_ _ -> return 5
+errorOrderServer = \_ _ -> throwE err402
 
 errorOrderSpec :: Spec
 errorOrderSpec = describe "HTTP error order"
@@ -65,6 +67,7 @@ errorOrderSpec = describe "HTTP error order"
       badUrl          = "home/nonexistent"
       badBody         = "nonsense"
       goodContentType = (hContentType, "application/json")
+      goodAccept      = (hAccept, "application/json")
       goodMethod      = methodPost
       goodUrl         = "home/2"
       goodBody        = encode (5 :: Int)
@@ -89,6 +92,10 @@ errorOrderSpec = describe "HTTP error order"
     request goodMethod goodUrl [goodContentType, badAccept] goodBody
       `shouldRespondWith` 406
 
+  it "has handler-level errors as last priority" $ do
+    request goodMethod goodUrl [goodContentType, goodAccept] goodBody
+      `shouldRespondWith` 402
+
 type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer
 
 prioErrorsApi :: Proxy PrioErrorsApi
@@ -107,7 +114,7 @@ prioErrorsSpec = describe "PrioErrors" $ do
               `shouldRespondWith` resp
           where
             fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
-                     ++ " " ++ (BC.unpack path) ++ " (" ++ cdescr ++ ")"
+                     ++ " " ++ BC.unpack path ++ " (" ++ cdescr ++ ")"
 
         get' = ("GET", methodGet)
         put' = ("PUT", methodPut)
@@ -140,7 +147,7 @@ prioErrorsSpec = describe "PrioErrors" $ do
 -- * Error Retry {{{
 
 type ErrorRetryApi
-     = "a" :> ReqBody '[JSON] Int      :> Post '[JSON] Int                -- 0
+     = "a" :> ReqBody '[JSON] Int      :> Post '[JSON] Int                -- err402
   :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int                -- 1
   :<|> "a" :> ReqBody '[JSON] Int      :> Post '[PlainText] Int           -- 2
   :<|> "a" :> ReqBody '[JSON] String   :> Post '[JSON] Int                -- 3
@@ -154,7 +161,7 @@ errorRetryApi = Proxy
 
 errorRetryServer :: Server ErrorRetryApi
 errorRetryServer
-     = (\_ -> return 0)
+     = (\_ -> throwE err402)
   :<|> (\_ -> return 1)
   :<|> (\_ -> return 2)
   :<|> (\_ -> return 3)
@@ -181,18 +188,6 @@ errorRetrySpec = describe "Handler search"
     request methodGet "a" [jsonCT, jsonAccept] jsonBody
      `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }
 
-  it "should not continue when Content-Types don't match" $ do
-    request methodPost "a" [plainCT, jsonAccept] jsonBody
-     `shouldRespondWith` 415
-
-  it "should not continue when body can't be deserialized" $ do
-    request methodPost "a" [jsonCT, jsonAccept] (encode ("nonsense" :: String))
-     `shouldRespondWith` 400
-
-  it "should not continue when Accepts don't match" $ do
-    request methodPost "a" [jsonCT, plainAccept] jsonBody
-     `shouldRespondWith` 406
-
 -- }}}
 ------------------------------------------------------------------------------
 -- * Error Choice {{{
@@ -233,7 +228,7 @@ errorChoiceSpec = describe "Multiple handlers return errors"
     request methodPost "path3" [(hContentType, "application/json")] ""
       `shouldRespondWith` 400
     request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"),
-                                (hAccept, "application/json")] ""
+                                (hAccept, "blah")] "5"
       `shouldRespondWith` 406
 
 
@@ -242,10 +237,8 @@ errorChoiceSpec = describe "Multiple handlers return errors"
 -- * Instances {{{
 
 instance MimeUnrender PlainText Int where
-    mimeUnrender _ = Right . read . BCL.unpack
+    mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BCL.unpack x)
 
 instance MimeRender PlainText Int where
     mimeRender _ = BCL.pack . show
 -- }}}
---
-
diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs
index 4ee65423..11816853 100644
--- a/servant-server/test/Servant/ServerSpec.hs
+++ b/servant-server/test/Servant/ServerSpec.hs
@@ -1,20 +1,12 @@
-<<<<<<< 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
 
@@ -55,6 +47,7 @@ import           Test.Hspec                 (Spec, describe, it, shouldBe)
 import           Test.Hspec.Wai             (get, liftIO, matchHeaders,
                                              matchStatus, post, request,
                                              shouldRespondWith, with, (<:>))
+<<<<<<< HEAD
 import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
                                              Get, Header (..), Headers,
                                              HttpVersion, IsSecure (..), JSON,
@@ -63,12 +56,12 @@ import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
                                              Raw, RemoteHost, ReqBody,
                                              addHeader)
 import           Servant.Server             (Server, serve, ServantErr(..), err404)
+=======
+import           Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..))
+>>>>>>> Rebase cleanup and test fixes.
 import           Servant.Server.Internal.Router
                                             (tweakResponse, runRouter,
                                              Router, Router'(LeafRouter))
-import           Servant.Server.Internal.RoutingApplication
-                                            (RouteResult(..), RouteMismatch(..),
-                                             toApplication)
 
 
 -- * test data types
@@ -279,13 +272,13 @@ queryParamSpec = do
              }
 
           let params3'' = "?unknown="
-          response3' <- Network.Wai.Test.request defaultRequest{
+          response3'' <- Network.Wai.Test.request defaultRequest{
             rawQueryString = params3'',
             queryString = parseQuery params3'',
             pathInfo = ["b"]
            }
           liftIO $
-            decode' (simpleBody response3') `shouldBe` Just alice{
+            decode' (simpleBody response3'') `shouldBe` Just alice{
               name = "Alice"
              }
 
@@ -553,7 +546,7 @@ routerSpec = do
 
         router', router :: Router
         router' = tweakResponse (twk <$>) router
-        router = LeafRouter $ \_ cont -> cont (RR . Right $ responseBuilder (Status 201 "") [] "")
+        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
diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs
index db8eb61e..ab857ce2 100644
--- a/servant/src/Servant/API/ContentTypes.hs
+++ b/servant/src/Servant/API/ContentTypes.hs
@@ -57,12 +57,14 @@ module Servant.API.ContentTypes
     , AcceptHeader(..)
     , AllCTRender(..)
     , AllCTUnrender(..)
+    , AllMime(..)
     , AllMimeRender(..)
     , AllMimeUnrender(..)
     , FromFormUrlEncoded(..)
     , ToFormUrlEncoded(..)
     , IsNonEmpty
     , eitherDecodeLenient
+    , canHandleAcceptH
     ) where
 
 #if !MIN_VERSION_base(4,8,0)
@@ -81,6 +83,7 @@ import           Data.ByteString.Lazy             (ByteString, fromStrict,
                                                    toStrict)
 import qualified Data.ByteString.Lazy             as B
 import qualified Data.ByteString.Lazy.Char8       as BC
+import           Data.Maybe                       (isJust)
 import           Data.Monoid
 import           Data.String.Conversions          (cs)
 import qualified Data.Text                        as TextS
@@ -156,14 +159,13 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
 class Accept ctype => MimeRender ctype a where
     mimeRender  :: Proxy ctype -> a -> ByteString
 
-class AllCTRender (list :: [*]) a where
+class (AllMimeRender list a) => AllCTRender (list :: [*]) a where
     -- If the Accept header can be matched, returns (Just) a tuple of the
     -- Content-Type and response (serialization of @a@ into the appropriate
     -- mimetype).
     handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
 
-instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
-         ) => AllCTRender ctyps a where
+instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where
     handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
       where pctyps = Proxy :: Proxy ctyps
             amrs = allMimeRender pctyps val
@@ -211,11 +213,24 @@ instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
 --------------------------------------------------------------------------
 -- * Utils (Internal)
 
+class AllMime (list :: [*]) where
+    allMime :: Proxy list -> [M.MediaType]
+
+instance AllMime '[] where
+    allMime _ = []
+
+instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where
+    allMime _ = (contentType pctyp):allMime pctyps
+      where pctyp  = Proxy :: Proxy ctyp
+            pctyps = Proxy :: Proxy ctyps
+
+canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool
+canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h
 
 --------------------------------------------------------------------------
 -- Check that all elements of list are instances of MimeRender
 --------------------------------------------------------------------------
-class AllMimeRender (list :: [*]) a where
+class (AllMime list) => AllMimeRender (list :: [*]) a where
     allMimeRender :: Proxy list
                   -> a                              -- value to serialize
                   -> [(M.MediaType, ByteString)]    -- content-types/response pairs
@@ -239,7 +254,7 @@ instance AllMimeRender '[] a where
 --------------------------------------------------------------------------
 -- Check that all elements of list are instances of MimeUnrender
 --------------------------------------------------------------------------
-class AllMimeUnrender (list :: [*]) a where
+class (AllMime list) => AllMimeUnrender (list :: [*]) a where
     allMimeUnrender :: Proxy list
                     -> ByteString
                     -> [(M.MediaType, Either String a)]

From 9c12b7839b6d7adc6bf1fc59c422797da0f5c5a0 Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Tue, 13 Oct 2015 20:29:14 +0200
Subject: [PATCH 6/6] 7.8 routing fixes, -Wall, cleanup, changelog.

---
 servant-server/CHANGELOG.md                   |  4 +---
 servant-server/servant-server.cabal           |  1 +
 .../src/Servant/Server/Internal/Router.hs     |  1 -
 .../Server/Internal/RoutingApplication.hs     |  9 +++-----
 .../test/Servant/Server/ErrorSpec.hs          | 22 +------------------
 servant-server/test/Servant/ServerSpec.hs     | 21 ++++--------------
 6 files changed, 10 insertions(+), 48 deletions(-)

diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md
index f45823eb..5ba871ee 100644
--- a/servant-server/CHANGELOG.md
+++ b/servant-server/CHANGELOG.md
@@ -7,9 +7,7 @@ HEAD
 * 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.
+* Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`)
 
 0.4.1
 -----
diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal
index 9b69d9c4..8d6beac4 100644
--- a/servant-server/servant-server.cabal
+++ b/servant-server/servant-server.cabal
@@ -95,6 +95,7 @@ test-suite spec
       Servant.Server.Internal.EnterSpec
       Servant.ServerSpec
       Servant.Utils.StaticFilesSpec
+      Servant.Server.ErrorSpec
   build-depends:
       base == 4.*
     , aeson
diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs
index 63b05c05..6f4ebfbb 100644
--- a/servant-server/src/Servant/Server/Internal/Router.hs
+++ b/servant-server/src/Servant/Server/Internal/Router.hs
@@ -6,7 +6,6 @@ import           Data.Map                                   (Map)
 import qualified Data.Map                                   as M
 import           Data.Text                                  (Text)
 import           Network.Wai                                (Request, Response, pathInfo)
-import           Servant.Server.Internal.PathInfo
 import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServantErr
 
diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
index cc3f5965..4b27c688 100644
--- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
+++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
@@ -8,9 +8,7 @@
 module Servant.Server.Internal.RoutingApplication where
 
 #if !MIN_VERSION_base(4,8,0)
-import           Control.Applicative                (Applicative, (<$>))
-import           Data.Monoid                        (Monoid, mappend, mempty,
-                                                     (<>))
+import           Control.Applicative                ((<$>))
 #endif
 import           Control.Monad.Trans.Except         (ExceptT, runExceptT)
 import qualified Data.ByteString                    as B
@@ -69,8 +67,6 @@ toApplication ra request respond = do
   routingRespond (FailFatal err) = respond $ responseServantErr err
   routingRespond (Route v)       = respond v
 
--- TODO: The above may not be quite right yet.
---
 -- We currently mix up the order in which we perform checks
 -- and the priority with which errors are reported.
 --
@@ -162,7 +158,8 @@ data Delayed :: * -> * where
           -> (a -> b -> RouteResult c)
           -> Delayed c
 
-deriving instance Functor Delayed
+instance Functor Delayed where
+   fmap f (Delayed a b c g) = Delayed a b c ((fmap.fmap.fmap) f g)
 
 -- | Add a capture to the end of the capture block.
 addCapture :: Delayed (a -> b)
diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs
index 60212a4a..2e93cc2a 100644
--- a/servant-server/test/Servant/Server/ErrorSpec.hs
+++ b/servant-server/test/Servant/Server/ErrorSpec.hs
@@ -18,24 +18,6 @@ import           Test.Hspec.Wai
 
 import           Servant
 
-
--- 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
@@ -174,9 +156,7 @@ errorRetrySpec :: Spec
 errorRetrySpec = describe "Handler search"
            $ with (return $ serve errorRetryApi errorRetryServer) $ do
 
-  let plainCT     = (hContentType, "text/plain")
-      plainAccept = (hAccept, "text/plain")
-      jsonCT      = (hContentType, "application/json")
+  let jsonCT      = (hContentType, "application/json")
       jsonAccept  = (hAccept, "application/json")
       jsonBody    = encode (1797 :: Int)
 
diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs
index 11816853..e017d399 100644
--- a/servant-server/test/Servant/ServerSpec.hs
+++ b/servant-server/test/Servant/ServerSpec.hs
@@ -33,21 +33,6 @@ 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,
-                                             shouldRespondWith, with, (<:>))
-<<<<<<< HEAD
 import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
                                              Get, Header (..), Headers,
                                              HttpVersion, IsSecure (..), JSON,
@@ -56,9 +41,11 @@ import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
                                              Raw, RemoteHost, ReqBody,
                                              addHeader)
 import           Servant.Server             (Server, serve, ServantErr(..), err404)
-=======
+import           Test.Hspec                 (Spec, describe, it, shouldBe)
+import           Test.Hspec.Wai             (get, liftIO, matchHeaders,
+                                             matchStatus, post, request,
+                                             shouldRespondWith, with, (<:>))
 import           Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..))
->>>>>>> Rebase cleanup and test fixes.
 import           Servant.Server.Internal.Router
                                             (tweakResponse, runRouter,
                                              Router, Router'(LeafRouter))