[server] Reimplement collaborative editing

forest-cabin/app/Main.hs

@@ -2,11 +2,16 @@
 
 module Main where
 
+import           Control.Concurrent.MVar
+import           Control.Concurrent.STM
+import           Control.Monad
 import qualified Network.WebSockets      as WS
 
 import           Forest.Node
 import           Forest.Server.TreeApp
 
+{- Websocket server stuff -}
+
 pingDelay :: Int
 pingDelay = 10
 
@@ -18,14 +23,68 @@ options = WS.defaultServerOptions
   { WS.serverRequirePong = Just pongDelay
   }
 
-app :: TreeApp Node ()
+{- The actual app -}
-app = TreeApp
+
-  { appGraft = id
+data AppEvent = SharedNodeEdited
-  , appHandleEvent = \s _ -> pure $ continue s
+  deriving (Show, Eq)
-  , appConstructor = simpleConstructor $ txtNode "" "Hello world"
+
+data AppState = AppState
+  { asBroadcastChan :: TChan AppEvent
+  , asReceiveChan   :: TChan AppEvent
+  , asSharedNodeVar :: MVar Node
+  , asSharedNode    :: Node
   }
 
+graft :: AppState -> Node
+graft = asSharedNode
+
+updateSharedNode :: AppState -> (Node -> Node) -> IO AppState
+updateSharedNode s f = do
+  node <- takeMVar $ asSharedNodeVar s
+  let node' = f node
+  putMVar (asSharedNodeVar s) node'
+  when (node /= node') $ atomically $ do
+    writeTChan (asBroadcastChan s) SharedNodeEdited
+    void $ readTChan $ asReceiveChan s
+  pure s{asSharedNode = node'}
+
+handleEvent :: AppState -> Event AppEvent -> IO (Next AppState)
+handleEvent s (Custom SharedNodeEdited) = do
+  node <- readMVar $ asSharedNodeVar s
+  pure $ continue s{asSharedNode = node}
+handleEvent s (Edit path text) = do
+  s' <- updateSharedNode s $ adjustAt (\n -> n{nodeText = text}) path
+  pure $ continue s'
+handleEvent s (Delete path) = do
+  s' <- updateSharedNode s $ deleteAt path
+  pure $ continue s'
+handleEvent s (Reply path text) = do
+  s' <- updateSharedNode s $ appendAt (txtNode "edr" text) path
+  pure $ continue s'
+handleEvent s _ = do
+  pure $ continue s
+
+constructor
+  :: TChan AppEvent
+  -> MVar Node
+  -> (AppState -> Maybe (TChan AppEvent) -> IO a)
+  -> IO a
+constructor broadcastChan sharedNodeVar cont = do
+  node <- readMVar sharedNodeVar
+  receiveChan <- atomically $ dupTChan broadcastChan
+  let state = AppState broadcastChan receiveChan sharedNodeVar node
+  cont state $ Just receiveChan
+
 main :: IO ()
 main = do
+  putStrLn "Preparing shared editing"
+  sharedNodeVar <- newMVar $ txtNode "r" "Sandbox"
+  broadcastChan <- atomically newBroadcastTChan
+  let app = TreeApp
+            { appGraft = graft
+            , appHandleEvent = handleEvent
+            , appConstructor = constructor broadcastChan sharedNodeVar
+            }
+
   putStrLn "Starting server"
-  WS.runServerWithOptions options $ runTreeApp pingDelay Nothing app
+  WS.runServerWithOptions options $ runTreeApp pingDelay app

forest-cabin/forest-cabin.cabal

@@ -33,6 +33,7 @@ library
       base >=4.7 && <5
     , forest-common
     , forest-server
+    , stm
     , websockets
   default-language: Haskell2010
 
@@ -48,5 +49,6 @@ executable forest-cabin
     , forest-cabin
     , forest-common
     , forest-server
+    , stm
     , websockets
   default-language: Haskell2010

forest-cabin/package.yaml

@@ -15,6 +15,7 @@ dependencies:
   - base >= 4.7 && < 5
   - forest-common
   - forest-server
+  - stm
   - websockets
 
 library:

forest-common/src/Forest/Node.hs

@@ -82,7 +82,7 @@ data Node = Node
   { nodeText     :: !T.Text
   , nodeFlags    :: !NodeFlags
   , nodeChildren :: !(OMap.OrderedMap NodeId Node)
-  } deriving (Show)
+  } deriving (Show, Eq)
 
 instance ToJSON Node where
   toJSON node = object

forest-common/src/Forest/OrderedMap.hs

@@ -65,7 +65,7 @@ import qualified Data.Set        as Set
 data OrderedMap k a = OrderedMap
   { omMap   :: Map.Map k a
   , omOrder :: [k]
-  }
+  } deriving (Eq)
 
 instance (Ord k, Show k, Show a) => Show (OrderedMap k a) where
   show m = "fromList " ++ show (toList m)

forest-server/src/Forest/Server/TreeApp.hs

@@ -1,7 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE TupleSections     #-}
-
 -- | This module specifies a structure for forest server applications. It is
 -- based on the way Brick models applications.
 
@@ -43,7 +41,7 @@ data Event e
 data TreeApp s e = TreeApp
   { appGraft       :: s -> Node
   , appHandleEvent :: s -> Event e -> IO (Next s)
-  , appConstructor :: forall a. (s -> IO a) -> IO a
+  , appConstructor :: forall a. (s -> Maybe (TChan e) -> IO a) -> IO a
   }
 
 simpleConstructor :: s -> (s -> IO a) -> IO a
@@ -99,12 +97,12 @@ runUntilHalt conn app rs = do
       sendNodeUpdate conn (rsNode rs) node'
       runUntilHalt conn app rs{rsState = state', rsNode = node'}
 
-runTreeApp :: Int -> Maybe (TChan e) -> TreeApp s e -> WS.ServerApp
+runTreeApp :: Int -> TreeApp s e -> WS.ServerApp
-runTreeApp pingDelay customChan app pendingConn = do
+runTreeApp pingDelay app pendingConn = do
   conn <- WS.acceptRequest pendingConn
   chan <- atomically newTChan
   WS.withPingThread conn pingDelay (pure ()) $
-    appConstructor app $ \initialState -> do
+    appConstructor app $ \initialState customChan -> do
       firstPacket <- receivePacket conn
       case firstPacket of
         ClientHello _ -> do