From e917893a9bc27bd33895351d18820cca6344ba26 Mon Sep 17 00:00:00 2001
From: Joscha <joscha@plugh.de>
Date: Tue, 18 Feb 2020 00:42:57 +0000
Subject: [PATCH] [server] Print exceptions encountered during a connection

---
 src/Forest/Server.hs | 10 ++++++++--
 1 file changed, 8 insertions(+), 2 deletions(-)

diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs
index 228c1fa..e8e3716 100644
--- a/src/Forest/Server.hs
+++ b/src/Forest/Server.hs
@@ -7,6 +7,7 @@ module Forest.Server
   ) where
 
 import           Control.Concurrent.Chan
+import           Control.Exception
 import qualified Network.WebSockets      as WS
 
 import           Forest.Api
@@ -48,18 +49,23 @@ receivePackets conn treeModule = runUntilJustM $ do
       act treeModule path
     ClientHello _ -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once"
 
+printException :: SomeException -> IO ()
+printException e = putStrLn $ "Encountered exception: " ++ show e
+
 serverApp :: TreeModule a () => Int -> ModuleConstructor (a ()) -> WS.ServerApp
 serverApp pingDelay constructor pendingConnection = do
   conn <- WS.acceptRequest pendingConnection
   chan <- newChan
-  WS.withPingThread conn pingDelay (pure ()) $ do
+  WS.withPingThread conn pingDelay (pure ()) $ handle printException $ 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
+          constructor (writeChan chan) $ \tm -> do
+            receivePackets conn tm
+            putStrLn "Module finished, closing connection"
       _ -> closeWithErrorMessage conn "Invalid packet: Expected a hello packet"
   where
     initialNode = txtNode "" "Loading..."