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] 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
 -- >