diff --git a/forest-cabin/app/Main.hs b/forest-cabin/app/Main.hs index 6ced424..1d75ba1 100644 --- a/forest-cabin/app/Main.hs +++ b/forest-cabin/app/Main.hs @@ -2,11 +2,16 @@ module Main where -import qualified Network.WebSockets as WS +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 () -app = TreeApp - { appGraft = id - , appHandleEvent = \s _ -> pure $ continue s - , appConstructor = simpleConstructor $ txtNode "" "Hello world" +{- The actual app -} + +data AppEvent = SharedNodeEdited + deriving (Show, Eq) + +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 diff --git a/forest-cabin/forest-cabin.cabal b/forest-cabin/forest-cabin.cabal index 3c0b54a..8d6e630 100644 --- a/forest-cabin/forest-cabin.cabal +++ b/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 diff --git a/forest-cabin/package.yaml b/forest-cabin/package.yaml index 4bfa1c6..41b5343 100644 --- a/forest-cabin/package.yaml +++ b/forest-cabin/package.yaml @@ -15,6 +15,7 @@ dependencies: - base >= 4.7 && < 5 - forest-common - forest-server + - stm - websockets library: diff --git a/forest-common/src/Forest/Node.hs b/forest-common/src/Forest/Node.hs index c89b6c3..b78a70a 100644 --- a/forest-common/src/Forest/Node.hs +++ b/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 diff --git a/forest-common/src/Forest/OrderedMap.hs b/forest-common/src/Forest/OrderedMap.hs index 9d5c1d3..5d13333 100644 --- a/forest-common/src/Forest/OrderedMap.hs +++ b/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) diff --git a/forest-server/src/Forest/Server/TreeApp.hs b/forest-server/src/Forest/Server/TreeApp.hs index 88aafe8..a33dd01 100644 --- a/forest-server/src/Forest/Server/TreeApp.hs +++ b/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 pingDelay customChan app pendingConn = do +runTreeApp :: Int -> TreeApp s e -> WS.ServerApp +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