From e7ec259c92718ee10257ef0537aa1d5fa6a59ab0 Mon Sep 17 00:00:00 2001
From: Pascal Grange <pascal@grange.nom.fr>
Date: Wed, 1 Feb 2023 09:02:31 +0000
Subject: [PATCH] FIX Async issue with tracer

The log tracer used to be multi-threaded, using a queue to store
messages and a thread consuming these messages, posting it to
stdout and flushing stdout.

We observe some race condition at the end of the program execution
that could lead to lost logs.

For instance this test run exhibit the problem: https://github.com/input-output-hk/hydra/actions/runs/4056786570/jobs/6981708131

One thread reads the next message to write from the queue and is
interrupted before actually writing it. Then the _flush_ function is
finally called, reading the full messages queue and writing each of
these messages to stdout. Unfortunately, the message taken but not
written yet is lots.

This could be quite of a bummer in case of problem: the hydra-node
could crash and then, looking at the logs, we would see the last logs
but one missing and that could lead to problematic diagnosis.

We decide to remove this multi-threading for now and proceed as follow:
* all logs are written to sdtout
* we trust _the system_ to manage the buffering and flushing of data
* finally, when the process stops, we explicitly flush all the buffered
  messages.
---
 hydra-node/src/Hydra/Logging.hs | 36 +++++++++------------------------
 1 file changed, 9 insertions(+), 27 deletions(-)

diff --git a/hydra-node/src/Hydra/Logging.hs b/hydra-node/src/Hydra/Logging.hs
index 0685f859e84..b425f25dda2 100644
--- a/hydra-node/src/Hydra/Logging.hs
+++ b/hydra-node/src/Hydra/Logging.hs
@@ -30,13 +30,9 @@ import Hydra.Prelude
 import Cardano.BM.Tracing (ToObject (..), TracingVerbosity (..))
 import Control.Monad.Class.MonadFork (myThreadId)
 import Control.Monad.Class.MonadSTM (
-  flushTBQueue,
   modifyTVar,
-  newTBQueueIO,
   newTVarIO,
-  readTBQueue,
   readTVarIO,
-  writeTBQueue,
  )
 import Control.Monad.Class.MonadSay (MonadSay, say)
 import Control.Tracer (
@@ -77,12 +73,9 @@ instance ToJSON a => ToJSON (Envelope a) where
 instance Arbitrary a => Arbitrary (Envelope a) where
   arbitrary = genericArbitrary
 
-defaultQueueSize :: Natural
-defaultQueueSize = 500
-
--- | Start logging thread and acquire a 'Tracer'. This tracer will dump all
--- messsages on @stdout@, one message per line, formatted as JSON. This tracer
--- is wrapping 'msg' into an 'Envelope' with metadata.
+-- | This tracer will dump all messages on @stdout@, one message per line,
+--  formatted as JSON. This tracer is wrapping 'msg' into an 'Envelope'
+--  with metadata.
 withTracer ::
   forall m msg a.
   (MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
@@ -92,9 +85,8 @@ withTracer ::
 withTracer Quiet = ($ nullTracer)
 withTracer (Verbose namespace) = withTracerOutputTo stdout namespace
 
--- | Start logging thread acquiring a 'Tracer', outputting JSON formatted
--- messages to some 'Handle'. This tracer is wrapping 'msg' into an 'Envelope'
--- with metadata.
+-- | Outputting JSON formatted messages to some 'Handle'. This tracer is
+-- wrapping 'msg' into an 'Envelope' with metadata.
 withTracerOutputTo ::
   forall m msg a.
   (MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
@@ -103,23 +95,13 @@ withTracerOutputTo ::
   (Tracer m msg -> IO a) ->
   IO a
 withTracerOutputTo hdl namespace action = do
-  msgQueue <- newTBQueueIO @_ @(Envelope msg) defaultQueueSize
-  withAsync (writeLogs msgQueue) $ \_ ->
-    action (tracer msgQueue) `finally` flushLogs msgQueue
+  action tracer `finally` flushLogs
  where
-  tracer queue =
+  tracer =
     Tracer $
-      mkEnvelope namespace >=> liftIO . atomically . writeTBQueue queue
-
-  writeLogs queue =
-    forever $ do
-      atomically (readTBQueue queue) >>= write . Aeson.encode
-      hFlush hdl
+      mkEnvelope namespace >=> liftIO . write . Aeson.encode
 
-  flushLogs queue = liftIO $ do
-    entries <- atomically $ flushTBQueue queue
-    forM_ entries (write . Aeson.encode)
-    hFlush hdl
+  flushLogs = liftIO $ hFlush hdl
 
   write bs = LBS.hPut hdl (bs <> "\n")