From f2e77b7c036d32ecdcb770ce260283f7752cb40f Mon Sep 17 00:00:00 2001 From: Joscha Date: Tue, 18 Feb 2020 00:43:30 +0000 Subject: [PATCH] [server] Implement shared editing module --- server/Main.hs | 27 +++++-------- src/Forest/Node.hs | 35 ++++++++++++++++ src/Forest/TreeModule/SharedEditing.hs | 56 ++++++++++++++++++++++++++ 3 files changed, 100 insertions(+), 18 deletions(-) create mode 100644 src/Forest/TreeModule/SharedEditing.hs diff --git a/server/Main.hs b/server/Main.hs index 836d28a..9dc690d 100644 --- a/server/Main.hs +++ b/server/Main.hs @@ -2,13 +2,15 @@ module Main where -import qualified Network.WebSockets as WS +import Control.Concurrent.MVar +import qualified Network.WebSockets as WS +import Forest.Broadcast import Forest.Node import Forest.Server -import Forest.TreeModule.Animate import Forest.TreeModule.Const import Forest.TreeModule.Fork +import Forest.TreeModule.SharedEditing pingDelay :: Int pingDelay = 10 @@ -23,24 +25,13 @@ options = WS.defaultServerOptions main :: IO () main = do + putStrLn "Preparing shared edit module" + sharedEditNodeVar <- newMVar $ txtNode "r" "" + sharedEditBroadcaster <- newBroadcaster + putStrLn "Starting server" WS.runServerWithOptions options $ serverApp pingDelay $ forkModule "Forest" [ ProngConstructor "Test" $ constModule $ newNode "" "" [txtNode "" "Bla"] - , ProngConstructor "Animation" $ animateModule 200000 $ map (newNode "" "") - [ [txtNode "" "|> |", txtNode "" "Ping!"] - , [txtNode "" "|-> |", txtNode "" "Ping!"] - , [txtNode "" "| -> |", txtNode "" "Ping!"] - , [txtNode "" "| -> |", txtNode "" "Ping!"] - , [txtNode "" "| ->|", txtNode "" "Ping!"] - , [txtNode "" "| -|", txtNode "" "Ping!"] - , [txtNode "" "| |", txtNode "" "Ping!"] - , [txtNode "" "| <|", txtNode "" "Pong!"] - , [txtNode "" "| <-|", txtNode "" "Pong!"] - , [txtNode "" "| <- |", txtNode "" "Pong!"] - , [txtNode "" "| <- |", txtNode "" "Pong!"] - , [txtNode "" "|<- |", txtNode "" "Pong!"] - , [txtNode "" "|- |", txtNode "" "Pong!"] - , [txtNode "" "| |", txtNode "" "Pong!"] - ] + , ProngConstructor "Sandbox" $ sharedEditingModule sharedEditNodeVar sharedEditBroadcaster , ProngConstructor "About" $ constModule projectDescriptionNode ] diff --git a/src/Forest/Node.hs b/src/Forest/Node.hs index 4a40c79..bb55a47 100644 --- a/src/Forest/Node.hs +++ b/src/Forest/Node.hs @@ -4,6 +4,7 @@ module Forest.Node ( NodeId , enumerateIds + , findUnusedId , NodeFlags(..) , readFlags , Node(..) @@ -15,8 +16,12 @@ module Forest.Node , applyPath , adjustAt , replaceAt + , deleteAt + , appendAt , diffNodes , Path(..) + , split + , parent , narrow , narrowSet ) where @@ -35,6 +40,10 @@ type NodeId = T.Text enumerateIds :: [NodeId] enumerateIds = map (T.pack . show) [(0::Integer)..] +findUnusedId :: Set.Set NodeId -> NodeId +findUnusedId usedIds = + head $ filter (\nid -> not $ nid `Set.member` usedIds) enumerateIds + data NodeFlags = NodeFlags { flagEdit :: !Bool , flagDelete :: !Bool @@ -146,6 +155,25 @@ adjustAt f (Path (x:xs)) node = replaceAt :: Node -> Path -> Node -> Node replaceAt node = adjustAt $ const node +-- | Delete a subnode at a specified path. Does nothing if the path is 'mempty'. +deleteAt :: Path -> Node -> Node +deleteAt path node = case split path of + Nothing -> node + Just (parentPath, nodeId) -> adjustAt + (\n -> n{nodeChildren = OMap.delete nodeId $ nodeChildren n}) + parentPath + node + +-- | Append a new child node to the node at the specified path. Chooses an +-- unused node id. +appendAt :: Node -> Path -> Node -> Node +appendAt node = + adjustAt (\n -> n {nodeChildren = appendAtNewId $ nodeChildren n}) + where + appendAtNewId m = + let nid = findUnusedId $ OMap.keysSet m + in OMap.append nid node m + diffNodes :: Node -> Node -> Maybe (Path, Node) diffNodes a b | nodesDiffer || childrenChanged = Just (Path [], b) @@ -165,6 +193,13 @@ newtype Path = Path { pathElements :: [NodeId] } deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON) +split :: Path -> Maybe (Path, NodeId) +split (Path []) = Nothing +split (Path xs) = Just (Path (init xs), last xs) + +parent :: Path -> Maybe Path +parent path = fst <$> split path + -- | Try to remove a 'NodeId' from the beginning of a 'Path'. narrow :: NodeId -> Path -> Maybe Path narrow nid (Path (x:xs)) diff --git a/src/Forest/TreeModule/SharedEditing.hs b/src/Forest/TreeModule/SharedEditing.hs new file mode 100644 index 0000000..b67d431 --- /dev/null +++ b/src/Forest/TreeModule/SharedEditing.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Forest.TreeModule.SharedEditing + ( SharedEditingModule + , sharedEditingModule + ) where + +import Control.Concurrent.MVar +import Control.Monad + +import Forest.Broadcast +import Forest.Node +import Forest.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