eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Return JSON error messages in response

Browse source
This commit is contained in:
Phil Freeman 2015-01-19 19:12:08 -08:00
parent f04bd3e24b
commit 56791952b8
1 changed files with 17 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
src/Servant/Server/Internal.hs
View file

@ -9,7 +9,7 @@ module Servant.Server.Internal where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad.Trans.Either (EitherT, runEitherT) import Control.Monad.Trans.Either (EitherT, runEitherT)
import Data.Aeson (ToJSON, FromJSON, encode, decode') import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode')
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef, writeIORef) import Data.IORef (newIORef, readIORef, writeIORef)
@ -64,34 +64,34 @@ toApplication ra request respond = do
respond $ responseLBS notFound404 [] "not found" respond $ responseLBS notFound404 [] "not found"
routingRespond (Left WrongMethod) = routingRespond (Left WrongMethod) =
respond $ responseLBS methodNotAllowed405 [] "method not allowed" respond $ responseLBS methodNotAllowed405 [] "method not allowed"
routingRespond (Left InvalidBody) = routingRespond (Left (InvalidBody err)) =
respond $ responseLBS badRequest400 [] "Invalid JSON in request body" respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err
routingRespond (Right response) = routingRespond (Right response) =
respond response respond response
-- * Route mismatch -- * Route mismatch
data RouteMismatch = data RouteMismatch =
NotFound -- ^ the usual "not found" error NotFound -- ^ the usual "not found" error
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
| InvalidBody -- ^ an even more informative "your json request body wasn't valid" error | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
deriving (Eq, Show) deriving (Eq, Show)
-- | -- |
-- @ -- @
-- > mempty = NotFound -- > mempty = NotFound
-- > -- >
-- > NotFound `mappend` x = x -- > NotFound `mappend` x = x
-- > WrongMethod `mappend` InvalidBody = InvalidBody -- > WrongMethod `mappend` InvalidBody s = InvalidBody s
-- > WrongMethod `mappend` _ = WrongMethod -- > WrongMethod `mappend` _ = WrongMethod
-- > InvalidBody `mappend` _ = InvalidBody -- > InvalidBody s `mappend` _ = InvalidBody s
-- @ -- @
instance Monoid RouteMismatch where instance Monoid RouteMismatch where
mempty = NotFound mempty = NotFound
NotFound `mappend` x = x NotFound `mappend` x = x
WrongMethod `mappend` InvalidBody = InvalidBody WrongMethod `mappend` InvalidBody s = InvalidBody s
WrongMethod `mappend` _ = WrongMethod WrongMethod `mappend` _ = WrongMethod
InvalidBody `mappend` _ = InvalidBody InvalidBody s `mappend` _ = InvalidBody s
-- | A wrapper around @'Either' 'RouteMismatch' a@. -- | A wrapper around @'Either' 'RouteMismatch' a@.
newtype RouteResult a = newtype RouteResult a =
@ -621,10 +621,10 @@ instance (FromJSON a, HasServer sublayout)
a -> Server sublayout a -> Server sublayout
route Proxy subserver request respond = do route Proxy subserver request respond = do
mrqbody <- decode' <$> lazyRequestBody request mrqbody <- eitherDecode' <$> lazyRequestBody request
case mrqbody of case mrqbody of
Nothing -> respond $ failWith InvalidBody Left e -> respond . failWith $ InvalidBody e
Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
-- | Make sure the incoming request starts with @"/path"@, strip it and -- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@. -- pass the rest of the request path to @sublayout@.