Cardano Tracer library

cardano-tracer/CHANGELOG.md

@@ -1,5 +1,9 @@
 # ChangeLog
 
+## NEXT
+* Cardano-tracer library functionality, allows shutting down and sending signals to running
+  instances through channels.
+
 ## 0.3.6 (November 2025)
 * Implement Prometheus HTTP service discovery (SD) under the URL `/targets`
 * Add optional config field `"prometheusLabels": { "<labelname>": "<labelvalue>", ... }` for custom labels to be attached with Prometheus SD

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"
+       ]

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

cardano-tracer/cardano-tracer.cabal

@@ -203,6 +203,7 @@ library
                       , trace-dispatcher ^>= 2.11.0
                       , trace-forward ^>= 2.4.0
                       , trace-resources ^>= 0.2.4
+                      , unagi-chan
                       , wai ^>= 3.2
                       , warp ^>= 3.4
                       , yaml
@@ -297,6 +298,7 @@ library demo-acceptor-lib
   exposed-modules:      Cardano.Tracer.Test.Acceptor
 
   build-depends:        bytestring
+                      , QuickCheck
                       , cardano-tracer
                       , containers
                       , extra
@@ -309,9 +311,9 @@ library demo-acceptor-lib
                       , text
                       , trace-dispatcher
                       , trace-forward
+                      , unagi-chan
                       , vector
                       , vector-algorithms
-                      , QuickCheck
 
 executable demo-acceptor
   import:               project-config
@@ -455,12 +457,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

cardano-tracer/src/Cardano/Tracer/Acceptors/Run.hs

@@ -6,13 +6,14 @@ module Cardano.Tracer.Acceptors.Run
   ) where
 
 import           Cardano.Logging.Types (TraceObject)
-import           Cardano.Logging.Utils (runInLoop)
+import           Cardano.Logging.Utils (runInLoop, RunInLoopTermination(..))
 import           Cardano.Tracer.Acceptors.Client
 import           Cardano.Tracer.Acceptors.Server
 import           Cardano.Tracer.Configuration
 import           Cardano.Tracer.Environment
 import           Cardano.Tracer.MetaTrace
 
+import           Control.Concurrent.Chan.Unagi (dupChan)
 import           Control.Concurrent.Async (forConcurrently_)
 import           Control.Exception (SomeException (..))
 import           "contra-tracer" Control.Tracer (Tracer, contramap, nullTracer, stdoutTracer)
@@ -33,20 +34,24 @@ 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 (show howToConnect))
-        (handleOnInterruption howToConnect) initialPauseInSec 10
+      action :: IO ()
+      action = do
+        dieOnShutdown =<< dupChan inChan
+        runAcceptorsServer tracerEnv tracerEnvRTView howToConnect $ acceptorsConfigs (show howToConnect)
+      in runInLoop action TerminateNever (handleOnInterruption howToConnect) initialPauseInSec 10
     ConnectTo localSocks ->
       -- Run N clients that initiate connections to the nodes.
-      forConcurrently_ (NE.nub localSocks) \howToConnect ->
-        runInLoop
-          (runAcceptorsClient tracerEnv tracerEnvRTView howToConnect $ acceptorsConfigs (show howToConnect))
-          (handleOnInterruption howToConnect) initialPauseInSec 30
+      forConcurrently_ (NE.nub localSocks) \howToConnect -> let
+        action :: IO ()
+        action = do
+          dieOnShutdown =<< dupChan inChan
+          runAcceptorsClient tracerEnv tracerEnvRTView howToConnect $ acceptorsConfigs (show howToConnect)
+        in runInLoop action TerminateNever (handleOnInterruption howToConnect) initialPauseInSec 30
  where
   handleOnInterruption howToConnect (SomeException e)
     | verbosity == Just Minimum = pure ()