From 5902421872f763bbd3734a44411022c2532f3420 Mon Sep 17 00:00:00 2001
From: Joscha <joscha@plugh.de>
Date: Mon, 10 Feb 2020 23:48:44 +0000
Subject: [PATCH] Add very basic logging to server

---
 src/Forest/Node.hs   |  4 ----
 src/Forest/Server.hs | 20 ++++++++++++++++----
 2 files changed, 16 insertions(+), 8 deletions(-)

diff --git a/src/Forest/Node.hs b/src/Forest/Node.hs
index 992dc03..487ceff 100644
--- a/src/Forest/Node.hs
+++ b/src/Forest/Node.hs
@@ -8,7 +8,6 @@ module Forest.Node
     NodeId
   , Node(..)
   , emptyNode
-  , initialNode
   , hasChildren
   , mapChildren
   , applyId
@@ -60,9 +59,6 @@ instance FromJSON Node where
 emptyNode :: T.Text -> Bool -> Bool -> Bool -> Bool -> Node
 emptyNode text edit delete reply act = Node text edit delete reply act Map.empty
 
-initialNode :: Node
-initialNode = emptyNode "Loading..." False False False False
-
 hasChildren :: Node -> Bool
 hasChildren = not . Map.null . nodeChildren
 
diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs
index ace3669..739d4b5 100644
--- a/src/Forest/Server.hs
+++ b/src/Forest/Server.hs
@@ -20,6 +20,7 @@ sendUpdatesThread :: WS.Connection -> Chan Node -> Node -> IO ()
 sendUpdatesThread conn nodeChan _ = do
   newNode <- readChan nodeChan
   -- TODO Don't send the whole node every time
+  putStrLn $ "Sending full node update with " ++ show newNode
   sendPacket conn $ ServerUpdate (Path []) newNode
   sendUpdatesThread conn nodeChan newNode
 
@@ -29,10 +30,18 @@ receivePackets :: TreeModule a => WS.Connection -> a -> IO ()
 receivePackets conn treeModule = forever $ do
   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
+    ClientEdit path text -> do
+      putStrLn $ "Editing " ++ show path ++ " to " ++ show text
+      edit treeModule path text
+    ClientDelete path -> do
+      putStrLn $ "Deleting " ++ show path
+      delete treeModule path
+    ClientReply path text -> do
+      putStrLn $ "Replying to " ++ show path ++ " with " ++ show text
+      reply treeModule path text
+    ClientAct path -> do
+      putStrLn $ "Acting upon " ++ show path
+      act treeModule path
     ClientHello _ -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once"
 
 serverApp :: TreeModule a => Int -> ModuleConstructor a -> WS.ServerApp
@@ -43,7 +52,10 @@ serverApp pingDelay constructor pendingConnection = do
     firstPacket <- receivePacket conn
     case firstPacket of
       ClientHello _ -> do
+        putStrLn $ "Sending hello reply with " ++ show initialNode
         sendPacket conn $ ServerHello [] initialNode
         withThread (sendUpdatesThread conn chan initialNode) $
           constructor (writeChan chan) $ receivePackets conn
       _ -> closeWithErrorMessage conn "Invalid packet: Expected a hello packet"
+  where
+    initialNode = emptyNode "Loading ..." False False False False