improve the routing mechanism by augmenting the routing error type with some information and a sound monoid instance. this addresses #10

src/Servant/API/Capture.hs

@@ -31,11 +31,11 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
   route Proxy subserver request respond = case pathInfo request of
     (first : rest)
       -> case captured captureProxy first of
-           Nothing  -> respond Nothing
+           Nothing  -> respond $ failWith NotFound
            Just v   -> route (Proxy :: Proxy sublayout) (subserver v) request{
                          pathInfo = rest
                        } respond
-    _ -> respond Nothing
+    _ -> respond $ failWith NotFound
 
     where captureProxy = Proxy :: Proxy (Capture capture a)
 

src/Servant/API/Delete.hs

@@ -26,12 +26,14 @@ instance HasServer Delete where
   route Proxy action request respond
     | null (pathInfo request) && requestMethod request == methodDelete = do
         e <- runEitherT action
-        respond $ Just $ case e of
+        respond $ succeedWith $ case e of
           Right () ->
             responseLBS status204 [] ""
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
-    | otherwise = respond Nothing
+    | null (pathInfo request) && requestMethod request /= methodDelete =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
 
 instance HasClient Delete where
   type Client Delete = URI -> EitherT String IO ()

src/Servant/API/Get.hs

@@ -27,12 +27,14 @@ instance ToJSON result => HasServer (Get result) where
   route Proxy action request respond
     | null (pathInfo request) && requestMethod request == methodGet = do
         e <- runEitherT action
-        respond $ Just $ case e of
+        respond . succeedWith $ case e of
           Right output ->
             responseLBS ok200 [("Content-Type", "application/json")] (encode output)
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
-    | otherwise = respond Nothing
+    | null (pathInfo request) && requestMethod request /= methodGet =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
 
 instance FromJSON result => HasClient (Get result) where
   type Client (Get result) = URI -> EitherT String IO result

src/Servant/API/Post.hs

@@ -29,12 +29,14 @@ instance ToJSON a => HasServer (Post a) where
   route Proxy action request respond
     | null (pathInfo request) && requestMethod request == methodPost = do
         e <- runEitherT action
-        respond $ Just $ case e of
+        respond . succeedWith $ case e of
           Right out ->
             responseLBS status201 [("Content-Type", "application/json")] (encode out)
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
-    | otherwise = respond Nothing
+    | null (pathInfo request) && requestMethod request /= methodPost =
+        respond $ failWith WrongMethod
+    | otherwise = respond $ failWith NotFound
 
 instance FromJSON a => HasClient (Post a) where
   type Client (Post a) = URI -> EitherT String IO a

src/Servant/API/Put.hs

@@ -27,12 +27,15 @@ instance ToJSON a => HasServer (Put a) where
   route Proxy action request respond
     | null (pathInfo request) && requestMethod request == methodPut = do
         e <- runEitherT action
-        respond $ Just $ case e of
+        respond . succeedWith $ case e of
           Right out ->
             responseLBS ok200 [("Content-Type", "application/json")] (encode out)
           Left (status, message) ->
             responseLBS (mkStatus status (cs message)) [] (cs message)
-    | otherwise = respond Nothing
+    | null (pathInfo request) && requestMethod request /= methodPut =
+        respond $ failWith WrongMethod
+
+    | otherwise = respond $ failWith NotFound
 
 instance FromJSON a => HasClient (Put a) where
   type Client (Put a) = URI -> EitherT String IO a

src/Servant/API/RQBody.hs

@@ -26,7 +26,7 @@ instance (FromJSON a, HasServer sublayout)
   route Proxy subserver request respond = do
     mrqbody <- decode' <$> lazyRequestBody request
     case mrqbody of
-      Nothing -> respond Nothing
+      Nothing -> respond $ failWith NotFound
       Just v  -> route (Proxy :: Proxy sublayout) (subserver v) request respond
 
 instance (ToJSON a, HasClient sublayout)

src/Servant/API/Raw.hs

