kansas-comet 0.2 → 0.3.0

raw patch · 4 files changed

+286/−233 lines, 4 filesdep ~aesondep ~basedep ~scottyPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, base, scotty, stm, text, transformers, unordered-containers

API changes (from Hackage documentation)

Files

• Web/KansasComet.hs +0/−217
• Web/Scotty/Comet.hs +256/−0
• kansas-comet.cabal +12/−14
• static/js/kansas-comet.js +18/−2

@@ -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/<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-

@@ -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/<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+   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+

@@ -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 <andygill@ku.edu>, Andrew Farmer <anfarmer@ku.edu> Maintainer:          Andrew Gill <andygill@ku.edu>-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 

@@ -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);