[server] Implement shared editing module

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
     ]

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))

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