cardano-tracer: Add functionality to run cardano-tracer as a library, with shut-down functionality and internal/user messaging.

Icelandjack · Icelandjack · commit 23d0e031ff7b · 2025-11-11T10:54:23.000Z
Signed-off-by: Baldur Blöndal &lt;baldur.blondal@iohk.io&gt;
diff --git a/cardano-tracer/CHANGELOG.md b/cardano-tracer/CHANGELOG.md
@@ -1,5 +1,10 @@
 # ChangeLog
 
+## NEXT
+
+* Cardano-tracer library functionality, allows shutting down and sending signals to running
+  instances through channels.
+
 ## 0.3.4 (July, 2025)
 * Forwarding protocol supports connections over TCP socket, in addition to Unix domain sockets.
 
diff --git a/cardano-tracer/app/cardano-tracer.hs b/cardano-tracer/app/cardano-tracer.hs
@@ -1,14 +1,23 @@
-import           Cardano.Tracer.CLI (TracerParams, parseTracerParams)
+{-# LANGUAGE OverloadedRecordDot #-}
+
+import           Cardano.Tracer.CLI (TracerParams(..), parseTracerParams)
+import           Cardano.Tracer.MetaTrace
 import           Cardano.Tracer.Run (runCardanoTracer)
 
+import           Data.Functor (void)
 import           Data.Version (showVersion)
 import           Options.Applicative
 
 import           Paths_cardano_tracer (version)
 
 main :: IO ()
-main =
-  runCardanoTracer =<< customExecParser (prefs showHelpOnEmpty) tracerInfo
+main = void do
+  tracerParams :: TracerParams
+     <- customExecParser (prefs showHelpOnEmpty) tracerInfo
+  trace :: Trace IO TracerTrace <-
+    -- Default `Nothing' severity filter to Info.
+    mkTracerTracer $ SeverityF (tracerParams.logSeverity <|> Just Info)
+  runCardanoTracer trace tracerParams
 
 tracerInfo :: ParserInfo TracerParams
 tracerInfo = info
@@ -21,7 +30,9 @@ tracerInfo = info
 
 versionOption :: Parser (a -> a)
 versionOption = infoOption
-  (showVersion version)
-  (long "version" <>
-   short 'v' <>
-   help "Show version")
+  do showVersion version
+  do mconcat
+       [ long  "version"
+       , short 'v'
+       , help  "Show version"
+       ]
diff --git a/cardano-tracer/bench/cardano-tracer-bench.hs b/cardano-tracer/bench/cardano-tracer-bench.hs
@@ -19,6 +19,7 @@ import           Control.Concurrent.Extra (newLock)
 #if RTVIEW
 import           Control.Concurrent.STM.TVar (newTVarIO)
 #endif
+import           Control.Concurrent.Chan.Unagi (newChan)
 import           Control.DeepSeq
 import qualified Data.List.NonEmpty as NE
 import           Data.Time.Clock (UTCTime, getCurrentTime)
@@ -63,6 +64,8 @@ main = do
 
   tracer <- mkTracerTracer $ SeverityF $ Just Warning
 
+  (inChan, _outChan) <- newChan
+
   let tracerEnv :: TracerConfig -> HandleRegistry -> TracerEnv
       tracerEnv config handleRegistry = TracerEnv
         { teConfig                = config
@@ -74,6 +77,7 @@ main = do
         , teDPRequestors          = dpRequestors
         , teProtocolsBrake        = protocolsBrake
         , teTracer                = tracer
+        , teInChan                = inChan
         , teReforwardTraceObjects = \_-> pure ()
         , teRegistry              = handleRegistry
         , teStateDir              = Nothing
diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal
@@ -200,6 +200,7 @@ library
                       , trace-dispatcher ^>= 2.10.0
                       , trace-forward ^>= 2.3.0
                       , trace-resources ^>= 0.2.4
+                      , unagi-chan
                       , wai ^>= 3.2
                       , warp ^>= 3.4
                       , yaml
@@ -294,6 +295,7 @@ library demo-acceptor-lib
   exposed-modules:      Cardano.Tracer.Test.Acceptor
 
   build-depends:        bytestring
+                      , QuickCheck
                       , cardano-tracer
                       , containers
                       , extra
@@ -306,9 +308,9 @@ library demo-acceptor-lib
                       , text
                       , trace-dispatcher
                       , trace-forward
+                      , unagi-chan
                       , vector
                       , vector-algorithms
-                      , QuickCheck
 
 executable demo-acceptor
   import:               project-config
@@ -452,12 +454,13 @@ benchmark cardano-tracer-bench
     build-depends:      stm <2.5.2 || >=2.5.3
   build-depends:        cardano-tracer
                       , criterion
-                      , directory
                       , deepseq
+                      , directory
                       , extra
                       , filepath
                       , time
                       , trace-dispatcher
+                      , unagi-chan
 
   ghc-options:          -threaded
                         -rtsopts
diff --git a/cardano-tracer/src/Cardano/Tracer/Acceptors/Run.hs b/cardano-tracer/src/Cardano/Tracer/Acceptors/Run.hs
@@ -14,6 +14,7 @@ import           Cardano.Tracer.Utils
 import           Cardano.Logging.Types (TraceObject)
 import qualified Cardano.Logging.Types as Net
 
+import           Control.Concurrent.Chan.Unagi (dupChan)
 import           Control.Concurrent.Async (forConcurrently_)
 import           "contra-tracer" Control.Tracer (Tracer, contramap, nullTracer, stdoutTracer)
 import qualified Data.List.NonEmpty as NE
@@ -33,20 +34,28 @@ import qualified Trace.Forward.Protocol.TraceObject.Type as TOF
 --   1. Server mode, when the tracer accepts connections from any number of nodes.
 --   2. Client mode, when the tracer initiates connections to specified number of nodes.
 runAcceptors :: TracerEnv -> TracerEnvRTView -> IO ()
-runAcceptors tracerEnv@TracerEnv{teTracer} tracerEnvRTView = do
+runAcceptors tracerEnv@TracerEnv{teTracer, teInChan = inChan} tracerEnvRTView = do
   traceWith teTracer $ TracerStartedAcceptors network
   case network of
-    AcceptAt howToConnect ->
+    AcceptAt howToConnect -> let
       -- Run one server that accepts connections from the nodes.
-      runInLoop
-        (runAcceptorsServer tracerEnv tracerEnvRTView howToConnect $ acceptorsConfigs (Net.howToConnectString howToConnect))
-        verbosity howToConnect initialPauseInSec
-    ConnectTo localSocks ->
+
+      action :: IO ()
+      action = do
+        dieOnShutdown =<< dupChan inChan
+        runAcceptorsServer tracerEnv tracerEnvRTView howToConnect $ acceptorsConfigs (Net.howToConnectString howToConnect)
+
+      in runInLoop action verbosity howToConnect initialPauseInSec
+    ConnectTo localSocks -> do
       -- Run N clients that initiate connections to the nodes.
-      forConcurrently_ (NE.nub localSocks) \howToConnect ->
-        runInLoop
-          (runAcceptorsClient tracerEnv tracerEnvRTView howToConnect $ acceptorsConfigs (Net.howToConnectString howToConnect))
-          verbosity howToConnect initialPauseInSec
+      forConcurrently_ (NE.nub localSocks) \howToConnect -> let
+
+        action :: IO ()
+        action = runAcceptorsClient tracerEnv tracerEnvRTView howToConnect $ acceptorsConfigs (Net.howToConnectString howToConnect)
+
+        in do
+          dieOnShutdown =<< dupChan inChan
+          runInLoop action verbosity howToConnect initialPauseInSec
  where
   TracerConfig{network, ekgRequestFreq, verbosity, ekgRequestFull} = teConfig tracerEnv
   ekgUseFullRequests = fromMaybe False ekgRequestFull
diff --git a/cardano-tracer/src/Cardano/Tracer/Environment.hs b/cardano-tracer/src/Cardano/Tracer/Environment.hs
@@ -1,11 +1,24 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Cardano.Tracer.Environment
   ( TracerEnv (..)
   , TracerEnvRTView (..)
+  , RawMessage (..)
+  , InternalMessage (..)
+  , Tag (..)
+  , CardanoTracerMessage
+  , onRawMessage
+  , onInternal
+  , onUser
+  , blockUntilShutdown
+  , dieOnShutdown
+  , forever'tilShutdown
   ) where
 
 import           Cardano.Logging.Types
+import           Cardano.Logging.Resources.Types (ResourceStats)
 import           Cardano.Tracer.Configuration
 #if RTVIEW
 import           Cardano.Tracer.Handlers.Notifications.Types
@@ -16,10 +29,13 @@ import           Cardano.Tracer.Handlers.State.TraceObjects
 import           Cardano.Tracer.MetaTrace
 import           Cardano.Tracer.Types
 
+import           Control.Concurrent (myThreadId)
+import           Control.Exception (AsyncException(ThreadKilled), throwTo)
+import           Control.Concurrent.Chan.Unagi (InChan, OutChan, readChan, tryReadChan, tryRead)
 import           Control.Concurrent.Extra (Lock)
 import           Data.Text (Text)
 import           Data.Text.Lazy.Builder (Builder)
-
+import           Data.Kind (Type)
 
 -- | Environment for all functions.
 data TracerEnv = TracerEnv
@@ -36,6 +52,7 @@ data TracerEnv = TracerEnv
   , teRegistry              :: !HandleRegistry
   , teStateDir              :: !(Maybe FilePath)
   , teMetricsHelp           :: ![(Text, Builder)]
+  , teInChan                :: !(InChan (CardanoTracerMessage ()))
   }
 
 #if RTVIEW
@@ -51,3 +68,58 @@ data TracerEnvRTView = TracerEnvRTView
 #else
 data TracerEnvRTView = TracerEnvRTView
 #endif
+
+type CardanoTracerMessage userMsg = RawMessage InternalMessage userMsg
+
+type RawMessage :: Type -> Type -> Type
+data RawMessage internal user
+  = Shutdown
+  | InternalMessage internal
+  | UserMessage     user
+
+blockUntilShutdown :: OutChan (RawMessage internal user) -> IO ()
+blockUntilShutdown outChan = go where
+  go :: IO ()
+  go = readChan outChan >>= \case
+         Shutdown -> pure ()
+         _        -> go
+
+onRawMessage :: (internal -> IO ()) -> (user -> IO ()) -> OutChan (RawMessage internal user) -> IO ()
+onRawMessage internalAction userAction outChan = do
+  (element, _out) <- tryReadChan outChan
+  tryRead element >>= \case
+    Just (Shutdown)                 -> myThreadId >>= (`throwTo` ThreadKilled)
+    Just (InternalMessage internal) -> internalAction internal
+    Just (UserMessage user)         -> userAction user
+    Nothing                         -> pure ()
+
+-- foo :: IO () -> 
+-- foo action outChan = do
+--   (element, _out) <- tryReadChan outChan
+--   tryRead element >>= \case
+--     Just _ -> action
+--     Nothing -> 
+
+
+onInternal :: (internal -> IO ()) -> OutChan (RawMessage internal user) -> IO ()
+onInternal = (`onRawMessage` mempty)
+
+onUser :: (user -> IO ()) -> OutChan (RawMessage internal user) -> IO ()
+onUser = (mempty `onRawMessage`)
+
+data InternalMessage where
+  ResourceMessage :: Tag ex -> (ex -> IO ()) -> InternalMessage
+
+data Tag a where
+  TagResource :: Tag (ResourceStats, Trace IO TracerTrace)
+
+dieOnShutdown :: OutChan (RawMessage internal user) -> IO ()
+dieOnShutdown = onRawMessage mempty mempty
+
+forever'tilShutdown :: OutChan (RawMessage internal user) -> IO () -> IO ()
+forever'tilShutdown outChan action = do
+  (element, _out) <- tryReadChan outChan
+  tryRead element >>= \case
+    Just Shutdown -> pure ()
+    Just _  -> forever'tilShutdown outChan action
+    Nothing -> action *> forever'tilShutdown outChan action
diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/Logs/Rotator.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/Logs/Rotator.hs
@@ -6,16 +6,17 @@ module Cardano.Tracer.Handlers.Logs.Rotator
   ) where
 
 import           Cardano.Tracer.Configuration
-import           Cardano.Tracer.Environment
+import           Cardano.Tracer.Environment (TracerEnv (..), forever'tilShutdown)
 import           Cardano.Tracer.Handlers.Logs.Utils (createOrUpdateEmptyLog, getTimeStampFromLog,
                    isItLog)
 import           Cardano.Tracer.MetaTrace
 import           Cardano.Tracer.Types (HandleRegistry, HandleRegistryKey, NodeName)
 import           Cardano.Tracer.Utils (showProblemIfAny, readRegistry)
 
 import           Control.Concurrent.Async (forConcurrently_)
+import           Control.Concurrent.Chan.Unagi (dupChan)
 import           Control.Concurrent.Extra (Lock)
-import           Control.Monad (forM_, forever, unless, when)
+import           Control.Monad (forM_, unless, when)
 import           Control.Monad.Extra (whenJust, whenM)
 import           Data.Foldable (for_)
 import           Data.List (nub, sort)
@@ -33,38 +34,40 @@ import           System.Time.Extra (sleep)
 
 -- | Runs rotation mechanism for the log files.
 runLogsRotator :: TracerEnv -> IO ()
-runLogsRotator TracerEnv
-  { teConfig = TracerConfig{rotation, verbosity, logging}
-  , teCurrentLogLock
-  , teTracer
-  , teRegistry
-  } = do
-  whenJust rotation \rotParams -> do
+runLogsRotator tracerEnv@TracerEnv { teConfig = TracerConfig{rotation}, teTracer } = do
+  whenJust rotation \rot -> do
     traceWith teTracer TracerStartedLogRotator
-    launchRotator loggingParamsForFiles rotParams verbosity teRegistry teCurrentLogLock
- where
+    launchRotator tracerEnv rot
+
+launchRotator
+  :: TracerEnv
+  -> RotationParams
+  -> IO ()
+launchRotator tracerEnv rot@RotationParams{rpFrequencySecs} = do
+  whenNonEmpty loggingParamsForFiles do
+    outChan <- dupChan teInChan
+    forever'tilShutdown outChan do
+      showProblemIfAny verbosity do
+        forM_ loggingParamsForFiles \loggingParam -> do
+          checkRootDir teCurrentLogLock teRegistry rot loggingParam
+      sleep (fromIntegral rpFrequencySecs)
+  where
+  whenNonEmpty :: Applicative f => [a] -> f () -> f ()
+  whenNonEmpty = unless . null
+
+  TracerEnv
+    { teConfig = TracerConfig{verbosity, logging}
+    , teCurrentLogLock
+    , teRegistry
+    , teInChan
+    } = tracerEnv
+
   loggingParamsForFiles :: [LoggingParams]
   loggingParamsForFiles = nub (NE.filter filesOnly logging)
 
   filesOnly :: LoggingParams -> Bool
   filesOnly LoggingParams{logMode} = logMode == FileMode
 
-launchRotator
-  :: [LoggingParams]
-  -> RotationParams
-  -> Maybe Verbosity
-  -> HandleRegistry
-  -> Lock
-  -> IO ()
-launchRotator [] _ _ _ _ = return ()
-launchRotator loggingParamsForFiles
-              rotParams@RotationParams{rpFrequencySecs} verb registry currentLogLock =
-  forever do
-    showProblemIfAny verb do
-      forM_ loggingParamsForFiles \loggingParam -> do
-        checkRootDir currentLogLock registry rotParams loggingParam
-    sleep $ fromIntegral rpFrequencySecs
-
 -- | All the logs with 'TraceObject's received from particular node
 --   will be stored in a separate subdirectory in the root directory.
 --
diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Monitoring.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Monitoring.hs
@@ -14,6 +14,8 @@ import           Cardano.Tracer.Types
 
 import           Prelude hiding (head)
 
+import           Control.Concurrent.Async (race_)
+import           Control.Concurrent.Chan.Unagi (OutChan, dupChan)
 import           Data.ByteString as ByteString (ByteString, isInfixOf)
 import           Data.ByteString.Builder (stringUtf8)
 import qualified Data.Text as T
@@ -39,19 +41,26 @@ runMonitoringServer
   -> Endpoint -- ^ (web page with list of connected nodes, EKG web page).
   -> IO RouteDictionary
   -> IO ()
-runMonitoringServer TracerEnv{teTracer} endpoint computeRoutes_autoUpdate = do
+runMonitoringServer TracerEnv{teTracer, teInChan = inChan} endpoint computeRoutes_autoUpdate = do
   -- Pause to prevent collision between "Listening"-notifications from servers.
   sleep 0.2
   traceWith teTracer TracerStartedMonitoring
     { ttMonitoringEndpoint = endpoint
     , ttMonitoringType     = "list"
     }
   dummyStore <- EKG.newStore
-  runSettings (setEndpoint endpoint defaultSettings) do
-    renderEkg dummyStore computeRoutes_autoUpdate
+  outChan    <- dupChan inChan
+
+  let run :: IO ()
+      run = runSettings (setEndpoint endpoint defaultSettings) $
+              renderEkg dummyStore outChan computeRoutes_autoUpdate
+
+  race_ run (blockUntilShutdown outChan)
+
+renderEkg :: EKG.Store -> OutChan (CardanoTracerMessage ()) -> IO RouteDictionary -> Application
+renderEkg dummyStore outChan computeRoutes_autoUpdate request send = do
+  dieOnShutdown outChan
 
-renderEkg :: EKG.Store -> IO RouteDictionary -> Application
-renderEkg dummyStore computeRoutes_autoUpdate request send = do
   routeDictionary :: RouteDictionary <-
     computeRoutes_autoUpdate
 
diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Prometheus.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/Metrics/Prometheus.hs
diff --git a/cardano-tracer/src/Cardano/Tracer/Run.hs b/cardano-tracer/src/Cardano/Tracer/Run.hs
diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs b/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs
diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Restart/Tests.hs b/cardano-tracer/test/Cardano/Tracer/Test/Restart/Tests.hs
