diff --git a/Yesod/Core.hs b/Yesod/Core.hs --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -40,6 +40,7 @@ -- * Misc , yesodVersion , yesodRender + , runFakeHandler -- * Re-exports , module Yesod.Content , module Yesod.Dispatch diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -95,6 +95,7 @@ , newIdent -- * Lifting , MonadLift (..) + , handlerToIO -- * i18n , getMessageRender -- * Per-request caching @@ -390,6 +391,68 @@ -- master site. getRouteToMaster :: GHandler sub master (Route sub -> Route master) getRouteToMaster = handlerToMaster `liftM` ask + + +-- | Returns a function that runs 'GHandler' actions inside @IO@. +-- +-- Sometimes you want to run an inner 'GHandler' action outside +-- the control flow of an HTTP request (on the outer 'GHandler' +-- action). For example, you may want to spawn a new thread: +-- +-- @ +-- getFooR :: Handler RepHtml +-- getFooR = do +-- runInnerHandler <- handlerToIO +-- liftIO $ forkIO $ runInnerHandler $ do +-- /Code here runs inside GHandler but on a new thread./ +-- /This is the inner GHandler./ +-- ... +-- /Code here runs inside the request's control flow./ +-- /This is the outer GHandler./ +-- ... +-- @ +-- +-- Another use case for this function is creating a stream of +-- server-sent events using 'GHandler' actions (see +-- @yesod-eventsource@). +-- +-- Most of the environment from the outer 'GHandler' is preserved +-- on the inner 'GHandler', however: +-- +-- * The request body is cleared (otherwise it would be very +-- difficult to prevent huge memory leaks). +-- +-- * The cache is cleared (see 'CacheKey'). +-- +-- Changes to the response made inside the inner 'GHandler' are +-- ignored (e.g., session variables, cookies, response headers). +-- This allows the inner 'GHandler' to outlive the outer +-- 'GHandler' (e.g., on the @forkIO@ example above, a response +-- may be sent to the client without killing the new thread). +handlerToIO :: MonadIO m => GHandler sub master (GHandler sub master a -> m a) +handlerToIO = + GHandler $ \oldHandlerData -> do + -- Let go of the request body, cache and response headers. + let oldReq = handlerRequest oldHandlerData + oldWaiReq = reqWaiRequest oldReq + newWaiReq = oldWaiReq { W.requestBody = mempty } + newReq = oldReq { reqWaiRequest = newWaiReq + , reqBodySize = 0 } + newState <- liftIO $ do + oldState <- I.readIORef (handlerState oldHandlerData) + return $ oldState { ghsRBC = Nothing + , ghsIdent = 1 + , ghsCache = mempty + , ghsHeaders = mempty } + + -- Return GHandler running function. + return $ \(GHandler f) -> liftIO $ do + -- The state IORef needs to be created here, otherwise it + -- will be shared by different invocations of this function. + newStateIORef <- I.newIORef newState + runResourceT $ f oldHandlerData { handlerRequest = newReq + , handlerState = newStateIORef } + -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'W.Application'. Should not be needed by users. diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs --- a/Yesod/Internal/Core.hs +++ b/Yesod/Internal/Core.hs @@ -36,6 +36,7 @@ , resolveApproot , Approot (..) , FileUpload (..) + , runFakeHandler ) where import Yesod.Content @@ -55,6 +56,7 @@ import qualified Web.ClientSession as CS import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L +import qualified Data.IORef as I import Data.Monoid import Text.Hamlet import Text.Julius @@ -64,6 +66,7 @@ import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Maybe (fromMaybe, isJust) import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Resource (runResourceT) import Web.Cookie (parseCookies) import qualified Data.Map as Map import Data.Time @@ -752,3 +755,82 @@ expires = fromIntegral (timeout * 60) `addUTCTime` now' sessionVal iv = encodeClientSession key iv expires host sess' + +-- | Run a 'GHandler' completely outside of Yesod. This +-- function comes with many caveats and you shouldn't use it +-- unless you fully understand what it's doing and how it works. +-- +-- As of now, there's only one reason to use this function at +-- all: in order to run unit tests of functions inside 'GHandler' +-- but that aren't easily testable with a full HTTP request. +-- Even so, it's better to use @wai-test@ or @yesod-test@ instead +-- of using this function. +-- +-- This function will create a fake HTTP request (both @wai@'s +-- 'W.Request' and @yesod@'s 'Request') and feed it to the +-- @GHandler@. The only useful information the @GHandler@ may +-- get from the request is the session map, which you must supply +-- as argument to @runFakeHandler@. All other fields contain +-- fake information, which means that they can be accessed but +-- won't have any useful information. The response of the +-- @GHandler@ is completely ignored, including changes to the +-- session, cookies or headers. We only return you the +-- @GHandler@'s return value. +runFakeHandler :: (Yesod master, MonadIO m) => + SessionMap + -> (master -> Logger) + -> master + -> GHandler master master a + -> m (Either ErrorResponse a) +runFakeHandler fakeSessionMap logger master handler = liftIO $ do + ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") + let handler' = do liftIO . I.writeIORef ret . Right =<< handler + return () + let YesodApp yapp = + runHandler + handler' + (yesodRender master "") + Nothing + id + master + master + (fileUpload master) + (messageLogger master $ logger master) + errHandler err = + YesodApp $ \_ _ _ session -> do + liftIO $ I.writeIORef ret (Left err) + return $ YARPlain + H.status500 + [] + typePlain + (toContent ("runFakeHandler: errHandler" :: S8.ByteString)) + session + fakeWaiRequest = + W.Request + { W.requestMethod = "POST" + , W.httpVersion = H.http11 + , W.rawPathInfo = "/runFakeHandler/pathInfo" + , W.rawQueryString = "" + , W.serverName = "runFakeHandler-serverName" + , W.serverPort = 80 + , W.requestHeaders = [] + , W.isSecure = False + , W.remoteHost = error "runFakeHandler-remoteHost" + , W.pathInfo = ["runFakeHandler", "pathInfo"] + , W.queryString = [] + , W.requestBody = mempty + , W.vault = mempty + } + fakeRequest = + Request + { reqGetParams = [] + , reqCookies = [] + , reqWaiRequest = fakeWaiRequest + , reqLangs = [] + , reqToken = Just "NaN" -- not a nonce =) + , reqBodySize = 0 + } + fakeContentType = [] + _ <- runResourceT $ yapp errHandler fakeRequest fakeContentType fakeSessionMap + I.readIORef ret +{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.1.0.1 +version: 1.1.1 license: MIT license-file: LICENSE author: Michael Snoyman