kansas-comet 0.3.1 → 0.4
raw patch · 4 files changed
+131/−125 lines, 4 filesdep +data-default-classdep −data-defaultdep ~aesondep ~basedep ~containers
Dependencies added: data-default-class
Dependencies removed: data-default
Dependency ranges changed: aeson, base, containers, scotty, stm, text, time, transformers, unordered-containers
Files
- CHANGELOG.md +5/−0
- README.md +3/−0
- Web/Scotty/Comet.hs +110/−113
- kansas-comet.cabal +13/−12
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+## 0.4+* Require `scotty` >= 0.10+* `connect` now returns `IO (ScottyM ())`+* Allowed building with `base-4.8.0.0` and older `base`s (down to 4.3)+* Added `Eq` instances for `Document` and `Options`, and `Ord` and `Show` instances for `Options`
+ README.md view
@@ -0,0 +1,3 @@+# kansas-comet [](http://hackage.haskell.org/package/kansas-comet) [](https://travis-ci.org/ku-fpg/kansas-comet)++A JavaScript push mechanism and event listener support
Web/Scotty/Comet.hs view
@@ -13,15 +13,15 @@ ) where import Web.Scotty (ScottyM, text, post, capture, param, setHeader, get, ActionM, jsonData)-import Data.Aeson hiding ((.=))+import Data.Aeson (Value(..)) 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 Paths_kansas_comet (getDataFileName) import qualified Data.Map as Map import Control.Concurrent-import Data.Default+import Data.Default.Class import Data.Maybe ( fromJust ) import qualified Data.HashMap.Strict as HashMap import System.Exit@@ -39,27 +39,27 @@ connect :: Options -- ^ URL path prefix for this page -> (Document -> IO ()) -- ^ called for access of the page- -> ScottyM ()+ -> IO (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+ then 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)+ when (verbose opt >= 1) $ 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+ uniqVar <- newMVar 0 let getUniq :: IO Int getUniq = do u <- takeMVar uniqVar putMVar uniqVar (u + 1) return u - tm :: UTCTime <- liftIO $ getCurrentTime+ tm :: UTCTime <- getCurrentTime let server_id = Numeric.showHex (toModifiedJulianDay (utctDay tm))@@ -67,7 +67,7 @@ $ Numeric.showHex (floor (utctDayTime tm * 1000) :: Integer) $ "" - contextDB <- liftIO $ atomically $ newTVar $ (Map.empty :: Map.Map Int Document)+ contextDB <- atomically $ newTVar $ (Map.empty :: Map.Map Int Document) let newContext :: IO Int newContext = do uq <- getUniq@@ -84,110 +84,107 @@ 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 ()+ return $ do+ 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 "" -- | 'kCometPlugin' provides the location of the Kansas Comet jQuery plugin. kCometPlugin :: IO String-kCometPlugin = do- dataDir <- getDataDir- return $ dataDir ++ "/static/js/kansas-comet.js"+kCometPlugin = getDataFileName "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,@@ -216,13 +213,13 @@ , 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- }+ } deriving Eq -- '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- }+ } deriving (Eq, Ord, Show) instance Default Options where def = Options
kansas-comet.cabal view
@@ -1,5 +1,5 @@ Name: kansas-comet-Version: 0.3.1+Version: 0.4 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/issues@@ -11,6 +11,7 @@ Category: Web Stability: beta Build-type: Simple+extra-source-files: CHANGELOG.md, README.md Cabal-version: >= 1.10 Description: A transport-level remote JavaScript RESTful push mechanism.@@ -22,18 +23,18 @@ Exposed-modules: Web.Scotty.Comet other-modules: Paths_kansas_comet default-language: Haskell2010- build-depends: aeson >= 0.7 && < 0.9,- base >= 4.6 && < 4.8,- containers == 0.5.*,- data-default == 0.5.*,- scotty >= 0.8 && < 0.10,- stm >= 2.2 && < 2.5,- text >= 1.1 && < 1.3,- time >= 1.4 && < 1.6,- transformers >= 0.3 && < 0.5,- unordered-containers >= 0.2.3 && < 0.2.6+ build-depends: aeson >= 0.9 && < 0.11,+ base >= 4.6 && < 4.9,+ containers >= 0.4 && < 0.6,+ data-default-class == 0.0.*,+ scotty >= 0.10 && < 0.11,+ stm >= 2.2 && < 2.5,+ text >= 0.11.3.1 && < 1.3,+ time >= 1.2 && < 1.6,+ transformers >= 0.3 && < 0.5,+ unordered-containers >= 0.2.3 && < 0.2.6 - GHC-options: -Wall -fno-warn-orphans+ GHC-options: -Wall source-repository head type: git