Remove memoReqBody.

This commit is contained in:
Julian K. Arni 2016-01-26 14:43:15 +01:00
parent b9fb80ac5e
commit 1aeee3ef94
2 changed files with 2 additions and 28 deletions

View file

@ -158,7 +158,7 @@ methodCheck method request
acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ()) acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())
acceptCheck proxy accH acceptCheck proxy accH
| canHandleAcceptH proxy (AcceptHeader accH) = return $ Route () | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()
| otherwise = return $ Fail err406 | otherwise = return $ FailFatal err406
methodRouter :: (AllCTRender ctypes a) methodRouter :: (AllCTRender ctypes a)
=> Method -> Proxy ctypes -> Status => Method -> Proxy ctypes -> Status

View file

@ -33,34 +33,8 @@ data RouteResult a =
| Route !a | Route !a
deriving (Eq, Show, Read, Functor) deriving (Eq, Show, Read, Functor)
data ReqBodyState = Uncalled
| Called !B.ByteString
| Done !B.ByteString
toApplication :: RoutingApplication -> Application toApplication :: RoutingApplication -> Application
toApplication ra request respond = do toApplication ra request respond = ra request routingRespond
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
where where
routingRespond :: RouteResult Response -> IO ResponseReceived routingRespond :: RouteResult Response -> IO ResponseReceived
routingRespond (Fail err) = respond $ responseServantErr err routingRespond (Fail err) = respond $ responseServantErr err