diff --git a/bundles/_bootstrap/bootstrap.js b/bundles/_bootstrap/bootstrap.js --- a/bundles/_bootstrap/bootstrap.js +++ b/bundles/_bootstrap/bootstrap.js @@ -2,17 +2,21 @@ * Bootstrapping code. */ var Dingo; -Dingo = (function () { - var encoders = {}; - var decoders = {}; +Dingo = (function ($) { + "use strict"; + var exports, encoders, decoders; + exports = {}; + encoders = {}; + decoders = {}; + function getWidget(i) { return $('#i' + i); } function encodeAll(encoders) { var encodedState = {}; - $.each(encoders, function(widgetId, encoder) { + $.each(encoders, function (widgetId, encoder) { var widget; widget = getWidget(widgetId); if (widget.length > 0) { @@ -24,56 +28,39 @@ return encodedState; } - function addEncoder(id, encoderFunc) { + exports.addEncoder = function (id, encoderFunc) { if (encoderFunc !== null) { encoders[id] = encoderFunc; } - } + }; - function addDecoder(id, decoderFunc) { + exports.addDecoder = function (id, decoderFunc) { if (decoderFunc !== null) { decoders[id] = decoderFunc; } - } + }; - function setWidgetValue(id, json) { + exports.setWidgetValue = function (id, json) { var d = decoders[id]; if (typeof d === 'function') { d.call(getWidget(id), json); } - } + }; - // Long polling handler. + // Initialize event source for receiving updates. function poll() { - var delay = 0; - // Otherwise we start one... - console.log("Starting long polling..."); - $.ajax({ - error : function (xhr, status, err) { - if (err === 'timeout') { - delay = 0; // timeout means we need to retry immediately - } else { - delay = 15000; // don't hammer the server - } - }, - success : function (data, status, xhr) { - // Start polling immediately again. - delay = 0; - }, - complete : function () { - // Restart poll. - setTimeout(poll, delay); - }, - timeout : 60000, - data : { }, - type : 'GET', - dataType : 'script', - url: '/poll' - }); + var eventSource; + + console.log("Starting event source..."); + + eventSource = new EventSource("poll"); + eventSource.onmessage = function(msg) { + eval(msg.data); + }; } // Set up the callback handler. - function callback(id) { + exports.callback = function (id) { var encodedState; // Go. encodedState = encodeAll(encoders); @@ -98,14 +85,11 @@ dataType : 'script', url: '/callback/' + id }); - } + }; + // Return the methods. - return { 'callback' : callback, - 'addEncoder' : addEncoder, - 'addDecoder' : addDecoder, - 'setWidgetValue' : setWidgetValue - }; -}()); + return exports; +}(jQuery)); /* * Bootstrap. diff --git a/dingo-core.cabal b/dingo-core.cabal --- a/dingo-core.cabal +++ b/dingo-core.cabal @@ -1,5 +1,5 @@ Name: dingo-core -Version: 0.0.3.5 +Version: 0.1.0 Synopsis: Dingo is a Rich Internet Application platform based on the Warp web server. Description: Dingo is a Rich Internet Application platform based on the Warp web server. It allows you to write code which looks very much like regular GUI code and have it work in the browser. @@ -17,17 +17,17 @@ Library Build-Depends: base == 4.* - , aeson >= 0.3.2.12 && <0.4 - , attoparsec >= 0.9.0.0 && < 0.10 + , aeson >= 0.5 && <0.6 + , attoparsec >= 0.10 && < 0.11 , base64-bytestring >= 0.1 && < 0.2 , bytestring >= 0.9.0.1 , blaze-builder >= 0.3 && <0.4 , blaze-html >= 0.4.1.6 && < 0.5 , blaze-textual >= 0.2.0.5 && < 0.3 + , conduit >= 0.1 && < 0.2 , containers >= 0.4 , cookie >= 0.3.0 && < 0.4 , deepseq >= 1.1 && < 1.2 - , enumerator >= 0.4 && < 0.5 , file-embed >= 0.0.4 && < 0.1 , fclabels == 1.0.* , hashable >= 1.1.0.0 && < 1.2 @@ -40,9 +40,10 @@ , text == 0.11.* , transformers >= 0.2.2 && < 0.3 , unordered-containers >= 0.1.4 && < 0.2 - , wai == 0.4.* - , wai-extra == 0.4.* - , warp == 0.4.* + , wai == 1.0.* + , wai-eventsource == 1.0.* + , wai-extra == 1.0.* + , warp == 1.0.* , web-css == 0.1.* Extensions: CPP DeriveDataTypeable @@ -72,7 +73,6 @@ Dingo.Internal.EventTypes Dingo.Internal.Html Dingo.Internal.JavaScript - Dingo.Internal.Queue Dingo.Internal.ResourceBundle.Internal Dingo.Internal.ResourceBundle.Boot Dingo.Internal.Server.State diff --git a/src/Dingo/Internal/JavaScript.hs b/src/Dingo/Internal/JavaScript.hs --- a/src/Dingo/Internal/JavaScript.hs +++ b/src/Dingo/Internal/JavaScript.hs @@ -2,7 +2,6 @@ ( renderCommandsToJs ) where -import Blaze.ByteString.Builder (toLazyByteString) import Data.Aeson (Value) import Data.Aeson.Encode (fromValue) import Data.ByteString (ByteString) @@ -10,7 +9,7 @@ import Data.Monoid (mconcat) import Data.Text (Text) import qualified Data.Text as TS -import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) +import Data.Text.Lazy.Encoding (encodeUtf8) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import Dingo.Internal.Base (Command(..)) @@ -22,7 +21,7 @@ -- Convert a JSON value to Javascript. instance ToJavascript Value where toJavascript json = - toJavascript $ decodeUtf8 $ toLazyByteString $ fromValue json + toJavascript $ TLB.toLazyText $ fromValue json jsHtml :: Html -> TL.Text jsHtml html = TLB.toLazyText $ diff --git a/src/Dingo/Internal/Queue.hs b/src/Dingo/Internal/Queue.hs deleted file mode 100644 --- a/src/Dingo/Internal/Queue.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Dingo.Internal.Queue - ( readChanTimeout - ) where - -import Control.Concurrent (forkIO, threadDelay, killThread, myThreadId) -import Control.Concurrent.Chan.Strict (Chan, readChan) -import Control.Concurrent.MVar.Strict (newEmptyMVar, putMVar, takeMVar) -import Control.DeepSeq (NFData) - --- Read a Chan with timeout. -readChanTimeout :: NFData a => Chan a -> Int -> IO (Maybe a) -readChanTimeout ch timeout = do - result <- newEmptyMVar - _ <- forkIO $ do - wid <- myThreadId - readerThreadId <- forkIO $ do - x <- readChan ch - killThread wid - putMVar result (Just x) - threadDelay timeout - killThread readerThreadId - putMVar result Nothing - -- Block waiting for either timeout or the read. - takeMVar result diff --git a/src/Dingo/Internal/Server/State.hs b/src/Dingo/Internal/Server/State.hs --- a/src/Dingo/Internal/Server/State.hs +++ b/src/Dingo/Internal/Server/State.hs @@ -8,12 +8,12 @@ , getSession , getSessionId , handleCallback - , readCommandWithTimeout + , readCommand , ssApplicationTitle , ssBootResourceBundles ) where -import Control.Concurrent.Chan.Strict (Chan, newChan, writeChan) +import Control.Concurrent.Chan.Strict (Chan, newChan, readChan, writeChan) import Control.DeepSeq.ByteString () import Control.Monad (replicateM) import Data.Aeson (Value(..)) @@ -31,7 +31,6 @@ import Dingo.Internal.Base (CallbackId, WidgetId) import Dingo.Internal.CallbackTypes (WrapCallback(..), CallbackM, mkSession, getCommands) import Dingo.Internal.JavaScript (renderCommandsToJs) -import Dingo.Internal.Queue (readChanTimeout) import Dingo.Internal.ResourceBundle.Boot (bootResourceBundles) import Dingo.Internal.Session (SessionState, runSessionT, runCallback) import Dingo.ResourceBundle (ResourceBundle) @@ -130,16 +129,8 @@ -- Update the session reference. atomicModifyIORef clientSessionRef (\_ -> (ClientSessionState sessionState' commandsChan, ())) --- Wait for a command to appear in the queue. -readCommandWithTimeout :: ServerState -> ClientSession -> Int -> IO (Maybe ByteString) -readCommandWithTimeout serverState clientSession timeout = do - serverStateM <- readIORef $ L.get ssClientSessions serverState - case M.lookup clientSessionId serverStateM of - Nothing -> return Nothing - Just sessionRef -> do - commandsChan <- fmap (L.get cssCommandsForClient) $ readIORef sessionRef - readChanTimeout commandsChan timeout - - where - - clientSessionId = fst clientSession +-- Wait for a command to appear in the queue and return it. +readCommand :: ClientSession -> IO ByteString +readCommand clientSession = do + commandsChan <- fmap (L.get cssCommandsForClient) $ readIORef $ snd clientSession + readChan commandsChan diff --git a/src/Dingo/Internal/Server/Wai.hs b/src/Dingo/Internal/Server/Wai.hs --- a/src/Dingo/Internal/Server/Wai.hs +++ b/src/Dingo/Internal/Server/Wai.hs @@ -3,33 +3,37 @@ ) where import Blaze.ByteString.Builder (fromByteString, toByteString) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Chan (newChan, writeChan) import Control.DeepSeq.ByteString () -import Control.Monad (forM_) +import Control.Monad (forM_, forever, void) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (resourceForkIO) import Data.Aeson (Value(..)) import qualified Data.Aeson.Parser as AEP import Data.Attoparsec (Parser) import qualified Data.Attoparsec as AP import Data.ByteString (ByteString) -import Data.Enumerator (Iteratee) +import qualified Data.ByteString as B +import Data.Conduit (ResourceT, ($$)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as H import Data.IORef (readIORef) import qualified Data.Label as L -import qualified Data.Map as M import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid (mempty) import Data.Text (Text) import qualified Data.Text.Encoding as TE import Dingo.Internal.Base import Dingo.Internal.Html (mkHeadMerge) -import Dingo.Internal.Server.State (ServerState, ClientSession, SessionId, ssApplicationTitle, ssBootResourceBundles, handleCallback, readCommandWithTimeout, getSession, getSessionId, cssClientSessionState) +import Dingo.Internal.Server.State (ServerState, ClientSession, SessionId, ssApplicationTitle, ssBootResourceBundles, handleCallback, readCommand, getSession, getSessionId, cssClientSessionState) import Dingo.Internal.Session (lookupResource) import Dingo.ResourceBundle (ResourceBundle) import Network.HTTP.Types (statusOK, statusForbidden, headerContentType, Header, ResponseHeaders) import Network.Wai (Request(..), Response(..)) import qualified Network.Wai as W import Network.Wai.Parse (parseRequestBody, lbsSink) +import Network.Wai.EventSource (eventSourceApp, ServerEvent(..)) import Text.Blaze ((!), toHtml, unsafeByteStringValue) import qualified Text.Blaze.Html4.Strict as H4 import qualified Text.Blaze.Html4.Strict.Attributes as A @@ -40,13 +44,9 @@ headerSetCookie :: SetCookie -> Header headerSetCookie s = ("Set-Cookie", toByteString $ renderSetCookie s) --- Timeout for poll requests. -longPollTimeout :: Int -longPollTimeout = 30 * 1000 * 1000 - --- JavaScript content type. -jsContentType :: ByteString -jsContentType = "text/javascript;charset=utf-8" +-- Keep-alive interval for events. +eventSourceKeepAlive :: Int +eventSourceKeepAlive = 5 * 1000 * 1000 -- HTML content type. htmlContentType :: ByteString @@ -102,7 +102,7 @@ Left _ -> H.empty -- Error parsing; ignore. Right (Object o) -> - H.fromList $ mapMaybe f $ M.toList o + H.fromList $ mapMaybe f $ H.toList o Right _ -> H.empty -- Invalid format; ignore. where @@ -110,15 +110,15 @@ fmap (\i -> (i,v)) $ parseOnlyText widgetIdParser k -- Callback server part. -callback :: Request -> ClientSession -> Text -> Iteratee ByteString IO Response +callback :: Request -> ClientSession -> Text -> ResourceT IO Response callback request clientSession callbackIdStr = handle $ parseOnlyText callbackIdParser callbackIdStr where - handle :: Maybe CallbackId -> Iteratee ByteString IO Response + handle :: Maybe CallbackId -> ResourceT IO Response handle Nothing = return forbiddenResponse handle (Just callbackId) = do -- Post body contains URL-encoded data. - (params, _) <- parseRequestBody lbsSink request + (params, _) <- requestBody request $$ parseRequestBody lbsSink request let stateJson = fromMaybe "{}" $ lookup "state" params -- Get the state update portion of the form data. let stateUpdates = convertStateUpdates stateJson @@ -127,11 +127,24 @@ return emptyOKResponse -- Long polling handler. -poll :: ServerState -> ClientSession -> Iteratee ByteString IO Response -poll serverState clientSession = do - command <- liftIO $ readCommandWithTimeout serverState clientSession longPollTimeout - let command_ = fromMaybe "" command - return $ ResponseBuilder statusOK [headerContentType jsContentType] $ fromByteString command_ +poll :: ClientSession -> Request -> ResourceT IO Response +poll clientSession request = do + evChan <- liftIO $ newChan + -- Introduce a thread which issues keep-alive events. + void $ resourceForkIO $ forever $ liftIO $ do + threadDelay eventSourceKeepAlive + writeChan evChan $ CommentEvent $ fromByteString "keep-alive" + -- Introduce a thread which transforms commands from client session to events. + void $ resourceForkIO $ forever $ liftIO $ do + c <- readCommand clientSession + writeChan evChan $ ServerEvent Nothing Nothing + [ fromByteString $ B.map escape c ] + -- Serve the events. + eventSourceApp evChan request + where + -- Replace all non-printable characters with a space. + escape c | c < 0x20 = 0x20 + escape c | otherwise = c -- Generate SetCookie session header if necessary. generateSessionSetCookie :: Maybe SessionId -> ClientSession -> Maybe SetCookie @@ -140,7 +153,7 @@ | otherwise = Just $ mkSessionCookie $ getSessionId clientSession -- Serve a bundle. -serveBundle :: ClientSession -> [Text] -> Iteratee ByteString IO Response +serveBundle :: ClientSession -> [Text] -> ResourceT IO Response serveBundle _ [] = return forbiddenResponse serveBundle clientSession (bundleId:path) = do clientSessionStateRef <- liftIO $ readIORef (snd clientSession) @@ -155,7 +168,6 @@ mkWaiApplication :: ServerState -> W.Application mkWaiApplication serverState = loop where - loop :: Request -> Iteratee ByteString IO Response loop request = do -- Extract the cookies. let cookies = @@ -178,7 +190,7 @@ -- Process the request case pathInfo request of [] -> return $ indexResponse serverState responseHeaders - ["poll"] -> poll serverState clientSession + ["poll"] -> poll clientSession request ["callback",cid] -> callback request clientSession cid ("bundles":bundlePath) -> serveBundle clientSession bundlePath _ -> return forbiddenResponse