eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Memoize requestBody IO action.

Browse source
This commit is contained in:
Julian K. Arni 2015-01-02 19:34:15 +01:00
parent 1e6fbd111d
commit 83f55259fa
1 changed files with 10 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
src/Servant/Server/Internal.hs
View file

@ -10,13 +10,14 @@ module Servant.Server.Internal where
import Control.Applicative import Control.Applicative
import Control.Monad.Trans.Either import Control.Monad.Trans.Either
import Data.Aeson import Data.Aeson
import Data.Maybe (catMaybes) import Data.IORef
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid import Data.Monoid
import Data.Proxy import Data.Proxy
import Data.String import Data.String
import Data.String.Conversions import Data.String.Conversions
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8) import Data.Text.Encoding (decodeUtf8)
import Data.Text (Text)
import GHC.TypeLits import GHC.TypeLits
import Network.HTTP.Types hiding (Header) import Network.HTTP.Types hiding (Header)
import Network.Wai import Network.Wai
@ -25,7 +26,12 @@ import Servant.Common.Text
toApplication :: RoutingApplication -> Application toApplication :: RoutingApplication -> Application
toApplication ra request respond = do 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 where
routingRespond :: Either RouteMismatch Response -> IO ResponseReceived routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
routingRespond (Left NotFound) = routingRespond (Left NotFound) =