From 60046bad966be10777d6cd9fdf4e6de4ea4bb2ef Mon Sep 17 00:00:00 2001
From: Felipe Lessa <felipe.lessa@gmail.com>
Date: Mon, 20 Aug 2012 13:07:58 -0300
Subject: [PATCH] yesod-core: New handlerToIO function.

---
 yesod-core/Yesod/Handler.hs | 64 +++++++++++++++++++++++++++++++++++++
 1 file changed, 64 insertions(+)

diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs
index 6e70f20c..e6775471 100644
--- a/yesod-core/Yesod/Handler.hs
+++ b/yesod-core/Yesod/Handler.hs
@@ -95,6 +95,7 @@ module Yesod.Handler
     , newIdent
       -- * Lifting
     , MonadLift (..)
+    , handlerToIO
       -- * i18n
     , getMessageRender
       -- * Per-request caching
@@ -177,6 +178,7 @@ import Control.Exception.Lifted (catch)
 import Control.Monad.Trans.Control
 import Control.Monad.Trans.Resource
 import Control.Monad.Base
+import Data.Conduit.List (sourceList)
 import Yesod.Routes.Class
 import Data.Word (Word64)
 import Language.Haskell.TH.Syntax (Loc)
@@ -391,6 +393,68 @@ getCurrentRoute = handlerRoute `liftM` ask
 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
+--   runHandler <- handlerToIO
+--   liftIO $ forkIO $ runHandler $ 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 = sourceList [] }
+        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.
 runHandler :: HasReps c