@@ -9,7 +9,7 @@ module Servant.Server.Internal where
99
1010import Control.Applicative ((<$>))
1111import Control.Monad.Trans.Either (EitherT, runEitherT)
12−import Data.Aeson (ToJSON, FromJSON, encode, decode')
12+import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode')
1313import qualified Data.ByteString as B
1414import qualified Data.ByteString.Lazy as BL
1515import Data.IORef (newIORef, readIORef, writeIORef)
@@ -64,34 +64,34 @@ toApplication ra request respond = do
6464 respond $ responseLBS notFound404 [] "not found"
6565 routingRespond (Left WrongMethod) =
6666 respond $ responseLBS methodNotAllowed405 [] "method not allowed"
67− routingRespond (Left InvalidBody) =
68− respond $ responseLBS badRequest400 [] "Invalid JSON in request body"
67+ routingRespond (Left (InvalidBody err)) =
68+ respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err
6969 routingRespond (Right response) =
7070 respond response
7171
7272-- * Route mismatch
7373data RouteMismatch =
74− NotFound -- ^ the usual "not found" 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
74+ NotFound -- ^ the usual "not found" error
75+ | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
76+ | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
7777 deriving (Eq, Show)
7878
7979-- |
8080-- @
8181-- > mempty = NotFound
8282-- >
83−-- > NotFound `mappend` x = x
84−-- > WrongMethod `mappend` InvalidBody = InvalidBody
85−-- > WrongMethod `mappend` _ = WrongMethod
86−-- > InvalidBody `mappend` _ = InvalidBody
83+-- > NotFound `mappend` x = x
84+-- > WrongMethod `mappend` InvalidBody s = InvalidBody s
85+-- > WrongMethod `mappend` _ = WrongMethod
86+-- > InvalidBody s `mappend` _ = InvalidBody s
8787-- @
8888instance Monoid RouteMismatch where
8989 mempty = NotFound
9090
91− NotFound `mappend` x = x
92− WrongMethod `mappend` InvalidBody = InvalidBody
93− WrongMethod `mappend` _ = WrongMethod
94− InvalidBody `mappend` _ = InvalidBody
91+ NotFound `mappend` x = x
92+ WrongMethod `mappend` InvalidBody s = InvalidBody s
93+ WrongMethod `mappend` _ = WrongMethod
94+ InvalidBody s `mappend` _ = InvalidBody s
9595
9696-- | A wrapper around @'Either' 'RouteMismatch' a@.
9797newtype RouteResult a =
@@ -621,10 +621,10 @@ instance (FromJSON a, HasServer sublayout)
621621 a -> Server sublayout
622622
623623 route Proxy subserver request respond = do
624− mrqbody <- decode' <$> lazyRequestBody request
624+ mrqbody <- eitherDecode' <$> lazyRequestBody request
625625 case mrqbody of
626− Nothing -> respond $ failWith InvalidBody
627− Just v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
626+ Left e -> respond . failWith $ InvalidBody e
627+ Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
628628
629629-- | Make sure the incoming request starts with @"/path"@, strip it and
630630-- pass the rest of the request path to @sublayout@.