@@ -15,4 +15,4 @@ data Raw
 instance HasServer Raw where
   type Server Raw = Application
   route Proxy rawApplication request respond =
-    rawApplication request (respond . Just)
+    rawApplication request (respond . succeedWith)

src/Servant/API/Sub.hs

@@ -25,7 +25,7 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout
       -> route (Proxy :: Proxy sublayout) subserver request{
            pathInfo = rest
          } respond
-    _ -> respond Nothing
+    _ -> respond $ failWith NotFound
 
     where proxyPath = Proxy :: Proxy path
 

src/Servant/API/Union.hs

@@ -14,11 +14,16 @@ infixr 8 :<|>
 
 instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
   type Server (a :<|> b) = Server a :<|> Server b
-  route Proxy (a :<|> b) request respond = do
+  route Proxy (a :<|> b) request respond =
-    route (Proxy :: Proxy a) a request $ \ mResponse ->
+    route pa a request $ \ mResponse ->
-      case mResponse of
+      case isMismatch mResponse of
-        Nothing -> route (Proxy :: Proxy b) b request respond
+        True  -> route pb b request $ \mResponse' ->
-        Just resp -> respond $ Just resp
+                   respond (mResponse <> mResponse')
+        False -> respond mResponse
+
+
+    where pa = Proxy :: Proxy a
+          pb = Proxy :: Proxy b
 
 instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
   type Client (a :<|> b) = Client a :<|> Client b

src/Servant/Server.hs

@@ -7,6 +7,7 @@
 
 module Servant.Server where
 
+import Data.Monoid
 import Data.Proxy
 import Network.HTTP.Types
 import Network.Wai
@@ -19,17 +20,62 @@ serve p server = toApplication (route p server)
 
 toApplication :: RoutingApplication -> Application
 toApplication ra request respond = do
-  ra request routingRespond
+  ra request (routingRespond . routeResult)
  where
-  routingRespond :: Maybe Response -> IO ResponseReceived
+  routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
-  routingRespond Nothing =
+  routingRespond (Left NotFound) =
     respond $ responseLBS notFound404 [] "not found"
-  routingRespond (Just response) =
+  routingRespond (Left WrongMethod) =
+    respond $ responseLBS methodNotAllowed405 [] "method not allowed"
+  routingRespond (Right response) =
     respond response
 
+-- * Route mismatch
+data RouteMismatch =
+    NotFound    -- ^ the usual "not found" error
+  | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
+  deriving (Eq, Show)
+
+-- | 
+-- @
+-- 'NotFound'    <> x = x
+-- 'WrongMethod' <> _ = 'WrongMethod'
+-- @
+instance Monoid RouteMismatch where
+  mempty = NotFound
+
+  NotFound `mappend` x = x
+  WrongMethod `mappend` _ = WrongMethod
+
+-- | A wrapper around @'Either' 'RouteMismatch' a@.
+newtype RouteResult a =
+  RR { routeResult :: Either RouteMismatch a }
+  deriving (Eq, Show)
+
+failWith :: RouteMismatch -> RouteResult a
+failWith = RR . Left
+
+succeedWith :: a -> RouteResult a
+succeedWith = RR . Right
+
+isMismatch :: RouteResult a -> Bool
+isMismatch (RR (Left _)) = True
+isMismatch _             = False
+
+-- | 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
+
 type RoutingApplication =
      Request -- ^ the request, the field 'pathInfo' may be modified by url routing
-  -> (Maybe Response -> IO ResponseReceived) -> IO ResponseReceived
+  -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
 
 class HasServer layout where
   type Server layout :: *

test/Servant/ServerSpec.hs

@@ -113,8 +113,8 @@ getSpec = do
         liftIO $ do
           decode' (simpleBody response) `shouldBe` Just alice
 
-      it "throws 404 on POSTs" $ do
+      it "throws 405 (wrong method) on POSTs" $ do
-        post "/" "" `shouldRespondWith` 404
+        post "/" "" `shouldRespondWith` 405
 
 
 type GetParamApi = GetParam "name" String :> Get Person