Reading request body twice in happstack-server

Question

I have a problem reading the body twice in a happstack-server application.

I have embeded a library for user authentication (happstack-authenticate). happstack-authenticate has an JSON-Api to manage users and I trying access the same request body after the JSON-Api is called. Unfortunately this libray use the method takeRequestBody which destory the body, so I can't access the request body after this. Trying to access the body before the library is called shift only the problem because I also use takeRequestBody.

The reason why takeRequestBody deletes the content is because it is based on tryTakeMVAR.

Is there a workaround for my problem? Do i need to access the body twice or is there another solution? Or maybe there is another method to read the body which don't destroy the body?

Simple code to demonstrate the problem:

module Test where

import Data.Data                     ( Data, Typeable )
import Happstack.Server 
import Happstack.Authenticate.Core
import Data.Acid                     ( AcidState )
import Web.Routes                    ( RouteT(..) )
import Control.Monad.IO.Class        ( liftIO )
import qualified Data.ByteString.Lazy.Char8 as L


getBody :: RouteT AuthenticateURL (ServerPartT IO) L.ByteString
getBody = do
    req  <- askRq
    body <- liftIO $ takeRequestBody req
    case body of
        Just rqbody -> return . unBody $ rqbody
        Nothing     -> return (L.pack "")


route :: AcidState AuthenticateState -> (AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response)
        -> AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response
route authenticateState routeAuthenticate authenticateURL =
    do
        --routeAuthenticate is a routing function from Happstack.Authenticate
        routeAuthenticate authenticateURL
        body <- getBody
        ok $ toResponse body

Answer 1

I have implement a workaround, which use the function tryReadMVar instead tryTakeMVAR. With this fuction i can read the body without destroy it for the continuing process

peekRequestBody :: (MonadIO m) => Request -> m (Maybe RqBody)
peekRequestBody rq = liftIO $ tryReadMVar (rqBody rq)

getBody :: RouteT AuthenticateURL (ServerPartT IO) L.ByteString
getBody = do
    req  <- askRq
    body <- liftIO $ peekRequestBody req
    case body of
        Just rqbody -> return . unBody $ rqbody
        Nothing     -> return (L.pack "")