kansas-comet 0.4 → 0.4.1
raw patch · 4 files changed
+78/−41 lines, 4 filesdep ~aesondep ~basedep ~containersnew-uploader
Dependency ranges changed: aeson, base, containers, text, time, transformers
Files
- CHANGELOG.md +3/−0
- README.md +1/−1
- Web/Scotty/Comet.hs +49/−29
- kansas-comet.cabal +25/−11
CHANGELOG.md view
@@ -1,3 +1,6 @@+## 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 ())`
README.md view
@@ -1,3 +1,3 @@-# kansas-comet [](http://hackage.haskell.org/package/kansas-comet) [](https://travis-ci.org/ku-fpg/kansas-comet)+# 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@@ -23,7 +27,6 @@ import Control.Concurrent 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@@ -31,6 +34,12 @@ import Data.Time.Clock import Numeric +#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+#else+import qualified Data.HashMap.Strict as HashMap+#endif+ -- | connect "/foobar" (...) gives a scotty session that: -- -- > POST http://.../foobar/ <- bootstrap the interaction@@ -44,9 +53,9 @@ if not rtsSupportsBoundThreads -- we need the -threaded flag turned on then do putStrLn "Application needs to be re-compiled with -threaded flag" exitFailure- else return () - - + else return ()++ when (verbose opt >= 1) $ putStrLn $ "kansas-comet connect with prefix=" ++ show (prefix opt) -- A unique number generator, or ephemeral generator.@@ -88,19 +97,19 @@ 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@@ -111,11 +120,11 @@ 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@@ -123,28 +132,30 @@ 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+ m <- case wrappedVal of+ Object m -> return m+ _ -> fail $ "Expected Object, received: " ++ show wrappedVal+ let val = fromJust $ lookupKM "data" m --liftIO $ print (val :: Value) db <- liftIO $ atomically $ readTVar contextDB case Map.lookup num db of@@ -153,26 +164,28 @@ Just doc -> do liftIO $ do atomically $ do- m <- readTVar (replies doc)- writeTVar (replies doc) $ Map.insert uq val m+ 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"- + when (verbose opt >= 2) $ liftIO $ putStrLn $- "Kansas Comet: post .../event/" ++ show num - + "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+ m <- case wrappedVal of+ Object m -> return m+ _ -> fail $ "Expected Object, received: " ++ show wrappedVal+ let val = fromJust $ lookupKM "data" m --liftIO $ print (val :: Value)- + db <- liftIO $ atomically $ readTVar contextDB case Map.lookup num db of Nothing -> do@@ -181,6 +194,13 @@ liftIO $ atomically $ do writeTChan (eventQueue doc) val text $ LT.pack ""++ where+#if MIN_VERSION_aeson(2,0,0)+ lookupKM = KeyMap.lookup+#else+ lookupKM = HashMap.lookup+#endif -- | 'kCometPlugin' provides the location of the Kansas Comet jQuery plugin. kCometPlugin :: IO String
kansas-comet.cabal view
@@ -1,5 +1,5 @@ Name: kansas-comet-Version: 0.4+Version: 0.4.1 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@@ -13,6 +13,16 @@ Build-type: Simple extra-source-files: CHANGELOG.md, README.md Cabal-version: >= 1.10+tested-with: GHC == 7.6.3+ , GHC == 7.8.4+ , GHC == 7.10.3+ , GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.4+ , GHC == 9.0.1 Description: A transport-level remote JavaScript RESTful push mechanism. @@ -23,16 +33,20 @@ Exposed-modules: Web.Scotty.Comet other-modules: Paths_kansas_comet default-language: Haskell2010- 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+ build-depends:+ -- TODO: Eventually, we should bump the lower version+ -- bounds to >=2 so that we can remove some CPP in+ -- Web.Scotty.Comet.+ aeson >= 0.9 && < 2.1,+ base >= 4.6 && < 4.16,+ containers >= 0.4 && < 0.7,+ data-default-class >= 0.0.1 && < 0.2,+ scotty >= 0.10 && < 0.13,+ stm >= 2.2 && < 2.6,+ text >= 0.11.3.1 && < 1.6,+ time >= 1.2 && < 1.11,+ transformers >= 0.3 && < 0.6,+ unordered-containers >= 0.2.3 && < 0.3 GHC-options: -Wall