From 1aeee3ef9403251fbc500ee3e3df91f699ed54b3 Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Tue, 26 Jan 2016 14:43:15 +0100
Subject: [PATCH 1/2] Remove memoReqBody.

---
 servant-server/src/Servant/Server/Internal.hs |  2 +-
 .../Server/Internal/RoutingApplication.hs     | 28 +------------------
 2 files changed, 2 insertions(+), 28 deletions(-)

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 bcb563df..05814fe6 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

From 3bd3eff488a382ece37a481cc28547c5721ab187 Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Tue, 26 Jan 2016 18:47:34 +0100
Subject: [PATCH 2/2] Add test for failing 400

---
 servant-server/test/Servant/Server/ErrorSpec.hs | 4 ++++
 1 file changed, 4 insertions(+)

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 {{{