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 +++++++++++++++--
 src/Erebos/Network/Protocol.hs |  4 +++-
 2 files changed, 18 insertions(+), 3 deletions(-)

(limited to 'src')

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
diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs
index e629967..bd640ac 100644
--- a/src/Erebos/Network/Protocol.hs
+++ b/src/Erebos/Network/Protocol.hs
@@ -213,6 +213,7 @@ data GlobalState addr = (Eq addr, Show addr) => GlobalState
     , gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr)
     , gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject))
     , gLog :: String -> STM ()
+    , gTestLog :: String -> STM ()
     , gStorage :: PartialStorage
     , gStartTime :: TimeSpec
     , gNowVar :: TVar TimeSpec
@@ -494,10 +495,11 @@ data ControlMessage addr = NewConnection (Connection addr) (Maybe RefDigest)
 erebosNetworkProtocol :: (Eq addr, Ord addr, Show addr)
                       => UnifiedIdentity
                       -> (String -> STM ())
+                      -> (String -> STM ())
                       -> SymFlow (addr, ByteString)
                       -> Flow (ControlRequest addr) (ControlMessage addr)
                       -> IO ()
-erebosNetworkProtocol initialIdentity gLog gDataFlow gControlFlow = do
+erebosNetworkProtocol initialIdentity gLog gTestLog gDataFlow gControlFlow = do
     gIdentity <- newTVarIO (initialIdentity, [])
     gConnections <- newTVarIO []
     gNextUp <- newEmptyTMVarIO
-- 
cgit v1.2.3