diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ())` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +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://img.shields.io/travis/ku-fpg/kansas-comet.svg?style=flat)](https://travis-ci.org/ku-fpg/kansas-comet) +# 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 @@ -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 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.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