@@ -10,22 +10,50 @@ module Servant.Server.Internal where
1010import Control.Applicative
1111import Control.Monad.Trans.Either
1212import Data.Aeson
13+import qualified Data.ByteString as B
14+import qualified Data.ByteString.Lazy as BL
15+import Data.IORef
1316import Data.Maybe (catMaybes)
1417import Data.Monoid
1518import Data.Proxy
1619import Data.String
1720import Data.String.Conversions
18−import Data.Text (Text)
1921import Data.Text.Encoding (decodeUtf8)
22+import Data.Text (Text)
2023import GHC.TypeLits
2124import Network.HTTP.Types hiding (Header)
2225import Network.Wai
2326import Servant.API
2427import Servant.Common.Text
2528
29+data ReqBodyState = Uncalled
30+ | Called !B.ByteString
31+ | Done !B.ByteString
32+
2633toApplication :: RoutingApplication -> Application
2734toApplication ra request respond = do
28− ra request (routingRespond . routeResult)
35+ reqBodyRef <- newIORef Uncalled
36+ -- We may need to consume the requestBody more than once. In order to
37+ -- maintain the illusion that 'requestBody' works as expected,
38+ -- 'ReqBodyState' is introduced, and the complete body is memoized and
39+ -- returned as many times as requested with empty "Done" marker chunks in
40+ -- between.
41+ -- See https://github.com/haskell-servant/servant/issues/3
42+ let memoReqBody = do
43+ ior <- readIORef reqBodyRef
44+ case ior of
45+ Uncalled -> do
46+ r <- BL.toStrict <$> strictRequestBody request
47+ writeIORef reqBodyRef $ Done r
48+ return r
49+ Called bs -> do
50+ writeIORef reqBodyRef $ Done bs
51+ return bs
52+ Done bs -> do
53+ writeIORef reqBodyRef $ Called bs
54+ return B.empty
55+
56+ ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
2957 where
3058 routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
3159 routingRespond (Left NotFound) =
@@ -44,7 +72,7 @@ data RouteMismatch =
4472 | InvalidBody -- ^ an even more informative "your json request body wasn't valid" error
4573 deriving (Eq, Show)
4674
47−-- |
75+-- |
4876-- @
4977-- > mempty = NotFound
5078-- >