Merge pull request #690 from input-output-hk/async_issues_with_tracer

Async issues with tracer

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")