Server test log

3 files changed, 26 insertions, 7 deletions

diff --git a/main/Test.hs b/main/Test.hs
index c978a6a..b1c8f01 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -504,16 +504,18 @@ cmdStartServer = do
 
     let parseParams = \case
             (name : value : rest)
-                | name == "services" -> T.splitOn "," value
+                | name == "services" -> second ( map splitServiceParams (T.splitOn "," value) ++ ) (parseParams rest)
+            (name : rest)
+                | name == "test-log" -> first (\o -> o { serverTestLog = True }) (parseParams rest)
                 | otherwise -> parseParams rest
-            _ -> []
+            _ -> ( defaultServerOptions { serverErrorPrefix = "server-error-message " }, [] )
 
         splitServiceParams svc =
             case T.splitOn ":" svc of
                 name : params -> ( name, params )
                 _ -> ( svc, [] )
 
-    serviceNames <- map splitServiceParams . parseParams <$> asks tiParams
+    ( serverOptions, serviceNames ) <- parseParams <$> asks tiParams
 
     h <- getOrLoadHead
     rsPeers <- liftIO $ newMVar (1, [])
@@ -547,7 +549,9 @@ cmdStartServer = do
             }
         ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'"
 
-    rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services
+    let logPrint str = do BC.hPutStrLn stdout (BC.pack str)
+                          hFlush stdout
+    rsServer <- liftIO $ startServer serverOptions h logPrint services
 
     rsPeerThread <- liftIO $ forkIO $ void $ forever $ do
         peer <- getNextPeerChange rsServer
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