From 8c233ae4e04068e4db674ab64922bf44a62a5c3e Mon Sep 17 00:00:00 2001
From: Joscha <joscha@plugh.de>
Date: Tue, 18 Feb 2020 00:41:19 +0000
Subject: [PATCH] [server] Fix fork module

Previously, the fork module would return Just () on all actions. This made the
server disconnect any client after a successful action (e. g. editing a node).
---
 src/Forest/TreeModule/Fork.hs | 26 +++++++++++++++++---------
 1 file changed, 17 insertions(+), 9 deletions(-)

diff --git a/src/Forest/TreeModule/Fork.hs b/src/Forest/TreeModule/Fork.hs
index 1c4f612..d1b4d67 100644
--- a/src/Forest/TreeModule/Fork.hs
+++ b/src/Forest/TreeModule/Fork.hs
@@ -28,23 +28,31 @@ newtype ForkModule r = ForkModule (Map.Map NodeId Prong)
 instance TreeModule ForkModule () where
   edit _ (Path []) _ = pure Nothing
   edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
-    Just (Prong a) -> Just () <$ edit a (Path xs) text
-    Nothing        -> pure Nothing
+    Nothing -> pure Nothing
+    Just (Prong a) -> do
+      result <- edit a (Path xs) text
+      pure $ () <$ result
 
   delete _ (Path []) = pure Nothing
   delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
-    Just (Prong a) -> Just () <$ delete a (Path xs)
-    Nothing        -> pure Nothing
+    Nothing -> pure Nothing
+    Just (Prong a) -> do
+      result <- delete a (Path xs)
+      pure $ () <$ result
 
   reply _ (Path []) _ = pure Nothing
   reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of
-    Just (Prong a) -> Just () <$ reply a (Path xs) text
-    Nothing        -> pure Nothing
+    Nothing -> pure Nothing
+    Just (Prong a) -> do
+      result <- reply a (Path xs) text
+      pure $ () <$ result
 
   act _ (Path []) = pure Nothing
   act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of
-    Just (Prong a) -> Just () <$ act a (Path xs)
-    Nothing        -> pure Nothing
+    Nothing -> pure Nothing
+    Just (Prong a) -> do
+      result <- act a (Path xs)
+      pure $ () <$ result
 
 data ProngInfo = ProngInfo
   { piTopName :: T.Text
@@ -66,7 +74,7 @@ sendNodeFromProng :: MVar ProngInfo -> (Node -> IO ()) -> NodeId -> Node -> IO (
 sendNodeFromProng piVar sendNode nodeId node =
   modifyMVar_ piVar $ \pInfo -> do
     let newPInfo = pInfo {piNodes = Map.insert nodeId node $ piNodes pInfo}
-    sendNode $ renderProngInfo pInfo
+    sendNode $ renderProngInfo newPInfo
     pure newPInfo
 
 constructProngs