[client] Rewrite client structure
This commit is contained in:
parent
bd06b64699
commit
e8b6efcb76
10 changed files with 547 additions and 494 deletions
224
client/Main.hs
224
client/Main.hs
|
|
@ -1,230 +1,12 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Brick
|
||||
import Control.Monad.IO.Class
|
||||
import Brick.BChan
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import qualified Graphics.Vty as Vty
|
||||
import qualified Network.WebSockets as WS
|
||||
import Options.Applicative
|
||||
import qualified Wuss as WSS
|
||||
|
||||
import Forest.Api
|
||||
import Forest.Client.NodeEditor
|
||||
import Forest.Client
|
||||
import Forest.Client.Options
|
||||
import Forest.Client.ResourceName
|
||||
import Forest.Client.Tree
|
||||
import Forest.Client.WidgetTree
|
||||
import Forest.Node
|
||||
import Forest.Util
|
||||
|
||||
{- First, the UI types -}
|
||||
|
||||
data Event = EventNode Node
|
||||
| EventConnectionClosed
|
||||
|
||||
data ClientState = ClientState
|
||||
{ csTree :: Tree
|
||||
, csEditor :: Maybe NodeEditor
|
||||
, csConn :: WS.Connection
|
||||
, csEventChan :: BChan Event
|
||||
}
|
||||
|
||||
newClientState :: BChan Event -> Node -> WS.Connection -> ClientState
|
||||
newClientState eventChan node conn = ClientState
|
||||
{ csTree = newTree node mempty Set.empty
|
||||
, csEditor = Nothing
|
||||
, csConn = conn
|
||||
, csEventChan = eventChan
|
||||
}
|
||||
|
||||
type ClientM a = EventM ResourceName a
|
||||
|
||||
{- Actions in normal mode -}
|
||||
|
||||
foldAction :: ClientState -> ClientM (Next ClientState)
|
||||
foldAction cs = continue cs{csTree = toggleFold $ csTree cs}
|
||||
|
||||
upAction :: ClientState -> ClientM (Next ClientState)
|
||||
upAction cs = continue cs{csTree = moveUp $ csTree cs}
|
||||
|
||||
downAction :: ClientState -> ClientM (Next ClientState)
|
||||
downAction cs = continue cs{csTree = moveDown $ csTree cs}
|
||||
|
||||
withCurrent
|
||||
:: (ClientState -> Node -> Path -> ClientM (Next ClientState))
|
||||
-> ClientState
|
||||
-> ClientM (Next ClientState)
|
||||
withCurrent f cs = f cs (getCurrent tree) (getCurrentPath tree)
|
||||
where
|
||||
tree = csTree cs
|
||||
|
||||
editAction :: ClientState -> ClientM (Next ClientState)
|
||||
editAction = withCurrent $ \cs node _ -> do
|
||||
let editor = editNode $ nodeText node
|
||||
continue $ if flagEdit (nodeFlags node) then cs{csEditor = Just editor} else cs
|
||||
|
||||
deleteAction :: ClientState -> ClientM (Next ClientState)
|
||||
deleteAction = withCurrent $ \cs node path -> do
|
||||
when (flagDelete $ nodeFlags node) $
|
||||
liftIO $ sendPacket (csConn cs) $ ClientDelete path
|
||||
continue cs
|
||||
|
||||
replyAction :: ClientState -> ClientM (Next ClientState)
|
||||
replyAction = withCurrent $ \cs node _ ->
|
||||
continue $ if flagReply (nodeFlags node) then cs{csEditor = Just replyToNode} else cs
|
||||
|
||||
actAction :: ClientState -> ClientM (Next ClientState)
|
||||
actAction = withCurrent $ \cs node path -> do
|
||||
when (flagAct $ nodeFlags node) $
|
||||
liftIO $ sendPacket (csConn cs) $ ClientAct path
|
||||
continue cs
|
||||
|
||||
onKeyWithoutEditor :: ClientState -> Vty.Event -> EventM ResourceName (Next ClientState)
|
||||
onKeyWithoutEditor cs (Vty.EvKey k _)
|
||||
| k `elem` quitKeys = halt cs
|
||||
| k `elem` foldKeys = foldAction cs
|
||||
| k `elem` upKeys = upAction cs
|
||||
| k `elem` downKeys = downAction cs
|
||||
| k `elem` editKeys = editAction cs
|
||||
| k `elem` deleteKeys = deleteAction cs
|
||||
| k `elem` replyKeys = replyAction cs
|
||||
| k `elem` actKeys = actAction cs
|
||||
where
|
||||
quitKeys = [Vty.KChar 'q', Vty.KEsc]
|
||||
foldKeys = [Vty.KChar '\t']
|
||||
upKeys = [Vty.KChar 'k', Vty.KUp]
|
||||
downKeys = [Vty.KChar 'j', Vty.KDown]
|
||||
editKeys = [Vty.KChar 'e']
|
||||
deleteKeys = [Vty.KChar 'd']
|
||||
replyKeys = [Vty.KChar 'r']
|
||||
actKeys = [Vty.KChar 'a', Vty.KChar ' ', Vty.KEnter]
|
||||
onKeyWithoutEditor cs _ = continue cs
|
||||
|
||||
{- Actions in edit mode -}
|
||||
|
||||
updateEditor :: NodeEditor -> ClientState -> Vty.Event -> ClientM (Next ClientState)
|
||||
updateEditor ed cs ev = do
|
||||
newEd <- handleNodeEditorEvent ev ed
|
||||
continue cs{csEditor = Just newEd}
|
||||
|
||||
finishEditing :: NodeEditor -> ClientState -> ClientM (Next ClientState)
|
||||
finishEditing ed = withCurrent $ \cs _ path -> do
|
||||
let text = T.intercalate "\n" $ getCurrentText ed
|
||||
liftIO $ sendPacket (csConn cs) $
|
||||
if asReply ed then ClientReply path text else ClientEdit path text
|
||||
continue cs{csEditor = Nothing}
|
||||
|
||||
onKeyWithEditor :: NodeEditor -> ClientState -> Vty.Event -> ClientM (Next ClientState)
|
||||
-- Finish editing normally
|
||||
onKeyWithEditor ed cs (Vty.EvKey Vty.KEnter _) = finishEditing ed cs
|
||||
-- Abort editing with Escape
|
||||
onKeyWithEditor _ cs (Vty.EvKey Vty.KEsc _) = continue cs{csEditor = Nothing}
|
||||
-- Insert a newline on C-n
|
||||
onKeyWithEditor ed cs (Vty.EvKey (Vty.KChar 'n') m)
|
||||
| Vty.MCtrl `elem` m = updateEditor ed cs $ Vty.EvKey Vty.KEnter []
|
||||
-- Forward all other events as usual
|
||||
onKeyWithEditor ed cs ev = updateEditor ed cs ev
|
||||
|
||||
{- And the rest of the Brick application -}
|
||||
|
||||
clientDraw :: ClientState -> [Widget ResourceName]
|
||||
clientDraw cs = [padTopBottom 1 $ padLeftRight 2 vp]
|
||||
where
|
||||
tree = renderTree boxDrawingBranching (csEditor cs) (csTree cs)
|
||||
vp = viewport RnViewport Vertical tree
|
||||
|
||||
clientHandleEvent
|
||||
:: ClientState
|
||||
-> BrickEvent ResourceName Event
|
||||
-> ClientM (Next ClientState)
|
||||
clientHandleEvent cs (VtyEvent ev) = case csEditor cs of
|
||||
Nothing -> onKeyWithoutEditor cs ev
|
||||
Just ed -> onKeyWithEditor ed cs ev
|
||||
clientHandleEvent cs (AppEvent ev) = case ev of
|
||||
EventNode node -> continue cs{csTree = replaceNode node $ csTree cs}
|
||||
EventConnectionClosed -> halt cs
|
||||
clientHandleEvent cs _ = continue cs
|
||||
|
||||
clientAttrMap :: AttrMap
|
||||
clientAttrMap = attrMap Vty.defAttr
|
||||
[ ("expand", Vty.currentAttr `Vty.withStyle` Vty.bold `Vty.withForeColor` Vty.yellow)
|
||||
, ("focus", Vty.currentAttr `Vty.withBackColor` Vty.blue)
|
||||
, ("flags", Vty.currentAttr `Vty.withForeColor` Vty.brightBlack)
|
||||
]
|
||||
|
||||
clientApp :: App ClientState Event ResourceName
|
||||
clientApp = App
|
||||
{ appDraw = clientDraw
|
||||
, appChooseCursor = showFirstCursor
|
||||
, appHandleEvent = clientHandleEvent
|
||||
, appStartEvent = pure
|
||||
, appAttrMap = const clientAttrMap
|
||||
}
|
||||
|
||||
{- And now for the websocket connection handling -}
|
||||
|
||||
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
|
||||
|
||||
{- Gluing everything together -}
|
||||
|
||||
sendCloseEvent :: BChan Event -> SomeException -> IO ()
|
||||
sendCloseEvent eventChan e = do
|
||||
putStrLn $ "Encountered exception: " ++ show e
|
||||
writeBChan eventChan EventConnectionClosed
|
||||
import Forest.Client.Websocket
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- execParser clientOptionsParserInfo
|
||||
putStrLn "Connecting to server"
|
||||
runCorrectClient opts $ \conn -> do
|
||||
putStrLn "Performing initialization ritual"
|
||||
node <- performInitialContact conn
|
||||
chan <- newBChan 100
|
||||
let appState = newClientState chan node conn
|
||||
putStrLn "Starting WS thread"
|
||||
withThread (handle (sendCloseEvent chan) $ receiveUpdates chan node conn) $ do
|
||||
putStrLn "Starting UI"
|
||||
let vtyBuilder = Vty.mkVty Vty.defaultConfig
|
||||
initialVty <- vtyBuilder
|
||||
void $ customMain initialVty vtyBuilder (Just chan) clientApp appState
|
||||
putStrLn "Connection closed"
|
||||
runWithEventChan opts runClient
|
||||
|
|
|
|||
145
src/Forest/Client.hs
Normal file
145
src/Forest/Client.hs
Normal file
|
|
@ -0,0 +1,145 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Forest.Client
|
||||
( ClientState
|
||||
, newClientState
|
||||
, runClient
|
||||
) where
|
||||
|
||||
import Brick
|
||||
import Brick.BChan
|
||||
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.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 -}
|
||||
|
||||
onKeyWithoutEditor :: ClientState -> Vty.Event -> ClientM (Next ClientState)
|
||||
onKeyWithoutEditor cs (Vty.EvKey k _)
|
||||
| k `elem` quitKeys = halt cs
|
||||
| k `elem` foldKeys = onUiState cs foldAtFocus
|
||||
| k `elem` upKeys = onUiState cs moveFocusUp
|
||||
| k `elem` downKeys = onUiState cs moveFocusDown
|
||||
| k `elem` editKeys = onUiState cs editCurrentNode
|
||||
| k `elem` deleteKeys = do
|
||||
liftIO $ sendPacket (csConn cs) $ ClientDelete (getFocusedPath $ csUiState cs)
|
||||
continue cs
|
||||
| k `elem` replyKeys = onUiState cs replyToCurrentNode
|
||||
| k `elem` replyKeys' = onUiState cs replyAfterCurrentNode
|
||||
| k `elem` actKeys = do
|
||||
liftIO $ sendPacket (csConn cs) $ ClientAct (getFocusedPath $ csUiState cs)
|
||||
continue cs
|
||||
where
|
||||
quitKeys = [Vty.KChar 'q', Vty.KEsc]
|
||||
foldKeys = [Vty.KChar '\t']
|
||||
upKeys = [Vty.KChar 'k', Vty.KUp]
|
||||
downKeys = [Vty.KChar 'j', Vty.KDown]
|
||||
editKeys = [Vty.KChar 'e']
|
||||
deleteKeys = [Vty.KChar 'd']
|
||||
replyKeys = [Vty.KChar 'r']
|
||||
replyKeys' = [Vty.KChar 'R']
|
||||
actKeys = [Vty.KChar 'a', Vty.KChar ' ', Vty.KEnter]
|
||||
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.currentAttr `Vty.withStyle` Vty.bold `Vty.withForeColor` Vty.yellow)
|
||||
, ("focus", Vty.currentAttr `Vty.withBackColor` Vty.blue)
|
||||
, ("flags", Vty.currentAttr `Vty.withForeColor` 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,78 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Forest.Client.Node
|
||||
( DrawState(..)
|
||||
, nodeToTree
|
||||
) where
|
||||
|
||||
import Brick
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Forest.Client.NodeEditor
|
||||
import Forest.Client.ResourceName
|
||||
import Forest.Client.WidgetTree
|
||||
import Forest.Node
|
||||
import qualified Forest.OrderedMap as OMap
|
||||
|
||||
data DrawState = DrawState
|
||||
{ dsEditor :: Maybe NodeEditor
|
||||
, dsFocused :: Maybe Path
|
||||
, dsUnfolded :: Set.Set Path
|
||||
}
|
||||
|
||||
isFocused :: DrawState -> Bool
|
||||
isFocused ds = dsFocused ds == Just mempty
|
||||
|
||||
isFolded :: DrawState -> Bool
|
||||
isFolded ds = not $ mempty `Set.member` dsUnfolded ds
|
||||
|
||||
decorateExpand :: Bool -> Widget n -> Widget n
|
||||
decorateExpand True widget = withDefAttr "expand" widget
|
||||
decorateExpand False widget = withDefAttr "noexpand" widget
|
||||
|
||||
decorateFocus :: Bool -> Widget n -> Widget n
|
||||
decorateFocus True widget = visible $ withDefAttr "focus" widget
|
||||
decorateFocus False widget = withDefAttr "nofocus" widget
|
||||
|
||||
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)
|
||||
|
||||
narrowDrawState :: NodeId -> DrawState -> DrawState
|
||||
narrowDrawState nodeId ds = ds
|
||||
{ dsUnfolded = narrowSet nodeId $ dsUnfolded ds
|
||||
, dsFocused = narrow nodeId =<< dsFocused ds
|
||||
}
|
||||
|
||||
nodeToWidget :: Node -> Widget ResourceName
|
||||
nodeToWidget node = txtWrap $ nodeText node
|
||||
|
||||
subnodeToTree :: DrawState -> NodeId -> Node -> WidgetTree ResourceName
|
||||
subnodeToTree ds nodeId node =
|
||||
let newDs = narrowDrawState nodeId ds
|
||||
in nodeToTree newDs node
|
||||
|
||||
subnodesToTrees :: DrawState -> Node -> [WidgetTree ResourceName]
|
||||
subnodesToTrees ds = map (uncurry $ subnodeToTree ds) . OMap.toList . nodeChildren
|
||||
|
||||
nodeToTree :: DrawState -> Node -> WidgetTree ResourceName
|
||||
nodeToTree ds node = case dsEditor ds of
|
||||
Nothing -> WidgetTree nodeWidget subnodeWidgets
|
||||
Just ed
|
||||
| not focused -> WidgetTree nodeWidget subnodeWidgets
|
||||
| asReply ed -> WidgetTree nodeWidget (subnodeWidgets ++ [WidgetTree (renderNodeEditor ed) []])
|
||||
| otherwise -> WidgetTree (expand $ renderNodeEditor ed) subnodeWidgets
|
||||
where
|
||||
focused = isFocused ds
|
||||
folded = isFolded ds
|
||||
expand = decorateExpand $ hasChildren node
|
||||
nodeWidget =
|
||||
decorateFlags (nodeFlags node) $
|
||||
decorateFocus focused $
|
||||
expand $ nodeToWidget node
|
||||
subnodeWidgets = if folded then [] else subnodesToTrees ds node
|
||||
|
|
@ -3,63 +3,45 @@
|
|||
module Forest.Client.NodeEditor
|
||||
( NodeEditor
|
||||
, getCurrentText
|
||||
, asReply
|
||||
, editNode
|
||||
, replyToNode
|
||||
, beginEdit
|
||||
, handleNodeEditorEvent
|
||||
, renderNodeEditor
|
||||
) where
|
||||
|
||||
import Brick
|
||||
import Brick.Widgets.Edit
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Zipper
|
||||
import qualified Graphics.Vty as Vty
|
||||
import qualified Graphics.Vty as Vty
|
||||
import Lens.Micro
|
||||
|
||||
import Forest.Client.ResourceName
|
||||
newtype NodeEditor n = NodeEditor (Editor T.Text n)
|
||||
deriving (Show)
|
||||
|
||||
data NodeEditor = NodeEditor
|
||||
{ neEditor :: Editor T.Text ResourceName
|
||||
, neReply :: Bool
|
||||
} deriving (Show)
|
||||
getCurrentLines :: NodeEditor n -> [T.Text]
|
||||
getCurrentLines (NodeEditor e) = getEditContents e
|
||||
|
||||
getCurrentText :: NodeEditor -> [T.Text]
|
||||
getCurrentText = getEditContents . neEditor
|
||||
getCurrentText :: NodeEditor n -> T.Text
|
||||
getCurrentText = T.intercalate "\n" . getCurrentLines
|
||||
|
||||
asReply :: NodeEditor -> Bool
|
||||
asReply = neReply
|
||||
beginEdit :: n -> T.Text -> NodeEditor n
|
||||
beginEdit name = NodeEditor . applyEdit gotoEOL . editorText name Nothing
|
||||
|
||||
editNode :: T.Text -> NodeEditor
|
||||
editNode text = NodeEditor
|
||||
{ neEditor = applyEdit gotoEOL $ editorText RnEditor Nothing text
|
||||
, neReply = False
|
||||
}
|
||||
edit :: (TextZipper T.Text -> TextZipper T.Text) -> NodeEditor n -> EventM n (NodeEditor n)
|
||||
edit z (NodeEditor e) = pure $ NodeEditor $ applyEdit z e
|
||||
|
||||
replyToNode :: NodeEditor
|
||||
replyToNode = NodeEditor
|
||||
{ neEditor = editorText RnEditor Nothing ""
|
||||
, neReply = True
|
||||
}
|
||||
|
||||
edit :: (TextZipper T.Text -> TextZipper T.Text) -> NodeEditor -> EventM ResourceName NodeEditor
|
||||
edit z ne = pure $ ne{neEditor = applyEdit z $ neEditor ne}
|
||||
|
||||
handleNodeEditorEvent :: Vty.Event -> NodeEditor -> EventM ResourceName NodeEditor
|
||||
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 ne = do
|
||||
newEditor <- handleEditorEvent event $ neEditor ne
|
||||
pure ne{neEditor = newEditor}
|
||||
handleNodeEditorEvent event (NodeEditor e) = NodeEditor <$> handleEditorEvent event e
|
||||
|
||||
renderNodeEditor :: NodeEditor -> Widget ResourceName
|
||||
renderNodeEditor ne = makeVisible $ vLimit height $ renderEditor renderFunc True ed
|
||||
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
|
||||
ed = neEditor ne
|
||||
|
||||
height = length $ getCurrentText ne
|
||||
renderFunc :: [T.Text] -> Widget ResourceName
|
||||
renderFunc = vBox . map (\t -> if T.null t then txt " " else txt t)
|
||||
|
||||
(row, col) = cursorPosition $ ed ^. editContentsL
|
||||
height = length $ getCurrentLines ne
|
||||
(row, col) = cursorPosition $ e ^. editContentsL
|
||||
makeVisible = visibleRegion (Location (col, row)) (1, 1)
|
||||
|
|
|
|||
50
src/Forest/Client/NodeUtil.hs
Normal file
50
src/Forest/Client/NodeUtil.hs
Normal file
|
|
@ -0,0 +1,50 @@
|
|||
module Forest.Client.NodeUtil
|
||||
( Unfolded
|
||||
, foldVisibleNodes
|
||||
, applyFolds
|
||||
, flatten
|
||||
, 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 = foldVisibleNodes (\_ node _ -> node)
|
||||
|
||||
-- | Return the 'Path's to a node and its subnodes in the order they would be
|
||||
-- displayed in.
|
||||
flatten :: Node -> [Path]
|
||||
flatten node =
|
||||
let flattenedChildren =
|
||||
mapChildren (\nid n -> map (Path [nid] <>) $ flatten n) node
|
||||
in Path [] : concat flattenedChildren
|
||||
|
||||
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,6 +0,0 @@
|
|||
module Forest.Client.ResourceName
|
||||
( ResourceName(..)
|
||||
) where
|
||||
|
||||
data ResourceName = RnViewport | RnEditor
|
||||
deriving (Show, Eq, Ord)
|
||||
|
|
@ -1,142 +0,0 @@
|
|||
module Forest.Client.Tree
|
||||
( Tree
|
||||
, newTree
|
||||
, replaceNode
|
||||
, renderTree
|
||||
-- * Focused element
|
||||
, getCurrent
|
||||
, getCurrentPath
|
||||
, moveUp
|
||||
, moveDown
|
||||
-- * Folding
|
||||
, isCurrentFolded
|
||||
, foldCurrent
|
||||
, unfoldCurrent
|
||||
, toggleFold
|
||||
) where
|
||||
|
||||
import Brick
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Forest.Client.Node
|
||||
import Forest.Client.NodeEditor
|
||||
import Forest.Client.ResourceName
|
||||
import Forest.Client.WidgetTree
|
||||
import Forest.Node
|
||||
import qualified Forest.OrderedMap as OMap
|
||||
import Forest.Util
|
||||
|
||||
data Tree = Tree
|
||||
{ treeNode :: Node
|
||||
-- Invariant: The node pointed to by the focused path must always exist
|
||||
-- Invariant: The node pointed to by the focused path must not be folded away
|
||||
, treeFocused :: Path
|
||||
-- Invariant: The nodes pointed to by the unfolded paths must always exist
|
||||
, treeUnfolded :: Set.Set Path
|
||||
} deriving (Show)
|
||||
|
||||
-- | Find the focus path closest to the input path that still corresponds to a
|
||||
-- node in the input tree.
|
||||
findNearestFocus :: Node -> Path -> Path
|
||||
findNearestFocus _ (Path []) = Path []
|
||||
findNearestFocus node (Path (x:xs)) = case applyId x node of
|
||||
Nothing -> Path []
|
||||
Just child ->
|
||||
let (Path childPath) = findNearestFocus child $ Path xs
|
||||
in Path (x:childPath)
|
||||
|
||||
-- | Create a new tree, ensuring that all required invariants hold.
|
||||
newTree :: Node -> Path -> Set.Set Path -> Tree
|
||||
newTree node focused unfolded = Tree
|
||||
{ treeNode = node
|
||||
, treeFocused = safeFocused
|
||||
, treeUnfolded = safeUnfolded
|
||||
}
|
||||
where
|
||||
isValidFold :: Node -> Path -> Bool
|
||||
isValidFold n p = case applyPath p n of
|
||||
Nothing -> False
|
||||
Just childNode -> hasChildren childNode
|
||||
|
||||
foldedNode = applyFolds unfolded node
|
||||
safeUnfolded = Set.filter (isValidFold foldedNode) unfolded
|
||||
safeFocused = findNearestFocus (applyFolds safeUnfolded node) focused
|
||||
|
||||
-- | Switch out a tree's node, keeping as much of the focus and folding
|
||||
-- information as the type's invariants allow.
|
||||
replaceNode :: Node -> Tree -> Tree
|
||||
replaceNode node tree = newTree node (treeFocused tree) (treeUnfolded tree)
|
||||
|
||||
-- | Render a 'Tree' into a widget.
|
||||
renderTree :: IndentOptions -> Maybe NodeEditor -> Tree -> Widget ResourceName
|
||||
renderTree opts maybeEditor tree =
|
||||
renderWidgetTree opts $ nodeToTree drawState $ treeNode tree
|
||||
where
|
||||
drawState = DrawState
|
||||
{ dsEditor = maybeEditor
|
||||
, dsFocused = Just $ treeFocused tree
|
||||
, dsUnfolded = treeUnfolded tree
|
||||
}
|
||||
|
||||
{- Focused element -}
|
||||
|
||||
-- | Get the currently focused node.
|
||||
getCurrent :: Tree -> Node
|
||||
-- We rely on the invariant that the focused node always exists
|
||||
getCurrent tree = fromJust $ applyPath (treeFocused tree) (treeNode tree)
|
||||
|
||||
-- | Get the path of the currently focused node.
|
||||
getCurrentPath :: Tree -> Path
|
||||
getCurrentPath = treeFocused
|
||||
|
||||
flatten :: Node -> [Path]
|
||||
flatten node =
|
||||
let flattenedChildren =
|
||||
mapChildren (\nid n -> map (Path [nid] <>) $ flatten n) node
|
||||
in Path [] : concat flattenedChildren
|
||||
|
||||
moveWith :: ((Path -> Bool) -> [Path] -> Maybe Path) -> Tree -> Tree
|
||||
moveWith finder Tree{treeNode=n, treeFocused=f, treeUnfolded=u} =
|
||||
let flattened = flatten $ applyFolds u n
|
||||
target = fromMaybe f $ finder (==f) flattened
|
||||
in newTree n target u
|
||||
|
||||
-- | Move the focus upward by one node, if possible. Otherwise, do nothing.
|
||||
moveUp :: Tree -> Tree
|
||||
moveUp = moveWith findPrev
|
||||
|
||||
-- | Move the focus downward by one node, if possible. Otherwise, do nothing.
|
||||
moveDown :: Tree -> Tree
|
||||
moveDown = moveWith findNext
|
||||
|
||||
{- Folding -}
|
||||
|
||||
-- | Check if the currently focused node is folded.
|
||||
isCurrentFolded :: Tree -> Bool
|
||||
isCurrentFolded tree = not $ treeFocused tree `Set.member` treeUnfolded tree
|
||||
|
||||
-- | Fold the currently focused node. Does nothing if it is already folded.
|
||||
foldCurrent :: Tree -> Tree
|
||||
foldCurrent Tree{treeNode=n, treeFocused=f, treeUnfolded=u} =
|
||||
newTree n f $ Set.delete f u
|
||||
|
||||
-- | Unfold the currently focused node. Does nothing if it is already unfolded.
|
||||
unfoldCurrent :: Tree -> Tree
|
||||
unfoldCurrent Tree{treeNode=n, treeFocused=f, treeUnfolded=u} =
|
||||
newTree n f $ Set.insert f u
|
||||
|
||||
-- | Toggle whether the currently focused node is folded.
|
||||
toggleFold :: Tree -> Tree
|
||||
toggleFold tree
|
||||
| isCurrentFolded tree = unfoldCurrent tree
|
||||
| otherwise = foldCurrent tree
|
||||
|
||||
-- | Remove all nodes that would not be visible due to the folding.
|
||||
applyFolds :: Set.Set Path -> Node -> Node
|
||||
applyFolds unfolded node
|
||||
| mempty `Set.member` unfolded = node {nodeChildren = foldedChildren}
|
||||
| otherwise = node {nodeChildren = OMap.empty}
|
||||
where
|
||||
foldedChildren = OMap.mapWithKey applyFoldsToChild $ nodeChildren node
|
||||
applyFoldsToChild nid = applyFolds $ narrowSet nid unfolded
|
||||
238
src/Forest/Client/UiState.hs
Normal file
238
src/Forest/Client/UiState.hs
Normal file
|
|
@ -0,0 +1,238 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Forest.Client.UiState
|
||||
( UiState
|
||||
, newUiState
|
||||
, getFocusedPath
|
||||
, getFocusedNode
|
||||
-- * Modifying the UI state
|
||||
, replaceRootNode
|
||||
, moveFocusUp
|
||||
, moveFocusDown
|
||||
, foldAtFocus
|
||||
-- ** The node editor
|
||||
-- *** Creating
|
||||
, editCurrentNode
|
||||
, replyToCurrentNode
|
||||
, replyAfterCurrentNode
|
||||
-- *** Updating
|
||||
, isEditorActive
|
||||
, updateEditor
|
||||
-- *** Finishing the edit
|
||||
, EditResult(..)
|
||||
, finishEditing
|
||||
, abortEditing
|
||||
-- * Rendering the UI state
|
||||
, renderUiState
|
||||
) where
|
||||
|
||||
import qualified Graphics.Vty as Vty
|
||||
import Brick
|
||||
import Control.Monad
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Forest.Client.NodeEditor
|
||||
import Forest.Client.NodeUtil
|
||||
import Forest.Client.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
|
||||
}
|
||||
|
||||
getFocusedPath :: UiState n -> Path
|
||||
getFocusedPath = uiFocused
|
||||
|
||||
getFocusedNode :: UiState n -> Node
|
||||
getFocusedNode s = fromMaybe rootNode $ applyPath (uiFocused s) rootNode
|
||||
where
|
||||
rootNode = 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 x node of
|
||||
Nothing -> Path []
|
||||
Just child -> findValidParent child (Path xs)
|
||||
|
||||
-- | Modify the focused path so it always points to an existing node.
|
||||
validateFocused :: UiState n -> UiState n
|
||||
validateFocused s =
|
||||
let foldedRootNode = applyFolds (uiUnfolded s) (uiRootNode s)
|
||||
in s {uiFocused = findValidParent foldedRootNode $ uiFocused s}
|
||||
|
||||
-- | Close the editor if it doesn't point to a valid path.
|
||||
validateEditor :: UiState n -> UiState n
|
||||
validateEditor s = case uiEditor s of
|
||||
Nothing -> s
|
||||
Just e -> keepEditor $ fromMaybe False $ do
|
||||
node <- applyPath (eiPath e) (uiRootNode s)
|
||||
let flags = nodeFlags node
|
||||
pure $ if eiReply e then flagReply flags else flagEdit flags
|
||||
where
|
||||
keepEditor True = s
|
||||
keepEditor False = s {uiEditor = Nothing}
|
||||
|
||||
-- | Modify the UI state so it is consistent again.
|
||||
validate :: UiState n -> UiState n
|
||||
validate = validateEditor . validateFocused . validateUnfolded
|
||||
|
||||
replaceRootNode :: Node -> UiState n -> UiState n
|
||||
replaceRootNode node s = validate s {uiRootNode = node}
|
||||
|
||||
moveFocusUp :: UiState n -> UiState n
|
||||
moveFocusUp s =
|
||||
let foldedRootNode = applyFolds (uiUnfolded s) (uiRootNode s)
|
||||
in s {uiFocused = findPrevNode foldedRootNode $ uiFocused s}
|
||||
|
||||
moveFocusDown :: UiState n -> UiState n
|
||||
moveFocusDown s =
|
||||
let foldedRootNode = applyFolds (uiUnfolded s) (uiRootNode s)
|
||||
in s {uiFocused = findNextNode foldedRootNode $ uiFocused s}
|
||||
|
||||
foldAtFocus :: UiState n -> UiState n
|
||||
foldAtFocus s =
|
||||
let focused = uiFocused s
|
||||
unfolded = uiUnfolded s
|
||||
newUnfolded = if focused `Set.member` unfolded
|
||||
then Set.delete focused unfolded
|
||||
else Set.insert focused unfolded
|
||||
in validateUnfolded s {uiUnfolded = newUnfolded}
|
||||
|
||||
editNode :: Bool -> Path -> UiState n -> UiState n
|
||||
editNode reply path s =
|
||||
let text = maybe "" nodeText $ applyPath path $ uiRootNode 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
|
||||
|
||||
-- | Return an action to update the editor if the editor is currently active.
|
||||
-- Returns 'Nothing' otherwise.
|
||||
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 = case uiEditor s of
|
||||
Nothing -> (s, Nothing)
|
||||
Just e ->
|
||||
let editResult = EditResult
|
||||
{ erText = getCurrentText $ eiEditor e
|
||||
, erPath = eiPath e
|
||||
, erReply = eiReply e
|
||||
}
|
||||
in (abortEditing s, Just editResult)
|
||||
|
||||
abortEditing :: UiState n -> UiState n
|
||||
abortEditing s = s {uiEditor = Nothing}
|
||||
|
||||
{- Rendering -}
|
||||
|
||||
decorateExpand :: Bool -> Widget n -> Widget n
|
||||
decorateExpand True widget = withDefAttr "expand" widget
|
||||
decorateExpand False widget = withDefAttr "noexpand" widget
|
||||
|
||||
decorateFocus :: Bool -> Widget n -> Widget n
|
||||
decorateFocus True widget = visible $ withDefAttr "focus" widget
|
||||
decorateFocus False widget = withDefAttr "nofocus" widget
|
||||
|
||||
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 (not $ OMap.null $ nodeChildren node) $
|
||||
txtWrap $ nodeText node
|
||||
|
||||
beingEdited :: UiState n -> Path -> Maybe (EditorInfo n)
|
||||
beingEdited s path = do
|
||||
e <- uiEditor s
|
||||
if eiReply e
|
||||
then do
|
||||
p <- parent path
|
||||
guard $ p == eiPath e
|
||||
else
|
||||
guard $ path == eiPath e
|
||||
pure e
|
||||
|
||||
nodeToTree :: (Ord n, Show n) => UiState n -> Path -> Node -> Maybe [WidgetTree n] -> WidgetTree n
|
||||
nodeToTree s path node = withChildren $ case beingEdited s path of
|
||||
Just e -> renderNodeEditor $ eiEditor e
|
||||
Nothing -> renderNode isFocused node
|
||||
where
|
||||
withChildren :: Widget n -> Maybe [WidgetTree n] -> WidgetTree n
|
||||
withChildren nodeWidget = WidgetTree nodeWidget . fromMaybe []
|
||||
isFocused = isNothing (uiEditor s) && (path == uiFocused s)
|
||||
|
||||
renderUiState :: (Ord n, Show n) => IndentOptions -> UiState n -> Widget n
|
||||
renderUiState opts s =
|
||||
renderWidgetTree opts $
|
||||
foldVisibleNodes (nodeToTree s) (uiUnfolded s) (uiRootNode s)
|
||||
73
src/Forest/Client/Websocket.hs
Normal file
73
src/Forest/Client/Websocket.hs
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Forest.Client.Websocket
|
||||
( Event(..)
|
||||
, runWithEventChan
|
||||
) where
|
||||
|
||||
import Brick.BChan
|
||||
import Control.Exception
|
||||
import qualified Network.WebSockets as WS
|
||||
import qualified Wuss as WSS
|
||||
|
||||
import Forest.Api
|
||||
import Forest.Client.Options
|
||||
import Forest.Node
|
||||
import Forest.Util
|
||||
|
||||
data Event
|
||||
= EventNode Node
|
||||
| EventConnectionClosed
|
||||
|
||||
performInitialContact :: WS.Connection -> IO Node
|
||||
performInitialContact conn = do
|
||||
-- First, the client must send a hello packet containing the protocol
|
||||
-- extensions it requests.
|
||||
sendPacket conn $ ClientHello []
|
||||
-- Then, the server must reply with a hello packet containing the extensions
|
||||
-- that will be active for this connection, and an initial node.
|
||||
serverReply <- receivePacket conn
|
||||
case serverReply of
|
||||
(ServerHello [] node) -> pure node
|
||||
-- Since the client never requests any protocol extensions, the server must
|
||||
-- also reply with an empty list of extensions.
|
||||
(ServerHello _ _) -> closeWithErrorMessage conn "Invalid protocol extensions"
|
||||
_ -> closeWithErrorMessage conn "Invalid packet: Expected hello"
|
||||
|
||||
receiveUpdates :: BChan Event -> Node -> WS.Connection -> IO ()
|
||||
receiveUpdates eventChan node conn = do
|
||||
packet <- receivePacket conn
|
||||
case packet of
|
||||
ServerUpdate path subnode -> do
|
||||
let node' = replaceAt subnode path node
|
||||
writeBChan eventChan $ EventNode node'
|
||||
receiveUpdates eventChan node' conn -- Aaand close the loop :D
|
||||
_ -> closeWithErrorMessage conn "Invalid packet: Expected update"
|
||||
|
||||
runCorrectClient :: ClientOptions -> WS.ClientApp a -> IO a
|
||||
runCorrectClient opts app
|
||||
| ssl = WSS.runSecureClient name (fromInteger $ toInteger port) path app
|
||||
| otherwise = WS.runClient name port path app
|
||||
where
|
||||
-- I found this nicer to read than (ab-)using record syntax in the arguments
|
||||
name = clientHostName opts
|
||||
port = clientPort opts
|
||||
path = clientPath opts
|
||||
ssl = clientSsl opts
|
||||
|
||||
sendCloseEvent :: BChan Event -> SomeException -> IO ()
|
||||
sendCloseEvent eventChan e = do
|
||||
putStrLn $ "Encountered exception: " ++ show e
|
||||
writeBChan eventChan EventConnectionClosed
|
||||
|
||||
runWithEventChan :: ClientOptions -> (WS.Connection -> BChan Event -> Node -> IO ()) -> IO ()
|
||||
runWithEventChan opts f = do
|
||||
putStrLn "Connecting to server"
|
||||
runCorrectClient opts $ \conn -> do
|
||||
putStrLn "Performing initialization ritual"
|
||||
node <- performInitialContact conn
|
||||
chan <- newBChan 100
|
||||
putStrLn "Starting WS thread"
|
||||
let wsThread = handle (sendCloseEvent chan) $ receiveUpdates chan node conn
|
||||
withThread wsThread $ f conn chan node
|
||||
putStrLn "Connection closed and UI stopped"
|
||||
|
|
@ -20,7 +20,9 @@ module Forest.Node
|
|||
, appendAt
|
||||
, diffNodes
|
||||
, Path(..)
|
||||
, split
|
||||
, referencedNodeExists
|
||||
, splitHeadTail
|
||||
, splitInitLast
|
||||
, parent
|
||||
, narrow
|
||||
, narrowSet
|
||||
|
|
@ -157,7 +159,7 @@ replaceAt node = adjustAt $ const node
|
|||
|
||||
-- | Delete a subnode at a specified path. Does nothing if the path is 'mempty'.
|
||||
deleteAt :: Path -> Node -> Node
|
||||
deleteAt path node = case split path of
|
||||
deleteAt path node = case splitInitLast path of
|
||||
Nothing -> node
|
||||
Just (parentPath, nodeId) -> adjustAt
|
||||
(\n -> n{nodeChildren = OMap.delete nodeId $ nodeChildren n})
|
||||
|
|
@ -193,12 +195,19 @@ newtype Path = Path
|
|||
{ pathElements :: [NodeId]
|
||||
} deriving (Show, Eq, Ord, Semigroup, Monoid, ToJSON, FromJSON)
|
||||
|
||||
split :: Path -> Maybe (Path, NodeId)
|
||||
split (Path []) = Nothing
|
||||
split (Path xs) = Just (Path (init xs), last xs)
|
||||
referencedNodeExists :: Node -> Path -> Bool
|
||||
referencedNodeExists node path = isJust $ applyPath path node
|
||||
|
||||
splitHeadTail :: Path -> Maybe (NodeId, Path)
|
||||
splitHeadTail (Path []) = Nothing
|
||||
splitHeadTail (Path (x:xs)) = Just (x, Path xs)
|
||||
|
||||
splitInitLast :: Path -> Maybe (Path, NodeId)
|
||||
splitInitLast (Path []) = Nothing
|
||||
splitInitLast (Path xs) = Just (Path (init xs), last xs)
|
||||
|
||||
parent :: Path -> Maybe Path
|
||||
parent path = fst <$> split path
|
||||
parent path = fst <$> splitInitLast path
|
||||
|
||||
-- | Try to remove a 'NodeId' from the beginning of a 'Path'.
|
||||
narrow :: NodeId -> Path -> Maybe Path
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue