Merge pull request #357 from haskell-servant/jkarni/remove-memoReqBody

Remove memoReqBody.

Author: jkarni

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

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

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