Commit unstaged changes

Coming back to this project after a while, these changes were still unstaged. In
order not to lose them I'm committing them here, even though I don't remember
what they're for. They might not even work properly.

.gitignore

@@ -1,3 +1,2 @@
 .stack-work/
-forest.cabal
 *~

CHANGELOG.md

@@ -1,4 +1,4 @@
 # Changelog for forest
 
 ## upcoming
-* create project
+- create project

README.md

@@ -1,5 +1,19 @@
 # forest
 
-Forest is an experiment in tree-based interaction.
+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.
 
 [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)

Setup.hs

@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain

forest-cabin/README.md

@@ -0,0 +1 @@
+# forest-cabin

forest-cabin/app/Main.hs

@@ -0,0 +1,114 @@
+{-# 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

forest-cabin/forest-cabin.cabal

@@ -0,0 +1,60 @@
+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 <https://github.com/Garmelon/forest#readme>
+homepage:       https://github.com/Garmelon/forest#readme
+bug-reports:    https://github.com/Garmelon/forest/issues
+author:         Garmelon <joscha@plugh.de>
+maintainer:     Garmelon <joscha@plugh.de>
+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

forest-cabin/package.yaml

@@ -0,0 +1,36 @@
+name: forest-cabin
+version: 0.1.0.0
+license: MIT
+author: Garmelon <joscha@plugh.de>
+copyright: 2020 Garmelon
+
+synopsis: A forest server hosted at forest.plugh.de
+description: Please see the README at <https://github.com/Garmelon/forest#readme>
+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

forest-common/README.md

@@ -0,0 +1 @@
+# forest-common

forest-common/forest-common.cabal

@@ -0,0 +1,45 @@
+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 <https://github.com/Garmelon/forest#readme>
+homepage:       https://github.com/Garmelon/forest#readme
+bug-reports:    https://github.com/Garmelon/forest/issues
+author:         Garmelon <joscha@plugh.de>
+maintainer:     Garmelon <joscha@plugh.de>
+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

forest-common/package.yaml

@@ -0,0 +1,24 @@
+name: forest-common
+version: 0.1.0.0
+license: MIT
+author: Garmelon <joscha@plugh.de>
+copyright: 2020 Garmelon
+
+synopsis: A tree-based multi-user interaction thing
+description: Please see the README at <https://github.com/Garmelon/forest#readme>
+github: Garmelon/forest
+
+extra-source-files:
+  - README.md
+
+dependencies:
+  - base >= 4.7 && < 5
+  - aeson
+  - async
+  - containers
+  - safe
+  - text
+  - websockets
+
+library:
+  source-dirs: src

forest-common/src/Forest/Node.hs

@@ -2,7 +2,9 @@
 {-# LANGUAGE OverloadedStrings          #-}
 
 module Forest.Node
-  ( NodeId
+  (
+  -- * Nodes
+    NodeId
   , enumerateIds
   , findUnusedId
   , NodeFlags(..)
@@ -11,14 +13,27 @@ module Forest.Node
   , newNode
   , txtNode
   , hasChildren
-  , mapChildren
+  , diffNodes
+  , flatten
+  -- ** Traversing the tree
   , applyId
   , applyPath
+  , firstChild
+  , lastChild
+  , firstSibling
+  , prevSibling
+  , nextSibling
+  , lastSibling
+  , firstNode
+  , prevNode
+  , nextNode
+  , lastNode
+  -- ** Modifying at a path
   , adjustAt
   , replaceAt
   , deleteAt
   , appendAt
-  , diffNodes
+  -- * Paths
   , Path(..)
   , referencedNodeExists
   , splitHeadTail
@@ -34,14 +49,21 @@ 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
@@ -82,7 +104,7 @@ data Node = Node
   { nodeText     :: !T.Text
   , nodeFlags    :: !NodeFlags
   , nodeChildren :: !(OMap.OrderedMap NodeId Node)
-  } deriving (Show)
+  } deriving (Show, Eq)
 
 instance ToJSON Node where
   toJSON node = object
@@ -140,14 +162,87 @@ txtNode flags text = newNode flags text []
 hasChildren :: Node -> Bool
 hasChildren = not . OMap.null . nodeChildren
 
-mapChildren :: (NodeId -> Node -> a) -> Node -> [a]
+diffNodes :: Node -> Node -> Maybe (Path, Node)
-mapChildren f = map (uncurry f) . OMap.toList . nodeChildren
+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]
 
-applyId :: NodeId -> Node -> Maybe Node
+-- | Return the 'Path's to a node and its subnodes in the order they would be
-applyId nid node = nodeChildren node OMap.!? nid
+-- 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
 
-applyPath :: Path -> Node -> Maybe Node
+{- Traversing the tree -}
-applyPath (Path ids) node = foldM (flip applyId) node ids
+
+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 -}
 
 adjustAt :: (Node -> Node) -> Path -> Node -> Node
 adjustAt f (Path []) node = f node
@@ -176,27 +271,14 @@ appendAt node =
       let nid = findUnusedId $ OMap.keysSet m
       in  OMap.append nid node m
 
-diffNodes :: Node -> Node -> Maybe (Path, Node)
+{- Paths -}
-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 path node
+referencedNodeExists node path = isJust $ applyPath node path
 
 splitHeadTail :: Path -> Maybe (NodeId, Path)
 splitHeadTail (Path [])     = Nothing

forest-common/src/Forest/OrderedMap.hs

@@ -65,11 +65,17 @@ 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.

forest-common/src/Forest/Util.hs

@@ -1,11 +1,16 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Forest.Util
-  ( findPrev
+  (
+  -- * List operations
+    findPrev
   , findNext
+  -- * Monadic looping constructs
   , whileM
-  , runUntilJustM
+  , whileNothingM
+  -- * Multithreading helpers
   , withThread
+  -- * Websocket helper functions
   , sendPacket
   , closeWithErrorMessage
   , receivePacket
@@ -24,9 +29,6 @@ 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
@@ -36,13 +38,16 @@ whileM f = do
     else pure ()
 
 -- | Run a monadic action until it returns @Just a@ for the first time.
-runUntilJustM :: Monad m => m (Maybe a) -> m a
+whileNothingM :: Monad m => m (Maybe a) -> m a
-runUntilJustM f = do
+whileNothingM f = do
   result <- f
   case result of
-    Nothing -> runUntilJustM f
+    Nothing -> whileNothingM 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
 

forest-server/README.md

@@ -0,0 +1 @@
+# forest-server

forest-server/forest-server.cabal

@@ -0,0 +1,45 @@
+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 <https://github.com/Garmelon/forest#readme>
+homepage:       https://github.com/Garmelon/forest#readme
+bug-reports:    https://github.com/Garmelon/forest/issues
+author:         Garmelon <joscha@plugh.de>
+maintainer:     Garmelon <joscha@plugh.de>
+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

forest-server/package.yaml

@@ -0,0 +1,25 @@
+name: forest-server
+version: 0.1.0.0
+license: MIT
+author: Garmelon <joscha@plugh.de>
+copyright: 2020 Garmelon
+
+synopsis: A framework for forest servers
+description: Please see the README at <https://github.com/Garmelon/forest#readme>
+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

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

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

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

@@ -0,0 +1,85 @@
+{-# 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

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

@@ -0,0 +1,113 @@
+{-# 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"

forest-tui/README.md

@@ -0,0 +1 @@
+# forest-tui

forest-tui/app/Main.hs

@@ -0,0 +1,12 @@
+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

forest-tui/forest-tui.cabal

@@ -0,0 +1,74 @@
+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 <https://github.com/Garmelon/forest#readme>
+homepage:       https://github.com/Garmelon/forest#readme
+bug-reports:    https://github.com/Garmelon/forest/issues
+author:         Garmelon <joscha@plugh.de>
+maintainer:     Garmelon <joscha@plugh.de>
+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

forest-tui/package.yaml

@@ -0,0 +1,39 @@
+name: forest-tui
+version: 0.1.0.0
+license: MIT
+author: Garmelon <joscha@plugh.de>
+copyright: 2020 Garmelon
+
+synopsis: A terminal-based client for forest
+description: Please see the README at <https://github.com/Garmelon/forest#readme>
+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

forest-tui/src/Forest/Client.hs

@@ -0,0 +1,156 @@
+{-# 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

forest-tui/src/Forest/Client/NodeUtil.hs

@@ -0,0 +1,47 @@
+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

forest-tui/src/Forest/Client/Options.hs

@@ -0,0 +1,67 @@
+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)
+  )

forest-tui/src/Forest/Client/UiState.hs

@@ -0,0 +1,292 @@
+{-# 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)

forest-tui/src/Forest/Client/Websocket.hs

@@ -0,0 +1,73 @@
+{-# 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"

forest-tui/src/Forest/Client/Widgets/NodeEditor.hs

@@ -0,0 +1,46 @@
+{-# 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)

forest-tui/src/Forest/Client/Widgets/WidgetTree.hs

@@ -0,0 +1,115 @@
+{-# 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      = "| "
+  }

forest-web/about.html

@@ -0,0 +1,67 @@
+<!DOCTYPE html>
+<html lang="en">
+    <head>
+        <meta charset="utf-8">
+        <title>Forest - About</title>
+        <link rel="stylesheet" href="main.css">
+    </head>
+    <body>
+        <main>
+
+            <h1>Forest</h1>
+            <h2>Description</h2>
+            <p>
+                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!
+            </p>
+            <p>
+                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.
+            </p>
+
+            <h2>Code and docs</h2>
+            <ol>
+                <li><a href="https://github.com/Garmelon/forest">Server and terminal-based client</a></li>
+                <li>Web-based client (coming soon)</li>
+                <li><a href="https://github.com/Garmelon/forest/blob/master/docs/API.md#api">API documentation</a></li>
+            </ol>
+
+            <h2>Usage</h2>
+            <h3>Controls</h3>
+            <pre>
+tab           - fold/unfold current node
+arrow keys/jk - move cursor
+            </pre>
+            <h3>Permissions</h3>
+            <p>
+                A node's permissions are displayed at the right side of the
+                screen, like this:
+                <span style="color: var(--bright-black);">(edra)</span>.
+                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.
+            </p>
+            <pre>
+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
+            </pre>
+            <h3>Colors</h3>
+            <p>
+                The cursor position is marked by a
+                <span style="background-color: var(--blue);">blue background</span>.
+                If a node is colored
+                <span style="color: var(--yellow); font-weight: bold;">yellow</span>,
+                it has child nodes.
+            </p>
+
+        </main>
+    </body>
+</html>

forest-web/init.html

@@ -0,0 +1,39 @@
+<!DOCTYPE html>
+<html lang="en">
+    <head>
+        <meta charset="utf-8">
+        <title>Forest</title>
+        <link rel="stylesheet" href="main.css">
+        <link rel="stylesheet" href="node.css">
+        <link rel="stylesheet" href="settings.css">
+        <script defer src="node.js"></script>
+        <script defer src="settings.js"></script>
+    </head>
+    <body>
+
+        <div id="root-node-container">
+            <div class="node">
+                <div class="node-line">
+                    <span class="node-text">Please enable javascript.</span>
+                    <span class="node-permissions">(----)</span>
+                </div>
+                <div class="node-children"></div>
+            </div>
+        </div>
+
+        <div id="settings">
+            <button>Settings</button>
+            <form>
+                <div>
+                    <input type="checkbox" id="curvy-lines-checkbox">
+                    <label for="curvy-lines-checkbox" title="Make the end bits of the tree lines curved">Curvy lines</label>
+                </div>
+            </form>
+        </div>
+
+        <div id="about">
+            <a href="about.html">About</a>
+        </div>
+
+    </body>
+</html>

forest-web/main.css

@@ -0,0 +1,76 @@
+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);
+}

forest-web/node.css

@@ -0,0 +1,71 @@
+.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;
+}

forest-web/node.js

@@ -0,0 +1,684 @@
+"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();
+    }
+});

forest-web/settings.css

@@ -0,0 +1,16 @@
+#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;
+}

