diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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` diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# kansas-comet [![Hackage version](https://img.shields.io/hackage/v/kansas-comet.svg?style=flat)](http://hackage.haskell.org/package/kansas-comet) [![Build Status](https://github.com/ku-fpg/kansas-comet/workflows/Haskell-CI/badge.svg)](https://github.com/ku-fpg/kansas-comet/actions?query=workflow%3AHaskell-CI) + +A JavaScript push mechanism and event listener support diff --git a/Web/Scotty/Comet.hs b/Web/Scotty/Comet.hs --- a/Web/Scotty/Comet.hs +++ b/Web/Scotty/Comet.hs @@ -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 diff --git a/kansas-comet.cabal b/kansas-comet.cabal --- a/kansas-comet.cabal +++ b/kansas-comet.cabal @@ -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