diff --git a/client/Main.hs b/client/Main.hs index 41e8206..e935c82 100644 --- a/client/Main.hs +++ b/client/Main.hs @@ -3,132 +3,95 @@ module Main where import Brick -import Control.Concurrent.Chan +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.Options import Forest.Client.ResourceName import Forest.Client.Tree import Forest.Client.WidgetTree import Forest.Node import Forest.Util -{- Listening for server events -} +{- First, the UI types -} -data Event = EventNode Node | EventConnectionClosed T.Text - -sendCloseEvent :: Chan Event -> WS.ConnectionException -> IO () -sendCloseEvent eventChan e = writeChan eventChan $ EventConnectionClosed $ T.pack $ show e - -receiveUpdates :: Chan Event -> Node -> WS.Connection -> IO () -receiveUpdates eventChan node conn = handle (sendCloseEvent eventChan) $ do - maybePacket <- receivePacket conn - case maybePacket of - -- Wait for ws exception since 'receivePacket' should have already closed - -- the connection. - Nothing -> waitForCloseException conn - Just packet -> case packet of - ServerUpdate path subnode -> do - let newNode = replaceAt subnode path node - writeChan eventChan $ EventNode newNode - receiveUpdates eventChan newNode conn - _ -> do - closeWithErrorMessage conn "Invalid packet: Expected update" - waitForCloseException conn - -wsClientApp :: Chan Event -> WS.ClientApp () -wsClientApp eventChan conn = handle (sendCloseEvent eventChan) $ do - maybePacket <- receivePacket conn - case maybePacket of - -- Wait for ws exception since 'receivePacket' should have already closed - -- the connection. - Nothing -> waitForCloseException conn - Just (ServerHello _ node) -> do - writeChan eventChan $ EventNode node - receiveUpdates eventChan node conn - _ -> do - closeWithErrorMessage conn "Invalid packet: Expected hello" - waitForCloseException conn - -{- Brick client application-} +data Event = EventNode Node + | EventConnectionClosed T.Text data ClientState = ClientState - { csTree :: Tree - , csEditor :: Maybe NodeEditor + { csTree :: Tree + , csEditor :: Maybe NodeEditor + , csConn :: WS.Connection + , csEventChan :: BChan Event } -newClientState :: Node -> ClientState -newClientState node = ClientState - { csTree = newTree node localPath Set.empty - , csEditor = Nothing +newClientState :: BChan Event -> Node -> WS.Connection -> ClientState +newClientState eventChan node conn = ClientState + { csTree = newTree node localPath Set.empty + , csEditor = Nothing + , csConn = conn + , csEventChan = eventChan } type ClientM a = EventM ResourceName a -{- Normal actions -} - -quitKeys :: [Vty.Key] -quitKeys = [Vty.KEsc, Vty.KChar 'q'] - -foldKeys :: [Vty.Key] -foldKeys = [Vty.KChar '\t'] +{- Actions in normal mode -} foldAction :: ClientState -> ClientM (Next ClientState) foldAction cs = continue cs{csTree = toggleFold $ csTree cs} -upKeys :: [Vty.Key] -upKeys = [Vty.KUp, Vty.KChar 'k'] - upAction :: ClientState -> ClientM (Next ClientState) upAction cs = continue cs{csTree = moveUp $ csTree cs} -downKeys :: [Vty.Key] -downKeys = [Vty.KDown, Vty.KChar 'j'] - downAction :: ClientState -> ClientM (Next ClientState) downAction cs = continue cs{csTree = moveDown $ csTree cs} -editKeys :: [Vty.Key] -editKeys = [Vty.KChar 'e'] - editAction :: ClientState -> ClientM (Next ClientState) editAction cs = let node = getCurrent $ csTree cs editor = editNode $ nodeText node in continue cs{csEditor = Just editor} -deleteKeys :: [Vty.Key] -deleteKeys = [Vty.KChar 'e'] - -replyKeys :: [Vty.Key] -replyKeys = [Vty.KChar 'r'] +deleteAction :: ClientState -> ClientM (Next ClientState) +deleteAction cs = continue cs -- TODO implement replyAction :: ClientState -> ClientM (Next ClientState) replyAction cs = continue cs{csEditor = Just replyToNode} -actKeys :: [Vty.Key] -actKeys = [Vty.KEnter, Vty.KChar 'a'] +actAction :: ClientState -> ClientM (Next ClientState) +actAction cs = continue cs -- TODO implement -onKeyWithoutEditor - :: ClientState - -> Vty.Event - -> EventM ResourceName (Next ClientState) +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` replyKeys = replyAction cs + | 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.KEsc, Vty.KChar 'q'] + foldKeys = [Vty.KChar '\t'] + upKeys = [Vty.KUp, Vty.KChar 'k'] + downKeys = [Vty.KDown, Vty.KChar 'j'] + editKeys = [Vty.KChar 'e'] + deleteKeys = [Vty.KChar 'e'] + replyKeys = [Vty.KChar 'r'] + actKeys = [Vty.KEnter, Vty.KChar 'a'] onKeyWithoutEditor cs _ = continue cs -{- Editor actions -} +{- Actions in edit mode -} updateEditor :: NodeEditor -> ClientState -> Vty.Event -> ClientM (Next ClientState) updateEditor ed cs ev = do @@ -144,17 +107,23 @@ onKeyWithEditor ed cs (Vty.EvKey (Vty.KChar 'n') m) -- Forward all other events as usual onKeyWithEditor ed cs ev = updateEditor ed cs ev -{- Constructing the client app -} +{- And the rest of the Brick application -} clientDraw :: ClientState -> [Widget ResourceName] clientDraw cs = [padTop (Pad 1) $ padLeft (Pad 2) tree] where tree = renderTree boxDrawingBranching (csEditor cs) (csTree cs) -clientHandleEvent :: ClientState -> BrickEvent ResourceName () -> EventM ResourceName (Next ClientState) +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 @@ -164,7 +133,7 @@ clientAttrMap = attrMap Vty.defAttr , ("flags", Vty.currentAttr `Vty.withForeColor` Vty.brightBlack) ] -clientApp :: App ClientState () ResourceName +clientApp :: App ClientState Event ResourceName clientApp = App { appDraw = clientDraw , appChooseCursor = showFirstCursor @@ -173,5 +142,58 @@ clientApp = App , 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" + +sendCloseEvent :: BChan Event -> WS.ConnectionException -> IO () +sendCloseEvent eventChan = + writeBChan eventChan . EventConnectionClosed . T.pack . show + +receiveUpdates :: BChan Event -> Node -> WS.Connection -> IO () +receiveUpdates eventChan node conn = handle (sendCloseEvent eventChan) $ do + packet <- receivePacket conn + case packet of + ServerUpdate path subnode -> do + let newNode = replaceAt subnode path node + writeBChan eventChan $ EventNode newNode + receiveUpdates eventChan newNode 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 -} + main :: IO () -main = void $ defaultMain clientApp $ newClientState exampleNode +main = do + opts <- execParser clientOptionsParserInfo + runCorrectClient opts $ \conn -> do + node <- performInitialContact conn + chan <- newBChan 100 + let appState = newClientState chan node conn + withThread (receiveUpdates chan node conn) $ do + let vtyBuilder = Vty.mkVty Vty.defaultConfig + initialVty <- vtyBuilder + void $ customMain initialVty vtyBuilder (Just chan) clientApp appState diff --git a/package.yaml b/package.yaml index 2f7ebc0..63b9343 100644 --- a/package.yaml +++ b/package.yaml @@ -24,6 +24,7 @@ dependencies: - transformers - vty - websockets +- wuss library: source-dirs: src diff --git a/src/Forest/Client/Tree.hs b/src/Forest/Client/Tree.hs index 7c4844c..9f409b2 100644 --- a/src/Forest/Client/Tree.hs +++ b/src/Forest/Client/Tree.hs @@ -1,7 +1,7 @@ module Forest.Client.Tree ( Tree , newTree - , switchNode + , replaceNode , renderTree -- * Focused element , getCurrent @@ -64,8 +64,8 @@ newTree node focused unfolded = Tree -- | Switch out a tree's node, keeping as much of the focus and folding -- information as the type's invariants allow. -switchNode :: Node -> Tree -> Tree -switchNode node tree = newTree node (treeFocused tree) (treeUnfolded tree) +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 diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs index 2e93eb3..ace3669 100644 --- a/src/Forest/Server.hs +++ b/src/Forest/Server.hs @@ -27,16 +27,13 @@ sendUpdatesThread conn nodeChan _ = do receivePackets :: TreeModule a => WS.Connection -> a -> IO () receivePackets conn treeModule = forever $ do - maybePacket <- receivePacket conn - case maybePacket of - Nothing -> pure () - Just packet -> - case packet of - ClientEdit path text -> edit treeModule path text - ClientDelete path -> delete treeModule path - ClientReply path text -> reply treeModule path text - ClientAct path -> act treeModule path - ClientHello _ -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once" + packet <- receivePacket conn + case packet of + ClientEdit path text -> edit treeModule path text + ClientDelete path -> delete treeModule path + ClientReply path text -> reply treeModule path text + ClientAct path -> act treeModule path + ClientHello _ -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once" serverApp :: TreeModule a => Int -> ModuleConstructor a -> WS.ServerApp serverApp pingDelay constructor pendingConnection = do @@ -45,9 +42,8 @@ serverApp pingDelay constructor pendingConnection = do WS.withPingThread conn pingDelay (pure ()) $ do firstPacket <- receivePacket conn case firstPacket of - Nothing -> pure () - Just (ClientHello _) -> do + ClientHello _ -> do sendPacket conn $ ServerHello [] initialNode withThread (sendUpdatesThread conn chan initialNode) $ constructor (writeChan chan) $ receivePackets conn - Just _ -> closeWithErrorMessage conn "Invalid packet: Expected a hello packet" + _ -> closeWithErrorMessage conn "Invalid packet: Expected a hello packet" diff --git a/src/Forest/Util.hs b/src/Forest/Util.hs index 4eb6b7c..04ef67b 100644 --- a/src/Forest/Util.hs +++ b/src/Forest/Util.hs @@ -5,9 +5,8 @@ module Forest.Util , findNext , withThread , sendPacket - , receivePacket , closeWithErrorMessage - , waitForCloseException + , receivePacket ) where import Control.Concurrent.Async @@ -29,7 +28,14 @@ withThread thread main = withAsync thread $ const main sendPacket :: ToJSON a => WS.Connection -> a -> IO () sendPacket conn packet = WS.sendTextData conn $ encode packet -receivePacket :: FromJSON a => WS.Connection -> IO (Maybe a) +waitForCloseException :: WS.Connection -> IO a +waitForCloseException conn = forever $ void $ WS.receiveDataMessage conn + +closeWithErrorMessage :: WS.Connection -> T.Text -> IO a +closeWithErrorMessage conn text = + WS.sendCloseCode conn 1003 text >> waitForCloseException conn + +receivePacket :: FromJSON a => WS.Connection -> IO a receivePacket conn = do dataMessage <- WS.receiveDataMessage conn closeOnErrorMessage $ case dataMessage of @@ -38,13 +44,6 @@ receivePacket conn = do Left errorMsg -> Left $ "Invalid packet: " <> T.pack errorMsg Right packet -> Right packet where - closeOnErrorMessage :: Either T.Text a -> IO (Maybe a) - closeOnErrorMessage (Right a) = pure $ Just a - closeOnErrorMessage (Left errorMsg) = - Nothing <$ closeWithErrorMessage conn errorMsg - -closeWithErrorMessage :: WS.Connection -> T.Text -> IO () -closeWithErrorMessage conn = WS.sendCloseCode conn 1003 - -waitForCloseException :: WS.Connection -> IO () -waitForCloseException conn = forever $ void $ WS.receiveDataMessage conn + closeOnErrorMessage :: Either T.Text a -> IO a + closeOnErrorMessage (Right a) = pure a + closeOnErrorMessage (Left errorMsg) = closeWithErrorMessage conn errorMsg