From 33add1fb412a9af173c10f8cdd957c3638d4df7f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 13 Jul 2025 21:05:02 +0200
Subject: Server test log

---
 src/Erebos/Network.hs | 17 +++++++++++++++--
 1 file changed, 15 insertions(+), 2 deletions(-)

(limited to 'src/Erebos/Network.hs')

diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs
index 60d4f00..a90f5d8 100644
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -114,12 +114,16 @@ getNextPeerChange = atomically . readTChan . serverChanPeer
 data ServerOptions = ServerOptions
     { serverPort :: PortNumber
     , serverLocalDiscovery :: Bool
+    , serverErrorPrefix :: String
+    , serverTestLog :: Bool
     }
 
 defaultServerOptions :: ServerOptions
 defaultServerOptions = ServerOptions
     { serverPort = discoveryPort
     , serverLocalDiscovery = True
+    , serverErrorPrefix = ""
+    , serverTestLog = False
     }
 
 
@@ -254,7 +258,16 @@ startServer serverOptions serverOrigHead logd' serverServices = do
 
     let logd = writeTQueue serverErrorLog
     forkServerThread server $ forever $ do
-        logd' =<< atomically (readTQueue serverErrorLog)
+        logd' . (serverErrorPrefix serverOptions <>) =<< atomically (readTQueue serverErrorLog)
+
+    logt <- if
+        | serverTestLog serverOptions -> do
+            serverTestLog <- newTQueueIO
+            forkServerThread server $ forever $ do
+                logd' =<< atomically (readTQueue serverTestLog)
+            return $ writeTQueue serverTestLog
+        | otherwise -> do
+            return $ \_ -> return ()
 
     forkServerThread server $ dataResponseWorker server
     forkServerThread server $ forever $ do
@@ -378,7 +391,7 @@ startServer serverOptions serverOrigHead logd' serverServices = do
                     ReceivedAnnounce addr _ -> do
                         void $ serverPeer' server addr
 
-            erebosNetworkProtocol (headLocalIdentity serverOrigHead) logd protocolRawPath protocolControlFlow
+            erebosNetworkProtocol (headLocalIdentity serverOrigHead) logd logt protocolRawPath protocolControlFlow
 
     forkServerThread server $ withSocketsDo $ do
         let hints = defaultHints
-- 
cgit v1.2.3