{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Web.Scotty.Comet
    ( connect
    , kCometPlugin
    , send
    , Document
    , Options(..)
    , getReply
    , eventQueue
    , debugDocument
    , debugReplyDocument
    , defaultOptions
    ) where

import Web.Scotty (ScottyM, text, post, capture, param, setHeader, get, ActionM, jsonData)
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 (getDataFileName)
import qualified Data.Map as Map
import Control.Concurrent
import Data.Default.Class
import Data.Maybe ( fromJust )
import System.Exit
import qualified Data.Text.Lazy as LT
import qualified Data.Text      as T
import Data.Time.Calendar
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
-- >  GET  http://.../foobar/act/<id#>/<act#>       <- get a specific action
-- >  POST http://.../foobar/reply/<id#>/<reply#>   <- send a reply as a JSON object

connect :: Options             -- ^ URL path prefix for this page
        -> (Document -> IO ()) -- ^ called for access of the page
        -> IO (ScottyM ())
connect :: Options -> (Document -> IO ()) -> IO (ScottyM ())
connect Options
opt Document -> IO ()
callback = do
   if Bool -> Bool
not Bool
rtsSupportsBoundThreads  -- we need the -threaded flag turned on
   then do String -> IO ()
putStrLn String
"Application needs to be re-compiled with -threaded flag"
           IO ()
forall a. IO a
exitFailure
   else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
verbose Options
opt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"kansas-comet connect with prefix=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Options -> String
prefix Options
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)
   MVar Int
uniqVar <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar Int
0
   let getUniq :: IO Int
       getUniq :: IO Int
getUniq = do
              Int
u <- MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
uniqVar
              MVar Int -> Int -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Int
