Hook up WS connection to client UI

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