diff --git a/client/Main.hs b/client/Main.hs index 4ba757d..41e8206 100644 --- a/client/Main.hs +++ b/client/Main.hs @@ -3,12 +3,9 @@ module Main where import Brick -import Brick.Widgets.Border -import Brick.Widgets.Border.Style import Control.Concurrent.Chan import Control.Exception import Control.Monad -import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T import qualified Graphics.Vty as Vty @@ -26,19 +23,38 @@ import Forest.Util data Event = EventNode Node | EventConnectionClosed T.Text -wsClientApp :: Chan Event -> WS.ClientApp () -wsClientApp eventChan conn = handle handleConnectionException $ forever $ do +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 - Nothing -> pure () + -- Wait for ws exception since 'receivePacket' should have already closed + -- the connection. + Nothing -> waitForCloseException conn Just packet -> case packet of - ServerHello _ node -> writeChan eventChan (EventNode node) - -- TODO properly insert node into existing tree - ServerUpdate _ node -> writeChan eventChan (EventNode node) - where - handleConnectionException :: WS.ConnectionException -> IO () - handleConnectionException e = - writeChan eventChan $ EventConnectionClosed $ T.pack $ show e + 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-} diff --git a/src/Forest/Util.hs b/src/Forest/Util.hs index 2f76301..4eb6b7c 100644 --- a/src/Forest/Util.hs +++ b/src/Forest/Util.hs @@ -7,9 +7,11 @@ module Forest.Util , sendPacket , receivePacket , closeWithErrorMessage + , waitForCloseException ) where import Control.Concurrent.Async +import Control.Monad import Data.Aeson import Data.List import qualified Data.Text as T @@ -27,9 +29,6 @@ withThread thread main = withAsync thread $ const main sendPacket :: ToJSON a => WS.Connection -> a -> IO () sendPacket conn packet = WS.sendTextData conn $ encode packet -closeWithErrorMessage :: WS.Connection -> T.Text -> IO () -closeWithErrorMessage conn = WS.sendCloseCode conn 1003 - receivePacket :: FromJSON a => WS.Connection -> IO (Maybe a) receivePacket conn = do dataMessage <- WS.receiveDataMessage conn @@ -43,3 +42,9 @@ receivePacket conn = do 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