introduce InvalidBody as the 'stickiest' route mismatch reason. code review changes too, to close #14 close #11 close #10

src/Servant/API/Union.hs

@@ -16,11 +16,9 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
   type Server (a :<|> b) = Server a :<|> Server b
   route Proxy (a :<|> b) request respond =
     route pa a request $ \ mResponse ->
-      case isMismatch mResponse of
+      if isMismatch mResponse
-        True  -> route pb b request $ \mResponse' ->
+        then route pb b request $ \mResponse' -> respond (mResponse <> mResponse')
-                   respond (mResponse <> mResponse')
+        else respond mResponse
-        False -> respond mResponse
-
 
     where pa = Proxy :: Proxy a
           pb = Proxy :: Proxy b

src/Servant/Server.hs

@@ -27,6 +27,8 @@ toApplication ra request respond = do
     respond $ responseLBS notFound404 [] "not found"
   routingRespond (Left WrongMethod) =
     respond $ responseLBS methodNotAllowed405 [] "method not allowed"
+  routingRespond (Left InvalidBody) =
+    respond $ responseLBS badRequest400 [] "Invalid JSON in request body"
   routingRespond (Right response) =
     respond response
 
@@ -34,18 +36,25 @@ toApplication ra request respond = do
 data RouteMismatch =
     NotFound    -- ^ the usual "not found" error
   | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
+  | InvalidBody -- ^ an even more informative "you json request body wasn't valid" error
   deriving (Eq, Show)
 
 -- | 
 -- @
--- 'NotFound'    <> x = x
+-- > mempty = NotFound
--- 'WrongMethod' <> _ = 'WrongMethod'
+-- >
+-- > NotFound    `mappend`           x = x
+-- > WrongMethod `mappend` InvalidBody = InvalidBody
+-- > WrongMethod `mappend`           _ = WrongMethod
+-- > InvalidBody `mappend`           _ = InvalidBody
 -- @
 instance Monoid RouteMismatch where
   mempty = NotFound
 
-  NotFound `mappend` x = x
+  NotFound    `mappend`           x = x
-  WrongMethod `mappend` _ = WrongMethod
+  WrongMethod `mappend` InvalidBody = InvalidBody
+  WrongMethod `mappend`           _ = WrongMethod
+  InvalidBody `mappend`           _ = InvalidBody
 
 -- | A wrapper around @'Either' 'RouteMismatch' a@.
 newtype RouteResult a =