uniqVar (Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
              Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
u

   UTCTime
tm ::  UTCTime  <- IO UTCTime
getCurrentTime

   let server_id :: String
server_id
           = Integer -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
Numeric.showHex (Day -> Integer
toModifiedJulianDay (UTCTime -> Day
utctDay UTCTime
tm))
           (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++)
           (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Integer -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
Numeric.showHex (DiffTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (UTCTime -> DiffTime
utctDayTime UTCTime
tm DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
1000) :: Integer)
           (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
""

   TVar (Map Int Document)
contextDB <- STM (TVar (Map Int Document)) -> IO (TVar (Map Int Document))
forall a. STM a -> IO a
atomically (STM (TVar (Map Int Document)) -> IO (TVar (Map Int Document)))
-> STM (TVar (Map Int Document)) -> IO (TVar (Map Int Document))
forall a b. (a -> b) -> a -> b
$ Map Int Document -> STM (TVar (Map Int Document))
forall a. a -> STM (TVar a)
newTVar (Map Int Document -> STM (TVar (Map Int Document)))
-> Map Int Document -> STM (TVar (Map Int Document))
forall a b. (a -> b) -> a -> b
$ (Map Int Document
forall k a. Map k a
Map.empty :: Map.Map Int Document)
   let newContext :: IO Int
       newContext :: IO Int
newContext = do
            Int
uq <- IO Int
getUniq
            TMVar Text
picture <- STM (TMVar Text) -> IO (TMVar Text)
forall a. STM a -> IO a
atomically (STM (TMVar Text) -> IO (TMVar Text))
-> STM (TMVar Text) -> IO (TMVar Text)
forall a b. (a -> b) -> a -> b
$ STM (TMVar Text)
forall a. STM (TMVar a)
newEmptyTMVar
            TVar (Map Int Value)
callbacks <- STM (TVar (Map Int Value)) -> IO (TVar (Map Int Value))
forall a. STM a -> IO a
atomically (STM (TVar (Map Int Value)) -> IO (TVar (Map Int Value)))
-> STM (TVar (Map Int Value)) -> IO (TVar (Map Int Value))
forall a b. (a -> b) -> a -> b
$ Map Int Value -> STM (TVar (Map Int Value))
forall a. a -> STM (TVar a)
newTVar (Map Int Value -> STM (TVar (Map Int Value)))
-> Map Int Value -> STM (TVar (Map Int Value))
forall a b. (a -> b) -> a -> b
$ Map Int Value
forall k a. Map k a
Map.empty
            TChan Value
queue <- STM (TChan Value) -> IO (TChan Value)
forall a. STM a -> IO a
atomically (STM (TChan Value) -> IO (TChan Value))
-> STM (TChan Value) -> IO (TChan Value)
forall a b. (a -> b) -> a -> b
$ STM (TChan Value)
forall a. STM (TChan a)
newTChan
            let cxt :: Document
cxt = TMVar Text
-> TVar (Map Int Value) -> TChan Value -> Int -> Document
Document TMVar Text
picture TVar (Map Int Value)
callbacks TChan Value
queue Int
uq
            IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Map Int Document
db <- TVar (Map Int Document) -> STM (Map Int Document)
forall a. TVar a -> STM a
readTVar TVar (Map Int Document)
contextDB
                    -- assumes the getUniq is actually unique
                    TVar (Map Int Document) -> Map Int Document -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Map Int Document)
contextDB (Map Int Document -> STM ()) -> Map Int Document -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> Document -> Map Int Document -> Map Int Document
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
uq Document
cxt Map Int Document
db
            -- Here is where we actually spawn the user code
            ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Document -> IO ()
callback Document
cxt
            Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
uq

   -- POST starts things off.
   ScottyM () -> IO (ScottyM ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ScottyM () -> IO (ScottyM ())) -> ScottyM () -> IO (ScottyM ())
forall a b. (a -> b) -> a -> b
$ do
       RoutePattern -> ActionM () -> ScottyM ()
post (String -> RoutePattern
capture (String -> RoutePattern) -> String -> RoutePattern
forall a b. (a -> b) -> a -> b
$ Options -> String
prefix Options
opt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/") (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
                Int
uq  <- IO Int -> ActionT Text IO Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> ActionT Text IO Int) -> IO Int -> ActionT Text IO Int
forall a b. (a -> b) -> a -> b
$ IO Int
newContext
                Text -> ActionM ()
text (String -> Text
LT.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"$.kc.session(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
server_id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
uq String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
");")

       -- GET the updates to the documents (should this be an (empty) POST?)

    --   liftIO $ print $ prefix opt ++ "/act/:id/:act"
       RoutePattern -> ActionM () -> ScottyM ()
get (String -> RoutePattern
capture (String -> RoutePattern) -> String -> RoutePattern
forall a b. (a -> b) -> a -> b
$ Options -> String
prefix Options
opt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/act/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
server_id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/:id/:act") (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
                Text -> Text -> ActionM ()
setHeader Text
"Cache-Control" Text
"max-age=0, no-cache, private, no-store, must-revalidate"
                -- do something and return a new list of commands to the client
                Int
num <- Text -> ActionT Text IO Int
forall a. Parsable a => Text -> ActionM a
param Text
"id"

                Bool -> ActionM () -> ActionM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
verbose Options
opt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (ActionM () -> ActionM ()) -> ActionM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ IO () -> ActionM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String
"Kansas Comet: get .../act/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
num
    --            liftIO $ print (num :: Int)

                let tryPushAction :: TMVar T.Text -> Int -> ActionM ()
                    tryPushAction :: TMVar Text -> Int -> ActionM ()
tryPushAction TMVar Text
var Int
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)
                        TVar Bool
ping <- IO (TVar Bool) -> ActionT Text IO (TVar Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Bool) -> ActionT Text IO (TVar Bool))
-> IO (TVar Bool) -> ActionT Text IO (TVar Bool)
forall a b. (a -> b) -> a -> b
$ Int -> IO (TVar Bool)
registerDelay (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000)
                        Maybe Text
res <- IO (Maybe Text) -> ActionT Text IO (Maybe Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text) -> ActionT Text IO (Maybe Text))
-> IO (Maybe Text) -> ActionT Text IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ STM (Maybe Text) -> IO (Maybe Text)
forall a. STM a -> IO a
atomically (STM (Maybe Text) -> IO (Maybe Text))
-> STM (Maybe Text) -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
                                Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
ping
                                if Bool
b then Maybe Text -> STM (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing else do
                                     (Text -> Maybe Text) -> STM Text -> STM (Maybe Text)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Text -> Maybe Text
forall a. a -> Maybe a
Just (TMVar Text -> STM Text
forall a. TMVar a -> STM a
takeTMVar TMVar Text
var)


                        Bool -> ActionM () -> ActionM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
verbose Options
opt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (ActionM () -> ActionM ()) -> ActionM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ IO () -> ActionM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                                    String
"Kansas Comet (sending to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"):\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Text -> String
forall a. Show a => a -> String
show Maybe Text
res

                        case Maybe Text
res of
                         Just Text
js -> do
    --                            liftIO $ putStrLn $ show js
                                Text -> ActionM ()
text (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
LT.fromChunks [Text
js]
                         Maybe Text
Nothing  ->
                                -- give the browser something to do (approx every 3 seconds)
                                Text -> ActionM ()
text Text
LT.empty

                Map Int Document
db <- IO (Map Int Document) -> ActionT Text IO (Map Int Document)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Int Document) -> ActionT Text IO (Map Int Document))
-> IO (Map Int Document) -> ActionT Text IO (Map Int Document)
forall a b. (a -> b) -> a -> b
$ STM (Map Int Document) -> IO (Map Int Document)
forall a. STM a -> IO a
atomically (STM (Map Int Document) -> IO (Map Int Document))
-> STM (Map Int Document) -> IO (Map Int Document)
forall a b. (a -> b) -> a -> b
$ TVar (Map Int Document) -> STM (Map Int Document)
forall a. TVar a -> STM a
readTVar TVar (Map Int Document)
contextDB
                case Int -> Map Int Document -> Maybe Document
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
num Map Int Document
db of
                   Maybe Document
Nothing  -> Text -> ActionM ()
text (String -> Text
LT.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"console.warn('Can not find act #" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
num String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"');")
                   Just Document
doc -> TMVar Text -> Int -> ActionM ()
tryPushAction (Document -> TMVar Text
sending Document
doc) Int
num


       RoutePattern -> ActionM () -> ScottyM ()
post (String -> RoutePattern
capture (String -> RoutePattern) -> String -> RoutePattern
forall a b. (a -> b) -> a -> b
$ Options -> String
prefix Options
opt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/reply/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
server_id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/:id/:uq") (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
               Text -> Text -> ActionM ()
setHeader Text
"Cache-Control" Text
"max-age=0, no-cache, private, no-store, must-revalidate"
               Int
num <- Text -> ActionT Text IO Int
forall a. Parsable a => Text -> ActionM a
param Text
"id"
               Int
uq :: Int <- Text -> ActionT Text IO Int
forall a. Parsable a => Text -> ActionM a
param Text
"uq"
               --liftIO $ print (num :: Int, event :: String)

               Bool -> ActionM () -> ActionM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
verbose Options
opt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (ActionM () -> ActionM ()) -> ActionM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ IO () -> ActionM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String
"Kansas Comet: post .../reply/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
num String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
uq

               Value
wrappedVal :: Value <- ActionM Value
forall a. FromJSON a => ActionM a
jsonData
               -- Unwrap the data wrapped, because 'jsonData' only supports
               -- objects or arrays, but not primitive values like numbers
               -- or booleans.
               Object
m <- case Value
wrappedVal of
                      Object Object
m -> Object -> ActionT Text IO Object
forall (m :: * -> *) a. Monad m => a -> m a
return Object
m
                      Value
_ -> String -> ActionT Text IO Object
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionT Text IO Object)
-> String -> ActionT Text IO Object
forall a b. (a -> b) -> a -> b
$ String
"Expected Object, received: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
wrappedVal
               let val :: Value
val = Maybe Value -> Value
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Maybe Value
forall v. Text -> HashMap Text v -> Maybe v
lookupKM Text
"data" Object
m
               --liftIO $ print (val :: Value)
               Map Int Document
db <- IO (Map Int Document) -> ActionT Text IO (Map Int Document)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Int Document) -> ActionT Text IO (Map Int Document))
-> IO (Map Int Document) -> ActionT Text IO (Map Int Document)
forall a b. (a -> b) -> a -> b
$ STM (Map Int Document) -> IO (Map Int Document)
forall a. STM a -> IO a
atomically (STM (Map Int Document) -> IO (Map Int Document))
-> STM (Map Int Document) -> IO (Map Int Document)
forall a b. (a -> b) -> a -> b
$ TVar (Map Int Document) -> STM (Map Int Document)
forall a. TVar a -> STM a
readTVar TVar (Map Int Document)
contextDB
               case Int -> Map Int Document -> Maybe Document
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
num Map Int Document
db of
                   Maybe Document
Nothing  -> do
                       Text -> ActionM ()
text (String -> Text
LT.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"console.warn('Ignore reply for session #" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
num String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"');")
                   Just Document
doc -> do
                       IO () -> ActionM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ do
                             STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                               Map Int Value
mv <- TVar (Map Int Value) -> STM (Map Int Value)
forall a. TVar a -> STM a
readTVar (Document -> TVar (Map Int Value)
replies Document
doc)
                               TVar (Map Int Value) -> Map Int Value -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Document -> TVar (Map Int Value)
replies Document
doc) (Map Int Value -> STM ()) -> Map Int Value -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> Value -> Map Int Value -> Map Int Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
uq Value
val Map Int Value
mv
                       Text -> ActionM ()
text (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> Text
LT.pack String
""


       RoutePattern -> ActionM () -> ScottyM ()
post (String -> RoutePattern
capture (String -> RoutePattern) -> String -> RoutePattern
forall a b. (a -> b) -> a -> b
$ Options -> String
prefix Options
opt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/event/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
server_id String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/:id") (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
forall a b. (a -> b) -> a -> b
$ do
               Text -> Text -> ActionM ()
setHeader Text
"Cache-Control" Text
"max-age=0, no-cache, private, no-store, must-revalidate"
               Int
num <- Text -> ActionT Text IO Int
forall a. Parsable a => Text -> ActionM a
param Text
"id"

               Bool -> ActionM () -> ActionM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
verbose Options
opt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (ActionM () -> ActionM ()) -> ActionM () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ IO () -> ActionM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String
"Kansas Comet: post .../event/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
num

               Value
wrappedVal :: Value <- ActionM Value
forall a. FromJSON a => ActionM a
jsonData
               -- Unwrap the data wrapped, because 'jsonData' only supports
               -- objects or arrays, but not primitive values like numbers
               -- or booleans.
               Object
m <- case Value
wrappedVal of
                      Object Object
m -> Object -> ActionT Text IO Object
forall (m :: * -> *) a. Monad m => a -> m a
return Object
m
                      Value
_ -> String -> ActionT Text IO Object
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ActionT Text IO Object)
-> String -> ActionT Text IO Object
forall a b. (a -> b) -> a -> b
$ String
"Expected Object, received: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
wrappedVal
               let val :: Value
val = Maybe Value -> Value
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Maybe Value
forall v. Text -> HashMap Text v -> Maybe v
lookupKM Text
"data" Object
m
               --liftIO $ print (val :: Value)

               Map Int Document
db <- IO (Map Int Document) -> ActionT Text IO (Map Int Document)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Int Document) -> ActionT Text IO (Map Int Document))
-> IO (Map Int Document) -> ActionT Text IO (Map Int Document)
forall a b. (a -> b) -> a -> b
$ STM (Map Int Document) -> IO (Map Int Document)
forall a. STM a -> IO a
atomically (STM (Map Int Document) -> IO (Map Int Document))
-> STM (Map Int Document) -> IO (Map Int Document)
forall a b. (a -> b) -> a -> b
$ TVar (Map Int Document) -> STM (Map Int Document)
forall a. TVar a -> STM a
readTVar TVar (Map Int Document)
contextDB
               case Int -> Map Int Document -> Maybe Document
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
num Map Int Document
db of
                   Maybe Document
Nothing  -> do
                       Text -> ActionM ()
text (String -> Text
LT.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"console.warn('Ignore reply for session #" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
num String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"');")
                   Just Document
doc -> do
                       IO () -> ActionM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                               TChan Value -> Value -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (Document -> TChan Value
eventQueue Document
doc) Value
val
                       Text -> ActionM ()
text (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ String -> Text
LT.pack String
""

  where
#if MIN_VERSION_aeson(2,0,0)
    lookupKM = KeyMap.lookup
#else
    lookupKM :: Text -> HashMap Text v -> Maybe v
lookupKM = Text -> HashMap Text v -> Maybe v
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup
#endif

-- | 'kCometPlugin' provides the location of the Kansas Comet jQuery plugin.
kCometPlugin :: IO String
kCometPlugin :: IO String
kCometPlugin = String -> IO String
getDataFileName String
"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,
-- or some costly evaluation needs done first).
-- 'send' suspends the thread if the last javascript has not been *dispatched*
-- the the browser.
send :: Document -> T.Text -> IO ()
send :: Document -> Text -> IO ()
send Document
doc Text
js = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Text -> Text -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (Document -> TMVar Text
sending Document
doc) (Text -> STM ()) -> Text -> STM ()
forall a b. (a -> b) -> a -> b
$! Text
js

-- | wait for a virtual-to-this-document's port numbers' reply.
getReply :: Document -> Int -> IO Value
getReply :: Document -> Int -> IO Value
getReply Document
doc Int
num = do
        STM Value -> IO Value
forall a. STM a -> IO a
atomically (STM Value -> IO Value) -> STM Value -> IO Value
forall a b. (a -> b) -> a -> b
$ do
           Map Int Value
db <- TVar (Map Int Value) -> STM (Map Int Value)
forall a. TVar a -> STM a
readTVar (Document -> TVar (Map Int Value)
replies Document
doc)
           case Int -> Map Int Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
num Map Int Value
db of
              Maybe Value
Nothing -> STM Value
forall a. STM a
retry
              Just Value
r -> do
                      TVar (Map Int Value) -> Map Int Value -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Document -> TVar (Map Int Value)
replies Document
doc) (Map Int Value -> STM ()) -> Map Int Value -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> Map Int Value -> Map Int Value
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int
num Map Int Value
db
                      Value -> STM Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
r

-- | 'Document' is the Handle into a specific interaction with a web page.
data Document = Document
        { Document -> TMVar Text
sending    :: TMVar T.Text             -- ^ Code to be sent to the browser
                                                 -- This is a TMVar to stop the generation
                                                 -- getting ahead of the rendering engine
        , Document -> TVar (Map Int Value)
replies    :: TVar (Map.Map Int Value) -- ^ This is numbered replies, to ports
        , Document -> TChan Value
eventQueue :: TChan Value              -- ^ Events being sent
        , Document -> Int
_secret    :: Int                      -- ^ the (session) number of this document
        } deriving Document -> Document -> Bool
(Document -> Document -> Bool)
-> (Document -> Document -> Bool) -> Eq Document
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Document -> Document -> Bool
$c/= :: Document -> Document -> Bool
== :: Document -> Document -> Bool
$c== :: Document -> Document -> Bool
Eq

-- 'Options' for Comet.
data Options = Options
        { Options -> String
prefix  :: String             -- ^ what is the prefix at at start of the URL (for example \"ajax\")
        , Options -> Int
verbose :: Int                -- ^ 0 == none (default), 1 == inits, 2 == cmds done, 3 == complete log
        } deriving (Options -> Options -> Bool
(Options -> Options -> Bool)
-> (Options -> Options -> Bool) -> Eq Options
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options -> Options -> Bool
$c/= :: Options -> Options -> Bool
== :: Options -> Options -> Bool
$c== :: Options -> Options -> Bool
Eq, Eq Options
Eq Options
-> (Options -> Options -> Ordering)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Bool)
-> (Options -> Options -> Options)
-> (Options -> Options -> Options)
-> Ord Options
Options -> Options -> Bool
Options -> Options -> Ordering
Options -> Options -> Options
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Options -> Options -> Options
$cmin :: Options -> Options -> Options
max :: Options -> Options -> Options
$cmax :: Options -> Options -> Options
>= :: Options -> Options -> Bool
$c>= :: Options -> Options -> Bool
> :: Options -> Options -> Bool
$c> :: Options -> Options -> Bool
<= :: Options -> Options -> Bool
$c<= :: Options -> Options -> Bool
< :: Options -> Options -> Bool
$c< :: Options -> Options -> Bool
compare :: Options -> Options -> Ordering
$ccompare :: Options -> Options -> Ordering
$cp1Ord :: Eq Options
Ord, Int -> Options -> String -> String
[Options] -> String -> String
Options -> String
(Int -> Options -> String -> String)
-> (Options -> String)
-> ([Options] -> String -> String)
-> Show Options
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Options] -> String -> String
$cshowList :: [Options] -> String -> String
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> String -> String
$cshowsPrec :: Int -> Options -> String -> String
Show)

