diff --git a/Web/KansasComet.hs b/Web/KansasComet.hs deleted file mode 100644 --- a/Web/KansasComet.hs +++ /dev/null @@ -1,217 +0,0 @@ -{-# 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/Web/Scotty/Comet.hs b/Web/Scotty/Comet.hs new file mode 100644 --- /dev/null +++ b/Web/Scotty/Comet.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, KindSignatures, GADTs #-} +module Web.Scotty.Comet + ( connect + , kCometPlugin + , send + , Document + , Options(..) + , getReply + , eventQueue + , debugDocument + , debugReplyDocument + , defaultOptions + ) where + +import Web.Scotty (ScottyM, text, post, capture, param, setHeader, 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 System.Exit +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 + if not rtsSupportsBoundThreads -- we need the -threaded flag turned on + then liftIO $ do putStrLn "Application needs to be re-compiled with -threaded flag" + exitFailure + else return () + + + 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 + queue <- atomically $ newTChan + let cxt = Document picture callbacks queue 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 + setHeader "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.fromChunks [js] + Nothing -> + -- give the browser something to do (approx every 3 seconds) + text LT.empty + + 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 + setHeader "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 (replies doc) + writeTVar (replies doc) $ Map.insert uq val m + text $ LT.pack "" + + + post (capture $ prefix opt ++ "/event/" ++ server_id ++ "/:id") $ do + setHeader "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate" + num <- param "id" + + when (verbose opt >= 2) $ liftIO $ putStrLn $ + "Kansas Comet: post .../event/" ++ show num + + 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 $ atomically $ do + writeTChan (eventQueue doc) val + 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 Text 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 -> T.Text -> IO () +send doc js = atomically $ putTMVar (sending doc) $! 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 (replies doc) + case Map.lookup num db of + Nothing -> retry + Just r -> do + writeTVar (replies 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 + , replies :: TVar (Map.Map Int Value) -- ^ This is numbered replies, to ports + , eventQueue :: TChan Value -- ^ Events being sent + , _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 (default), 1 == inits, 2 == cmds done, 3 == complete log + } + +instance Default Options where + def = Options + { prefix = "" -- default to root, this assumes single page, etc. + , verbose = 0 + } + + +-- Defaults for 'Options'. Or you can use the defaults package. +defaultOptions :: Options +defaultOptions = def + +------------------------------------------------------------------------------------ + +-- | Generate a @Document@ that prints what it 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 + q <- atomically $ newTChan + return $ Document picture callbacks q 0 + +-- | Fake a specific reply on a virtual @Document@ port. +debugReplyDocument :: Document -> Int -> Value -> IO () +debugReplyDocument doc uq val = atomically $ do + m <- readTVar (replies doc) + writeTVar (replies doc) $ Map.insert uq val m + diff --git a/kansas-comet.cabal b/kansas-comet.cabal --- a/kansas-comet.cabal +++ b/kansas-comet.cabal @@ -1,15 +1,15 @@ Name: kansas-comet -Version: 0.2 +Version: 0.3.0 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/ +Bug-reports: https://github.com/ku-fpg/kansas-comet/issues License: BSD3 License-file: LICENSE Author: Andrew Gill , Andrew Farmer Maintainer: Andrew Gill -Copyright: (c) 2013 The University of Kansas +Copyright: (c) 2014 The University of Kansas Category: Web -Stability: experimental +Stability: beta Build-type: Simple Cabal-version: >= 1.10 Description: @@ -19,21 +19,19 @@ static/js/kansas-comet.js Library - Exposed-modules: Web.KansasComet + Exposed-modules: Web.Scotty.Comet other-modules: Paths_kansas_comet default-language: Haskell2010 - build-depends: base >= 4.5 && < 5, - unordered-containers >= 0.2.3 && < 0.3, - aeson == 0.6.*, + build-depends: base >= 4.6 && < 4.8, + unordered-containers >= 0.2.3 && <= 0.2.4.0, + aeson == 0.7.*, containers == 0.5.*, data-default == 0.5.*, - scotty >= 0.4.3 && < 0.5, - stm >= 2.2 && < 3.0, - transformers == 0.3.*, - text == 0.11.*, + scotty == 0.8.*, + stm >= 2.2 && < 2.5, + transformers >= 0.3 && < 0.5, + text >= 0.11.3.1 && < 1.2, time == 1.4.* - --- text is needed just for scotty's literal GHC-options: -Wall -fno-warn-orphans diff --git a/static/js/kansas-comet.js b/static/js/kansas-comet.js --- a/static/js/kansas-comet.js +++ b/static/js/kansas-comet.js @@ -3,7 +3,7 @@ var the_prefix = ""; var kansascomet_session; var kansascomet_server; - var eventQueues = {}; // TODO: add the use of the queue + var eventQueues = {}; var eventCallbacks = {}; var please_debug = false; @@ -57,6 +57,7 @@ }); // TODO: Add failure; could happen }, + // TODO: move register, send & waitFor into different library // This says someone is listening on a specific event // The full event name is "scope/eventname", for example // "body/click" @@ -134,7 +135,22 @@ data: "{ \"data\": " + $.toJSON(obj) + " }", contentType: "application/json; charset=utf-8", dataType: "json"}); - } + }, + event: function (obj) { + debug('event(' + $.toJSON(obj) + ')'); + $.ajax({ url: the_prefix + "/event/" + kansascomet_server + "/" + kansascomet_session, + 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);