Add a simplified thread safe tracer for ToText instances

lib/iohk-monitoring-extra/iohk-monitoring-extra.cabal

@@ -11,8 +11,8 @@ build-type:    Simple
 library
   default-language:   Haskell2010
   default-extensions:
-    NoImplicitPrelude
     DerivingStrategies
+    NoImplicitPrelude
     OverloadedStrings
 
   ghc-options:
@@ -25,7 +25,10 @@ library
     -freverse-errors
 
   hs-source-dirs:     src
-  exposed-modules:    Cardano.BM.Extra
+  exposed-modules:
+    Cardano.BM.Extra
+    Cardano.BM.ToTextTracer
+
   build-depends:
     , aeson
     , base
@@ -34,9 +37,10 @@ library
     , deepseq
     , exceptions
     , fmt
-    , iohk-monitoring      ^>=0.1.11.3
+    , iohk-monitoring
+    , stm
     , text
-    , text-class           ^>=2024.3.27
+    , text-class
     , time
     , tracer-transformers
     , transformers

lib/iohk-monitoring-extra/src/Cardano/BM/ToTextTracer.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Cardano.BM.ToTextTracer
+    ( ToTextTracer (..)
+    , newToTextTracer
+    )
+where
+
+import Prelude
+
+import Cardano.BM.Data.Tracer
+    ( HasSeverityAnnotation (..)
+    , Tracer (Tracer)
+    )
+import Cardano.BM.Tracing
+    ( Severity
+    )
+import Control.Monad
+    ( forever
+    , unless
+    , (>=>)
+    )
+import Control.Monad.STM
+    ( retry
+    )
+import Control.Monad.Trans.Cont
+    ( ContT (..)
+    )
+import Data.Text.Class
+    ( ToText (..)
+    )
+import Data.Time
+    ( getCurrentTime
+    )
+import Data.Time.Format.ISO8601
+    ( iso8601Show
+    )
+import UnliftIO
+    ( BufferMode (NoBuffering)
+    , IOMode (WriteMode)
+    , MonadIO (liftIO)
+    , async
+    , atomically
+    , hSetBuffering
+    , isEmptyTChan
+    , link
+    , newTChanIO
+    , readTChan
+    , stdout
+    , withFile
+    , writeTChan
+    )
+
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+
+-- | A thread-safe tracer that logs messages to a file or stdout for anything
+-- that has ToText instance
+newtype ToTextTracer
+    = ToTextTracer
+        (forall a. (HasSeverityAnnotation a, ToText a) => Tracer IO a)
+
+-- | Create a new `ToTextTracer`
+newToTextTracer
+    :: Maybe FilePath
+    -- ^ If provided, logs will be written to this file, otherwise to stdout
+    -> Maybe Severity
+    -- ^ Minimum severity level to log
+    -> (ToTextTracer -> IO r)
+    -- ^ Action to run with the new tracer
+    -> IO r
+newToTextTracer clusterLogs minSeverity = runContT $ do
+    ch <- newTChanIO
+    h <- case clusterLogs of
+        Nothing -> pure stdout
+        Just logFile -> do
+            ContT $ withFile logFile WriteMode
+    liftIO $ hSetBuffering h NoBuffering
+    liftIO $ async >=> link $ forever $ do
+        (x, s, t) <- atomically $ readTChan ch
+        T.hPutStrLn h
+            $ T.pack (iso8601Show t)
+                <> " ["
+                <> T.pack (show s)
+                <> "] "
+                <> x
+    ContT $ \k -> do
+        r <- k $ ToTextTracer $ Tracer $ \msg -> do
+            let severity = getSeverityAnnotation msg
+            unless (Just severity < minSeverity) $ do
+                t <- getCurrentTime
+                atomically $ writeTChan ch (toText msg, severity, t)
+        -- wait until the channel is empty
+        atomically $ do
+            empty <- isEmptyTChan ch
+            unless empty retry
+        pure r