{-# 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 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 (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

-- | 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 [Char] -> IO ()
putStrLn [Char]
"Application needs to be re-compiled with -threaded flag"
           IO ()
forall a. IO a
exitFailure
   else () -> IO ()
forall a. a -> IO a
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
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"kansas-comet connect with prefix=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show (Options -> [Char]
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
u

   UTCTime
tm ::  UTCTime  <- IO UTCTime
getCurrentTime

   let server_id :: [Char]
server_id
           = Integer -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
Numeric.showHex (Day -> Integer
toModifiedJulianDay (UTCTime -> Day
utctDay UTCTime
tm))
           ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ ([Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
           ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Integer -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
Numeric.showHex (DiffTime -> Integer
forall b. Integral b => DiffTime -> b
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)
           ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
""

   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 a. IO a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
uq

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

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

    --   liftIO $ print $ prefix opt ++ "/act/:id/:act"
       RoutePattern -> ActionM () -> ScottyM ()
get ([Char] -> RoutePattern
capture ([Char] -> RoutePattern) -> [Char] -> RoutePattern
forall a b. (a -> b) -> a -> b
$ Options -> [Char]
prefix Options
opt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/act/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
server_id [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/: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 IO Int
captureParam 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 a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char]
"Kansas Comet: get .../act/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
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 IO (TVar Bool)
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Bool) -> ActionT IO (TVar Bool))
-> IO (TVar Bool) -> ActionT 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 IO (Maybe Text)
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text) -> ActionT IO (Maybe Text))
-> IO (Maybe Text) -> ActionT 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 a. a -> STM a
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 a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                                    [Char]
"Kansas Comet (sending to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"):\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe Text -> [Char]
forall a. Show a => a -> [Char]
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 IO (Map Int Document)
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Int Document) -> ActionT IO (Map Int Document))
-> IO (Map Int Document) -> ActionT 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 ([Char] -> Text
LT.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"console.warn('Can not find act #" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
num [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"');")
                   Just Document
doc -> TMVar Text -> Int -> ActionM ()
tryPushAction (Document -> TMVar Text
sending Document
doc) Int
num


       RoutePattern -> ActionM () -> ScottyM ()
post ([Char] -> RoutePattern
capture ([Char] -> RoutePattern) -> [Char] -> RoutePattern
forall a b. (a -> b) -> a -> b
$ Options -> [Char]
prefix Options
opt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/reply/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
server_id [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/: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 IO Int
captureParam Text
"id"
               Int
uq :: Int <- Text -> ActionT IO Int
captureParam 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 a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char]
"Kansas Comet: post .../reply/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
num [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
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 IO Object
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Object
m
                      Value
_ -> [Char] -> ActionT IO Object
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionT IO Object) -> [Char] -> ActionT IO Object
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected Object, received: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Value -> [Char]
forall a. Show a => a -> [Char]
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
$ Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"data" Object
m
               --liftIO $ print (val :: Value)
               Map Int Document
db <- IO (Map Int Document) -> ActionT IO (Map Int Document)
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Int Document) -> ActionT IO (Map Int Document))
-> IO (Map Int Document) -> ActionT 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 ([Char] -> Text
LT.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"console.warn('Ignore reply for session #" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
num [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"');")
                   Just Document
doc -> do
                       IO () -> ActionM ()
forall a. IO a -> ActionT IO a
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
$ [Char] -> Text
LT.pack [Char]
""


       RoutePattern -> ActionM () -> ScottyM ()
post ([Char] -> RoutePattern
capture ([Char] -> RoutePattern) -> [Char] -> RoutePattern
forall a b. (a -> b) -> a -> b
$ Options -> [Char]
prefix Options
opt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/event/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
server_id [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/: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 IO Int
captureParam 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 a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ActionM ()) -> IO () -> ActionM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char]
"Kansas Comet: post .../event/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
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 IO Object
forall a. a -> ActionT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Object
m
                      Value
_ -> [Char] -> ActionT IO Object
forall a. [Char] -> ActionT IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ActionT IO Object) -> [Char] -> ActionT IO Object
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected Object, received: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Value -> [Char]
forall a. Show a => a -> [Char]
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
$ Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"data" Object
m
               --liftIO $ print (val :: Value)

               Map Int Document
db <- IO (Map Int Document) -> ActionT IO (Map Int Document)
forall a. IO a -> ActionT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Int Document) -> ActionT IO (Map Int Document))
-> IO (Map Int Document) -> ActionT 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 ([Char] -> Text
LT.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"console.warn('Ignore reply for session #" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
num [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"');")
                   Just Document
doc -> do
                       IO () -> ActionM ()
forall a. IO a -> ActionT IO a
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
$ [Char] -> Text
LT.pack [Char]
""

  where
#if MIN_VERSION_scotty(0,20,0)
    captureParam :: Text -> ActionT IO Int
captureParam = Text -> ActionT IO Int
forall a. Parsable a => Text -> ActionM a
Scotty.captureParam
#else
    captureParam = Scotty.param
#endif

-- | 'kCometPlugin' provides the location of the Kansas Comet jQuery plugin.
kCometPlugin :: IO String
kCometPlugin :: IO [Char]
kCometPlugin = [Char] -> IO [Char]
getDataFileName [Char]
"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 a. a -> STM a
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
$c== :: Document -> Document -> Bool
== :: Document -> Document -> Bool
$c/= :: Document -> Document -> Bool
/= :: Document -> Document -> Bool
Eq

-- 'Options' for Comet.
data Options = Options
        { Options -> [Char]
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
$c== :: Options -> Options -> Bool
== :: Options -> Options -> Bool
$c/= :: Options -> Options -> Bool
/= :: 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
$ccompare :: Options -> Options -> Ordering
compare :: Options -> Options -> Ordering
$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
>= :: Options -> Options -> Bool
$cmax :: Options -> Options -> Options
max :: Options -> Options -> Options
$cmin :: Options -> Options -> Options
min :: Options -> Options -> Options
Ord, Int -> Options -> [Char] -> [Char]
[Options] -> [Char] -> [Char]
Options -> [Char]
(Int -> Options -> [Char] -> [Char])
-> (Options -> [Char])
-> ([Options] -> [Char] -> [Char])
-> Show Options
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Options -> [Char] -> [Char]
showsPrec :: Int -> Options -> [Char] -> [Char]
$cshow :: Options -> [Char]
show :: Options -> [Char]
$cshowList :: [Options] -> [Char] -> [Char]
showList :: [Options] -> [Char] -> [Char]
Show)

instance Default Options where
  def :: Options
def = Options
        { prefix :: [Char]
prefix = [Char]
""                   -- 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
          [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Sending: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
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 a. a -> IO a
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