diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Web/KansasComet.hs b/Web/KansasComet.hs new file mode 100644 --- /dev/null +++ b/Web/KansasComet.hs @@ -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// <- get a specific action +-- > POST http://.../foobar/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 + diff --git a/kansas-comet.cabal b/kansas-comet.cabal new file mode 100644 --- /dev/null +++ b/kansas-comet.cabal @@ -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 , Andrew Farmer +Maintainer: Andrew Gill +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 diff --git a/static/js/kansas-comet.js b/static/js/kansas-comet.js new file mode 100644 --- /dev/null +++ b/static/js/kansas-comet.js @@ -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); + + + + +