{-# 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 :: Options
-> (Document -> IO ())
-> IO (ScottyM ())
connect :: Options -> (Document -> IO ()) -> IO (ScottyM ())
connect Options
opt Document -> IO ()
callback = do
if Bool -> Bool
not Bool
rtsSupportsBoundThreads
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)
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
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
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
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
");")
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"
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
let tryPushAction :: TMVar T.Text -> Int -> ActionM ()
tryPushAction :: TMVar Text -> Int -> ActionM ()
tryPushAction TMVar Text
var Int
n = do
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
Text -> ActionM ()
text (Text -> ActionM ()) -> Text -> ActionM ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
LT.fromChunks [Text
js]
Maybe Text
Nothing ->
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"
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
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
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
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
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 :: IO String
kCometPlugin :: IO String
kCometPlugin = String -> IO String
getDataFileName String
"static/js/kansas-comet.js"
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
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
data Document = Document
{ Document -> TMVar Text
sending :: TMVar T.Text
, Document -> TVar (Map Int Value)
replies :: TVar (Map.Map Int Value)
, Document -> TChan Value
eventQueue :: TChan Value
, Document -> Int
_secret :: Int
} 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
data Options = Options
{ Options -> String
prefix :: String
, Options -> Int
verbose :: Int
} 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
""
, verbose :: Int
verbose = Int
0
}
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options
forall a. Default a => a
def
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
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