diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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` 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://img.shields.io/travis/ku-fpg/kansas-comet.svg?style=flat)](https://travis-ci.org/ku-fpg/kansas-comet) + +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 @@ -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 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.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