kansas-comet 0.3.0 → 0.4.4
raw patch · 4 files changed
Files
- CHANGELOG.md +20/−0
- README.md +3/−0
- Web/Scotty/Comet.hs +115/−102
- kansas-comet.cabal +29/−13
+ CHANGELOG.md view
@@ -0,0 +1,20 @@+## 0.4.4 [2026.01.10]+* Allow building with `base-4.22.*` and `time-1.15.*` (GHC 9.14).+* Allow building with `scotty-0.30.*`.+* Remove unused `transformers` and `unordered-containers` dependencies.++## 0.4.3 [2024.10.26]+* Allow building with `data-default-class-0.2.*`.+* Drop support for pre-8.0 versions of GHC.++## 0.4.2 [2023.10.05]+* Support building with `scotty-0.20`.++## 0.4.1 [2021.10.09]+* Allow building with `aeson-2.0.0.0`.++## 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://github.com/ku-fpg/kansas-comet/actions?query=workflow%3AHaskell-CI)++A JavaScript push mechanism and event listener support
Web/Scotty/Comet.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, KindSignatures, GADTs #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Web.Scotty.Comet ( connect , kCometPlugin@@ -12,18 +16,19 @@ , defaultOptions ) where -import Web.Scotty (ScottyM, text, post, capture, param, setHeader, get, ActionM, jsonData)-import Data.Aeson hiding ((.=))+import qualified Web.Scotty as Scotty+import Web.Scotty (ScottyM, text, post, capture, setHeader, get, ActionM, jsonData)+import Data.Aeson (Value(..))+import qualified Data.Aeson.KeyMap as KeyMap 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 import qualified Data.Text.Lazy as LT import qualified Data.Text as T@@ -39,27 +44,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- else return () - - - when (verbose opt >= 1) $ liftIO $ putStrLn $ "kansas-comet connect with prefix=" ++ show (prefix opt)+ then do putStrLn "Application needs to be re-compiled with -threaded flag"+ exitFailure+ else return () ++ 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 +72,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 +89,118 @@ return uq -- POST starts things off.- post (capture $ prefix opt ++ "/") $ do- uq <- liftIO $ newContext- text (LT.pack $ "$.kc.session(" ++ show server_id ++ "," ++ show uq ++ ");")+ 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?)+ -- 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"+ -- 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 <- captureParam "id" - when (verbose opt >= 2) $ liftIO $ putStrLn $- "Kansas Comet: get .../act/" ++ show num--- liftIO $ print (num :: Int)+ 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)+ 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+ 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+ 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+ 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)+ post (capture $ prefix opt ++ "/reply/" ++ server_id ++ "/:id/:uq") $ do+ setHeader "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate"+ num <- captureParam "id"+ uq :: Int <- captureParam "uq"+ --liftIO $ print (num :: Int, event :: String) - when (verbose opt >= 2) $ liftIO $ putStrLn $- "Kansas Comet: post .../reply/" ++ show num ++ "/" ++ show uq+ 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 ""+ wrappedVal :: Value <- jsonData+ -- Unwrap the data wrapped, because 'jsonData' only supports+ -- objects or arrays, but not primitive values like numbers+ -- or booleans.+ m <- case wrappedVal of+ Object m -> return m+ _ -> fail $ "Expected Object, received: " ++ show wrappedVal+ let val = fromJust $ KeyMap.lookup "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+ mv <- readTVar (replies doc)+ writeTVar (replies doc) $ Map.insert uq val mv+ 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"+ post (capture $ prefix opt ++ "/event/" ++ server_id ++ "/:id") $ do+ setHeader "Cache-Control" "max-age=0, no-cache, private, no-store, must-revalidate"+ num <- captureParam "id" - when (verbose opt >= 2) $ liftIO $ putStrLn $- "Kansas Comet: post .../event/" ++ show num + 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)+ wrappedVal :: Value <- jsonData+ -- Unwrap the data wrapped, because 'jsonData' only supports+ -- objects or arrays, but not primitive values like numbers+ -- or booleans.+ m <- case wrappedVal of+ Object m -> return m+ _ -> fail $ "Expected Object, received: " ++ show wrappedVal+ let val = fromJust $ KeyMap.lookup "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 ()+ 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 "" + where+#if MIN_VERSION_scotty(0,20,0)+ captureParam = Scotty.captureParam+#else+ captureParam = Scotty.param+#endif+ -- | '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 +229,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.0+Version: 0.4.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,7 +11,22 @@ Category: Web Stability: beta Build-type: Simple+extra-source-files: CHANGELOG.md, README.md Cabal-version: >= 1.10+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1 Description: A transport-level remote JavaScript RESTful push mechanism. @@ -22,19 +37,20 @@ Exposed-modules: Web.Scotty.Comet other-modules: Paths_kansas_comet default-language: Haskell2010- 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.8.*,- stm >= 2.2 && < 2.5,- transformers >= 0.3 && < 0.5,- text >= 0.11.3.1 && < 1.2,- time == 1.4.*+ build-depends: aeson >= 2 && < 2.3,+ base >= 4.9 && < 4.23,+ containers >= 0.4 && < 0.9,+ data-default-class >= 0.0.1 && < 0.3,+ -- TODO: Eventually, we should bump the lower version+ -- bounds to >=0.20 so that we can remove some CPP in+ -- Web.Scotty.Comet.+ scotty >= 0.10 && < 0.31,+ stm >= 2.2 && < 2.6,+ text >= 0.11.3.1 && < 2.2,+ time >= 1.2 && < 1.16 - GHC-options: -Wall -fno-warn-orphans+ GHC-options: -Wall source-repository head type: git- location: git://github.com/ku-fpg/kansas-comet.git+ location: https://github.com/ku-fpg/kansas-comet.git