diff --git a/forest-cabin/app/Main.hs b/forest-cabin/app/Main.hs index b8443cd..50e97b9 100644 --- a/forest-cabin/app/Main.hs +++ b/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" diff --git a/forest-cabin/forest-cabin.cabal b/forest-cabin/forest-cabin.cabal index 8d6e630..6b40d14 100644 --- a/forest-cabin/forest-cabin.cabal +++ b/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 diff --git a/forest-cabin/package.yaml b/forest-cabin/package.yaml index 41b5343..143b8dc 100644 --- a/forest-cabin/package.yaml +++ b/forest-cabin/package.yaml @@ -15,6 +15,8 @@ dependencies: - base >= 4.7 && < 5 - forest-common - forest-server + - microlens + - microlens-th - stm - websockets diff --git a/forest-server/forest-server.cabal b/forest-server/forest-server.cabal index 64e5f60..b581d18 100644 --- a/forest-server/forest-server.cabal +++ b/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 diff --git a/forest-server/package.yaml b/forest-server/package.yaml index cb5c5f6..f9395d9 100644 --- a/forest-server/package.yaml +++ b/forest-server/package.yaml @@ -15,6 +15,7 @@ dependencies: - base >= 4.7 && < 5 - containers - forest-common + - microlens - stm - text - transformers diff --git a/forest-server/src/Forest/Server/Branch/SharedEdit.hs b/forest-server/src/Forest/Server/Branch/SharedEdit.hs new file mode 100644 index 0000000..d7502fe --- /dev/null +++ b/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 + } diff --git a/forest-server/src/Forest/Server/Schema.hs b/forest-server/src/Forest/Server/Schema.hs index 3b7d1cf..e7856f8 100644 --- a/forest-server/src/Forest/Server/Schema.hs +++ b/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