git.iko.soy/typeable/servant
on master help sign in
Remove memoReqBody.
1aeee3eJulian K. Arni
servant-server/src/Servant/Server/Internal.hs+1−1
compare with master
unifiedsplit
@@ -158,7 +158,7 @@ methodCheck method request
158acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())
158acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())
159acceptCheck proxy accH
159acceptCheck proxy accH
160 | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()
160 | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()
161− | otherwise = return $ Fail err406
161+ | otherwise = return $ FailFatal err406
162
162
163methodRouter :: (AllCTRender ctypes a)
163methodRouter :: (AllCTRender ctypes a)
164 => Method -> Proxy ctypes -> Status
164 => Method -> Proxy ctypes -> Status
servant-server/src/Servant/Server/Internal/RoutingApplication.hs+1−27
@@ -33,34 +33,8 @@ data RouteResult a =
33 | Route !a
33 | Route !a
34 deriving (Eq, Show, Read, Functor)
34 deriving (Eq, Show, Read, Functor)
35
35
36−data ReqBodyState = Uncalled
37− | Called !B.ByteString
38− | Done !B.ByteString
39−
40toApplication :: RoutingApplication -> Application
36toApplication :: RoutingApplication -> Application
41−toApplication ra request respond = do
37+toApplication ra request respond = ra request routingRespond
42− reqBodyRef <- newIORef Uncalled
43− -- We may need to consume the requestBody more than once. In order to
44− -- maintain the illusion that 'requestBody' works as expected,
45− -- 'ReqBodyState' is introduced, and the complete body is memoized and
46− -- returned as many times as requested with empty "Done" marker chunks in
47− -- between.
48− -- See https://github.com/haskell-servant/servant/issues/3
49− let memoReqBody = do
50− ior <- readIORef reqBodyRef
51− case ior of
52− Uncalled -> do
53− r <- BL.toStrict <$> strictRequestBody request
54− writeIORef reqBodyRef $ Done r
55− return r
56− Called bs -> do
57− writeIORef reqBodyRef $ Done bs
58− return bs
59− Done bs -> do
60− writeIORef reqBodyRef $ Called bs
61− return B.empty
62−
63− ra request{ requestBody = memoReqBody } routingRespond
64 where
38 where
65 routingRespond :: RouteResult Response -> IO ResponseReceived
39 routingRespond :: RouteResult Response -> IO ResponseReceived
66 routingRespond (Fail err) = respond $ responseServantErr err
40 routingRespond (Fail err) = respond $ responseServantErr err