diff --git a/.gitignore b/.gitignore index 2bd1e769362..4b9c3d1b2e9 100644 --- a/.gitignore +++ b/.gitignore @@ -63,3 +63,5 @@ logs /example /.hlint.yaml /testnet + +.vscode/ diff --git a/Makefile b/Makefile index 46946344ddb..02752599aba 100644 --- a/Makefile +++ b/Makefile @@ -68,7 +68,7 @@ ps: ## Plain-text list of profiles ## ## Profile-based cluster shells (autogenerated targets) ## -PROFILES_BASE := default plutus oldtracing +PROFILES_BASE := default plutus oldtracing idle tracer-only PROFILES_STARTSTOP := startstop startstop-p2p startstop-plutus startstop-notracer startstop-oldtracing PROFILES_CI_TEST := ci-test ci-test-p2p ci-test-plutus ci-test-notracer ci-test-dense10 PROFILES_CI_BENCH := ci-bench ci-bench-p2p ci-bench-plutus ci-bench-notracer diff --git a/bench/tx-generator/tx-generator.cabal b/bench/tx-generator/tx-generator.cabal index ab5e2724acf..5344230e7ea 100644 --- a/bench/tx-generator/tx-generator.cabal +++ b/bench/tx-generator/tx-generator.cabal @@ -12,6 +12,10 @@ cabal-version: >= 1.10 extra-source-files: README.md data-files: data/protocol-parameters.json +common project-config + if os(windows) + buildable: False + library hs-source-dirs: src ghc-options: -Wall @@ -26,14 +30,14 @@ library exposed-modules: Cardano.Benchmarking.Command - Cardano.Benchmarking.Compiler + Cardano.Benchmarking.Compiler Cardano.Benchmarking.GeneratorTx Cardano.Benchmarking.GeneratorTx.Genesis Cardano.Benchmarking.GeneratorTx.NodeToNode Cardano.Benchmarking.GeneratorTx.SizedMetadata Cardano.Benchmarking.GeneratorTx.Submission Cardano.Benchmarking.GeneratorTx.SubmissionClient - Cardano.Benchmarking.LogTypes + Cardano.Benchmarking.LogTypes Cardano.Benchmarking.NixOptions Cardano.Benchmarking.OuroborosImports Cardano.Benchmarking.Script @@ -41,8 +45,8 @@ library Cardano.Benchmarking.Script.Aeson Cardano.Benchmarking.Script.Core Cardano.Benchmarking.Script.Env - Cardano.Benchmarking.Script.NodeConfig - Cardano.Benchmarking.Script.Selftest + Cardano.Benchmarking.Script.NodeConfig + Cardano.Benchmarking.Script.Selftest Cardano.Benchmarking.Script.Setters Cardano.Benchmarking.Script.Store Cardano.Benchmarking.Script.Types @@ -52,7 +56,7 @@ library Cardano.Benchmarking.Version Cardano.Benchmarking.Wallet Cardano.Benchmarking.PlutusExample - + Cardano.TxGenerator.Fund Cardano.TxGenerator.FundQueue Cardano.TxGenerator.PureExample diff --git a/cardano-node-chairman/cardano-node-chairman.cabal b/cardano-node-chairman/cardano-node-chairman.cabal index 08541fe889c..ae8c413c829 100644 --- a/cardano-node-chairman/cardano-node-chairman.cabal +++ b/cardano-node-chairman/cardano-node-chairman.cabal @@ -12,6 +12,10 @@ build-type: Simple common base { build-depends: base >= 4.14 && < 4.15 } + if os(windows) + buildable: False + + common project-config default-language: Haskell2010 default-extensions: NoImplicitPrelude diff --git a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs index 95e15cc2794..eae0886693a 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs @@ -35,7 +35,8 @@ import Cardano.Node.Tracing.Tracers.BlockReplayProgress import Cardano.Node.Tracing.Tracers.ChainDB import Cardano.Node.Tracing.Tracers.Consensus import Cardano.Node.Tracing.Tracers.Diffusion -import Cardano.Node.Tracing.Tracers.ForgingThreadStats (docForgeStats, forgeThreadStats) +import Cardano.Node.Tracing.Tracers.ForgingThreadStats ( + docForgeStats, forgeThreadStats) import Cardano.Node.Tracing.Tracers.KESInfo import Cardano.Node.Tracing.Tracers.NodeToClient import Cardano.Node.Tracing.Tracers.NodeToNode @@ -49,7 +50,6 @@ import Cardano.Node.Handlers.Shutdown (ShutdownTrace) import Cardano.Node.Startup import Cardano.Node.TraceConstraints - import Ouroboros.Consensus.Block.Forging import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime) import Ouroboros.Consensus.BlockchainTime.WallClock.Util (TraceBlockchainTimeEvent (..)) @@ -424,22 +424,19 @@ docTracers configFileName outputFileName _ _ _ = do mkCardanoTracer' trBase trForward mbTrEKG ["Forge", "Stats"] - namesForForge - severityForge + namesForForge2 + severityForge2 allPublic forgeThreadStats configureTracers trConfig docForge [forgeTr, forgeThreadStatsTr] forgeTrDoc <- documentTracer trConfig forgeTr - (docForge :: Documented - (Either (Consensus.TraceForgeEvent blk) - TraceStartLeadershipCheckPlus)) + (docForge :: Documented (Either (Consensus.TraceForgeEvent blk) + TraceStartLeadershipCheckPlus)) forgeThreadStatsTrDoc <- documentTracer trConfig forgeThreadStatsTr - (docForgeStats :: Documented - (Either - (Consensus.TraceForgeEvent blk) - TraceStartLeadershipCheckPlus)) + (docForgeStats :: Documented (Either (Consensus.TraceForgeEvent blk) + TraceStartLeadershipCheckPlus)) blockchainTimeTr <- mkCardanoTracer trBase trForward mbTrEKG diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index aec51cc305c..1a8505537a1 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -23,7 +23,7 @@ import Cardano.Node.Tracing.Tracers.BlockReplayProgress import Cardano.Node.Tracing.Tracers.ChainDB import Cardano.Node.Tracing.Tracers.Consensus import Cardano.Node.Tracing.Tracers.Diffusion -import Cardano.Node.Tracing.Tracers.ForgingThreadStats (forgeThreadStats) +import Cardano.Node.Tracing.Tracers.ForgingThreadStats (docForgeStats, forgeThreadStats) import Cardano.Node.Tracing.Tracers.KESInfo import Cardano.Node.Tracing.Tracers.NodeToClient import Cardano.Node.Tracing.Tracers.NodeToNode @@ -352,11 +352,12 @@ mkConsensusTracers trBase trForward mbTrEKG _trDataPoint trConfig nodeKernel = d forgeThreadStatsTr <- mkCardanoTracer' trBase trForward mbTrEKG ["Forge", "Stats"] - namesForForge - severityForge + namesForForge2 + severityForge2 allPublic forgeThreadStats - configureTracers trConfig docForge [forgeTr, forgeThreadStatsTr] + configureTracers trConfig docForge [forgeTr] + configureTracers trConfig docForgeStats [forgeThreadStatsTr] blockchainTimeTr <- mkCardanoTracer trBase trForward mbTrEKG ["BlockchainTime"] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index 08d9c92139d..0d8bdde267b 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -60,6 +60,10 @@ module Cardano.Node.Tracing.Tracers.Consensus , namesForForge , docForge + , severityForge2 + , namesForForge2 + , docForge2 + , namesForBlockchainTime , severityBlockchainTime , docBlockchainTime @@ -90,6 +94,7 @@ import Cardano.Node.Tracing.Era.Shelley () import Cardano.Node.Tracing.Formatting () import Cardano.Node.Tracing.Render import Cardano.Node.Tracing.Tracers.StartLeadershipCheck +import Cardano.Node.Tracing.Tracers.ForgingThreadStats(ForgingStats) import Cardano.Prelude hiding (All, Show, show) import Cardano.Protocol.TPraos.OCert (KESPeriod (..)) @@ -1095,7 +1100,14 @@ namesForForge'' TraceForgedInvalidBlock {} = ["ForgedInvalidBlock"] namesForForge'' TraceAdoptedBlock {} = ["AdoptedBlock"] namesForForge'''' :: TraceStartLeadershipCheckPlus -> [Text] -namesForForge'''' TraceStartLeadershipCheckPlus{} = ["StartLeadershipCheckPlus"] +namesForForge'''' TraceStartLeadershipCheckPlus{} = ["StartLeadershipCheck"] + +namesForForge2 :: ForgingStats -> [Text] +namesForForge2 _ = ["StartLeadershipCheck"] + +severityForge2 :: ForgingStats -> SeverityS +severityForge2 _ = Info + instance ( tx ~ GenTx blk , ConvertRawHash blk @@ -1544,7 +1556,7 @@ docForge' = Documented [ "We adopted the block we produced, we also trace the transactions\ \ that were adopted." , DocMsg - ["StartLeadershipCheckPlus"] + ["StartLeadershipCheck"] [ ("Forge.AboutToLeadSlotLast", "") , ("Forge.UtxoSize", "") , ("Forge.DelegMapSize", "") @@ -1554,6 +1566,10 @@ docForge' = Documented [ ] +docForge2 :: Documented ForgingStats +docForge2 = addDocumentedNamespace [] docForge' + + instance ( tx ~ GenTx blk , ConvertRawHash blk , GetHeader blk diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs index 7e8158ac3d9..ba4f716eace 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/ForgingThreadStats.hs @@ -69,10 +69,8 @@ instance LogFormatting ForgeThreadStats where emptyForgeThreadStats :: ForgeThreadStats emptyForgeThreadStats = ForgeThreadStats 0 0 0 0 0 -docForgeStats :: Documented - (Either - (Consensus.TraceForgeEvent blk) - TraceStartLeadershipCheckPlus) +docForgeStats :: Documented (Either (Consensus.TraceForgeEvent blk) + TraceStartLeadershipCheckPlus) docForgeStats = Documented [ DocMsg [] @@ -85,7 +83,7 @@ docForgeStats = Documented [ ,("Forge.SlotsMissed", "How many slots were missed in this node?") ,("Forge.LastSlot", - "") + "") ] "nodeCannotForgeNum shows how many times this node could not forge.\ \\nnodeIsLeaderNum shows how many times this node was leader.\ @@ -126,18 +124,22 @@ instance LogFormatting ForgingStats where , IntM "Forge.NodeIsLeaderNum" (fromIntegral fsNodeIsLeaderNum) , IntM "Forge.BlocksForgedNum" (fromIntegral fsBlocksForgedNum) , IntM "Forge.SlotsMissed" (fromIntegral fsSlotsMissedNum) - ] + ] emptyForgingStats :: ForgingStats emptyForgingStats = ForgingStats mempty 0 0 0 0 -forgeThreadStats :: Trace IO (Folding (ForgeTracerType blk) ForgingStats) +forgeThreadStats :: Trace IO ForgingStats -> IO (Trace IO (ForgeTracerType blk)) -forgeThreadStats = foldMCondTraceM calculateThreadStats emptyForgingStats - (\case - Left Consensus.TraceStartLeadershipCheck{} -> True - Left _ -> False - Right _ -> True) +forgeThreadStats tr = + let tr' = contramap unfold tr + in foldMCondTraceM calculateThreadStats emptyForgingStats + (\case + Left Consensus.TraceStartLeadershipCheck{} -> True + Left _ -> False + Right _ -> True + ) + tr' calculateThreadStats :: MonadIO m => ForgingStats diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs index 75211865779..efec8eae7dd 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs @@ -33,7 +33,7 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Cardano.Node.Queries (LedgerQueries (..), NodeKernelData (..)) import Cardano.Slotting.Slot (fromWithOrigin) -import Cardano.Ledger.BaseTypes (StrictMaybe (..), fromSMaybe) +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) type ForgeTracerType blk = Either (TraceForgeEvent blk) @@ -64,16 +64,15 @@ forgeTracerTransform nodeKern (Trace tr) = pure $ Trace $ T.arrow $ T.emit $ <*> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk <*> nkQueryChain fragmentChainDensity nk) nodeKern - fromSMaybe - (T.traceWith tr (lc, Right (Left slc))) - (query <&> - \(utxoSize, delegMapSize, chainDensity) -> + case query of + SNothing -> T.traceWith tr (lc, Right (Left slc)) + SJust (utxoSize, delegMapSize, chainDensity) -> let msg = TraceStartLeadershipCheckPlus slotNo utxoSize delegMapSize (fromRational chainDensity) - in T.traceWith tr (lc, Right (Right msg))) + in T.traceWith tr (lc, Right (Right msg)) (lc, Right a) -> T.traceWith tr (lc, Right a) (lc, Left control) -> diff --git a/cardano-tracer/bench/cardano-tracer-bench.hs b/cardano-tracer/bench/cardano-tracer-bench.hs index 03f814681cf..049d4a50ee7 100644 --- a/cardano-tracer/bench/cardano-tracer-bench.hs +++ b/cardano-tracer/bench/cardano-tracer-bench.hs @@ -17,6 +17,7 @@ import Cardano.Tracer.Utils import Cardano.Tracer.Configuration import Cardano.Tracer.Environment import Cardano.Tracer.Handlers.Logs.TraceObjects +import Cardano.Tracer.MetaTrace import Cardano.Tracer.Types main :: IO () @@ -48,6 +49,8 @@ main = do rtViewPageOpened <- newTVarIO False + tr <- mkTracerTracer $ SeverityF $ Just Warning + let te1 = TracerEnv { teConfig = c1 @@ -65,6 +68,7 @@ main = do , teProtocolsBrake = protocolsBrake , teRTViewPageOpened = rtViewPageOpened , teRTViewStateDir = Nothing + , teTracer = tr } te2 = TracerEnv @@ -83,6 +87,7 @@ main = do , teProtocolsBrake = protocolsBrake , teRTViewPageOpened = rtViewPageOpened , teRTViewStateDir = Nothing + , teTracer = tr } removePathForcibly root diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal index 32d0256252f..45645a36254 100644 --- a/cardano-tracer/cardano-tracer.cabal +++ b/cardano-tracer/cardano-tracer.cabal @@ -111,6 +111,7 @@ library Cardano.Tracer.CLI Cardano.Tracer.Configuration Cardano.Tracer.Environment + Cardano.Tracer.MetaTrace Cardano.Tracer.Run Cardano.Tracer.Types Cardano.Tracer.Utils @@ -186,18 +187,27 @@ library demo-forwarder-lib hs-source-dirs: test + other-modules: Cardano.Tracer.Test.Utils + exposed-modules: Cardano.Tracer.Test.Forwarder + Cardano.Tracer.Test.TestSetup build-depends: aeson , async , bytestring - , cborg , cardano-tracer + , cborg , contra-tracer + , directory , ekg-core , ekg-forward + , extra + , filepath + , generic-data + , optparse-applicative-fork , ouroboros-network , ouroboros-network-framework + , tasty-quickcheck , time , trace-dispatcher , trace-forward @@ -214,12 +224,17 @@ executable demo-forwarder ghc-options: -threaded -rtsopts -with-rtsopts=-T + if os(windows) + buildable: False library demo-acceptor-lib import: base, project-config hs-source-dirs: test + other-modules: Cardano.Tracer.Test.TestSetup + Cardano.Tracer.Test.Utils + exposed-modules: Cardano.Tracer.Test.Acceptor build-depends: async-extras @@ -227,8 +242,13 @@ library demo-acceptor-lib , cardano-tracer , containers , extra + , filepath + , generic-data + , optparse-applicative-fork + , ouroboros-network , stm , text + , tasty-quickcheck , trace-forward executable demo-acceptor @@ -243,10 +263,13 @@ executable demo-acceptor ghc-options: -threaded -rtsopts -with-rtsopts=-T + if os(windows) + buildable: False test-suite cardano-tracer-test import: base, project-config type: exitcode-stdio-1.0 + default-extensions: OverloadedStrings hs-source-dirs: test @@ -256,8 +279,9 @@ test-suite cardano-tracer-test Cardano.Tracer.Test.DataPoint.Tests Cardano.Tracer.Test.Logs.Tests Cardano.Tracer.Test.Restart.Tests - Cardano.Tracer.Test.Queue.Tests + Cardano.Tracer.Test.TestSetup Cardano.Tracer.Test.Utils + Cardano.Tracer.Test.Queue.Tests build-depends: aeson , async @@ -271,8 +295,11 @@ test-suite cardano-tracer-test , ekg-forward , extra , filepath + , generic-data + , optparse-applicative-fork , ouroboros-network , ouroboros-network-framework + , QuickCheck , stm , tasty , tasty-quickcheck @@ -280,6 +307,62 @@ test-suite cardano-tracer-test , time , trace-dispatcher , trace-forward + , unix-compat + + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N + +test-suite cardano-tracer-test-ext + import: base, project-config + type: exitcode-stdio-1.0 + default-extensions: OverloadedStrings + + hs-source-dirs: test + + main-is: cardano-tracer-test-ext.hs + + other-modules: Cardano.Tracer.Test.Forwarder + Cardano.Tracer.Test.TestSetup + Cardano.Tracer.Test.Utils + Cardano.Tracer.Test.ForwardingStressTest.Script + Cardano.Tracer.Test.ForwardingStressTest.Config + Cardano.Tracer.Test.ForwardingStressTest.Messages + Cardano.Tracer.Test.ForwardingStressTest.Types + + build-tool-depends: cardano-tracer:cardano-tracer + + -- Sadly, this does not work on Windows (Path vs. PATH?): + -- *** Failed! Exception: 'cardano-tracer: spawnProcess: failed (Success)' (after 1 test): + if os(windows) + buildable: False + + build-depends: aeson + , async + , bytestring + , cardano-tracer + , cborg + , containers + , contra-tracer + , directory + , ekg-core + , ekg-forward + , extra + , filepath + , generic-data + , Glob + , optparse-applicative-fork + , ouroboros-network + , ouroboros-network-framework + , process + , QuickCheck + , tasty + , tasty-quickcheck + , text + , time + , trace-dispatcher + , trace-forward + , unix-compat ghc-options: -threaded -rtsopts diff --git a/cardano-tracer/demo/ssh/forwarder.hs b/cardano-tracer/demo/ssh/forwarder.hs index 75d43dd127d..b43ab173fb1 100644 --- a/cardano-tracer/demo/ssh/forwarder.hs +++ b/cardano-tracer/demo/ssh/forwarder.hs @@ -1,11 +1,27 @@ {-# LANGUAGE LambdaCase #-} +import Data.Functor.Identity import System.Environment (getArgs) import Cardano.Tracer.Test.Forwarder +import Cardano.Tracer.Test.TestSetup main :: IO () -main = getArgs >>= \case - [localSock, "Initiator"] -> launchForwardersSimple Initiator localSock 1000 2000 - [localSock, "Responder"] -> launchForwardersSimple Responder localSock 1000 2000 - _ -> putStrLn "Usage: ./demo-forwarder /path/to/local/sock Initiator|Responder" +main = getArgs >>= + \case + [localSock, mode] -> + let ts = TestSetup + { tsTime = Identity 0 + , tsThreads = Identity 0 + , tsMessages = Identity $ Just 0 + , tsSockInternal = Identity localSock + , tsSockExternal = Identity "" + , tsNetworkMagic = Identity $ NetworkMagic 42 + , tsWorkDir = Identity "." + } + in case mode of + "Initiator" -> launchForwardersSimple ts Initiator localSock 1000 2000 + "Responder" -> launchForwardersSimple ts Responder localSock 1000 2000 + _ -> err + _ -> err + where err = error "Usage: ./demo-forwarder /path/to/local/sock Initiator|Responder" diff --git a/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs b/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs index 7fe1a5cf635..49c1a0788b5 100644 --- a/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs +++ b/cardano-tracer/src/Cardano/Tracer/Acceptors/Client.hs @@ -40,6 +40,7 @@ import Cardano.Tracer.Acceptors.Utils (notifyAboutNodeDisconnected, import qualified Cardano.Tracer.Configuration as TC import Cardano.Tracer.Environment import Cardano.Tracer.Handlers.Logs.TraceObjects (traceObjectsHandler) +import Cardano.Tracer.MetaTrace import Cardano.Tracer.Utils (connIdToNodeId) runAcceptorsClient @@ -50,7 +51,8 @@ runAcceptorsClient , DPF.AcceptorConfiguration ) -> IO () -runAcceptorsClient tracerEnv p (ekgConfig, tfConfig, dpfConfig) = withIOManager $ \iocp -> +runAcceptorsClient tracerEnv p (ekgConfig, tfConfig, dpfConfig) = withIOManager $ \iocp -> do + traceWith (teTracer tracerEnv) $ TracerSockConnecting p doConnectToForwarder (localSnocket iocp) (localAddressFromPath p) diff --git a/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs b/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs index bfc100ed95b..34694a94b30 100644 --- a/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs +++ b/cardano-tracer/src/Cardano/Tracer/Acceptors/Server.hs @@ -43,6 +43,7 @@ import Cardano.Tracer.Acceptors.Utils (notifyAboutNodeDisconnected, import qualified Cardano.Tracer.Configuration as TC import Cardano.Tracer.Environment import Cardano.Tracer.Handlers.Logs.TraceObjects (traceObjectsHandler) +import Cardano.Tracer.MetaTrace import Cardano.Tracer.Utils (connIdToNodeId) runAcceptorsServer @@ -53,7 +54,8 @@ runAcceptorsServer , DPF.AcceptorConfiguration ) -> IO () -runAcceptorsServer tracerEnv p (ekgConfig, tfConfig, dpfConfig) = withIOManager $ \iocp -> +runAcceptorsServer tracerEnv p (ekgConfig, tfConfig, dpfConfig) = withIOManager $ \iocp -> do + traceWith (teTracer tracerEnv) $ TracerSockListen p doListenToForwarder (localSnocket iocp) (localAddressFromPath p) diff --git a/cardano-tracer/src/Cardano/Tracer/CLI.hs b/cardano-tracer/src/Cardano/Tracer/CLI.hs index ad0b89e8057..f02d6b537ea 100644 --- a/cardano-tracer/src/Cardano/Tracer/CLI.hs +++ b/cardano-tracer/src/Cardano/Tracer/CLI.hs @@ -5,10 +5,14 @@ module Cardano.Tracer.CLI import Options.Applicative +import Cardano.Logging + + -- | CLI parameters required for the tracer. data TracerParams = TracerParams { tracerConfig :: !FilePath , stateDir :: !(Maybe FilePath) + , logSeverity :: !(Maybe SeverityS) } -- | Parse CLI parameters for the tracer. @@ -30,3 +34,10 @@ parseTracerParams = TracerParams <> completer (bashCompleter "file") ) ) + <*> optional + ( option auto + ( long "min-log-severity" + <> metavar "SEVERITY" + <> help "Drop messages less severe than this. One of: Debug. Info. Notice. Warning. Error. Critical. Alert. Emergency." + ) + ) diff --git a/cardano-tracer/src/Cardano/Tracer/Configuration.hs b/cardano-tracer/src/Cardano/Tracer/Configuration.hs index ecbdfbbed32..74343acf2ef 100644 --- a/cardano-tracer/src/Cardano/Tracer/Configuration.hs +++ b/cardano-tracer/src/Cardano/Tracer/Configuration.hs @@ -17,7 +17,7 @@ module Cardano.Tracer.Configuration , readTracerConfig ) where -import Data.Aeson (FromJSON) +import Data.Aeson (FromJSON, ToJSON) import Data.Fixed (Pico) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) @@ -31,13 +31,13 @@ import System.Exit (die) -- | Only local socket is supported, to avoid unauthorized connections. newtype Address = LocalSocket FilePath - deriving (Eq, Generic, FromJSON, Show) + deriving (Eq, Generic, FromJSON, ToJSON, Show) -- | Endpoint for internal services. data Endpoint = Endpoint { epHost :: !String , epPort :: !Word16 - } deriving (Eq, Generic, FromJSON, Show) + } deriving (Eq, Generic, FromJSON, ToJSON, Show) -- | Parameters of rotation mechanism for logs. data RotationParams = RotationParams @@ -45,39 +45,39 @@ data RotationParams = RotationParams , rpLogLimitBytes :: !Word64 -- ^ Max size of log file in bytes. , rpMaxAgeHours :: !Word16 -- ^ Max age of log file in hours. , rpKeepFilesNum :: !Word32 -- ^ Number of log files to keep in any case. - } deriving (Eq, Generic, FromJSON, Show) + } deriving (Eq, Generic, FromJSON, ToJSON, Show) -- | Logging mode. data LogMode = FileMode -- ^ Store items in log file. | JournalMode -- ^ Store items in Linux journal service. - deriving (Eq, Generic, FromJSON, Show) + deriving (Eq, Generic, FromJSON, ToJSON, Show) -- | Format of log files. data LogFormat = ForHuman -- ^ For human (text) | ForMachine -- ^ For machine (JSON) - deriving (Eq, Generic, FromJSON, Show) + deriving (Eq, Generic, FromJSON, ToJSON, Show) -- | Logging parameters. data LoggingParams = LoggingParams { logRoot :: !FilePath -- ^ Root directory where all subdirs with logs are created. , logMode :: !LogMode -- ^ Log mode. , logFormat :: !LogFormat -- ^ Log format. - } deriving (Eq, Generic, FromJSON, Show) + } deriving (Eq, Generic, FromJSON, ToJSON, Show) -- | Connection mode. data Network = AcceptAt !Address -- ^ Server mode: accepts connections. | ConnectTo !(NonEmpty Address) -- ^ Client mode: initiates connections. - deriving (Eq, Generic, FromJSON, Show) + deriving (Eq, Generic, FromJSON, ToJSON, Show) -- | Tracer's verbosity. data Verbosity = Minimum -- ^ Display minimum of messages. | ErrorsOnly -- ^ Display errors only. | Maximum -- ^ Display all the messages (protocols tracing, errors). - deriving (Eq, Generic, FromJSON, Show) + deriving (Eq, Generic, FromJSON, ToJSON, Show) -- | Tracer configuration. data TracerConfig = TracerConfig @@ -91,7 +91,7 @@ data TracerConfig = TracerConfig , logging :: !(NonEmpty LoggingParams) -- ^ Logging parameters. , rotation :: !(Maybe RotationParams) -- ^ Rotation parameters. , verbosity :: !(Maybe Verbosity) -- ^ Verbosity of the tracer itself. - } deriving (Eq, Generic, FromJSON, Show) + } deriving (Eq, Generic, FromJSON, ToJSON, Show) -- | Read the tracer's configuration file. readTracerConfig :: FilePath -> IO TracerConfig diff --git a/cardano-tracer/src/Cardano/Tracer/Environment.hs b/cardano-tracer/src/Cardano/Tracer/Environment.hs index 580546f87bf..c18bb008a6b 100644 --- a/cardano-tracer/src/Cardano/Tracer/Environment.hs +++ b/cardano-tracer/src/Cardano/Tracer/Environment.hs @@ -9,6 +9,7 @@ import Cardano.Tracer.Handlers.RTView.Notifications.Types import Cardano.Tracer.Handlers.RTView.State.Historical import Cardano.Tracer.Handlers.RTView.State.TraceObjects import Cardano.Tracer.Handlers.RTView.UI.Types +import Cardano.Tracer.MetaTrace import Cardano.Tracer.Types -- | Environment for all functions. @@ -28,4 +29,5 @@ data TracerEnv = TracerEnv , teProtocolsBrake :: !ProtocolsBrake , teRTViewPageOpened :: !WebPageStatus , teRTViewStateDir :: !(Maybe FilePath) + , teTracer :: !(Trace IO TracerTrace) } diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Notifications/Send.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Notifications/Send.hs index e7c97f01131..8a9b291053a 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Notifications/Send.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Notifications/Send.hs @@ -17,32 +17,29 @@ import Data.Time.Clock (UTCTime) import Data.Time.Format (defaultTimeLocale, formatTime) import Cardano.Tracer.Handlers.RTView.Notifications.Email -import Cardano.Tracer.Handlers.RTView.Notifications.Settings import Cardano.Tracer.Handlers.RTView.Notifications.Types import Cardano.Tracer.Types import Cardano.Tracer.Utils makeAndSendNotification - :: Maybe FilePath + :: EmailSettings -> ConnectedNodesNames -> DataPointRequestors -> Lock -> TVar UTCTime -> EventsQueue -> IO () -makeAndSendNotification rtvSD connectedNodesNames dpRequestors +makeAndSendNotification emailSettings connectedNodesNames dpRequestors currentDPLock lastTime eventsQueue = do - emailSettings <- readSavedEmailSettings rtvSD - unless (incompleteEmailSettings emailSettings) $ do - events <- atomically $ nub <$> flushTBQueue eventsQueue - let (nodeIds, tss) = unzip $ nub [(nodeId, ts) | Event nodeId ts _ _ <- events] - unless (null nodeIds) $ do - nodeNames <- - forM nodeIds $ askNodeNameRaw connectedNodesNames dpRequestors currentDPLock - lastEventTime <- readTVarIO lastTime - let onlyNewEvents = filter (\(Event _ ts _ _) -> ts > lastEventTime) events - sendNotification emailSettings onlyNewEvents $ zip nodeIds nodeNames - updateLastTime $ maximum tss + events <- atomically $ nub <$> flushTBQueue eventsQueue + let (nodeIds, tss) = unzip $ nub [(nodeId, ts) | Event nodeId ts _ _ <- events] + unless (null nodeIds) $ do + nodeNames <- + forM nodeIds $ askNodeNameRaw connectedNodesNames dpRequestors currentDPLock + lastEventTime <- readTVarIO lastTime + let onlyNewEvents = filter (\(Event _ ts _ _) -> ts > lastEventTime) events + sendNotification emailSettings onlyNewEvents $ zip nodeIds nodeNames + updateLastTime $ maximum tss where updateLastTime = atomically . modifyTVar' lastTime . const diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Notifications/Utils.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Notifications/Utils.hs index a4e44e3bcfd..f40a4581109 100644 --- a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Notifications/Utils.hs +++ b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Notifications/Utils.hs @@ -30,41 +30,28 @@ initEventsQueues -> Lock -> IO EventsQueues initEventsQueues rtvSD nodesNames dpReqs curDPLock = do - lastTime <- newTVarIO nullTime + emailSettings <- readSavedEmailSettings rtvSD - warnQ <- initEventsQueue - errsQ <- initEventsQueue - critQ <- initEventsQueue - alrtQ <- initEventsQueue - emrgQ <- initEventsQueue - nodeDisconQ <- initEventsQueue + newTVarIO . M.fromList =<< + if incompleteEmailSettings emailSettings + then pure [] + else do + lastTime <- newTVarIO nullTime + let mkEventQueue ident (evsS, evsP) = do + evsQ <- newTBQueueIO 2000 + evsT <- mkTimer + (makeAndSendNotification emailSettings nodesNames dpReqs curDPLock lastTime evsQ) evsS evsP + pure (ident, (evsQ, evsT)) - settings <- readSavedEventsSettings rtvSD - let (warnS, warnP) = evsWarnings settings - (errsS, errsP) = evsErrors settings - (critS, critP) = evsCriticals settings - (alrtS, alrtP) = evsAlerts settings - (emrgS, emrgP) = evsEmergencies settings - (nodeDisconS, nodeDisconP) = evsNodeDisconnected settings - - warnT <- mkTimer (makeAndSendNotification rtvSD nodesNames dpReqs curDPLock lastTime warnQ) warnS warnP - errsT <- mkTimer (makeAndSendNotification rtvSD nodesNames dpReqs curDPLock lastTime errsQ) errsS errsP - critT <- mkTimer (makeAndSendNotification rtvSD nodesNames dpReqs curDPLock lastTime critQ) critS critP - alrtT <- mkTimer (makeAndSendNotification rtvSD nodesNames dpReqs curDPLock lastTime alrtQ) alrtS alrtP - emrgT <- mkTimer (makeAndSendNotification rtvSD nodesNames dpReqs curDPLock lastTime emrgQ) emrgS emrgP - nodeDisconT <- - mkTimer (makeAndSendNotification rtvSD nodesNames dpReqs curDPLock lastTime nodeDisconQ) nodeDisconS nodeDisconP - - newTVarIO $ M.fromList - [ (EventWarnings, (warnQ, warnT)) - , (EventErrors, (errsQ, errsT)) - , (EventCriticals, (critQ, critT)) - , (EventAlerts, (alrtQ, alrtT)) - , (EventEmergencies, (emrgQ, emrgT)) - , (EventNodeDisconnected, (nodeDisconQ, nodeDisconT)) - ] - where - initEventsQueue = newTBQueueIO 2000 + settings <- readSavedEventsSettings rtvSD + mapM (uncurry mkEventQueue) + [ (EventWarnings, evsWarnings settings) + , (EventErrors, evsErrors settings) + , (EventCriticals, evsCriticals settings) + , (EventAlerts, evsAlerts settings) + , (EventEmergencies, evsEmergencies settings) + , (EventNodeDisconnected, evsNodeDisconnected settings) + ] getNewEvents :: EventsQueues diff --git a/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs b/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs new file mode 100644 index 00000000000..3bb666099e2 --- /dev/null +++ b/cardano-tracer/src/Cardano/Tracer/MetaTrace.hs @@ -0,0 +1,152 @@ +{-# OPTIONS_GHC -Wno-partial-fields #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Tracer.MetaTrace + ( module Cardano.Tracer.MetaTrace + , Trace, SeverityF (..), SeverityS (..) + , traceWith + ) where + +import qualified "trace-dispatcher" Control.Tracer as T +import Data.Aeson (ToJSON (..), (.=)) +import Data.Aeson qualified as AE +import Data.Function +import Data.Map qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Generics +import qualified System.IO as Sys + +import Cardano.Logging + +import Cardano.Tracer.Configuration + + +ctorTracerTrace :: TracerTrace -> Text +ctorTracerTrace = \case + TracerParamsAre{} -> "TracerParamsAre" + TracerConfigIs{} -> "TracerConfigIs" + TracerInitStarted{} -> "TracerInitStarted" + TracerInitEventQueues{} -> "TracerInitEventQueues" + TracerInitDone{} -> "TracerInitDone" + TracerSockListen{} -> "TracerSockListen" + TracerSockIncoming{} -> "TracerSockIncoming" + TracerSockConnecting{} -> "TracerSockConnecting" + TracerSockConnected{} -> "TracerSockConnected" + TracerShutdownInitiated{} -> "TracerShutdownInitiated" + TracerShutdownHistBackup{} -> "TracerShutdownHistBackup" + TracerShutdownComplete{} -> "TracerShutdownComplete" + TracerError{} -> "TracerError" + +data TracerTrace + = TracerParamsAre + { ttConfigPath :: !FilePath + , ttStateDir :: !(Maybe FilePath) + , ttMinLogSeverity :: !(Maybe SeverityS) } + | TracerConfigIs + { ttConfig :: !TracerConfig } + | TracerInitStarted + | TracerInitEventQueues + | TracerInitDone + | TracerSockListen + { ttListenAt :: !FilePath } + | TracerSockIncoming + { ttConnectionIncomingAt :: !FilePath + , ttAddr :: !Text } + | TracerSockConnecting + { ttConnectingTo :: !FilePath } + | TracerSockConnected + { ttConnectedTo :: !FilePath } + | TracerShutdownInitiated + | TracerShutdownHistBackup + | TracerShutdownComplete + | TracerError + { ttError :: !Text } + deriving (Generic, Show) + +instance ToJSON TracerTrace where + toJSON = AE.genericToJSON jsonEncodingOptions + toEncoding = AE.genericToEncoding jsonEncodingOptions + +jsonEncodingOptions :: AE.Options +jsonEncodingOptions = AE.defaultOptions + { AE.fieldLabelModifier = drop 2 + , AE.tagSingleConstructors = True + , AE.sumEncoding = + AE.TaggedObject + { AE.tagFieldName = "kind" + , AE.contentsFieldName = "contents" + } + } + +instance LogFormatting TracerTrace where + forHuman = T.pack . show + forMachine DMinimal _ = mempty + forMachine DNormal t = mconcat [ "kind" .= AE.String (ctorTracerTrace t) ] + forMachine DDetailed t = forMachine DMaximum t + forMachine DMaximum t = case AE.toJSON t of + AE.Object x -> x + _ -> error "Impossible" + +stderrShowTracer :: Trace IO TracerTrace +stderrShowTracer = + Trace $ T.arrow $ T.emit $ + either (const $ pure ()) (Sys.hPrint Sys.stderr) . snd + +stderrTracer :: Trace IO FormattedMessage +stderrTracer = + Trace $ T.arrow $ T.emit $ + either (const $ pure ()) (Sys.hPutStrLn Sys.stderr . T.unpack . render) . snd + where + render = \case + FormattedHuman _ x -> x + FormattedMachine x -> x + _ -> "" + +mkTracerTracer :: SeverityF -> IO (Trace IO TracerTrace) +mkTracerTracer defSeverity = do + base :: Trace IO FormattedMessage <- standardTracer + metaBase :: Trace IO TracerTrace <- + machineFormatter Nothing base + >>= withDetailsFromConfig + let tr = metaBase + & withNamesAppended ((:[]) . ctorTracerTrace) + & appendName "Tracer" + & withSeverity + (\case + TracerParamsAre{} -> Warning + TracerConfigIs{} -> Warning + TracerShutdownInitiated{} -> Warning + TracerShutdownComplete{} -> Warning + TracerError{} -> Error + _ -> Info) + configureTracers initialTraceConfig trDoc [tr] + pure tr + where + initialTraceConfig :: TraceConfig + initialTraceConfig = + TraceConfig + { tcForwarder = defaultForwarder + , tcNodeName = Nothing + , tcPeerFrequency = Nothing + , tcResourceFrequency = Nothing + , tcOptions = Map.fromList + [ ([], [ConfSeverity defSeverity]) + , (["Tracer"], [ConfDetail DMaximum]) + ] + } + trDoc :: Documented TracerTrace + trDoc = Documented [] diff --git a/cardano-tracer/src/Cardano/Tracer/Run.hs b/cardano-tracer/src/Cardano/Tracer/Run.hs index 0c2adf17012..561859eb832 100644 --- a/cardano-tracer/src/Cardano/Tracer/Run.hs +++ b/cardano-tracer/src/Cardano/Tracer/Run.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} -- | This top-level module is used by 'cardano-tracer' app. module Cardano.Tracer.Run @@ -20,25 +21,33 @@ import Cardano.Tracer.Handlers.Metrics.Servers import Cardano.Tracer.Handlers.RTView.Run import Cardano.Tracer.Handlers.RTView.State.Historical import Cardano.Tracer.Handlers.RTView.Update.Historical +import Cardano.Tracer.MetaTrace import Cardano.Tracer.Types import Cardano.Tracer.Utils -- | Top-level run function, called by 'cardano-tracer' app. runCardanoTracer :: TracerParams -> IO () -runCardanoTracer TracerParams{tracerConfig, stateDir} = do +runCardanoTracer TracerParams{tracerConfig, stateDir, logSeverity} = do + tr <- mkTracerTracer $ SeverityF logSeverity + traceWith tr $ TracerParamsAre tracerConfig stateDir logSeverity + config <- readTracerConfig tracerConfig + traceWith tr $ TracerConfigIs config + brake <- initProtocolsBrake dpRequestors <- initDataPointRequestors - doRunCardanoTracer config stateDir brake dpRequestors + doRunCardanoTracer config stateDir tr brake dpRequestors -- | Runs all internal services of the tracer. doRunCardanoTracer :: TracerConfig -- ^ Tracer's configuration. -> Maybe FilePath -- ^ Path to RTView's internal state files. + -> Trace IO TracerTrace -> ProtocolsBrake -- ^ The flag we use to stop all the protocols. -> DataPointRequestors -- ^ The DataPointRequestors to ask 'DataPoint's. -> IO () -doRunCardanoTracer config rtViewStateDir protocolsBrake dpRequestors = do +doRunCardanoTracer config rtViewStateDir tr protocolsBrake dpRequestors = do + traceWith tr TracerInitStarted connectedNodes <- initConnectedNodes connectedNodesNames <- initConnectedNodesNames acceptedMetrics <- initAcceptedMetrics @@ -50,6 +59,8 @@ doRunCardanoTracer config rtViewStateDir protocolsBrake dpRequestors = do currentLogLock <- newLock currentDPLock <- newLock + + traceWith tr TracerInitEventQueues eventsQueues <- initEventsQueues rtViewStateDir connectedNodesNames dpRequestors currentDPLock rtViewPageOpened <- newTVarIO False @@ -72,13 +83,18 @@ doRunCardanoTracer config rtViewStateDir protocolsBrake dpRequestors = do , teProtocolsBrake = protocolsBrake , teRTViewPageOpened = rtViewPageOpened , teRTViewStateDir = rtViewStateDir + , teTracer = tr } -- Specify what should be done before 'cardano-tracer' stops. beforeProgramStops $ do + traceWith tr TracerShutdownInitiated backupAllHistory tracerEnv + traceWith tr TracerShutdownHistBackup applyBrake (teProtocolsBrake tracerEnv) + traceWith tr TracerShutdownComplete + traceWith tr TracerInitDone void . sequenceConcurrently $ [ runLogsRotator tracerEnv , runMetricsServers tracerEnv diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs b/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs index 3cc010ff058..410d2c5c8f6 100644 --- a/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs +++ b/cardano-tracer/test/Cardano/Tracer/Test/Acceptor.hs @@ -21,6 +21,7 @@ import Cardano.Tracer.Acceptors.Run import Cardano.Tracer.Configuration import Cardano.Tracer.Handlers.RTView.Run import Cardano.Tracer.Handlers.RTView.State.Historical +import Cardano.Tracer.MetaTrace import Cardano.Tracer.Types import Cardano.Tracer.Utils import Trace.Forward.Utils.DataPoint @@ -49,6 +50,8 @@ launchAcceptorsSimple mode localSock dpName = do rtViewPageOpened <- newTVarIO False + tr <- mkTracerTracer $ SeverityF $ Just Warning + let tracerEnv = TracerEnv { teConfig = mkConfig @@ -66,6 +69,7 @@ launchAcceptorsSimple mode localSock dpName = do , teProtocolsBrake = protocolsBrake , teRTViewPageOpened = rtViewPageOpened , teRTViewStateDir = Nothing + , teTracer = tr } void . sequenceConcurrently $ diff --git a/cardano-tracer/test/Cardano/Tracer/Test/DataPoint/Tests.hs b/cardano-tracer/test/Cardano/Tracer/Test/DataPoint/Tests.hs index eec913372f3..14eb70c2b3f 100644 --- a/cardano-tracer/test/Cardano/Tracer/Test/DataPoint/Tests.hs +++ b/cardano-tracer/test/Cardano/Tracer/Test/DataPoint/Tests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Cardano.Tracer.Test.DataPoint.Tests @@ -19,25 +20,27 @@ import Trace.Forward.Protocol.DataPoint.Type import Trace.Forward.Utils.DataPoint (askForDataPoints) import Cardano.Tracer.Configuration +import Cardano.Tracer.MetaTrace import Cardano.Tracer.Run (doRunCardanoTracer) import Cardano.Tracer.Utils (applyBrake, initProtocolsBrake, initDataPointRequestors) import Cardano.Tracer.Test.Forwarder +import Cardano.Tracer.Test.TestSetup import Cardano.Tracer.Test.Utils -tests :: TestTree -tests = localOption (QuickCheckTests 1) $ testGroup "Test.DataPoint" - [ testProperty "ask" $ propRunInLogsStructure propDataPoint +tests :: TestSetup Identity -> TestTree +tests ts = localOption (QuickCheckTests 1) $ testGroup "Test.DataPoint" + [ testProperty "ask" $ propRunInLogsStructure ts (propDataPoint ts) ] -propDataPoint :: FilePath -> FilePath -> IO Property -propDataPoint rootDir localSock = do +propDataPoint :: TestSetup Identity -> FilePath -> FilePath -> IO Property +propDataPoint ts@TestSetup{..} rootDir localSock = do stopProtocols <- initProtocolsBrake dpRequestors <- initDataPointRequestors savedDPValues :: TVar DataPointValues <- newTVarIO [] - withAsync (doRunCardanoTracer config Nothing stopProtocols dpRequestors) . const $ do + withAsync (doRunCardanoTracer config (Just $ rootDir <> "/../state") stderrShowTracer stopProtocols dpRequestors) . const $ do sleep 1.0 - withAsync (launchForwardersSimple Initiator localSock 1000 10000) . const $ do + withAsync (launchForwardersSimple ts Initiator localSock 1000 10000) . const $ do sleep 1.5 -- We know that there is one single "node" only (and one single requestor too). -- requestors ((_, dpRequestor):_) <- M.toList <$> readTVarIO dpRequestors @@ -77,7 +80,7 @@ propDataPoint rootDir localSock = do _ -> false "Not expected number of DataPoint values!" where config = TracerConfig - { networkMagic = 764824073 + { networkMagic = unNetworkMagic $ unI tsNetworkMagic , network = AcceptAt (LocalSocket localSock) -- ConnectTo $ NE.fromList [LocalSocket localSock] , loRequestNum = Just 1 , ekgRequestFreq = Just 1.0 diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs b/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs index 3b9c05203bb..d1551d1c83a 100644 --- a/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs +++ b/cardano-tracer/test/Cardano/Tracer/Test/Forwarder.hs @@ -3,6 +3,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} module Cardano.Tracer.Test.Forwarder ( ForwardersMode (..) @@ -23,6 +25,7 @@ import Data.Void (Void) import Data.Word (Word16) import GHC.Generics import qualified System.Metrics as EKG +import System.Directory import Cardano.Logging (DetailLevel (..), SeverityS (..), TraceObject (..)) import Cardano.Logging.Version (ForwardingVersion (..), ForwardingVersionData (..), @@ -30,7 +33,6 @@ import Cardano.Logging.Version (ForwardingVersion (..), ForwardingVers import Ouroboros.Network.Driver.Limits (ProtocolTimeLimits) import Ouroboros.Network.ErrorPolicy (nullErrorPolicies) import Ouroboros.Network.IOManager (IOManager, withIOManager) -import Ouroboros.Network.Magic (NetworkMagic (..)) import Ouroboros.Network.Mux (MiniProtocol (..), MiniProtocolLimits (..), MiniProtocolNum (..), MuxMode (..), OuroborosApplication (..), RunMiniProtocol (..), miniProtocolLimits, miniProtocolNum, miniProtocolRun) @@ -55,6 +57,8 @@ import Trace.Forward.Utils.DataPoint import Trace.Forward.Utils.TraceObject import Cardano.Tracer.Configuration (Verbosity (..)) +import Cardano.Tracer.Test.TestSetup +import Cardano.Tracer.Test.Utils import Cardano.Tracer.Utils data ForwardersMode = Initiator | Responder @@ -73,31 +77,35 @@ mkTestDataPoint = TestDataPoint } launchForwardersSimple - :: ForwardersMode + :: TestSetup Identity + -> ForwardersMode -> FilePath -> Word -> Word -> IO () -launchForwardersSimple mode p connSize disconnSize = withIOManager $ \iomgr -> - runInLoop (launchForwardersSimple' iomgr mode p connSize disconnSize) (Just Minimum) p 1 +launchForwardersSimple ts mode p connSize disconnSize = withIOManager $ \iomgr -> + runInLoop (launchForwardersSimple' ts iomgr mode p connSize disconnSize) (Just Minimum) p 1 launchForwardersSimple' - :: IOManager + :: TestSetup Identity + -> IOManager -> ForwardersMode -> FilePath -> Word -> Word -> IO () -launchForwardersSimple' iomgr mode p connSize disconnSize = +launchForwardersSimple' ts iomgr mode p connSize disconnSize = do case mode of Initiator -> doConnectToAcceptor + ts (localSnocket iomgr) (localAddressFromPath p) noTimeLimitsHandshake (ekgConfig, tfConfig, dpfConfig) Responder -> doListenToAcceptor + ts (localSnocket iomgr) (localAddressFromPath p) noTimeLimitsHandshake @@ -124,12 +132,13 @@ launchForwardersSimple' iomgr mode p connSize disconnSize = dpfConfig :: DPF.ForwarderConfiguration dpfConfig = DPF.ForwarderConfiguration - { DPF.forwarderTracer = contramap show stdoutTracer -- nullTracer + { DPF.forwarderTracer = nullTracer -- contramap show stdoutTracer -- nullTracer , DPF.acceptorEndpoint = p } doConnectToAcceptor - :: Snocket IO fd addr + :: TestSetup Identity + -> Snocket IO fd addr -> addr -> ProtocolTimeLimits (Handshake ForwardingVersion Term) -> ( EKGF.ForwarderConfiguration @@ -137,7 +146,7 @@ doConnectToAcceptor , DPF.ForwarderConfiguration ) -> IO () -doConnectToAcceptor snocket address timeLimits (ekgConfig, tfConfig, dpfConfig) = do +doConnectToAcceptor TestSetup{..} snocket address timeLimits (ekgConfig, tfConfig, dpfConfig) = do store <- EKG.newStore EKG.registerGcMetrics store sink <- initForwardSink tfConfig @@ -153,7 +162,7 @@ doConnectToAcceptor snocket address timeLimits (ekgConfig, tfConfig, dpfConfig) acceptableVersion (simpleSingletonVersions ForwardingV_1 - (ForwardingVersionData $ NetworkMagic 764824073) -- Taken from mainnet shelley genesis file. + (ForwardingVersionData $ unI tsNetworkMagic) (forwarderApp [ (forwardEKGMetrics ekgConfig store, 1) , (forwardTraceObjectsInit tfConfig sink, 2) , (forwardDataPointsInit dpfConfig dpStore, 3) @@ -178,7 +187,8 @@ doConnectToAcceptor snocket address timeLimits (ekgConfig, tfConfig, dpfConfig) doListenToAcceptor :: Ord addr - => Snocket IO fd addr + => TestSetup Identity + -> Snocket IO fd addr -> addr -> ProtocolTimeLimits (Handshake ForwardingVersion Term) -> ( EKGF.ForwarderConfiguration @@ -186,7 +196,9 @@ doListenToAcceptor , DPF.ForwarderConfiguration ) -> IO () -doListenToAcceptor snocket address timeLimits (ekgConfig, tfConfig, dpfConfig) = do +doListenToAcceptor TestSetup{..} + snocket address timeLimits (ekgConfig, tfConfig, dpfConfig) = do + store <- EKG.newStore EKG.registerGcMetrics store sink <- initForwardSink tfConfig @@ -207,7 +219,7 @@ doListenToAcceptor snocket address timeLimits (ekgConfig, tfConfig, dpfConfig) = acceptableVersion (simpleSingletonVersions ForwardingV_1 - (ForwardingVersionData $ NetworkMagic 764824073) -- Taken from mainnet shelley genesis file. + (ForwardingVersionData $ unI tsNetworkMagic) -- Taken from mainnet shelley genesis file. (SomeResponderApplication $ forwarderApp [ (forwardEKGMetricsResp ekgConfig store, 1) , (forwardTraceObjectsResp tfConfig sink, 2) diff --git a/cardano-tracer/test/Cardano/Tracer/Test/ForwardingStressTest/Config.hs b/cardano-tracer/test/Cardano/Tracer/Test/ForwardingStressTest/Config.hs new file mode 100644 index 00000000000..561e9527219 --- /dev/null +++ b/cardano-tracer/test/Cardano/Tracer/Test/ForwardingStressTest/Config.hs @@ -0,0 +1,85 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Tracer.Test.ForwardingStressTest.Config ( + config1 + , config2 + , config3 + , config4 + ) where + +import Data.Map (fromList) +import Test.QuickCheck + +import Cardano.Logging + + +-- | different configurations for testing +config1 :: TraceConfig +config1 = emptyTraceConfig { + tcOptions = fromList + [([] :: Namespace, + [ ConfSeverity (SeverityF (Just Debug)) + , ConfDetail DNormal + , ConfBackend [Stdout HumanFormatColoured, Forwarder, EKGBackend] + ]) + ] + } + +config2 :: TraceConfig +config2 = emptyTraceConfig { + tcOptions = fromList + [ ([] :: Namespace, + [ ConfSeverity (SeverityF (Just Debug)) + , ConfDetail DNormal + , ConfBackend [Stdout HumanFormatColoured, Forwarder, EKGBackend] + ]) + , (["Test", "Message1"], + [ ConfSeverity (SeverityF (Just Info)) + , ConfDetail DNormal + , ConfBackend [Stdout HumanFormatColoured, EKGBackend] + ]) + , (["Test", "Message2"], + [ ConfSeverity (SeverityF (Just Error)) + , ConfDetail DMinimal + , ConfBackend [Forwarder, EKGBackend] + ]) + ] + } + + +config3 :: TraceConfig +config3 = emptyTraceConfig { + tcOptions = fromList + [ ([] :: Namespace, + [ ConfSeverity (SeverityF (Just Debug)) + , ConfDetail DNormal + , ConfBackend [Stdout HumanFormatColoured, Forwarder, EKGBackend] + ]) + , (["Test", "Message1"], + [ ConfSeverity (SeverityF (Just Debug)) + , ConfDetail DNormal + , ConfBackend [Stdout HumanFormatColoured, EKGBackend] + , ConfLimiter 100 + ]) + , (["Test", "Message2"], + [ ConfSeverity (SeverityF (Just Error)) + , ConfDetail DMinimal + , ConfBackend [Forwarder, EKGBackend] + ]) + ] + } + +-- | different configurations for testing +config4 :: TraceConfig +config4 = emptyTraceConfig { + tcOptions = fromList + [([] :: Namespace, + [ ConfSeverity (SeverityF (Just Debug)) + , ConfDetail DNormal + , ConfBackend [EKGBackend] + ]) + ] + } + +instance Arbitrary TraceConfig where + arbitrary = elements [config1, config2] diff --git a/cardano-tracer/test/Cardano/Tracer/Test/ForwardingStressTest/Messages.hs b/cardano-tracer/test/Cardano/Tracer/Test/ForwardingStressTest/Messages.hs new file mode 100644 index 00000000000..b5d2b57bdd2 --- /dev/null +++ b/cardano-tracer/test/Cardano/Tracer/Test/ForwardingStressTest/Messages.hs @@ -0,0 +1,54 @@ +module Cardano.Tracer.Test.ForwardingStressTest.Messages ( + namesForMessage + , severityForMessage + , privacyForMessage + , docMessage + , getMessageID + , setMessageID + ) where + +import Data.Text + +import Cardano.Logging +import Cardano.Tracer.Test.ForwardingStressTest.Types + +getMessageID :: Message -> MessageID +getMessageID (Message1 mid _) = mid +getMessageID (Message2 mid _) = mid +getMessageID (Message3 mid _) = mid + +setMessageID :: Message -> MessageID -> Message +setMessageID (Message1 _ v) mid = Message1 mid v +setMessageID (Message2 _ v) mid = Message2 mid v +setMessageID (Message3 _ v) mid = Message3 mid v + +namesForMessage :: Message -> [Text] +namesForMessage Message1 {} = ["Message1"] +namesForMessage Message2 {} = ["Message2"] +namesForMessage Message3 {} = ["Message3"] + +severityForMessage :: Message -> SeverityS +severityForMessage Message1 {} = Debug +severityForMessage Message2 {} = Info +severityForMessage Message3 {} = Error + +privacyForMessage :: Message -> Privacy +privacyForMessage Message1 {} = Public +privacyForMessage Message2 {} = Confidential +privacyForMessage Message3 {} = Public + +docMessage :: Documented Message +docMessage = Documented [ + DocMsg + ["Message1"] + [] + "The first message." + , DocMsg + ["Message2"] + [] + "The second message." + , DocMsg + ["Message3"] + [("Metrics1", "A number")] + "The third message." + ] diff --git a/cardano-tracer/test/Cardano/Tracer/Test/ForwardingStressTest/Script.hs b/cardano-tracer/test/Cardano/Tracer/Test/ForwardingStressTest/Script.hs new file mode 100644 index 00000000000..32aaa35c6d6 --- /dev/null +++ b/cardano-tracer/test/Cardano/Tracer/Test/ForwardingStressTest/Script.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Tracer.Test.ForwardingStressTest.Script + ( TestSetup(..) + , simpleTestConfig + , getTestSetup + , runScriptForwarding + ) where + +import Control.Concurrent (ThreadId, forkFinally, threadDelay) +import Control.Concurrent.MVar +import Control.Exception.Base (SomeException, throw) +import Control.Monad (when) +import Data.Functor.Identity +import Data.IORef +import Data.List (sort) +import Data.Map (fromList) +import Data.Maybe +import System.FilePath.Glob + +import Test.QuickCheck + +import Cardano.Logging +import Cardano.Tracer.Test.ForwardingStressTest.Config () +import Cardano.Tracer.Test.ForwardingStressTest.Messages +import Cardano.Tracer.Test.ForwardingStressTest.Types +import Cardano.Tracer.Test.TestSetup +import Cardano.Tracer.Test.Utils + + +import Debug.Trace + +-- | configuration for testing +simpleTestConfig :: TraceConfig +simpleTestConfig = emptyTraceConfig { + tcOptions = fromList + [([] :: Namespace, + [ ConfSeverity (SeverityF (Just Debug)) + , ConfDetail DNormal + , ConfBackend [Forwarder] + ]) + ] + } + +-- | Run scripts in three threads in parallel. +-- The duration of the test is given by time in seconds +runScriptForwarding :: + TestSetup Identity + -> IORef Int + -> IO (Trace IO Message) + -> Property +runScriptForwarding ts@TestSetup{..} msgCounter tracerGetter = + trace ("Test setup " ++ show ts) $ do + let generator :: Gen [Script] = vectorOf (unI tsThreads) $ + case unI tsMessages of + Nothing -> scale (* 1000) arbitrary + Just numMsg -> Script <$> vectorOf numMsg arbitrary + forAll generator (\ (scripts :: [Script]) + -> ioProperty $ do + tr <- tracerGetter + configureTracers simpleTestConfig docMessage [tr] + let scripts' = map (\ (Script sc) -> Script + $ filter (\(ScriptedMessage _ msg) -> + namesForMessage msg /= ["Message2"]) sc) scripts + scripts'' = map (\ (Script sc) -> Script (sort sc)) scripts' + scripts''' = zipWith (\ (Script sc) ind -> Script ( + withMessageIds (unI tsThreads) ind sc)) scripts'' [0..] + scripts'''' = map (\ (Script sc) -> Script + $ map (withTimeFactor (unI tsTime)) sc) scripts''' + + + -- putStrLn ("runTest " ++ show scripts) + children :: MVar [MVar (Either SomeException ())] <- newMVar [] + mapM_ (\sc -> forkChild children (playIt sc tr 0.0)) scripts'''' + res <- waitForChildren children [] + let resErr = mapMaybe + (\case + Right _ -> Nothing + Left err -> Just err) res + threadDelay 500000 --wait 0,5 seconds + if not (null resErr) + then throw (head resErr) + else -- Oracle + let numMsg = sum (map (\ (Script sc) -> length sc) scripts'''') + in if numMsg > 0 then do + -- TODO mutiple files + let logfileGlobPattern = unI tsWorkDir <> "/logs/*sock@*/node-*.json" + logs <- glob logfileGlobPattern + logFile <- case logs of + [] -> fail $ "No files match the logfile glob pattern: " <> logfileGlobPattern + _:_:_ -> fail $ "More than one file matches the logfile glob pattern: " <> logfileGlobPattern + x:_ -> pure x + contents <- readFile logFile + let lineLength = length (lines contents) + totalNumMsg <- atomicModifyIORef msgCounter (\ac -> + let nc = ac + numMsg + in (nc, nc)) + pure (totalNumMsg == lineLength) + else do + pure True + + ) + +forkChild :: MVar [MVar (Either SomeException ())] -> IO () -> IO ThreadId +forkChild children io = do + mvar <- newEmptyMVar + childs <- takeMVar children + putMVar children (mvar:childs) + forkFinally io (putMVar mvar) + +waitForChildren :: MVar [MVar (Either SomeException ())] + -> [Either SomeException ()] + -> IO [Either SomeException ()] +waitForChildren children accum = do + cs <- takeMVar children + case cs of + [] -> pure accum + m:ms -> do + putMVar children ms + res <- takeMVar m + waitForChildren children (res : accum) + + +-- | Play the current script in one thread +-- The time is in milliseconds +playIt :: Script -> Trace IO Message -> Double -> IO () +playIt (Script []) _tr _d = pure () +playIt (Script (ScriptedMessage d1 m1 : rest)) tr d = do + when (d < d1) $ threadDelay (round ((d1 - d) * 1000000)) + -- this is in microseconds + traceWith tr m1 + playIt (Script rest) tr d1 + +-- | Adds a message id to every message. +-- MessageId gives the id to start with. +-- Returns a tuple with the messages with ids and +-- the successor of the last used messageId +withMessageIds :: Int -> MessageID -> [ScriptedMessage] -> [ScriptedMessage] +withMessageIds numThreads mid sMsgs = go mid sMsgs [] + where + go _mid' [] acc = reverse acc + go mid' (ScriptedMessage time msg : tl) acc = + go (mid' + numThreads) tl (ScriptedMessage time (setMessageID msg mid') : acc) + +withTimeFactor :: Double -> ScriptedMessage -> ScriptedMessage +withTimeFactor factor (ScriptedMessage time msg) = + ScriptedMessage (time * factor) msg diff --git a/cardano-tracer/test/Cardano/Tracer/Test/ForwardingStressTest/Types.hs b/cardano-tracer/test/Cardano/Tracer/Test/ForwardingStressTest/Types.hs new file mode 100644 index 00000000000..ae08cfe1816 --- /dev/null +++ b/cardano-tracer/test/Cardano/Tracer/Test/ForwardingStressTest/Types.hs @@ -0,0 +1,101 @@ +module Cardano.Tracer.Test.ForwardingStressTest.Types ( + MessageID + , Message (..) + , ScriptedMessage (..) + , Script (..) + , ScriptRes (..) + , scriptLength + , emptyScriptRes + ) where + +import Data.Aeson (Value (..), (.=)) +import Data.Text hiding (length) +import Test.QuickCheck + +import Cardano.Logging + +type MessageID = Int + +data Message = + Message1 MessageID Int + | Message2 MessageID Text + | Message3 MessageID Double + deriving (Eq, Ord, Show) + +instance LogFormatting Message where + forMachine _dtal (Message1 mid i) = + mconcat [ "kind" .= String "Message1" + , "mid" .= ("<" <> showT mid <> ">") + , "workload" .= String (showT i) + ] + forMachine DMinimal (Message2 mid _s) = + mconcat [ "mid" .= ("<" <> showT mid <> ">") + , "kind" .= String "Message2" + ] + forMachine _dtal (Message2 mid s) = + mconcat [ "kind" .= String "Message2" + , "mid" .= String ("<" <> showT mid <> ">") + , "workload" .= String s + ] + forMachine _dtal (Message3 mid d) = + mconcat [ "kind" .= String "Message3" + , "mid" .= String ("<" <> showT mid <> ">") + , "workload" .= String (showT d) + ] + forHuman (Message1 mid i) = + "Message1 <" <> showT mid <> "> " <> showT i + forHuman (Message2 mid s) = + "Message2 <" <> showT mid <> "> " <> s + forHuman (Message3 mid d) = + "Message3 <" <> showT mid <> "> " <> showT d + asMetrics (Message1 mid _i) = + [ IntM "Metrics1" (fromIntegral mid) + , IntM "Metrics2" (fromIntegral mid) + , IntM "Metrics3" (fromIntegral mid) + , IntM "Metrics4" (fromIntegral mid) + , IntM "Metrics5" (fromIntegral mid)] + asMetrics _ = [] + +instance Arbitrary Message where + arbitrary = oneof + [ Message1 0 <$> arbitrary, + Message2 0 <$> elements ["Hallo", "Goodbye", "Whatelse"], + Message3 0 <$> arbitrary + ] + + +-- | Adds a time between 0 and 1. +-- 0 is the time of the test start, and 1 the test end +data ScriptedMessage = ScriptedMessage Double Message + deriving (Eq, Show) + +-- Ordered by time +instance Ord ScriptedMessage where + compare (ScriptedMessage d1 _m1) (ScriptedMessage d2 _m2) = compare d1 d2 + +instance Arbitrary ScriptedMessage where + arbitrary = ScriptedMessage <$> choose (0.0, 1.0) <*> arbitrary + +newtype Script = Script [ScriptedMessage] + deriving (Eq, Show) + +scriptLength :: Script -> Int +scriptLength (Script m) = length m + +instance Arbitrary Script where + arbitrary = Script <$> listOf arbitrary + +data ScriptRes = ScriptRes { + srScript :: Script + , srStdoutRes :: [FormattedMessage] + , srForwardRes :: [FormattedMessage] + , srEkgRes :: [FormattedMessage] + } + +emptyScriptRes :: ScriptRes +emptyScriptRes = ScriptRes { + srScript = Script [] + , srStdoutRes = [] + , srForwardRes = [] + , srEkgRes = [] +} diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Logs/Tests.hs b/cardano-tracer/test/Cardano/Tracer/Test/Logs/Tests.hs index 8bb187b7420..ed36b8d97f3 100644 --- a/cardano-tracer/test/Cardano/Tracer/Test/Logs/Tests.hs +++ b/cardano-tracer/test/Cardano/Tracer/Test/Logs/Tests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} module Cardano.Tracer.Test.Logs.Tests ( tests @@ -18,34 +19,36 @@ import System.Time.Extra import Cardano.Tracer.Configuration import Cardano.Tracer.Handlers.Logs.Utils (isItLog) import Cardano.Tracer.Run (doRunCardanoTracer) +import Cardano.Tracer.MetaTrace import Cardano.Tracer.Utils (applyBrake, initProtocolsBrake, initDataPointRequestors) import Cardano.Tracer.Test.Forwarder +import Cardano.Tracer.Test.TestSetup import Cardano.Tracer.Test.Utils -tests :: TestTree -tests = localOption (QuickCheckTests 1) $ testGroup "Test.Logs" - [ testProperty ".log" $ propRunInLogsStructure (propLogs ForHuman) - , testProperty ".json" $ propRunInLogsStructure (propLogs ForMachine) - , testProperty "multi, initiator" $ propRunInLogsStructure2 (propMultiInit ForMachine) - , testProperty "multi, responder" $ propRunInLogsStructure (propMultiResp ForMachine) +tests :: TestSetup Identity -> TestTree +tests ts = localOption (QuickCheckTests 1) $ testGroup "Test.Logs" + [ testProperty ".log" $ propRunInLogsStructure ts (propLogs ts ForHuman) + , testProperty ".json" $ propRunInLogsStructure ts (propLogs ts ForMachine) + , testProperty "multi, initiator" $ propRunInLogsStructure2 ts (propMultiInit ts ForMachine) + , testProperty "multi, responder" $ propRunInLogsStructure ts (propMultiResp ts ForMachine) ] -propLogs :: LogFormat -> FilePath -> FilePath -> IO Property -propLogs format rootDir localSock = do +propLogs :: TestSetup Identity -> LogFormat -> FilePath -> FilePath -> IO Property +propLogs ts@TestSetup{..} format rootDir localSock = do stopProtocols <- initProtocolsBrake dpRequestors <- initDataPointRequestors - withAsync (doRunCardanoTracer (config rootDir localSock) Nothing stopProtocols dpRequestors) . const $ do + withAsync (doRunCardanoTracer (config rootDir localSock) (Just $ rootDir <> "/../state") stderrShowTracer stopProtocols dpRequestors) . const $ do sleep 1.0 - withAsync (launchForwardersSimple Initiator localSock 1000 10000) . const $ do + withAsync (launchForwardersSimple ts Initiator localSock 1000 10000) . const $ do sleep 8.0 -- Wait till some rotation is done. applyBrake stopProtocols sleep 0.5 doesDirectoryExist rootDir >>= \case False -> false "root dir doesn't exist" - True -> + True -> do -- ... and contains one node's subdir... listDirectories rootDir >>= \case [] -> false "root dir is empty" @@ -61,7 +64,7 @@ propLogs format rootDir localSock = do _logs -> return $ property True where config root p = TracerConfig - { networkMagic = 764824073 + { networkMagic = unNetworkMagic $ unI tsNetworkMagic , network = AcceptAt (LocalSocket p) , loRequestNum = Just 1 , ekgRequestFreq = Just 1.0 @@ -78,22 +81,22 @@ propLogs format rootDir localSock = do , verbosity = Just Minimum } -propMultiInit :: LogFormat -> FilePath -> FilePath -> FilePath -> IO Property -propMultiInit format rootDir localSock1 localSock2 = do +propMultiInit :: TestSetup Identity -> LogFormat -> FilePath -> FilePath -> FilePath -> IO Property +propMultiInit ts@TestSetup{..} format rootDir localSock1 localSock2 = do stopProtocols <- initProtocolsBrake dpRequestors <- initDataPointRequestors - withAsync (doRunCardanoTracer (config rootDir localSock1 localSock2) Nothing stopProtocols dpRequestors) . const $ do + withAsync (doRunCardanoTracer (config rootDir localSock1 localSock2) (Just $ rootDir <> "/../state") stderrShowTracer stopProtocols dpRequestors) . const $ do sleep 1.0 - withAsync (launchForwardersSimple Responder localSock1 1000 10000) . const $ do + withAsync (launchForwardersSimple ts Responder localSock1 1000 10000) . const $ do sleep 1.0 - withAsync (launchForwardersSimple Responder localSock2 1000 10000) . const $ do + withAsync (launchForwardersSimple ts Responder localSock2 1000 10000) . const $ do sleep 5.0 -- Wait till some work is done. applyBrake stopProtocols sleep 0.5 checkMultiResults rootDir where config root p1 p2 = TracerConfig - { networkMagic = 764824073 + { networkMagic = unNetworkMagic $ unI tsNetworkMagic , network = ConnectTo $ NE.fromList [LocalSocket p1, LocalSocket p2] , loRequestNum = Just 1 , ekgRequestFreq = Just 1.0 @@ -105,22 +108,22 @@ propMultiInit format rootDir localSock1 localSock2 = do , verbosity = Just Minimum } -propMultiResp :: LogFormat -> FilePath -> FilePath -> IO Property -propMultiResp format rootDir localSock = do +propMultiResp :: TestSetup Identity -> LogFormat -> FilePath -> FilePath -> IO Property +propMultiResp ts@TestSetup{..} format rootDir localSock = do stopProtocols <- initProtocolsBrake dpRequestors <- initDataPointRequestors - withAsync (doRunCardanoTracer (config rootDir localSock) Nothing stopProtocols dpRequestors) . const $ do + withAsync (doRunCardanoTracer (config rootDir localSock) (Just $ rootDir <> "/../state") stderrShowTracer stopProtocols dpRequestors) . const $ do sleep 1.0 - withAsync (launchForwardersSimple Initiator localSock 1000 10000) . const $ do + withAsync (launchForwardersSimple ts Initiator localSock 1000 10000) . const $ do sleep 1.0 - withAsync (launchForwardersSimple Initiator localSock 1000 10000) . const $ do + withAsync (launchForwardersSimple ts Initiator localSock 1000 10000) . const $ do sleep 5.0 -- Wait till some work is done. applyBrake stopProtocols sleep 0.5 checkMultiResults rootDir where config root p = TracerConfig - { networkMagic = 764824073 + { networkMagic = unNetworkMagic $ unI tsNetworkMagic , network = AcceptAt $ LocalSocket p , loRequestNum = Just 1 , ekgRequestFreq = Just 1.0 diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Queue/Tests.hs b/cardano-tracer/test/Cardano/Tracer/Test/Queue/Tests.hs index 217a8271e1d..8248f23287a 100644 --- a/cardano-tracer/test/Cardano/Tracer/Test/Queue/Tests.hs +++ b/cardano-tracer/test/Cardano/Tracer/Test/Queue/Tests.hs @@ -15,17 +15,20 @@ import System.IO import System.Time.Extra (sleep) import Cardano.Tracer.Test.Forwarder +import Cardano.Tracer.Test.TestSetup import Cardano.Tracer.Test.Utils -tests :: TestTree -tests = localOption (QuickCheckTests 1) $ testGroup "Test.Queue" - [ testProperty "check queue" $ propRunInLogsStructure propQueue +tests :: TestSetup Identity -> TestTree +tests ts = localOption (QuickCheckTests 1) $ testGroup "Test.Queue" + [ testProperty "check queue" $ propRunInLogsStructure ts (propQueue ts) ] -propQueue :: FilePath -> FilePath -> IO Property -propQueue rootDir localSock = do +propQueue :: TestSetup Identity -> FilePath -> FilePath -> IO Property +propQueue ts rootDir localSock = do -- Temporarily switch stdout to a temp file. (tmpPath, tmpHdl) <- openTempFile rootDir "cardano-tracer-tmp-stdout" + putStrLn $ "Queue tmp file: " <> tmpPath + -- Queue tmp file: ./tracer/extra-dir-50990537063901/cardano-tracer-tmp-stdout3063636-8 stdDup <- hDuplicate stdout hDuplicateTo tmpHdl stdout hClose tmpHdl @@ -33,7 +36,7 @@ propQueue rootDir localSock = do -- misconfigured and cannot be launched, so the connection cannot be established. -- In this case, the forwarder should collect trace items in its internal -- "flexible queue" and periodically flush them to stdout. - withAsyncBound (launchForwardersSimple Responder localSock connSize disconnSize) . const $ + withAsyncBound (launchForwardersSimple ts Responder localSock connSize disconnSize) . const $ -- Wait till the queue will be redirected to stdout. sleep 7.0 -- Return the normal stdout. diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Restart/Tests.hs b/cardano-tracer/test/Cardano/Tracer/Test/Restart/Tests.hs index f64b378514b..af2d1f0daf3 100644 --- a/cardano-tracer/test/Cardano/Tracer/Test/Restart/Tests.hs +++ b/cardano-tracer/test/Cardano/Tracer/Test/Restart/Tests.hs @@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -Wno-partial-fields -Wno-unused-local-binds -Wno-unused-binds -Wno-unused-matches -Wno-unused-imports #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} module Cardano.Tracer.Test.Restart.Tests ( tests @@ -15,33 +17,41 @@ import System.Directory (removePathForcibly) import System.Directory.Extra (listDirectories) import System.Time.Extra (sleep) +import Ouroboros.Network.Magic (NetworkMagic (..)) + import Cardano.Tracer.Configuration +import Cardano.Tracer.MetaTrace import Cardano.Tracer.Run import Cardano.Tracer.Utils import Cardano.Tracer.Test.Forwarder +import Cardano.Tracer.Test.TestSetup import Cardano.Tracer.Test.Utils -tests :: TestTree -tests = localOption (QuickCheckTests 1) $ testGroup "Test.Restart" - [ testProperty "forwarder" $ propRunInLogsStructure propNetworkForwarder +import Cardano.Logging (Trace (..)) +import qualified System.IO as Sys + +tests :: TestSetup Identity -> TestTree +tests ts = localOption (QuickCheckTests 1) $ testGroup "Test.Restart" + [ testProperty "forwarder" $ propRunInLogsStructure ts (propNetworkForwarder ts) ] -propNetworkForwarder :: FilePath -> FilePath -> IO Property -propNetworkForwarder rootDir localSock = do - let config = mkConfig rootDir localSock +propNetworkForwarder :: TestSetup Identity -> FilePath -> FilePath -> IO Property +propNetworkForwarder ts rootDir localSock = do + let config = mkConfig ts rootDir localSock brake <- initProtocolsBrake dpRequestors <- initDataPointRequestors - propNetwork' rootDir - ( launchForwardersSimple Initiator localSock 1000 10000 - , doRunCardanoTracer config Nothing brake dpRequestors + propNetwork' ts rootDir + ( launchForwardersSimple ts Initiator localSock 1000 10000 + , doRunCardanoTracer config (Just $ rootDir <> "/../state") stderrShowTracer brake dpRequestors ) propNetwork' - :: FilePath + :: TestSetup Identity + -> FilePath -> (IO (), IO ()) -> IO Property -propNetwork' rootDir (fstSide, sndSide) = do +propNetwork' _ rootDir (fstSide, sndSide) = do f <- asyncBound fstSide sleep 1.0 s <- asyncBound sndSide @@ -49,8 +59,8 @@ propNetwork' rootDir (fstSide, sndSide) = do sleep 5.0 -- Check if the root dir contains subdir, which is a proof that interaction -- between sides already occurred. - ifM (doesDirectoryEmpty rootDir) - (false "root dir is empty after the first start") + ifM (isDirectoryEmpty rootDir) + (false $ "root dir is empty after the first start: " <> rootDir) $ do -- Take current subdirs (it corresponds to the connection). subDirs <- listDirectories rootDir @@ -73,18 +83,19 @@ propNetwork' rootDir (fstSide, sndSide) = do _ -> return $ property True mkConfig - :: FilePath + :: TestSetup Identity + -> FilePath -> FilePath -> TracerConfig -mkConfig root p = TracerConfig - { networkMagic = 764824073 +mkConfig TestSetup{..} rootDir p = TracerConfig + { networkMagic = fromIntegral . unNetworkMagic $ unI tsNetworkMagic , network = AcceptAt $ LocalSocket p , loRequestNum = Just 1 , ekgRequestFreq = Just 1.0 , hasEKG = Nothing , hasPrometheus = Nothing , hasRTView = Nothing - , logging = NE.fromList [LoggingParams root FileMode ForMachine] + , logging = NE.fromList [LoggingParams rootDir FileMode ForMachine] , rotation = Nothing , verbosity = Just Minimum } diff --git a/cardano-tracer/test/Cardano/Tracer/Test/TestSetup.hs b/cardano-tracer/test/Cardano/Tracer/Test/TestSetup.hs new file mode 100644 index 00000000000..6eae0520c40 --- /dev/null +++ b/cardano-tracer/test/Cardano/Tracer/Test/TestSetup.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Tracer.Test.TestSetup + ( module Cardano.Tracer.Test.TestSetup + , module Ouroboros.Network.Magic + ) +where + +import Control.Monad (join) +import Data.Functor ((<&>)) +import Data.Functor.Identity +import Data.Maybe +import Data.Monoid +import GHC.Generics (Generic) +import Generic.Data (gmappend) + +import Options.Applicative + +import Ouroboros.Network.Magic (NetworkMagic (..)) + + +data TestSetup a + = TestSetup + { tsTime :: !(a Double) + , tsThreads :: !(a Int) + , tsMessages :: !(a (Maybe Int)) + , tsSockInternal :: !(a FilePath) + , tsSockExternal :: !(a FilePath) + , tsNetworkMagic :: !(a NetworkMagic) + , tsWorkDir :: !(a FilePath) + } deriving (Generic) +instance Semigroup (TestSetup Last) where + (<>) = gmappend + +deriving instance Show (TestSetup Identity) + +parseTestSetup :: Parser (TestSetup Last) +parseTestSetup = + TestSetup + <$> (Last <$> optional (option auto (long "time" <> metavar "SEC"))) + <*> (Last <$> optional (option auto (long "threads" <> metavar "THRDS"))) + <*> (Last <$> optional (option auto (long "messages" <> metavar "MSGS"))) + <*> (Last <$> optional (option auto (long "sock-internal" <> metavar "FILE"))) + <*> (Last <$> optional (option auto (long "sock-external" <> metavar "FILE"))) + <*> (Last <$> optional (option (NetworkMagic <$> auto) + (long "network-magic" <> metavar "INT"))) + <*> (Last <$> optional (option auto (long "workdir" <> metavar "DIR"))) + +mergeTestSetup :: TestSetup Last -> TestSetup Identity +mergeTestSetup TestSetup{..} = + TestSetup + { tsTime = get "Missing tsTime" tsTime + , tsThreads = get "Missing tsThreads" tsThreads + , tsMessages = Identity . join $ getLast tsMessages + , tsSockInternal = get "Missing tsSockInternal" tsSockInternal + , tsSockExternal = get "Missing tsSockExternal" tsSockExternal + , tsNetworkMagic = get "Missing tsNetworkMagic" tsNetworkMagic + , tsWorkDir = get "Missing tsWorkDir" tsWorkDir + } + where + get desc = Identity . fromMaybe (error $ "Missing " <> desc) . getLast + +getTestSetup :: TestSetup Last -> IO (TestSetup Identity) +getTestSetup def = + customExecParser + (prefs showHelpOnEmpty) + (info parseTestSetup mempty) + <&> (def <>) + <&> mergeTestSetup diff --git a/cardano-tracer/test/Cardano/Tracer/Test/Utils.hs b/cardano-tracer/test/Cardano/Tracer/Test/Utils.hs index 5f072ff7b1c..c73df1fcdf0 100644 --- a/cardano-tracer/test/Cardano/Tracer/Test/Utils.hs +++ b/cardano-tracer/test/Cardano/Tracer/Test/Utils.hs @@ -1,44 +1,50 @@ +{-# LANGUAGE RecordWildCards #-} module Cardano.Tracer.Test.Utils - ( doesDirectoryEmpty - , false - , propRunInLogsStructure - , propRunInLogsStructure2 + ( module Cardano.Tracer.Test.Utils + , module Data.Functor.Identity ) where +import Data.Functor.Identity + import System.Directory.Extra (listDirectories) -import System.FilePath ((), (<.>), dropDrive, takeBaseName) -import System.IO.Extra (newTempDir, newTempFile) +import System.FilePath (dropDrive, dropExtension) +import System.IO.Extra (newTempDirWithin) import System.Info.Extra (isMac, isWindows) + import Test.Tasty.QuickCheck +import Cardano.Tracer.Test.TestSetup + +unI :: Identity a -> a +unI (Identity x) = x false :: String -> IO Property false msg = return . counterexample msg $ property False propRunInLogsStructure - :: (FilePath -> FilePath -> IO Property) + :: TestSetup Identity -> (FilePath -> FilePath -> IO Property) -> Property -propRunInLogsStructure testAction = ioProperty $ do - (rootDir, _) <- newTempDir - (localSock, _) <- newTempFile - testAction rootDir (prepareLocalSock localSock) +propRunInLogsStructure TestSetup{..} testAction = ioProperty $ do + (rootDir, _) <- newTempDirWithin (unI tsWorkDir) + testAction rootDir + (prepareLocalSock $ unI tsSockInternal) propRunInLogsStructure2 - :: (FilePath -> FilePath -> FilePath -> IO Property) + :: TestSetup Identity -> (FilePath -> FilePath -> FilePath -> IO Property) -> Property -propRunInLogsStructure2 testAction = ioProperty $ do - (rootDir, _) <- newTempDir - (localSock1, _) <- newTempFile - (localSock2, _) <- newTempFile - testAction rootDir (prepareLocalSock localSock1) (prepareLocalSock localSock2) +propRunInLogsStructure2 TestSetup{..} testAction = ioProperty $ do + (rootDir, _) <- newTempDirWithin (unI tsWorkDir) + testAction rootDir + (prepareLocalSock . replaceExtension "1.sock" $ unI tsSockInternal) + (prepareLocalSock . replaceExtension "2.sock" $ unI tsSockInternal) prepareLocalSock :: FilePath -> FilePath prepareLocalSock localSock - | isWindows = pipeForWindows - | isMac = sockForMac + | isWindows = "\\\\.\\pipe\\build\\" <> dropDrive localSock + | isMac = replaceExtension "pipe" localSock | otherwise = localSock - where - pipeForWindows = "\\\\.\\pipe\\" <> dropDrive localSock - sockForMac = "/tmp" takeBaseName localSock <.> "pipe" -doesDirectoryEmpty :: FilePath -> IO Bool -doesDirectoryEmpty = fmap null . listDirectories +replaceExtension :: String -> FilePath -> FilePath +replaceExtension new f = dropExtension f <> "." <> new + +isDirectoryEmpty :: FilePath -> IO Bool +isDirectoryEmpty = fmap null . listDirectories diff --git a/cardano-tracer/test/cardano-tracer-test-ext.hs b/cardano-tracer/test/cardano-tracer-test-ext.hs new file mode 100644 index 00000000000..f1a1674f721 --- /dev/null +++ b/cardano-tracer/test/cardano-tracer-test-ext.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + +import Control.Concurrent (threadDelay) +import Control.Exception +import Control.Monad.Extra +import Data.Functor ((<&>)) +import Data.Functor.Identity +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.List as L +import Data.Monoid +import qualified System.Directory as Sys +import System.Environment (setEnv, unsetEnv) +import qualified System.IO as Sys +import System.PosixCompat.Files (fileExist) +import qualified System.Process as Sys +import Test.Tasty +import Test.Tasty.QuickCheck + +import Cardano.Logging +import Cardano.Tracer.Test.ForwardingStressTest.Messages +import Cardano.Tracer.Test.ForwardingStressTest.Script +import Cardano.Tracer.Test.ForwardingStressTest.Types +import Cardano.Tracer.Test.Utils +import Ouroboros.Network.Magic (NetworkMagic (..)) +import Ouroboros.Network.NodeToClient (withIOManager) + +main :: IO () +main = do + setEnv "TASTY_NUM_THREADS" "1" -- For sequential running of tests (because of Windows). + + ts' <- getTestSetup + TestSetup + { tsTime = Last $ Just 10.0 + , tsThreads = Last $ Just 5 + , tsMessages = Last Nothing + , tsSockInternal = Last $ Just "tracer.sock" + , tsSockExternal = Last $ Just "tracer.sock" + , tsNetworkMagic = Last $ Just $ NetworkMagic 42 + , tsWorkDir = Last $ Just "./test" + } + + -- 1. Prepare directory hierarchy + tracerRoot <- Sys.canonicalizePath $ unI (tsWorkDir ts') + putStrLn . mconcat $ [ "tsWorkDir ts: ", tracerRoot ] + -- Weird: using path canonicalisation leads to process shutdown failures + whenM (fileExist tracerRoot) $ + Sys.removeDirectoryRecursive tracerRoot + Sys.createDirectoryIfMissing True (tracerRoot <> "/logs") + Sys.setCurrentDirectory tracerRoot + + let ts = ts' { tsWorkDir = Identity tracerRoot + } + putStrLn $ "Test setup: " <> show ts + + -- 2. Actual tests + msgCounterRef <- newIORef 0 + tracerRef <- newIORef Nothing + let tracerGetter = getExternalTracerState ts tracerRef + defaultMain (allTests ts msgCounterRef (tracerGetter <&> snd)) + `catch` (\ (e :: SomeException) -> do + unsetEnv "TASTY_NUM_THREADS" + trState <- readIORef tracerRef + case trState of + Nothing -> pure () + Just (tracerHdl, _) -> + Sys.cleanupProcess (Nothing, Nothing, Nothing, tracerHdl) + throwIO e) + +allTests :: + TestSetup Identity + -> IORef Int + -> IO (Trace IO Message) + -> TestTree +allTests ts msgCounter externalTracerGetter = + testGroup "Tests" + [ localOption (QuickCheckTests 10) $ testGroup "trace-forwarder" + [ testProperty "multi-threaded forwarder stress test" $ + runScriptForwarding ts msgCounter externalTracerGetter + ] + ] + +-- Caution: non-thread-safe! +getExternalTracerState :: + TestSetup Identity + -> IORef (Maybe (Sys.ProcessHandle, Trace IO Message)) + -> IO (Sys.ProcessHandle, Trace IO Message) +getExternalTracerState TestSetup{..} ref = do + state <- readIORef ref + case state of + Just st -> pure st + Nothing -> do + stdTr <- standardTracer + (procHdl, fwdTr) <- setupFwdTracer + tr <- mkCardanoTracer + stdTr fwdTr Nothing + ["Test"] + namesForMessage severityForMessage privacyForMessage + let st = (procHdl, tr) + writeIORef ref $ Just st + pure st + where + setupFwdTracer :: IO (Sys.ProcessHandle, Trace IO FormattedMessage) + setupFwdTracer = do + Sys.writeFile "config.yaml" . L.unlines $ + [ "networkMagic: " <> show (unNetworkMagic $ unI tsNetworkMagic) + , "network:" + , " tag: AcceptAt" + , " contents: \""<> unI tsSockExternal <>"\"" + , "logging:" + , "- logRoot: \"logs\"" + , " logMode: FileMode" + , " logFormat: ForMachine" + ] + externalTracerHdl <- Sys.spawnProcess "cardano-tracer" + [ "--config" , "config.yaml" + , "--state-dir" , unI tsWorkDir <> "/tracer-statedir" + ] + threadDelay 1000000 --wait 1 seconds + res <- Sys.getProcessExitCode externalTracerHdl + case res of + Nothing -> putStrLn "cardano-tracer started.." + Just code -> + error $ "cardano-tracer failed to start with code " <> show code + -- TODO: check if this is the correct way to use withIOManager + (forwardSink, _dpStore) <- withIOManager $ \iomgr -> do + -- For simplicity, we are always 'Initiator', + -- so 'cardano-tracer' is always a 'Responder'. + let tracerSocketMode = Just (unI tsSockExternal, Initiator) + initForwarding iomgr simpleTestConfig (unI tsNetworkMagic) Nothing tracerSocketMode + pure (externalTracerHdl, forwardTracer forwardSink) diff --git a/cardano-tracer/test/cardano-tracer-test.hs b/cardano-tracer/test/cardano-tracer-test.hs index b6df20c46a7..0c17604f18c 100644 --- a/cardano-tracer/test/cardano-tracer-test.hs +++ b/cardano-tracer/test/cardano-tracer-test.hs @@ -1,23 +1,58 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + +import Control.Exception +import Control.Monad.Extra +import Data.Functor.Identity +import Data.Monoid +import qualified System.Directory as Sys import System.Environment (setEnv, unsetEnv) +import System.PosixCompat.Files (fileExist) import Test.Tasty --- WIP: tests are temporarily disabled, till MVP. +import qualified Cardano.Tracer.Test.Logs.Tests as Logs +import qualified Cardano.Tracer.Test.DataPoint.Tests as DataPoint +import qualified Cardano.Tracer.Test.Restart.Tests as Restart +import qualified Cardano.Tracer.Test.Queue.Tests as Queue --- import qualified Cardano.Tracer.Test.Logs.Tests as Logs --- import qualified Cardano.Tracer.Test.DataPoint.Tests as DataPoint --- import qualified Cardano.Tracer.Test.Restart.Tests as Restart --- import qualified Cardano.Tracer.Test.Queue.Tests as Queue +import Cardano.Tracer.Test.TestSetup +import Cardano.Tracer.Test.Utils main :: IO () main = do - setEnv tastyNumThreads "1" -- For sequential running of tests (because of Windows). - defaultMain $ testGroup "cardano-tracer" - [ - -- Logs.tests - -- , DataPoint.tests - -- , Restart.tests - -- , Queue.tests - ] - unsetEnv tastyNumThreads - where - tastyNumThreads = "TASTY_NUM_THREADS" + setEnv "TASTY_NUM_THREADS" "1" -- For sequential running of tests (because of Windows). + + ts' <- getTestSetup + TestSetup + { tsTime = Last $ Just 10.0 + , tsThreads = Last $ Just 5 + , tsMessages = Last Nothing + , tsSockInternal = Last $ Just "tracer.sock" + , tsSockExternal = Last $ Just "tracer-external.sock" + , tsNetworkMagic = Last $ Just $ NetworkMagic 42 + , tsWorkDir = Last $ Just "./cardano-tracer-test" + } + + -- 1. Prepare directory hierarchy + tracerRoot <- Sys.canonicalizePath $ unI (tsWorkDir ts') + putStrLn . mconcat $ [ "tsWorkDir ts: ", tracerRoot ] + -- Weird: using path canonicalisation leads to process shutdown failures + whenM (fileExist tracerRoot) $ + Sys.removeDirectoryRecursive tracerRoot + Sys.createDirectoryIfMissing True (tracerRoot <> "/logs") + Sys.setCurrentDirectory tracerRoot + + let ts = ts' { tsWorkDir = Identity tracerRoot + } + putStrLn $ "Test setup: " <> show ts + + defaultMain + (testGroup "Tests" + [ Logs.tests ts + , DataPoint.tests ts + , Restart.tests ts + , Queue.tests ts + ]) + `catch` (\ (e :: SomeException) -> do + unsetEnv "TASTY_NUM_THREADS" + throwIO e) diff --git a/doc/new-tracing/tracers_doc_generated.md b/doc/new-tracing/tracers_doc_generated.md index 983155c4771..997e0e75157 100644 --- a/doc/new-tracing/tracers_doc_generated.md +++ b/doc/new-tracing/tracers_doc_generated.md @@ -241,7 +241,7 @@ 1. [NodeNotLeader](#forgeloopnodenotleader) 1. [SlotIsImmutable](#forgeloopslotisimmutable) 1. [StartLeadershipCheck](#forgeloopstartleadershipcheck) - 1. [StartLeadershipCheckPlus](#forgeloopstartleadershipcheckplus) + 1. [StartLeadershipCheck](#forgeloopstartleadershipcheck) 1. [Stats](#forgestats) 1. __Mempool__ 1. [AddedTx](#mempooladdedtx) @@ -868,6 +868,7 @@ Backends: `Stdout MachineFormat`, `Forwarder` Filtered by config value: `Notice` +Limiters: Limiter `BlockFetch.Client.CompletedBlockFetch` with frequency `2.0` ### BlockFetch.Client.CompletedFetchBatch @@ -2547,6 +2548,7 @@ Backends: `Stdout MachineFormat`, `Forwarder` Filtered by config value: `Info` +Limiters: Limiter `ChainSync.Client.DownloadedHeader` with frequency `2.0` ### ChainSync.Client.Exception @@ -3580,7 +3582,7 @@ Backends: `Forwarder` Filtered by config value: `Info` -### Forge.Loop.StartLeadershipCheckPlus +### Forge.Loop.StartLeadershipCheck > We adopted the block we produced, we also trace the transactions that were adopted. @@ -9177,7 +9179,6 @@ ChainSync.ServerHeader.Update Dispatched by: Forge.Loop.StartLeadershipCheck -Forge.Loop.StartLeadershipCheckPlus ### Forge.AdoptedOwnBlockSlotLast @@ -9228,7 +9229,7 @@ Forge.Loop.ForgeStateUpdateError Dispatched by: -Forge.Loop.StartLeadershipCheckPlus +Forge.Loop.StartLeadershipCheck ### Forge.ForgedInvalidSlotLast @@ -9350,7 +9351,7 @@ Forge.Stats Dispatched by: -Forge.Loop.StartLeadershipCheckPlus +Forge.Loop.StartLeadershipCheck ### Mempool.MempoolBytes @@ -9640,7 +9641,7 @@ TxSubmission.TxInbound.Collected > _suiSlotsPerKESPeriod_: KES period length, in slots. -Configuration: TraceConfig {tcOptions = fromList [([],[ConfSeverity {severity = Notice},ConfDetail {detail = DNormal},ConfBackend {backends = [Stdout MachineFormat,EKGBackend,Forwarder]}]),(["BlockFetch","Decision"],[ConfSeverity {severity = Info}]),(["BlockFetchClient","CompletedBlockFetch"],[]),(["ChainDB"],[ConfSeverity {severity = Info}]),(["ChainDB","AddBlockEvent","AddBlockValidation","ValidCandidate"],[ConfLimiter {maxFrequency = 2.0}]),(["ChainDB","AddBlockEvent","AddedBlockToQueue"],[ConfLimiter {maxFrequency = 2.0}]),(["ChainDB","AddBlockEvent","AddedBlockToVolatileDB"],[ConfLimiter {maxFrequency = 2.0}]),(["ChainDB","CopyToImmutableDBEvent","CopiedBlockToImmutableDB"],[ConfLimiter {maxFrequency = 2.0}]),(["ChainSync","Client"],[ConfSeverity {severity = Info}]),(["DNSSubscription"],[ConfSeverity {severity = Info}]),(["DiffusionInit"],[ConfSeverity {severity = Info}]),(["ErrorPolicy"],[ConfSeverity {severity = Notice}]),(["Forge"],[ConfSeverity {severity = Info}]),(["IpSubscription"],[ConfSeverity {severity = Info}]),(["LocalErrorPolicy"],[ConfSeverity {severity = Info}]),(["Mempool"],[ConfSeverity {severity = Info}]),(["Net","ConnectionManager","Remote"],[ConfSeverity {severity = Info}]),(["Net","InboundGovernor","Remote"],[ConfSeverity {severity = Info}]),(["Net","Mux","Remote"],[ConfSeverity {severity = Info}]),(["Net","PeerSelection"],[ConfSeverity {severity = Info}]),(["Resources"],[ConfSeverity {severity = Info}])], tcForwarder = TraceOptionForwarder {tofConnQueueSize = 2000, tofDisconnQueueSize = 200000, tofVerbosity = Minimum}, tcNodeName = Nothing, tcPeerFrequency = Just 3000, tcResourceFrequency = Just 4000} +Configuration: TraceConfig {tcOptions = fromList [([],[ConfSeverity {severity = Notice},ConfDetail {detail = DNormal},ConfBackend {backends = [Stdout MachineFormat,EKGBackend,Forwarder]}]),(["BlockFetch","Client","CompletedBlockFetch"],[ConfLimiter {maxFrequency = 2.0}]),(["BlockFetch","Decision"],[ConfSeverity {severity = Info}]),(["ChainDB"],[ConfSeverity {severity = Info}]),(["ChainDB","AddBlockEvent","AddBlockValidation","ValidCandidate"],[ConfLimiter {maxFrequency = 2.0}]),(["ChainDB","AddBlockEvent","AddedBlockToQueue"],[ConfLimiter {maxFrequency = 2.0}]),(["ChainDB","AddBlockEvent","AddedBlockToVolatileDB"],[ConfLimiter {maxFrequency = 2.0}]),(["ChainDB","CopyToImmutableDBEvent","CopiedBlockToImmutableDB"],[ConfLimiter {maxFrequency = 2.0}]),(["ChainSync","Client"],[ConfSeverity {severity = Info}]),(["ChainSync","Client","DownloadedHeader"],[ConfLimiter {maxFrequency = 2.0}]),(["DNSSubscription"],[ConfSeverity {severity = Info}]),(["DiffusionInit"],[ConfSeverity {severity = Info}]),(["ErrorPolicy"],[ConfSeverity {severity = Info}]),(["Forge"],[ConfSeverity {severity = Info}]),(["IpSubscription"],[ConfSeverity {severity = Info}]),(["LocalErrorPolicy"],[ConfSeverity {severity = Info}]),(["Mempool"],[ConfSeverity {severity = Info}]),(["Net","ConnectionManager","Remote"],[ConfSeverity {severity = Info}]),(["Net","InboundGovernor","Remote"],[ConfSeverity {severity = Info}]),(["Net","Mux","Remote"],[ConfSeverity {severity = Info}]),(["Net","PeerSelection"],[ConfSeverity {severity = Info}]),(["Resources"],[ConfSeverity {severity = Info}])], tcForwarder = TraceOptionForwarder {tofConnQueueSize = 2000, tofDisconnQueueSize = 200000, tofVerbosity = Minimum}, tcNodeName = Nothing, tcPeerFrequency = Just 3000, tcResourceFrequency = Just 4000} 670 log messages. -Generated at 2022-08-18 11:45:18.644048874 CEST. \ No newline at end of file +Generated at 2022-11-01 13:30:29.099431258 CET. \ No newline at end of file diff --git a/flake.nix b/flake.nix index 5cf4892c621..66c98224eff 100644 --- a/flake.nix +++ b/flake.nix @@ -461,7 +461,7 @@ overlay = final: prev: { cardanoNodeProject = flake.project.${final.system}; cardanoNodePackages = mkCardanoNodePackages final.cardanoNodeProject; - inherit (final.cardanoNodePackages) cardano-node cardano-cli cardano-submit-api bech32 plutus-example; + inherit (final.cardanoNodePackages) cardano-node cardano-cli cardano-submit-api cardano-tracer bech32 locli plutus-example; # TODO, fix this #db-analyser = ouroboros-network-snapshot.haskellPackages.ouroboros-consensus-cardano.components.exes.db-analyser; diff --git a/nix/haskell.nix b/nix/haskell.nix index cd435d5c10c..2930b83fa27 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -67,11 +67,10 @@ haskell-nix.cabalProject' ({ pkgs in [ ({ pkgs, ... }: { - packages.tx-generator.package.buildable = with pkgs.stdenv.hostPlatform; isUnix && !isMusl; - packages.cardano-tracer.package.buildable = with pkgs.stdenv.hostPlatform; isUnix && !isMusl; + packages.cardano-tracer.package.buildable = with pkgs.stdenv.hostPlatform; lib.mkForce (!isMusl); packages.cardano-node-chairman.components.tests.chairman-tests.buildable = lib.mkForce pkgs.stdenv.hostPlatform.isUnix; packages.plutus-tx-plugin.components.library.platforms = with lib.platforms; [ linux darwin ]; - packages.locli.package.buildable = with pkgs.stdenv.hostPlatform; isUnix && !isMusl; + packages.tx-generator.package.buildable = with pkgs.stdenv.hostPlatform; !isMusl; }) ({ pkgs, ... }: { # Needed for the CLI tests. diff --git a/nix/workbench/profiles/prof1-variants.jq b/nix/workbench/profiles/prof1-variants.jq index 8372e3c34f3..5eef42e9ff4 100644 --- a/nix/workbench/profiles/prof1-variants.jq +++ b/nix/workbench/profiles/prof1-variants.jq @@ -290,6 +290,12 @@ def all_profile_variants: ($compressed_timescale * $current_tps_saturation_value * { scenario: "fixed-loaded" }) as $scenario_fixed_loaded + | + ({ scenario: "idle" + }) as $scenario_idle + | + ({ scenario: "tracer-only" + }) as $scenario_tracer_only | ## ### Definition vocabulary: base variant @@ -369,6 +375,14 @@ def all_profile_variants: { name: "oldtracing" , desc: "Default in legacy tracing mode" } + , $scenario_idle * + { name: "idle" + , desc: "Idle scenario: start nodes & detach from tty; no cluster termination" + } + , $scenario_tracer_only * + { name: "tracer-only" + , desc: "Idle scenario: start only the tracer & detach from tty; no termination" + } ## Fastest -- start-stop , $startstop_base * diff --git a/nix/workbench/scenario.sh b/nix/workbench/scenario.sh index 5c5de9ceaa5..0205e131176 100644 --- a/nix/workbench/scenario.sh +++ b/nix/workbench/scenario.sh @@ -34,6 +34,10 @@ case "$op" in backend start-nodes "$dir" ;; + tracer-only ) + backend start "$dir" + ;; + fixed ) backend start "$dir" diff --git a/trace-dispatcher/bench/trace-dispatcher-bench.hs b/trace-dispatcher/bench/trace-dispatcher-bench.hs index 98dee97d605..7ab9c3a4c24 100644 --- a/trace-dispatcher/bench/trace-dispatcher-bench.hs +++ b/trace-dispatcher/bench/trace-dispatcher-bench.hs @@ -10,7 +10,6 @@ import Cardano.Logging.Test.Tracer import Cardano.Logging.Test.Types import System.Remote.Monitoring (forkServer) -import Debug.Trace -- Can be run with: -- cabal bench trace-dispatcher-bench --benchmark-option='-o benchmark-trace.html' diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs index 8942c0679a4..f3a0ac13a23 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs @@ -72,9 +72,9 @@ mkCardanoTracer' :: forall evt evt1. -> Trace IO FormattedMessage -> Maybe (Trace IO FormattedMessage) -> [Text] - -> (evt -> [Text]) - -> (evt -> SeverityS) - -> (evt -> Privacy) + -> (evt1 -> [Text]) + -> (evt1 -> SeverityS) + -> (evt1 -> Privacy) -> (Trace IO evt1 -> IO (Trace IO evt)) -> IO (Trace IO evt) mkCardanoTracer' trStdout trForward mbTrEkg tracerName namesFor severityFor privacyFor @@ -83,17 +83,17 @@ mkCardanoTracer' trStdout trForward mbTrEkg tracerName namesFor severityFor priv messageTrace' <- withLimitersFromConfig (NT.contramap Message messageTrace) (NT.contramap Limit messageTrace) - messageTrace'' <- hook messageTrace' - messageTrace''' <- addContextAndFilter messageTrace'' + messageTrace'' <- addContextAndFilter messageTrace' let metricsTrace = case mbTrEkg of Nothing -> Trace NT.nullTracer Just ekgTrace -> metricsFormatter "Cardano" ekgTrace let metricsTrace' = filterTrace (\(_,v) -> asMetrics v /= []) metricsTrace - metricsTrace'' <- hook metricsTrace' - pure $ messageTrace''' <> metricsTrace'' + let hookedTrace = messageTrace'' <> metricsTrace' + hook hookedTrace + where - addContextAndFilter :: Trace IO evt -> IO (Trace IO evt) + addContextAndFilter :: Trace IO evt1 -> IO (Trace IO evt1) addContextAndFilter tr = do tr' <- withDetailsFromConfig tr tr'' <- filterSeverityFromConfig tr' diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs index 74a485fd4e0..2a0f19c1c91 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Forward.hs @@ -15,6 +15,7 @@ import Trace.Forward.Utils.TraceObject (ForwardSink, writeToSink) import Cardano.Logging.DocuGenerator import Cardano.Logging.Types + --------------------------------------------------------------------------- forwardTracer :: forall m. (MonadIO m) @@ -34,4 +35,6 @@ forwardTracer forwardSink = pure () output _sink lk (Left c@Document {}) = docIt Forwarder (lk, Left c) - output _sink LoggingContext {} _ = pure () + output _sink LoggingContext {} (Right _) = pure () + -- writeToSink sink lo + output _sink LoggingContext {} _ = pure () \ No newline at end of file diff --git a/trace-dispatcher/src/Cardano/Logging/Types.hs b/trace-dispatcher/src/Cardano/Logging/Types.hs index 378ac0e088c..64824bead2b 100644 --- a/trace-dispatcher/src/Cardano/Logging/Types.hs +++ b/trace-dispatcher/src/Cardano/Logging/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -179,7 +180,7 @@ data SeverityS | Critical -- ^ Severe situations | Alert -- ^ Take immediate action | Emergency -- ^ System is unusable - deriving (Show, Eq, Ord, Bounded, Enum) + deriving (Show, Eq, Ord, Bounded, Enum, Read, AE.ToJSON) -- | Severity for a filter -- Nothing means don't show anything (Silence) diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs b/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs index ccada10f5e4..1265edd0c4a 100644 --- a/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs +++ b/trace-dispatcher/test/Cardano/Logging/Test/Oracles.hs @@ -14,8 +14,6 @@ import Cardano.Logging import Cardano.Logging.Test.Messages import Cardano.Logging.Test.Types -import Debug.Trace - -- | Checks for every message that it appears or does not appear at the right -- backend. Tests filtering and routing to backends @@ -41,7 +39,7 @@ oracleMessages conf ScriptRes {..} = res = isCorrectStdout && isCorrectForwarder && isCorrectEKG in case traceMessage isCorrectStdout isCorrectForwarder isCorrectEKG msg of Nothing -> res - Just str -> trace str res + Just str -> error (str ++ " " ++ show res) traceMessage :: Bool -> Bool -> Bool -> Message -> Maybe String traceMessage isCorrectStdout isCorrectForwarder isCorrectEKG msg | not isCorrectStdout diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Script.hs b/trace-dispatcher/test/Cardano/Logging/Test/Script.hs index 0ae5cdd0d4e..01abfaed0b0 100644 --- a/trace-dispatcher/test/Cardano/Logging/Test/Script.hs +++ b/trace-dispatcher/test/Cardano/Logging/Test/Script.hs @@ -26,8 +26,6 @@ import Cardano.Logging.Test.Messages import Cardano.Logging.Test.Tracer import Cardano.Logging.Test.Types --- import Debug.Trace - -- | Run a script in a single thread and uses the oracle to test for correctness -- The duration of the test is given by time in seconds diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Types.hs b/trace-dispatcher/test/Cardano/Logging/Test/Types.hs index 62695767383..aa377e066f8 100644 --- a/trace-dispatcher/test/Cardano/Logging/Test/Types.hs +++ b/trace-dispatcher/test/Cardano/Logging/Test/Types.hs @@ -39,7 +39,7 @@ instance LogFormatting Message where ] forMachine _dtal (Message3 mid d) = mconcat [ "kind" .= String "Message3" - , "mid" .= String (showT mid) + , "mid" .= String ("<" <> showT mid <> ">") , "workload" .= String (showT d) ] forHuman (Message1 mid i) = diff --git a/trace-dispatcher/test/trace-dispatcher-test.hs b/trace-dispatcher/test/trace-dispatcher-test.hs index 0cb3a014ce1..e7a75c2aef6 100644 --- a/trace-dispatcher/test/trace-dispatcher-test.hs +++ b/trace-dispatcher/test/trace-dispatcher-test.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-imports #-} import Test.Tasty @@ -10,10 +10,10 @@ import Cardano.Logging.Test.Script main :: IO () -main = defaultMain tests +main = defaultMain localTests -tests :: TestTree -tests = localOption (QuickCheckTests 10) $ testGroup "trace-dispatcher" +localTests :: TestTree +localTests = localOption (QuickCheckTests 10) $ testGroup "trace-dispatcher" [ testProperty "single-threaded send tests" $ runScriptSimple 1.0 oracleMessages , testProperty "multi-threaded send tests" $ @@ -22,4 +22,4 @@ tests = localOption (QuickCheckTests 10) $ testGroup "trace-dispatcher" -- runScriptMultithreadedWithReconfig 1.0 oracleMessages , testProperty "reconfiguration stress test" $ runScriptMultithreadedWithConstantReconfig 1.0 (\ _ _ -> property True) - ] + ] \ No newline at end of file diff --git a/trace-dispatcher/trace-dispatcher.cabal b/trace-dispatcher/trace-dispatcher.cabal index f2b934b760f..fcee362c29d 100644 --- a/trace-dispatcher/trace-dispatcher.cabal +++ b/trace-dispatcher/trace-dispatcher.cabal @@ -17,7 +17,7 @@ library Cardano.Logging.Types Cardano.Logging.Trace Cardano.Logging.Configuration - Cardano.Logging.ConfigurationParser + Cardano.Logging.ConfigurationParser Cardano.Logging.DocuGenerator Cardano.Logging.Formatter Cardano.Logging.Forwarding @@ -128,15 +128,20 @@ test-suite trace-dispatcher-test Cardano.Logging.Test.Tracer Cardano.Logging.Test.Messages Cardano.Logging.Test.Script + default-language: Haskell2010 default-extensions: OverloadedStrings build-depends: base >=4.12 && <5 , aeson >= 2.1.0.0 , bytestring + , cardano-prelude , containers , ekg , ekg-core + , generic-data , hostname + , optparse-applicative + , ouroboros-network , text , stm , tasty @@ -150,6 +155,7 @@ test-suite trace-dispatcher-test , yaml , QuickCheck + ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns diff --git a/trace-forward/src/Trace/Forward/Utils/TraceObject.hs b/trace-forward/src/Trace/Forward/Utils/TraceObject.hs index b6058dbf4f4..e0647bbfcfd 100644 --- a/trace-forward/src/Trace/Forward/Utils/TraceObject.hs +++ b/trace-forward/src/Trace/Forward/Utils/TraceObject.hs @@ -14,15 +14,16 @@ module Trace.Forward.Utils.TraceObject import Control.Concurrent.STM (STM, atomically, retry) import Control.Concurrent.STM.TBQueue import Control.Concurrent.STM.TVar -import Control.Monad (unless) +import Control.Monad (unless, (<$!>)) import Control.Monad.Extra (whenM) import qualified Data.List.NonEmpty as NE import Data.Word (Word16) import System.IO import Trace.Forward.Configuration.TraceObject -import Trace.Forward.Protocol.TraceObject.Type import qualified Trace.Forward.Protocol.TraceObject.Forwarder as Forwarder +import Trace.Forward.Protocol.TraceObject.Type + data ForwardSink lo = ForwardSink { forwardQueue :: !(TVar (TBQueue lo)) @@ -58,40 +59,57 @@ writeToSink -> lo -> IO () writeToSink ForwardSink{forwardQueue, disconnectedSize, connectedSize, wasUsed} traceObject = do - q <- readTVarIO forwardQueue - atomically ((,) <$> isFullTBQueue q - <*> isEmptyTBQueue q) >>= \case - (True, _) -> maybeFlushQueueToStdout q - (_, True) -> checkIfSinkWasUsed q - (_, _) -> return () - atomically $ readTVar forwardQueue >>= flip writeTBQueue traceObject + condToFlush <- atomically $ do + q <- readTVar forwardQueue + ((,) <$> isFullTBQueue q + <*> isEmptyTBQueue q) >>= \case + (True, _) -> do + res <- maybeFlushQueueToStdout q + q' <- readTVar forwardQueue + writeTBQueue q' traceObject + pure res + (_, True) -> do + maybeShrinkQueue q + q' <- readTVar forwardQueue + writeTBQueue q' traceObject + pure Nothing + (_, _) -> do + writeTBQueue q traceObject + pure Nothing + case condToFlush of + Nothing -> pure () + Just li -> do + mapM_ print li + hFlush stdout where -- The queue is full, but if it's a small queue, we can switch it -- to a big one and give a chance not to flush items to stdout yet. maybeFlushQueueToStdout q = do - qLen <- atomically $ lengthTBQueue q + qLen <- lengthTBQueue q if fromIntegral qLen == connectedSize - then atomically $ do + then do -- The small queue is full, so we have to switch to a big one and -- then flush collected items from the small queue and store them in -- a big one. - acceptedItems <- flushTBQueue q + + acceptedItems <- -- trace ("growQueue disconnected" ++ show disconnectedSize) $ + flushTBQueue q switchQueue disconnectedSize bigQ <- readTVar forwardQueue mapM_ (writeTBQueue bigQ) acceptedItems + pure Nothing else do -- The big queue is full, we have to flush it to stdout. - atomically (flushTBQueue q) >>= mapM_ print - hFlush stdout - - checkIfSinkWasUsed q = atomically $ - whenM (readTVar wasUsed) $ switchToAnotherQueue q + Just <$!> flushTBQueue q - switchToAnotherQueue q = do - qLen <- lengthTBQueue q - if fromIntegral qLen == disconnectedSize - then switchQueue connectedSize - else switchQueue disconnectedSize + -- if the sink was used and it + maybeShrinkQueue q = do + whenM (readTVar wasUsed) $ do + qLen <- lengthTBQueue q + if fromIntegral qLen == disconnectedSize + then -- trace ("shrinkQueue connected " ++ show connectedSize) $ + switchQueue connectedSize + else pure () switchQueue size = newTBQueue (fromIntegral size) >>= modifyTVar' forwardQueue . const