diff --git a/src/Servant/API/Union.hs b/src/Servant/API/Union.hs index 6fd51aea..ff53682d 100644 --- a/src/Servant/API/Union.hs +++ b/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 - True -> route pb b request $ \mResponse' -> - respond (mResponse <> mResponse') - False -> respond mResponse - + if isMismatch mResponse + then route pb b request $ \mResponse' -> respond (mResponse <> mResponse') + else respond mResponse where pa = Proxy :: Proxy a pb = Proxy :: Proxy b diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs index e272d304..72166f0c 100644 --- a/src/Servant/Server.hs +++ 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 --- 'WrongMethod' <> _ = 'WrongMethod' +-- > mempty = NotFound +-- > +-- > NotFound `mappend` x = x +-- > WrongMethod `mappend` InvalidBody = InvalidBody +-- > WrongMethod `mappend` _ = WrongMethod +-- > InvalidBody `mappend` _ = InvalidBody -- @ instance Monoid RouteMismatch where mempty = NotFound - NotFound `mappend` x = x - WrongMethod `mappend` _ = WrongMethod + NotFound `mappend` x = x + WrongMethod `mappend` InvalidBody = InvalidBody + WrongMethod `mappend` _ = WrongMethod + InvalidBody `mappend` _ = InvalidBody -- | A wrapper around @'Either' 'RouteMismatch' a@. newtype RouteResult a =