{-# 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 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 [Char] -> IO ()
putStrLn [Char]
"Application needs to be re-compiled with -threaded flag"
           forall a. IO a
exitFailure
   else forall (m :: * -> *) a. Monad m => a -> m a
return ()


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

   UTCTime
tm ::  UTCTime  <- IO UTCTime
getCurrentTime

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

   TVar (Map Int Document)
contextDB <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. a -> STM (TVar a)
newTVar forall a b. (a -> b) -> a -> b
$ (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 <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. STM (TMVar a)
newEmptyTMVar
            TVar (Map Int Value)
callbacks <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. a -> STM (TVar a)
newTVar forall a b. (a -> b) -> a -> b
$ forall k a. Map k a
Map.empty
            TChan Value
queue <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ 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
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
                    Map Int Document
db <- forall a. TVar a -> STM a
readTVar TVar (Map Int Document)
contextDB
                    -- assumes the getUniq is actually unique
                    forall a. TVar a -> a -> STM ()
writeTVar TVar (Map Int Document)
contextDB forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ Document -> IO ()
callback Document
cxt
            forall (m :: * -> *) a. Monad m => a -> m a
return Int
uq

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

                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
verbose Options
opt forall a. Ord a => a -> a -> Bool
>= Int
2) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
                    [Char]
"Kansas Comet: get .../act/" forall a. [a] -> [a] -> [a]
++ 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO (TVar Bool)
registerDelay (Int
3 forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000)
                        Maybe Text
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
                                Bool
b <- forall a. TVar a -> STM a
readTVar TVar Bool
ping
                                if Bool
b then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing else do
                                     forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just (forall a. TMVar a -> STM a
takeTMVar TMVar Text
var)


                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Int
verbose Options
opt forall a. Ord a => a -> a -> Bool
>= Int
2) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
                                    [Char]
"Kansas Comet (sending to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
n forall a. [a] -> [a] -> [a]
++ [Char]
"):\n" forall a. [a] -> [a] -> [a]
++ 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 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
readTVar TVar (Map Int Document)
contextDB
                case 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 forall a b. (a -> b) -> a -> b
$ [Char]
"console.warn('Can not find act #" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
num 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 forall a b. (a -> b) -> a -> b
$ Options -> [Char]
prefix Options
opt forall a. [a] -> [a] -> [a]
++ [Char]
"/reply/" forall a. [a] -> [a] -> [a]
++ [Char]
server_id forall a. [a] -> [a] -> [a]
++ [Char]
"/:id/:uq") 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)

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

               Value
wrappedVal :: 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Object
m
                      Value
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Expected Object, received: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Value
wrappedVal
               let val :: Value
val = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall {v}. Key -> KeyMap v -> Maybe v
lookupKM Key
"data" Object
m
               --liftIO $ print (val :: Value)
               Map Int Document
db <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
readTVar TVar (Map Int Document)
contextDB
               case 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 forall a b. (a -> b) -> a -> b
$ [Char]
"console.warn('Ignore reply for session #" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
num forall a. [a] -> [a] -> [a]
++ [Char]
"');")
                   Just Document
doc -> do
                       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                             forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
                               Map Int Value
mv <- forall a. TVar a -> STM a
readTVar (Document -> TVar (Map Int Value)
replies Document
doc)
                               forall a. TVar a -> a -> STM ()
writeTVar (Document -> TVar (Map Int Value)
replies Document
doc) forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ [Char] -> Text
LT.pack [Char]
""


       RoutePattern -> ActionM () -> ScottyM ()
post ([Char] -> RoutePattern
capture forall a b. (a -> b) -> a -> b
$ Options -> [Char]
prefix Options
opt forall a. [a] -> [a] -> [a]
++ [Char]
"/event/" forall a. [a] -> [a] -> [a]
++ [Char]
server_id forall a. [a] -> [a] -> [a]
++ [Char]
"/:id") 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"

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

               Value
wrappedVal :: 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Object
m
                      Value
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Expected Object, received: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Value
wrappedVal
               let val :: Value
val = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall {v}. Key -> KeyMap v -> Maybe v
lookupKM Key
"data" Object
m
               --liftIO $ print (val :: Value)

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

  where
#if MIN_VERSION_aeson(2,0,0)
    lookupKM :: Key -> KeyMap v -> Maybe v
lookupKM = forall {v}. Key -> KeyMap v -> Maybe v
KeyMap.lookup
#else
    lookupKM = HashMap.lookup
#endif

#if MIN_VERSION_scotty(0,20,0)
    captureParam :: Text -> ActionT IO Int
captureParam = 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 = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar (Document -> TMVar Text
sending Document
doc) 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
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
           Map Int Value
db <- forall a. TVar a -> STM a
readTVar (Document -> TVar (Map Int Value)
replies Document
doc)
           case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
num Map Int Value
db of
              Maybe Value
Nothing -> forall a. STM a
retry
              Just Value
r -> do
                      forall a. TVar a -> a -> STM ()
writeTVar (Document -> TVar (Map Int Value)
replies Document
doc) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Int
num Map Int Value
db
                      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
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 -> [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
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
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
Ord, Int -> Options -> ShowS
[Options] -> ShowS
Options -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> [Char]
$cshow :: Options -> [Char]
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
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 = 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 <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. STM (TMVar a)
newEmptyTMVar
  TVar (Map Int Value)
callbacks <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. a -> STM (TVar a)
newTVar forall a b. (a -> b) -> a -> b
$ forall k a. Map k a
Map.empty
  ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
          Text
res <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar forall a b. (a -> b) -> a -> b
$ TMVar Text
picture
          [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Sending: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
res
  TChan Value
q <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. STM (TChan a)
newTChan
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
   Map Int Value
m <- forall a. TVar a -> STM a
readTVar (Document -> TVar (Map Int Value)
replies Document
doc)
   forall a. TVar a -> a -> STM ()
writeTVar (Document -> TVar (Map Int Value)
replies Document
doc) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
uq Value
val Map Int Value
m