Merge branch 'master' of github.com:yesodweb/yesod

yesod-core/Yesod/Core.hs

@@ -40,6 +40,7 @@ module Yesod.Core
       -- * Misc
     , yesodVersion
     , yesodRender
+    , runFakeHandler
       -- * Re-exports
     , module Yesod.Content
     , module Yesod.Dispatch

yesod-core/Yesod/Handler.hs

@@ -95,6 +95,7 @@ module Yesod.Handler
     , newIdent
       -- * Lifting
     , MonadLift (..)
+    , handlerToIO
       -- * i18n
     , getMessageRender
       -- * Per-request caching
@@ -391,6 +392,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
+--   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.
 runHandler :: HasReps c

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,82 @@ loadClientSession key timeout sessionName master req now = return (sess, save)
           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." #-}

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.

yesod-eventsource/Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

yesod-eventsource/Yesod/EventSource.hs

@@ -0,0 +1,101 @@
+{-# 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 (mappend, mempty)
+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
+
+
+
+-- | 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))
+
+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.  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
+-- 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)
+        case evs of
+          [] -> getEvents s'
+          _  -> do
+            let (builder, continue) = joinEvents evs mempty
+            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 (acc `mappend` b)
+          Nothing -> (fst $ joinEvents [] acc, False)
+      joinEvents [] acc = (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
+    -- <https://github.com/remy/polyfills/blob/master/EventSource.js>.
+    -- 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)

yesod-eventsource/yesod-eventsource.cabal

@@ -0,0 +1,42 @@
+name:            yesod-eventsource
+version:         1.0.0.1
+license:         MIT
+license-file:    LICENSE
+author:          Felipe Lessa <felipe.lessa@gmail.com>
+maintainer:      Felipe Lessa <felipe.lessa@gmail.com>
+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 (<http://www.w3.org/TR/eventsource/>) 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