Remove memoReqBody.
This commit is contained in:
parent
b9fb80ac5e
commit
1aeee3ef94
2 changed files with 2 additions and 28 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue