diff --git a/client/Main.hs b/client/Main.hs index 7519d9a..4a11e56 100644 --- a/client/Main.hs +++ b/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 diff --git a/src/Forest/Client.hs b/src/Forest/Client.hs new file mode 100644 index 0000000..5b727da --- /dev/null +++ b/src/Forest/Client.hs @@ -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 diff --git a/src/Forest/Client/Node.hs b/src/Forest/Client/Node.hs deleted file mode 100644 index 5cbb0f9..0000000 --- a/src/Forest/Client/Node.hs +++ /dev/null @@ -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 diff --git a/src/Forest/Client/NodeEditor.hs b/src/Forest/Client/NodeEditor.hs index aefa448..aae8142 100644 --- a/src/Forest/Client/NodeEditor.hs +++ b/src/Forest/Client/NodeEditor.hs @@ -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) diff --git a/src/Forest/Client/NodeUtil.hs b/src/Forest/Client/NodeUtil.hs new file mode 100644 index 0000000..2ccb332 --- /dev/null +++ b/src/Forest/Client/NodeUtil.hs @@ -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 diff --git a/src/Forest/Client/ResourceName.hs b/src/Forest/Client/ResourceName.hs deleted file mode 100644 index 99adc15..0000000 --- a/src/Forest/Client/ResourceName.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Forest.Client.ResourceName - ( ResourceName(..) - ) where - -data ResourceName = RnViewport | RnEditor - deriving (Show, Eq, Ord) diff --git a/src/Forest/Client/Tree.hs b/src/Forest/Client/Tree.hs deleted file mode 100644 index 8891bd0..0000000 --- a/src/Forest/Client/Tree.hs +++ /dev/null @@ -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 diff --git a/src/Forest/Client/UiState.hs b/src/Forest/Client/UiState.hs new file mode 100644 index 0000000..16b701e --- /dev/null +++ b/src/Forest/Client/UiState.hs @@ -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) diff --git a/src/Forest/Client/Websocket.hs b/src/Forest/Client/Websocket.hs new file mode 100644 index 0000000..2b9d703 --- /dev/null +++ b/src/Forest/Client/Websocket.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Forest.Client.Websocket + ( Event(..) + , runWithEventChan + ) where + +import Brick.BChan +import Control.Exception +import qualified Network.WebSockets as WS +import qualified Wuss as WSS + +import Forest.Api +import Forest.Client.Options +import Forest.Node +import Forest.Util + +data Event + = EventNode Node + | EventConnectionClosed + +performInitialContact :: WS.Connection -> IO Node +performInitialContact conn = do + -- First, the client must send a hello packet containing the protocol + -- extensions it requests. + sendPacket conn $ ClientHello [] + -- Then, the server must reply with a hello packet containing the extensions + -- that will be active for this connection, and an initial node. + serverReply <- receivePacket conn + case serverReply of + (ServerHello [] node) -> pure node + -- Since the client never requests any protocol extensions, the server must + -- also reply with an empty list of extensions. + (ServerHello _ _) -> closeWithErrorMessage conn "Invalid protocol extensions" + _ -> closeWithErrorMessage conn "Invalid packet: Expected hello" + +receiveUpdates :: BChan Event -> Node -> WS.Connection -> IO () +receiveUpdates eventChan node conn = do + packet <- receivePacket conn + case packet of + ServerUpdate path subnode -> do + let node' = replaceAt subnode path node + writeBChan eventChan $ EventNode node' + receiveUpdates eventChan node' conn -- Aaand close the loop :D + _ -> closeWithErrorMessage conn "Invalid packet: Expected update" + +runCorrectClient :: ClientOptions -> WS.ClientApp a -> IO a +runCorrectClient opts app + | ssl = WSS.runSecureClient name (fromInteger $ toInteger port) path app + | otherwise = WS.runClient name port path app + where + -- I found this nicer to read than (ab-)using record syntax in the arguments + name = clientHostName opts + port = clientPort opts + path = clientPath opts + ssl = clientSsl opts + +sendCloseEvent :: BChan Event -> SomeException -> IO () +sendCloseEvent eventChan e = do + putStrLn $ "Encountered exception: " ++ show e + writeBChan eventChan EventConnectionClosed + +runWithEventChan :: ClientOptions -> (WS.Connection -> BChan Event -> Node -> IO ()) -> IO () +runWithEventChan opts f = do + putStrLn "Connecting to server" + runCorrectClient opts $ \conn -> do + putStrLn "Performing initialization ritual" + node <- performInitialContact conn + chan <- newBChan 100 + putStrLn "Starting WS thread" + let wsThread = handle (sendCloseEvent chan) $ receiveUpdates chan node conn + withThread wsThread $ f conn chan node + putStrLn "Connection closed and UI stopped" diff --git a/src/Forest/Node.hs b/src/Forest/Node.hs index bb55a47..c89b6c3 100644 --- a/src/Forest/Node.hs +++ b/src/Forest/Node.hs @@ -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