forest-web/settings.js

@@ -0,0 +1,35 @@
+"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");
+    }
+}

package.yaml

@@ -1,36 +0,0 @@
-name:                forest
-version:             0.1.0.0
-license:             MIT
-author:              "Garmelon <joscha@plugh.de>"
-copyright:           "2020 Garmelon"
-
-synopsis:            A tree-based multi-user interaction thing
-description:         Please see the README on GitHub at <https://github.com/Garmelon/forest#readme>
-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

server/Main.hs

@@ -1,37 +0,0 @@
-{-# 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
-    ]

src/Forest/Broadcast.hs

@@ -1,52 +0,0 @@
--- | 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

src/Forest/Server.hs

@@ -1,71 +0,0 @@
-{-# 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..."

src/Forest/TreeModule.hs

@@ -1,25 +0,0 @@
-{-# 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 ()

src/Forest/TreeModule/Animate.hs

@@ -1,27 +0,0 @@
-{-# 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]

src/Forest/TreeModule/Const.hs

@@ -1,118 +0,0 @@
-{-# 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)"
-    ]
-  ]

src/Forest/TreeModule/Fork.hs

@@ -1,102 +0,0 @@
-{-# 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)

src/Forest/TreeModule/SharedEditing.hs

@@ -1,56 +0,0 @@
-{-# 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

stack.yaml

@@ -1,66 +1,6 @@
-# This file was automatically generated by 'stack init'
+resolver: lts-15.3
-#
-# 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
-# Dependency packages to be pulled from upstream that are not in the resolver.
+  - forest-common
-# These entries can reference officially published versions as well as
+  - forest-server
-# forks / in-progress versions pinned to a git hash. For example:
+  - forest-tui
-#
-# 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

stack.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 489011
+    size: 491373
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/1.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/3.yaml
-    sha256: d4ecc42b7125d68e4c3c036a08046ad0cd02ae0d9efbe3af2223a00ff8cc16f3
+    sha256: 29e9ff61b8bf4b4fcff55cde3ac106ebb971f0d21331dccac9eee63374fa6ca8
-  original: lts-15.1
+  original: lts-15.3