kansas-comet (empty) → 0.2
raw patch · 5 files changed
+435/−0 lines, 5 filesdep +aesondep +basedep +containerssetup-changed
Dependencies added: aeson, base, containers, data-default, scotty, stm, text, time, transformers, unordered-containers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Web/KansasComet.hs +217/−0
- kansas-comet.cabal +42/−0
- static/js/kansas-comet.js +144/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2013, The University of Kansas++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Andy Gill nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Web/KansasComet.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, KindSignatures, GADTs #-}+module Web.KansasComet+ ( connect+ , kCometPlugin+ , send+ , Document+ , Options(..)+ , getReply+ , debugDocument+ , debugReplyDocument+ ) where++import Web.Scotty (ScottyM, text, post, capture, param, header, get, ActionM, jsonData)+import Data.Aeson hiding ((.=))+import Control.Monad+import Control.Concurrent.STM as STM+import Control.Concurrent.MVar as STM+import Control.Monad.IO.Class+import Paths_kansas_comet+import qualified Data.Map as Map+import Control.Concurrent+import Data.Default+import Data.Maybe ( fromJust )+import qualified Data.HashMap.Strict as HashMap++import qualified Data.Text.Lazy as LT+import qualified Data.Text as T+import Data.Time.Calendar+import Data.Time.Clock+import Numeric++-- | connect "/foobar" (...) gives a scotty session that:+--+-- > POST http://.../foobar/ <- bootstrap the interaction+-- > GET http://.../foobar/act/<id#>/<act#> <- get a specific action+-- > POST http://.../foobar/reply/<id#>/<reply#> <- send a reply as a JSON object++connect :: Options -- ^ URL path prefix for this page+ -> (Document -> IO ()) -- ^ called for access of the page+ -> ScottyM ()+connect opt callback = do+ when (verbose opt >= 1) $ liftIO $ putStrLn $ "kansas-comet connect with prefix=" ++ show (prefix opt)++ -- A unique number generator, or ephemeral generator.+ -- This is the (open) secret between the client and server.+ -- (Why are we using an MVar vs a TMVar? No specific reason here)+ uniqVar <- liftIO $ newMVar 0+ let getUniq :: IO Int+ getUniq = do+ u <- takeMVar uniqVar+ putMVar uniqVar (u + 1)+ return u++ tm :: UTCTime <- liftIO $ getCurrentTime++ let server_id+ = Numeric.showHex (toModifiedJulianDay (utctDay tm))+ $ ("-" ++)+ $ Numeric.showHex (floor (utctDayTime tm * 1000) :: Integer)+ $ ""++ contextDB <- liftIO $ atomically $ newTVar $ (Map.empty :: Map.Map Int Document)+ let newContext :: IO Int+ newContext = do+ uq <- getUniq+ picture <- atomically $ newEmptyTMVar+ callbacks <- atomically $ newTVar $ Map.empty+ let cxt = Document picture callbacks uq+ liftIO $ atomically $ do+ db <- readTVar contextDB+ -- assumes the getUniq is actually unique+ writeTVar contextDB $ Map.insert uq cxt db+ -- Here is where we actually spawn the user code+ _ <- forkIO $ callback cxt+ return uq++ -- POST starts things off.+ post (capture $ prefix opt ++ "/") $ do+ uq <- liftIO $ newContext+ text (LT.pack $ "$.kc.session(" ++ show server_id ++ "," ++ show uq ++ ");")++ -- GET the updates to the documents (should this be an (empty) POST?)++-- liftIO $ print $ prefix opt ++ "/act/:id/:act"+ get (capture $ prefix opt ++ "/act/" ++ server_id ++ "/:id/:act") $ do+ header "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate"+ -- do something and return a new list of commands to the client+ num <- param "id"++ when (verbose opt >= 2) $ liftIO $ putStrLn $+ "Kansas Comet: get .../act/" ++ show num+-- liftIO $ print (num :: Int)++ let tryPushAction :: TMVar T.Text -> Int -> ActionM ()+ tryPushAction var n = do+ -- The PUSH archtecture means that we wait upto 3 seconds if there+ -- is not javascript to push yet. This stops a busy-waiting+ -- (or technically restricts it to once every 3 second busy)+ ping <- liftIO $ registerDelay (3 * 1000 * 1000)+ res <- liftIO $ atomically $ do+ b <- readTVar ping+ if b then return Nothing else do+ liftM Just (takeTMVar var)+++ when (verbose opt >= 2) $ liftIO $ putStrLn $+ "Kansas Comet (sending to " ++ show n ++ "):\n" ++ show res++ case res of+ Just js -> do+-- liftIO $ putStrLn $ show js+ text $ LT.pack $ T.unpack js+ Nothing ->+ -- give the browser something to do (approx every 3 seconds)+ text (LT.pack "")++ db <- liftIO $ atomically $ readTVar contextDB+ case Map.lookup num db of+ Nothing -> text (LT.pack $ "console.warn('Can not find act #" ++ show num ++ "');")+ Just doc -> tryPushAction (sending doc) num+++ post (capture $ prefix opt ++ "/reply/" ++ server_id ++ "/:id/:uq") $ do+ header "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate"+ num <- param "id"+ uq :: Int <- param "uq"+ --liftIO $ print (num :: Int, event :: String)++ when (verbose opt >= 2) $ liftIO $ putStrLn $+ "Kansas Comet: post .../reply/" ++ show num ++ "/" ++ show uq++ wrappedVal :: Value <- jsonData+ -- Unwrap the data wrapped, because 'jsonData' only supports+ -- objects or arrays, but not primitive values like numbers+ -- or booleans.+ let val = fromJust $ let (Object m) = wrappedVal+ in HashMap.lookup (T.pack "data") m+ --liftIO $ print (val :: Value)+ db <- liftIO $ atomically $ readTVar contextDB+ case Map.lookup num db of+ Nothing -> do+ text (LT.pack $ "console.warn('Ignore reply for session #" ++ show num ++ "');")+ Just doc -> do+ liftIO $ do+ atomically $ do+ m <- readTVar (listening doc)+ writeTVar (listening doc) $ Map.insert uq val m+ text $ LT.pack ""++ return ()++-- | 'kCometPlugin' provides the location of the Kansas Comet jQuery plugin.+kCometPlugin :: IO String+kCometPlugin = do+ dataDir <- getDataDir+ return $ dataDir ++ "/static/js/kansas-comet.js"++-- | 'send' sends a javascript fragement to a document.+-- The string argument will be evaluated before sending (in case there is an error,+-- or some costly evaluation needs done first).+-- 'send' suspends the thread if the last javascript has not been *dispatched*+-- the the browser.+send :: Document -> String -> IO ()+send doc js = atomically $ putTMVar (sending doc) $! T.pack js++-- | wait for a virtual-to-this-document's port numbers' reply.+getReply :: Document -> Int -> IO Value+getReply doc num = do+ atomically $ do+ db <- readTVar (listening doc)+ case Map.lookup num db of+ Nothing -> retry+ Just r -> do+ writeTVar (listening doc) $ Map.delete num db+ return r+++-- | 'Document' is the Handle into a specific interaction with a web page.+data Document = Document+ { sending :: TMVar T.Text -- ^ Code to be sent to the browser+ -- This is a TMVar to stop the generation+ -- getting ahead of the rendering engine+ , listening :: TVar (Map.Map Int Value) -- ^ This is numbered replies.+ , _secret :: Int -- ^ the (session) number of this document+ }++-- 'Options' for Comet.+data Options = Options+ { prefix :: String -- ^ what is the prefix at at start of the URL (for example \"ajax\")+ , verbose :: Int -- ^ 0 == none, 1 == inits, 2 == cmds done, 3 == complete log+ }++instance Default Options where+ def = Options+ { prefix = "" -- default to root, this assumes single page, etc.+ , verbose = 1+ }+++------------------------------------------------------------------------------------++-- | Generate a @Document@ that prints what is would send to the server.+debugDocument :: IO Document+debugDocument = do+ picture <- atomically $ newEmptyTMVar+ callbacks <- atomically $ newTVar $ Map.empty+ _ <- forkIO $ forever $ do+ res <- atomically $ takeTMVar $ picture+ putStrLn $ "Sending: " ++ show res+ return $ Document picture callbacks 0++-- | Fake a specific reply on a virtual @Document@ port.+debugReplyDocument :: Document -> Int -> Value -> IO ()+debugReplyDocument doc uq val = atomically $ do+ m <- readTVar (listening doc)+ writeTVar (listening doc) $ Map.insert uq val m+
+ kansas-comet.cabal view
@@ -0,0 +1,42 @@+Name: kansas-comet+Version: 0.2+Synopsis: A JavaScript push mechanism based on the comet idiom+Homepage: https://github.com/ku-fpg/kansas-comet/+Bug-reports: https://github.com/ku-fpg/kansas-comet/+License: BSD3+License-file: LICENSE+Author: Andrew Gill <andygill@ku.edu>, Andrew Farmer <anfarmer@ku.edu>+Maintainer: Andrew Gill <andygill@ku.edu>+Copyright: (c) 2013 The University of Kansas+Category: Web+Stability: experimental+Build-type: Simple+Cabal-version: >= 1.10+Description:+ A transport-level remote JavaScript RESTful push mechanism.++data-files:+ static/js/kansas-comet.js++Library+ Exposed-modules: Web.KansasComet+ other-modules: Paths_kansas_comet+ default-language: Haskell2010+ build-depends: base >= 4.5 && < 5,+ unordered-containers >= 0.2.3 && < 0.3,+ aeson == 0.6.*,+ containers == 0.5.*,+ data-default == 0.5.*,+ scotty >= 0.4.3 && < 0.5,+ stm >= 2.2 && < 3.0,+ transformers == 0.3.*,+ text == 0.11.*,+ time == 1.4.*++-- text is needed just for scotty's literal++ GHC-options: -Wall -fno-warn-orphans++source-repository head+ type: git+ location: git://github.com/ku-fpg/kansas-comet.git
+ static/js/kansas-comet.js view
@@ -0,0 +1,144 @@+// Kansas Comet jQuery plugin+(function($) {+ var the_prefix = "";+ var kansascomet_session;+ var kansascomet_server;+ var eventQueues = {}; // TODO: add the use of the queue+ var eventCallbacks = {};+ var please_debug = false;++ var debug = function () { };++ var failure_callback = function(ig,ty,msg,re) {+ console.error("redraw failed (retrying) : " + ig + "," + ty + "," + msg);+ }++ $.kc = {+ // If we want to debug, then add a true+ connect: function(prefix) {+ the_prefix = prefix;+ // if there is a ?debug=0, then send debug messages to it+ if (window.location.search == '?debug=1') {+ console.log("using logging to console for " + prefix);+ debug = function(arg) {+ console.log(arg);+ };+ }++ $.ajax({ url: the_prefix,+ type: "POST",+ data: "",+ dataType: "script"});+ debug('connect(' + prefix + ')');+ },++ session: function(server_id, session_id) {+ kansascomet_server = server_id;+ kansascomet_session = session_id;+ debug('session(' + session_id + ')');+ $.kc.register("session","abort",null);+ $.kc.redraw(0);+ },++ // Set failure behavior+ failure: function(f) {+ failure_callback = f;+ },++ redraw: function (count) {+ debug('redraw(' + count + ') url = ' + the_prefix + "/act/" + kansascomet_server + "/" + kansascomet_session + "/" + count);+ $.ajax({ url: the_prefix + "/act/" + kansascomet_server + "/" + kansascomet_session + "/" + count,+ type: "GET",+ dataType: "script",+ success: function success() { $.kc.redraw(count + 1); },+ error: function failure(ig,ty,msg) { + failure_callback(ig,ty,msg,function() { $.kc.redraw(count + 1); });+ }+ });+ // TODO: Add failure; could happen+ },+ // This says someone is listening on a specific event+ // The full event name is "scope/eventname", for example+ // "body/click"+ register: function (scope, eventname, fn) {+ debug('register(' + scope + ',' + eventname + ')');+ var fulleventname = scope + "/" + eventname;+ eventQueues[fulleventname] = [];+ if (fn == null) {+ // no special setup required, because no callback to call.+ } else {+ $(scope).on(eventname, "." + eventname, function (event,aux) {+ var e = fn(this,event,aux);+ debug('{callback}on(' + eventname + ')');+ e.eventname = eventname;+ $.kc.send(fulleventname,e);+ });+ }+ },++ send: function (fulleventname, event) {+ debug('send(' + fulleventname + ')');+ if (eventCallbacks[fulleventname] == undefined) {+ if (eventQueues[fulleventname] != undefined) { + eventQueues[fulleventname].push(event);+ } else {+ debug('send(' + fulleventname + ') not sent (no one listening)');+ }+ } else {+ eventCallbacks[fulleventname](event);+ }+ },+ + // This waits for (full) named event(s). The second argument is the continuation+ waitFor: function (scope, eventnames, fn) {+ debug('waitFor(' + scope + ',' + eventnames + ')');+ var prefixScope = function(o) { return scope + "/" + o; }+ for (eventname in eventnames) {+ var e = eventQueues[prefixScope(eventnames[eventname])].shift();+ if (e != undefined) {+ // call with event from queue+ fn(e);+ // and we are done+ return; + }+ if (eventCallbacks[prefixScope(eventnames[eventname])] != undefined) {+ alert("ABORT: event queue callback failure for " + eventname);+ }+ }+ // All the callback better be undefined+ var f = function (e) {+ // delete all the waiting callback(s)+ for (eventname in eventnames) {+ delete eventCallbacks[prefixScope(eventnames[eventname])];+ }+ // and do the callback+ fn(e);+ };+ for (eventname in eventnames) {+ eventCallbacks[prefixScope(eventnames[eventname])] = f;+ }+ },+ // There is a requirement that obj be an object or array.+ // See RFC 4627 for details.+ reply: function (uq,obj) {+ debug('reply(' + uq + ')');+ $.ajax({ url: the_prefix + "/reply/" + kansascomet_server + "/" + kansascomet_session + "/" + uq,+ type: "POST",+ // This wrapper is needed because the JSON parser+ // used on the Haskell side only supports objects+ // and arrays. But the returned data might be just+ // a number or a boolean. So this wrapper keeps + // the value safe to parse and has to be unwrapped + // on server side. Formatting it as string is also+ // important for some reason.+ data: "{ \"data\": " + $.toJSON(obj) + " }",+ contentType: "application/json; charset=utf-8",+ dataType: "json"});+ }+ };+})(jQuery);+++++