diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 1b2c19a2..daf44640 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -158,7 +158,7 @@ methodCheck method request acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ()) acceptCheck proxy accH | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route () - | otherwise = return $ Fail err406 + | otherwise = return $ FailFatal err406 methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 3112c640..4aa3bda7 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -33,34 +33,8 @@ data RouteResult a = | Route !a deriving (Eq, Show, Read, Functor) -data ReqBodyState = Uncalled - | Called !B.ByteString - | Done !B.ByteString - toApplication :: RoutingApplication -> Application -toApplication ra request respond = do - reqBodyRef <- newIORef Uncalled - -- We may need to consume the requestBody more than once. In order to - -- maintain the illusion that 'requestBody' works as expected, - -- 'ReqBodyState' is introduced, and the complete body is memoized and - -- returned as many times as requested with empty "Done" marker chunks in - -- between. - -- See https://github.com/haskell-servant/servant/issues/3 - let memoReqBody = do - ior <- readIORef reqBodyRef - case ior of - Uncalled -> do - r <- BL.toStrict <$> strictRequestBody request - writeIORef reqBodyRef $ Done r - return r - Called bs -> do - writeIORef reqBodyRef $ Done bs - return bs - Done bs -> do - writeIORef reqBodyRef $ Called bs - return B.empty - - ra request{ requestBody = memoReqBody } routingRespond +toApplication ra request respond = ra request routingRespond where routingRespond :: RouteResult Response -> IO ResponseReceived routingRespond (Fail err) = respond $ responseServantErr err diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 745b47d9..5314f37e 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -168,6 +168,10 @@ errorRetrySpec = describe "Handler search" request methodGet "a" [jsonCT, jsonAccept] jsonBody `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) } + it "should not continue when body cannot be decoded" $ do + request methodPost "a" [jsonCT, jsonAccept] "a string" + `shouldRespondWith` 400 + -- }}} ------------------------------------------------------------------------------ -- * Error Choice {{{