Propagate PartialTraceOptions to cardano-node

IntersectMBO · Feb 9, 2022 · d1f6451 · d1f6451
1 parent cbde4a4
commit d1f6451
Show file tree

Hide file tree

Showing 4 changed files with 175 additions and 184 deletions.
diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs
@@ -28,6 +28,7 @@ import           Prelude (String)
 import           Control.Monad (fail)
 import           Data.Aeson
 import qualified Data.Aeson.Types as Aeson
+import qualified Data.Text as Text
 import           Data.Time.Clock (DiffTime)
 import           Data.Yaml (decodeFileThrow)
 import           Generic.Data (gmappend)
@@ -166,7 +167,7 @@ data PartialNodeConfiguration
          -- Logging parameters:
        , pncLoggingSwitch  :: !(Last Bool)
        , pncLogMetrics     :: !(Last Bool)
-       , pncTraceConfig    :: !(Last TraceOptions)
+       , pncTraceConfig    :: !(Last PartialTraceOptions)
 
          -- Configuration for testing purposes
        , pncMaybeMempoolCapacityOverride :: !(Last MempoolCapacityBytesOverride)
@@ -218,13 +219,13 @@ instance FromJSON PartialNodeConfiguration where
       pncLoggingSwitch'  <-                 v .:? "TurnOnLogging" .!= True
       pncLogMetrics      <- Last        <$> v .:? "TurnOnLogMetrics"
       useTraceDispatcher <-                 v .:? "UseTraceDispatcher" .!= False
-      pncTraceConfig     <- Last . Just <$> if pncLoggingSwitch'
-                                            then
-                                                 traceConfigParser v
-                                                 (if useTraceDispatcher
-                                                  then TraceDispatcher
-                                                  else TracingOnLegacy)
-                                            else pure TracingOff
+      pncTraceConfig     <-  if pncLoggingSwitch'
+                             then do
+                               partialTraceSelection <- parseJSON $ Object v
+                               if useTraceDispatcher
+                               then Last . Just <$> return (PartialTraceDispatcher partialTraceSelection)
+                               else Last . Just <$> return (PartialTracingOnLegacy partialTraceSelection)
+                             else Last . Just <$> return PartialTracingOff
 
       -- Protocol parameters
       protocol <-  v .:? "Protocol" .!= ByronProtocol
@@ -442,9 +443,6 @@ defaultPartialNodeConfiguration =
 lastOption :: Parser a -> Parser (Last a)
 lastOption = fmap Last . optional
 
-lastToEither :: String -> Last a -> Either String a
-lastToEither errMsg (Last x) = maybe (Left errMsg) Right x
-
 makeNodeConfiguration :: PartialNodeConfiguration -> Either String NodeConfiguration
 makeNodeConfiguration pnc = do
   configFile <- lastToEither "Missing YAML config file" $ pncConfigFile pnc
@@ -455,7 +453,7 @@ makeNodeConfiguration pnc = do
   protocolConfig <- lastToEither "Missing ProtocolConfig" $ pncProtocolConfig pnc
   loggingSwitch <- lastToEither "Missing LoggingSwitch" $ pncLoggingSwitch pnc
   logMetrics <- lastToEither "Missing LogMetrics" $ pncLogMetrics pnc
-  traceConfig <- lastToEither "Missing TraceConfig" $ pncTraceConfig pnc
+  traceConfig <- first Text.unpack $ partialTraceSelectionToEither $ pncTraceConfig pnc
   diffusionMode <- lastToEither "Missing DiffusionMode" $ pncDiffusionMode pnc
   snapshotInterval <- lastToEither "Missing SnapshotInterval" $ pncSnapshotInterval pnc
   shutdownConfig <- lastToEither "Missing ShutdownConfig" $ pncShutdownConfig pnc

diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs
@@ -1,13 +1,13 @@
-{-# LANGUAGE BangPatterns        #-}
-{-# LANGUAGE CPP                 #-}
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE PackageImports      #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections       #-}
-{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
 
 #if !defined(mingw32_HOST_OS)
 #define UNIX
@@ -18,9 +18,9 @@ module Cardano.Node.Run
   , checkVRFFilePermissions
   ) where
 
-import           Cardano.Prelude hiding (ByteString, STM, atomically, take, trace)
-import           Prelude (String, error, id)
+import           Cardano.Prelude hiding (ByteString, STM, atomically, putStrLn, show, take, trace)
 import           Data.IP (toSockAddr)
+import           Prelude (String, error, id, putStrLn, show)
 
 import qualified Control.Concurrent.Async as Async
 import           Control.Monad.Class.MonadSTM.Strict
@@ -34,8 +34,7 @@ import           Data.Time.Clock (getCurrentTime)
 import           Data.Version (showVersion)
 import           Network.HostName (getHostName)
 import           Network.Socket (Socket)
-import           System.Directory (canonicalizePath, createDirectoryIfMissing,
-                     makeAbsolute)
+import           System.Directory (canonicalizePath, createDirectoryIfMissing, makeAbsolute)
 import           System.Environment (lookupEnv)
 
 #ifdef UNIX
@@ -55,19 +54,18 @@ import qualified Cardano.Crypto.Libsodium as Crypto
 
 import           Cardano.Node.Configuration.Logging (LoggingLayer (..), createLoggingLayer,
                    shutdownLoggingLayer)
+import           Cardano.Node.Configuration.NodeAddress
 import           Cardano.Node.Configuration.POM (NodeConfiguration (..),
                    PartialNodeConfiguration (..), SomeNetworkP2PMode (..),
                    defaultPartialNodeConfiguration, makeNodeConfiguration, parseNodeConfigurationFP)
-import           Cardano.Node.Configuration.NodeAddress
 import           Cardano.Node.Startup
-import           Cardano.Node.Types
 import           Cardano.Node.Tracing.API
 import           Cardano.Node.Tracing.Tracers.Startup (getStartupInfo)
+import           Cardano.Node.Types
 import           Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..))
 
 import qualified Ouroboros.Consensus.Config as Consensus
-import           Ouroboros.Consensus.Config.SupportsNode
-                     (ConfigSupportsNode (..))
+import           Ouroboros.Consensus.Config.SupportsNode (ConfigSupportsNode (..))
 import           Ouroboros.Consensus.Node (NetworkP2PMode (..), RunNode, RunNodeArgs (..),
                    StdRunNodeArgs (..))
 import qualified Ouroboros.Consensus.Node as Node (getChainDB, run)
@@ -96,8 +94,8 @@ import qualified Cardano.Node.Configuration.TopologyP2P as TopologyP2P
 import           Cardano.Node.Handlers.Shutdown
 import           Cardano.Node.Protocol (mkConsensusProtocol)
 import           Cardano.Node.Protocol.Types
-import           Cardano.Node.TraceConstraints (TraceConstraints)
 import           Cardano.Node.Queries
+import           Cardano.Node.TraceConstraints (TraceConstraints)
 import           Cardano.Tracing.Peer
 import           Cardano.Tracing.Tracers
 
@@ -116,7 +114,7 @@ runNode cmdPc = do
             Left err -> panic $ "Error in creating the NodeConfiguration: " <> Text.pack err
             Right nc' -> return nc'
 
-    putStrLn $ "Node configuration: " <> show @_ @Text nc
+    putStrLn $ "Node configuration: " <> show nc
 
     case shelleyVRFFile $ ncProtocolFiles nc of
       Just vrfFp -> do vrf <- runExceptT $ checkVRFFilePermissions vrfFp
@@ -181,7 +179,7 @@ handleNodeWithTracers  cmdPc nc p networkMagic runP = do
               p
 
             loggingLayer <- case eLoggingLayer of
-              Left err  -> putTextLn (show err) >> exitFailure
+              Left err  -> putTextLn (Text.pack $ show err) >> exitFailure
               Right res -> return res
             !trace <- setupTrace loggingLayer
             let tracer = contramap pack $ toLogObject trace