Hook up WS connection to client UI

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

package.yaml

@@ -24,6 +24,7 @@ dependencies:
 - transformers
 - vty
 - websockets
+- wuss
 
 library:
   source-dirs: src

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

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"

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