git.iko.soy/typeable/servant
on master help sign in
Merge pull request #3 from haskell-servant/jkarni/servant-issue-2
3ac502cJulian Arni
src/Servant/Server/Internal.hs+31−3
compare with master
unifiedsplit
@@ -10,22 +10,50 @@ module Servant.Server.Internal where
10import Control.Applicative
10import Control.Applicative
11import Control.Monad.Trans.Either
11import Control.Monad.Trans.Either
12import Data.Aeson
12import Data.Aeson
13+import qualified Data.ByteString as B
14+import qualified Data.ByteString.Lazy as BL
15+import Data.IORef
13import Data.Maybe (catMaybes)
16import Data.Maybe (catMaybes)
14import Data.Monoid
17import Data.Monoid
15import Data.Proxy
18import Data.Proxy
16import Data.String
19import Data.String
17import Data.String.Conversions
20import Data.String.Conversions
18−import Data.Text (Text)
19import Data.Text.Encoding (decodeUtf8)
21import Data.Text.Encoding (decodeUtf8)
22+import Data.Text (Text)
20import GHC.TypeLits
23import GHC.TypeLits
21import Network.HTTP.Types hiding (Header)
24import Network.HTTP.Types hiding (Header)
22import Network.Wai
25import Network.Wai
23import Servant.API
26import Servant.API
24import Servant.Common.Text
27import Servant.Common.Text
25
28
29+data ReqBodyState = Uncalled
30+ | Called !B.ByteString
31+ | Done !B.ByteString
32+
26toApplication :: RoutingApplication -> Application
33toApplication :: RoutingApplication -> Application
27toApplication ra request respond = do
34toApplication ra request respond = do
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+
28− ra request (routingRespond . routeResult)
56+ ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
29 where
57 where
30 routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
58 routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
31 routingRespond (Left NotFound) =
59 routingRespond (Left NotFound) =
@@ -44,7 +72,7 @@ data RouteMismatch =
44 | InvalidBody -- ^ an even more informative "your json request body wasn't valid" error
72 | InvalidBody -- ^ an even more informative "your json request body wasn't valid" error
45 deriving (Eq, Show)
73 deriving (Eq, Show)
46
74
47−-- |
75+-- |
48-- @
76-- @
49-- > mempty = NotFound
77-- > mempty = NotFound
50-- >
78-- >