@@ -9,7 +9,7 @@ module Servant.Server.Internal where
10import Control.Applicative ((<$>))
10import Control.Applicative ((<$>))
11import Control.Monad.Trans.Either (EitherT, runEitherT)
11import Control.Monad.Trans.Either (EitherT, runEitherT)
12−import Data.Aeson (ToJSON, FromJSON, encode, decode')
12+import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode')
13import qualified Data.ByteString as B
13import qualified Data.ByteString as B
14import qualified Data.ByteString.Lazy as BL
14import qualified Data.ByteString.Lazy as BL
15import Data.IORef (newIORef, readIORef, writeIORef)
15import Data.IORef (newIORef, readIORef, writeIORef)
@@ -64,34 +64,34 @@ toApplication ra request respond = do
64 respond $ responseLBS notFound404 [] "not found"
64 respond $ responseLBS notFound404 [] "not found"
65 routingRespond (Left WrongMethod) =
65 routingRespond (Left WrongMethod) =
66 respond $ responseLBS methodNotAllowed405 [] "method not allowed"
66 respond $ responseLBS methodNotAllowed405 [] "method not allowed"
67− routingRespond (Left InvalidBody) =
67+ routingRespond (Left (InvalidBody err)) =
68− respond $ responseLBS badRequest400 [] "Invalid JSON in request body"
68+ respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err
69 routingRespond (Right response) =
69 routingRespond (Right response) =
70 respond response
70 respond response
72-- * Route mismatch
72-- * Route mismatch
73data RouteMismatch =
73data RouteMismatch =
74− NotFound -- ^ the usual "not found" error
74+ NotFound -- ^ the usual "not found" error
75− | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
75+ | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
76− | InvalidBody -- ^ an even more informative "your json request body wasn't valid" error
76+ | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
77 deriving (Eq, Show)
77 deriving (Eq, Show)
81-- > mempty = NotFound
81-- > mempty = NotFound
83−-- > NotFound `mappend` x = x
83+-- > NotFound `mappend` x = x
84−-- > WrongMethod `mappend` InvalidBody = InvalidBody
84+-- > WrongMethod `mappend` InvalidBody s = InvalidBody s
85−-- > WrongMethod `mappend` _ = WrongMethod
85+-- > WrongMethod `mappend` _ = WrongMethod
86−-- > InvalidBody `mappend` _ = InvalidBody
86+-- > InvalidBody s `mappend` _ = InvalidBody s
88instance Monoid RouteMismatch where
88instance Monoid RouteMismatch where
89 mempty = NotFound
89 mempty = NotFound
91− NotFound `mappend` x = x
91+ NotFound `mappend` x = x
92− WrongMethod `mappend` InvalidBody = InvalidBody
92+ WrongMethod `mappend` InvalidBody s = InvalidBody s
93− WrongMethod `mappend` _ = WrongMethod
93+ WrongMethod `mappend` _ = WrongMethod
94− InvalidBody `mappend` _ = InvalidBody
94+ InvalidBody s `mappend` _ = InvalidBody s
96-- | A wrapper around @'Either' 'RouteMismatch' a@.
96-- | A wrapper around @'Either' 'RouteMismatch' a@.
97newtype RouteResult a =
97newtype RouteResult a =
@@ -621,10 +621,10 @@ instance (FromJSON a, HasServer sublayout)
621 a -> Server sublayout
621 a -> Server sublayout
623 route Proxy subserver request respond = do
623 route Proxy subserver request respond = do
624− mrqbody <- decode' <$> lazyRequestBody request
624+ mrqbody <- eitherDecode' <$> lazyRequestBody request
625 case mrqbody of
625 case mrqbody of
626− Nothing -> respond $ failWith InvalidBody
626+ Left e -> respond . failWith $ InvalidBody e
627− Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
627+ Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
629-- | Make sure the incoming request starts with @"/path"@, strip it and
629-- | Make sure the incoming request starts with @"/path"@, strip it and
630-- pass the rest of the request path to @sublayout@.
630-- pass the rest of the request path to @sublayout@.