diff --git a/.gitignore b/.gitignore index 76467e6..a5c3e0f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ .stack-work/ +forest.cabal *~ diff --git a/CHANGELOG.md b/CHANGELOG.md index 2447cb3..8afd99e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,4 @@ # Changelog for forest ## upcoming -- create project +* create project diff --git a/README.md b/README.md index 6dbb792..bcabaf8 100644 --- a/README.md +++ b/README.md @@ -1,19 +1,5 @@ # forest -Forest is an experiment in tree-based interaction: One or more clients connect -to a server and interact with it (and each other) via an interface consisting of -text-based nodes forming a tree. - -The project is split into multiple subprojects, most of which are Haskell -packages. For more information on individual subprojects, see their README or -the summary below. +Forest is an experiment in tree-based interaction. [API documentation](docs/API.md) - -## Subprojects - -- [forest-cabin](forest-cabin/): Server (Haskell) -- [forest-common](forest-common/): Common types and functions (Haskell) -- [forest-server](forest-server/): Server framework (Haskell) -- [forest-tui](forest-tui/): Terminal-based client (Haskell) -- [forest-web](forest-web/): Web-based client (static site) diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/forest-cabin/README.md b/forest-cabin/README.md deleted file mode 100644 index 403023d..0000000 --- a/forest-cabin/README.md +++ /dev/null @@ -1 +0,0 @@ -# forest-cabin diff --git a/forest-cabin/app/Main.hs b/forest-cabin/app/Main.hs deleted file mode 100644 index 82c4a76..0000000 --- a/forest-cabin/app/Main.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module Main where - -import Control.Concurrent.STM -import Lens.Micro -import Lens.Micro.TH -import qualified Network.WebSockets as WS -import Options.Applicative - -import Forest.Node -import Forest.Server.Branch.SharedEdit -import Forest.Server.Schema -import Forest.Server.TreeApp - -{- Command line options -} - -data ServerOptions = ServerOptions - { serverPingDelay :: Int - , serverHost :: String - , serverPort :: Int - } - -parser :: Parser ServerOptions -parser = ServerOptions - <$> option auto - ( long "ping-delay" - <> help "How many seconds to wait between each ping sent to the client" - <> value 10 - <> showDefault - <> metavar "SECONDS" - ) - <*> strOption - ( short 'h' - <> long "host" - <> help "The server's host" - <> value (WS.serverHost WS.defaultServerOptions) - <> showDefault - <> metavar "HOST" - ) - <*> option auto - ( short 'p' - <> long "port" - <> help "The port to listen for websocket connections on" - <> value (WS.serverPort WS.defaultServerOptions) - <> showDefault - <> metavar "PORT" - ) - -serverOptionsParserInfo :: ParserInfo ServerOptions -serverOptionsParserInfo = info (helper <*> parser) fullDesc - -wsOptions :: ServerOptions -> WS.ServerOptions -wsOptions o = WS.defaultServerOptions - { WS.serverHost = serverHost o - , WS.serverPort = serverPort o - , WS.serverRequirePong = Just $ serverPingDelay o * 2 - } - -{- The actual app -} - -data AppEvent = UpdateSharedEdit - deriving (Show, Eq) - -newtype AppState = AppState - { _asSharedEdit :: SharedEditLocal - } - -makeLenses ''AppState - -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 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 - -> SharedEditGlobal - -> (AppState -> Maybe (TChan AppEvent) -> IO a) - -> IO a -constructor broadcastChan seg cont = do - sel <- sharedEditLocal seg - receiveChan <- atomically $ dupTChan broadcastChan - cont (AppState sel) (Just receiveChan) - -main :: IO () -main = do - opts <- execParser serverOptionsParserInfo - - 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 seg - } - - putStrLn "Starting server" - WS.runServerWithOptions (wsOptions opts) $ - runTreeApp (serverPingDelay opts) app diff --git a/forest-cabin/forest-cabin.cabal b/forest-cabin/forest-cabin.cabal deleted file mode 100644 index 4cd34f2..0000000 --- a/forest-cabin/forest-cabin.cabal +++ /dev/null @@ -1,60 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.31.2. --- --- see: https://github.com/sol/hpack --- --- hash: c619b22393d818639b183c69031b267a4ed16faeaf609a75ef1cadb9288195e1 - -name: forest-cabin -version: 0.1.0.0 -synopsis: A forest server hosted at forest.plugh.de -description: Please see the README at -homepage: https://github.com/Garmelon/forest#readme -bug-reports: https://github.com/Garmelon/forest/issues -author: Garmelon -maintainer: Garmelon -copyright: 2020 Garmelon -license: MIT -build-type: Simple -extra-source-files: - README.md - -source-repository head - type: git - location: https://github.com/Garmelon/forest - -library - other-modules: - Paths_forest_cabin - hs-source-dirs: - src - build-depends: - base >=4.7 && <5 - , forest-common - , forest-server - , microlens - , microlens-th - , optparse-applicative - , stm - , websockets - default-language: Haskell2010 - -executable forest-cabin - main-is: Main.hs - other-modules: - Paths_forest_cabin - hs-source-dirs: - app - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - base >=4.7 && <5 - , forest-cabin - , forest-common - , forest-server - , microlens - , microlens-th - , optparse-applicative - , stm - , websockets - default-language: Haskell2010 diff --git a/forest-cabin/package.yaml b/forest-cabin/package.yaml deleted file mode 100644 index 6e7ebe9..0000000 --- a/forest-cabin/package.yaml +++ /dev/null @@ -1,36 +0,0 @@ -name: forest-cabin -version: 0.1.0.0 -license: MIT -author: Garmelon -copyright: 2020 Garmelon - -synopsis: A forest server hosted at forest.plugh.de -description: Please see the README at -github: Garmelon/forest - -extra-source-files: - - README.md - -dependencies: - - base >= 4.7 && < 5 - - forest-common - - forest-server - - microlens - - microlens-th - - optparse-applicative - - stm - - websockets - -library: - source-dirs: src - -executables: - forest-cabin: - source-dirs: app - main: Main.hs - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - forest-cabin diff --git a/forest-common/README.md b/forest-common/README.md deleted file mode 100644 index 1f158f6..0000000 --- a/forest-common/README.md +++ /dev/null @@ -1 +0,0 @@ -# forest-common diff --git a/forest-common/forest-common.cabal b/forest-common/forest-common.cabal deleted file mode 100644 index 80b2f04..0000000 --- a/forest-common/forest-common.cabal +++ /dev/null @@ -1,45 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.31.2. --- --- see: https://github.com/sol/hpack --- --- hash: e59723e563cf364a74b1032409ed7a9d3ecbec3a6baa34554771cb5c1a5689d9 - -name: forest-common -version: 0.1.0.0 -synopsis: A tree-based multi-user interaction thing -description: Please see the README at -homepage: https://github.com/Garmelon/forest#readme -bug-reports: https://github.com/Garmelon/forest/issues -author: Garmelon -maintainer: Garmelon -copyright: 2020 Garmelon -license: MIT -build-type: Simple -extra-source-files: - README.md - -source-repository head - type: git - location: https://github.com/Garmelon/forest - -library - exposed-modules: - Forest.Api - Forest.Node - Forest.OrderedMap - Forest.Util - other-modules: - Paths_forest_common - hs-source-dirs: - src - build-depends: - aeson - , async - , base >=4.7 && <5 - , containers - , safe - , text - , websockets - default-language: Haskell2010 diff --git a/forest-common/package.yaml b/forest-common/package.yaml deleted file mode 100644 index b49c2d7..0000000 --- a/forest-common/package.yaml +++ /dev/null @@ -1,24 +0,0 @@ -name: forest-common -version: 0.1.0.0 -license: MIT -author: Garmelon -copyright: 2020 Garmelon - -synopsis: A tree-based multi-user interaction thing -description: Please see the README at -github: Garmelon/forest - -extra-source-files: - - README.md - -dependencies: - - base >= 4.7 && < 5 - - aeson - - async - - containers - - safe - - text - - websockets - -library: - source-dirs: src diff --git a/forest-server/README.md b/forest-server/README.md deleted file mode 100644 index b13ad16..0000000 --- a/forest-server/README.md +++ /dev/null @@ -1 +0,0 @@ -# forest-server diff --git a/forest-server/forest-server.cabal b/forest-server/forest-server.cabal deleted file mode 100644 index b581d18..0000000 --- a/forest-server/forest-server.cabal +++ /dev/null @@ -1,45 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.31.2. --- --- see: https://github.com/sol/hpack --- --- hash: c0d366de2ff27f13dd69d751b47017143df332454ad700dd8fb5089d9837f1a8 - -name: forest-server -version: 0.1.0.0 -synopsis: A framework for forest servers -description: Please see the README at -homepage: https://github.com/Garmelon/forest#readme -bug-reports: https://github.com/Garmelon/forest/issues -author: Garmelon -maintainer: Garmelon -copyright: 2020 Garmelon -license: MIT -build-type: Simple -extra-source-files: - README.md - -source-repository head - type: git - location: https://github.com/Garmelon/forest - -library - exposed-modules: - Forest.Server.Branch.SharedEdit - Forest.Server.Schema - Forest.Server.TreeApp - other-modules: - Paths_forest_server - hs-source-dirs: - src - build-depends: - base >=4.7 && <5 - , containers - , forest-common - , microlens - , stm - , text - , transformers - , websockets - default-language: Haskell2010 diff --git a/forest-server/package.yaml b/forest-server/package.yaml deleted file mode 100644 index f9395d9..0000000 --- a/forest-server/package.yaml +++ /dev/null @@ -1,25 +0,0 @@ -name: forest-server -version: 0.1.0.0 -license: MIT -author: Garmelon -copyright: 2020 Garmelon - -synopsis: A framework for forest servers -description: Please see the README at -github: Garmelon/forest - -extra-source-files: - - README.md - -dependencies: - - base >= 4.7 && < 5 - - containers - - forest-common - - microlens - - stm - - text - - transformers - - websockets - -library: - source-dirs: src diff --git a/forest-server/src/Forest/Server/Branch/SharedEdit.hs b/forest-server/src/Forest/Server/Branch/SharedEdit.hs deleted file mode 100644 index d7502fe..0000000 --- a/forest-server/src/Forest/Server/Branch/SharedEdit.hs +++ /dev/null @@ -1,80 +0,0 @@ -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 deleted file mode 100644 index e7856f8..0000000 --- a/forest-server/src/Forest/Server/Schema.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module Forest.Server.Schema - ( Schema - , fork - , fork' - , leaf - , collect - , collectWith - , dispatch - -- * Useful type - , Branch(..) - , schemaDraw - , schemaHandleEvent - , schemaLift - ) where - -import qualified Data.Text as T -import Lens.Micro - -import Forest.Node -import qualified Forest.OrderedMap as OMap -import Forest.Server.TreeApp - -data Schema a - = Fork T.Text (OMap.OrderedMap NodeId (Schema a)) - | Leaf a - -instance Functor Schema where - fmap f (Leaf a) = Leaf $ f a - fmap f (Fork text children) = Fork text $ fmap (fmap f) children - -fork :: T.Text -> [(NodeId, Schema a)] -> Schema a -fork text = Fork text . OMap.fromList - -fork' :: T.Text -> [Schema a] -> Schema a -fork' text = fork text . zip keys - where - keys :: [NodeId] - keys = map (T.pack . show) [0::Int ..] - -leaf :: a -> Schema a -leaf = Leaf - -collect :: Schema Node -> Node -collect (Leaf node) = node -collect (Fork text children) = Node text mempty $ OMap.map collect children - -collectWith :: (a -> Node) -> Schema a -> Node -collectWith f = collect . fmap f - -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 diff --git a/forest-server/src/Forest/Server/TreeApp.hs b/forest-server/src/Forest/Server/TreeApp.hs deleted file mode 100644 index a43e16d..0000000 --- a/forest-server/src/Forest/Server/TreeApp.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} --- | This module specifies a structure for forest server applications. It is --- based on the way Brick models applications. - -module Forest.Server.TreeApp - ( Next - , continue - , halt - , Event(..) - , TreeApp(..) - , simpleConstructor - , runTreeApp - ) where - -import Control.Concurrent.STM -import Control.Monad -import Data.Function -import qualified Data.Text as T -import qualified Network.WebSockets as WS - -import Forest.Api -import Forest.Node -import Forest.Util - -data Next a = Continue a | Halt - -continue :: a -> Next a -continue = Continue - -halt :: Next a -halt = Halt - -data Event e - = Edit Path T.Text - | Delete Path - | Reply Path T.Text - | Act Path - | Custom e - -data TreeApp s e = TreeApp - { appDraw :: s -> Node - , appHandleEvent :: s -> Event e -> IO (Next s) - , appConstructor :: forall a. (s -> Maybe (TChan e) -> IO a) -> IO a - } - -simpleConstructor :: s -> (s -> IO a) -> IO a -simpleConstructor = (&) - -{- The websocket app receiving and sending the packets -} - -packetToEvent :: ClientPacket -> Maybe (Event e) -packetToEvent (ClientEdit path text) = Just $ Edit path text -packetToEvent (ClientDelete path) = Just $ Delete path -packetToEvent (ClientReply path text) = Just $ Reply path text -packetToEvent (ClientAct path) = Just $ Act path -packetToEvent (ClientHello _) = Nothing - -receiveThread :: WS.Connection -> TChan (Event e) -> IO () -receiveThread conn chan = forever $ do - packet <- receivePacket conn - case packetToEvent packet of - -- We can wrap a 'forever' around all of this because closeWithErrorMessage - -- throws a runtime exception once the connection is closed. - Nothing -> closeWithErrorMessage conn "Invalid packet: Hello" - Just event -> atomically $ writeTChan chan event - -data RunState s e = RunState - { rsEventChan :: TChan (Event e) - , rsCustomEventChan :: Maybe (TChan e) - , rsState :: s - , rsNode :: Node - } - -readEvent :: RunState s e -> STM (Event e) -readEvent rs = case rsCustomEventChan rs of - Nothing -> readTChan ec - Just cec -> readTChan ec `orElse` (Custom <$> readTChan cec) - where - ec = rsEventChan rs - -sendNodeUpdate :: WS.Connection -> Node -> Node -> IO () -sendNodeUpdate conn nodeOld nodeNew = case diffNodes nodeOld nodeNew of - Nothing -> putStrLn "Sending no update because the node didn't change" - Just (path, updatedNode) -> do - putStrLn $ "Sending partial update at " ++ show path ++ ": " ++ show updatedNode - sendPacket conn $ ServerUpdate path updatedNode - -runUntilHalt :: WS.Connection -> TreeApp s e -> RunState s e -> IO () -runUntilHalt conn app rs = do - event <- atomically $ readEvent rs - next <- appHandleEvent app (rsState rs) event - case next of - Halt -> pure () - Continue state' -> do - let node' = appDraw app state' - sendNodeUpdate conn (rsNode rs) node' - runUntilHalt conn app rs{rsState = state', rsNode = node'} - -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 customChan -> do - firstPacket <- receivePacket conn - case firstPacket of - ClientHello _ -> do - let initialNode = appDraw app initialState - rs = RunState chan customChan initialState initialNode - sendPacket conn $ ServerHello [] initialNode - withThread (receiveThread conn chan) $ runUntilHalt conn app rs - _ -> closeWithErrorMessage conn "Invalid packet: Expected hello" diff --git a/forest-tui/README.md b/forest-tui/README.md deleted file mode 100644 index 244c893..0000000 --- a/forest-tui/README.md +++ /dev/null @@ -1 +0,0 @@ -# forest-tui diff --git a/forest-tui/app/Main.hs b/forest-tui/app/Main.hs deleted file mode 100644 index 4a11e56..0000000 --- a/forest-tui/app/Main.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Main where - -import Options.Applicative - -import Forest.Client -import Forest.Client.Options -import Forest.Client.Websocket - -main :: IO () -main = do - opts <- execParser clientOptionsParserInfo - runWithEventChan opts runClient diff --git a/forest-tui/forest-tui.cabal b/forest-tui/forest-tui.cabal deleted file mode 100644 index 5cae330..0000000 --- a/forest-tui/forest-tui.cabal +++ /dev/null @@ -1,74 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.31.2. --- --- see: https://github.com/sol/hpack --- --- hash: 9ca3a1fe555e2dceb3459b6ae920b1ed93aac76398d4909a7030d7992b79ce40 - -name: forest-tui -version: 0.1.0.0 -synopsis: A terminal-based client for forest -description: Please see the README at -homepage: https://github.com/Garmelon/forest#readme -bug-reports: https://github.com/Garmelon/forest/issues -author: Garmelon -maintainer: Garmelon -copyright: 2020 Garmelon -license: MIT -build-type: Simple -extra-source-files: - README.md - -source-repository head - type: git - location: https://github.com/Garmelon/forest - -library - exposed-modules: - Forest.Client - Forest.Client.NodeUtil - Forest.Client.Options - Forest.Client.UiState - Forest.Client.Websocket - Forest.Client.Widgets.NodeEditor - Forest.Client.Widgets.WidgetTree - other-modules: - Paths_forest_tui - hs-source-dirs: - src - build-depends: - base >=4.7 && <5 - , brick - , containers - , forest-common - , optparse-applicative - , safe - , text - , text-zipper - , vty - , websockets - , wuss - default-language: Haskell2010 - -executable forest - main-is: Main.hs - other-modules: - Paths_forest_tui - hs-source-dirs: - app - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - base >=4.7 && <5 - , brick - , containers - , forest-common - , forest-tui - , optparse-applicative - , safe - , text - , text-zipper - , vty - , websockets - , wuss - default-language: Haskell2010 diff --git a/forest-tui/package.yaml b/forest-tui/package.yaml deleted file mode 100644 index 12f71d9..0000000 --- a/forest-tui/package.yaml +++ /dev/null @@ -1,39 +0,0 @@ -name: forest-tui -version: 0.1.0.0 -license: MIT -author: Garmelon -copyright: 2020 Garmelon - -synopsis: A terminal-based client for forest -description: Please see the README at -github: Garmelon/forest - -extra-source-files: - - README.md - -dependencies: - - base >= 4.7 && < 5 - - brick - - containers - - forest-common - - optparse-applicative - - safe - - text - - text-zipper - - vty - - websockets - - wuss - -library: - source-dirs: src - -executables: - forest: - source-dirs: app - main: Main.hs - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - forest-tui diff --git a/forest-tui/src/Forest/Client.hs b/forest-tui/src/Forest/Client.hs deleted file mode 100644 index 8f7bacd..0000000 --- a/forest-tui/src/Forest/Client.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Client - ( ClientState - , newClientState - , runClient - ) where - -import Brick -import Brick.BChan -import Brick.Widgets.Edit -import Control.Monad -import Control.Monad.IO.Class -import qualified Graphics.Vty as Vty -import qualified Network.WebSockets as WS - -import Forest.Api -import Forest.Client.UiState -import Forest.Client.Websocket -import Forest.Client.Widgets.WidgetTree -import Forest.Node -import Forest.Util - -data ResourceName = RnViewport | RnEditor - deriving (Show, Eq, Ord) - -data ClientState = ClientState - { csUiState :: UiState ResourceName - , csConn :: WS.Connection - } - -newClientState :: WS.Connection -> Node -> ClientState -newClientState conn node = ClientState - { csUiState = newUiState RnEditor node - , csConn = conn - } - -{- Handling input events -} - -type ClientM a = EventM ResourceName a - -onUiState :: - ClientState - -> (UiState ResourceName -> UiState ResourceName) - -> ClientM (Next ClientState) -onUiState cs f = continue cs {csUiState = f $ csUiState cs} - -onUiState' :: - ClientState - -> (UiState ResourceName -> ClientM (UiState ResourceName)) - -> ClientM (Next ClientState) -onUiState' cs f = do - s' <- f $ csUiState cs - continue cs {csUiState = s'} - -{- ... without active editor -} - -deleteNode :: ClientState -> ClientM () -deleteNode cs = - when (flagDelete $ nodeFlags $ focusedNode s) $ - liftIO $ sendPacket (csConn cs) $ ClientDelete (focusedPath s) - where - s = csUiState cs - -actUponNode :: ClientState -> ClientM () -actUponNode cs = - when (flagAct $ nodeFlags $ focusedNode s) $ - liftIO $ sendPacket (csConn cs) $ ClientAct (focusedPath s) - where - s = csUiState cs - -onKeyWithoutEditor :: ClientState -> Vty.Event -> ClientM (Next ClientState) -onKeyWithoutEditor cs (Vty.EvKey k _) - | k `elem` [Vty.KChar 'q', Vty.KEsc] = halt cs - | k == Vty.KChar '\t' = onUiState cs toggleFoldAtFocus - | k `elem` [Vty.KChar 'k', Vty.KUp] = onUiState cs moveFocusUp - | k `elem` [Vty.KChar 'j', Vty.KDown] = onUiState cs moveFocusDown - | k `elem` [Vty.KChar 'K', Vty.KPageUp] = onUiState cs moveFocusToPrevSibling - | k `elem` [Vty.KChar 'J', Vty.KPageDown] = - onUiState cs moveFocusToNextSibling - | k `elem` [Vty.KChar 'h', Vty.KLeft] = onUiState cs moveFocusToParent - | k `elem` [Vty.KChar 'g', Vty.KHome] = onUiState cs moveFocusToTop - | k `elem` [Vty.KChar 'G', Vty.KEnd] = onUiState cs moveFocusToBottom - | k == Vty.KChar 'e' = onUiState cs editCurrentNode - | k == Vty.KChar 'r' = onUiState cs (replyToCurrentNode . unfoldAtFocus) - | k == Vty.KChar 'R' = onUiState cs replyAfterCurrentNode - | k `elem` [Vty.KChar 'd', Vty.KChar 'x', Vty.KDel, Vty.KBS] = - deleteNode cs *> continue cs - | k `elem` [Vty.KChar 'a', Vty.KChar ' ', Vty.KEnter] = - actUponNode cs *> continue cs -onKeyWithoutEditor cs _ = continue cs - -{- ... with active editor -} - -editResultToPacket :: EditResult -> ClientPacket -editResultToPacket result - | erReply result = ClientReply (erPath result) (erText result) - | otherwise = ClientEdit (erPath result) (erText result) - -onKeyWithEditor :: ClientState -> Vty.Event -> ClientM (Next ClientState) --- Finish editing normally -onKeyWithEditor cs (Vty.EvKey Vty.KEnter _) = do - let (s', maybeResult) = finishEditing $ csUiState cs - forM_ maybeResult $ liftIO . sendPacket (csConn cs) . editResultToPacket - continue cs {csUiState = s'} --- Abort editing with Escape -onKeyWithEditor cs (Vty.EvKey Vty.KEsc _) = onUiState cs abortEditing --- Insert a newline on C-n -onKeyWithEditor cs (Vty.EvKey (Vty.KChar 'n') m) - | Vty.MCtrl `elem` m = onUiState' cs $ updateEditor $ Vty.EvKey Vty.KEnter [] --- Forward all other events as usual -onKeyWithEditor cs ev = onUiState' cs $ updateEditor ev - -{- And the rest of the Brick application -} - -clientDraw :: ClientState -> [Widget ResourceName] -clientDraw cs = [padTopBottom 1 $ padLeftRight 2 vp] - where - tree = renderUiState boxDrawingBranching $ csUiState cs - vp = viewport RnViewport Vertical tree - -clientHandleEvent :: - ClientState -> BrickEvent ResourceName Event -> ClientM (Next ClientState) -clientHandleEvent cs (VtyEvent ev) - | isEditorActive (csUiState cs) = onKeyWithEditor cs ev - | otherwise = onKeyWithoutEditor cs ev -clientHandleEvent cs (AppEvent ev) = case ev of - EventNode node -> onUiState cs $ replaceRootNode node - EventConnectionClosed -> halt cs -clientHandleEvent cs _ = continue cs - -clientAttrMap :: AttrMap -clientAttrMap = attrMap Vty.defAttr - [ ("expand", Vty.defAttr `Vty.withStyle` Vty.bold `Vty.withForeColor` Vty.yellow) - , ("focus", Vty.defAttr `Vty.withBackColor` Vty.blue) - , ("flags", Vty.defAttr `Vty.withForeColor` Vty.brightBlack) - , (treeLineAttr, Vty.defAttr `Vty.withForeColor` Vty.brightBlack) - , (editAttr, Vty.defAttr `Vty.withBackColor` Vty.brightBlack) - ] - -clientApp :: App ClientState Event ResourceName -clientApp = App - { appDraw = clientDraw - , appChooseCursor = showFirstCursor - , appHandleEvent = clientHandleEvent - , appStartEvent = pure - , appAttrMap = const clientAttrMap - } - -runClient :: WS.Connection -> BChan Event -> Node -> IO () -runClient conn chan node = do - putStrLn "Starting UI" - let clientState = newClientState conn node - vtyBuilder = Vty.mkVty Vty.defaultConfig - initialVty <- vtyBuilder - void $ customMain initialVty vtyBuilder (Just chan) clientApp clientState diff --git a/forest-tui/src/Forest/Client/NodeUtil.hs b/forest-tui/src/Forest/Client/NodeUtil.hs deleted file mode 100644 index 3712e83..0000000 --- a/forest-tui/src/Forest/Client/NodeUtil.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Forest.Client.NodeUtil - ( Unfolded - , foldVisibleNodes - , applyFolds - , findPrevNode - , findNextNode - ) where - -import Data.Maybe -import qualified Data.Set as Set - -import Forest.Node -import qualified Forest.OrderedMap as OMap -import Forest.Util - -type Unfolded = Set.Set Path - -foldVisibleNodes' :: Path -> (Path -> Node -> Maybe [a] -> a) -> Unfolded -> Node -> a -foldVisibleNodes' path f unfolded node - | childrenVisible = f path node $ Just mappedChildren - | otherwise = f path node Nothing - where - childrenVisible = mempty `Set.member` unfolded - mappedChildren = map (uncurry goDeeper) $ OMap.toList $ nodeChildren node - goDeeper nid = foldVisibleNodes' (path <> Path [nid]) f (narrowSet nid unfolded) - --- | The word "fold" in the name of this function is meant as in 'foldr'. This --- function folds a tree of nodes while respecting which nodes should be visible --- according to the 'Unfolded' set. -foldVisibleNodes :: (Path -> Node -> Maybe [a] -> a) -> Unfolded -> Node -> a -foldVisibleNodes = foldVisibleNodes' mempty - --- | Keep only those nodes that are visible according to the 'Unfolded' set. -applyFolds :: Unfolded -> Node -> Node -applyFolds unfolded node - | mempty `Set.member` unfolded = node {nodeChildren = children} - | otherwise = node {nodeChildren = OMap.empty} - where - children = - OMap.mapWithKey (\nid -> applyFolds $ narrowSet nid unfolded) $ - nodeChildren node - -findPrevNode :: Node -> Path -> Path -findPrevNode node path = fromMaybe path $ findPrev (==path) $ flatten node - -findNextNode :: Node -> Path -> Path -findNextNode node path = fromMaybe path $ findNext (==path) $ flatten node diff --git a/forest-tui/src/Forest/Client/Options.hs b/forest-tui/src/Forest/Client/Options.hs deleted file mode 100644 index ead27bf..0000000 --- a/forest-tui/src/Forest/Client/Options.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Forest.Client.Options - ( ClientOptions(..) - , clientOptionsParserInfo - ) where - -import Data.List -import Options.Applicative -import Options.Applicative.Help.Pretty - -data ClientOptions = ClientOptions - { clientHostName :: String - , clientPort :: Int - , clientPath :: String - , clientSsl :: Bool - } - -parser :: Parser ClientOptions -parser = ClientOptions - <$> strArgument - ( help "The name of the host to connect to" - <> metavar "HOST" - ) - <*> option auto - ( short 'p' - <> long "port" - <> help "The port to connect to" - <> value 11133 -- Chosen by fair dice roll - <> showDefault - <> metavar "PORT" - ) - <*> strOption - ( short 'P' - <> long "path" - <> help "The path to connect to on the given domain" - <> value "" - <> showDefault - <> metavar "PATH" - ) - <*> flag True False -- Ssl enabled by default - ( short 'n' - <> long "no-ssl" - <> help "This flag disables ssl on outgoing websocket connections" - ) - -keyBindings :: String -keyBindings = intercalate "\n" - [ "Key bindings:" - , " exit q, esc" - , " move cursor up/down, j/k" - , " toggle fold tab" - , " edit node e" - , " delete node d" - , " new child (reply) r" - , " new sibling R" - , " perform action a, enter, space" - , "" - , "Editor key bindings:" - , " confirm edit enter" - , " abort edit esc" - , " insert newline ctrl+n" - ] - -clientOptionsParserInfo :: ParserInfo ClientOptions -clientOptionsParserInfo = info (helper <*> parser) - ( fullDesc - <> footerDoc (Just $ string keyBindings) - ) diff --git a/forest-tui/src/Forest/Client/UiState.hs b/forest-tui/src/Forest/Client/UiState.hs deleted file mode 100644 index 2f4ac86..0000000 --- a/forest-tui/src/Forest/Client/UiState.hs +++ /dev/null @@ -1,292 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Client.UiState - ( UiState - , newUiState - , focusedPath - , focusedNode - -- * Modifying the UI state - , replaceRootNode - , moveFocusUp - , moveFocusDown - , moveFocusToParent - , moveFocusToPrevSibling - , moveFocusToNextSibling - , moveFocusToTop - , moveFocusToBottom - , foldAtFocus - , unfoldAtFocus - , toggleFoldAtFocus - -- ** The node editor - -- *** Creating - , editCurrentNode - , replyToCurrentNode - , replyAfterCurrentNode - -- *** Updating - , isEditorActive - , updateEditor - -- *** Finishing the edit - , EditResult(..) - , finishEditing - , abortEditing - -- * Rendering the UI state - , renderUiState - ) where - -import Brick -import Control.Monad -import Data.List -import Data.Maybe -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Graphics.Vty as Vty - -import Forest.Client.NodeUtil -import Forest.Client.Widgets.NodeEditor -import Forest.Client.Widgets.WidgetTree -import Forest.Node -import qualified Forest.OrderedMap as OMap - -data EditorInfo n = EditorInfo - { eiEditor :: !(NodeEditor n) - , eiPath :: !Path - , eiReply :: !Bool - } deriving (Show) - -data UiState n = UiState - { uiRootNode :: !Node - , uiFocused :: !Path - , uiUnfolded :: !Unfolded - , uiEditor :: !(Maybe (EditorInfo n)) - , uiEditorName :: !n - } deriving (Show) - -newUiState :: n -> Node -> UiState n -newUiState editorName node = UiState - { uiRootNode = node - , uiFocused = mempty - , uiUnfolded = mempty - , uiEditor = Nothing - , uiEditorName = editorName - } - -focusedPath :: UiState n -> Path -focusedPath = uiFocused - -focusedNode :: UiState n -> Node -focusedNode s = fromMaybe rootNode $ applyPath rootNode $ uiFocused s - where - rootNode = uiRootNode s - -foldedRootNode :: UiState n -> Node -foldedRootNode s = applyFolds (uiUnfolded s) (uiRootNode s) - -{- Modifying -} - --- | Only keep those unfolded nodes that actually exist. -validateUnfolded :: UiState n -> UiState n -validateUnfolded s = - s {uiUnfolded = Set.filter (referencedNodeExists $ uiRootNode s) (uiUnfolded s)} - --- | Try to find the closest parent to a 'Path' that exists in the 'Node'. -findValidParent :: Node -> Path -> Path -findValidParent _ (Path []) = Path [] -findValidParent node (Path (x:xs)) = case applyId node x of - Nothing -> Path [] - Just child -> Path [x] <> findValidParent child (Path xs) - --- | Move to the closest valid parent as a last-ditch effort if the current --- focus path is invalid. -validateFocused :: UiState n -> UiState n -validateFocused s = - s {uiFocused = findValidParent (foldedRootNode s) (uiFocused s)} - --- | Close the editor if it doesn't point to a valid path. -validateEditor :: UiState n -> UiState n -validateEditor s = fromMaybe s{uiEditor = Nothing} $ do - e <- uiEditor s - node <- applyPath (uiRootNode s) (eiPath e) - let flags = nodeFlags node - guard $ if eiReply e then flagReply flags else flagEdit flags - pure s - --- | Modify the UI state so it is consistent again. -validate :: UiState n -> UiState n -validate = validateEditor . validateFocused . validateUnfolded - --- | Find a node that is close to the previously focused node, taking into --- account its previous position in the tree. -findNextValidNode :: Node -> Node -> Path -> Path -findNextValidNode _ _ (Path []) = Path [] -findNextValidNode from to (Path (x:xs)) = fromMaybe (Path []) $ do - fromNode <- applyId from x - case applyId to x of - Just toNode -> pure $ Path [x] <> findNextValidNode fromNode toNode (Path xs) - Nothing -> do - fromIdx <- elemIndex x $ OMap.keys $ nodeChildren from - let toKeys = OMap.keys $ nodeChildren to - x' <- getValueClosestToIndex fromIdx toKeys - pure $ Path [x'] - where - -- Slightly unsafe code, but it should be fine - getValueClosestToIndex idx list - | length list > idx = Just $ list !! idx - | null list = Nothing - | otherwise = Just $ last list - -replaceRootNode :: Node -> UiState n -> UiState n -replaceRootNode node s = validate s - { uiRootNode = node - , uiFocused = findNextValidNode (uiRootNode s) node (uiFocused s) - } - -moveFocus :: (Node -> Path -> Maybe Path) -> UiState n -> UiState n -moveFocus f s = fromMaybe s $ do - newFocus <- f (foldedRootNode s) (uiFocused s) - pure $ validateFocused s{uiFocused = newFocus} - -moveFocusUp :: UiState n -> UiState n -moveFocusUp = moveFocus prevNode - -moveFocusDown :: UiState n -> UiState n -moveFocusDown = moveFocus nextNode - -moveFocusToPrevSibling :: UiState n -> UiState n -moveFocusToPrevSibling = moveFocus prevSibling - -moveFocusToNextSibling :: UiState n -> UiState n -moveFocusToNextSibling = moveFocus nextSibling - -moveFocusToParent :: UiState n -> UiState n -moveFocusToParent = moveFocus $ const parent - -moveFocusToTop :: UiState n -> UiState n -moveFocusToTop = moveFocus firstNode - -moveFocusToBottom :: UiState n -> UiState n -moveFocusToBottom = moveFocus lastNode - -foldAtFocus :: UiState n -> UiState n -foldAtFocus s = - validateUnfolded s{uiUnfolded = Set.delete (uiFocused s) (uiUnfolded s)} - -unfoldAtFocus :: UiState n -> UiState n -unfoldAtFocus s = - validateUnfolded s{uiUnfolded = Set.insert (uiFocused s) (uiUnfolded s)} - -toggleFoldAtFocus :: UiState n -> UiState n -toggleFoldAtFocus s = if uiFocused s `Set.member` uiUnfolded s - then foldAtFocus s - else unfoldAtFocus s - -editNode :: Bool -> Path -> UiState n -> UiState n -editNode reply path s = - let text = if reply then "" else nodeText $ focusedNode s - editorInfo = EditorInfo - { eiEditor = beginEdit (uiEditorName s) text - , eiPath = path - , eiReply = reply - } - in validateEditor s{uiEditor = Just editorInfo} - --- | Begin editing the currently focused node. Discards any current editor --- status. -editCurrentNode :: UiState n -> UiState n -editCurrentNode s = editNode False (uiFocused s) s - --- | Reply to the currently focused node. Discards any current editor status. -replyToCurrentNode :: UiState n -> UiState n -replyToCurrentNode s = editNode True (uiFocused s) s - --- | Reply in parallel to the currently focused node, unless it is the root node --- (in which case no action is taken). -replyAfterCurrentNode :: UiState n -> UiState n -replyAfterCurrentNode s = case parent $ uiFocused s of - Nothing -> s - Just path -> editNode True path s - -isEditorActive :: UiState n -> Bool -isEditorActive = isJust . uiEditor - -updateEditor :: Vty.Event -> UiState n -> EventM n (UiState n) -updateEditor ev s = case uiEditor s of - Nothing -> pure s - Just e -> do - newEditor <- handleNodeEditorEvent ev $ eiEditor e - pure s {uiEditor = Just e {eiEditor = newEditor}} - -data EditResult = EditResult - { erText :: T.Text - , erPath :: Path - , erReply :: Bool - } deriving (Show) - -finishEditing :: UiState n -> (UiState n, Maybe EditResult) -finishEditing s = fromMaybe (s, Nothing) $ do - e <- uiEditor s - let editResult = EditResult - { erText = getCurrentText $ eiEditor e - , erPath = eiPath e - , erReply = eiReply e - } - pure (abortEditing s, Just editResult) - -abortEditing :: UiState n -> UiState n -abortEditing s = s{uiEditor = Nothing} - -{- Rendering -} - -decorateExpand :: Bool -> Widget n -> Widget n -decorateExpand True = withDefAttr "expand" -decorateExpand False = id - -decorateFocus :: Bool -> Widget n -> Widget n -decorateFocus True = withDefAttr "focus" -decorateFocus False = id - -decorateFlags :: NodeFlags -> Widget n -> Widget n -decorateFlags node widget = - let e = if flagEdit node then "e" else "-" - d = if flagDelete node then "d" else "-" - r = if flagReply node then "r" else "-" - a = if flagAct node then "a" else "-" - flags = "(" <> e <> d <> r <> a <> ")" - in widget <+> txt " " <+> withDefAttr "flags" (txt flags) - -renderNode :: Bool -> Node -> Widget n -renderNode focused node = - decorateFlags (nodeFlags node) $ - decorateFocus focused $ - decorateExpand (hasChildren node) $ - padRight Max text - where - -- The height of the text widget must be at least 1 for 'padRight Max' to - -- expand it. As far as I know, if the text has at least one character, it - -- also has a height of at least 1, but if it has no characters, its height - -- is 0. Because of that, we insert a filler space if the text is empty. - text - | T.null $ nodeText node = txt " " - | otherwise = txtWrap $ nodeText node - -nodeToTree - :: (Ord n, Show n) - => UiState n - -> Path - -> Node - -> Maybe [WidgetTree n] - -> WidgetTree n -nodeToTree s path node maybeChildren = case uiEditor s of - Just e | path == eiPath e -> - let renderedEditor = renderNodeEditor $ eiEditor e - in if eiReply e - then WidgetTree renderedNode $ children ++ [WidgetTree renderedEditor []] - else WidgetTree renderedEditor children - _ -> WidgetTree (visible renderedNode) children - where - renderedNode = renderNode (path == uiFocused s) node - children = fromMaybe [] maybeChildren - -renderUiState :: (Ord n, Show n) => IndentOptions -> UiState n -> Widget n -renderUiState opts s = - renderWidgetTree opts $ - foldVisibleNodes (nodeToTree s) (uiUnfolded s) (uiRootNode s) diff --git a/forest-tui/src/Forest/Client/Websocket.hs b/forest-tui/src/Forest/Client/Websocket.hs deleted file mode 100644 index 2b9d703..0000000 --- a/forest-tui/src/Forest/Client/Websocket.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Client.Websocket - ( Event(..) - , runWithEventChan - ) where - -import Brick.BChan -import Control.Exception -import qualified Network.WebSockets as WS -import qualified Wuss as WSS - -import Forest.Api -import Forest.Client.Options -import Forest.Node -import Forest.Util - -data Event - = EventNode Node - | EventConnectionClosed - -performInitialContact :: WS.Connection -> IO Node -performInitialContact conn = do - -- First, the client must send a hello packet containing the protocol - -- extensions it requests. - sendPacket conn $ ClientHello [] - -- Then, the server must reply with a hello packet containing the extensions - -- that will be active for this connection, and an initial node. - serverReply <- receivePacket conn - case serverReply of - (ServerHello [] node) -> pure node - -- Since the client never requests any protocol extensions, the server must - -- also reply with an empty list of extensions. - (ServerHello _ _) -> closeWithErrorMessage conn "Invalid protocol extensions" - _ -> closeWithErrorMessage conn "Invalid packet: Expected hello" - -receiveUpdates :: BChan Event -> Node -> WS.Connection -> IO () -receiveUpdates eventChan node conn = do - packet <- receivePacket conn - case packet of - ServerUpdate path subnode -> do - let node' = replaceAt subnode path node - writeBChan eventChan $ EventNode node' - receiveUpdates eventChan node' conn -- Aaand close the loop :D - _ -> closeWithErrorMessage conn "Invalid packet: Expected update" - -runCorrectClient :: ClientOptions -> WS.ClientApp a -> IO a -runCorrectClient opts app - | ssl = WSS.runSecureClient name (fromInteger $ toInteger port) path app - | otherwise = WS.runClient name port path app - where - -- I found this nicer to read than (ab-)using record syntax in the arguments - name = clientHostName opts - port = clientPort opts - path = clientPath opts - ssl = clientSsl opts - -sendCloseEvent :: BChan Event -> SomeException -> IO () -sendCloseEvent eventChan e = do - putStrLn $ "Encountered exception: " ++ show e - writeBChan eventChan EventConnectionClosed - -runWithEventChan :: ClientOptions -> (WS.Connection -> BChan Event -> Node -> IO ()) -> IO () -runWithEventChan opts f = do - putStrLn "Connecting to server" - runCorrectClient opts $ \conn -> do - putStrLn "Performing initialization ritual" - node <- performInitialContact conn - chan <- newBChan 100 - putStrLn "Starting WS thread" - let wsThread = handle (sendCloseEvent chan) $ receiveUpdates chan node conn - withThread wsThread $ f conn chan node - putStrLn "Connection closed and UI stopped" diff --git a/forest-tui/src/Forest/Client/Widgets/NodeEditor.hs b/forest-tui/src/Forest/Client/Widgets/NodeEditor.hs deleted file mode 100644 index 51e8e86..0000000 --- a/forest-tui/src/Forest/Client/Widgets/NodeEditor.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Client.Widgets.NodeEditor - ( NodeEditor - , getCurrentText - , beginEdit - , handleNodeEditorEvent - , renderNodeEditor - ) where - -import Brick -import Brick.Widgets.Edit -import qualified Data.Text as T -import Data.Text.Zipper -import qualified Graphics.Vty as Vty - -newtype NodeEditor n = NodeEditor (Editor T.Text n) - deriving (Show) - -getCurrentLines :: NodeEditor n -> [T.Text] -getCurrentLines (NodeEditor e) = getEditContents e - -getCurrentText :: NodeEditor n -> T.Text -getCurrentText = T.intercalate "\n" . getCurrentLines - -beginEdit :: n -> T.Text -> NodeEditor n -beginEdit name = NodeEditor . applyEdit gotoEOL . editorText name Nothing - -edit :: (TextZipper T.Text -> TextZipper T.Text) -> NodeEditor n -> EventM n (NodeEditor n) -edit z (NodeEditor e) = pure $ NodeEditor $ applyEdit z e - -handleNodeEditorEvent :: Vty.Event -> NodeEditor n -> EventM n (NodeEditor n) -handleNodeEditorEvent (Vty.EvKey Vty.KHome _) ne = edit gotoBOL ne -handleNodeEditorEvent (Vty.EvKey Vty.KEnd _) ne = edit gotoEOL ne -handleNodeEditorEvent event (NodeEditor e) = NodeEditor <$> handleEditorEvent event e - -renderLines :: [T.Text] -> Widget n -renderLines = vBox . map (\t -> txt $ if T.null t then " " else t) - -renderNodeEditor :: (Ord n, Show n) => NodeEditor n -> Widget n -renderNodeEditor ne@(NodeEditor e) = - makeVisible $ vLimit height $ renderEditor renderLines True e - where - height = length $ getCurrentLines ne - (row, col) = cursorPosition $ editContents e - makeVisible = visibleRegion (Location (col, row)) (1, 1) diff --git a/forest-tui/src/Forest/Client/Widgets/WidgetTree.hs b/forest-tui/src/Forest/Client/Widgets/WidgetTree.hs deleted file mode 100644 index 17cd0ce..0000000 --- a/forest-tui/src/Forest/Client/Widgets/WidgetTree.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Client.Widgets.WidgetTree - ( WidgetTree(..) - , renderWidgetTreeWith - , renderWidgetTree - , treeLineAttr - , IndentOptions(..) - , boxDrawingBranching - , boxDrawingLine - , asciiBranching - , asciiLine - ) where - -import Brick -import qualified Data.Text as T -import qualified Graphics.Vty as Vty - -data WidgetTree n = WidgetTree (Widget n) [WidgetTree n] - -indentWith :: AttrName -> T.Text -> T.Text -> Widget n -> Widget n --- The "left" variables are for rendering the indentation text, the "right" --- variables are for the rendered wrapped widget. -indentWith indentAttrName firstLine otherLines wrapped = - Widget (hSize wrapped) (vSize wrapped) $ do - let leftWidth = max (T.length firstLine) (T.length otherLines) - context <- getContext - rightResult <- render $ hLimit (availWidth context - leftWidth) wrapped - let rightImage = image rightResult - -- Construct the Vty image containing the indentation text - height = Vty.imageHeight rightImage - leftLines = firstLine : replicate (height - 1) otherLines - leftAttribute = attrMapLookup indentAttrName $ ctxAttrMap context - leftImage = Vty.vertCat $ map (Vty.text' leftAttribute) leftLines - -- Add the indentation text to the left of the result image - combinedImage = leftImage Vty.<|> image rightResult - offset = Location (leftWidth, 0) - result = (addResultOffset offset rightResult) {image=combinedImage} - pure result - -indent :: AttrName -> IndentOptions -> [Widget n] -> Widget n -indent indentAttrName opts widgets = vBox $ reverse $ case reverse widgets of - [] -> [] - (w:ws) -> - indentWith indentAttrName (indentLastNodeFirstLine opts) (indentLastNodeRest opts) w : - map (indentWith indentAttrName (indentNodeFirstLine opts) (indentNodeRest opts)) ws - -renderWidgetTreeWith :: AttrName -> IndentOptions -> WidgetTree n -> Widget n -renderWidgetTreeWith indentAttrName opts (WidgetTree node children) = - node <=> indent indentAttrName opts (map (renderWidgetTreeWith indentAttrName opts) children) - -renderWidgetTree :: IndentOptions -> WidgetTree n -> Widget n -renderWidgetTree = renderWidgetTreeWith treeLineAttr - --- | The attribute that 'renderWidgetTree' uses. -treeLineAttr :: AttrName -treeLineAttr = "treeLine" - --- | These options control how a tree is rendered. --- --- In the following example, the indent options are set to @'IndentOptions' "a" "b" "c" "d"@: --- --- > a This is the first node. --- > b c It has a child. --- > a This is a... --- > b multiline... --- > b node. --- > c This is the last node. --- > d c It has one child. --- > d c And another one. --- --- Warning: The options /must/ be single line strings and /must not/ contain --- newlines of any sort. -data IndentOptions = IndentOptions - { indentNodeFirstLine :: T.Text - -- ^ This is prepended to the first line of a node. - , indentNodeRest :: T.Text - -- ^ This is prepended to all other lines of a node, including its subnodes. - , indentLastNodeFirstLine :: T.Text - -- ^ This is prepended to the first line of the last node. - , indentLastNodeRest :: T.Text - -- ^ This is prepended to all other lines of the last node, including its subnodes. - } deriving (Show, Eq) - -boxDrawingBranching :: IndentOptions -boxDrawingBranching = IndentOptions - { indentNodeFirstLine = "├╴" - , indentNodeRest = "│ " - , indentLastNodeFirstLine = "└╴" - , indentLastNodeRest = " " - } - -boxDrawingLine :: IndentOptions -boxDrawingLine = IndentOptions - { indentNodeFirstLine = "│ " - , indentNodeRest = "│ " - , indentLastNodeFirstLine = "│ " - , indentLastNodeRest = "│ " - } - -asciiBranching :: IndentOptions -asciiBranching = IndentOptions - { indentNodeFirstLine = "+-" - , indentNodeRest = "| " - , indentLastNodeFirstLine = "+-" - , indentLastNodeRest = " " - } - -asciiLine :: IndentOptions -asciiLine = IndentOptions - { indentNodeFirstLine = "| " - , indentNodeRest = "| " - , indentLastNodeFirstLine = "| " - , indentLastNodeRest = "| " - } diff --git a/forest-web/about.html b/forest-web/about.html deleted file mode 100644 index 704d4f0..0000000 --- a/forest-web/about.html +++ /dev/null @@ -1,67 +0,0 @@ - - - - - Forest - About - - - -
- -

Forest

-

Description

-

- Forest is a project based around interacting with trees of - plain-text nodes. It has an API that is intentionally kept - simple. Writing your own clients or bots is explicitly - encouraged! -

-

- At the moment, there are a server and a terminal-based client - written in haskell, and the web-based client you're using right - now, made with (vanilla) javascript. The web-based client is - heavily based on the terminal-based client, both in look and - behaviour. The color scheme is just my terminal's current color - scheme. -

- -

Code and docs

-
    -
  1. Server and terminal-based client
    2. -
  2. Web-based client (coming soon)
    3. -
  3. API documentation
    4. -
- -

Usage

-

Controls

- 
-tab           - fold/unfold current node
-arrow keys/jk - move cursor
-
-

Permissions

-

- A node's permissions are displayed at the right side of the - screen, like this: - (edra). - If a permission is set, its character is displayed. Otherwise, a - dash is displayed in its place. Only when a permission is set - can its action be performed. -

- 
-e (edit)   - edit a node's text
-d (delete) - delete a node
-r (reply)  - reply to a node
-a (act)    - perform a node-specific action
-
-

Colors

-

- The cursor position is marked by a - blue background. - If a node is colored - yellow, - it has child nodes. -

- -
- - diff --git a/forest-web/init.html b/forest-web/init.html deleted file mode 100644 index 1cde6ea..0000000 --- a/forest-web/init.html +++ /dev/null @@ -1,39 +0,0 @@ - - - - - Forest - - - - - - - - -
-
-
- Please enable javascript. - (----) -
-
-
-
- -
- -
-
- - -
-
-
- -
- About -
- - - diff --git a/forest-web/main.css b/forest-web/main.css deleted file mode 100644 index dd992a8..0000000 --- a/forest-web/main.css +++ /dev/null @@ -1,76 +0,0 @@ -html { - /* My terminal's color scheme */ - --background: #000000; - --foreground: #babdb6; - --black: #2e3436; - --bright-black: #555753; - --red: #cc0000; - --bright-red: #ef2929; - --green: #4e9a06; - --bright-green: #8ae234; - --yellow: #c4a000; - --bright-yellow: #fce94f; - --blue: #3465a4; - --bright-blue: #729fcf; - --magenta: #75507b; - --bright-magenta: #ad7fa8; - --cyan: #06989a; - --bright-cyan: #34e2e2; - --white: #d3d7cf; - --bright-white: #eeeeec; - - font-family: monospace; - font-size: 16px; - color: var(--foreground); - background-color: var(--background); -} -body { - max-width: 1024px; - margin: 0 auto; - padding: 2em; -} -h1, h2, h3, h4, h5, h6 { - color: var(--white); - margin-top: 1.5em; -} -h1 { - margin-top: 0; - font-size: 2em; -} -h2 { - text-decoration: underline; -} -a { - color: var(--bright-blue); -} -a:visited { - color: var(--bright-magenta); -} -/* Input elements */ -input[type="checkbox"] { - display: none; -} -input[type="checkbox"] + label::before { - content: "[_] "; - font-weight: bold; -} -input[type="checkbox"]:checked + label::before { - content: "[X] "; -} -button, textarea { - font-family: inherit; - font-size: inherit; - color: inherit; - background-color: inherit; - margin: 0; - padding: 0; - border: none; - outline: none; -} -button { - font-weight: bold; -} -textarea { - color: var(--foreground); - background-color: var(--bright-black); -} diff --git a/forest-web/node.css b/forest-web/node.css deleted file mode 100644 index 7fdefee..0000000 --- a/forest-web/node.css +++ /dev/null @@ -1,71 +0,0 @@ -.node-line { - display: flex; -} -.node-text { - flex-grow: 1; -} -.node-permissions { - color: var(--bright-black); - margin-left: 1ch; -} -.node textarea { - width: 100%; - resize: none; -} - -/* Special display states a node can be in */ -.has-children > .node-line > .node-text { - font-weight: bold; - color: var(--yellow); -} -.has-cursor > .node-line > .node-text { - background-color: var(--blue); -} -.has-editor > .node-line { - display: none; -} -.is-folded > .node-children { - display: none; -} - -/* Fancy tree lines */ -.node-children > *, .node-children > *::before { - border-color: var(--bright-black); - border-width: 2px; -} -.node-children > * { - position: relative; /* .node is containing block for its .node::before */ - margin-left: calc(0.5ch - 1px); - padding-left: calc(1.5ch - 1px); - border-left-style: solid; -} -.node-children > *:last-child { - padding-left: calc(1.5ch + 1px); - border-left-style: none; -} -.node-children > *::before { - content: ""; - position: absolute; - left: 0; - top: 0; - width: calc(1ch - 1px); - height: calc(0.6em - 1px); - border-bottom-style: solid; -} -.node-children > *:last-child::before { - border-left-style: solid; - transition: border-bottom-left-radius 0.4s; -} - -/* Curvy lines */ -.curvy .node-children > *:last-child, .curvy .node-children > *:last-child::before { - border-bottom-left-radius: 6px; -} - -/* About link in bottom right corner */ -#about { - position: fixed; - bottom: 0; - right: 0; - margin: 1ch; -} diff --git a/forest-web/node.js b/forest-web/node.js deleted file mode 100644 index b276399..0000000 --- a/forest-web/node.js +++ /dev/null @@ -1,684 +0,0 @@ -"use strict"; - -/* - * Utility functions - */ - -function removeAllChildren(element) { - while (element.firstChild) { - element.removeChild(element.lastChild); - } -} - -// Create a new DOM element. -// 'classes' can either be a string or a list of strings. -// A child can either be a string or a DOM element. -function newElement(type, classes, ...children) { - let e = document.createElement(type); - - if (classes !== undefined) { - if (typeof classes == "string") { - e.classList.add(classes); - } else if (classes instanceof Array) { - e.classList.add(...classes); - } - } - - children.forEach(child => { - if (typeof child == "string") { - e.appendChild(document.createTextNode(child)); - } else { - e.appendChild(child); - } - }); - - return e; -} - -/* - * Classes - */ - -// Enum representing useful positions relative to a node. -const RelPos = Object.freeze({ - FIRST_CHILD: 1, - NEXT_SIBLING: 2, -}); - -class Path { - constructor(...components) { - this._components = components.slice(); - } - - get components() { - return this._components.slice(); - } - - get length() { - return this._components.length; - } - - get last() { - return this._components[this.length - 1]; - } - - get parent() { - if (this.length === 0) return undefined; - return new Path(...this._components.slice(0, this.length - 1)); - } - - append(nodeId) { - return new Path(...this._components.concat([nodeId])); - } - - concat(otherPath) { - return new Path(...this._components.concat(otherPath._components)); - } -} - -class NodeElements { - constructor() { - this._elText = newElement("span", "node-text"); - this._elPermissions = newElement("span", "node-permissions"); - this._elChildren = newElement("div", "node-children"); - - let line = newElement("div", "node-line", this._elText, this._elPermissions); - this._elMain = newElement("div", ["node", "is-folded"], line, this._elChildren); - } - - get text() { - return this._elText.textContent; - } - - set text(text) { - this._elText.textContent = text; - } - - set permissions(perms) { - this._elPermissions.textContent = perms.asText; - } - - get hasChildren() { - return this._elMain.classList.contains("has-children"); - } - - set hasChildren(flag) { - return this._elMain.classList.toggle("has-children", flag); - } - - removeAllChildren() { - removeAllChildren(this._elChildren); - } - - addChild(child) { - this._elChildren.appendChild(child._elMain); - } - - appendTo(element) { - element.appendChild(this._elMain); - } - - get folded() { - return this._elMain.classList.contains("is-folded"); - } - - set folded(flag) { - this._elMain.classList.toggle("is-folded", flag); - } - - toggleFolded() { - this.folded = !this.folded; - } - - get hasCursor() { - return this._elMain.classList.contains("has-cursor"); - } - - set hasCursor(flag) { - return this._elMain.classList.toggle("has-cursor", flag); - } - - get hasEditor() { - return this._elMain.classList.contains("has-editor"); - } - - set hasEditor(flag) { - return this._elMain.classList.toggle("has-editor", flag); - } -} - -class NodePermissions { - constructor(edit, delete_, reply, act) { - this._edit = edit; - this._delete = delete_; - this._reply = reply; - this._act = act; - } - - get edit() { - return this._edit; - } - - get delete() { - return this._delete; - } - - get reply() { - return this._reply; - } - - get act() { - return this._act; - } - - get asText() { - return [ - "(", - this.edit ? "e" : "-", - this.delete ? "d" : "-", - this.reply ? "r" : "-", - this.act ? "a" : "-", - ")" - ].join(""); - } -} - -class Node { - constructor(nodeJson) { - this._el = undefined; - - this._text = nodeJson.text; - - this._permissions = new NodePermissions( - nodeJson.edit, - nodeJson.delete, - nodeJson.reply, - nodeJson.act, - ); - - this._children = new Map(); - this._order = nodeJson.order; - this._order.forEach(childId => { - let childJson = nodeJson.children[childId]; - let childNode = new Node(childJson); - this._children.set(childId, childNode); - }); - } - - child(childId) { - return this._children.get(childId); - } - - get order() { - return this._order.slice(); - } - - // Only replaces existing children. Does not add new children. - replaceChild(childId, newChild) { - let oldChild = this.child(childId); - if (oldChild === undefined) return; - newChild.obtainElements(oldChild); - this._children.set(childId, newChild); - } - - // Obtain and update this node's DOM elements. After this call, this.el - // represents the current node's contents. - // - // This function may optionally be called with an old node. If that node or - // its children already has existing DOM elements, they are repurposed. - // Otherwise, new DOM elements are created. - obtainElements(oldNode) { - if (this._el === undefined) { - // Obtain DOM elements because we don't yet have any - if (oldNode === undefined || oldNode._el === undefined) { - this._el = new NodeElements(); - } else { - this._el = oldNode._el; - } - } - - this._el.text = this._text; - this._el.permissions = this._permissions; - this._el.hasChildren = this.order.length > 0; - - this._el.removeAllChildren(); - - let oldChildren = (oldNode === undefined) ? new Map() : oldNode._children; - this._order.forEach(childId => { - let oldChild = oldChildren.get(childId); // May be undefined - let child = this._children.get(childId); // Not undefined - child.obtainElements(oldChild); - this._el.addChild(child._el); - }); - } - - // Wrapper functions for this._el - - appendTo(element) { - if (this._el === undefined) this.obtainElements(); - this._el.appendTo(element); - } - - get folded() { - if (this._el === undefined) return undefined; - return this._el.folded; - } - - set folded(flag) { - if (this._el === undefined) return; - this._el.folded = flag; - } - - toggleFolded() { - if (this._el === undefined) return; - this._el.toggleFolded(); - } - - get hasCursor() { - if (this._el === undefined) return undefined; - return this._el.hasCursor; - } - - set hasCursor(flag) { - if (this._el === undefined) return; - this._el.hasCursor = flag; - } - - get hasEditor() { - if (this._el === undefined) return undefined; - return this._el.hasEditor; - } - - set hasEditor(flag) { - if (this._el === undefined) return; - this._el.hasEditor = flag; - } -} - -class NodeTree { - constructor(rootNodeContainer, rootNode) { - this._rootNodeContainer = rootNodeContainer; - this._rootNode = rootNode; - - // Prepare root node container - removeAllChildren(this._rootNodeContainer); - this._rootNode.appendTo(this._rootNodeContainer); - } - - at(path) { - let node = this._rootNode; - for (let childId of path.components) { - node = node.child(childId); - if (node === undefined) break; - } - return node; - } - - updateAt(path, newNode) { - if (path.length === 0) { - newNode.obtainElements(this._rootNode); - this._rootNode = newNode; - } else { - let parentNode = this.at(path.parent); - parentNode.replaceChild(path.last, newNode); - } - } - - getChildWith(path, f) { - let node = this.at(path); - if (node === undefined) return undefined; - let index = f(node.order.length); - if (index === undefined) return undefined; - let childId = node.order[index]; - if (childId === undefined) return undefined; - return path.append(childId); - } - - getFirstChild(path) { - return this.getChildWith(path, l => 0); - } - - getLastChild(path) { - return this.getChildWith(path, l => l - 1); - } - - getSiblingWith(path, f) { - if (path.parent === undefined) return undefined; - let parentNode = this.at(path.parent); - if (parentNode === undefined) return undefined; - - let index = parentNode.order.indexOf(path.last); - if (index === undefined) return undefined; - let newIndex = f(index); - if (newIndex === undefined) return undefined; - let siblingId = parentNode.order[newIndex]; - if (siblingId === undefined) return undefined; - - return path.parent.append(siblingId); - } - - getPrevSibling(path) { - return this.getSiblingWith(path, i => i - 1); - } - - getNextSibling(path) { - return this.getSiblingWith(path, i => i + 1); - } - - getNodeAbove(path) { - let prevPath = this.getPrevSibling(path); - if (prevPath === undefined) return path.parent; - - // Get last child of previous path - while (true) { - let prevNode = this.at(prevPath); - if (prevNode.folded) return prevPath; - - let childPath = this.getLastChild(prevPath); - if (childPath === undefined) return prevPath; - - prevPath = childPath; - } - } - - getNodeBelow(path) { - let node = this.at(path); - if (!node.folded) { - let childPath = this.getFirstChild(path); - if (childPath !== undefined) return childPath; - } - - while (path !== undefined) { - let nextPath = this.getNextSibling(path); - if (nextPath !== undefined) return nextPath; - path = path.parent; - } - - return undefined; - } -} - -class Cursor { - constructor(nodeTree) { - this._nodeTree = nodeTree; - - this._path = new Path(); - this._relPos = null; // Either null or a RelPos value - - this.restore(); - } - - getSelectedNode() { - return this._nodeTree.at(this._path); - } - - _applyRelPos() { - if (this._relPos === null) return; - - let newPath; - if (this._relPos === RelPos.FIRST_CHILD) { - newPath = this._nodeTree.getFirstChild(this._path); - } else if (this._relPos === RelPos.NEXT_SIBLING) { - newPath = this._nodeTree.getNextSibling(this._path); - } - - if (newPath !== undefined) { - this._path = newPath; - this._relPos = null; - } - } - - _moveToNearestValidNode() { - // TODO Maybe select a sibling instead of going to nearest visible parent - let path = new Path(); - for (let component of this._path.components) { - let newPath = path.append(component); - let newNode = this._nodeTree.at(newPath); - if (newNode === undefined) break; - if (newNode.folded) break; - path = newPath; - } - this._path = path; - } - - _set(visible) { - this.getSelectedNode().hasCursor = visible; - } - - restore() { - this._applyRelPos(); - this._moveToNearestValidNode(); - this._set(true); - } - - moveTo(path) { - if (path === undefined) return; - this._set(false); - this._path = path; - this._set(true); - } - - moveUp() { - this.moveTo(this._nodeTree.getNodeAbove(this._path)); - } - - moveDown() { - this.moveTo(this._nodeTree.getNodeBelow(this._path)); - } -} - -class Editor { - constructor(nodeTree) { - this._nodeTree = nodeTree; - - this._elTextarea = newElement("textarea"); - this._elTextarea.addEventListener("input", event => this._updateTextAreaHeight()); - this._elMain = newElement("div", "node-editor", this.textarea); - - this._path = undefined; - this._asChild = false; - } - - _updateTextAreaHeight() { - this._elTextarea.style.height = 0; - this._elTextarea.style.height = this._elTextarea.scrollHeight + "px"; - } - - _getAttachedNode() { - if (this._path === undefined) return undefined; - return this._nodeTree.at(this._path); - } - - _detach(node, asChild) { - if (!asChild) { - node.hasEditor = false; - } - - this._elMain.parentNode.removeChild(this._elMain); - } - - _attachTo(node, asChild) { - if (asChild) { - node._el._elChildren.appendChild(this.element); - node.folded = false; - } else { - node._el._elMain.classList.add("has-editor"); - node._el._elMain.insertBefore(this.element, node._el._elChildren); - } - this._updateTextAreaHeight(); - } - - restore() { - if (this.element.parentNode !== null) return; // Already attached - let node = this._getAttachedNode(); - if (node === undefined) return; // Nowhere to attach - this._attachTo(node, this.asChild); - } - - attachTo(path, asChild) { - this.detach(); - this.path = path; - this.asChild = asChild; - this.restore(); - - this.textarea.focus(); - let length = this.textarea.value.length; - this.textarea.setSelectionRange(length, length); - } - - detach() { - let node = this._getAttachedNode(); - if (node === undefined) return; - this._detach(node, this.asChild); - this.path = undefined; - } - - set content(text) { - this.textarea.value = text; - } - - get content() { - return this.textarea.value; - } -} - -class Connection { - constructor(nodeTree, cursor, editor, url) { - this.nodeTree = nodeTree; - this.cursor = cursor; - this.editor = editor; - - this.url = url; - this.ws = new WebSocket(this.url); - this.ws.addEventListener("message", msg => this.onMessage(msg)); - this.ws.addEventListener("open", _ => this.sendHello()); - } - - onMessage(msg) { - let content = JSON.parse(msg.data); - if (content.type === "hello") { - this.onHello(content); - } else if (content.type === "update") { - this.onUpdate(content); - } - } - - onHello(content) { - this.nodeTree.updateAt(new Path(), new Node(content.node)); - this.cursor.restore(); - this.editor.restore(); - } - - onUpdate(content) { - this.nodeTree.updateAt(new Path(...content.path), new Node(content.node)); - this.cursor.restore(); - this.editor.restore(); - } - - _send(thing) { - this.ws.send(JSON.stringify(thing)); - } - - sendHello() { - this._send({type: "hello", extensions: []}); - } - - sendEdit(path, text) { - this._send({type: "edit", path: path.components, text: text}); - } - - sendDelete(path) { - this._send({type: "delete", path: path.components}); - } - - sendReply(path, text) { - this._send({type: "reply", path: path.components, text: text}); - } - - sendAct(path) { - this._send({type: "act", path: path.components}); - } -} - -/* - * The main application - */ - -const rootNodeContainer = document.getElementById("root-node-container"); -const loadingNode = new Node({text: "Connecting...", children: {}, order: []}); -const nodeTree = new NodeTree(rootNodeContainer, loadingNode); -const cursor = new Cursor(nodeTree); -const editor = new Editor(nodeTree); -const conn = new Connection(nodeTree, cursor, editor, "ws://127.0.0.1:8080/"); - -function beginEdit() { - let node = cursor.getSelectedNode(); - editor.content = node.text; - editor.attachTo(cursor.path, false); -} - -function beginDirectReply() { - editor.content = ""; - editor.attachTo(cursor.path, true); -} - -function beginIndirectReply() { - let path = cursor.path.parent; - if (path === undefined) return; - editor.content = ""; - editor.attachTo(path, true); -} - -function cancelEdit() { - editor.detach(); -} - -function completeEdit() { - let path = editor.path; - let text = editor.textarea.value; - if (editor.asChild) { - conn.sendReply(path, text); - } else { - conn.sendEdit(path, text); - } - editor.detach(); -} - -document.addEventListener("keydown", event => { - if (event.code === "Escape") { - cancelEdit(); - event.preventDefault(); - } else if (event.code === "Enter" && !event.shiftKey) { - completeEdit(); - event.preventDefault(); - } else if (document.activeElement.tagName === "TEXTAREA") { - return; // Do nothing special - } else if (event.code === "Tab") { - cursor.getSelectedNode().toggleFolded(); - event.preventDefault(); - } else if (event.code === "KeyK" || event.code === "ArrowUp") { - cursor.moveUp(); - event.preventDefault(); - } else if (event.code === "KeyJ" || event.code === "ArrowDown") { - cursor.moveDown(); - event.preventDefault(); - } else if (event.code === "KeyE") { - beginEdit(); - event.preventDefault(); - } else if (event.code === "KeyR") { - if (event.shiftKey) { - console.log("indirect"); - beginIndirectReply(); - } else { - console.log("direct"); - beginDirectReply(); - } - event.preventDefault(); - } else if (event.code === "KeyD") { - conn.sendDelete(cursor.path); - event.preventDefault(); - } else if (event.code === "KeyA") { - conn.sendAct(cursor.path); - event.preventDefault(); - } -}); diff --git a/forest-web/settings.css b/forest-web/settings.css deleted file mode 100644 index 817bcab..0000000 --- a/forest-web/settings.css +++ /dev/null @@ -1,16 +0,0 @@ -#settings { - position: fixed; - bottom: 0; - transition: all 0.2s ease-out; - transform: translateY(100%); -} -#settings a { - color: var(--white); -} -#settings > button, #settings > form { - padding: 1ch; - background-color: var(--magenta); -} -#settings > button { - font-weight: bold; -} diff --git a/forest-web/settings.js b/forest-web/settings.js deleted file mode 100644 index 2bcc331..0000000 --- a/forest-web/settings.js +++ /dev/null @@ -1,35 +0,0 @@ -"use strict"; - -const settingsDiv = document.getElementById("settings"); -const settingsButton = settingsDiv.querySelector("button"); -const settingsForm = settingsDiv.querySelector("form"); -let settingsMenuState; -settingsButton.addEventListener("click", event => setSettingsMenuState(!settingsMenuState)); -window.addEventListener("load", event => setSettingsMenuState(false)); - -function setSettingsMenuState(open) { - settingsMenuState = open; - if (open) { - settingsDiv.style.transform = "none"; - } else { - let height = settingsButton.offsetHeight; - settingsDiv.style.transform = `translateY(calc(100% - ${height}px))`; - } -} - -const curvyLinesCheckbox = document.getElementById("curvy-lines-checkbox"); -curvyLinesCheckbox.addEventListener("change", event => setCurvyLines(event.target.checked)); -window.addEventListener("load", event => { - let curvy = window.localStorage.getItem("curvy"); - curvyLinesCheckbox.checked = curvy; - setCurvyLines(curvy); -}); - -function setCurvyLines(curvy) { - document.body.classList.toggle("curvy", curvy); - if (curvy) { - window.localStorage.setItem("curvy", "yes"); - } else { - window.localStorage.removeItem("curvy"); - } -} diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..375ed1d --- /dev/null +++ b/package.yaml @@ -0,0 +1,36 @@ +name: forest +version: 0.1.0.0 +license: MIT +author: "Garmelon " +copyright: "2020 Garmelon" + +synopsis: A tree-based multi-user interaction thing +description: Please see the README on GitHub at +github: "Garmelon/forest" + +extra-source-files: +- README.md +- CHANGELOG.md + +dependencies: +- base >= 4.7 && < 5 +- aeson +- async +- containers +- text +- transformers +- websockets + +library: + source-dirs: src + +executables: + forest-server: + main: Main.hs + source-dirs: server + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - forest diff --git a/server/Main.hs b/server/Main.hs new file mode 100644 index 0000000..9dc690d --- /dev/null +++ b/server/Main.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Concurrent.MVar +import qualified Network.WebSockets as WS + +import Forest.Broadcast +import Forest.Node +import Forest.Server +import Forest.TreeModule.Const +import Forest.TreeModule.Fork +import Forest.TreeModule.SharedEditing + +pingDelay :: Int +pingDelay = 10 + +pongDelay :: Int +pongDelay = 3 * pingDelay + +options :: WS.ServerOptions +options = WS.defaultServerOptions + { WS.serverRequirePong = Just pongDelay + } + +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 "Sandbox" $ sharedEditingModule sharedEditNodeVar sharedEditBroadcaster + , ProngConstructor "About" $ constModule projectDescriptionNode + ] diff --git a/forest-common/src/Forest/Api.hs b/src/Forest/Api.hs similarity index 100% rename from forest-common/src/Forest/Api.hs rename to src/Forest/Api.hs diff --git a/src/Forest/Broadcast.hs b/src/Forest/Broadcast.hs new file mode 100644 index 0000000..2c319c6 --- /dev/null +++ b/src/Forest/Broadcast.hs @@ -0,0 +1,52 @@ +-- | A 'Broadcaster' allows threads to 'broadcast' values to 'Listeners' +-- attached to that broadcaster. A value that is sent through a broadcaster will +-- arrive exactly once at each attached listener and can then be collected by +-- calling 'listen'. +-- +-- All functions included in this module should be threadsafe. Be sure to read +-- the warning on the 'broadcast' function. + +module Forest.Broadcast + ( Broadcaster + , Listener + , newBroadcaster + , attachListener + , broadcast + , listen + ) where + +import Control.Concurrent.Chan + +-- | A 'Broadcaster' can broadcast values to all attached 'Listener's +newtype Broadcaster a = Broadcaster (Chan a) + +-- | A 'Listener' receives values from the 'Broadcaster' it is attached to +newtype Listener a = Listener (Chan a) + +-- | Create a new 'Broadcaster' +newBroadcaster :: IO (Broadcaster a) +newBroadcaster = Broadcaster <$> newChan + +-- | Create a new 'Listener' that is attached to a 'Broadcaster' +attachListener :: Broadcaster a -> IO (Listener a) +attachListener (Broadcaster chan) = Listener <$> dupChan chan + +-- | Send a value through the 'Broadcaster'. That value will arrive exactly once +-- at all 'Listener's attached to this broadcaster via 'attachListener'. +-- +-- Warning: During this function call, no exception should occur or elements may +-- build up in the broadcaster, leading to a memory/space leak. +broadcast :: Broadcaster a -> a -> IO () +-- Because the same function that puts something into the broadcaster channel +-- also immediately reads something from that channel, there is no build-up of +-- values in the broadcaster channel, as one element is removed for each element +-- written. Since the broadcaster channel is separate from the listener +-- channels, no event is swallowed accidentally. +-- +-- If some exception happens after the write operation succeeds but before the +-- read operation finishes, elements can build up in the broadcast channel. +broadcast (Broadcaster chan) value = writeChan chan value <* readChan chan + +-- | Read the next value from the 'Listener'. Blocks when the listener is empty. +listen :: Listener a -> IO a +listen (Listener chan) = readChan chan diff --git a/forest-common/src/Forest/Node.hs b/src/Forest/Node.hs similarity index 68% rename from forest-common/src/Forest/Node.hs rename to src/Forest/Node.hs index d30ebb1..c89b6c3 100644 --- a/forest-common/src/Forest/Node.hs +++ b/src/Forest/Node.hs @@ -2,9 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} module Forest.Node - ( - -- * Nodes - NodeId + ( NodeId , enumerateIds , findUnusedId , NodeFlags(..) @@ -13,27 +11,14 @@ module Forest.Node , newNode , txtNode , hasChildren - , diffNodes - , flatten - -- ** Traversing the tree + , mapChildren , applyId , applyPath - , firstChild - , lastChild - , firstSibling - , prevSibling - , nextSibling - , lastSibling - , firstNode - , prevNode - , nextNode - , lastNode - -- ** Modifying at a path , adjustAt , replaceAt , deleteAt , appendAt - -- * Paths + , diffNodes , Path(..) , referencedNodeExists , splitHeadTail @@ -49,21 +34,14 @@ import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T -import Safe import qualified Forest.OrderedMap as OMap -import Forest.Util - -{- Nodes -} type NodeId = T.Text --- | An infinite list of 'NodeId's. Does *not* contain every possible 'NodeId'. enumerateIds :: [NodeId] enumerateIds = map (T.pack . show) [(0::Integer)..] --- | Find a 'NodeId' that is not contained in the given set of IDs. Returns the --- first matching ID from 'enumerateIds'. findUnusedId :: Set.Set NodeId -> NodeId findUnusedId usedIds = head $ filter (\nid -> not $ nid `Set.member` usedIds) enumerateIds @@ -104,7 +82,7 @@ data Node = Node { nodeText :: !T.Text , nodeFlags :: !NodeFlags , nodeChildren :: !(OMap.OrderedMap NodeId Node) - } deriving (Show, Eq) + } deriving (Show) instance ToJSON Node where toJSON node = object @@ -162,87 +140,14 @@ txtNode flags text = newNode flags text [] hasChildren :: Node -> Bool hasChildren = not . OMap.null . nodeChildren -diffNodes :: Node -> Node -> Maybe (Path, Node) -diffNodes a b - | nodesDiffer || childrenChanged = Just (Path [], b) - | otherwise = case differingChildren of - [] -> Nothing - [(x, Path xs, node)] -> Just (Path (x:xs), node) - _ -> Just (Path [], b) - where - nodesDiffer = nodeText a /= nodeText b || nodeFlags a /= nodeFlags b - aChildren = nodeChildren a - bChildren = nodeChildren b - childrenChanged = OMap.keys aChildren /= OMap.keys bChildren - diffedChildren = Map.toList $ Map.intersectionWith diffNodes (OMap.toMap aChildren) (OMap.toMap bChildren) - differingChildren = [(key, path, node) | (key, Just (path, node)) <- diffedChildren] +mapChildren :: (NodeId -> Node -> a) -> Node -> [a] +mapChildren f = map (uncurry f) . OMap.toList . nodeChildren --- | Return the 'Path's to a node and its subnodes in the order they would be --- displayed in. -flatten :: Node -> [Path] -flatten node = Path [] : flattenedChildren - where - flattenChild nid n = map (Path [nid] <>) (flatten n) - flattenedChildren = - concat $ OMap.elems $ OMap.mapWithKey flattenChild $ nodeChildren node +applyId :: NodeId -> Node -> Maybe Node +applyId nid node = nodeChildren node OMap.!? nid -{- Traversing the tree -} - -applyId :: Node -> NodeId -> Maybe Node -applyId node nid = nodeChildren node OMap.!? nid - -applyPath :: Node -> Path -> Maybe Node -applyPath node (Path ids) = foldM applyId node ids - -getChild :: ([NodeId] -> Maybe NodeId) -> Node -> Path -> Maybe Path -getChild f root path = do - node <- applyPath root path - let childIds = OMap.keys $ nodeChildren node - childId <- f childIds - pure $ path <> Path [childId] - -firstChild :: Node -> Path -> Maybe Path -firstChild = getChild headMay - -lastChild :: Node -> Path -> Maybe Path -lastChild = getChild lastMay - -getSibling :: (NodeId -> [NodeId] -> Maybe NodeId) -> Node -> Path -> Maybe Path -getSibling f root path = do - (parentPath, nodeId) <- splitInitLast path - parentNode <- applyPath root parentPath - let siblingIds = OMap.keys $ nodeChildren parentNode - siblingId <- f nodeId siblingIds - pure $ parentPath <> Path [siblingId] - -firstSibling :: Node -> Path -> Maybe Path -firstSibling = getSibling $ const headMay - -prevSibling :: Node -> Path -> Maybe Path -prevSibling = getSibling $ findPrev . (==) - -nextSibling :: Node -> Path -> Maybe Path -nextSibling = getSibling $ findNext . (==) - -lastSibling :: Node -> Path -> Maybe Path -lastSibling = getSibling $ const lastMay - -getNode :: (Path -> [Path] -> Maybe Path) -> Node -> Path -> Maybe Path -getNode f root path = f path $ flatten root - -firstNode :: Node -> Path -> Maybe Path -firstNode = getNode $ const headMay - -prevNode :: Node -> Path -> Maybe Path -prevNode = getNode $ findPrev . (==) - -nextNode :: Node -> Path -> Maybe Path -nextNode = getNode $ findNext . (==) - -lastNode :: Node -> Path -> Maybe Path -lastNode = getNode $ const lastMay - -{- Modifying at a path -} +applyPath :: Path -> Node -> Maybe Node +applyPath (Path ids) node = foldM (flip applyId) node ids adjustAt :: (Node -> Node) -> Path -> Node -> Node adjustAt f (Path []) node = f node @@ -271,14 +176,27 @@ appendAt node = let nid = findUnusedId $ OMap.keysSet m in OMap.append nid node m -{- Paths -} +diffNodes :: Node -> Node -> Maybe (Path, Node) +diffNodes a b + | nodesDiffer || childrenChanged = Just (Path [], b) + | otherwise = case differingChildren of + [] -> Nothing + [(x, Path xs, node)] -> Just (Path (x:xs), node) + _ -> Just (Path [], b) + where + nodesDiffer = nodeText a /= nodeText b || nodeFlags a /= nodeFlags b + aChildren = nodeChildren a + bChildren = nodeChildren b + childrenChanged = OMap.keys aChildren /= OMap.keys bChildren + diffedChildren = Map.toList $ Map.intersectionWith diffNodes (OMap.toMap aChildren) (OMap.toMap bChildren) + differingChildren = [(key, path, node) | (key, Just (path, node)) <- diffedChildren] newtype Path = Path { pathElements :: [NodeId] } deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON) referencedNodeExists :: Node -> Path -> Bool -referencedNodeExists node path = isJust $ applyPath node path +referencedNodeExists node path = isJust $ applyPath path node splitHeadTail :: Path -> Maybe (NodeId, Path) splitHeadTail (Path []) = Nothing diff --git a/forest-common/src/Forest/OrderedMap.hs b/src/Forest/OrderedMap.hs similarity index 97% rename from forest-common/src/Forest/OrderedMap.hs rename to src/Forest/OrderedMap.hs index 5d13333..a29f3af 100644 --- a/forest-common/src/Forest/OrderedMap.hs +++ b/src/Forest/OrderedMap.hs @@ -65,17 +65,11 @@ 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) -instance Functor (OrderedMap k) where - fmap = Forest.OrderedMap.map - -instance (Ord k) => Foldable (OrderedMap k) where - foldMap f = foldMap f . elems - -- Invariants of this data type: -- -- 1. The 'omOrder' list contains each key from 'omMap' exactly once. diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs new file mode 100644 index 0000000..e8e3716 --- /dev/null +++ b/src/Forest/Server.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Forest.Server + ( withThread + , serverApp + ) where + +import Control.Concurrent.Chan +import Control.Exception +import qualified Network.WebSockets as WS + +import Forest.Api +import Forest.Node +import Forest.TreeModule +import Forest.Util + +{- Thread that sends updates to the client -} + +sendUpdatesThread :: WS.Connection -> Chan Node -> Node -> IO () +sendUpdatesThread conn nodeChan nodeA = do + nodeB <- readChan nodeChan + case diffNodes nodeA nodeB of + Nothing -> do + putStrLn "Sending no update because the node didn't change" + sendUpdatesThread conn nodeChan nodeA + Just (path, nextNode) -> do + putStrLn $ "Sending partial update for path " ++ show path ++ ": " ++ show nextNode + sendPacket conn $ ServerUpdate path nextNode + sendUpdatesThread conn nodeChan nodeB + +{- Main server application that receives and processes client packets -} + +receivePackets :: TreeModule a () => WS.Connection -> a () -> IO () +receivePackets conn treeModule = runUntilJustM $ do + packet <- receivePacket conn + case packet of + ClientEdit path text -> do + putStrLn $ "Editing " ++ show path ++ " to " ++ show text + edit treeModule path text + ClientDelete path -> do + putStrLn $ "Deleting " ++ show path + delete treeModule path + ClientReply path text -> do + putStrLn $ "Replying to " ++ show path ++ " with " ++ show text + reply treeModule path text + ClientAct path -> do + putStrLn $ "Acting upon " ++ show path + act treeModule path + ClientHello _ -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once" + +printException :: SomeException -> IO () +printException e = putStrLn $ "Encountered exception: " ++ show e + +serverApp :: TreeModule a () => Int -> ModuleConstructor (a ()) -> WS.ServerApp +serverApp pingDelay constructor pendingConnection = do + conn <- WS.acceptRequest pendingConnection + chan <- newChan + WS.withPingThread conn pingDelay (pure ()) $ handle printException $ do + firstPacket <- receivePacket conn + case firstPacket of + ClientHello _ -> do + putStrLn $ "Sending hello reply with " ++ show initialNode + sendPacket conn $ ServerHello [] initialNode + withThread (sendUpdatesThread conn chan initialNode) $ + constructor (writeChan chan) $ \tm -> do + receivePackets conn tm + putStrLn "Module finished, closing connection" + _ -> closeWithErrorMessage conn "Invalid packet: Expected a hello packet" + where + initialNode = txtNode "" "Loading..." diff --git a/src/Forest/TreeModule.hs b/src/Forest/TreeModule.hs new file mode 100644 index 0000000..bcd7036 --- /dev/null +++ b/src/Forest/TreeModule.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Forest.TreeModule + ( TreeModule(..) + , ModuleConstructor + ) where + +import qualified Data.Text as T + +import Forest.Node + +class TreeModule a r where + edit :: a r -> Path -> T.Text -> IO (Maybe r) + edit _ _ _ = pure Nothing + + delete :: a r -> Path -> IO (Maybe r) + delete _ _ = pure Nothing + + reply :: a r -> Path -> T.Text -> IO (Maybe r) + reply _ _ _ = pure Nothing + + act :: a r -> Path -> IO (Maybe r) + act _ _ = pure Nothing + +type ModuleConstructor a = (Node -> IO ()) -> (a -> IO ()) -> IO () diff --git a/src/Forest/TreeModule/Animate.hs b/src/Forest/TreeModule/Animate.hs new file mode 100644 index 0000000..7a5b32c --- /dev/null +++ b/src/Forest/TreeModule/Animate.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Forest.TreeModule.Animate + ( AnimateModule + , animateModule + ) where + +import Control.Concurrent + +import Forest.Node +import Forest.TreeModule +import Forest.Util + +data AnimateModule r = AnimateModule + +instance TreeModule AnimateModule () where + +animateModule :: Int -> [Node] -> ModuleConstructor (AnimateModule ()) +animateModule delay frames sendNode continue = + withThread (animateThread frames) $ continue AnimateModule + where + animateThread [] = sendNode $ txtNode "" "Invalid animation: No frames provided" + animateThread (x:xs) = do + sendNode x + threadDelay delay + animateThread $ xs ++ [x] diff --git a/src/Forest/TreeModule/Const.hs b/src/Forest/TreeModule/Const.hs new file mode 100644 index 0000000..25ac72b --- /dev/null +++ b/src/Forest/TreeModule/Const.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Forest.TreeModule.Const + ( ConstModule + , constModule + , projectDescriptionNode + ) where + +import Forest.Node +import Forest.TreeModule + +data ConstModule r = ConstModule + +instance TreeModule ConstModule () where + +constModule :: Node -> ModuleConstructor (ConstModule ()) +constModule node sendNode continue = do + sendNode node + continue ConstModule + +projectDescriptionNode :: Node +projectDescriptionNode = + newNode "" "About" + [ txtNode "" "This project is an experiment in tree-based interaction." + , newNode "" "Motivation" + [ txtNode "" "My goals for this project were:" + , newNode "" "Interactons between multiple people" + [ txtNode "" + ( "I wanted to create a project that let multiple people interact with " + <> "each other in different ways. Examples for interactions include:\n" + <> "* Chatting\n" + <> "* Collaborative editing\n" + <> "* Playing (multiplayer) games\n" + ) + , txtNode "" "The project should allow for many different kinds of interactions." + ] + , newNode "" "Portability" + [ txtNode "" + ( "The project should be usable on multiple different platforms. To " + <> "facilitate this, clients should be easy to create. In particular, I " + <> "want at least one terminal-based and one web-based client." + ) + ] + , txtNode "" "Based on these goals, I made the following design decisions:" + , newNode "" "Text-based" + [ txtNode "" + ( "Text is a medium that works on all platforms and easy to work with " + <> "as a developer." + ) + , txtNode "" + ( "But text still allows for a lot of different interactions. Of all " + <> "the kinds of media one can produce with a computer, text is easy " + <> "and quick to create. After all, pretty much every computer has a " + <> "keyboard." + ) + ] + , newNode "" "Tree-based" + [ txtNode "" + ( "While plain text may be easy to work with, it makes interactions " + <> "cumbersome if limited to basic input and output. To make " + <> "interactions nicer, the server could send the client a screen's " + <> "worth of text to display, in effect creating a TUI-like interface. " + <> "The client would then only need to send key presses or mouse clicks " + <> "to the server." + ) + , txtNode "" + ( "In my opinion, that approach moves too many decisions on how to " + <> "interact to the server and imposes unnecessary limits on the client " + <> "design. Instead, I went with a plaintext-in-tree-structure " + <> "approach, which allows for more flexibility in the client design. " + <> "Also, this should make bots easier to write, since they don't have " + <> "to emulate human input." + ) + ] + , newNode "" "Simple API" + [ txtNode "" + ( "Every client must use the same API to interact with the server. " + <> "Because clients should be easy to create on different platforms, " + <> "the API should also be simple." + ) + , txtNode "" + ( "One way in which the API is simple is that the server doesn't send " + <> "direct responses to client commands. Instead, there is only the " + <> "'update' packet, which is sent whenever the client should modify " + <> "its tree structure." + ) + , txtNode "" + ( "In total, there are 5 different client packages and 2 different " + <> "server packages. If at some point the API turns out to be too " + <> "simple, it has a built-in way of negotiating protocol extensions." + ) + ] + , newNode "" "Most logic in server" + [ txtNode "" + ( "All logic besides the immediate input handling and tree folding " + <> "happens in the server. This has multiple advantages:" + ) + , txtNode "" "The API and clients are simpler, clients are easier to write or maintain." + , txtNode "" "Updates in logic don't require updates of the client." + , txtNode "" "The server-side logic becomes easier to write." + ] + , txtNode "" + ( "Those design decisions should allow for various different kinds of " + <> "interactions, for example linear and threaded chat, collaborative " + <> "node editing, reading node-based documents (like this one), playing " + <> "text adventures and more." + ) + , txtNode "" + ( "And of course, which interactions are supported only depends on the " + <> "server and not on the client." + ) + ] + , newNode "" "Inspirations" + [ txtNode "" "The tree-based chat model and UI of euphoria (euphoria.io) and instant (instant.leet.nu)" + , txtNode "" "MUDs (which are text based and most of the logic happens server-side)" + ] + ] diff --git a/src/Forest/TreeModule/Fork.hs b/src/Forest/TreeModule/Fork.hs new file mode 100644 index 0000000..d1b4d67 --- /dev/null +++ b/src/Forest/TreeModule/Fork.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} + +module Forest.TreeModule.Fork + ( ForkModule + , ProngConstructor(..) + , forkModule + ) where + +import Control.Concurrent.MVar +import Control.Monad.Trans.Cont +import qualified Data.Map as Map +import qualified Data.Text as T + +import Forest.Node +import qualified Forest.OrderedMap as OMap +import Forest.TreeModule + +data Prong = forall r a . TreeModule a r => Prong (a r) + +data ProngConstructor = forall r a . TreeModule a r => + ProngConstructor T.Text (ModuleConstructor (a r)) + +newtype ForkModule r = ForkModule (Map.Map NodeId Prong) + +instance TreeModule ForkModule () where + edit _ (Path []) _ = pure Nothing + edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of + Nothing -> pure Nothing + Just (Prong a) -> do + result <- edit a (Path xs) text + pure $ () <$ result + + delete _ (Path []) = pure Nothing + delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of + Nothing -> pure Nothing + Just (Prong a) -> do + result <- delete a (Path xs) + pure $ () <$ result + + reply _ (Path []) _ = pure Nothing + reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of + Nothing -> pure Nothing + Just (Prong a) -> do + result <- reply a (Path xs) text + pure $ () <$ result + + act _ (Path []) = pure Nothing + act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of + Nothing -> pure Nothing + Just (Prong a) -> do + result <- act a (Path xs) + pure $ () <$ result + +data ProngInfo = ProngInfo + { piTopName :: T.Text + , piNames :: Map.Map NodeId T.Text + , piNodes :: Map.Map NodeId Node + , piOrder :: [NodeId] + } + +renderProngInfo :: ProngInfo -> Node +renderProngInfo pInfo = + let childMap = Map.intersectionWith + (\name node -> node{nodeText = name}) + (piNames pInfo) + (piNodes pInfo) + children = OMap.fromMapWithOrder childMap $ piOrder pInfo + in Node {nodeText = piTopName pInfo, nodeFlags = mempty, nodeChildren = children} + +sendNodeFromProng :: MVar ProngInfo -> (Node -> IO ()) -> NodeId -> Node -> IO () +sendNodeFromProng piVar sendNode nodeId node = + modifyMVar_ piVar $ \pInfo -> do + let newPInfo = pInfo {piNodes = Map.insert nodeId node $ piNodes pInfo} + sendNode $ renderProngInfo newPInfo + pure newPInfo + +constructProngs + :: MVar ProngInfo + -> (Node -> IO ()) + -> Map.Map NodeId ProngConstructor + -> Cont (IO ()) (Map.Map NodeId Prong) +constructProngs piVar sendNode = + Map.traverseWithKey constructProng + where + constructProng nodeId (ProngConstructor _ constructor) = + Prong <$> cont (constructor $ sendNodeFromProng piVar sendNode nodeId) + +forkModule :: T.Text -> [ProngConstructor] -> ModuleConstructor (ForkModule ()) +forkModule text prongs sendNode continue = do + let namePairs = zip enumerateIds $ map (\(ProngConstructor name _) -> name) prongs + nodesVar <- newMVar ProngInfo + { piTopName = text + , piNames = Map.fromList namePairs + , piNodes = Map.empty + , piOrder = map fst namePairs + } + let numbers = map (T.pack . show) [(0::Integer)..] + prongMap = Map.fromList $ zip numbers prongs + runCont (constructProngs nodesVar sendNode prongMap) (continue . ForkModule) diff --git a/src/Forest/TreeModule/SharedEditing.hs b/src/Forest/TreeModule/SharedEditing.hs new file mode 100644 index 0000000..b67d431 --- /dev/null +++ b/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 diff --git a/forest-common/src/Forest/Util.hs b/src/Forest/Util.hs similarity index 88% rename from forest-common/src/Forest/Util.hs rename to src/Forest/Util.hs index 68cad73..b92ca77 100644 --- a/forest-common/src/Forest/Util.hs +++ b/src/Forest/Util.hs @@ -1,16 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Forest.Util - ( - -- * List operations - findPrev + ( findPrev , findNext - -- * Monadic looping constructs , whileM - , whileNothingM - -- * Multithreading helpers + , runUntilJustM , withThread - -- * Websocket helper functions , sendPacket , closeWithErrorMessage , receivePacket @@ -29,6 +24,9 @@ findPrev f as = fst <$> find (f . snd) (zip as $ tail as) findNext :: (a -> Bool) -> [a] -> Maybe a findNext f as = snd <$> find (f . fst) (zip as $ tail as) +withThread :: IO () -> IO () -> IO () +withThread thread main = withAsync thread $ const main + -- | Run a monadic action until it returns @False@ for the first time. whileM :: Monad m => m Bool -> m () whileM f = do @@ -38,16 +36,13 @@ whileM f = do else pure () -- | Run a monadic action until it returns @Just a@ for the first time. -whileNothingM :: Monad m => m (Maybe a) -> m a -whileNothingM f = do +runUntilJustM :: Monad m => m (Maybe a) -> m a +runUntilJustM f = do result <- f case result of - Nothing -> whileNothingM f + Nothing -> runUntilJustM f Just a -> pure a -withThread :: IO () -> IO () -> IO () -withThread thread main = withAsync thread $ const main - sendPacket :: ToJSON a => WS.Connection -> a -> IO () sendPacket conn packet = WS.sendTextData conn $ encode packet diff --git a/stack.yaml b/stack.yaml index 2c294b0..465f104 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,66 @@ -resolver: lts-15.3 +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-15.1 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai packages: - - forest-cabin - - forest-common - - forest-server - - forest-tui +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock index eeb93a9..7e51098 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 491373 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/3.yaml - sha256: 29e9ff61b8bf4b4fcff55cde3ac106ebb971f0d21331dccac9eee63374fa6ca8 - original: lts-15.3 + size: 489011 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/1.yaml + sha256: d4ecc42b7125d68e4c3c036a08046ad0cd02ae0d9efbe3af2223a00ff8cc16f3 + original: lts-15.1