From 83f55259fa45f2ecfc73e0c2833ec262347a0fdb Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Fri, 2 Jan 2015 19:34:15 +0100
Subject: [PATCH 1/4] Memoize requestBody IO action.
---
src/Servant/Server/Internal.hs | 14 ++++++++++----
1 file changed, 10 insertions(+), 4 deletions(-)
diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs
index a706c211..8a8d423a 100644
--- a/src/Servant/Server/Internal.hs
+++ b/src/Servant/Server/Internal.hs
@@ -10,13 +10,14 @@ module Servant.Server.Internal where
import Control.Applicative
import Control.Monad.Trans.Either
import Data.Aeson
-import Data.Maybe (catMaybes)
+import Data.IORef
+import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid
import Data.Proxy
import Data.String
import Data.String.Conversions
-import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
+import Data.Text (Text)
import GHC.TypeLits
import Network.HTTP.Types hiding (Header)
import Network.Wai
@@ -25,7 +26,12 @@ import Servant.Common.Text
toApplication :: RoutingApplication -> Application
toApplication ra request respond = do
- ra request (routingRespond . routeResult)
+ reqBodyRef <- newIORef Nothing
+ let memoReqBody = fromMaybe <$> (do
+ r <- requestBody request
+ writeIORef reqBodyRef $ Just r
+ return r ) <*> readIORef reqBodyRef
+ ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
where
routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
routingRespond (Left NotFound) =
@@ -44,7 +50,7 @@ data RouteMismatch =
| InvalidBody -- ^ an even more informative "your json request body wasn't valid" error
deriving (Eq, Show)
--- |
+-- |
-- @
-- > mempty = NotFound
-- >
From ecb1da0e37a260b0ee9123a57ddbd10b4d39b70d Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Sat, 3 Jan 2015 18:07:39 +0100
Subject: [PATCH 2/4] Cycle through ByteString.
---
src/Servant/Server/Internal.hs | 28 ++++++++++++++++++++++------
1 file changed, 22 insertions(+), 6 deletions(-)
diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs
index 8a8d423a..2b16fea0 100644
--- a/src/Servant/Server/Internal.hs
+++ b/src/Servant/Server/Internal.hs
@@ -10,8 +10,10 @@ module Servant.Server.Internal where
import Control.Applicative
import Control.Monad.Trans.Either
import Data.Aeson
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
import Data.IORef
-import Data.Maybe (catMaybes, fromMaybe)
+import Data.Maybe (catMaybes)
import Data.Monoid
import Data.Proxy
import Data.String
@@ -24,13 +26,27 @@ import Network.Wai
import Servant.API
import Servant.Common.Text
+data ReqBodyState = Uncalled
+ | Called B.ByteString
+ | Done B.ByteString
+
toApplication :: RoutingApplication -> Application
toApplication ra request respond = do
- reqBodyRef <- newIORef Nothing
- let memoReqBody = fromMaybe <$> (do
- r <- requestBody request
- writeIORef reqBodyRef $ Just r
- return r ) <*> readIORef reqBodyRef
+ reqBodyRef <- newIORef Uncalled
+ 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 . routeResult)
where
routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
From 726848b8a3e58bc92172bc1bedd7e9d72d2b9b8c Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Sat, 3 Jan 2015 18:16:26 +0100
Subject: [PATCH 3/4] Add comment about what the bug was. Make ReqBodyState
strict.
---
src/Servant/Server/Internal.hs | 7 +++++--
1 file changed, 5 insertions(+), 2 deletions(-)
diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs
index 2b16fea0..5a9fbe5b 100644
--- a/src/Servant/Server/Internal.hs
+++ b/src/Servant/Server/Internal.hs
@@ -27,12 +27,15 @@ import Servant.API
import Servant.Common.Text
data ReqBodyState = Uncalled
- | Called B.ByteString
- | Done B.ByteString
+ | Called !B.ByteString
+ | Done !B.ByteString
toApplication :: RoutingApplication -> Application
toApplication ra request respond = do
reqBodyRef <- newIORef Uncalled
+ -- We need to check the requestBody possibly more than once, so instead
+ -- of consuming it entirely once, we cycle through it.
+ -- See https://github.com/haskell-servant/servant/issues/3
let memoReqBody = do
ior <- readIORef reqBodyRef
case ior of
From b43301967d20c160ef624129a0b20e596261af22 Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Sun, 4 Jan 2015 16:08:22 +0100
Subject: [PATCH 4/4] Update reqBodyRef comment.
---
src/Servant/Server/Internal.hs | 7 +++++--
1 file changed, 5 insertions(+), 2 deletions(-)
diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs
index 5a9fbe5b..e87a4733 100644
--- a/src/Servant/Server/Internal.hs
+++ b/src/Servant/Server/Internal.hs
@@ -33,8 +33,11 @@ data ReqBodyState = Uncalled
toApplication :: RoutingApplication -> Application
toApplication ra request respond = do
reqBodyRef <- newIORef Uncalled
- -- We need to check the requestBody possibly more than once, so instead
- -- of consuming it entirely once, we cycle through it.
+ -- 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