instance Default Options where
  def :: Options
def = Options :: String -> Int -> Options
Options
        { prefix :: String
prefix = String
""                   -- default to root, this assumes single page, etc.
        , verbose :: Int
verbose = Int
0
        }


-- Defaults for 'Options'. Or you can use the defaults package.
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options
forall a. Default a => a
def

------------------------------------------------------------------------------------

-- | Generate a @Document@ that prints what it would send to the server.
debugDocument :: IO Document
debugDocument :: IO Document
debugDocument = do
  TMVar Text
picture <- STM (TMVar Text) -> IO (TMVar Text)
forall a. STM a -> IO a
atomically (STM (TMVar Text) -> IO (TMVar Text))
-> STM (TMVar Text) -> IO (TMVar Text)
forall a b. (a -> b) -> a -> b
$ STM (TMVar Text)
forall a. STM (TMVar a)
newEmptyTMVar
  TVar (Map Int Value)
callbacks <- STM (TVar (Map Int Value)) -> IO (TVar (Map Int Value))
forall a. STM a -> IO a
atomically (STM (TVar (Map Int Value)) -> IO (TVar (Map Int Value)))
-> STM (TVar (Map Int Value)) -> IO (TVar (Map Int Value))
forall a b. (a -> b) -> a -> b
$ Map Int Value -> STM (TVar (Map Int Value))
forall a. a -> STM (TVar a)
newTVar (Map Int Value -> STM (TVar (Map Int Value)))
-> Map Int Value -> STM (TVar (Map Int Value))
forall a b. (a -> b) -> a -> b
$ Map Int Value
forall k a. Map k a
Map.empty
  ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Text
res <- STM Text -> IO Text
forall a. STM a -> IO a
atomically (STM Text -> IO Text) -> STM Text -> IO Text
forall a b. (a -> b) -> a -> b
$ TMVar Text -> STM Text
forall a. TMVar a -> STM a
takeTMVar (TMVar Text -> STM Text) -> TMVar Text -> STM Text
forall a b. (a -> b) -> a -> b
$ TMVar Text
picture
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Sending: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
res
  TChan Value
q <- STM (TChan Value) -> IO (TChan Value)
forall a. STM a -> IO a
atomically (STM (TChan Value) -> IO (TChan Value))
-> STM (TChan Value) -> IO (TChan Value)
forall a b. (a -> b) -> a -> b
$ STM (TChan Value)
forall a. STM (TChan a)
newTChan
  Document -> IO Document
forall (m :: * -> *) a. Monad m => a -> m a
return (Document -> IO Document) -> Document -> IO Document
forall a b. (a -> b) -> a -> b
$ TMVar Text
-> TVar (Map Int Value) -> TChan Value -> Int -> Document
Document TMVar Text
picture TVar (Map Int Value)
callbacks TChan Value
q Int
0

-- | Fake a specific reply on a virtual @Document@ port.
debugReplyDocument :: Document -> Int -> Value -> IO ()
debugReplyDocument :: Document -> Int -> Value -> IO ()
debugReplyDocument Document
doc Int
uq Value
val = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
   Map Int Value
m <- TVar (Map Int Value) -> STM (Map Int Value)
forall a. TVar a -> STM a
readTVar (Document -> TVar (Map Int Value)
replies Document
doc)
   TVar (Map Int Value) -> Map Int Value -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Document -> TVar (Map Int Value)
replies Document
doc) (Map Int Value -> STM ()) -> Map Int Value -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> Value -> Map Int Value -> Map Int Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
uq Value
val Map Int Value
m