Compare commits
1 commit
master
...
server-onl
| Author | SHA1 | Date | |
|---|---|---|---|
| 922488a836 |
50 changed files with 632 additions and 2692 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -1,2 +1,3 @@
|
||||||
.stack-work/
|
.stack-work/
|
||||||
|
forest.cabal
|
||||||
*~
|
*~
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,4 @@
|
||||||
# Changelog for forest
|
# Changelog for forest
|
||||||
|
|
||||||
## upcoming
|
## upcoming
|
||||||
- create project
|
* create project
|
||||||
|
|
|
||||||
16
README.md
16
README.md
|
|
@ -1,19 +1,5 @@
|
||||||
# forest
|
# forest
|
||||||
|
|
||||||
Forest is an experiment in tree-based interaction: One or more clients connect
|
Forest is an experiment in tree-based interaction.
|
||||||
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)
|
[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)
|
|
||||||
|
|
|
||||||
2
Setup.hs
Normal file
2
Setup.hs
Normal file
|
|
@ -0,0 +1,2 @@
|
||||||
|
import Distribution.Simple
|
||||||
|
main = defaultMain
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
# forest-cabin
|
|
||||||
|
|
@ -1,114 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
|
|
||||||
module Main where
|
|
||||||
|
|
||||||
import Control.Concurrent.STM
|
|
||||||
import Lens.Micro
|
|
||||||
import Lens.Micro.TH
|
|
||||||
import qualified Network.WebSockets as WS
|
|
||||||
import Options.Applicative
|
|
||||||
|
|
||||||
import Forest.Node
|
|
||||||
import Forest.Server.Branch.SharedEdit
|
|
||||||
import Forest.Server.Schema
|
|
||||||
import Forest.Server.TreeApp
|
|
||||||
|
|
||||||
{- Command line options -}
|
|
||||||
|
|
||||||
data ServerOptions = ServerOptions
|
|
||||||
{ serverPingDelay :: Int
|
|
||||||
, serverHost :: String
|
|
||||||
, serverPort :: Int
|
|
||||||
}
|
|
||||||
|
|
||||||
parser :: Parser ServerOptions
|
|
||||||
parser = ServerOptions
|
|
||||||
<$> option auto
|
|
||||||
( long "ping-delay"
|
|
||||||
<> help "How many seconds to wait between each ping sent to the client"
|
|
||||||
<> value 10
|
|
||||||
<> showDefault
|
|
||||||
<> metavar "SECONDS"
|
|
||||||
)
|
|
||||||
<*> strOption
|
|
||||||
( short 'h'
|
|
||||||
<> long "host"
|
|
||||||
<> help "The server's host"
|
|
||||||
<> value (WS.serverHost WS.defaultServerOptions)
|
|
||||||
<> showDefault
|
|
||||||
<> metavar "HOST"
|
|
||||||
)
|
|
||||||
<*> option auto
|
|
||||||
( short 'p'
|
|
||||||
<> long "port"
|
|
||||||
<> help "The port to listen for websocket connections on"
|
|
||||||
<> value (WS.serverPort WS.defaultServerOptions)
|
|
||||||
<> showDefault
|
|
||||||
<> metavar "PORT"
|
|
||||||
)
|
|
||||||
|
|
||||||
serverOptionsParserInfo :: ParserInfo ServerOptions
|
|
||||||
serverOptionsParserInfo = info (helper <*> parser) fullDesc
|
|
||||||
|
|
||||||
wsOptions :: ServerOptions -> WS.ServerOptions
|
|
||||||
wsOptions o = WS.defaultServerOptions
|
|
||||||
{ WS.serverHost = serverHost o
|
|
||||||
, WS.serverPort = serverPort o
|
|
||||||
, WS.serverRequirePong = Just $ serverPingDelay o * 2
|
|
||||||
}
|
|
||||||
|
|
||||||
{- The actual app -}
|
|
||||||
|
|
||||||
data AppEvent = UpdateSharedEdit
|
|
||||||
deriving (Show, Eq)
|
|
||||||
|
|
||||||
newtype AppState = AppState
|
|
||||||
{ _asSharedEdit :: SharedEditLocal
|
|
||||||
}
|
|
||||||
|
|
||||||
makeLenses ''AppState
|
|
||||||
|
|
||||||
schema :: AppState -> Schema (Branch AppState AppEvent)
|
|
||||||
schema s = fork' "Forest"
|
|
||||||
[ leaf $ schemaLift asSharedEdit sharedEditBranch s
|
|
||||||
]
|
|
||||||
|
|
||||||
draw :: AppState -> Node
|
|
||||||
draw = schemaDraw . schema
|
|
||||||
|
|
||||||
handleEvent :: AppState -> Event AppEvent -> IO (Next AppState)
|
|
||||||
handleEvent s (Custom UpdateSharedEdit) = do
|
|
||||||
sel' <- sharedEditUpdate $ s ^. asSharedEdit
|
|
||||||
pure $ continue $ s & asSharedEdit .~ sel'
|
|
||||||
handleEvent s e = case schemaHandleEvent (schema s) e of
|
|
||||||
Nothing -> pure $ continue s
|
|
||||||
Just s' -> continue <$> s'
|
|
||||||
|
|
||||||
constructor
|
|
||||||
:: TChan AppEvent
|
|
||||||
-> SharedEditGlobal
|
|
||||||
-> (AppState -> Maybe (TChan AppEvent) -> IO a)
|
|
||||||
-> IO a
|
|
||||||
constructor broadcastChan seg cont = do
|
|
||||||
sel <- sharedEditLocal seg
|
|
||||||
receiveChan <- atomically $ dupTChan broadcastChan
|
|
||||||
cont (AppState sel) (Just receiveChan)
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
opts <- execParser serverOptionsParserInfo
|
|
||||||
|
|
||||||
putStrLn "Preparing server"
|
|
||||||
broadcastChan <- atomically newBroadcastTChan
|
|
||||||
let onEditChange = atomically $ writeTChan broadcastChan UpdateSharedEdit
|
|
||||||
seg <- sharedEditGlobal onEditChange "Sandbox"
|
|
||||||
let app = TreeApp
|
|
||||||
{ appDraw = draw
|
|
||||||
, appHandleEvent = handleEvent
|
|
||||||
, appConstructor = constructor broadcastChan seg
|
|
||||||
}
|
|
||||||
|
|
||||||
putStrLn "Starting server"
|
|
||||||
WS.runServerWithOptions (wsOptions opts) $
|
|
||||||
runTreeApp (serverPingDelay opts) app
|
|
||||||
|
|
@ -1,60 +0,0 @@
|
||||||
cabal-version: 1.12
|
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.31.2.
|
|
||||||
--
|
|
||||||
-- see: https://github.com/sol/hpack
|
|
||||||
--
|
|
||||||
-- hash: c619b22393d818639b183c69031b267a4ed16faeaf609a75ef1cadb9288195e1
|
|
||||||
|
|
||||||
name: forest-cabin
|
|
||||||
version: 0.1.0.0
|
|
||||||
synopsis: A forest server hosted at forest.plugh.de
|
|
||||||
description: Please see the README at <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
|
|
||||||
|
|
@ -1,36 +0,0 @@
|
||||||
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
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
# forest-common
|
|
||||||
|
|
@ -1,45 +0,0 @@
|
||||||
cabal-version: 1.12
|
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.31.2.
|
|
||||||
--
|
|
||||||
-- see: https://github.com/sol/hpack
|
|
||||||
--
|
|
||||||
-- hash: e59723e563cf364a74b1032409ed7a9d3ecbec3a6baa34554771cb5c1a5689d9
|
|
||||||
|
|
||||||
name: forest-common
|
|
||||||
version: 0.1.0.0
|
|
||||||
synopsis: A tree-based multi-user interaction thing
|
|
||||||
description: Please see the README at <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
|
|
||||||
|
|
@ -1,24 +0,0 @@
|
||||||
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
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
# forest-server
|
|
||||||
|
|
@ -1,45 +0,0 @@
|
||||||
cabal-version: 1.12
|
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.31.2.
|
|
||||||
--
|
|
||||||
-- see: https://github.com/sol/hpack
|
|
||||||
--
|
|
||||||
-- hash: c0d366de2ff27f13dd69d751b47017143df332454ad700dd8fb5089d9837f1a8
|
|
||||||
|
|
||||||
name: forest-server
|
|
||||||
version: 0.1.0.0
|
|
||||||
synopsis: A framework for forest servers
|
|
||||||
description: Please see the README at <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
|
|
||||||
|
|
@ -1,25 +0,0 @@
|
||||||
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
|
|
||||||
|
|
@ -1,80 +0,0 @@
|
||||||
module Forest.Server.Branch.SharedEdit
|
|
||||||
( SharedEditGlobal
|
|
||||||
, sharedEditGlobal
|
|
||||||
, SharedEditLocal
|
|
||||||
, sharedEditLocal
|
|
||||||
, sharedEditDraw
|
|
||||||
, sharedEditUpdate
|
|
||||||
, sharedEditHandleEvent
|
|
||||||
, sharedEditBranch
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Monad
|
|
||||||
import qualified Data.Text as T
|
|
||||||
|
|
||||||
import Forest.Node
|
|
||||||
import Forest.Server.Schema
|
|
||||||
import Forest.Server.TreeApp
|
|
||||||
|
|
||||||
data SharedEditGlobal = SharedEditGlobal
|
|
||||||
{ seOnUpdate :: IO ()
|
|
||||||
, seNodeVar :: MVar Node
|
|
||||||
}
|
|
||||||
|
|
||||||
sharedEditGlobal :: IO () -> T.Text -> IO SharedEditGlobal
|
|
||||||
sharedEditGlobal onUpdate initialText = do
|
|
||||||
nodeVar <- newMVar $ txtNode "r" initialText
|
|
||||||
pure SharedEditGlobal
|
|
||||||
{ seOnUpdate = onUpdate
|
|
||||||
, seNodeVar = nodeVar
|
|
||||||
}
|
|
||||||
|
|
||||||
data SharedEditLocal = SharedEditLocal
|
|
||||||
{ seGlobal :: SharedEditGlobal
|
|
||||||
, seNode :: Node
|
|
||||||
}
|
|
||||||
|
|
||||||
sharedEditLocal :: SharedEditGlobal -> IO SharedEditLocal
|
|
||||||
sharedEditLocal seg = do
|
|
||||||
node <- readMVar $ seNodeVar seg
|
|
||||||
pure SharedEditLocal
|
|
||||||
{ seGlobal = seg
|
|
||||||
, seNode = node
|
|
||||||
}
|
|
||||||
|
|
||||||
sharedEditDraw :: SharedEditLocal -> Node
|
|
||||||
sharedEditDraw = seNode
|
|
||||||
|
|
||||||
sharedEditUpdate :: SharedEditLocal -> IO SharedEditLocal
|
|
||||||
sharedEditUpdate sel = do
|
|
||||||
node <- readMVar $ seNodeVar $ seGlobal sel
|
|
||||||
pure sel{seNode = node}
|
|
||||||
|
|
||||||
updateNode :: SharedEditLocal -> (Node -> Node) -> IO SharedEditLocal
|
|
||||||
updateNode sel f = do
|
|
||||||
let seg = seGlobal sel
|
|
||||||
nodeVar = seNodeVar seg
|
|
||||||
node <- takeMVar nodeVar
|
|
||||||
let node' = f node
|
|
||||||
putMVar nodeVar node'
|
|
||||||
when (node /= node') $ seOnUpdate seg
|
|
||||||
pure sel{seNode = node'}
|
|
||||||
|
|
||||||
sharedEditHandleEvent :: SharedEditLocal -> Path -> Event e -> IO SharedEditLocal
|
|
||||||
-- Ignore edits to the top node since it's only reply-able, not edit-able
|
|
||||||
sharedEditHandleEvent sel (Path []) (Edit _ _) = pure sel
|
|
||||||
sharedEditHandleEvent sel (Path []) (Delete _) = pure sel
|
|
||||||
sharedEditHandleEvent sel path (Edit _ text) =
|
|
||||||
updateNode sel $ adjustAt (\n -> n {nodeText = text}) path
|
|
||||||
sharedEditHandleEvent sel path (Delete _) =
|
|
||||||
updateNode sel $ deleteAt path
|
|
||||||
sharedEditHandleEvent sel path (Reply _ text) =
|
|
||||||
updateNode sel $ appendAt (txtNode "edr" text) path
|
|
||||||
sharedEditHandleEvent sel _ _ = pure sel
|
|
||||||
|
|
||||||
sharedEditBranch :: SharedEditLocal -> Branch SharedEditLocal e
|
|
||||||
sharedEditBranch sel = Branch
|
|
||||||
{ branchNode = sharedEditDraw sel
|
|
||||||
, branchHandleEvent = sharedEditHandleEvent sel
|
|
||||||
}
|
|
||||||
|
|
@ -1,85 +0,0 @@
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
|
|
||||||
module Forest.Server.Schema
|
|
||||||
( Schema
|
|
||||||
, fork
|
|
||||||
, fork'
|
|
||||||
, leaf
|
|
||||||
, collect
|
|
||||||
, collectWith
|
|
||||||
, dispatch
|
|
||||||
-- * Useful type
|
|
||||||
, Branch(..)
|
|
||||||
, schemaDraw
|
|
||||||
, schemaHandleEvent
|
|
||||||
, schemaLift
|
|
||||||
) where
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Lens.Micro
|
|
||||||
|
|
||||||
import Forest.Node
|
|
||||||
import qualified Forest.OrderedMap as OMap
|
|
||||||
import Forest.Server.TreeApp
|
|
||||||
|
|
||||||
data Schema a
|
|
||||||
= Fork T.Text (OMap.OrderedMap NodeId (Schema a))
|
|
||||||
| Leaf a
|
|
||||||
|
|
||||||
instance Functor Schema where
|
|
||||||
fmap f (Leaf a) = Leaf $ f a
|
|
||||||
fmap f (Fork text children) = Fork text $ fmap (fmap f) children
|
|
||||||
|
|
||||||
fork :: T.Text -> [(NodeId, Schema a)] -> Schema a
|
|
||||||
fork text = Fork text . OMap.fromList
|
|
||||||
|
|
||||||
fork' :: T.Text -> [Schema a] -> Schema a
|
|
||||||
fork' text = fork text . zip keys
|
|
||||||
where
|
|
||||||
keys :: [NodeId]
|
|
||||||
keys = map (T.pack . show) [0::Int ..]
|
|
||||||
|
|
||||||
leaf :: a -> Schema a
|
|
||||||
leaf = Leaf
|
|
||||||
|
|
||||||
collect :: Schema Node -> Node
|
|
||||||
collect (Leaf node) = node
|
|
||||||
collect (Fork text children) = Node text mempty $ OMap.map collect children
|
|
||||||
|
|
||||||
collectWith :: (a -> Node) -> Schema a -> Node
|
|
||||||
collectWith f = collect . fmap f
|
|
||||||
|
|
||||||
dispatch :: Path -> Schema a -> Maybe (Path, a)
|
|
||||||
dispatch path (Leaf a) = Just (path, a)
|
|
||||||
dispatch (Path (x:xs)) (Fork _ omap) = dispatch (Path xs) =<< (omap OMap.!? x)
|
|
||||||
dispatch (Path []) (Fork _ _ ) = Nothing -- More specfic than required
|
|
||||||
|
|
||||||
data Branch s e = Branch
|
|
||||||
{ branchNode :: Node
|
|
||||||
, branchHandleEvent :: Path -> Event e -> IO s
|
|
||||||
}
|
|
||||||
|
|
||||||
schemaDraw :: Schema (Branch s e) -> Node
|
|
||||||
schemaDraw = collectWith branchNode
|
|
||||||
|
|
||||||
schemaHandleEvent :: Schema (Branch s e) -> Event e -> Maybe (IO s)
|
|
||||||
schemaHandleEvent schema event = do
|
|
||||||
path <- getPath event
|
|
||||||
(relPath, branch) <- dispatch path schema
|
|
||||||
pure $ branchHandleEvent branch relPath event
|
|
||||||
where
|
|
||||||
getPath (Edit path _) = Just path
|
|
||||||
getPath (Delete path) = Just path
|
|
||||||
getPath (Reply path _) = Just path
|
|
||||||
getPath (Act path) = Just path
|
|
||||||
getPath _ = Nothing
|
|
||||||
|
|
||||||
schemaLift :: Lens' s t -> (t -> Branch t e) -> s -> Branch s e
|
|
||||||
schemaLift l f s = Branch
|
|
||||||
{ branchNode = branchNode branch
|
|
||||||
, branchHandleEvent = \path event -> do
|
|
||||||
t' <- branchHandleEvent branch path event
|
|
||||||
pure $ s & l .~ t'
|
|
||||||
}
|
|
||||||
where
|
|
||||||
branch = f $ s ^. l
|
|
||||||
|
|
@ -1,113 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
-- | This module specifies a structure for forest server applications. It is
|
|
||||||
-- based on the way Brick models applications.
|
|
||||||
|
|
||||||
module Forest.Server.TreeApp
|
|
||||||
( Next
|
|
||||||
, continue
|
|
||||||
, halt
|
|
||||||
, Event(..)
|
|
||||||
, TreeApp(..)
|
|
||||||
, simpleConstructor
|
|
||||||
, runTreeApp
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Concurrent.STM
|
|
||||||
import Control.Monad
|
|
||||||
import Data.Function
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Network.WebSockets as WS
|
|
||||||
|
|
||||||
import Forest.Api
|
|
||||||
import Forest.Node
|
|
||||||
import Forest.Util
|
|
||||||
|
|
||||||
data Next a = Continue a | Halt
|
|
||||||
|
|
||||||
continue :: a -> Next a
|
|
||||||
continue = Continue
|
|
||||||
|
|
||||||
halt :: Next a
|
|
||||||
halt = Halt
|
|
||||||
|
|
||||||
data Event e
|
|
||||||
= Edit Path T.Text
|
|
||||||
| Delete Path
|
|
||||||
| Reply Path T.Text
|
|
||||||
| Act Path
|
|
||||||
| Custom e
|
|
||||||
|
|
||||||
data TreeApp s e = TreeApp
|
|
||||||
{ appDraw :: s -> Node
|
|
||||||
, appHandleEvent :: s -> Event e -> IO (Next s)
|
|
||||||
, appConstructor :: forall a. (s -> Maybe (TChan e) -> IO a) -> IO a
|
|
||||||
}
|
|
||||||
|
|
||||||
simpleConstructor :: s -> (s -> IO a) -> IO a
|
|
||||||
simpleConstructor = (&)
|
|
||||||
|
|
||||||
{- The websocket app receiving and sending the packets -}
|
|
||||||
|
|
||||||
packetToEvent :: ClientPacket -> Maybe (Event e)
|
|
||||||
packetToEvent (ClientEdit path text) = Just $ Edit path text
|
|
||||||
packetToEvent (ClientDelete path) = Just $ Delete path
|
|
||||||
packetToEvent (ClientReply path text) = Just $ Reply path text
|
|
||||||
packetToEvent (ClientAct path) = Just $ Act path
|
|
||||||
packetToEvent (ClientHello _) = Nothing
|
|
||||||
|
|
||||||
receiveThread :: WS.Connection -> TChan (Event e) -> IO ()
|
|
||||||
receiveThread conn chan = forever $ do
|
|
||||||
packet <- receivePacket conn
|
|
||||||
case packetToEvent packet of
|
|
||||||
-- We can wrap a 'forever' around all of this because closeWithErrorMessage
|
|
||||||
-- throws a runtime exception once the connection is closed.
|
|
||||||
Nothing -> closeWithErrorMessage conn "Invalid packet: Hello"
|
|
||||||
Just event -> atomically $ writeTChan chan event
|
|
||||||
|
|
||||||
data RunState s e = RunState
|
|
||||||
{ rsEventChan :: TChan (Event e)
|
|
||||||
, rsCustomEventChan :: Maybe (TChan e)
|
|
||||||
, rsState :: s
|
|
||||||
, rsNode :: Node
|
|
||||||
}
|
|
||||||
|
|
||||||
readEvent :: RunState s e -> STM (Event e)
|
|
||||||
readEvent rs = case rsCustomEventChan rs of
|
|
||||||
Nothing -> readTChan ec
|
|
||||||
Just cec -> readTChan ec `orElse` (Custom <$> readTChan cec)
|
|
||||||
where
|
|
||||||
ec = rsEventChan rs
|
|
||||||
|
|
||||||
sendNodeUpdate :: WS.Connection -> Node -> Node -> IO ()
|
|
||||||
sendNodeUpdate conn nodeOld nodeNew = case diffNodes nodeOld nodeNew of
|
|
||||||
Nothing -> putStrLn "Sending no update because the node didn't change"
|
|
||||||
Just (path, updatedNode) -> do
|
|
||||||
putStrLn $ "Sending partial update at " ++ show path ++ ": " ++ show updatedNode
|
|
||||||
sendPacket conn $ ServerUpdate path updatedNode
|
|
||||||
|
|
||||||
runUntilHalt :: WS.Connection -> TreeApp s e -> RunState s e -> IO ()
|
|
||||||
runUntilHalt conn app rs = do
|
|
||||||
event <- atomically $ readEvent rs
|
|
||||||
next <- appHandleEvent app (rsState rs) event
|
|
||||||
case next of
|
|
||||||
Halt -> pure ()
|
|
||||||
Continue state' -> do
|
|
||||||
let node' = appDraw app state'
|
|
||||||
sendNodeUpdate conn (rsNode rs) node'
|
|
||||||
runUntilHalt conn app rs{rsState = state', rsNode = node'}
|
|
||||||
|
|
||||||
runTreeApp :: Int -> TreeApp s e -> WS.ServerApp
|
|
||||||
runTreeApp pingDelay app pendingConn = do
|
|
||||||
conn <- WS.acceptRequest pendingConn
|
|
||||||
chan <- atomically newTChan
|
|
||||||
WS.withPingThread conn pingDelay (pure ()) $
|
|
||||||
appConstructor app $ \initialState customChan -> do
|
|
||||||
firstPacket <- receivePacket conn
|
|
||||||
case firstPacket of
|
|
||||||
ClientHello _ -> do
|
|
||||||
let initialNode = appDraw app initialState
|
|
||||||
rs = RunState chan customChan initialState initialNode
|
|
||||||
sendPacket conn $ ServerHello [] initialNode
|
|
||||||
withThread (receiveThread conn chan) $ runUntilHalt conn app rs
|
|
||||||
_ -> closeWithErrorMessage conn "Invalid packet: Expected hello"
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
# forest-tui
|
|
||||||
|
|
@ -1,12 +0,0 @@
|
||||||
module Main where
|
|
||||||
|
|
||||||
import Options.Applicative
|
|
||||||
|
|
||||||
import Forest.Client
|
|
||||||
import Forest.Client.Options
|
|
||||||
import Forest.Client.Websocket
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
opts <- execParser clientOptionsParserInfo
|
|
||||||
runWithEventChan opts runClient
|
|
||||||
|
|
@ -1,74 +0,0 @@
|
||||||
cabal-version: 1.12
|
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.31.2.
|
|
||||||
--
|
|
||||||
-- see: https://github.com/sol/hpack
|
|
||||||
--
|
|
||||||
-- hash: 9ca3a1fe555e2dceb3459b6ae920b1ed93aac76398d4909a7030d7992b79ce40
|
|
||||||
|
|
||||||
name: forest-tui
|
|
||||||
version: 0.1.0.0
|
|
||||||
synopsis: A terminal-based client for forest
|
|
||||||
description: Please see the README at <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
|
|
||||||
|
|
@ -1,39 +0,0 @@
|
||||||
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
|
|
||||||
|
|
@ -1,156 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Forest.Client
|
|
||||||
( ClientState
|
|
||||||
, newClientState
|
|
||||||
, runClient
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Brick
|
|
||||||
import Brick.BChan
|
|
||||||
import Brick.Widgets.Edit
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import qualified Graphics.Vty as Vty
|
|
||||||
import qualified Network.WebSockets as WS
|
|
||||||
|
|
||||||
import Forest.Api
|
|
||||||
import Forest.Client.UiState
|
|
||||||
import Forest.Client.Websocket
|
|
||||||
import Forest.Client.Widgets.WidgetTree
|
|
||||||
import Forest.Node
|
|
||||||
import Forest.Util
|
|
||||||
|
|
||||||
data ResourceName = RnViewport | RnEditor
|
|
||||||
deriving (Show, Eq, Ord)
|
|
||||||
|
|
||||||
data ClientState = ClientState
|
|
||||||
{ csUiState :: UiState ResourceName
|
|
||||||
, csConn :: WS.Connection
|
|
||||||
}
|
|
||||||
|
|
||||||
newClientState :: WS.Connection -> Node -> ClientState
|
|
||||||
newClientState conn node = ClientState
|
|
||||||
{ csUiState = newUiState RnEditor node
|
|
||||||
, csConn = conn
|
|
||||||
}
|
|
||||||
|
|
||||||
{- Handling input events -}
|
|
||||||
|
|
||||||
type ClientM a = EventM ResourceName a
|
|
||||||
|
|
||||||
onUiState ::
|
|
||||||
ClientState
|
|
||||||
-> (UiState ResourceName -> UiState ResourceName)
|
|
||||||
-> ClientM (Next ClientState)
|
|
||||||
onUiState cs f = continue cs {csUiState = f $ csUiState cs}
|
|
||||||
|
|
||||||
onUiState' ::
|
|
||||||
ClientState
|
|
||||||
-> (UiState ResourceName -> ClientM (UiState ResourceName))
|
|
||||||
-> ClientM (Next ClientState)
|
|
||||||
onUiState' cs f = do
|
|
||||||
s' <- f $ csUiState cs
|
|
||||||
continue cs {csUiState = s'}
|
|
||||||
|
|
||||||
{- ... without active editor -}
|
|
||||||
|
|
||||||
deleteNode :: ClientState -> ClientM ()
|
|
||||||
deleteNode cs =
|
|
||||||
when (flagDelete $ nodeFlags $ focusedNode s) $
|
|
||||||
liftIO $ sendPacket (csConn cs) $ ClientDelete (focusedPath s)
|
|
||||||
where
|
|
||||||
s = csUiState cs
|
|
||||||
|
|
||||||
actUponNode :: ClientState -> ClientM ()
|
|
||||||
actUponNode cs =
|
|
||||||
when (flagAct $ nodeFlags $ focusedNode s) $
|
|
||||||
liftIO $ sendPacket (csConn cs) $ ClientAct (focusedPath s)
|
|
||||||
where
|
|
||||||
s = csUiState cs
|
|
||||||
|
|
||||||
onKeyWithoutEditor :: ClientState -> Vty.Event -> ClientM (Next ClientState)
|
|
||||||
onKeyWithoutEditor cs (Vty.EvKey k _)
|
|
||||||
| k `elem` [Vty.KChar 'q', Vty.KEsc] = halt cs
|
|
||||||
| k == Vty.KChar '\t' = onUiState cs toggleFoldAtFocus
|
|
||||||
| k `elem` [Vty.KChar 'k', Vty.KUp] = onUiState cs moveFocusUp
|
|
||||||
| k `elem` [Vty.KChar 'j', Vty.KDown] = onUiState cs moveFocusDown
|
|
||||||
| k `elem` [Vty.KChar 'K', Vty.KPageUp] = onUiState cs moveFocusToPrevSibling
|
|
||||||
| k `elem` [Vty.KChar 'J', Vty.KPageDown] =
|
|
||||||
onUiState cs moveFocusToNextSibling
|
|
||||||
| k `elem` [Vty.KChar 'h', Vty.KLeft] = onUiState cs moveFocusToParent
|
|
||||||
| k `elem` [Vty.KChar 'g', Vty.KHome] = onUiState cs moveFocusToTop
|
|
||||||
| k `elem` [Vty.KChar 'G', Vty.KEnd] = onUiState cs moveFocusToBottom
|
|
||||||
| k == Vty.KChar 'e' = onUiState cs editCurrentNode
|
|
||||||
| k == Vty.KChar 'r' = onUiState cs (replyToCurrentNode . unfoldAtFocus)
|
|
||||||
| k == Vty.KChar 'R' = onUiState cs replyAfterCurrentNode
|
|
||||||
| k `elem` [Vty.KChar 'd', Vty.KChar 'x', Vty.KDel, Vty.KBS] =
|
|
||||||
deleteNode cs *> continue cs
|
|
||||||
| k `elem` [Vty.KChar 'a', Vty.KChar ' ', Vty.KEnter] =
|
|
||||||
actUponNode cs *> continue cs
|
|
||||||
onKeyWithoutEditor cs _ = continue cs
|
|
||||||
|
|
||||||
{- ... with active editor -}
|
|
||||||
|
|
||||||
editResultToPacket :: EditResult -> ClientPacket
|
|
||||||
editResultToPacket result
|
|
||||||
| erReply result = ClientReply (erPath result) (erText result)
|
|
||||||
| otherwise = ClientEdit (erPath result) (erText result)
|
|
||||||
|
|
||||||
onKeyWithEditor :: ClientState -> Vty.Event -> ClientM (Next ClientState)
|
|
||||||
-- Finish editing normally
|
|
||||||
onKeyWithEditor cs (Vty.EvKey Vty.KEnter _) = do
|
|
||||||
let (s', maybeResult) = finishEditing $ csUiState cs
|
|
||||||
forM_ maybeResult $ liftIO . sendPacket (csConn cs) . editResultToPacket
|
|
||||||
continue cs {csUiState = s'}
|
|
||||||
-- Abort editing with Escape
|
|
||||||
onKeyWithEditor cs (Vty.EvKey Vty.KEsc _) = onUiState cs abortEditing
|
|
||||||
-- Insert a newline on C-n
|
|
||||||
onKeyWithEditor cs (Vty.EvKey (Vty.KChar 'n') m)
|
|
||||||
| Vty.MCtrl `elem` m = onUiState' cs $ updateEditor $ Vty.EvKey Vty.KEnter []
|
|
||||||
-- Forward all other events as usual
|
|
||||||
onKeyWithEditor cs ev = onUiState' cs $ updateEditor ev
|
|
||||||
|
|
||||||
{- And the rest of the Brick application -}
|
|
||||||
|
|
||||||
clientDraw :: ClientState -> [Widget ResourceName]
|
|
||||||
clientDraw cs = [padTopBottom 1 $ padLeftRight 2 vp]
|
|
||||||
where
|
|
||||||
tree = renderUiState boxDrawingBranching $ csUiState cs
|
|
||||||
vp = viewport RnViewport Vertical tree
|
|
||||||
|
|
||||||
clientHandleEvent ::
|
|
||||||
ClientState -> BrickEvent ResourceName Event -> ClientM (Next ClientState)
|
|
||||||
clientHandleEvent cs (VtyEvent ev)
|
|
||||||
| isEditorActive (csUiState cs) = onKeyWithEditor cs ev
|
|
||||||
| otherwise = onKeyWithoutEditor cs ev
|
|
||||||
clientHandleEvent cs (AppEvent ev) = case ev of
|
|
||||||
EventNode node -> onUiState cs $ replaceRootNode node
|
|
||||||
EventConnectionClosed -> halt cs
|
|
||||||
clientHandleEvent cs _ = continue cs
|
|
||||||
|
|
||||||
clientAttrMap :: AttrMap
|
|
||||||
clientAttrMap = attrMap Vty.defAttr
|
|
||||||
[ ("expand", Vty.defAttr `Vty.withStyle` Vty.bold `Vty.withForeColor` Vty.yellow)
|
|
||||||
, ("focus", Vty.defAttr `Vty.withBackColor` Vty.blue)
|
|
||||||
, ("flags", Vty.defAttr `Vty.withForeColor` Vty.brightBlack)
|
|
||||||
, (treeLineAttr, Vty.defAttr `Vty.withForeColor` Vty.brightBlack)
|
|
||||||
, (editAttr, Vty.defAttr `Vty.withBackColor` Vty.brightBlack)
|
|
||||||
]
|
|
||||||
|
|
||||||
clientApp :: App ClientState Event ResourceName
|
|
||||||
clientApp = App
|
|
||||||
{ appDraw = clientDraw
|
|
||||||
, appChooseCursor = showFirstCursor
|
|
||||||
, appHandleEvent = clientHandleEvent
|
|
||||||
, appStartEvent = pure
|
|
||||||
, appAttrMap = const clientAttrMap
|
|
||||||
}
|
|
||||||
|
|
||||||
runClient :: WS.Connection -> BChan Event -> Node -> IO ()
|
|
||||||
runClient conn chan node = do
|
|
||||||
putStrLn "Starting UI"
|
|
||||||
let clientState = newClientState conn node
|
|
||||||
vtyBuilder = Vty.mkVty Vty.defaultConfig
|
|
||||||
initialVty <- vtyBuilder
|
|
||||||
void $ customMain initialVty vtyBuilder (Just chan) clientApp clientState
|
|
||||||
|
|
@ -1,47 +0,0 @@
|
||||||
module Forest.Client.NodeUtil
|
|
||||||
( Unfolded
|
|
||||||
, foldVisibleNodes
|
|
||||||
, applyFolds
|
|
||||||
, findPrevNode
|
|
||||||
, findNextNode
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.Maybe
|
|
||||||
import qualified Data.Set as Set
|
|
||||||
|
|
||||||
import Forest.Node
|
|
||||||
import qualified Forest.OrderedMap as OMap
|
|
||||||
import Forest.Util
|
|
||||||
|
|
||||||
type Unfolded = Set.Set Path
|
|
||||||
|
|
||||||
foldVisibleNodes' :: Path -> (Path -> Node -> Maybe [a] -> a) -> Unfolded -> Node -> a
|
|
||||||
foldVisibleNodes' path f unfolded node
|
|
||||||
| childrenVisible = f path node $ Just mappedChildren
|
|
||||||
| otherwise = f path node Nothing
|
|
||||||
where
|
|
||||||
childrenVisible = mempty `Set.member` unfolded
|
|
||||||
mappedChildren = map (uncurry goDeeper) $ OMap.toList $ nodeChildren node
|
|
||||||
goDeeper nid = foldVisibleNodes' (path <> Path [nid]) f (narrowSet nid unfolded)
|
|
||||||
|
|
||||||
-- | The word "fold" in the name of this function is meant as in 'foldr'. This
|
|
||||||
-- function folds a tree of nodes while respecting which nodes should be visible
|
|
||||||
-- according to the 'Unfolded' set.
|
|
||||||
foldVisibleNodes :: (Path -> Node -> Maybe [a] -> a) -> Unfolded -> Node -> a
|
|
||||||
foldVisibleNodes = foldVisibleNodes' mempty
|
|
||||||
|
|
||||||
-- | Keep only those nodes that are visible according to the 'Unfolded' set.
|
|
||||||
applyFolds :: Unfolded -> Node -> Node
|
|
||||||
applyFolds unfolded node
|
|
||||||
| mempty `Set.member` unfolded = node {nodeChildren = children}
|
|
||||||
| otherwise = node {nodeChildren = OMap.empty}
|
|
||||||
where
|
|
||||||
children =
|
|
||||||
OMap.mapWithKey (\nid -> applyFolds $ narrowSet nid unfolded) $
|
|
||||||
nodeChildren node
|
|
||||||
|
|
||||||
findPrevNode :: Node -> Path -> Path
|
|
||||||
findPrevNode node path = fromMaybe path $ findPrev (==path) $ flatten node
|
|
||||||
|
|
||||||
findNextNode :: Node -> Path -> Path
|
|
||||||
findNextNode node path = fromMaybe path $ findNext (==path) $ flatten node
|
|
||||||
|
|
@ -1,67 +0,0 @@
|
||||||
module Forest.Client.Options
|
|
||||||
( ClientOptions(..)
|
|
||||||
, clientOptionsParserInfo
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.List
|
|
||||||
import Options.Applicative
|
|
||||||
import Options.Applicative.Help.Pretty
|
|
||||||
|
|
||||||
data ClientOptions = ClientOptions
|
|
||||||
{ clientHostName :: String
|
|
||||||
, clientPort :: Int
|
|
||||||
, clientPath :: String
|
|
||||||
, clientSsl :: Bool
|
|
||||||
}
|
|
||||||
|
|
||||||
parser :: Parser ClientOptions
|
|
||||||
parser = ClientOptions
|
|
||||||
<$> strArgument
|
|
||||||
( help "The name of the host to connect to"
|
|
||||||
<> metavar "HOST"
|
|
||||||
)
|
|
||||||
<*> option auto
|
|
||||||
( short 'p'
|
|
||||||
<> long "port"
|
|
||||||
<> help "The port to connect to"
|
|
||||||
<> value 11133 -- Chosen by fair dice roll
|
|
||||||
<> showDefault
|
|
||||||
<> metavar "PORT"
|
|
||||||
)
|
|
||||||
<*> strOption
|
|
||||||
( short 'P'
|
|
||||||
<> long "path"
|
|
||||||
<> help "The path to connect to on the given domain"
|
|
||||||
<> value ""
|
|
||||||
<> showDefault
|
|
||||||
<> metavar "PATH"
|
|
||||||
)
|
|
||||||
<*> flag True False -- Ssl enabled by default
|
|
||||||
( short 'n'
|
|
||||||
<> long "no-ssl"
|
|
||||||
<> help "This flag disables ssl on outgoing websocket connections"
|
|
||||||
)
|
|
||||||
|
|
||||||
keyBindings :: String
|
|
||||||
keyBindings = intercalate "\n"
|
|
||||||
[ "Key bindings:"
|
|
||||||
, " exit q, esc"
|
|
||||||
, " move cursor up/down, j/k"
|
|
||||||
, " toggle fold tab"
|
|
||||||
, " edit node e"
|
|
||||||
, " delete node d"
|
|
||||||
, " new child (reply) r"
|
|
||||||
, " new sibling R"
|
|
||||||
, " perform action a, enter, space"
|
|
||||||
, ""
|
|
||||||
, "Editor key bindings:"
|
|
||||||
, " confirm edit enter"
|
|
||||||
, " abort edit esc"
|
|
||||||
, " insert newline ctrl+n"
|
|
||||||
]
|
|
||||||
|
|
||||||
clientOptionsParserInfo :: ParserInfo ClientOptions
|
|
||||||
clientOptionsParserInfo = info (helper <*> parser)
|
|
||||||
( fullDesc
|
|
||||||
<> footerDoc (Just $ string keyBindings)
|
|
||||||
)
|
|
||||||
|
|
@ -1,292 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Forest.Client.UiState
|
|
||||||
( UiState
|
|
||||||
, newUiState
|
|
||||||
, focusedPath
|
|
||||||
, focusedNode
|
|
||||||
-- * Modifying the UI state
|
|
||||||
, replaceRootNode
|
|
||||||
, moveFocusUp
|
|
||||||
, moveFocusDown
|
|
||||||
, moveFocusToParent
|
|
||||||
, moveFocusToPrevSibling
|
|
||||||
, moveFocusToNextSibling
|
|
||||||
, moveFocusToTop
|
|
||||||
, moveFocusToBottom
|
|
||||||
, foldAtFocus
|
|
||||||
, unfoldAtFocus
|
|
||||||
, toggleFoldAtFocus
|
|
||||||
-- ** The node editor
|
|
||||||
-- *** Creating
|
|
||||||
, editCurrentNode
|
|
||||||
, replyToCurrentNode
|
|
||||||
, replyAfterCurrentNode
|
|
||||||
-- *** Updating
|
|
||||||
, isEditorActive
|
|
||||||
, updateEditor
|
|
||||||
-- *** Finishing the edit
|
|
||||||
, EditResult(..)
|
|
||||||
, finishEditing
|
|
||||||
, abortEditing
|
|
||||||
-- * Rendering the UI state
|
|
||||||
, renderUiState
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Brick
|
|
||||||
import Control.Monad
|
|
||||||
import Data.List
|
|
||||||
import Data.Maybe
|
|
||||||
import qualified Data.Set as Set
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Graphics.Vty as Vty
|
|
||||||
|
|
||||||
import Forest.Client.NodeUtil
|
|
||||||
import Forest.Client.Widgets.NodeEditor
|
|
||||||
import Forest.Client.Widgets.WidgetTree
|
|
||||||
import Forest.Node
|
|
||||||
import qualified Forest.OrderedMap as OMap
|
|
||||||
|
|
||||||
data EditorInfo n = EditorInfo
|
|
||||||
{ eiEditor :: !(NodeEditor n)
|
|
||||||
, eiPath :: !Path
|
|
||||||
, eiReply :: !Bool
|
|
||||||
} deriving (Show)
|
|
||||||
|
|
||||||
data UiState n = UiState
|
|
||||||
{ uiRootNode :: !Node
|
|
||||||
, uiFocused :: !Path
|
|
||||||
, uiUnfolded :: !Unfolded
|
|
||||||
, uiEditor :: !(Maybe (EditorInfo n))
|
|
||||||
, uiEditorName :: !n
|
|
||||||
} deriving (Show)
|
|
||||||
|
|
||||||
newUiState :: n -> Node -> UiState n
|
|
||||||
newUiState editorName node = UiState
|
|
||||||
{ uiRootNode = node
|
|
||||||
, uiFocused = mempty
|
|
||||||
, uiUnfolded = mempty
|
|
||||||
, uiEditor = Nothing
|
|
||||||
, uiEditorName = editorName
|
|
||||||
}
|
|
||||||
|
|
||||||
focusedPath :: UiState n -> Path
|
|
||||||
focusedPath = uiFocused
|
|
||||||
|
|
||||||
focusedNode :: UiState n -> Node
|
|
||||||
focusedNode s = fromMaybe rootNode $ applyPath rootNode $ uiFocused s
|
|
||||||
where
|
|
||||||
rootNode = uiRootNode s
|
|
||||||
|
|
||||||
foldedRootNode :: UiState n -> Node
|
|
||||||
foldedRootNode s = applyFolds (uiUnfolded s) (uiRootNode s)
|
|
||||||
|
|
||||||
{- Modifying -}
|
|
||||||
|
|
||||||
-- | Only keep those unfolded nodes that actually exist.
|
|
||||||
validateUnfolded :: UiState n -> UiState n
|
|
||||||
validateUnfolded s =
|
|
||||||
s {uiUnfolded = Set.filter (referencedNodeExists $ uiRootNode s) (uiUnfolded s)}
|
|
||||||
|
|
||||||
-- | Try to find the closest parent to a 'Path' that exists in the 'Node'.
|
|
||||||
findValidParent :: Node -> Path -> Path
|
|
||||||
findValidParent _ (Path []) = Path []
|
|
||||||
findValidParent node (Path (x:xs)) = case applyId node x of
|
|
||||||
Nothing -> Path []
|
|
||||||
Just child -> Path [x] <> findValidParent child (Path xs)
|
|
||||||
|
|
||||||
-- | Move to the closest valid parent as a last-ditch effort if the current
|
|
||||||
-- focus path is invalid.
|
|
||||||
validateFocused :: UiState n -> UiState n
|
|
||||||
validateFocused s =
|
|
||||||
s {uiFocused = findValidParent (foldedRootNode s) (uiFocused s)}
|
|
||||||
|
|
||||||
-- | Close the editor if it doesn't point to a valid path.
|
|
||||||
validateEditor :: UiState n -> UiState n
|
|
||||||
validateEditor s = fromMaybe s{uiEditor = Nothing} $ do
|
|
||||||
e <- uiEditor s
|
|
||||||
node <- applyPath (uiRootNode s) (eiPath e)
|
|
||||||
let flags = nodeFlags node
|
|
||||||
guard $ if eiReply e then flagReply flags else flagEdit flags
|
|
||||||
pure s
|
|
||||||
|
|
||||||
-- | Modify the UI state so it is consistent again.
|
|
||||||
validate :: UiState n -> UiState n
|
|
||||||
validate = validateEditor . validateFocused . validateUnfolded
|
|
||||||
|
|
||||||
-- | Find a node that is close to the previously focused node, taking into
|
|
||||||
-- account its previous position in the tree.
|
|
||||||
findNextValidNode :: Node -> Node -> Path -> Path
|
|
||||||
findNextValidNode _ _ (Path []) = Path []
|
|
||||||
findNextValidNode from to (Path (x:xs)) = fromMaybe (Path []) $ do
|
|
||||||
fromNode <- applyId from x
|
|
||||||
case applyId to x of
|
|
||||||
Just toNode -> pure $ Path [x] <> findNextValidNode fromNode toNode (Path xs)
|
|
||||||
Nothing -> do
|
|
||||||
fromIdx <- elemIndex x $ OMap.keys $ nodeChildren from
|
|
||||||
let toKeys = OMap.keys $ nodeChildren to
|
|
||||||
x' <- getValueClosestToIndex fromIdx toKeys
|
|
||||||
pure $ Path [x']
|
|
||||||
where
|
|
||||||
-- Slightly unsafe code, but it should be fine
|
|
||||||
getValueClosestToIndex idx list
|
|
||||||
| length list > idx = Just $ list !! idx
|
|
||||||
| null list = Nothing
|
|
||||||
| otherwise = Just $ last list
|
|
||||||
|
|
||||||
replaceRootNode :: Node -> UiState n -> UiState n
|
|
||||||
replaceRootNode node s = validate s
|
|
||||||
{ uiRootNode = node
|
|
||||||
, uiFocused = findNextValidNode (uiRootNode s) node (uiFocused s)
|
|
||||||
}
|
|
||||||
|
|
||||||
moveFocus :: (Node -> Path -> Maybe Path) -> UiState n -> UiState n
|
|
||||||
moveFocus f s = fromMaybe s $ do
|
|
||||||
newFocus <- f (foldedRootNode s) (uiFocused s)
|
|
||||||
pure $ validateFocused s{uiFocused = newFocus}
|
|
||||||
|
|
||||||
moveFocusUp :: UiState n -> UiState n
|
|
||||||
moveFocusUp = moveFocus prevNode
|
|
||||||
|
|
||||||
moveFocusDown :: UiState n -> UiState n
|
|
||||||
moveFocusDown = moveFocus nextNode
|
|
||||||
|
|
||||||
moveFocusToPrevSibling :: UiState n -> UiState n
|
|
||||||
moveFocusToPrevSibling = moveFocus prevSibling
|
|
||||||
|
|
||||||
moveFocusToNextSibling :: UiState n -> UiState n
|
|
||||||
moveFocusToNextSibling = moveFocus nextSibling
|
|
||||||
|
|
||||||
moveFocusToParent :: UiState n -> UiState n
|
|
||||||
moveFocusToParent = moveFocus $ const parent
|
|
||||||
|
|
||||||
moveFocusToTop :: UiState n -> UiState n
|
|
||||||
moveFocusToTop = moveFocus firstNode
|
|
||||||
|
|
||||||
moveFocusToBottom :: UiState n -> UiState n
|
|
||||||
moveFocusToBottom = moveFocus lastNode
|
|
||||||
|
|
||||||
foldAtFocus :: UiState n -> UiState n
|
|
||||||
foldAtFocus s =
|
|
||||||
validateUnfolded s{uiUnfolded = Set.delete (uiFocused s) (uiUnfolded s)}
|
|
||||||
|
|
||||||
unfoldAtFocus :: UiState n -> UiState n
|
|
||||||
unfoldAtFocus s =
|
|
||||||
validateUnfolded s{uiUnfolded = Set.insert (uiFocused s) (uiUnfolded s)}
|
|
||||||
|
|
||||||
toggleFoldAtFocus :: UiState n -> UiState n
|
|
||||||
toggleFoldAtFocus s = if uiFocused s `Set.member` uiUnfolded s
|
|
||||||
then foldAtFocus s
|
|
||||||
else unfoldAtFocus s
|
|
||||||
|
|
||||||
editNode :: Bool -> Path -> UiState n -> UiState n
|
|
||||||
editNode reply path s =
|
|
||||||
let text = if reply then "" else nodeText $ focusedNode s
|
|
||||||
editorInfo = EditorInfo
|
|
||||||
{ eiEditor = beginEdit (uiEditorName s) text
|
|
||||||
, eiPath = path
|
|
||||||
, eiReply = reply
|
|
||||||
}
|
|
||||||
in validateEditor s{uiEditor = Just editorInfo}
|
|
||||||
|
|
||||||
-- | Begin editing the currently focused node. Discards any current editor
|
|
||||||
-- status.
|
|
||||||
editCurrentNode :: UiState n -> UiState n
|
|
||||||
editCurrentNode s = editNode False (uiFocused s) s
|
|
||||||
|
|
||||||
-- | Reply to the currently focused node. Discards any current editor status.
|
|
||||||
replyToCurrentNode :: UiState n -> UiState n
|
|
||||||
replyToCurrentNode s = editNode True (uiFocused s) s
|
|
||||||
|
|
||||||
-- | Reply in parallel to the currently focused node, unless it is the root node
|
|
||||||
-- (in which case no action is taken).
|
|
||||||
replyAfterCurrentNode :: UiState n -> UiState n
|
|
||||||
replyAfterCurrentNode s = case parent $ uiFocused s of
|
|
||||||
Nothing -> s
|
|
||||||
Just path -> editNode True path s
|
|
||||||
|
|
||||||
isEditorActive :: UiState n -> Bool
|
|
||||||
isEditorActive = isJust . uiEditor
|
|
||||||
|
|
||||||
updateEditor :: Vty.Event -> UiState n -> EventM n (UiState n)
|
|
||||||
updateEditor ev s = case uiEditor s of
|
|
||||||
Nothing -> pure s
|
|
||||||
Just e -> do
|
|
||||||
newEditor <- handleNodeEditorEvent ev $ eiEditor e
|
|
||||||
pure s {uiEditor = Just e {eiEditor = newEditor}}
|
|
||||||
|
|
||||||
data EditResult = EditResult
|
|
||||||
{ erText :: T.Text
|
|
||||||
, erPath :: Path
|
|
||||||
, erReply :: Bool
|
|
||||||
} deriving (Show)
|
|
||||||
|
|
||||||
finishEditing :: UiState n -> (UiState n, Maybe EditResult)
|
|
||||||
finishEditing s = fromMaybe (s, Nothing) $ do
|
|
||||||
e <- uiEditor s
|
|
||||||
let editResult = EditResult
|
|
||||||
{ erText = getCurrentText $ eiEditor e
|
|
||||||
, erPath = eiPath e
|
|
||||||
, erReply = eiReply e
|
|
||||||
}
|
|
||||||
pure (abortEditing s, Just editResult)
|
|
||||||
|
|
||||||
abortEditing :: UiState n -> UiState n
|
|
||||||
abortEditing s = s{uiEditor = Nothing}
|
|
||||||
|
|
||||||
{- Rendering -}
|
|
||||||
|
|
||||||
decorateExpand :: Bool -> Widget n -> Widget n
|
|
||||||
decorateExpand True = withDefAttr "expand"
|
|
||||||
decorateExpand False = id
|
|
||||||
|
|
||||||
decorateFocus :: Bool -> Widget n -> Widget n
|
|
||||||
decorateFocus True = withDefAttr "focus"
|
|
||||||
decorateFocus False = id
|
|
||||||
|
|
||||||
decorateFlags :: NodeFlags -> Widget n -> Widget n
|
|
||||||
decorateFlags node widget =
|
|
||||||
let e = if flagEdit node then "e" else "-"
|
|
||||||
d = if flagDelete node then "d" else "-"
|
|
||||||
r = if flagReply node then "r" else "-"
|
|
||||||
a = if flagAct node then "a" else "-"
|
|
||||||
flags = "(" <> e <> d <> r <> a <> ")"
|
|
||||||
in widget <+> txt " " <+> withDefAttr "flags" (txt flags)
|
|
||||||
|
|
||||||
renderNode :: Bool -> Node -> Widget n
|
|
||||||
renderNode focused node =
|
|
||||||
decorateFlags (nodeFlags node) $
|
|
||||||
decorateFocus focused $
|
|
||||||
decorateExpand (hasChildren node) $
|
|
||||||
padRight Max text
|
|
||||||
where
|
|
||||||
-- The height of the text widget must be at least 1 for 'padRight Max' to
|
|
||||||
-- expand it. As far as I know, if the text has at least one character, it
|
|
||||||
-- also has a height of at least 1, but if it has no characters, its height
|
|
||||||
-- is 0. Because of that, we insert a filler space if the text is empty.
|
|
||||||
text
|
|
||||||
| T.null $ nodeText node = txt " "
|
|
||||||
| otherwise = txtWrap $ nodeText node
|
|
||||||
|
|
||||||
nodeToTree
|
|
||||||
:: (Ord n, Show n)
|
|
||||||
=> UiState n
|
|
||||||
-> Path
|
|
||||||
-> Node
|
|
||||||
-> Maybe [WidgetTree n]
|
|
||||||
-> WidgetTree n
|
|
||||||
nodeToTree s path node maybeChildren = case uiEditor s of
|
|
||||||
Just e | path == eiPath e ->
|
|
||||||
let renderedEditor = renderNodeEditor $ eiEditor e
|
|
||||||
in if eiReply e
|
|
||||||
then WidgetTree renderedNode $ children ++ [WidgetTree renderedEditor []]
|
|
||||||
else WidgetTree renderedEditor children
|
|
||||||
_ -> WidgetTree (visible renderedNode) children
|
|
||||||
where
|
|
||||||
renderedNode = renderNode (path == uiFocused s) node
|
|
||||||
children = fromMaybe [] maybeChildren
|
|
||||||
|
|
||||||
renderUiState :: (Ord n, Show n) => IndentOptions -> UiState n -> Widget n
|
|
||||||
renderUiState opts s =
|
|
||||||
renderWidgetTree opts $
|
|
||||||
foldVisibleNodes (nodeToTree s) (uiUnfolded s) (uiRootNode s)
|
|
||||||
|
|
@ -1,73 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Forest.Client.Websocket
|
|
||||||
( Event(..)
|
|
||||||
, runWithEventChan
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Brick.BChan
|
|
||||||
import Control.Exception
|
|
||||||
import qualified Network.WebSockets as WS
|
|
||||||
import qualified Wuss as WSS
|
|
||||||
|
|
||||||
import Forest.Api
|
|
||||||
import Forest.Client.Options
|
|
||||||
import Forest.Node
|
|
||||||
import Forest.Util
|
|
||||||
|
|
||||||
data Event
|
|
||||||
= EventNode Node
|
|
||||||
| EventConnectionClosed
|
|
||||||
|
|
||||||
performInitialContact :: WS.Connection -> IO Node
|
|
||||||
performInitialContact conn = do
|
|
||||||
-- First, the client must send a hello packet containing the protocol
|
|
||||||
-- extensions it requests.
|
|
||||||
sendPacket conn $ ClientHello []
|
|
||||||
-- Then, the server must reply with a hello packet containing the extensions
|
|
||||||
-- that will be active for this connection, and an initial node.
|
|
||||||
serverReply <- receivePacket conn
|
|
||||||
case serverReply of
|
|
||||||
(ServerHello [] node) -> pure node
|
|
||||||
-- Since the client never requests any protocol extensions, the server must
|
|
||||||
-- also reply with an empty list of extensions.
|
|
||||||
(ServerHello _ _) -> closeWithErrorMessage conn "Invalid protocol extensions"
|
|
||||||
_ -> closeWithErrorMessage conn "Invalid packet: Expected hello"
|
|
||||||
|
|
||||||
receiveUpdates :: BChan Event -> Node -> WS.Connection -> IO ()
|
|
||||||
receiveUpdates eventChan node conn = do
|
|
||||||
packet <- receivePacket conn
|
|
||||||
case packet of
|
|
||||||
ServerUpdate path subnode -> do
|
|
||||||
let node' = replaceAt subnode path node
|
|
||||||
writeBChan eventChan $ EventNode node'
|
|
||||||
receiveUpdates eventChan node' conn -- Aaand close the loop :D
|
|
||||||
_ -> closeWithErrorMessage conn "Invalid packet: Expected update"
|
|
||||||
|
|
||||||
runCorrectClient :: ClientOptions -> WS.ClientApp a -> IO a
|
|
||||||
runCorrectClient opts app
|
|
||||||
| ssl = WSS.runSecureClient name (fromInteger $ toInteger port) path app
|
|
||||||
| otherwise = WS.runClient name port path app
|
|
||||||
where
|
|
||||||
-- I found this nicer to read than (ab-)using record syntax in the arguments
|
|
||||||
name = clientHostName opts
|
|
||||||
port = clientPort opts
|
|
||||||
path = clientPath opts
|
|
||||||
ssl = clientSsl opts
|
|
||||||
|
|
||||||
sendCloseEvent :: BChan Event -> SomeException -> IO ()
|
|
||||||
sendCloseEvent eventChan e = do
|
|
||||||
putStrLn $ "Encountered exception: " ++ show e
|
|
||||||
writeBChan eventChan EventConnectionClosed
|
|
||||||
|
|
||||||
runWithEventChan :: ClientOptions -> (WS.Connection -> BChan Event -> Node -> IO ()) -> IO ()
|
|
||||||
runWithEventChan opts f = do
|
|
||||||
putStrLn "Connecting to server"
|
|
||||||
runCorrectClient opts $ \conn -> do
|
|
||||||
putStrLn "Performing initialization ritual"
|
|
||||||
node <- performInitialContact conn
|
|
||||||
chan <- newBChan 100
|
|
||||||
putStrLn "Starting WS thread"
|
|
||||||
let wsThread = handle (sendCloseEvent chan) $ receiveUpdates chan node conn
|
|
||||||
withThread wsThread $ f conn chan node
|
|
||||||
putStrLn "Connection closed and UI stopped"
|
|
||||||
|
|
@ -1,46 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Forest.Client.Widgets.NodeEditor
|
|
||||||
( NodeEditor
|
|
||||||
, getCurrentText
|
|
||||||
, beginEdit
|
|
||||||
, handleNodeEditorEvent
|
|
||||||
, renderNodeEditor
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Brick
|
|
||||||
import Brick.Widgets.Edit
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Data.Text.Zipper
|
|
||||||
import qualified Graphics.Vty as Vty
|
|
||||||
|
|
||||||
newtype NodeEditor n = NodeEditor (Editor T.Text n)
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
getCurrentLines :: NodeEditor n -> [T.Text]
|
|
||||||
getCurrentLines (NodeEditor e) = getEditContents e
|
|
||||||
|
|
||||||
getCurrentText :: NodeEditor n -> T.Text
|
|
||||||
getCurrentText = T.intercalate "\n" . getCurrentLines
|
|
||||||
|
|
||||||
beginEdit :: n -> T.Text -> NodeEditor n
|
|
||||||
beginEdit name = NodeEditor . applyEdit gotoEOL . editorText name Nothing
|
|
||||||
|
|
||||||
edit :: (TextZipper T.Text -> TextZipper T.Text) -> NodeEditor n -> EventM n (NodeEditor n)
|
|
||||||
edit z (NodeEditor e) = pure $ NodeEditor $ applyEdit z e
|
|
||||||
|
|
||||||
handleNodeEditorEvent :: Vty.Event -> NodeEditor n -> EventM n (NodeEditor n)
|
|
||||||
handleNodeEditorEvent (Vty.EvKey Vty.KHome _) ne = edit gotoBOL ne
|
|
||||||
handleNodeEditorEvent (Vty.EvKey Vty.KEnd _) ne = edit gotoEOL ne
|
|
||||||
handleNodeEditorEvent event (NodeEditor e) = NodeEditor <$> handleEditorEvent event e
|
|
||||||
|
|
||||||
renderLines :: [T.Text] -> Widget n
|
|
||||||
renderLines = vBox . map (\t -> txt $ if T.null t then " " else t)
|
|
||||||
|
|
||||||
renderNodeEditor :: (Ord n, Show n) => NodeEditor n -> Widget n
|
|
||||||
renderNodeEditor ne@(NodeEditor e) =
|
|
||||||
makeVisible $ vLimit height $ renderEditor renderLines True e
|
|
||||||
where
|
|
||||||
height = length $ getCurrentLines ne
|
|
||||||
(row, col) = cursorPosition $ editContents e
|
|
||||||
makeVisible = visibleRegion (Location (col, row)) (1, 1)
|
|
||||||
|
|
@ -1,115 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Forest.Client.Widgets.WidgetTree
|
|
||||||
( WidgetTree(..)
|
|
||||||
, renderWidgetTreeWith
|
|
||||||
, renderWidgetTree
|
|
||||||
, treeLineAttr
|
|
||||||
, IndentOptions(..)
|
|
||||||
, boxDrawingBranching
|
|
||||||
, boxDrawingLine
|
|
||||||
, asciiBranching
|
|
||||||
, asciiLine
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Brick
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Graphics.Vty as Vty
|
|
||||||
|
|
||||||
data WidgetTree n = WidgetTree (Widget n) [WidgetTree n]
|
|
||||||
|
|
||||||
indentWith :: AttrName -> T.Text -> T.Text -> Widget n -> Widget n
|
|
||||||
-- The "left" variables are for rendering the indentation text, the "right"
|
|
||||||
-- variables are for the rendered wrapped widget.
|
|
||||||
indentWith indentAttrName firstLine otherLines wrapped =
|
|
||||||
Widget (hSize wrapped) (vSize wrapped) $ do
|
|
||||||
let leftWidth = max (T.length firstLine) (T.length otherLines)
|
|
||||||
context <- getContext
|
|
||||||
rightResult <- render $ hLimit (availWidth context - leftWidth) wrapped
|
|
||||||
let rightImage = image rightResult
|
|
||||||
-- Construct the Vty image containing the indentation text
|
|
||||||
height = Vty.imageHeight rightImage
|
|
||||||
leftLines = firstLine : replicate (height - 1) otherLines
|
|
||||||
leftAttribute = attrMapLookup indentAttrName $ ctxAttrMap context
|
|
||||||
leftImage = Vty.vertCat $ map (Vty.text' leftAttribute) leftLines
|
|
||||||
-- Add the indentation text to the left of the result image
|
|
||||||
combinedImage = leftImage Vty.<|> image rightResult
|
|
||||||
offset = Location (leftWidth, 0)
|
|
||||||
result = (addResultOffset offset rightResult) {image=combinedImage}
|
|
||||||
pure result
|
|
||||||
|
|
||||||
indent :: AttrName -> IndentOptions -> [Widget n] -> Widget n
|
|
||||||
indent indentAttrName opts widgets = vBox $ reverse $ case reverse widgets of
|
|
||||||
[] -> []
|
|
||||||
(w:ws) ->
|
|
||||||
indentWith indentAttrName (indentLastNodeFirstLine opts) (indentLastNodeRest opts) w :
|
|
||||||
map (indentWith indentAttrName (indentNodeFirstLine opts) (indentNodeRest opts)) ws
|
|
||||||
|
|
||||||
renderWidgetTreeWith :: AttrName -> IndentOptions -> WidgetTree n -> Widget n
|
|
||||||
renderWidgetTreeWith indentAttrName opts (WidgetTree node children) =
|
|
||||||
node <=> indent indentAttrName opts (map (renderWidgetTreeWith indentAttrName opts) children)
|
|
||||||
|
|
||||||
renderWidgetTree :: IndentOptions -> WidgetTree n -> Widget n
|
|
||||||
renderWidgetTree = renderWidgetTreeWith treeLineAttr
|
|
||||||
|
|
||||||
-- | The attribute that 'renderWidgetTree' uses.
|
|
||||||
treeLineAttr :: AttrName
|
|
||||||
treeLineAttr = "treeLine"
|
|
||||||
|
|
||||||
-- | These options control how a tree is rendered.
|
|
||||||
--
|
|
||||||
-- In the following example, the indent options are set to @'IndentOptions' "a" "b" "c" "d"@:
|
|
||||||
--
|
|
||||||
-- > a This is the first node.
|
|
||||||
-- > b c It has a child.
|
|
||||||
-- > a This is a...
|
|
||||||
-- > b multiline...
|
|
||||||
-- > b node.
|
|
||||||
-- > c This is the last node.
|
|
||||||
-- > d c It has one child.
|
|
||||||
-- > d c And another one.
|
|
||||||
--
|
|
||||||
-- Warning: The options /must/ be single line strings and /must not/ contain
|
|
||||||
-- newlines of any sort.
|
|
||||||
data IndentOptions = IndentOptions
|
|
||||||
{ indentNodeFirstLine :: T.Text
|
|
||||||
-- ^ This is prepended to the first line of a node.
|
|
||||||
, indentNodeRest :: T.Text
|
|
||||||
-- ^ This is prepended to all other lines of a node, including its subnodes.
|
|
||||||
, indentLastNodeFirstLine :: T.Text
|
|
||||||
-- ^ This is prepended to the first line of the last node.
|
|
||||||
, indentLastNodeRest :: T.Text
|
|
||||||
-- ^ This is prepended to all other lines of the last node, including its subnodes.
|
|
||||||
} deriving (Show, Eq)
|
|
||||||
|
|
||||||
boxDrawingBranching :: IndentOptions
|
|
||||||
boxDrawingBranching = IndentOptions
|
|
||||||
{ indentNodeFirstLine = "├╴"
|
|
||||||
, indentNodeRest = "│ "
|
|
||||||
, indentLastNodeFirstLine = "└╴"
|
|
||||||
, indentLastNodeRest = " "
|
|
||||||
}
|
|
||||||
|
|
||||||
boxDrawingLine :: IndentOptions
|
|
||||||
boxDrawingLine = IndentOptions
|
|
||||||
{ indentNodeFirstLine = "│ "
|
|
||||||
, indentNodeRest = "│ "
|
|
||||||
, indentLastNodeFirstLine = "│ "
|
|
||||||
, indentLastNodeRest = "│ "
|
|
||||||
}
|
|
||||||
|
|
||||||
asciiBranching :: IndentOptions
|
|
||||||
asciiBranching = IndentOptions
|
|
||||||
{ indentNodeFirstLine = "+-"
|
|
||||||
, indentNodeRest = "| "
|
|
||||||
, indentLastNodeFirstLine = "+-"
|
|
||||||
, indentLastNodeRest = " "
|
|
||||||
}
|
|
||||||
|
|
||||||
asciiLine :: IndentOptions
|
|
||||||
asciiLine = IndentOptions
|
|
||||||
{ indentNodeFirstLine = "| "
|
|
||||||
, indentNodeRest = "| "
|
|
||||||
, indentLastNodeFirstLine = "| "
|
|
||||||
, indentLastNodeRest = "| "
|
|
||||||
}
|
|
||||||
|
|
@ -1,67 +0,0 @@
|
||||||
<!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>
|
|
||||||
|
|
@ -1,39 +0,0 @@
|
||||||
<!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>
|
|
||||||
|
|
@ -1,76 +0,0 @@
|
||||||
html {
|
|
||||||
/* My terminal's color scheme */
|
|
||||||
--background: #000000;
|
|
||||||
--foreground: #babdb6;
|
|
||||||
--black: #2e3436;
|
|
||||||
--bright-black: #555753;
|
|
||||||
--red: #cc0000;
|
|
||||||
--bright-red: #ef2929;
|
|
||||||
--green: #4e9a06;
|
|
||||||
--bright-green: #8ae234;
|
|
||||||
--yellow: #c4a000;
|
|
||||||
--bright-yellow: #fce94f;
|
|
||||||
--blue: #3465a4;
|
|
||||||
--bright-blue: #729fcf;
|
|
||||||
--magenta: #75507b;
|
|
||||||
--bright-magenta: #ad7fa8;
|
|
||||||
--cyan: #06989a;
|
|
||||||
--bright-cyan: #34e2e2;
|
|
||||||
--white: #d3d7cf;
|
|
||||||
--bright-white: #eeeeec;
|
|
||||||
|
|
||||||
font-family: monospace;
|
|
||||||
font-size: 16px;
|
|
||||||
color: var(--foreground);
|
|
||||||
background-color: var(--background);
|
|
||||||
}
|
|
||||||
body {
|
|
||||||
max-width: 1024px;
|
|
||||||
margin: 0 auto;
|
|
||||||
padding: 2em;
|
|
||||||
}
|
|
||||||
h1, h2, h3, h4, h5, h6 {
|
|
||||||
color: var(--white);
|
|
||||||
margin-top: 1.5em;
|
|
||||||
}
|
|
||||||
h1 {
|
|
||||||
margin-top: 0;
|
|
||||||
font-size: 2em;
|
|
||||||
}
|
|
||||||
h2 {
|
|
||||||
text-decoration: underline;
|
|
||||||
}
|
|
||||||
a {
|
|
||||||
color: var(--bright-blue);
|
|
||||||
}
|
|
||||||
a:visited {
|
|
||||||
color: var(--bright-magenta);
|
|
||||||
}
|
|
||||||
/* Input elements */
|
|
||||||
input[type="checkbox"] {
|
|
||||||
display: none;
|
|
||||||
}
|
|
||||||
input[type="checkbox"] + label::before {
|
|
||||||
content: "[_] ";
|
|
||||||
font-weight: bold;
|
|
||||||
}
|
|
||||||
input[type="checkbox"]:checked + label::before {
|
|
||||||
content: "[X] ";
|
|
||||||
}
|
|
||||||
button, textarea {
|
|
||||||
font-family: inherit;
|
|
||||||
font-size: inherit;
|
|
||||||
color: inherit;
|
|
||||||
background-color: inherit;
|
|
||||||
margin: 0;
|
|
||||||
padding: 0;
|
|
||||||
border: none;
|
|
||||||
outline: none;
|
|
||||||
}
|
|
||||||
button {
|
|
||||||
font-weight: bold;
|
|
||||||
}
|
|
||||||
textarea {
|
|
||||||
color: var(--foreground);
|
|
||||||
background-color: var(--bright-black);
|
|
||||||
}
|
|
||||||
|
|
@ -1,71 +0,0 @@
|
||||||
.node-line {
|
|
||||||
display: flex;
|
|
||||||
}
|
|
||||||
.node-text {
|
|
||||||
flex-grow: 1;
|
|
||||||
}
|
|
||||||
.node-permissions {
|
|
||||||
color: var(--bright-black);
|
|
||||||
margin-left: 1ch;
|
|
||||||
}
|
|
||||||
.node textarea {
|
|
||||||
width: 100%;
|
|
||||||
resize: none;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Special display states a node can be in */
|
|
||||||
.has-children > .node-line > .node-text {
|
|
||||||
font-weight: bold;
|
|
||||||
color: var(--yellow);
|
|
||||||
}
|
|
||||||
.has-cursor > .node-line > .node-text {
|
|
||||||
background-color: var(--blue);
|
|
||||||
}
|
|
||||||
.has-editor > .node-line {
|
|
||||||
display: none;
|
|
||||||
}
|
|
||||||
.is-folded > .node-children {
|
|
||||||
display: none;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Fancy tree lines */
|
|
||||||
.node-children > *, .node-children > *::before {
|
|
||||||
border-color: var(--bright-black);
|
|
||||||
border-width: 2px;
|
|
||||||
}
|
|
||||||
.node-children > * {
|
|
||||||
position: relative; /* .node is containing block for its .node::before */
|
|
||||||
margin-left: calc(0.5ch - 1px);
|
|
||||||
padding-left: calc(1.5ch - 1px);
|
|
||||||
border-left-style: solid;
|
|
||||||
}
|
|
||||||
.node-children > *:last-child {
|
|
||||||
padding-left: calc(1.5ch + 1px);
|
|
||||||
border-left-style: none;
|
|
||||||
}
|
|
||||||
.node-children > *::before {
|
|
||||||
content: "";
|
|
||||||
position: absolute;
|
|
||||||
left: 0;
|
|
||||||
top: 0;
|
|
||||||
width: calc(1ch - 1px);
|
|
||||||
height: calc(0.6em - 1px);
|
|
||||||
border-bottom-style: solid;
|
|
||||||
}
|
|
||||||
.node-children > *:last-child::before {
|
|
||||||
border-left-style: solid;
|
|
||||||
transition: border-bottom-left-radius 0.4s;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Curvy lines */
|
|
||||||
.curvy .node-children > *:last-child, .curvy .node-children > *:last-child::before {
|
|
||||||
border-bottom-left-radius: 6px;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* About link in bottom right corner */
|
|
||||||
#about {
|
|
||||||
position: fixed;
|
|
||||||
bottom: 0;
|
|
||||||
right: 0;
|
|
||||||
margin: 1ch;
|
|
||||||
}
|
|
||||||
|
|
@ -1,684 +0,0 @@
|
||||||
"use strict";
|
|
||||||
|
|
||||||
/*
|
|
||||||
* Utility functions
|
|
||||||
*/
|
|
||||||
|
|
||||||
function removeAllChildren(element) {
|
|
||||||
while (element.firstChild) {
|
|
||||||
element.removeChild(element.lastChild);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
// Create a new DOM element.
|
|
||||||
// 'classes' can either be a string or a list of strings.
|
|
||||||
// A child can either be a string or a DOM element.
|
|
||||||
function newElement(type, classes, ...children) {
|
|
||||||
let e = document.createElement(type);
|
|
||||||
|
|
||||||
if (classes !== undefined) {
|
|
||||||
if (typeof classes == "string") {
|
|
||||||
e.classList.add(classes);
|
|
||||||
} else if (classes instanceof Array) {
|
|
||||||
e.classList.add(...classes);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
children.forEach(child => {
|
|
||||||
if (typeof child == "string") {
|
|
||||||
e.appendChild(document.createTextNode(child));
|
|
||||||
} else {
|
|
||||||
e.appendChild(child);
|
|
||||||
}
|
|
||||||
});
|
|
||||||
|
|
||||||
return e;
|
|
||||||
}
|
|
||||||
|
|
||||||
/*
|
|
||||||
* Classes
|
|
||||||
*/
|
|
||||||
|
|
||||||
// Enum representing useful positions relative to a node.
|
|
||||||
const RelPos = Object.freeze({
|
|
||||||
FIRST_CHILD: 1,
|
|
||||||
NEXT_SIBLING: 2,
|
|
||||||
});
|
|
||||||
|
|
||||||
class Path {
|
|
||||||
constructor(...components) {
|
|
||||||
this._components = components.slice();
|
|
||||||
}
|
|
||||||
|
|
||||||
get components() {
|
|
||||||
return this._components.slice();
|
|
||||||
}
|
|
||||||
|
|
||||||
get length() {
|
|
||||||
return this._components.length;
|
|
||||||
}
|
|
||||||
|
|
||||||
get last() {
|
|
||||||
return this._components[this.length - 1];
|
|
||||||
}
|
|
||||||
|
|
||||||
get parent() {
|
|
||||||
if (this.length === 0) return undefined;
|
|
||||||
return new Path(...this._components.slice(0, this.length - 1));
|
|
||||||
}
|
|
||||||
|
|
||||||
append(nodeId) {
|
|
||||||
return new Path(...this._components.concat([nodeId]));
|
|
||||||
}
|
|
||||||
|
|
||||||
concat(otherPath) {
|
|
||||||
return new Path(...this._components.concat(otherPath._components));
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
class NodeElements {
|
|
||||||
constructor() {
|
|
||||||
this._elText = newElement("span", "node-text");
|
|
||||||
this._elPermissions = newElement("span", "node-permissions");
|
|
||||||
this._elChildren = newElement("div", "node-children");
|
|
||||||
|
|
||||||
let line = newElement("div", "node-line", this._elText, this._elPermissions);
|
|
||||||
this._elMain = newElement("div", ["node", "is-folded"], line, this._elChildren);
|
|
||||||
}
|
|
||||||
|
|
||||||
get text() {
|
|
||||||
return this._elText.textContent;
|
|
||||||
}
|
|
||||||
|
|
||||||
set text(text) {
|
|
||||||
this._elText.textContent = text;
|
|
||||||
}
|
|
||||||
|
|
||||||
set permissions(perms) {
|
|
||||||
this._elPermissions.textContent = perms.asText;
|
|
||||||
}
|
|
||||||
|
|
||||||
get hasChildren() {
|
|
||||||
return this._elMain.classList.contains("has-children");
|
|
||||||
}
|
|
||||||
|
|
||||||
set hasChildren(flag) {
|
|
||||||
return this._elMain.classList.toggle("has-children", flag);
|
|
||||||
}
|
|
||||||
|
|
||||||
removeAllChildren() {
|
|
||||||
removeAllChildren(this._elChildren);
|
|
||||||
}
|
|
||||||
|
|
||||||
addChild(child) {
|
|
||||||
this._elChildren.appendChild(child._elMain);
|
|
||||||
}
|
|
||||||
|
|
||||||
appendTo(element) {
|
|
||||||
element.appendChild(this._elMain);
|
|
||||||
}
|
|
||||||
|
|
||||||
get folded() {
|
|
||||||
return this._elMain.classList.contains("is-folded");
|
|
||||||
}
|
|
||||||
|
|
||||||
set folded(flag) {
|
|
||||||
this._elMain.classList.toggle("is-folded", flag);
|
|
||||||
}
|
|
||||||
|
|
||||||
toggleFolded() {
|
|
||||||
this.folded = !this.folded;
|
|
||||||
}
|
|
||||||
|
|
||||||
get hasCursor() {
|
|
||||||
return this._elMain.classList.contains("has-cursor");
|
|
||||||
}
|
|
||||||
|
|
||||||
set hasCursor(flag) {
|
|
||||||
return this._elMain.classList.toggle("has-cursor", flag);
|
|
||||||
}
|
|
||||||
|
|
||||||
get hasEditor() {
|
|
||||||
return this._elMain.classList.contains("has-editor");
|
|
||||||
}
|
|
||||||
|
|
||||||
set hasEditor(flag) {
|
|
||||||
return this._elMain.classList.toggle("has-editor", flag);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
class NodePermissions {
|
|
||||||
constructor(edit, delete_, reply, act) {
|
|
||||||
this._edit = edit;
|
|
||||||
this._delete = delete_;
|
|
||||||
this._reply = reply;
|
|
||||||
this._act = act;
|
|
||||||
}
|
|
||||||
|
|
||||||
get edit() {
|
|
||||||
return this._edit;
|
|
||||||
}
|
|
||||||
|
|
||||||
get delete() {
|
|
||||||
return this._delete;
|
|
||||||
}
|
|
||||||
|
|
||||||
get reply() {
|
|
||||||
return this._reply;
|
|
||||||
}
|
|
||||||
|
|
||||||
get act() {
|
|
||||||
return this._act;
|
|
||||||
}
|
|
||||||
|
|
||||||
get asText() {
|
|
||||||
return [
|
|
||||||
"(",
|
|
||||||
this.edit ? "e" : "-",
|
|
||||||
this.delete ? "d" : "-",
|
|
||||||
this.reply ? "r" : "-",
|
|
||||||
this.act ? "a" : "-",
|
|
||||||
")"
|
|
||||||
].join("");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
class Node {
|
|
||||||
constructor(nodeJson) {
|
|
||||||
this._el = undefined;
|
|
||||||
|
|
||||||
this._text = nodeJson.text;
|
|
||||||
|
|
||||||
this._permissions = new NodePermissions(
|
|
||||||
nodeJson.edit,
|
|
||||||
nodeJson.delete,
|
|
||||||
nodeJson.reply,
|
|
||||||
nodeJson.act,
|
|
||||||
);
|
|
||||||
|
|
||||||
this._children = new Map();
|
|
||||||
this._order = nodeJson.order;
|
|
||||||
this._order.forEach(childId => {
|
|
||||||
let childJson = nodeJson.children[childId];
|
|
||||||
let childNode = new Node(childJson);
|
|
||||||
this._children.set(childId, childNode);
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
child(childId) {
|
|
||||||
return this._children.get(childId);
|
|
||||||
}
|
|
||||||
|
|
||||||
get order() {
|
|
||||||
return this._order.slice();
|
|
||||||
}
|
|
||||||
|
|
||||||
// Only replaces existing children. Does not add new children.
|
|
||||||
replaceChild(childId, newChild) {
|
|
||||||
let oldChild = this.child(childId);
|
|
||||||
if (oldChild === undefined) return;
|
|
||||||
newChild.obtainElements(oldChild);
|
|
||||||
this._children.set(childId, newChild);
|
|
||||||
}
|
|
||||||
|
|
||||||
// Obtain and update this node's DOM elements. After this call, this.el
|
|
||||||
// represents the current node's contents.
|
|
||||||
//
|
|
||||||
// This function may optionally be called with an old node. If that node or
|
|
||||||
// its children already has existing DOM elements, they are repurposed.
|
|
||||||
// Otherwise, new DOM elements are created.
|
|
||||||
obtainElements(oldNode) {
|
|
||||||
if (this._el === undefined) {
|
|
||||||
// Obtain DOM elements because we don't yet have any
|
|
||||||
if (oldNode === undefined || oldNode._el === undefined) {
|
|
||||||
this._el = new NodeElements();
|
|
||||||
} else {
|
|
||||||
this._el = oldNode._el;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
this._el.text = this._text;
|
|
||||||
this._el.permissions = this._permissions;
|
|
||||||
this._el.hasChildren = this.order.length > 0;
|
|
||||||
|
|
||||||
this._el.removeAllChildren();
|
|
||||||
|
|
||||||
let oldChildren = (oldNode === undefined) ? new Map() : oldNode._children;
|
|
||||||
this._order.forEach(childId => {
|
|
||||||
let oldChild = oldChildren.get(childId); // May be undefined
|
|
||||||
let child = this._children.get(childId); // Not undefined
|
|
||||||
child.obtainElements(oldChild);
|
|
||||||
this._el.addChild(child._el);
|
|
||||||
});
|
|
||||||
}
|
|
||||||
|
|
||||||
// Wrapper functions for this._el
|
|
||||||
|
|
||||||
appendTo(element) {
|
|
||||||
if (this._el === undefined) this.obtainElements();
|
|
||||||
this._el.appendTo(element);
|
|
||||||
}
|
|
||||||
|
|
||||||
get folded() {
|
|
||||||
if (this._el === undefined) return undefined;
|
|
||||||
return this._el.folded;
|
|
||||||
}
|
|
||||||
|
|
||||||
set folded(flag) {
|
|
||||||
if (this._el === undefined) return;
|
|
||||||
this._el.folded = flag;
|
|
||||||
}
|
|
||||||
|
|
||||||
toggleFolded() {
|
|
||||||
if (this._el === undefined) return;
|
|
||||||
this._el.toggleFolded();
|
|
||||||
}
|
|
||||||
|
|
||||||
get hasCursor() {
|
|
||||||
if (this._el === undefined) return undefined;
|
|
||||||
return this._el.hasCursor;
|
|
||||||
}
|
|
||||||
|
|
||||||
set hasCursor(flag) {
|
|
||||||
if (this._el === undefined) return;
|
|
||||||
this._el.hasCursor = flag;
|
|
||||||
}
|
|
||||||
|
|
||||||
get hasEditor() {
|
|
||||||
if (this._el === undefined) return undefined;
|
|
||||||
return this._el.hasEditor;
|
|
||||||
}
|
|
||||||
|
|
||||||
set hasEditor(flag) {
|
|
||||||
if (this._el === undefined) return;
|
|
||||||
this._el.hasEditor = flag;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
class NodeTree {
|
|
||||||
constructor(rootNodeContainer, rootNode) {
|
|
||||||
this._rootNodeContainer = rootNodeContainer;
|
|
||||||
this._rootNode = rootNode;
|
|
||||||
|
|
||||||
// Prepare root node container
|
|
||||||
removeAllChildren(this._rootNodeContainer);
|
|
||||||
this._rootNode.appendTo(this._rootNodeContainer);
|
|
||||||
}
|
|
||||||
|
|
||||||
at(path) {
|
|
||||||
let node = this._rootNode;
|
|
||||||
for (let childId of path.components) {
|
|
||||||
node = node.child(childId);
|
|
||||||
if (node === undefined) break;
|
|
||||||
}
|
|
||||||
return node;
|
|
||||||
}
|
|
||||||
|
|
||||||
updateAt(path, newNode) {
|
|
||||||
if (path.length === 0) {
|
|
||||||
newNode.obtainElements(this._rootNode);
|
|
||||||
this._rootNode = newNode;
|
|
||||||
} else {
|
|
||||||
let parentNode = this.at(path.parent);
|
|
||||||
parentNode.replaceChild(path.last, newNode);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
getChildWith(path, f) {
|
|
||||||
let node = this.at(path);
|
|
||||||
if (node === undefined) return undefined;
|
|
||||||
let index = f(node.order.length);
|
|
||||||
if (index === undefined) return undefined;
|
|
||||||
let childId = node.order[index];
|
|
||||||
if (childId === undefined) return undefined;
|
|
||||||
return path.append(childId);
|
|
||||||
}
|
|
||||||
|
|
||||||
getFirstChild(path) {
|
|
||||||
return this.getChildWith(path, l => 0);
|
|
||||||
}
|
|
||||||
|
|
||||||
getLastChild(path) {
|
|
||||||
return this.getChildWith(path, l => l - 1);
|
|
||||||
}
|
|
||||||
|
|
||||||
getSiblingWith(path, f) {
|
|
||||||
if (path.parent === undefined) return undefined;
|
|
||||||
let parentNode = this.at(path.parent);
|
|
||||||
if (parentNode === undefined) return undefined;
|
|
||||||
|
|
||||||
let index = parentNode.order.indexOf(path.last);
|
|
||||||
if (index === undefined) return undefined;
|
|
||||||
let newIndex = f(index);
|
|
||||||
if (newIndex === undefined) return undefined;
|
|
||||||
let siblingId = parentNode.order[newIndex];
|
|
||||||
if (siblingId === undefined) return undefined;
|
|
||||||
|
|
||||||
return path.parent.append(siblingId);
|
|
||||||
}
|
|
||||||
|
|
||||||
getPrevSibling(path) {
|
|
||||||
return this.getSiblingWith(path, i => i - 1);
|
|
||||||
}
|
|
||||||
|
|
||||||
getNextSibling(path) {
|
|
||||||
return this.getSiblingWith(path, i => i + 1);
|
|
||||||
}
|
|
||||||
|
|
||||||
getNodeAbove(path) {
|
|
||||||
let prevPath = this.getPrevSibling(path);
|
|
||||||
if (prevPath === undefined) return path.parent;
|
|
||||||
|
|
||||||
// Get last child of previous path
|
|
||||||
while (true) {
|
|
||||||
let prevNode = this.at(prevPath);
|
|
||||||
if (prevNode.folded) return prevPath;
|
|
||||||
|
|
||||||
let childPath = this.getLastChild(prevPath);
|
|
||||||
if (childPath === undefined) return prevPath;
|
|
||||||
|
|
||||||
prevPath = childPath;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
getNodeBelow(path) {
|
|
||||||
let node = this.at(path);
|
|
||||||
if (!node.folded) {
|
|
||||||
let childPath = this.getFirstChild(path);
|
|
||||||
if (childPath !== undefined) return childPath;
|
|
||||||
}
|
|
||||||
|
|
||||||
while (path !== undefined) {
|
|
||||||
let nextPath = this.getNextSibling(path);
|
|
||||||
if (nextPath !== undefined) return nextPath;
|
|
||||||
path = path.parent;
|
|
||||||
}
|
|
||||||
|
|
||||||
return undefined;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
class Cursor {
|
|
||||||
constructor(nodeTree) {
|
|
||||||
this._nodeTree = nodeTree;
|
|
||||||
|
|
||||||
this._path = new Path();
|
|
||||||
this._relPos = null; // Either null or a RelPos value
|
|
||||||
|
|
||||||
this.restore();
|
|
||||||
}
|
|
||||||
|
|
||||||
getSelectedNode() {
|
|
||||||
return this._nodeTree.at(this._path);
|
|
||||||
}
|
|
||||||
|
|
||||||
_applyRelPos() {
|
|
||||||
if (this._relPos === null) return;
|
|
||||||
|
|
||||||
let newPath;
|
|
||||||
if (this._relPos === RelPos.FIRST_CHILD) {
|
|
||||||
newPath = this._nodeTree.getFirstChild(this._path);
|
|
||||||
} else if (this._relPos === RelPos.NEXT_SIBLING) {
|
|
||||||
newPath = this._nodeTree.getNextSibling(this._path);
|
|
||||||
}
|
|
||||||
|
|
||||||
if (newPath !== undefined) {
|
|
||||||
this._path = newPath;
|
|
||||||
this._relPos = null;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
_moveToNearestValidNode() {
|
|
||||||
// TODO Maybe select a sibling instead of going to nearest visible parent
|
|
||||||
let path = new Path();
|
|
||||||
for (let component of this._path.components) {
|
|
||||||
let newPath = path.append(component);
|
|
||||||
let newNode = this._nodeTree.at(newPath);
|
|
||||||
if (newNode === undefined) break;
|
|
||||||
if (newNode.folded) break;
|
|
||||||
path = newPath;
|
|
||||||
}
|
|
||||||
this._path = path;
|
|
||||||
}
|
|
||||||
|
|
||||||
_set(visible) {
|
|
||||||
this.getSelectedNode().hasCursor = visible;
|
|
||||||
}
|
|
||||||
|
|
||||||
restore() {
|
|
||||||
this._applyRelPos();
|
|
||||||
this._moveToNearestValidNode();
|
|
||||||
this._set(true);
|
|
||||||
}
|
|
||||||
|
|
||||||
moveTo(path) {
|
|
||||||
if (path === undefined) return;
|
|
||||||
this._set(false);
|
|
||||||
this._path = path;
|
|
||||||
this._set(true);
|
|
||||||
}
|
|
||||||
|
|
||||||
moveUp() {
|
|
||||||
this.moveTo(this._nodeTree.getNodeAbove(this._path));
|
|
||||||
}
|
|
||||||
|
|
||||||
moveDown() {
|
|
||||||
this.moveTo(this._nodeTree.getNodeBelow(this._path));
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
class Editor {
|
|
||||||
constructor(nodeTree) {
|
|
||||||
this._nodeTree = nodeTree;
|
|
||||||
|
|
||||||
this._elTextarea = newElement("textarea");
|
|
||||||
this._elTextarea.addEventListener("input", event => this._updateTextAreaHeight());
|
|
||||||
this._elMain = newElement("div", "node-editor", this.textarea);
|
|
||||||
|
|
||||||
this._path = undefined;
|
|
||||||
this._asChild = false;
|
|
||||||
}
|
|
||||||
|
|
||||||
_updateTextAreaHeight() {
|
|
||||||
this._elTextarea.style.height = 0;
|
|
||||||
this._elTextarea.style.height = this._elTextarea.scrollHeight + "px";
|
|
||||||
}
|
|
||||||
|
|
||||||
_getAttachedNode() {
|
|
||||||
if (this._path === undefined) return undefined;
|
|
||||||
return this._nodeTree.at(this._path);
|
|
||||||
}
|
|
||||||
|
|
||||||
_detach(node, asChild) {
|
|
||||||
if (!asChild) {
|
|
||||||
node.hasEditor = false;
|
|
||||||
}
|
|
||||||
|
|
||||||
this._elMain.parentNode.removeChild(this._elMain);
|
|
||||||
}
|
|
||||||
|
|
||||||
_attachTo(node, asChild) {
|
|
||||||
if (asChild) {
|
|
||||||
node._el._elChildren.appendChild(this.element);
|
|
||||||
node.folded = false;
|
|
||||||
} else {
|
|
||||||
node._el._elMain.classList.add("has-editor");
|
|
||||||
node._el._elMain.insertBefore(this.element, node._el._elChildren);
|
|
||||||
}
|
|
||||||
this._updateTextAreaHeight();
|
|
||||||
}
|
|
||||||
|
|
||||||
restore() {
|
|
||||||
if (this.element.parentNode !== null) return; // Already attached
|
|
||||||
let node = this._getAttachedNode();
|
|
||||||
if (node === undefined) return; // Nowhere to attach
|
|
||||||
this._attachTo(node, this.asChild);
|
|
||||||
}
|
|
||||||
|
|
||||||
attachTo(path, asChild) {
|
|
||||||
this.detach();
|
|
||||||
this.path = path;
|
|
||||||
this.asChild = asChild;
|
|
||||||
this.restore();
|
|
||||||
|
|
||||||
this.textarea.focus();
|
|
||||||
let length = this.textarea.value.length;
|
|
||||||
this.textarea.setSelectionRange(length, length);
|
|
||||||
}
|
|
||||||
|
|
||||||
detach() {
|
|
||||||
let node = this._getAttachedNode();
|
|
||||||
if (node === undefined) return;
|
|
||||||
this._detach(node, this.asChild);
|
|
||||||
this.path = undefined;
|
|
||||||
}
|
|
||||||
|
|
||||||
set content(text) {
|
|
||||||
this.textarea.value = text;
|
|
||||||
}
|
|
||||||
|
|
||||||
get content() {
|
|
||||||
return this.textarea.value;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
class Connection {
|
|
||||||
constructor(nodeTree, cursor, editor, url) {
|
|
||||||
this.nodeTree = nodeTree;
|
|
||||||
this.cursor = cursor;
|
|
||||||
this.editor = editor;
|
|
||||||
|
|
||||||
this.url = url;
|
|
||||||
this.ws = new WebSocket(this.url);
|
|
||||||
this.ws.addEventListener("message", msg => this.onMessage(msg));
|
|
||||||
this.ws.addEventListener("open", _ => this.sendHello());
|
|
||||||
}
|
|
||||||
|
|
||||||
onMessage(msg) {
|
|
||||||
let content = JSON.parse(msg.data);
|
|
||||||
if (content.type === "hello") {
|
|
||||||
this.onHello(content);
|
|
||||||
} else if (content.type === "update") {
|
|
||||||
this.onUpdate(content);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
onHello(content) {
|
|
||||||
this.nodeTree.updateAt(new Path(), new Node(content.node));
|
|
||||||
this.cursor.restore();
|
|
||||||
this.editor.restore();
|
|
||||||
}
|
|
||||||
|
|
||||||
onUpdate(content) {
|
|
||||||
this.nodeTree.updateAt(new Path(...content.path), new Node(content.node));
|
|
||||||
this.cursor.restore();
|
|
||||||
this.editor.restore();
|
|
||||||
}
|
|
||||||
|
|
||||||
_send(thing) {
|
|
||||||
this.ws.send(JSON.stringify(thing));
|
|
||||||
}
|
|
||||||
|
|
||||||
sendHello() {
|
|
||||||
this._send({type: "hello", extensions: []});
|
|
||||||
}
|
|
||||||
|
|
||||||
sendEdit(path, text) {
|
|
||||||
this._send({type: "edit", path: path.components, text: text});
|
|
||||||
}
|
|
||||||
|
|
||||||
sendDelete(path) {
|
|
||||||
this._send({type: "delete", path: path.components});
|
|
||||||
}
|
|
||||||
|
|
||||||
sendReply(path, text) {
|
|
||||||
this._send({type: "reply", path: path.components, text: text});
|
|
||||||
}
|
|
||||||
|
|
||||||
sendAct(path) {
|
|
||||||
this._send({type: "act", path: path.components});
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
/*
|
|
||||||
* The main application
|
|
||||||
*/
|
|
||||||
|
|
||||||
const rootNodeContainer = document.getElementById("root-node-container");
|
|
||||||
const loadingNode = new Node({text: "Connecting...", children: {}, order: []});
|
|
||||||
const nodeTree = new NodeTree(rootNodeContainer, loadingNode);
|
|
||||||
const cursor = new Cursor(nodeTree);
|
|
||||||
const editor = new Editor(nodeTree);
|
|
||||||
const conn = new Connection(nodeTree, cursor, editor, "ws://127.0.0.1:8080/");
|
|
||||||
|
|
||||||
function beginEdit() {
|
|
||||||
let node = cursor.getSelectedNode();
|
|
||||||
editor.content = node.text;
|
|
||||||
editor.attachTo(cursor.path, false);
|
|
||||||
}
|
|
||||||
|
|
||||||
function beginDirectReply() {
|
|
||||||
editor.content = "";
|
|
||||||
editor.attachTo(cursor.path, true);
|
|
||||||
}
|
|
||||||
|
|
||||||
function beginIndirectReply() {
|
|
||||||
let path = cursor.path.parent;
|
|
||||||
if (path === undefined) return;
|
|
||||||
editor.content = "";
|
|
||||||
editor.attachTo(path, true);
|
|
||||||
}
|
|
||||||
|
|
||||||
function cancelEdit() {
|
|
||||||
editor.detach();
|
|
||||||
}
|
|
||||||
|
|
||||||
function completeEdit() {
|
|
||||||
let path = editor.path;
|
|
||||||
let text = editor.textarea.value;
|
|
||||||
if (editor.asChild) {
|
|
||||||
conn.sendReply(path, text);
|
|
||||||
} else {
|
|
||||||
conn.sendEdit(path, text);
|
|
||||||
}
|
|
||||||
editor.detach();
|
|
||||||
}
|
|
||||||
|
|
||||||
document.addEventListener("keydown", event => {
|
|
||||||
if (event.code === "Escape") {
|
|
||||||
cancelEdit();
|
|
||||||
event.preventDefault();
|
|
||||||
} else if (event.code === "Enter" && !event.shiftKey) {
|
|
||||||
completeEdit();
|
|
||||||
event.preventDefault();
|
|
||||||
} else if (document.activeElement.tagName === "TEXTAREA") {
|
|
||||||
return; // Do nothing special
|
|
||||||
} else if (event.code === "Tab") {
|
|
||||||
cursor.getSelectedNode().toggleFolded();
|
|
||||||
event.preventDefault();
|
|
||||||
} else if (event.code === "KeyK" || event.code === "ArrowUp") {
|
|
||||||
cursor.moveUp();
|
|
||||||
event.preventDefault();
|
|
||||||
} else if (event.code === "KeyJ" || event.code === "ArrowDown") {
|
|
||||||
cursor.moveDown();
|
|
||||||
event.preventDefault();
|
|
||||||
} else if (event.code === "KeyE") {
|
|
||||||
beginEdit();
|
|
||||||
event.preventDefault();
|
|
||||||
} else if (event.code === "KeyR") {
|
|
||||||
if (event.shiftKey) {
|
|
||||||
console.log("indirect");
|
|
||||||
beginIndirectReply();
|
|
||||||
} else {
|
|
||||||
console.log("direct");
|
|
||||||
beginDirectReply();
|
|
||||||
}
|
|
||||||
event.preventDefault();
|
|
||||||
} else if (event.code === "KeyD") {
|
|
||||||
conn.sendDelete(cursor.path);
|
|
||||||
event.preventDefault();
|
|
||||||
} else if (event.code === "KeyA") {
|
|
||||||
conn.sendAct(cursor.path);
|
|
||||||
event.preventDefault();
|
|
||||||
}
|
|
||||||
});
|
|
||||||
|
|
@ -1,16 +0,0 @@
|
||||||
#settings {
|
|
||||||
position: fixed;
|
|
||||||
bottom: 0;
|
|
||||||
transition: all 0.2s ease-out;
|
|
||||||
transform: translateY(100%);
|
|
||||||
}
|
|
||||||
#settings a {
|
|
||||||
color: var(--white);
|
|
||||||
}
|
|
||||||
#settings > button, #settings > form {
|
|
||||||
padding: 1ch;
|
|
||||||
background-color: var(--magenta);
|
|
||||||
}
|
|
||||||
#settings > button {
|
|
||||||
font-weight: bold;
|
|
||||||
}
|
|
||||||
|
|
@ -1,35 +0,0 @@
|
||||||
"use strict";
|
|
||||||
|
|
||||||
const settingsDiv = document.getElementById("settings");
|
|
||||||
const settingsButton = settingsDiv.querySelector("button");
|
|
||||||
const settingsForm = settingsDiv.querySelector("form");
|
|
||||||
let settingsMenuState;
|
|
||||||
settingsButton.addEventListener("click", event => setSettingsMenuState(!settingsMenuState));
|
|
||||||
window.addEventListener("load", event => setSettingsMenuState(false));
|
|
||||||
|
|
||||||
function setSettingsMenuState(open) {
|
|
||||||
settingsMenuState = open;
|
|
||||||
if (open) {
|
|
||||||
settingsDiv.style.transform = "none";
|
|
||||||
} else {
|
|
||||||
let height = settingsButton.offsetHeight;
|
|
||||||
settingsDiv.style.transform = `translateY(calc(100% - ${height}px))`;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
const curvyLinesCheckbox = document.getElementById("curvy-lines-checkbox");
|
|
||||||
curvyLinesCheckbox.addEventListener("change", event => setCurvyLines(event.target.checked));
|
|
||||||
window.addEventListener("load", event => {
|
|
||||||
let curvy = window.localStorage.getItem("curvy");
|
|
||||||
curvyLinesCheckbox.checked = curvy;
|
|
||||||
setCurvyLines(curvy);
|
|
||||||
});
|
|
||||||
|
|
||||||
function setCurvyLines(curvy) {
|
|
||||||
document.body.classList.toggle("curvy", curvy);
|
|
||||||
if (curvy) {
|
|
||||||
window.localStorage.setItem("curvy", "yes");
|
|
||||||
} else {
|
|
||||||
window.localStorage.removeItem("curvy");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
36
package.yaml
Normal file
36
package.yaml
Normal file
|
|
@ -0,0 +1,36 @@
|
||||||
|
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
|
||||||
37
server/Main.hs
Normal file
37
server/Main.hs
Normal file
|
|
@ -0,0 +1,37 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import Control.Concurrent.MVar
|
||||||
|
import qualified Network.WebSockets as WS
|
||||||
|
|
||||||
|
import Forest.Broadcast
|
||||||
|
import Forest.Node
|
||||||
|
import Forest.Server
|
||||||
|
import Forest.TreeModule.Const
|
||||||
|
import Forest.TreeModule.Fork
|
||||||
|
import Forest.TreeModule.SharedEditing
|
||||||
|
|
||||||
|
pingDelay :: Int
|
||||||
|
pingDelay = 10
|
||||||
|
|
||||||
|
pongDelay :: Int
|
||||||
|
pongDelay = 3 * pingDelay
|
||||||
|
|
||||||
|
options :: WS.ServerOptions
|
||||||
|
options = WS.defaultServerOptions
|
||||||
|
{ WS.serverRequirePong = Just pongDelay
|
||||||
|
}
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
putStrLn "Preparing shared edit module"
|
||||||
|
sharedEditNodeVar <- newMVar $ txtNode "r" ""
|
||||||
|
sharedEditBroadcaster <- newBroadcaster
|
||||||
|
|
||||||
|
putStrLn "Starting server"
|
||||||
|
WS.runServerWithOptions options $ serverApp pingDelay $ forkModule "Forest"
|
||||||
|
[ ProngConstructor "Test" $ constModule $ newNode "" "" [txtNode "" "Bla"]
|
||||||
|
, ProngConstructor "Sandbox" $ sharedEditingModule sharedEditNodeVar sharedEditBroadcaster
|
||||||
|
, ProngConstructor "About" $ constModule projectDescriptionNode
|
||||||
|
]
|
||||||
52
src/Forest/Broadcast.hs
Normal file
52
src/Forest/Broadcast.hs
Normal file
|
|
@ -0,0 +1,52 @@
|
||||||
|
-- | A 'Broadcaster' allows threads to 'broadcast' values to 'Listeners'
|
||||||
|
-- attached to that broadcaster. A value that is sent through a broadcaster will
|
||||||
|
-- arrive exactly once at each attached listener and can then be collected by
|
||||||
|
-- calling 'listen'.
|
||||||
|
--
|
||||||
|
-- All functions included in this module should be threadsafe. Be sure to read
|
||||||
|
-- the warning on the 'broadcast' function.
|
||||||
|
|
||||||
|
module Forest.Broadcast
|
||||||
|
( Broadcaster
|
||||||
|
, Listener
|
||||||
|
, newBroadcaster
|
||||||
|
, attachListener
|
||||||
|
, broadcast
|
||||||
|
, listen
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Concurrent.Chan
|
||||||
|
|
||||||
|
-- | A 'Broadcaster' can broadcast values to all attached 'Listener's
|
||||||
|
newtype Broadcaster a = Broadcaster (Chan a)
|
||||||
|
|
||||||
|
-- | A 'Listener' receives values from the 'Broadcaster' it is attached to
|
||||||
|
newtype Listener a = Listener (Chan a)
|
||||||
|
|
||||||
|
-- | Create a new 'Broadcaster'
|
||||||
|
newBroadcaster :: IO (Broadcaster a)
|
||||||
|
newBroadcaster = Broadcaster <$> newChan
|
||||||
|
|
||||||
|
-- | Create a new 'Listener' that is attached to a 'Broadcaster'
|
||||||
|
attachListener :: Broadcaster a -> IO (Listener a)
|
||||||
|
attachListener (Broadcaster chan) = Listener <$> dupChan chan
|
||||||
|
|
||||||
|
-- | Send a value through the 'Broadcaster'. That value will arrive exactly once
|
||||||
|
-- at all 'Listener's attached to this broadcaster via 'attachListener'.
|
||||||
|
--
|
||||||
|
-- Warning: During this function call, no exception should occur or elements may
|
||||||
|
-- build up in the broadcaster, leading to a memory/space leak.
|
||||||
|
broadcast :: Broadcaster a -> a -> IO ()
|
||||||
|
-- Because the same function that puts something into the broadcaster channel
|
||||||
|
-- also immediately reads something from that channel, there is no build-up of
|
||||||
|
-- values in the broadcaster channel, as one element is removed for each element
|
||||||
|
-- written. Since the broadcaster channel is separate from the listener
|
||||||
|
-- channels, no event is swallowed accidentally.
|
||||||
|
--
|
||||||
|
-- If some exception happens after the write operation succeeds but before the
|
||||||
|
-- read operation finishes, elements can build up in the broadcast channel.
|
||||||
|
broadcast (Broadcaster chan) value = writeChan chan value <* readChan chan
|
||||||
|
|
||||||
|
-- | Read the next value from the 'Listener'. Blocks when the listener is empty.
|
||||||
|
listen :: Listener a -> IO a
|
||||||
|
listen (Listener chan) = readChan chan
|
||||||
|
|
@ -2,9 +2,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Forest.Node
|
module Forest.Node
|
||||||
(
|
( NodeId
|
||||||
-- * Nodes
|
|
||||||
NodeId
|
|
||||||
, enumerateIds
|
, enumerateIds
|
||||||
, findUnusedId
|
, findUnusedId
|
||||||
, NodeFlags(..)
|
, NodeFlags(..)
|
||||||
|
|
@ -13,27 +11,14 @@ module Forest.Node
|
||||||
, newNode
|
, newNode
|
||||||
, txtNode
|
, txtNode
|
||||||
, hasChildren
|
, hasChildren
|
||||||
, diffNodes
|
, mapChildren
|
||||||
, flatten
|
|
||||||
-- ** Traversing the tree
|
|
||||||
, applyId
|
, applyId
|
||||||
, applyPath
|
, applyPath
|
||||||
, firstChild
|
|
||||||
, lastChild
|
|
||||||
, firstSibling
|
|
||||||
, prevSibling
|
|
||||||
, nextSibling
|
|
||||||
, lastSibling
|
|
||||||
, firstNode
|
|
||||||
, prevNode
|
|
||||||
, nextNode
|
|
||||||
, lastNode
|
|
||||||
-- ** Modifying at a path
|
|
||||||
, adjustAt
|
, adjustAt
|
||||||
, replaceAt
|
, replaceAt
|
||||||
, deleteAt
|
, deleteAt
|
||||||
, appendAt
|
, appendAt
|
||||||
-- * Paths
|
, diffNodes
|
||||||
, Path(..)
|
, Path(..)
|
||||||
, referencedNodeExists
|
, referencedNodeExists
|
||||||
, splitHeadTail
|
, splitHeadTail
|
||||||
|
|
@ -49,21 +34,14 @@ import qualified Data.Map.Strict as Map
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Safe
|
|
||||||
|
|
||||||
import qualified Forest.OrderedMap as OMap
|
import qualified Forest.OrderedMap as OMap
|
||||||
import Forest.Util
|
|
||||||
|
|
||||||
{- Nodes -}
|
|
||||||
|
|
||||||
type NodeId = T.Text
|
type NodeId = T.Text
|
||||||
|
|
||||||
-- | An infinite list of 'NodeId's. Does *not* contain every possible 'NodeId'.
|
|
||||||
enumerateIds :: [NodeId]
|
enumerateIds :: [NodeId]
|
||||||
enumerateIds = map (T.pack . show) [(0::Integer)..]
|
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 :: Set.Set NodeId -> NodeId
|
||||||
findUnusedId usedIds =
|
findUnusedId usedIds =
|
||||||
head $ filter (\nid -> not $ nid `Set.member` usedIds) enumerateIds
|
head $ filter (\nid -> not $ nid `Set.member` usedIds) enumerateIds
|
||||||
|
|
@ -104,7 +82,7 @@ data Node = Node
|
||||||
{ nodeText :: !T.Text
|
{ nodeText :: !T.Text
|
||||||
, nodeFlags :: !NodeFlags
|
, nodeFlags :: !NodeFlags
|
||||||
, nodeChildren :: !(OMap.OrderedMap NodeId Node)
|
, nodeChildren :: !(OMap.OrderedMap NodeId Node)
|
||||||
} deriving (Show, Eq)
|
} deriving (Show)
|
||||||
|
|
||||||
instance ToJSON Node where
|
instance ToJSON Node where
|
||||||
toJSON node = object
|
toJSON node = object
|
||||||
|
|
@ -162,87 +140,14 @@ txtNode flags text = newNode flags text []
|
||||||
hasChildren :: Node -> Bool
|
hasChildren :: Node -> Bool
|
||||||
hasChildren = not . OMap.null . nodeChildren
|
hasChildren = not . OMap.null . nodeChildren
|
||||||
|
|
||||||
diffNodes :: Node -> Node -> Maybe (Path, Node)
|
mapChildren :: (NodeId -> Node -> a) -> Node -> [a]
|
||||||
diffNodes a b
|
mapChildren f = map (uncurry f) . OMap.toList . nodeChildren
|
||||||
| 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]
|
|
||||||
|
|
||||||
-- | Return the 'Path's to a node and its subnodes in the order they would be
|
applyId :: NodeId -> Node -> Maybe Node
|
||||||
-- displayed in.
|
applyId nid node = nodeChildren node OMap.!? nid
|
||||||
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
|
|
||||||
|
|
||||||
{- Traversing the tree -}
|
applyPath :: Path -> Node -> Maybe Node
|
||||||
|
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 :: (Node -> Node) -> Path -> Node -> Node
|
||||||
adjustAt f (Path []) node = f node
|
adjustAt f (Path []) node = f node
|
||||||
|
|
@ -271,14 +176,27 @@ appendAt node =
|
||||||
let nid = findUnusedId $ OMap.keysSet m
|
let nid = findUnusedId $ OMap.keysSet m
|
||||||
in OMap.append nid node m
|
in OMap.append nid node m
|
||||||
|
|
||||||
{- Paths -}
|
diffNodes :: Node -> Node -> Maybe (Path, Node)
|
||||||
|
diffNodes a b
|
||||||
|
| nodesDiffer || childrenChanged = Just (Path [], b)
|
||||||
|
| otherwise = case differingChildren of
|
||||||
|
[] -> Nothing
|
||||||
|
[(x, Path xs, node)] -> Just (Path (x:xs), node)
|
||||||
|
_ -> Just (Path [], b)
|
||||||
|
where
|
||||||
|
nodesDiffer = nodeText a /= nodeText b || nodeFlags a /= nodeFlags b
|
||||||
|
aChildren = nodeChildren a
|
||||||
|
bChildren = nodeChildren b
|
||||||
|
childrenChanged = OMap.keys aChildren /= OMap.keys bChildren
|
||||||
|
diffedChildren = Map.toList $ Map.intersectionWith diffNodes (OMap.toMap aChildren) (OMap.toMap bChildren)
|
||||||
|
differingChildren = [(key, path, node) | (key, Just (path, node)) <- diffedChildren]
|
||||||
|
|
||||||
newtype Path = Path
|
newtype Path = Path
|
||||||
{ pathElements :: [NodeId]
|
{ pathElements :: [NodeId]
|
||||||
} deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON)
|
} deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON)
|
||||||
|
|
||||||
referencedNodeExists :: Node -> Path -> Bool
|
referencedNodeExists :: Node -> Path -> Bool
|
||||||
referencedNodeExists node path = isJust $ applyPath node path
|
referencedNodeExists node path = isJust $ applyPath path node
|
||||||
|
|
||||||
splitHeadTail :: Path -> Maybe (NodeId, Path)
|
splitHeadTail :: Path -> Maybe (NodeId, Path)
|
||||||
splitHeadTail (Path []) = Nothing
|
splitHeadTail (Path []) = Nothing
|
||||||
|
|
@ -65,17 +65,11 @@ import qualified Data.Set as Set
|
||||||
data OrderedMap k a = OrderedMap
|
data OrderedMap k a = OrderedMap
|
||||||
{ omMap :: Map.Map k a
|
{ omMap :: Map.Map k a
|
||||||
, omOrder :: [k]
|
, omOrder :: [k]
|
||||||
} deriving (Eq)
|
}
|
||||||
|
|
||||||
instance (Ord k, Show k, Show a) => Show (OrderedMap k a) where
|
instance (Ord k, Show k, Show a) => Show (OrderedMap k a) where
|
||||||
show m = "fromList " ++ show (toList m)
|
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:
|
-- Invariants of this data type:
|
||||||
--
|
--
|
||||||
-- 1. The 'omOrder' list contains each key from 'omMap' exactly once.
|
-- 1. The 'omOrder' list contains each key from 'omMap' exactly once.
|
||||||
71
src/Forest/Server.hs
Normal file
71
src/Forest/Server.hs
Normal file
|
|
@ -0,0 +1,71 @@
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Forest.Server
|
||||||
|
( withThread
|
||||||
|
, serverApp
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Concurrent.Chan
|
||||||
|
import Control.Exception
|
||||||
|
import qualified Network.WebSockets as WS
|
||||||
|
|
||||||
|
import Forest.Api
|
||||||
|
import Forest.Node
|
||||||
|
import Forest.TreeModule
|
||||||
|
import Forest.Util
|
||||||
|
|
||||||
|
{- Thread that sends updates to the client -}
|
||||||
|
|
||||||
|
sendUpdatesThread :: WS.Connection -> Chan Node -> Node -> IO ()
|
||||||
|
sendUpdatesThread conn nodeChan nodeA = do
|
||||||
|
nodeB <- readChan nodeChan
|
||||||
|
case diffNodes nodeA nodeB of
|
||||||
|
Nothing -> do
|
||||||
|
putStrLn "Sending no update because the node didn't change"
|
||||||
|
sendUpdatesThread conn nodeChan nodeA
|
||||||
|
Just (path, nextNode) -> do
|
||||||
|
putStrLn $ "Sending partial update for path " ++ show path ++ ": " ++ show nextNode
|
||||||
|
sendPacket conn $ ServerUpdate path nextNode
|
||||||
|
sendUpdatesThread conn nodeChan nodeB
|
||||||
|
|
||||||
|
{- Main server application that receives and processes client packets -}
|
||||||
|
|
||||||
|
receivePackets :: TreeModule a () => WS.Connection -> a () -> IO ()
|
||||||
|
receivePackets conn treeModule = runUntilJustM $ do
|
||||||
|
packet <- receivePacket conn
|
||||||
|
case packet of
|
||||||
|
ClientEdit path text -> do
|
||||||
|
putStrLn $ "Editing " ++ show path ++ " to " ++ show text
|
||||||
|
edit treeModule path text
|
||||||
|
ClientDelete path -> do
|
||||||
|
putStrLn $ "Deleting " ++ show path
|
||||||
|
delete treeModule path
|
||||||
|
ClientReply path text -> do
|
||||||
|
putStrLn $ "Replying to " ++ show path ++ " with " ++ show text
|
||||||
|
reply treeModule path text
|
||||||
|
ClientAct path -> do
|
||||||
|
putStrLn $ "Acting upon " ++ show path
|
||||||
|
act treeModule path
|
||||||
|
ClientHello _ -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once"
|
||||||
|
|
||||||
|
printException :: SomeException -> IO ()
|
||||||
|
printException e = putStrLn $ "Encountered exception: " ++ show e
|
||||||
|
|
||||||
|
serverApp :: TreeModule a () => Int -> ModuleConstructor (a ()) -> WS.ServerApp
|
||||||
|
serverApp pingDelay constructor pendingConnection = do
|
||||||
|
conn <- WS.acceptRequest pendingConnection
|
||||||
|
chan <- newChan
|
||||||
|
WS.withPingThread conn pingDelay (pure ()) $ handle printException $ do
|
||||||
|
firstPacket <- receivePacket conn
|
||||||
|
case firstPacket of
|
||||||
|
ClientHello _ -> do
|
||||||
|
putStrLn $ "Sending hello reply with " ++ show initialNode
|
||||||
|
sendPacket conn $ ServerHello [] initialNode
|
||||||
|
withThread (sendUpdatesThread conn chan initialNode) $
|
||||||
|
constructor (writeChan chan) $ \tm -> do
|
||||||
|
receivePackets conn tm
|
||||||
|
putStrLn "Module finished, closing connection"
|
||||||
|
_ -> closeWithErrorMessage conn "Invalid packet: Expected a hello packet"
|
||||||
|
where
|
||||||
|
initialNode = txtNode "" "Loading..."
|
||||||
25
src/Forest/TreeModule.hs
Normal file
25
src/Forest/TreeModule.hs
Normal file
|
|
@ -0,0 +1,25 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
|
||||||
|
module Forest.TreeModule
|
||||||
|
( TreeModule(..)
|
||||||
|
, ModuleConstructor
|
||||||
|
) where
|
||||||
|
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
import Forest.Node
|
||||||
|
|
||||||
|
class TreeModule a r where
|
||||||
|
edit :: a r -> Path -> T.Text -> IO (Maybe r)
|
||||||
|
edit _ _ _ = pure Nothing
|
||||||
|
|
||||||
|
delete :: a r -> Path -> IO (Maybe r)
|
||||||
|
delete _ _ = pure Nothing
|
||||||
|
|
||||||
|
reply :: a r -> Path -> T.Text -> IO (Maybe r)
|
||||||
|
reply _ _ _ = pure Nothing
|
||||||
|
|
||||||
|
act :: a r -> Path -> IO (Maybe r)
|
||||||
|
act _ _ = pure Nothing
|
||||||
|
|
||||||
|
type ModuleConstructor a = (Node -> IO ()) -> (a -> IO ()) -> IO ()
|
||||||
27
src/Forest/TreeModule/Animate.hs
Normal file
27
src/Forest/TreeModule/Animate.hs
Normal file
|
|
@ -0,0 +1,27 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Forest.TreeModule.Animate
|
||||||
|
( AnimateModule
|
||||||
|
, animateModule
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Concurrent
|
||||||
|
|
||||||
|
import Forest.Node
|
||||||
|
import Forest.TreeModule
|
||||||
|
import Forest.Util
|
||||||
|
|
||||||
|
data AnimateModule r = AnimateModule
|
||||||
|
|
||||||
|
instance TreeModule AnimateModule () where
|
||||||
|
|
||||||
|
animateModule :: Int -> [Node] -> ModuleConstructor (AnimateModule ())
|
||||||
|
animateModule delay frames sendNode continue =
|
||||||
|
withThread (animateThread frames) $ continue AnimateModule
|
||||||
|
where
|
||||||
|
animateThread [] = sendNode $ txtNode "" "Invalid animation: No frames provided"
|
||||||
|
animateThread (x:xs) = do
|
||||||
|
sendNode x
|
||||||
|
threadDelay delay
|
||||||
|
animateThread $ xs ++ [x]
|
||||||
118
src/Forest/TreeModule/Const.hs
Normal file
118
src/Forest/TreeModule/Const.hs
Normal file
|
|
@ -0,0 +1,118 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Forest.TreeModule.Const
|
||||||
|
( ConstModule
|
||||||
|
, constModule
|
||||||
|
, projectDescriptionNode
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Forest.Node
|
||||||
|
import Forest.TreeModule
|
||||||
|
|
||||||
|
data ConstModule r = ConstModule
|
||||||
|
|
||||||
|
instance TreeModule ConstModule () where
|
||||||
|
|
||||||
|
constModule :: Node -> ModuleConstructor (ConstModule ())
|
||||||
|
constModule node sendNode continue = do
|
||||||
|
sendNode node
|
||||||
|
continue ConstModule
|
||||||
|
|
||||||
|
projectDescriptionNode :: Node
|
||||||
|
projectDescriptionNode =
|
||||||
|
newNode "" "About"
|
||||||
|
[ txtNode "" "This project is an experiment in tree-based interaction."
|
||||||
|
, newNode "" "Motivation"
|
||||||
|
[ txtNode "" "My goals for this project were:"
|
||||||
|
, newNode "" "Interactons between multiple people"
|
||||||
|
[ txtNode ""
|
||||||
|
( "I wanted to create a project that let multiple people interact with "
|
||||||
|
<> "each other in different ways. Examples for interactions include:\n"
|
||||||
|
<> "* Chatting\n"
|
||||||
|
<> "* Collaborative editing\n"
|
||||||
|
<> "* Playing (multiplayer) games\n"
|
||||||
|
)
|
||||||
|
, txtNode "" "The project should allow for many different kinds of interactions."
|
||||||
|
]
|
||||||
|
, newNode "" "Portability"
|
||||||
|
[ txtNode ""
|
||||||
|
( "The project should be usable on multiple different platforms. To "
|
||||||
|
<> "facilitate this, clients should be easy to create. In particular, I "
|
||||||
|
<> "want at least one terminal-based and one web-based client."
|
||||||
|
)
|
||||||
|
]
|
||||||
|
, txtNode "" "Based on these goals, I made the following design decisions:"
|
||||||
|
, newNode "" "Text-based"
|
||||||
|
[ txtNode ""
|
||||||
|
( "Text is a medium that works on all platforms and easy to work with "
|
||||||
|
<> "as a developer."
|
||||||
|
)
|
||||||
|
, txtNode ""
|
||||||
|
( "But text still allows for a lot of different interactions. Of all "
|
||||||
|
<> "the kinds of media one can produce with a computer, text is easy "
|
||||||
|
<> "and quick to create. After all, pretty much every computer has a "
|
||||||
|
<> "keyboard."
|
||||||
|
)
|
||||||
|
]
|
||||||
|
, newNode "" "Tree-based"
|
||||||
|
[ txtNode ""
|
||||||
|
( "While plain text may be easy to work with, it makes interactions "
|
||||||
|
<> "cumbersome if limited to basic input and output. To make "
|
||||||
|
<> "interactions nicer, the server could send the client a screen's "
|
||||||
|
<> "worth of text to display, in effect creating a TUI-like interface. "
|
||||||
|
<> "The client would then only need to send key presses or mouse clicks "
|
||||||
|
<> "to the server."
|
||||||
|
)
|
||||||
|
, txtNode ""
|
||||||
|
( "In my opinion, that approach moves too many decisions on how to "
|
||||||
|
<> "interact to the server and imposes unnecessary limits on the client "
|
||||||
|
<> "design. Instead, I went with a plaintext-in-tree-structure "
|
||||||
|
<> "approach, which allows for more flexibility in the client design. "
|
||||||
|
<> "Also, this should make bots easier to write, since they don't have "
|
||||||
|
<> "to emulate human input."
|
||||||
|
)
|
||||||
|
]
|
||||||
|
, newNode "" "Simple API"
|
||||||
|
[ txtNode ""
|
||||||
|
( "Every client must use the same API to interact with the server. "
|
||||||
|
<> "Because clients should be easy to create on different platforms, "
|
||||||
|
<> "the API should also be simple."
|
||||||
|
)
|
||||||
|
, txtNode ""
|
||||||
|
( "One way in which the API is simple is that the server doesn't send "
|
||||||
|
<> "direct responses to client commands. Instead, there is only the "
|
||||||
|
<> "'update' packet, which is sent whenever the client should modify "
|
||||||
|
<> "its tree structure."
|
||||||
|
)
|
||||||
|
, txtNode ""
|
||||||
|
( "In total, there are 5 different client packages and 2 different "
|
||||||
|
<> "server packages. If at some point the API turns out to be too "
|
||||||
|
<> "simple, it has a built-in way of negotiating protocol extensions."
|
||||||
|
)
|
||||||
|
]
|
||||||
|
, newNode "" "Most logic in server"
|
||||||
|
[ txtNode ""
|
||||||
|
( "All logic besides the immediate input handling and tree folding "
|
||||||
|
<> "happens in the server. This has multiple advantages:"
|
||||||
|
)
|
||||||
|
, txtNode "" "The API and clients are simpler, clients are easier to write or maintain."
|
||||||
|
, txtNode "" "Updates in logic don't require updates of the client."
|
||||||
|
, txtNode "" "The server-side logic becomes easier to write."
|
||||||
|
]
|
||||||
|
, txtNode ""
|
||||||
|
( "Those design decisions should allow for various different kinds of "
|
||||||
|
<> "interactions, for example linear and threaded chat, collaborative "
|
||||||
|
<> "node editing, reading node-based documents (like this one), playing "
|
||||||
|
<> "text adventures and more."
|
||||||
|
)
|
||||||
|
, txtNode ""
|
||||||
|
( "And of course, which interactions are supported only depends on the "
|
||||||
|
<> "server and not on the client."
|
||||||
|
)
|
||||||
|
]
|
||||||
|
, newNode "" "Inspirations"
|
||||||
|
[ txtNode "" "The tree-based chat model and UI of euphoria (euphoria.io) and instant (instant.leet.nu)"
|
||||||
|
, txtNode "" "MUDs (which are text based and most of the logic happens server-side)"
|
||||||
|
]
|
||||||
|
]
|
||||||
102
src/Forest/TreeModule/Fork.hs
Normal file
102
src/Forest/TreeModule/Fork.hs
Normal file
|
|
@ -0,0 +1,102 @@
|
||||||
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
|
{-# LANGUAGE KindSignatures #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
|
||||||
|
module Forest.TreeModule.Fork
|
||||||
|
( ForkModule
|
||||||
|
, ProngConstructor(..)
|
||||||
|
, forkModule
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Concurrent.MVar
|
||||||
|
import Control.Monad.Trans.Cont
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
import Forest.Node
|
||||||
|
import qualified Forest.OrderedMap as OMap
|
||||||
|
import Forest.TreeModule
|
||||||
|
|
||||||
|
data Prong = forall r a . TreeModule a r => Prong (a r)
|
||||||
|
|
||||||
|
data ProngConstructor = forall r a . TreeModule a r =>
|
||||||
|
ProngConstructor T.Text (ModuleConstructor (a r))
|
||||||
|
|
||||||
|
newtype ForkModule r = ForkModule (Map.Map NodeId Prong)
|
||||||
|
|
||||||
|
instance TreeModule ForkModule () where
|
||||||
|
edit _ (Path []) _ = pure Nothing
|
||||||
|
edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
|
||||||
|
Nothing -> pure Nothing
|
||||||
|
Just (Prong a) -> do
|
||||||
|
result <- edit a (Path xs) text
|
||||||
|
pure $ () <$ result
|
||||||
|
|
||||||
|
delete _ (Path []) = pure Nothing
|
||||||
|
delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
|
||||||
|
Nothing -> pure Nothing
|
||||||
|
Just (Prong a) -> do
|
||||||
|
result <- delete a (Path xs)
|
||||||
|
pure $ () <$ result
|
||||||
|
|
||||||
|
reply _ (Path []) _ = pure Nothing
|
||||||
|
reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
|
||||||
|
Nothing -> pure Nothing
|
||||||
|
Just (Prong a) -> do
|
||||||
|
result <- reply a (Path xs) text
|
||||||
|
pure $ () <$ result
|
||||||
|
|
||||||
|
act _ (Path []) = pure Nothing
|
||||||
|
act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
|
||||||
|
Nothing -> pure Nothing
|
||||||
|
Just (Prong a) -> do
|
||||||
|
result <- act a (Path xs)
|
||||||
|
pure $ () <$ result
|
||||||
|
|
||||||
|
data ProngInfo = ProngInfo
|
||||||
|
{ piTopName :: T.Text
|
||||||
|
, piNames :: Map.Map NodeId T.Text
|
||||||
|
, piNodes :: Map.Map NodeId Node
|
||||||
|
, piOrder :: [NodeId]
|
||||||
|
}
|
||||||
|
|
||||||
|
renderProngInfo :: ProngInfo -> Node
|
||||||
|
renderProngInfo pInfo =
|
||||||
|
let childMap = Map.intersectionWith
|
||||||
|
(\name node -> node{nodeText = name})
|
||||||
|
(piNames pInfo)
|
||||||
|
(piNodes pInfo)
|
||||||
|
children = OMap.fromMapWithOrder childMap $ piOrder pInfo
|
||||||
|
in Node {nodeText = piTopName pInfo, nodeFlags = mempty, nodeChildren = children}
|
||||||
|
|
||||||
|
sendNodeFromProng :: MVar ProngInfo -> (Node -> IO ()) -> NodeId -> Node -> IO ()
|
||||||
|
sendNodeFromProng piVar sendNode nodeId node =
|
||||||
|
modifyMVar_ piVar $ \pInfo -> do
|
||||||
|
let newPInfo = pInfo {piNodes = Map.insert nodeId node $ piNodes pInfo}
|
||||||
|
sendNode $ renderProngInfo newPInfo
|
||||||
|
pure newPInfo
|
||||||
|
|
||||||
|
constructProngs
|
||||||
|
:: MVar ProngInfo
|
||||||
|
-> (Node -> IO ())
|
||||||
|
-> Map.Map NodeId ProngConstructor
|
||||||
|
-> Cont (IO ()) (Map.Map NodeId Prong)
|
||||||
|
constructProngs piVar sendNode =
|
||||||
|
Map.traverseWithKey constructProng
|
||||||
|
where
|
||||||
|
constructProng nodeId (ProngConstructor _ constructor) =
|
||||||
|
Prong <$> cont (constructor $ sendNodeFromProng piVar sendNode nodeId)
|
||||||
|
|
||||||
|
forkModule :: T.Text -> [ProngConstructor] -> ModuleConstructor (ForkModule ())
|
||||||
|
forkModule text prongs sendNode continue = do
|
||||||
|
let namePairs = zip enumerateIds $ map (\(ProngConstructor name _) -> name) prongs
|
||||||
|
nodesVar <- newMVar ProngInfo
|
||||||
|
{ piTopName = text
|
||||||
|
, piNames = Map.fromList namePairs
|
||||||
|
, piNodes = Map.empty
|
||||||
|
, piOrder = map fst namePairs
|
||||||
|
}
|
||||||
|
let numbers = map (T.pack . show) [(0::Integer)..]
|
||||||
|
prongMap = Map.fromList $ zip numbers prongs
|
||||||
|
runCont (constructProngs nodesVar sendNode prongMap) (continue . ForkModule)
|
||||||
56
src/Forest/TreeModule/SharedEditing.hs
Normal file
56
src/Forest/TreeModule/SharedEditing.hs
Normal file
|
|
@ -0,0 +1,56 @@
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
|
||||||
|
module Forest.TreeModule.SharedEditing
|
||||||
|
( SharedEditingModule
|
||||||
|
, sharedEditingModule
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Concurrent.MVar
|
||||||
|
import Control.Monad
|
||||||
|
|
||||||
|
import Forest.Broadcast
|
||||||
|
import Forest.Node
|
||||||
|
import Forest.TreeModule
|
||||||
|
import Forest.Util
|
||||||
|
|
||||||
|
data SharedEditingModule r = SharedEditingModule
|
||||||
|
{ seNodeVar :: MVar Node
|
||||||
|
, seBroadcaster :: Broadcaster Node
|
||||||
|
}
|
||||||
|
|
||||||
|
instance TreeModule SharedEditingModule r where
|
||||||
|
edit _ (Path []) _ = pure Nothing
|
||||||
|
edit se path text = do
|
||||||
|
node' <- modifyMVar (seNodeVar se) $ \node -> do
|
||||||
|
let updatedNode = adjustAt (\n -> n{nodeText = text}) path node
|
||||||
|
pure (updatedNode, updatedNode)
|
||||||
|
broadcast (seBroadcaster se) node'
|
||||||
|
pure Nothing
|
||||||
|
|
||||||
|
delete _ (Path []) = pure Nothing
|
||||||
|
delete se path = do
|
||||||
|
node' <- modifyMVar (seNodeVar se) $ \node -> do
|
||||||
|
let updatedNode = deleteAt path node
|
||||||
|
pure (updatedNode, updatedNode)
|
||||||
|
broadcast (seBroadcaster se) node'
|
||||||
|
pure Nothing
|
||||||
|
|
||||||
|
reply se path text = do
|
||||||
|
node' <- modifyMVar (seNodeVar se) $ \node -> do
|
||||||
|
let updatedNode = appendAt (txtNode "edr" text) path node
|
||||||
|
pure (updatedNode, updatedNode)
|
||||||
|
broadcast (seBroadcaster se) node'
|
||||||
|
pure Nothing
|
||||||
|
|
||||||
|
sharedEditingModule ::
|
||||||
|
MVar Node -> Broadcaster Node -> ModuleConstructor (SharedEditingModule ())
|
||||||
|
sharedEditingModule nodeVar broadcaster sendNode continue = do
|
||||||
|
listener <- attachListener broadcaster
|
||||||
|
withThread (updateOnNewBroadcast listener) $ do
|
||||||
|
withMVar nodeVar sendNode -- We need to show our initial edit state
|
||||||
|
continue $ SharedEditingModule nodeVar broadcaster
|
||||||
|
where
|
||||||
|
updateOnNewBroadcast listener = forever $ do
|
||||||
|
node <- listen listener
|
||||||
|
sendNode node
|
||||||
|
|
@ -1,16 +1,11 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Forest.Util
|
module Forest.Util
|
||||||
(
|
( findPrev
|
||||||
-- * List operations
|
|
||||||
findPrev
|
|
||||||
, findNext
|
, findNext
|
||||||
-- * Monadic looping constructs
|
|
||||||
, whileM
|
, whileM
|
||||||
, whileNothingM
|
, runUntilJustM
|
||||||
-- * Multithreading helpers
|
|
||||||
, withThread
|
, withThread
|
||||||
-- * Websocket helper functions
|
|
||||||
, sendPacket
|
, sendPacket
|
||||||
, closeWithErrorMessage
|
, closeWithErrorMessage
|
||||||
, receivePacket
|
, receivePacket
|
||||||
|
|
@ -29,6 +24,9 @@ findPrev f as = fst <$> find (f . snd) (zip as $ tail as)
|
||||||
findNext :: (a -> Bool) -> [a] -> Maybe a
|
findNext :: (a -> Bool) -> [a] -> Maybe a
|
||||||
findNext f as = snd <$> find (f . fst) (zip as $ tail as)
|
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.
|
-- | Run a monadic action until it returns @False@ for the first time.
|
||||||
whileM :: Monad m => m Bool -> m ()
|
whileM :: Monad m => m Bool -> m ()
|
||||||
whileM f = do
|
whileM f = do
|
||||||
|
|
@ -38,16 +36,13 @@ whileM f = do
|
||||||
else pure ()
|
else pure ()
|
||||||
|
|
||||||
-- | Run a monadic action until it returns @Just a@ for the first time.
|
-- | Run a monadic action until it returns @Just a@ for the first time.
|
||||||
whileNothingM :: Monad m => m (Maybe a) -> m a
|
runUntilJustM :: Monad m => m (Maybe a) -> m a
|
||||||
whileNothingM f = do
|
runUntilJustM f = do
|
||||||
result <- f
|
result <- f
|
||||||
case result of
|
case result of
|
||||||
Nothing -> whileNothingM f
|
Nothing -> runUntilJustM f
|
||||||
Just a -> pure a
|
Just a -> pure a
|
||||||
|
|
||||||
withThread :: IO () -> IO () -> IO ()
|
|
||||||
withThread thread main = withAsync thread $ const main
|
|
||||||
|
|
||||||
sendPacket :: ToJSON a => WS.Connection -> a -> IO ()
|
sendPacket :: ToJSON a => WS.Connection -> a -> IO ()
|
||||||
sendPacket conn packet = WS.sendTextData conn $ encode packet
|
sendPacket conn packet = WS.sendTextData conn $ encode packet
|
||||||
|
|
||||||
70
stack.yaml
70
stack.yaml
|
|
@ -1,6 +1,66 @@
|
||||||
resolver: lts-15.3
|
# This file was automatically generated by 'stack init'
|
||||||
|
#
|
||||||
|
# Some commonly used options have been documented as comments in this file.
|
||||||
|
# For advanced use and comprehensive documentation of the format, please see:
|
||||||
|
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
||||||
|
|
||||||
|
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
|
||||||
|
# A snapshot resolver dictates the compiler version and the set of packages
|
||||||
|
# to be used for project dependencies. For example:
|
||||||
|
#
|
||||||
|
# resolver: lts-3.5
|
||||||
|
# resolver: nightly-2015-09-21
|
||||||
|
# resolver: ghc-7.10.2
|
||||||
|
#
|
||||||
|
# The location of a snapshot can be provided as a file or url. Stack assumes
|
||||||
|
# a snapshot provided as a file might change, whereas a url resource does not.
|
||||||
|
#
|
||||||
|
# resolver: ./custom-snapshot.yaml
|
||||||
|
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||||
|
resolver: lts-15.1
|
||||||
|
|
||||||
|
# User packages to be built.
|
||||||
|
# Various formats can be used as shown in the example below.
|
||||||
|
#
|
||||||
|
# packages:
|
||||||
|
# - some-directory
|
||||||
|
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
|
||||||
|
# subdirs:
|
||||||
|
# - auto-update
|
||||||
|
# - wai
|
||||||
packages:
|
packages:
|
||||||
- forest-cabin
|
- .
|
||||||
- forest-common
|
# Dependency packages to be pulled from upstream that are not in the resolver.
|
||||||
- forest-server
|
# These entries can reference officially published versions as well as
|
||||||
- forest-tui
|
# forks / in-progress versions pinned to a git hash. For example:
|
||||||
|
#
|
||||||
|
# extra-deps:
|
||||||
|
# - acme-missiles-0.3
|
||||||
|
# - git: https://github.com/commercialhaskell/stack.git
|
||||||
|
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||||
|
#
|
||||||
|
# extra-deps: []
|
||||||
|
|
||||||
|
# Override default flag values for local packages and extra-deps
|
||||||
|
# flags: {}
|
||||||
|
|
||||||
|
# Extra package databases containing global packages
|
||||||
|
# extra-package-dbs: []
|
||||||
|
|
||||||
|
# Control whether we use the GHC we find on the path
|
||||||
|
# system-ghc: true
|
||||||
|
#
|
||||||
|
# Require a specific version of stack, using version ranges
|
||||||
|
# require-stack-version: -any # Default
|
||||||
|
# require-stack-version: ">=2.1"
|
||||||
|
#
|
||||||
|
# Override the architecture used by stack, especially useful on Windows
|
||||||
|
# arch: i386
|
||||||
|
# arch: x86_64
|
||||||
|
#
|
||||||
|
# Extra directories used by stack for building
|
||||||
|
# extra-include-dirs: [/path/to/dir]
|
||||||
|
# extra-lib-dirs: [/path/to/dir]
|
||||||
|
#
|
||||||
|
# Allow a newer minor version of GHC than the snapshot specifies
|
||||||
|
# compiler-check: newer-minor
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,7 @@
|
||||||
packages: []
|
packages: []
|
||||||
snapshots:
|
snapshots:
|
||||||
- completed:
|
- completed:
|
||||||
size: 491373
|
size: 489011
|
||||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/3.yaml
|
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/1.yaml
|
||||||
sha256: 29e9ff61b8bf4b4fcff55cde3ac106ebb971f0d21331dccac9eee63374fa6ca8
|
sha256: d4ecc42b7125d68e4c3c036a08046ad0cd02ae0d9efbe3af2223a00ff8cc16f3
|
||||||
original: lts-15.3
|
original: lts-15.1
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue