[server] Remove old tree modules
This commit is contained in:
parent
f6a281fee1
commit
a2d392bc4d
8 changed files with 0 additions and 458 deletions
|
|
@ -26,15 +26,8 @@ source-repository head
|
||||||
|
|
||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Forest.Server
|
|
||||||
Forest.Server.Broadcast
|
|
||||||
Forest.Server.Schema
|
Forest.Server.Schema
|
||||||
Forest.Server.TreeApp
|
Forest.Server.TreeApp
|
||||||
Forest.Server.TreeModule
|
|
||||||
Forest.Server.TreeModule.Animate
|
|
||||||
Forest.Server.TreeModule.Const
|
|
||||||
Forest.Server.TreeModule.Fork
|
|
||||||
Forest.Server.TreeModule.SharedEditing
|
|
||||||
other-modules:
|
other-modules:
|
||||||
Paths_forest_server
|
Paths_forest_server
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
|
|
|
||||||
|
|
@ -1,71 +0,0 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Forest.Server
|
|
||||||
( withThread
|
|
||||||
, serverApp
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent.Chan
|
|
||||||
import Control.Exception
|
|
||||||
import qualified Network.WebSockets as WS
|
|
||||||
|
|
||||||
import Forest.Api
|
|
||||||
import Forest.Node
|
|
||||||
import Forest.Server.TreeModule
|
|
||||||
import Forest.Util
|
|
||||||
|
|
||||||
{- Thread that sends updates to the client -}
|
|
||||||
|
|
||||||
sendUpdatesThread :: WS.Connection -> Chan Node -> Node -> IO ()
|
|
||||||
sendUpdatesThread conn nodeChan nodeA = do
|
|
||||||
nodeB <- readChan nodeChan
|
|
||||||
case diffNodes nodeA nodeB of
|
|
||||||
Nothing -> do
|
|
||||||
putStrLn "Sending no update because the node didn't change"
|
|
||||||
sendUpdatesThread conn nodeChan nodeA
|
|
||||||
Just (path, nextNode) -> do
|
|
||||||
putStrLn $ "Sending partial update for path " ++ show path ++ ": " ++ show nextNode
|
|
||||||
sendPacket conn $ ServerUpdate path nextNode
|
|
||||||
sendUpdatesThread conn nodeChan nodeB
|
|
||||||
|
|
||||||
{- Main server application that receives and processes client packets -}
|
|
||||||
|
|
||||||
receivePackets :: TreeModule a () => WS.Connection -> a () -> IO ()
|
|
||||||
receivePackets conn treeModule = whileNothingM $ do
|
|
||||||
packet <- receivePacket conn
|
|
||||||
case packet of
|
|
||||||
ClientEdit path text -> do
|
|
||||||
putStrLn $ "Editing " ++ show path ++ " to " ++ show text
|
|
||||||
edit treeModule path text
|
|
||||||
ClientDelete path -> do
|
|
||||||
putStrLn $ "Deleting " ++ show path
|
|
||||||
delete treeModule path
|
|
||||||
ClientReply path text -> do
|
|
||||||
putStrLn $ "Replying to " ++ show path ++ " with " ++ show text
|
|
||||||
reply treeModule path text
|
|
||||||
ClientAct path -> do
|
|
||||||
putStrLn $ "Acting upon " ++ show path
|
|
||||||
act treeModule path
|
|
||||||
ClientHello _ -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once"
|
|
||||||
|
|
||||||
printException :: SomeException -> IO ()
|
|
||||||
printException e = putStrLn $ "Encountered exception: " ++ show e
|
|
||||||
|
|
||||||
serverApp :: TreeModule a () => Int -> ModuleConstructor (a ()) -> WS.ServerApp
|
|
||||||
serverApp pingDelay constructor pendingConnection = do
|
|
||||||
conn <- WS.acceptRequest pendingConnection
|
|
||||||
chan <- newChan
|
|
||||||
WS.withPingThread conn pingDelay (pure ()) $ handle printException $ do
|
|
||||||
firstPacket <- receivePacket conn
|
|
||||||
case firstPacket of
|
|
||||||
ClientHello _ -> do
|
|
||||||
putStrLn $ "Sending hello reply with " ++ show initialNode
|
|
||||||
sendPacket conn $ ServerHello [] initialNode
|
|
||||||
withThread (sendUpdatesThread conn chan initialNode) $
|
|
||||||
constructor (writeChan chan) $ \tm -> do
|
|
||||||
receivePackets conn tm
|
|
||||||
putStrLn "Module finished, closing connection"
|
|
||||||
_ -> closeWithErrorMessage conn "Invalid packet: Expected a hello packet"
|
|
||||||
where
|
|
||||||
initialNode = txtNode "" "Loading..."
|
|
||||||
|
|
@ -1,52 +0,0 @@
|
||||||
-- | A 'Broadcaster' allows threads to 'broadcast' values to 'Listeners'
|
|
||||||
-- attached to that broadcaster. A value that is sent through a broadcaster will
|
|
||||||
-- arrive exactly once at each attached listener and can then be collected by
|
|
||||||
-- calling 'listen'.
|
|
||||||
--
|
|
||||||
-- All functions included in this module should be threadsafe. Be sure to read
|
|
||||||
-- the warning on the 'broadcast' function.
|
|
||||||
|
|
||||||
module Forest.Server.Broadcast
|
|
||||||
( Broadcaster
|
|
||||||
, Listener
|
|
||||||
, newBroadcaster
|
|
||||||
, attachListener
|
|
||||||
, broadcast
|
|
||||||
, listen
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent.Chan
|
|
||||||
|
|
||||||
-- | A 'Broadcaster' can broadcast values to all attached 'Listener's
|
|
||||||
newtype Broadcaster a = Broadcaster (Chan a)
|
|
||||||
|
|
||||||
-- | A 'Listener' receives values from the 'Broadcaster' it is attached to
|
|
||||||
newtype Listener a = Listener (Chan a)
|
|
||||||
|
|
||||||
-- | Create a new 'Broadcaster'
|
|
||||||
newBroadcaster :: IO (Broadcaster a)
|
|
||||||
newBroadcaster = Broadcaster <$> newChan
|
|
||||||
|
|
||||||
-- | Create a new 'Listener' that is attached to a 'Broadcaster'
|
|
||||||
attachListener :: Broadcaster a -> IO (Listener a)
|
|
||||||
attachListener (Broadcaster chan) = Listener <$> dupChan chan
|
|
||||||
|
|
||||||
-- | Send a value through the 'Broadcaster'. That value will arrive exactly once
|
|
||||||
-- at all 'Listener's attached to this broadcaster via 'attachListener'.
|
|
||||||
--
|
|
||||||
-- Warning: During this function call, no exception should occur or elements may
|
|
||||||
-- build up in the broadcaster, leading to a memory/space leak.
|
|
||||||
broadcast :: Broadcaster a -> a -> IO ()
|
|
||||||
-- Because the same function that puts something into the broadcaster channel
|
|
||||||
-- also immediately reads something from that channel, there is no build-up of
|
|
||||||
-- values in the broadcaster channel, as one element is removed for each element
|
|
||||||
-- written. Since the broadcaster channel is separate from the listener
|
|
||||||
-- channels, no event is swallowed accidentally.
|
|
||||||
--
|
|
||||||
-- If some exception happens after the write operation succeeds but before the
|
|
||||||
-- read operation finishes, elements can build up in the broadcast channel.
|
|
||||||
broadcast (Broadcaster chan) value = writeChan chan value <* readChan chan
|
|
||||||
|
|
||||||
-- | Read the next value from the 'Listener'. Blocks when the listener is empty.
|
|
||||||
listen :: Listener a -> IO a
|
|
||||||
listen (Listener chan) = readChan chan
|
|
||||||
|
|
@ -1,25 +0,0 @@
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
|
|
||||||
module Forest.Server.TreeModule
|
|
||||||
( TreeModule(..)
|
|
||||||
, ModuleConstructor
|
|
||||||
) where
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
|
||||||
|
|
||||||
import Forest.Node
|
|
||||||
|
|
||||||
class TreeModule a r where
|
|
||||||
edit :: a r -> Path -> T.Text -> IO (Maybe r)
|
|
||||||
edit _ _ _ = pure Nothing
|
|
||||||
|
|
||||||
delete :: a r -> Path -> IO (Maybe r)
|
|
||||||
delete _ _ = pure Nothing
|
|
||||||
|
|
||||||
reply :: a r -> Path -> T.Text -> IO (Maybe r)
|
|
||||||
reply _ _ _ = pure Nothing
|
|
||||||
|
|
||||||
act :: a r -> Path -> IO (Maybe r)
|
|
||||||
act _ _ = pure Nothing
|
|
||||||
|
|
||||||
type ModuleConstructor a = (Node -> IO ()) -> (a -> IO ()) -> IO ()
|
|
||||||
|
|
@ -1,27 +0,0 @@
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Forest.Server.TreeModule.Animate
|
|
||||||
( AnimateModule
|
|
||||||
, animateModule
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
|
|
||||||
import Forest.Node
|
|
||||||
import Forest.Server.TreeModule
|
|
||||||
import Forest.Util
|
|
||||||
|
|
||||||
data AnimateModule r = AnimateModule
|
|
||||||
|
|
||||||
instance TreeModule AnimateModule () where
|
|
||||||
|
|
||||||
animateModule :: Int -> [Node] -> ModuleConstructor (AnimateModule ())
|
|
||||||
animateModule delay frames sendNode continue =
|
|
||||||
withThread (animateThread frames) $ continue AnimateModule
|
|
||||||
where
|
|
||||||
animateThread [] = sendNode $ txtNode "" "Invalid animation: No frames provided"
|
|
||||||
animateThread (x:xs) = do
|
|
||||||
sendNode x
|
|
||||||
threadDelay delay
|
|
||||||
animateThread $ xs ++ [x]
|
|
||||||
|
|
@ -1,118 +0,0 @@
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Forest.Server.TreeModule.Const
|
|
||||||
( ConstModule
|
|
||||||
, constModule
|
|
||||||
, projectDescriptionNode
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Forest.Node
|
|
||||||
import Forest.Server.TreeModule
|
|
||||||
|
|
||||||
data ConstModule r = ConstModule
|
|
||||||
|
|
||||||
instance TreeModule ConstModule () where
|
|
||||||
|
|
||||||
constModule :: Node -> ModuleConstructor (ConstModule ())
|
|
||||||
constModule node sendNode continue = do
|
|
||||||
sendNode node
|
|
||||||
continue ConstModule
|
|
||||||
|
|
||||||
projectDescriptionNode :: Node
|
|
||||||
projectDescriptionNode =
|
|
||||||
newNode "" "About"
|
|
||||||
[ txtNode "" "This project is an experiment in tree-based interaction."
|
|
||||||
, newNode "" "Motivation"
|
|
||||||
[ txtNode "" "My goals for this project were:"
|
|
||||||
, newNode "" "Interactons between multiple people"
|
|
||||||
[ txtNode ""
|
|
||||||
( "I wanted to create a project that let multiple people interact with "
|
|
||||||
<> "each other in different ways. Examples for interactions include:\n"
|
|
||||||
<> "* Chatting\n"
|
|
||||||
<> "* Collaborative editing\n"
|
|
||||||
<> "* Playing (multiplayer) games\n"
|
|
||||||
)
|
|
||||||
, txtNode "" "The project should allow for many different kinds of interactions."
|
|
||||||
]
|
|
||||||
, newNode "" "Portability"
|
|
||||||
[ txtNode ""
|
|
||||||
( "The project should be usable on multiple different platforms. To "
|
|
||||||
<> "facilitate this, clients should be easy to create. In particular, I "
|
|
||||||
<> "want at least one terminal-based and one web-based client."
|
|
||||||
)
|
|
||||||
]
|
|
||||||
, txtNode "" "Based on these goals, I made the following design decisions:"
|
|
||||||
, newNode "" "Text-based"
|
|
||||||
[ txtNode ""
|
|
||||||
( "Text is a medium that works on all platforms and easy to work with "
|
|
||||||
<> "as a developer."
|
|
||||||
)
|
|
||||||
, txtNode ""
|
|
||||||
( "But text still allows for a lot of different interactions. Of all "
|
|
||||||
<> "the kinds of media one can produce with a computer, text is easy "
|
|
||||||
<> "and quick to create. After all, pretty much every computer has a "
|
|
||||||
<> "keyboard."
|
|
||||||
)
|
|
||||||
]
|
|
||||||
, newNode "" "Tree-based"
|
|
||||||
[ txtNode ""
|
|
||||||
( "While plain text may be easy to work with, it makes interactions "
|
|
||||||
<> "cumbersome if limited to basic input and output. To make "
|
|
||||||
<> "interactions nicer, the server could send the client a screen's "
|
|
||||||
<> "worth of text to display, in effect creating a TUI-like interface. "
|
|
||||||
<> "The client would then only need to send key presses or mouse clicks "
|
|
||||||
<> "to the server."
|
|
||||||
)
|
|
||||||
, txtNode ""
|
|
||||||
( "In my opinion, that approach moves too many decisions on how to "
|
|
||||||
<> "interact to the server and imposes unnecessary limits on the client "
|
|
||||||
<> "design. Instead, I went with a plaintext-in-tree-structure "
|
|
||||||
<> "approach, which allows for more flexibility in the client design. "
|
|
||||||
<> "Also, this should make bots easier to write, since they don't have "
|
|
||||||
<> "to emulate human input."
|
|
||||||
)
|
|
||||||
]
|
|
||||||
, newNode "" "Simple API"
|
|
||||||
[ txtNode ""
|
|
||||||
( "Every client must use the same API to interact with the server. "
|
|
||||||
<> "Because clients should be easy to create on different platforms, "
|
|
||||||
<> "the API should also be simple."
|
|
||||||
)
|
|
||||||
, txtNode ""
|
|
||||||
( "One way in which the API is simple is that the server doesn't send "
|
|
||||||
<> "direct responses to client commands. Instead, there is only the "
|
|
||||||
<> "'update' packet, which is sent whenever the client should modify "
|
|
||||||
<> "its tree structure."
|
|
||||||
)
|
|
||||||
, txtNode ""
|
|
||||||
( "In total, there are 5 different client packages and 2 different "
|
|
||||||
<> "server packages. If at some point the API turns out to be too "
|
|
||||||
<> "simple, it has a built-in way of negotiating protocol extensions."
|
|
||||||
)
|
|
||||||
]
|
|
||||||
, newNode "" "Most logic in server"
|
|
||||||
[ txtNode ""
|
|
||||||
( "All logic besides the immediate input handling and tree folding "
|
|
||||||
<> "happens in the server. This has multiple advantages:"
|
|
||||||
)
|
|
||||||
, txtNode "" "The API and clients are simpler, clients are easier to write or maintain."
|
|
||||||
, txtNode "" "Updates in logic don't require updates of the client."
|
|
||||||
, txtNode "" "The server-side logic becomes easier to write."
|
|
||||||
]
|
|
||||||
, txtNode ""
|
|
||||||
( "Those design decisions should allow for various different kinds of "
|
|
||||||
<> "interactions, for example linear and threaded chat, collaborative "
|
|
||||||
<> "node editing, reading node-based documents (like this one), playing "
|
|
||||||
<> "text adventures and more."
|
|
||||||
)
|
|
||||||
, txtNode ""
|
|
||||||
( "And of course, which interactions are supported only depends on the "
|
|
||||||
<> "server and not on the client."
|
|
||||||
)
|
|
||||||
]
|
|
||||||
, newNode "" "Inspirations"
|
|
||||||
[ txtNode "" "The tree-based chat model and UI of euphoria (euphoria.io) and instant (instant.leet.nu)"
|
|
||||||
, txtNode "" "MUDs (which are text based and most of the logic happens server-side)"
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
@ -1,102 +0,0 @@
|
||||||
{-# LANGUAGE ExistentialQuantification #-}
|
|
||||||
{-# LANGUAGE KindSignatures #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
|
|
||||||
module Forest.Server.TreeModule.Fork
|
|
||||||
( ForkModule
|
|
||||||
, ProngConstructor(..)
|
|
||||||
, forkModule
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent.MVar
|
|
||||||
import Control.Monad.Trans.Cont
|
|
||||||
import qualified Data.Map as Map
|
|
||||||
import qualified Data.Text as T
|
|
||||||
|
|
||||||
import Forest.Node
|
|
||||||
import qualified Forest.OrderedMap as OMap
|
|
||||||
import Forest.Server.TreeModule
|
|
||||||
|
|
||||||
data Prong = forall r a . TreeModule a r => Prong (a r)
|
|
||||||
|
|
||||||
data ProngConstructor = forall r a . TreeModule a r =>
|
|
||||||
ProngConstructor T.Text (ModuleConstructor (a r))
|
|
||||||
|
|
||||||
newtype ForkModule r = ForkModule (Map.Map NodeId Prong)
|
|
||||||
|
|
||||||
instance TreeModule ForkModule () where
|
|
||||||
edit _ (Path []) _ = pure Nothing
|
|
||||||
edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
|
|
||||||
Nothing -> pure Nothing
|
|
||||||
Just (Prong a) -> do
|
|
||||||
result <- edit a (Path xs) text
|
|
||||||
pure $ () <$ result
|
|
||||||
|
|
||||||
delete _ (Path []) = pure Nothing
|
|
||||||
delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
|
|
||||||
Nothing -> pure Nothing
|
|
||||||
Just (Prong a) -> do
|
|
||||||
result <- delete a (Path xs)
|
|
||||||
pure $ () <$ result
|
|
||||||
|
|
||||||
reply _ (Path []) _ = pure Nothing
|
|
||||||
reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
|
|
||||||
Nothing -> pure Nothing
|
|
||||||
Just (Prong a) -> do
|
|
||||||
result <- reply a (Path xs) text
|
|
||||||
pure $ () <$ result
|
|
||||||
|
|
||||||
act _ (Path []) = pure Nothing
|
|
||||||
act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
|
|
||||||
Nothing -> pure Nothing
|
|
||||||
Just (Prong a) -> do
|
|
||||||
result <- act a (Path xs)
|
|
||||||
pure $ () <$ result
|
|
||||||
|
|
||||||
data ProngInfo = ProngInfo
|
|
||||||
{ piTopName :: T.Text
|
|
||||||
, piNames :: Map.Map NodeId T.Text
|
|
||||||
, piNodes :: Map.Map NodeId Node
|
|
||||||
, piOrder :: [NodeId]
|
|
||||||
}
|
|
||||||
|
|
||||||
renderProngInfo :: ProngInfo -> Node
|
|
||||||
renderProngInfo pInfo =
|
|
||||||
let childMap = Map.intersectionWith
|
|
||||||
(\name node -> node{nodeText = name})
|
|
||||||
(piNames pInfo)
|
|
||||||
(piNodes pInfo)
|
|
||||||
children = OMap.fromMapWithOrder childMap $ piOrder pInfo
|
|
||||||
in Node {nodeText = piTopName pInfo, nodeFlags = mempty, nodeChildren = children}
|
|
||||||
|
|
||||||
sendNodeFromProng :: MVar ProngInfo -> (Node -> IO ()) -> NodeId -> Node -> IO ()
|
|
||||||
sendNodeFromProng piVar sendNode nodeId node =
|
|
||||||
modifyMVar_ piVar $ \pInfo -> do
|
|
||||||
let newPInfo = pInfo {piNodes = Map.insert nodeId node $ piNodes pInfo}
|
|
||||||
sendNode $ renderProngInfo newPInfo
|
|
||||||
pure newPInfo
|
|
||||||
|
|
||||||
constructProngs
|
|
||||||
:: MVar ProngInfo
|
|
||||||
-> (Node -> IO ())
|
|
||||||
-> Map.Map NodeId ProngConstructor
|
|
||||||
-> Cont (IO ()) (Map.Map NodeId Prong)
|
|
||||||
constructProngs piVar sendNode =
|
|
||||||
Map.traverseWithKey constructProng
|
|
||||||
where
|
|
||||||
constructProng nodeId (ProngConstructor _ constructor) =
|
|
||||||
Prong <$> cont (constructor $ sendNodeFromProng piVar sendNode nodeId)
|
|
||||||
|
|
||||||
forkModule :: T.Text -> [ProngConstructor] -> ModuleConstructor (ForkModule ())
|
|
||||||
forkModule text prongs sendNode continue = do
|
|
||||||
let namePairs = zip enumerateIds $ map (\(ProngConstructor name _) -> name) prongs
|
|
||||||
nodesVar <- newMVar ProngInfo
|
|
||||||
{ piTopName = text
|
|
||||||
, piNames = Map.fromList namePairs
|
|
||||||
, piNodes = Map.empty
|
|
||||||
, piOrder = map fst namePairs
|
|
||||||
}
|
|
||||||
let numbers = map (T.pack . show) [(0::Integer)..]
|
|
||||||
prongMap = Map.fromList $ zip numbers prongs
|
|
||||||
runCont (constructProngs nodesVar sendNode prongMap) (continue . ForkModule)
|
|
||||||
|
|
@ -1,56 +0,0 @@
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
|
|
||||||
module Forest.Server.TreeModule.SharedEditing
|
|
||||||
( SharedEditingModule
|
|
||||||
, sharedEditingModule
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent.MVar
|
|
||||||
import Control.Monad
|
|
||||||
|
|
||||||
import Forest.Node
|
|
||||||
import Forest.Server.Broadcast
|
|
||||||
import Forest.Server.TreeModule
|
|
||||||
import Forest.Util
|
|
||||||
|
|
||||||
data SharedEditingModule r = SharedEditingModule
|
|
||||||
{ seNodeVar :: MVar Node
|
|
||||||
, seBroadcaster :: Broadcaster Node
|
|
||||||
}
|
|
||||||
|
|
||||||
instance TreeModule SharedEditingModule r where
|
|
||||||
edit _ (Path []) _ = pure Nothing
|
|
||||||
edit se path text = do
|
|
||||||
node' <- modifyMVar (seNodeVar se) $ \node -> do
|
|
||||||
let updatedNode = adjustAt (\n -> n{nodeText = text}) path node
|
|
||||||
pure (updatedNode, updatedNode)
|
|
||||||
broadcast (seBroadcaster se) node'
|
|
||||||
pure Nothing
|
|
||||||
|
|
||||||
delete _ (Path []) = pure Nothing
|
|
||||||
delete se path = do
|
|
||||||
node' <- modifyMVar (seNodeVar se) $ \node -> do
|
|
||||||
let updatedNode = deleteAt path node
|
|
||||||
pure (updatedNode, updatedNode)
|
|
||||||
broadcast (seBroadcaster se) node'
|
|
||||||
pure Nothing
|
|
||||||
|
|
||||||
reply se path text = do
|
|
||||||
node' <- modifyMVar (seNodeVar se) $ \node -> do
|
|
||||||
let updatedNode = appendAt (txtNode "edr" text) path node
|
|
||||||
pure (updatedNode, updatedNode)
|
|
||||||
broadcast (seBroadcaster se) node'
|
|
||||||
pure Nothing
|
|
||||||
|
|
||||||
sharedEditingModule ::
|
|
||||||
MVar Node -> Broadcaster Node -> ModuleConstructor (SharedEditingModule ())
|
|
||||||
sharedEditingModule nodeVar broadcaster sendNode continue = do
|
|
||||||
listener <- attachListener broadcaster
|
|
||||||
withThread (updateOnNewBroadcast listener) $ do
|
|
||||||
withMVar nodeVar sendNode -- We need to show our initial edit state
|
|
||||||
continue $ SharedEditingModule nodeVar broadcaster
|
|
||||||
where
|
|
||||||
updateOnNewBroadcast listener = forever $ do
|
|
||||||
node <- listen listener
|
|
||||||
sendNode node
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue