[server] Extract shared editing logic into a branch

forest-cabin/app/Main.hs

@@ -1,13 +1,16 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
 module Main where
 
-import           Control.Concurrent.MVar
 import           Control.Concurrent.STM
-import           Control.Monad
-import qualified Network.WebSockets      as WS
+import           Lens.Micro
+import           Lens.Micro.TH
+import qualified Network.WebSockets              as WS
 
 import           Forest.Node
+import           Forest.Server.Branch.SharedEdit
+import           Forest.Server.Schema
 import           Forest.Server.TreeApp
 
 {- Websocket server stuff -}
@@ -25,64 +28,51 @@ options = WS.defaultServerOptions
 
 {- The actual app -}
 
-data AppEvent = SharedNodeEdited
+data AppEvent = UpdateSharedEdit
   deriving (Show, Eq)
 
-data AppState = AppState
-  { asBroadcastChan :: TChan AppEvent
-  , asReceiveChan   :: TChan AppEvent
-  , asSharedNodeVar :: MVar Node
-  , asSharedNode    :: Node
+newtype AppState = AppState
+  { _asSharedEdit :: SharedEditLocal
   }
 
-draw :: AppState -> Node
-draw = asSharedNode
+makeLenses ''AppState
 
-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'}
+schema :: AppState -> Schema (Branch AppState AppEvent)
+schema s = fork' "Forest"
+  [ leaf $ schemaLift asSharedEdit sharedEditBranch s
+  ]
+
+draw :: AppState -> Node
+draw = schemaDraw . schema
 
 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 _ = pure $ continue s
+handleEvent s (Custom UpdateSharedEdit) = do
+  sel' <- sharedEditUpdate $ s ^. asSharedEdit
+  pure $ continue $ s & asSharedEdit .~ sel'
+handleEvent s e = case schemaHandleEvent (schema s) e of
+  Nothing -> pure $ continue s
+  Just s' -> continue <$> s'
 
 constructor
   :: TChan AppEvent
-  -> MVar Node
+  -> SharedEditGlobal
   -> (AppState -> Maybe (TChan AppEvent) -> IO a)
   -> IO a
-constructor broadcastChan sharedNodeVar cont = do
-  node <- readMVar sharedNodeVar
+constructor broadcastChan seg cont = do
+  sel <- sharedEditLocal seg
   receiveChan <- atomically $ dupTChan broadcastChan
-  let state = AppState broadcastChan receiveChan sharedNodeVar node
-  cont state $ Just receiveChan
+  cont (AppState sel) (Just receiveChan)
 
 main :: IO ()
 main = do
-  putStrLn "Preparing shared editing"
-  sharedNodeVar <- newMVar $ txtNode "r" "Sandbox"
+  putStrLn "Preparing server"
   broadcastChan <- atomically newBroadcastTChan
+  let onEditChange = atomically $ writeTChan broadcastChan UpdateSharedEdit
+  seg <- sharedEditGlobal onEditChange "Sandbox"
   let app = TreeApp
             { appDraw = draw
             , appHandleEvent = handleEvent
-            , appConstructor = constructor broadcastChan sharedNodeVar
+            , appConstructor = constructor broadcastChan seg
             }
 
   putStrLn "Starting server"

forest-cabin/forest-cabin.cabal

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

forest-cabin/package.yaml

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

forest-server/forest-server.cabal

@@ -26,6 +26,7 @@ source-repository head
 
 library
   exposed-modules:
+      Forest.Server.Branch.SharedEdit
       Forest.Server.Schema
       Forest.Server.TreeApp
   other-modules:
@@ -36,6 +37,7 @@ library
       base >=4.7 && <5
     , containers
     , forest-common
+    , microlens
     , stm
     , text
     , transformers

forest-server/package.yaml

@@ -15,6 +15,7 @@ dependencies:
   - base >= 4.7 && < 5
   - containers
   - forest-common
+  - microlens
   - stm
   - text
   - transformers

forest-server/src/Forest/Server/Branch/SharedEdit.hs

@@ -0,0 +1,80 @@
+module Forest.Server.Branch.SharedEdit
+  ( SharedEditGlobal
+  , sharedEditGlobal
+  , SharedEditLocal
+  , sharedEditLocal
+  , sharedEditDraw
+  , sharedEditUpdate
+  , sharedEditHandleEvent
+  , sharedEditBranch
+  ) where
+
+import           Control.Concurrent
+import           Control.Monad
+import qualified Data.Text             as T
+
+import           Forest.Node
+import           Forest.Server.Schema
+import           Forest.Server.TreeApp
+
+data SharedEditGlobal = SharedEditGlobal
+  { seOnUpdate :: IO ()
+  , seNodeVar  :: MVar Node
+  }
+
+sharedEditGlobal :: IO () -> T.Text -> IO SharedEditGlobal
+sharedEditGlobal onUpdate initialText = do
+  nodeVar <- newMVar $ txtNode "r" initialText
+  pure SharedEditGlobal
+    { seOnUpdate = onUpdate
+    , seNodeVar  = nodeVar
+    }
+
+data SharedEditLocal = SharedEditLocal
+  { seGlobal :: SharedEditGlobal
+  , seNode   :: Node
+  }
+
+sharedEditLocal :: SharedEditGlobal -> IO SharedEditLocal
+sharedEditLocal seg = do
+  node <- readMVar $ seNodeVar seg
+  pure SharedEditLocal
+    { seGlobal = seg
+    , seNode   = node
+    }
+
+sharedEditDraw :: SharedEditLocal -> Node
+sharedEditDraw = seNode
+
+sharedEditUpdate :: SharedEditLocal -> IO SharedEditLocal
+sharedEditUpdate sel = do
+  node <- readMVar $ seNodeVar $ seGlobal sel
+  pure sel{seNode = node}
+
+updateNode :: SharedEditLocal -> (Node -> Node) -> IO SharedEditLocal
+updateNode sel f = do
+  let seg = seGlobal sel
+      nodeVar = seNodeVar seg
+  node <- takeMVar nodeVar
+  let node' = f node
+  putMVar nodeVar node'
+  when (node /= node') $ seOnUpdate seg
+  pure sel{seNode = node'}
+
+sharedEditHandleEvent :: SharedEditLocal -> Path -> Event e -> IO SharedEditLocal
+-- Ignore edits to the top node since it's only reply-able, not edit-able
+sharedEditHandleEvent sel (Path []) (Edit _ _) = pure sel
+sharedEditHandleEvent sel (Path []) (Delete _) = pure sel
+sharedEditHandleEvent sel path (Edit _ text) =
+  updateNode sel $ adjustAt (\n -> n {nodeText = text}) path
+sharedEditHandleEvent sel path (Delete _) =
+  updateNode sel $ deleteAt path
+sharedEditHandleEvent sel path (Reply _ text) =
+  updateNode sel $ appendAt (txtNode "edr" text) path
+sharedEditHandleEvent sel _ _ = pure sel
+
+sharedEditBranch :: SharedEditLocal -> Branch SharedEditLocal e
+sharedEditBranch sel = Branch
+  { branchNode        = sharedEditDraw sel
+  , branchHandleEvent = sharedEditHandleEvent sel
+  }

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE RankNTypes #-}
+
 module Forest.Server.Schema
   ( Schema
   , fork
@@ -6,12 +8,19 @@ module Forest.Server.Schema
   , collect
   , collectWith
   , dispatch
+  -- * Useful type
+  , Branch(..)
+  , schemaDraw
+  , schemaHandleEvent
+  , schemaLift
   ) where
 
-import qualified Data.Text         as T
+import qualified Data.Text             as T
+import           Lens.Micro
 
 import           Forest.Node
-import qualified Forest.OrderedMap as OMap
+import qualified Forest.OrderedMap     as OMap
+import           Forest.Server.TreeApp
 
 data Schema a
   = Fork T.Text (OMap.OrderedMap NodeId (Schema a))
@@ -44,3 +53,33 @@ dispatch :: Path -> Schema a -> Maybe (Path, a)
 dispatch path          (Leaf a)      = Just (path, a)
 dispatch (Path (x:xs)) (Fork _ omap) = dispatch (Path xs) =<< (omap OMap.!? x)
 dispatch (Path [])     (Fork _ _   ) = Nothing -- More specfic than required
+
+data Branch s e = Branch
+  { branchNode        :: Node
+  , branchHandleEvent :: Path -> Event e -> IO s
+  }
+
+schemaDraw :: Schema (Branch s e) -> Node
+schemaDraw = collectWith branchNode
+
+schemaHandleEvent :: Schema (Branch s e) -> Event e -> Maybe (IO s)
+schemaHandleEvent schema event = do
+  path <- getPath event
+  (relPath, branch) <- dispatch path schema
+  pure $ branchHandleEvent branch relPath event
+  where
+    getPath (Edit path _)  = Just path
+    getPath (Delete path)  = Just path
+    getPath (Reply path _) = Just path
+    getPath (Act path)     = Just path
+    getPath _              = Nothing
+
+schemaLift :: Lens' s t -> (t -> Branch t e) -> s -> Branch s e
+schemaLift l f s = Branch
+  { branchNode = branchNode branch
+  , branchHandleEvent = \path event -> do
+      t' <- branchHandleEvent branch path event
+      pure $ s & l .~ t'
+  }
+  where
+    branch = f $ s ^. l