From 183b640a55fedcccdafd4faa91ef2d3e9ff1d7d2 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Sun, 19 Aug 2012 14:52:30 -0300 Subject: [PATCH 01/14] New yesod-eventsource package. --- yesod-eventsource/LICENSE | 20 ++++++ yesod-eventsource/Yesod/EventSource.hs | 98 ++++++++++++++++++++++++++ yesod-eventsource/yesod-json.cabal | 42 +++++++++++ 3 files changed, 160 insertions(+) create mode 100644 yesod-eventsource/LICENSE create mode 100644 yesod-eventsource/Yesod/EventSource.hs create mode 100644 yesod-eventsource/yesod-json.cabal diff --git a/yesod-eventsource/LICENSE b/yesod-eventsource/LICENSE new file mode 100644 index 00000000..6baa863e --- /dev/null +++ b/yesod-eventsource/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2012 Felipe Lessa + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/yesod-eventsource/Yesod/EventSource.hs b/yesod-eventsource/Yesod/EventSource.hs new file mode 100644 index 00000000..989e4103 --- /dev/null +++ b/yesod-eventsource/Yesod/EventSource.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module contains everything that you need to support +-- server-sent events in Yesod applications. +module Yesod.EventSource + ( RepEventSource + , repEventSource + , ioToRepEventSource + , EventSourcePolyfill(..) + ) where + +import Blaze.ByteString.Builder (Builder) +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Data.Functor ((<$>)) +import Data.Monoid (mconcat) +import Yesod.Content +import Yesod.Core +import qualified Data.Conduit as C +import qualified Network.Wai as W +import qualified Network.Wai.EventSource as ES +import qualified Network.Wai.EventSource.EventStream as ES + + + +-- | Phantom type used for 'Handler'@s@ that are @EventSources@ +-- (e.g. 'repEventSource' and 'ioToRepEventSource'). +newtype RepEventSource = + RepEventSource (C.Source (C.ResourceT IO) (C.Flush Builder)) + +instance HasReps RepEventSource where + chooseRep (RepEventSource src) = + const $ return ("text/event-stream", ContentSource src) + + +-- | (Internal) Find out the request's 'EventSourcePolyfill' and +-- set any necessary headers. +prepareForEventSource :: GHandler sub master EventSourcePolyfill +prepareForEventSource = do + reqWith <- lookup "X-Requested-With" . W.requestHeaders <$> waiRequest + let polyfill | reqWith == Just "XMLHttpRequest" = Remy'sESPolyfill + | otherwise = NoESPolyfill + setHeader "Cache-Control" "no-cache" -- extremely important! + return polyfill + + +-- | Returns a Server-Sent Event stream from a 'C.Source' of +-- 'ES.ServerEvent'@s@. The HTTP socket is flushed after every +-- event. The connection is closed either when the 'C.Source' +-- finishes outputting data or a 'ES.CloseEvent' is outputted, +-- whichever comes first. +repEventSource :: (EventSourcePolyfill -> C.Source (C.ResourceT IO) ES.ServerEvent) + -> GHandler sub master RepEventSource +repEventSource src = RepEventSource . ES.sourceToSource . src <$> prepareForEventSource + + +-- | Return a Server-Sent Event stream given an @IO@ action that +-- is repeatedly called. An state is threaded for the action so +-- that it may avoid using @IORefs@. The @IO@ action may sleep +-- or block while waiting for more data. The HTTP socket is +-- flushed after every list of simultaneous events. The +-- connection is closed as soon as an 'ES.CloseEvent' is +-- outputted, after which no other events are sent to the client. +ioToRepEventSource :: s + -> (EventSourcePolyfill -> s -> IO ([ES.ServerEvent], s)) + -> GHandler sub master RepEventSource +ioToRepEventSource initial act = do + polyfill <- prepareForEventSource + let -- Get new events to be sent. + getEvents s = do + (evs, s') <- liftIO (act polyfill s) + let (builder, continue) = joinEvents evs [] + C.yield (C.Chunk builder) + C.yield C.Flush + when continue (getEvents s') + + -- Join all events in a single Builder. Returns @False@ + -- when we the connection should be closed. + joinEvents (ev:evs) acc = + case ES.eventToBuilder ev of + Just b -> joinEvents evs (b:acc) + Nothing -> (fst $ joinEvents [] acc, False) + joinEvents [] acc = (mconcat (reverse acc), True) + + return $ RepEventSource $ getEvents initial + + +-- | Which @EventSource@ polyfill was detected (if any). +data EventSourcePolyfill = + NoESPolyfill + -- ^ We didn't detect any @EventSource@ polyfill that we know. + | Remy'sESPolyfill + -- ^ See + -- . + -- In order to support Remy\'s polyfill, your server needs to + -- explicitly close the connection from time to + -- time--browsers such as IE7 will not show any event until + -- the connection is closed. + deriving (Eq, Ord, Show, Enum) diff --git a/yesod-eventsource/yesod-json.cabal b/yesod-eventsource/yesod-json.cabal new file mode 100644 index 00000000..88b1bef2 --- /dev/null +++ b/yesod-eventsource/yesod-json.cabal @@ -0,0 +1,42 @@ +name: yesod-eventsource +version: 1.0 +license: MIT +license-file: LICENSE +author: Felipe Lessa +maintainer: Felipe Lessa +synopsis: Server-sent events support for Yesod apps. +category: Web, Yesod +stability: Stable +cabal-version: >= 1.6 +build-type: Simple +homepage: http://www.yesodweb.com/ +description: + It's easy to send an event from an HTTP client to a server: + just send an HTTP request. However, sending events from the + server to the client requires more sophisticated approaches. + Server-sent events () are a + standardized way of pushing events from the server to the + client. + . + This package allows your Yesod application to easily send + server-sent events. On the client side, you may use the + @EventSource@ JavaScript object on browsers that support it + (https://developer.mozilla.org/en-US/docs/Server-sent_events/EventSource) + or a polyfill for browsers that don't (we support Remy's + polyfill out-of-the-box, although that requires you to + explicitly support it). + +library + build-depends: base >= 4 && < 5 + , yesod-core >= 1.1 && < 1.2 + , conduit >= 0.5 && < 0.6 + , wai >= 1.3 && < 1.4 + , wai-eventsource >= 1.3 && < 1.4 + , blaze-builder + , transformers + exposed-modules: Yesod.EventSource + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/yesodweb/yesod From b8b5ec49fbacac0dae4fb77dc773413d2fcf3352 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Sun, 19 Aug 2012 14:59:16 -0300 Subject: [PATCH 02/14] wai-eventsource: Add a Setup.lhs file. --- yesod-eventsource/Setup.lhs | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100755 yesod-eventsource/Setup.lhs diff --git a/yesod-eventsource/Setup.lhs b/yesod-eventsource/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/yesod-eventsource/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain From 765fa90eae75d97400d644f6750ac98f497b3f12 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Sun, 19 Aug 2012 15:00:35 -0300 Subject: [PATCH 03/14] wai-eventsource: Fix incorrect naming of the Cabal file. --- yesod-eventsource/{yesod-json.cabal => yesod-eventsource.cabal} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename yesod-eventsource/{yesod-json.cabal => yesod-eventsource.cabal} (100%) diff --git a/yesod-eventsource/yesod-json.cabal b/yesod-eventsource/yesod-eventsource.cabal similarity index 100% rename from yesod-eventsource/yesod-json.cabal rename to yesod-eventsource/yesod-eventsource.cabal From c8abfa15e38adc03116ce17535a58dffc7a2210b Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Sun, 19 Aug 2012 15:04:58 -0300 Subject: [PATCH 04/14] wai-eventsource: Small doc fix. --- yesod-eventsource/yesod-eventsource.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-eventsource/yesod-eventsource.cabal b/yesod-eventsource/yesod-eventsource.cabal index 88b1bef2..351d59aa 100644 --- a/yesod-eventsource/yesod-eventsource.cabal +++ b/yesod-eventsource/yesod-eventsource.cabal @@ -21,7 +21,7 @@ description: This package allows your Yesod application to easily send server-sent events. On the client side, you may use the @EventSource@ JavaScript object on browsers that support it - (https://developer.mozilla.org/en-US/docs/Server-sent_events/EventSource) + () or a polyfill for browsers that don't (we support Remy's polyfill out-of-the-box, although that requires you to explicitly support it). From e0462b294c00508c68ca3d9824f790b36990cb21 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Mon, 20 Aug 2012 11:32:13 -0300 Subject: [PATCH 05/14] wai-eventsource: Minor typo. --- yesod-eventsource/Yesod/EventSource.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-eventsource/Yesod/EventSource.hs b/yesod-eventsource/Yesod/EventSource.hs index 989e4103..501b4e61 100644 --- a/yesod-eventsource/Yesod/EventSource.hs +++ b/yesod-eventsource/Yesod/EventSource.hs @@ -54,7 +54,7 @@ repEventSource src = RepEventSource . ES.sourceToSource . src <$> prepareForEven -- | Return a Server-Sent Event stream given an @IO@ action that --- is repeatedly called. An state is threaded for the action so +-- is repeatedly called. A state is threaded for the action so -- that it may avoid using @IORefs@. The @IO@ action may sleep -- or block while waiting for more data. The HTTP socket is -- flushed after every list of simultaneous events. The From 600fec4852ce2f8333a0aa8aa07e9179ed3a1f16 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Mon, 20 Aug 2012 11:34:50 -0300 Subject: [PATCH 06/14] wai-eventsource: Do not Flush needlessly on ioToRepEventSource. --- yesod-eventsource/Yesod/EventSource.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/yesod-eventsource/Yesod/EventSource.hs b/yesod-eventsource/Yesod/EventSource.hs index 501b4e61..14948bd5 100644 --- a/yesod-eventsource/Yesod/EventSource.hs +++ b/yesod-eventsource/Yesod/EventSource.hs @@ -68,10 +68,13 @@ ioToRepEventSource initial act = do let -- Get new events to be sent. getEvents s = do (evs, s') <- liftIO (act polyfill s) - let (builder, continue) = joinEvents evs [] - C.yield (C.Chunk builder) - C.yield C.Flush - when continue (getEvents s') + case evs of + [] -> getEvents s' + _ -> do + let (builder, continue) = joinEvents evs [] + C.yield (C.Chunk builder) + C.yield C.Flush + when continue (getEvents s') -- Join all events in a single Builder. Returns @False@ -- when we the connection should be closed. From 93b2c3acf17c0d652f4a52ed68d49cad6af93645 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Mon, 20 Aug 2012 11:37:46 -0300 Subject: [PATCH 07/14] wai-eventsource: Avoid mconcat and reverse on ioToRepEventSource. --- yesod-eventsource/Yesod/EventSource.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/yesod-eventsource/Yesod/EventSource.hs b/yesod-eventsource/Yesod/EventSource.hs index 14948bd5..c860459a 100644 --- a/yesod-eventsource/Yesod/EventSource.hs +++ b/yesod-eventsource/Yesod/EventSource.hs @@ -12,7 +12,7 @@ import Blaze.ByteString.Builder (Builder) import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Data.Functor ((<$>)) -import Data.Monoid (mconcat) +import Data.Monoid (mappend, mempty) import Yesod.Content import Yesod.Core import qualified Data.Conduit as C @@ -71,7 +71,7 @@ ioToRepEventSource initial act = do case evs of [] -> getEvents s' _ -> do - let (builder, continue) = joinEvents evs [] + let (builder, continue) = joinEvents evs mempty C.yield (C.Chunk builder) C.yield C.Flush when continue (getEvents s') @@ -80,9 +80,9 @@ ioToRepEventSource initial act = do -- when we the connection should be closed. joinEvents (ev:evs) acc = case ES.eventToBuilder ev of - Just b -> joinEvents evs (b:acc) + Just b -> joinEvents evs (acc `mappend` b) Nothing -> (fst $ joinEvents [] acc, False) - joinEvents [] acc = (mconcat (reverse acc), True) + joinEvents [] acc = (acc, True) return $ RepEventSource $ getEvents initial From 828c99fb7b86367465bf90298dce7c05610afd7d Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Mon, 20 Aug 2012 11:39:11 -0300 Subject: [PATCH 08/14] wai-eventsource: Fix misleading doc on RepEventSource. --- yesod-eventsource/Yesod/EventSource.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-eventsource/Yesod/EventSource.hs b/yesod-eventsource/Yesod/EventSource.hs index c860459a..522116ea 100644 --- a/yesod-eventsource/Yesod/EventSource.hs +++ b/yesod-eventsource/Yesod/EventSource.hs @@ -22,8 +22,8 @@ import qualified Network.Wai.EventSource.EventStream as ES --- | Phantom type used for 'Handler'@s@ that are @EventSources@ --- (e.g. 'repEventSource' and 'ioToRepEventSource'). +-- | Data type representing a response of server-sent events +-- (e.g., see 'repEventSource' and 'ioToRepEventSource'). newtype RepEventSource = RepEventSource (C.Source (C.ResourceT IO) (C.Flush Builder)) From 927ae17b193d0753fe8763bd651caf52464b94b3 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Mon, 20 Aug 2012 11:39:53 -0300 Subject: [PATCH 09/14] yesod-eventsource: Bump version to 1.0.0.1. --- yesod-eventsource/yesod-eventsource.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-eventsource/yesod-eventsource.cabal b/yesod-eventsource/yesod-eventsource.cabal index 351d59aa..446ba75a 100644 --- a/yesod-eventsource/yesod-eventsource.cabal +++ b/yesod-eventsource/yesod-eventsource.cabal @@ -1,5 +1,5 @@ name: yesod-eventsource -version: 1.0 +version: 1.0.0.1 license: MIT license-file: LICENSE author: Felipe Lessa From 60046bad966be10777d6cd9fdf4e6de4ea4bb2ef Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Mon, 20 Aug 2012 13:07:58 -0300 Subject: [PATCH 10/14] 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 From 786b5bc6e27b54d521fa0b77d0fc98d100f154ef Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Mon, 20 Aug 2012 13:09:43 -0300 Subject: [PATCH 11/14] yesod-core: On handlerToIO's docs, avoid shadowing a name. --- yesod-core/Yesod/Handler.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index e6775471..89231650 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -403,8 +403,8 @@ getRouteToMaster = handlerToMaster `liftM` ask -- @ -- getFooR :: Handler RepHtml -- getFooR = do --- runHandler <- handlerToIO --- liftIO $ forkIO $ runHandler $ do +-- runInnerHandler <- handlerToIO +-- liftIO $ forkIO $ runInnerHandler $ do -- /Code here runs inside GHandler but on a new thread./ -- /This is the inner GHandler./ -- ... From dc14783c818cbe3cd198e122f3481ba5b8ce2cd9 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Mon, 20 Aug 2012 13:13:46 -0300 Subject: [PATCH 12/14] yesod-core: On handlerToIO, avoid 'sourceList []'. --- yesod-core/Yesod/Handler.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 89231650..811d8f54 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -178,7 +178,6 @@ 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) @@ -436,7 +435,7 @@ handlerToIO = -- Let go of the request body, cache and response headers. let oldReq = handlerRequest oldHandlerData oldWaiReq = reqWaiRequest oldReq - newWaiReq = oldWaiReq { W.requestBody = sourceList [] } + newWaiReq = oldWaiReq { W.requestBody = mempty } newReq = oldReq { reqWaiRequest = newWaiReq , reqBodySize = 0 } newState <- liftIO $ do From 0346dab14c839b72b6e0ed822b0b9c888d02c772 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Tue, 21 Aug 2012 13:29:53 -0300 Subject: [PATCH 13/14] yesod-core: New function runFakeHandler. --- yesod-core/Yesod/Core.hs | 1 + yesod-core/Yesod/Internal/Core.hs | 71 +++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 8a5c2cb3..294d17bf 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -40,6 +40,7 @@ module Yesod.Core -- * Misc , yesodVersion , yesodRender + , runFakeHandler -- * Re-exports , module Yesod.Content , module Yesod.Dispatch diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 0eb78497..a92db0d1 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -36,6 +36,7 @@ module Yesod.Internal.Core , resolveApproot , Approot (..) , FileUpload (..) + , runFakeHandler ) where import Yesod.Content @@ -55,6 +56,7 @@ import Yesod.Internal.Request 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.Builder (toLazyText) 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,71 @@ loadClientSession key timeout sessionName master req now = return (sess, save) expires = fromIntegral (timeout * 60) `addUTCTime` now' sessionVal iv = encodeClientSession key iv expires host sess' + +-- | Runs a 'GHandler' completely outside of Yesod. This +-- function comes with many caveats and you shouldn't use it +-- unless you 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. +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." #-} From 20f51e38e2fd68fdffe199af985349e1b17ddf2a Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Tue, 21 Aug 2012 13:38:15 -0300 Subject: [PATCH 14/14] yesod-core: Doc improvements for runFakeHandler. --- yesod-core/Yesod/Internal/Core.hs | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index a92db0d1..6562e6b8 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -756,15 +756,26 @@ loadClientSession key timeout sessionName master req now = return (sess, save) sessionVal iv = encodeClientSession key iv expires host sess' --- | Runs a 'GHandler' completely outside of Yesod. This +-- | Run a 'GHandler' completely outside of Yesod. This -- function comes with many caveats and you shouldn't use it --- unless you understand what it's doing and how it works. +-- 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)