From 922488a8366f0bc416fa45982b5cdf3315cd6610 Mon Sep 17 00:00:00 2001 From: Joscha Date: Tue, 18 Feb 2020 10:23:54 +0000 Subject: [PATCH] [client] Remove client --- client/Main.hs | 12 -- package.yaml | 17 -- src/Forest/Client.hs | 148 ------------------ src/Forest/Client/NodeEditor.hs | 47 ------ src/Forest/Client/NodeUtil.hs | 56 ------- src/Forest/Client/Options.hs | 67 -------- src/Forest/Client/UiState.hs | 269 -------------------------------- src/Forest/Client/Websocket.hs | 73 --------- src/Forest/Client/WidgetTree.hs | 120 -------------- 9 files changed, 809 deletions(-) delete mode 100644 client/Main.hs delete mode 100644 src/Forest/Client.hs delete mode 100644 src/Forest/Client/NodeEditor.hs delete mode 100644 src/Forest/Client/NodeUtil.hs delete mode 100644 src/Forest/Client/Options.hs delete mode 100644 src/Forest/Client/UiState.hs delete mode 100644 src/Forest/Client/Websocket.hs delete mode 100644 src/Forest/Client/WidgetTree.hs diff --git a/client/Main.hs b/client/Main.hs deleted file mode 100644 index 4a11e56..0000000 --- a/client/Main.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Main where - -import Options.Applicative - -import Forest.Client -import Forest.Client.Options -import Forest.Client.Websocket - -main :: IO () -main = do - opts <- execParser clientOptionsParserInfo - runWithEventChan opts runClient diff --git a/package.yaml b/package.yaml index 0d6dcdc..375ed1d 100644 --- a/package.yaml +++ b/package.yaml @@ -16,17 +16,10 @@ dependencies: - base >= 4.7 && < 5 - aeson - async -- brick - containers -- microlens -- optparse-applicative -- safe - text -- text-zipper - transformers -- vty - websockets -- wuss library: source-dirs: src @@ -41,13 +34,3 @@ executables: - -with-rtsopts=-N dependencies: - forest - - forest-client: - main: Main.hs - source-dirs: client - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - forest diff --git a/src/Forest/Client.hs b/src/Forest/Client.hs deleted file mode 100644 index 9ed37fe..0000000 --- a/src/Forest/Client.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# 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 toggleFoldAtFocus - | k `elem` upKeys = onUiState cs moveFocusUp - | k `elem` downKeys = onUiState cs moveFocusDown - | k `elem` editKeys = onUiState cs editCurrentNode - | k `elem` deleteKeys = do - when (flagDelete $ nodeFlags $ getFocusedNode $ csUiState cs) $ - liftIO $ sendPacket (csConn cs) $ ClientDelete (getFocusedPath $ csUiState cs) - continue cs - | k `elem` replyKeys = onUiState cs (replyToCurrentNode . unfoldAtFocus) - | k `elem` replyKeys' = onUiState cs replyAfterCurrentNode - | k `elem` actKeys = do - when (flagAct $ nodeFlags $ getFocusedNode $ csUiState cs) $ - 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.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) - ] - -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/NodeEditor.hs b/src/Forest/Client/NodeEditor.hs deleted file mode 100644 index aae8142..0000000 --- a/src/Forest/Client/NodeEditor.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Client.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 -import Lens.Micro - -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 $ e ^. editContentsL - makeVisible = visibleRegion (Location (col, row)) (1, 1) diff --git a/src/Forest/Client/NodeUtil.hs b/src/Forest/Client/NodeUtil.hs deleted file mode 100644 index 1f0c031..0000000 --- a/src/Forest/Client/NodeUtil.hs +++ /dev/null @@ -1,56 +0,0 @@ -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 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 - --- | 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/Options.hs b/src/Forest/Client/Options.hs deleted file mode 100644 index ead27bf..0000000 --- a/src/Forest/Client/Options.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Forest.Client.Options - ( ClientOptions(..) - , clientOptionsParserInfo - ) where - -import Data.List -import Options.Applicative -import Options.Applicative.Help.Pretty - -data ClientOptions = ClientOptions - { clientHostName :: String - , clientPort :: Int - , clientPath :: String - , clientSsl :: Bool - } - -parser :: Parser ClientOptions -parser = ClientOptions - <$> strArgument - ( help "The name of the host to connect to" - <> metavar "HOST" - ) - <*> option auto - ( short 'p' - <> long "port" - <> help "The port to connect to" - <> value 11133 -- Chosen by fair dice roll - <> showDefault - <> metavar "PORT" - ) - <*> strOption - ( short 'P' - <> long "path" - <> help "The path to connect to on the given domain" - <> value "" - <> showDefault - <> metavar "PATH" - ) - <*> flag True False -- Ssl enabled by default - ( short 'n' - <> long "no-ssl" - <> help "This flag disables ssl on outgoing websocket connections" - ) - -keyBindings :: String -keyBindings = intercalate "\n" - [ "Key bindings:" - , " exit q, esc" - , " move cursor up/down, j/k" - , " toggle fold tab" - , " edit node e" - , " delete node d" - , " new child (reply) r" - , " new sibling R" - , " perform action a, enter, space" - , "" - , "Editor key bindings:" - , " confirm edit enter" - , " abort edit esc" - , " insert newline ctrl+n" - ] - -clientOptionsParserInfo :: ParserInfo ClientOptions -clientOptionsParserInfo = info (helper <*> parser) - ( fullDesc - <> footerDoc (Just $ string keyBindings) - ) diff --git a/src/Forest/Client/UiState.hs b/src/Forest/Client/UiState.hs deleted file mode 100644 index 915172b..0000000 --- a/src/Forest/Client/UiState.hs +++ /dev/null @@ -1,269 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Client.UiState - ( UiState - , newUiState - , getFocusedPath - , getFocusedNode - -- * Modifying the UI state - , replaceRootNode - , moveFocusUp - , moveFocusDown - , moveFocusToFirstChild - , moveFocusToLastChild - , moveFocusToFirstSibling - , moveFocusToLastSibling - , 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 Data.Maybe -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Graphics.Vty as Vty -import Safe - -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 -> Path [x] <> 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} - -moveFocus :: (Node -> Path -> Path) -> UiState n -> UiState n -moveFocus f s = - let foldedRootNode = applyFolds (uiUnfolded s) (uiRootNode s) - in validateFocused s {uiFocused = f foldedRootNode $ uiFocused s} - -moveFocusUp :: UiState n -> UiState n -moveFocusUp = moveFocus findPrevNode - -moveFocusDown :: UiState n -> UiState n -moveFocusDown = moveFocus findNextNode - -moveFocusToParent :: UiState n -> UiState n -moveFocusToParent = moveFocus $ \_ focused -> fromMaybe focused $ parent focused - -moveFocusToChild :: ([NodeId] -> Maybe NodeId) -> UiState n -> UiState n -moveFocusToChild f = moveFocus $ \node focused -> fromMaybe focused $ do - siblings <- nodeChildren <$> applyPath focused node - firstSiblingName <- f $ OMap.keys siblings - pure $ focused <> Path [firstSiblingName] - -moveFocusToFirstChild :: UiState n -> UiState n -moveFocusToFirstChild = moveFocusToChild headMay - -moveFocusToLastChild :: UiState n -> UiState n -moveFocusToLastChild = moveFocusToChild lastMay - -moveFocusToSibling :: ([NodeId] -> Maybe NodeId) -> UiState n -> UiState n -moveFocusToSibling f s - | uiFocused s == mempty = s - | otherwise = moveFocusToChild f $ moveFocusToParent s - -moveFocusToFirstSibling :: UiState n -> UiState n -moveFocusToFirstSibling = moveFocusToSibling headMay - -moveFocusToLastSibling :: UiState n -> UiState n -moveFocusToLastSibling = moveFocusToSibling lastMay - -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 $ getFocusedNode 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) $ moveFocusToLastChild 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 $ moveFocusToLastSibling 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 - -nodeToTree :: (Ord n, Show n) => UiState n -> Path -> Node -> Maybe [WidgetTree n] -> WidgetTree n -nodeToTree s path node maybeChildren = case uiEditor s of - Nothing -> - let isFocused = path == uiFocused s - in WidgetTree (renderNode isFocused node) children - Just e -> - let renderedEditor = renderNodeEditor $ eiEditor e - renderedEditorTree = WidgetTree renderedEditor [] - in if path /= eiPath e - then WidgetTree (renderNode False node) children - else if eiReply e - then WidgetTree (renderNode False node) $ children ++ [renderedEditorTree] - else WidgetTree renderedEditor children - where - children = fromMaybe [] maybeChildren - -renderUiState :: (Ord n, Show n) => IndentOptions -> UiState n -> Widget n -renderUiState opts s = - renderWidgetTree opts $ - foldVisibleNodes (nodeToTree s) (uiUnfolded s) (uiRootNode s) diff --git a/src/Forest/Client/Websocket.hs b/src/Forest/Client/Websocket.hs deleted file mode 100644 index 2b9d703..0000000 --- a/src/Forest/Client/Websocket.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Client.Websocket - ( Event(..) - , runWithEventChan - ) where - -import Brick.BChan -import Control.Exception -import qualified Network.WebSockets as WS -import qualified Wuss as WSS - -import Forest.Api -import Forest.Client.Options -import Forest.Node -import Forest.Util - -data Event - = EventNode Node - | EventConnectionClosed - -performInitialContact :: WS.Connection -> IO Node -performInitialContact conn = do - -- First, the client must send a hello packet containing the protocol - -- extensions it requests. - sendPacket conn $ ClientHello [] - -- Then, the server must reply with a hello packet containing the extensions - -- that will be active for this connection, and an initial node. - serverReply <- receivePacket conn - case serverReply of - (ServerHello [] node) -> pure node - -- Since the client never requests any protocol extensions, the server must - -- also reply with an empty list of extensions. - (ServerHello _ _) -> closeWithErrorMessage conn "Invalid protocol extensions" - _ -> closeWithErrorMessage conn "Invalid packet: Expected hello" - -receiveUpdates :: BChan Event -> Node -> WS.Connection -> IO () -receiveUpdates eventChan node conn = do - packet <- receivePacket conn - case packet of - ServerUpdate path subnode -> do - let node' = replaceAt subnode path node - writeBChan eventChan $ EventNode node' - receiveUpdates eventChan node' conn -- Aaand close the loop :D - _ -> closeWithErrorMessage conn "Invalid packet: Expected update" - -runCorrectClient :: ClientOptions -> WS.ClientApp a -> IO a -runCorrectClient opts app - | ssl = WSS.runSecureClient name (fromInteger $ toInteger port) path app - | otherwise = WS.runClient name port path app - where - -- I found this nicer to read than (ab-)using record syntax in the arguments - name = clientHostName opts - port = clientPort opts - path = clientPath opts - ssl = clientSsl opts - -sendCloseEvent :: BChan Event -> SomeException -> IO () -sendCloseEvent eventChan e = do - putStrLn $ "Encountered exception: " ++ show e - writeBChan eventChan EventConnectionClosed - -runWithEventChan :: ClientOptions -> (WS.Connection -> BChan Event -> Node -> IO ()) -> IO () -runWithEventChan opts f = do - putStrLn "Connecting to server" - runCorrectClient opts $ \conn -> do - putStrLn "Performing initialization ritual" - node <- performInitialContact conn - chan <- newBChan 100 - putStrLn "Starting WS thread" - let wsThread = handle (sendCloseEvent chan) $ receiveUpdates chan node conn - withThread wsThread $ f conn chan node - putStrLn "Connection closed and UI stopped" diff --git a/src/Forest/Client/WidgetTree.hs b/src/Forest/Client/WidgetTree.hs deleted file mode 100644 index 7b4cad3..0000000 --- a/src/Forest/Client/WidgetTree.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Client.WidgetTree - ( WidgetTree(..) - , renderWidgetTree - , treeLineAttr - , IndentOptions(..) - , boxDrawingBranching - , boxDrawingLine - , asciiBranching - , asciiLine - ) where - -import Brick -import Brick.BorderMap -import Control.Monad.Trans.Reader -import qualified Data.Text as T -import qualified Graphics.Vty as Vty -import Lens.Micro - -data WidgetTree n = WidgetTree (Widget n) [WidgetTree n] - -addLoc :: Location -> Location -> Location -addLoc l1 l2 = - let (x1, y1) = loc l1 - (x2, y2) = loc l2 - in Location (x1 + x2, y1 + y2) - -offsetResult :: Location -> Result n -> Result n -offsetResult offset result = result - { cursors = map offsetCursor $ cursors result - , visibilityRequests = map offsetVr $ visibilityRequests result - , extents = map offsetExtent $ extents result - , borders = translate offset $ borders result - } - where - offsetCursor c = c{cursorLocation = addLoc offset $ cursorLocation c} - offsetVr vr = vr{vrPosition = addLoc offset $ vrPosition vr} - offsetExtent e = e - { extentUpperLeft = addLoc offset $ extentUpperLeft e - , extentOffset = addLoc offset $ extentOffset e - } - -indentWith :: T.Text -> T.Text -> Widget n -> Widget n -indentWith firstLine otherLines wrapped = Widget - { hSize = hSize wrapped - , vSize = vSize wrapped - , render = renderWidget - } - where - maxWidth = max (T.length firstLine) (T.length otherLines) - renderWidget = do - context <- ask - result <- render $ hLimit (availWidth context - maxWidth) wrapped - let attribute = attrMapLookup treeLineAttr $ context ^. ctxAttrMapL - resultHeight = Vty.imageHeight $ image result - textLines = firstLine : replicate (resultHeight - 1) otherLines - leftImage = Vty.vertCat $ map (Vty.text' attribute) textLines - newImage = leftImage Vty.<|> image result - newResult = offsetResult (Location (maxWidth, 0)) $ result{image=newImage} - pure newResult - -indent :: IndentOptions -> [Widget n] -> Widget n -indent opts widgets = vBox $ reverse $ case reverse widgets of - [] -> [] - (w:ws) -> - indentWith (lastBranch opts) (afterLastBranch opts) w : - map (indentWith (inlineBranch opts) (noBranch opts)) ws - -renderWidgetTree :: IndentOptions -> WidgetTree n -> Widget n -renderWidgetTree opts (WidgetTree node children) = - node <=> indent opts (map (renderWidgetTree opts) children) - -treeLineAttr :: AttrName -treeLineAttr = "treeLine" - --- | These options control how a tree is rendered. For more information on how --- the various options are used, try rendering a tree with 'boxDrawingBranhing' --- and inspect the results. --- --- Warning: The options *must* be single line strings and *must not* contain --- newlines of any sort. -data IndentOptions = IndentOptions - { noBranch :: T.Text - , inlineBranch :: T.Text - , lastBranch :: T.Text - , afterLastBranch :: T.Text - } deriving (Show, Eq) - -boxDrawingBranching :: IndentOptions -boxDrawingBranching = IndentOptions - { noBranch = "│ " - , inlineBranch = "├╴" - , lastBranch = "└╴" - , afterLastBranch = " " - } - -boxDrawingLine :: IndentOptions -boxDrawingLine = IndentOptions - { noBranch = "│ " - , inlineBranch = "│ " - , lastBranch = "│ " - , afterLastBranch = "│ " - } - -asciiBranching :: IndentOptions -asciiBranching = IndentOptions - { noBranch = "| " - , inlineBranch = "+-" - , lastBranch = "+-" - , afterLastBranch = " " - } - -asciiLine :: IndentOptions -asciiLine = IndentOptions - { noBranch = "| " - , inlineBranch = "| " - , lastBranch = "| " - , afterLastBranch = "| " - }