diff --git a/cabal.project b/cabal.project index 203826e8bed..b8a7399b94a 100644 --- a/cabal.project +++ b/cabal.project @@ -96,3 +96,34 @@ if impl (ghc >= 9.12) constraints: hedgehog-extras == 0.7.0.0 + +-- Points to ouroboros-consensus/leios-prototype +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus + tag: a571776defab2aff8e1e0a9e62646494a1a8af08 + --sha256: sha256-eucib6kUGFbiIM09nNHC+XR+gUSjiAtpKxcuKO/Kl1Q= + subdir: + ouroboros-consensus + ouroboros-consensus-cardano + ouroboros-consensus-diffusion + +-- Points to ouroboros-network/nfrisby/leios-202511-demo +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network.git + tag: 479f0d0d82413162c8444b912394dd74c052831f + --sha256: sha256-Up+Zh3+nHuwlHmpXgH0nNIvQ/yHm/Hxb9ZYQHibrDLc= + subdir: + cardano-ping + monoidal-synchronisation + quickcheck-monoids + network-mux + ouroboros-network + ouroboros-network-api + ouroboros-network-framework + ouroboros-network-mock + ouroboros-network-protocols + ouroboros-network-testing + ntp-client + cardano-client diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index a81e778428a..9844d26cd4f 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -169,6 +169,8 @@ import Paths_cardano_node (version) import Paths_cardano_node (version) +import LeiosDemoTypes (demoNewLeiosDbConnectionIO) + {- HLINT ignore "Fuse concatMap/map" -} {- HLINT ignore "Redundant <$>" -} {- HLINT ignore "Use fewer imports" -} @@ -520,6 +522,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , rnEnableP2P = p2pMode , rnPeerSharing = ncPeerSharing nc , rnGetUseBootstrapPeers = readTVar useBootstrapVar + , rnNewLeiosDbConnection = demoNewLeiosDbConnectionIO } #ifdef UNIX -- initial `SIGHUP` handler, which only rereads the topology file but @@ -618,6 +621,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do , rnEnableP2P = p2pMode , rnPeerSharing = ncPeerSharing nc , rnGetUseBootstrapPeers = pure DontUseBootstrapPeers + , rnNewLeiosDbConnection = demoNewLeiosDbConnectionIO } #ifdef UNIX -- initial `SIGHUP` handler; it only warns that neither updating of diff --git a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs index 42732499ae1..b955d6605ce 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Consistency.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Consistency.hs @@ -101,6 +101,9 @@ import qualified Data.Text as T import qualified Network.Mux as Mux import qualified Network.Socket as Socket +import LeiosDemoTypes (LeiosPoint, LeiosEb, LeiosTx, TraceLeiosKernel, TraceLeiosPeer) +import LeiosDemoOnlyTestFetch (LeiosFetch) +import LeiosDemoOnlyTestNotify (LeiosNotify) -- | Check the configuration in the given file. -- If there is no configuration in the file check the standard configuration @@ -207,7 +210,10 @@ getAllNamespaces = (allNamespaces :: [Namespace (Jumping.TraceEventCsj peer blk)]) dbfNS = map (nsGetTuple . nsReplacePrefix ["Consensus", "DevotedBlockFetch"]) (allNamespaces :: [Namespace (Jumping.TraceEventDbf peer)]) - + leiosKernelNS = map (nsGetTuple . nsReplacePrefix ["Consensus", "LeiosKernel"]) + (allNamespaces :: [Namespace TraceLeiosKernel]) + leiosPeerNS = map (nsGetTuple . nsReplacePrefix ["Consensus", "LeiosPeer"]) + (allNamespaces :: [Namespace (BlockFetch.TraceLabelPeer remotePeer TraceLeiosPeer)]) -- Node to client keepAliveClientNS = map (nsGetTuple . nsReplacePrefix ["Net"]) (allNamespaces :: [Namespace (TraceKeepAliveClient peer)]) @@ -263,6 +269,18 @@ getAllNamespaces = (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk))))]) + leiosNotifyNS = map (nsGetTuple . nsReplacePrefix ["LeiosNotify", "Remote"]) + (allNamespaces :: [Namespace + (BlockFetch.TraceLabelPeer peer + (TraceSendRecv + (LeiosNotify LeiosPoint ())))]) + + leiosFetchNS = map (nsGetTuple . nsReplacePrefix ["LeiosFetch", "Remote"]) + (allNamespaces :: [Namespace + (BlockFetch.TraceLabelPeer peer + (TraceSendRecv + (LeiosFetch LeiosPoint LeiosEb LeiosTx)))]) + -- Diffusion dtMuxNS = map (nsGetTuple . nsReplacePrefix ["Net", "Mux", "Remote"]) @@ -420,6 +438,8 @@ getAllNamespaces = <> gsmNS <> csjNS <> dbfNS + <> leiosKernelNS + <> leiosPeerNS -- NodeToClient <> keepAliveClientNS <> chainSyncNS @@ -432,6 +452,8 @@ getAllNamespaces = <> blockFetchNS <> blockFetchSerialisedNS <> txSubmission2NS + <> leiosNotifyNS + <> leiosFetchNS -- Diffusion <> dtMuxNS <> dtLocalMuxNS diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index da4c82fd265..b9bb87bf7ac 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -362,6 +362,16 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf ["Consensus", "DevotedBlockFetch"] configureTracers configReflection trConfig [consensusDbfTr] + !consensusLeiosKernelTr <- mkCardanoTracer + trBase trForward mbTrEKG + ["Consensus", "LeiosKernel"] + configureTracers configReflection trConfig [consensusLeiosKernelTr] + + !consensusLeiosPeerTr <- mkCardanoTracer + trBase trForward mbTrEKG + ["Consensus", "LeiosPeer"] + configureTracers configReflection trConfig [consensusLeiosPeerTr] + pure $ Consensus.Tracers { Consensus.chainSyncClientTracer = Tracer $ traceWith chainSyncClientTr @@ -408,6 +418,10 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf traceWith consensusCsjTr , Consensus.dbfTracer = Tracer $ traceWith consensusDbfTr + , Consensus.leiosKernelTracer = Tracer $ + traceWith consensusLeiosKernelTr + , Consensus.leiosPeerTracer = Tracer $ + traceWith consensusLeiosPeerTr } mkNodeToClientTracers :: forall blk. @@ -502,6 +516,16 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon ["PeerSharing", "Remote"] configureTracers configReflection trConfig [peerSharingTracer] + !leiosNotifyTracer <- mkCardanoTracer + trBase trForward mbTrEKG + ["LeiosNotify", "Remote"] + configureTracers configReflection trConfig [leiosNotifyTracer] + + !leiosFetchTracer <- mkCardanoTracer + trBase trForward mbTrEKG + ["LeiosFetch", "Remote"] + configureTracers configReflection trConfig [leiosFetchTracer] + pure $ NtN.Tracers { NtN.tChainSyncTracer = Tracer $ traceWith chainSyncTracer @@ -517,6 +541,10 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon traceWith keepAliveTracer , NtN.tPeerSharingTracer = Tracer $ traceWith peerSharingTracer + , NtN.tLeiosNotifyTracer = Tracer $ + traceWith leiosNotifyTracer + , NtN.tLeiosFetchTracer = Tracer $ + traceWith leiosFetchTracer } mkDiffusionTracers diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index 3daec1eb691..1eaa93077a8 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -81,6 +81,7 @@ import Data.Time (NominalDiffTime) import Data.Word (Word32, Word64) import Network.TypedProtocol.Core +import LeiosDemoTypes (TraceLeiosKernel, TraceLeiosPeer, traceLeiosKernelToObject, traceLeiosPeerToObject) instance (LogFormatting adr, Show adr) => LogFormatting (ConnectionId adr) where forMachine _dtal (ConnectionId local' remote) = @@ -2267,3 +2268,25 @@ instance ( StandardHash blk ] forHuman = showT + +----- + +instance LogFormatting TraceLeiosKernel where + forHuman = showT + forMachine _dtal = traceLeiosKernelToObject + +instance MetaTrace TraceLeiosKernel where + namespaceFor _ = Namespace [] [] + severityFor _ _ = Just Debug + documentFor _ = Nothing + allNamespaces = [ Namespace [] [] ] + +instance LogFormatting TraceLeiosPeer where + forHuman = showT + forMachine _dtal = traceLeiosPeerToObject + +instance MetaTrace TraceLeiosPeer where + namespaceFor _ = Namespace [] [] + severityFor _ _ = Just Debug + documentFor _ = Nothing + allNamespaces = [ Namespace [] [] ] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs index a504b19c4a9..e4f9b46d036 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs @@ -19,71 +19,75 @@ import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LSQ import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Type as LTM import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS -import Data.Aeson (Value (String), (.=)) +import Control.Monad.Class.MonadTime.SI (Time (..)) +import Data.Aeson (Value (String), (.=), (.?=)) import Data.Text (Text, pack) import qualified Network.TypedProtocol.Codec as Simple import qualified Network.TypedProtocol.Stateful.Codec as Stateful {-# ANN module ("HLint: ignore Redundant bracket" :: Text) #-} +jsonTime :: Time -> Double +jsonTime (Time x) = realToFrac x + instance LogFormatting (Simple.AnyMessage ps) => LogFormatting (Simple.TraceSendRecv ps) where - forMachine dtal (Simple.TraceSendMsg m) = mconcat - [ "kind" .= String "Send" , "msg" .= forMachine dtal m ] - forMachine dtal (Simple.TraceRecvMsg m) = mconcat - [ "kind" .= String "Recv" , "msg" .= forMachine dtal m ] + forMachine dtal (Simple.TraceSendMsg tm m) = mconcat + [ "kind" .= String "Send" , "msg" .= forMachine dtal m, "mux_at" .= jsonTime tm ] + forMachine dtal (Simple.TraceRecvMsg mbTm m) = mconcat + [ "kind" .= String "Recv" , "msg" .= forMachine dtal m, "mux_at" .?= fmap jsonTime mbTm ] - forHuman (Simple.TraceSendMsg m) = "Send: " <> forHumanOrMachine m - forHuman (Simple.TraceRecvMsg m) = "Receive: " <> forHumanOrMachine m + forHuman (Simple.TraceSendMsg _tm m) = "Send: " <> forHumanOrMachine m + forHuman (Simple.TraceRecvMsg _mbTm m) = "Receive: " <> forHumanOrMachine m - asMetrics (Simple.TraceSendMsg m) = asMetrics m - asMetrics (Simple.TraceRecvMsg m) = asMetrics m + asMetrics (Simple.TraceSendMsg _tm m) = asMetrics m + asMetrics (Simple.TraceRecvMsg _mbTm m) = asMetrics m instance LogFormatting (Stateful.AnyMessage ps f) => LogFormatting (Stateful.TraceSendRecv ps f) where - forMachine dtal (Stateful.TraceSendMsg m) = mconcat - [ "kind" .= String "Send" , "msg" .= forMachine dtal m ] - forMachine dtal (Stateful.TraceRecvMsg m) = mconcat - [ "kind" .= String "Recv" , "msg" .= forMachine dtal m ] + forMachine dtal (Stateful.TraceSendMsg tm m) = mconcat + [ "kind" .= String "Send" , "msg" .= forMachine dtal m, "mux_at" .= jsonTime tm ] + forMachine dtal (Stateful.TraceRecvMsg mbTm m) = mconcat + [ "kind" .= String "Recv" , "msg" .= forMachine dtal m, "mux_at" .?= fmap jsonTime mbTm ] - forHuman (Stateful.TraceSendMsg m) = "Send: " <> forHumanOrMachine m - forHuman (Stateful.TraceRecvMsg m) = "Receive: " <> forHumanOrMachine m + forHuman (Stateful.TraceSendMsg _tm m) = "Send: " <> forHumanOrMachine m + forHuman (Stateful.TraceRecvMsg _mbTm m) = "Receive: " <> forHumanOrMachine m - asMetrics (Stateful.TraceSendMsg m) = asMetrics m - asMetrics (Stateful.TraceRecvMsg m) = asMetrics m + asMetrics (Stateful.TraceSendMsg _tm m) = asMetrics m + asMetrics (Stateful.TraceRecvMsg _mbTm m) = asMetrics m instance MetaTrace (Simple.AnyMessage ps) => MetaTrace (Simple.TraceSendRecv ps) where - namespaceFor (Simple.TraceSendMsg msg) = + namespaceFor (Simple.TraceSendMsg _tm msg) = nsPrependInner "Send" (namespaceFor msg) - namespaceFor (Simple.TraceRecvMsg msg) = + namespaceFor (Simple.TraceRecvMsg _mbTm msg) = nsPrependInner "Receive" (namespaceFor msg) - severityFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg msg)) = + severityFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg _tm msg)) = severityFor (Namespace out tl) (Just msg) severityFor (Namespace out ("Send" : tl)) Nothing = severityFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing - severityFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg msg)) = + severityFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg _tm msg)) = severityFor (Namespace out tl) (Just msg) severityFor (Namespace out ("Receive" : tl)) Nothing = severityFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing severityFor _ _ = Nothing - privacyFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg msg)) = + privacyFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg _tm msg)) = privacyFor (Namespace out tl) (Just msg) privacyFor (Namespace out ("Send" : tl)) Nothing = privacyFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing - privacyFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg msg)) = + privacyFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg _tm msg)) = privacyFor (Namespace out tl) (Just msg) privacyFor (Namespace out ("Receive" : tl)) Nothing = privacyFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing privacyFor _ _ = Nothing - detailsFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg msg)) = + detailsFor (Namespace out ("Send" : tl)) (Just (Simple.TraceSendMsg _tm msg)) = detailsFor (Namespace out tl) (Just msg) detailsFor (Namespace out ("Send" : tl)) Nothing = detailsFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing - detailsFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg msg)) = + detailsFor (Namespace out ("Receive" : tl)) (Just (Simple.TraceSendMsg _tm msg)) = detailsFor (Namespace out tl) (Just msg) detailsFor (Namespace out ("Receive" : tl)) Nothing = detailsFor (Namespace out tl :: Namespace (Simple.AnyMessage ps)) Nothing @@ -107,36 +111,36 @@ instance MetaTrace (Simple.AnyMessage ps) => instance MetaTrace (Stateful.AnyMessage ps f) => MetaTrace (Stateful.TraceSendRecv ps f) where - namespaceFor (Stateful.TraceSendMsg msg) = + namespaceFor (Stateful.TraceSendMsg _tm msg) = nsPrependInner "Send" (namespaceFor msg) - namespaceFor (Stateful.TraceRecvMsg msg) = + namespaceFor (Stateful.TraceRecvMsg _mbTm msg) = nsPrependInner "Receive" (namespaceFor msg) - severityFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg msg)) = + severityFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg _tm msg)) = severityFor (Namespace out tl) (Just msg) severityFor (Namespace out ("Send" : tl)) Nothing = severityFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing - severityFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) = + severityFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg _tm msg)) = severityFor (Namespace out tl) (Just msg) severityFor (Namespace out ("Receive" : tl)) Nothing = severityFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing severityFor _ _ = Nothing - privacyFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg msg)) = + privacyFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg _tm msg)) = privacyFor (Namespace out tl) (Just msg) privacyFor (Namespace out ("Send" : tl)) Nothing = privacyFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing - privacyFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) = + privacyFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg _tm msg)) = privacyFor (Namespace out tl) (Just msg) privacyFor (Namespace out ("Receive" : tl)) Nothing = privacyFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing privacyFor _ _ = Nothing - detailsFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg msg)) = + detailsFor (Namespace out ("Send" : tl)) (Just (Stateful.TraceSendMsg _tm msg)) = detailsFor (Namespace out tl) (Just msg) detailsFor (Namespace out ("Send" : tl)) Nothing = detailsFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing - detailsFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) = + detailsFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg _tm msg)) = detailsFor (Namespace out tl) (Just msg) detailsFor (Namespace out ("Receive" : tl)) Nothing = detailsFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs index 59adf4bb7b4..ccddf7ad479 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs @@ -23,18 +23,23 @@ import Ouroboros.Network.Block (Point, Serialised (..), blockHash) import Ouroboros.Network.DeltaQ (GSV (..), PeerGSV (..)) import Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..)) import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch (..), Message (..)) -import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as STX import qualified Ouroboros.Network.Protocol.KeepAlive.Type as KA import qualified Ouroboros.Network.Protocol.PeerSharing.Type as PS +import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as STX import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) import Control.Monad.Class.MonadTime.SI (Time (..)) import Data.Aeson (ToJSON (..), Value (String), (.=)) import Data.Proxy (Proxy (..)) -import Data.Time (DiffTime) import Data.Text (pack) +import Data.Time (DiffTime) import Network.TypedProtocol.Codec (AnyMessage (AnyMessageAndAgency)) +import qualified LeiosDemoOnlyTestFetch as LF +import qualified LeiosDemoOnlyTestNotify as LN +import LeiosDemoTypes (EbHash (..), LeiosEb, LeiosPoint (..), LeiosTx, + messageLeiosFetchToObject, prettyEbHash) + -------------------------------------------------------------------------------- -- BlockFetch Tracer -------------------------------------------------------------------------------- @@ -466,3 +471,81 @@ instance MetaTrace (TraceKeepAliveClient remotePeer) where documentFor _ = Just "" allNamespaces = [Namespace [] ["KeepAliveClient"]] + +----- + +instance ToJSON EbHash where toJSON = toJSON . prettyEbHash + +instance LogFormatting (AnyMessage (LN.LeiosNotify LeiosPoint ())) where + forHuman = showT + + forMachine _dtal (AnyMessageAndAgency _stok msg) = case msg of + + LN.MsgLeiosNotificationRequestNext -> + mconcat [ "kind" .= String "MsgLeiosNotificationRequestNext" + ] + + LN.MsgLeiosBlockAnnouncement () -> + mconcat [ "kind" .= String "MsgLeiosBlockAnnouncement" + ] + LN.MsgLeiosBlockOffer (MkLeiosPoint ebSlot ebHash) ebBytesSize -> + mconcat [ "kind" .= String "MsgLeiosBlockOffer" + , "ebSlot" .= ebSlot + , "ebHash" .= ebHash + , "ebBytesSize" .= ebBytesSize + ] + LN.MsgLeiosBlockTxsOffer (MkLeiosPoint ebSlot ebHash) -> + mconcat [ "kind" .= String "MsgLeiosBlockTxsOffer" + , "ebSlot" .= ebSlot + , "ebHash" .= ebHash + ] + + LN.MsgDone -> + mconcat [ "kind" .= String "MsgDone" + ] + +instance LogFormatting (AnyMessage (LF.LeiosFetch LeiosPoint LeiosEb LeiosTx)) where + forHuman = showT + + forMachine _dtal (AnyMessageAndAgency _stok msg) = + messageLeiosFetchToObject msg + +instance MetaTrace (AnyMessage (LN.LeiosNotify LeiosPoint ())) where + namespaceFor (AnyMessageAndAgency _stok msg) = case msg of + LN.MsgLeiosNotificationRequestNext {} -> Namespace [] ["RequestNext"] + LN.MsgLeiosBlockAnnouncement {} -> Namespace [] ["BlockAnnouncement"] + LN.MsgLeiosBlockOffer {} -> Namespace [] ["BlockOffer"] + LN.MsgLeiosBlockTxsOffer {} -> Namespace [] ["BlockTxsOffer"] + LN.MsgDone -> Namespace [] ["Done"] + + severityFor _ _ = Just Debug + + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["RequestNext"] + , Namespace [] ["BlockAnnouncement"] + , Namespace [] ["BlockOffer"] + , Namespace [] ["BlockTxsOffer"] + , Namespace [] ["Done"] + ] + +instance MetaTrace (AnyMessage (LF.LeiosFetch LeiosPoint LeiosEb LeiosTx)) where + namespaceFor (AnyMessageAndAgency _stok msg) = case msg of + LF.MsgLeiosBlockRequest {} -> Namespace [] ["BlockRequest"] + LF.MsgLeiosBlock {} -> Namespace [] ["Block"] + LF.MsgLeiosBlockTxsRequest {} -> Namespace [] ["BlockTxsRequest"] + LF.MsgLeiosBlockTxs {} -> Namespace [] ["BlockTxs"] + LF.MsgDone -> Namespace [] ["Done"] + + severityFor _ _ = Just Debug + + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["BlockRequest"] + , Namespace [] ["Block"] + , Namespace [] ["BlockTxsRequest"] + , Namespace [] ["BlockTxs"] + , Namespace [] ["Done"] + ] diff --git a/cardano-node/src/Cardano/Tracing/Config.hs b/cardano-node/src/Cardano/Tracing/Config.hs index b71e90f52aa..158c0a498d6 100644 --- a/cardano-node/src/Cardano/Tracing/Config.hs +++ b/cardano-node/src/Cardano/Tracing/Config.hs @@ -72,6 +72,8 @@ module Cardano.Tracing.Config , TraceTxSubmission2Protocol , TraceKeepAliveProtocol , TracePeerSharingProtocol + , TraceLeiosNotifyProtocol + , TraceLeiosFetchProtocol , proxyName ) where @@ -180,9 +182,13 @@ type TraceTxSubmissionProtocol = ("TraceTxSubmissionProtocol" :: Symbol) type TraceTxSubmission2Protocol = ("TraceTxSubmission2Protocol" :: Symbol) type TraceKeepAliveProtocol = ("TraceKeepAliveProtocol" :: Symbol) type TracePeerSharingProtocol = ("TracePeerSharingProtocol" :: Symbol) +type TraceLeiosNotifyProtocol = ("TraceLeiosNotifyProtocol" :: Symbol) +type TraceLeiosFetchProtocol = ("TraceLeiosFetchProtocol" :: Symbol) type TraceGsm = ("TraceGsm" :: Symbol) type TraceCsj = ("TraceCsj" :: Symbol) type TraceDevotedBlockFetch = ("TraceDevotedBlockFetch" :: Symbol) +type TraceLeiosKernel = ("TraceLeiosKernel" :: Symbol) +type TraceLeiosPeer = ("TraceLeiosPeer" :: Symbol) newtype OnOff (name :: Symbol) = OnOff { isOn :: Bool } deriving (Eq, Show) @@ -256,9 +262,13 @@ data TraceSelection , traceTxSubmission2Protocol :: OnOff TraceTxSubmission2Protocol , traceKeepAliveProtocol :: OnOff TraceKeepAliveProtocol , tracePeerSharingProtocol :: OnOff TracePeerSharingProtocol + , traceLeiosNotifyProtocol :: OnOff TraceLeiosNotifyProtocol + , traceLeiosFetchProtocol :: OnOff TraceLeiosFetchProtocol , traceGsm :: OnOff TraceGsm , traceCsj :: OnOff TraceCsj , traceDevotedBlockFetch :: OnOff TraceDevotedBlockFetch + , traceLeiosKernel :: OnOff TraceLeiosKernel + , traceLeiosPeer :: OnOff TraceLeiosPeer } deriving (Eq, Show) @@ -326,9 +336,13 @@ data PartialTraceSelection , pTraceTxSubmission2Protocol :: Last (OnOff TraceTxSubmission2Protocol) , pTraceKeepAliveProtocol :: Last (OnOff TraceKeepAliveProtocol) , pTracePeerSharingProtocol :: Last (OnOff TracePeerSharingProtocol) + , pTraceLeiosNotifyProtocol :: Last (OnOff TraceLeiosNotifyProtocol) + , pTraceLeiosFetchProtocol :: Last (OnOff TraceLeiosFetchProtocol) , pTraceGsm :: Last (OnOff TraceGsm) , pTraceCsj :: Last (OnOff TraceCsj) , pTraceDevotedBlockFetch :: Last (OnOff TraceDevotedBlockFetch) + , pTraceLeiosKernel :: Last (OnOff TraceLeiosKernel) + , pTraceLeiosPeer :: Last (OnOff TraceLeiosPeer) } deriving (Eq, Generic, Show) @@ -397,9 +411,13 @@ instance FromJSON PartialTraceSelection where <*> parseTracer (Proxy @TraceTxSubmission2Protocol) v <*> parseTracer (Proxy @TraceKeepAliveProtocol) v <*> parseTracer (Proxy @TracePeerSharingProtocol) v + <*> parseTracer (Proxy @TraceLeiosNotifyProtocol) v + <*> parseTracer (Proxy @TraceLeiosFetchProtocol) v <*> parseTracer (Proxy @TraceGsm) v <*> parseTracer (Proxy @TraceCsj) v <*> parseTracer (Proxy @TraceDevotedBlockFetch) v + <*> parseTracer (Proxy @TraceLeiosKernel) v + <*> parseTracer (Proxy @TraceLeiosPeer) v defaultPartialTraceConfiguration :: PartialTraceSelection @@ -465,9 +483,13 @@ defaultPartialTraceConfiguration = , pTraceTxSubmission2Protocol = pure $ OnOff False , pTraceKeepAliveProtocol = pure $ OnOff False , pTracePeerSharingProtocol = pure $ OnOff False + , pTraceLeiosNotifyProtocol = pure $ OnOff False + , pTraceLeiosFetchProtocol = pure $ OnOff False , pTraceGsm = pure $ OnOff True , pTraceCsj = pure $ OnOff True , pTraceDevotedBlockFetch = pure $ OnOff True + , pTraceLeiosKernel = pure $ OnOff True + , pTraceLeiosPeer = pure $ OnOff True } @@ -535,9 +557,13 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio traceTxSubmission2Protocol <- proxyLastToEither (Proxy @TraceTxSubmission2Protocol) pTraceTxSubmission2Protocol traceKeepAliveProtocol <- proxyLastToEither (Proxy @TraceKeepAliveProtocol) pTraceKeepAliveProtocol tracePeerSharingProtocol <- proxyLastToEither (Proxy @TracePeerSharingProtocol) pTracePeerSharingProtocol + traceLeiosNotifyProtocol <- proxyLastToEither (Proxy @TraceLeiosNotifyProtocol) pTraceLeiosNotifyProtocol + traceLeiosFetchProtocol <- proxyLastToEither (Proxy @TraceLeiosFetchProtocol) pTraceLeiosFetchProtocol traceGsm <- proxyLastToEither (Proxy @TraceGsm) pTraceGsm traceCsj <- proxyLastToEither (Proxy @TraceCsj) pTraceCsj traceDevotedBlockFetch <- proxyLastToEither (Proxy @TraceDevotedBlockFetch) pTraceDevotedBlockFetch + traceLeiosKernel <- proxyLastToEither (Proxy @TraceLeiosKernel) pTraceLeiosKernel + traceLeiosPeer <- proxyLastToEither (Proxy @TraceLeiosPeer) pTraceLeiosPeer Right $ TraceDispatcher $ TraceSelection { traceVerbosity = traceVerbosity , traceAcceptPolicy = traceAcceptPolicy @@ -598,9 +624,13 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio , traceTxSubmission2Protocol = traceTxSubmission2Protocol , traceKeepAliveProtocol = traceKeepAliveProtocol , tracePeerSharingProtocol = tracePeerSharingProtocol + , traceLeiosNotifyProtocol = traceLeiosNotifyProtocol + , traceLeiosFetchProtocol = traceLeiosFetchProtocol , traceGsm = traceGsm , traceCsj = traceCsj , traceDevotedBlockFetch = traceDevotedBlockFetch + , traceLeiosKernel = traceLeiosKernel + , traceLeiosPeer = traceLeiosPeer } partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelection))) = do @@ -665,9 +695,13 @@ partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelectio traceTxSubmission2Protocol <- proxyLastToEither (Proxy @TraceTxSubmission2Protocol) pTraceTxSubmission2Protocol traceKeepAliveProtocol <- proxyLastToEither (Proxy @TraceKeepAliveProtocol) pTraceKeepAliveProtocol tracePeerSharingProtocol <- proxyLastToEither (Proxy @TracePeerSharingProtocol) pTracePeerSharingProtocol + traceLeiosNotifyProtocol <- proxyLastToEither (Proxy @TraceLeiosNotifyProtocol) pTraceLeiosNotifyProtocol + traceLeiosFetchProtocol <- proxyLastToEither (Proxy @TraceLeiosFetchProtocol) pTraceLeiosFetchProtocol traceGsm <- proxyLastToEither (Proxy @TraceGsm) pTraceGsm traceCsj <- proxyLastToEither (Proxy @TraceCsj) pTraceCsj traceDevotedBlockFetch <- proxyLastToEither (Proxy @TraceDevotedBlockFetch) pTraceDevotedBlockFetch + traceLeiosKernel <- proxyLastToEither (Proxy @TraceLeiosKernel) pTraceLeiosKernel + traceLeiosPeer <- proxyLastToEither (Proxy @TraceLeiosPeer) pTraceLeiosPeer Right $ TracingOnLegacy $ TraceSelection { traceVerbosity = traceVerbosity , traceAcceptPolicy = traceAcceptPolicy @@ -728,9 +762,13 @@ partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelectio , traceTxSubmission2Protocol = traceTxSubmission2Protocol , traceKeepAliveProtocol = traceKeepAliveProtocol , tracePeerSharingProtocol = tracePeerSharingProtocol + , traceLeiosNotifyProtocol = traceLeiosNotifyProtocol + , traceLeiosFetchProtocol = traceLeiosFetchProtocol , traceGsm = traceGsm , traceCsj = traceCsj , traceDevotedBlockFetch = traceDevotedBlockFetch + , traceLeiosKernel = traceLeiosKernel + , traceLeiosPeer = traceLeiosPeer } proxyLastToEither :: KnownSymbol name => Proxy name -> Last (OnOff name) -> Either Text (OnOff name) diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs index 5e3398c9174..35b4dda95e3 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -27,20 +27,20 @@ module Cardano.Tracing.OrphanInstances.Network , FetchDecisionToJSON (..) ) where +import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) +import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) +import Cardano.Network.Types (LedgerStateJudgement (..)) import Cardano.Node.Queries (ConvertTxId) import Cardano.Tracing.OrphanInstances.Common import Cardano.Tracing.Render +import qualified Ouroboros.Cardano.Network.PeerSelection.Governor.PeerSelectionState as Cardano +import qualified Ouroboros.Cardano.Network.PeerSelection.Governor.Types as Cardano +import qualified Ouroboros.Cardano.Network.PublicRootPeers as Cardano.PublicRootPeers import Ouroboros.Consensus.Block (ConvertRawHash (..), Header, getHeader) import Ouroboros.Consensus.Ledger.Query (BlockQuery, Query) import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, GenTxId, HasTxs (..), TxId, txId) import Ouroboros.Consensus.Node.Run (RunNode, estimateBlockSize) -import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers(..)) -import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable(..)) -import Cardano.Network.Types (LedgerStateJudgement(..)) -import qualified Ouroboros.Cardano.Network.PeerSelection.Governor.PeerSelectionState as Cardano -import qualified Ouroboros.Cardano.Network.PeerSelection.Governor.Types as Cardano -import qualified Ouroboros.Cardano.Network.PublicRootPeers as Cardano.PublicRootPeers import qualified Ouroboros.Network.AnchoredFragment as AF import qualified Ouroboros.Network.AnchoredSeq as AS import Ouroboros.Network.Block @@ -51,15 +51,14 @@ import Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecl import qualified Ouroboros.Network.BlockFetch.Decision.Trace as BlockFetch import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..)) import Ouroboros.Network.ConnectionId (ConnectionId (..)) -import Ouroboros.Network.ConnectionManager.Core as ConnMgr (Trace (..)) import Ouroboros.Network.ConnectionManager.ConnMap (ConnMap (..), LocalAddr (..)) +import Ouroboros.Network.ConnectionManager.Core as ConnMgr (Trace (..)) import Ouroboros.Network.ConnectionManager.State (ConnStateId (..)) import Ouroboros.Network.ConnectionManager.Types (AbstractState (..), - ConnectionManagerCounters (..), - OperationResult (..)) + ConnectionManagerCounters (..), OperationResult (..)) import qualified Ouroboros.Network.ConnectionManager.Types as ConnMgr -import qualified Ouroboros.Network.Diffusion.Common as Diffusion import Ouroboros.Network.DeltaQ (GSV (..), PeerGSV (..)) +import qualified Ouroboros.Network.Diffusion.Common as Diffusion import Ouroboros.Network.Driver.Limits (ProtocolLimitFailure (..)) import qualified Ouroboros.Network.Driver.Stateful as Stateful import Ouroboros.Network.ExitPolicy (RepromoteDelay (..)) @@ -73,10 +72,10 @@ import qualified Ouroboros.Network.NodeToClient as NtC import Ouroboros.Network.NodeToNode (ErrorPolicyTrace (..), NodeToNodeVersion (..), NodeToNodeVersionData (..), RemoteAddress, TraceSendRecv (..), WithAddr (..)) import qualified Ouroboros.Network.NodeToNode as NtN -import Ouroboros.Network.PeerSelection.Governor (AssociationMode (..), DebugPeerSelection (..), - DebugPeerSelectionState (..), PeerSelectionCounters, PeerSelectionState (..), - PeerSelectionTargets (..), PeerSelectionView (..), TracePeerSelection (..), - peerSelectionStateToCounters) +import Ouroboros.Network.PeerSelection.Governor (AssociationMode (..), + DebugPeerSelection (..), DebugPeerSelectionState (..), PeerSelectionCounters, + PeerSelectionState (..), PeerSelectionTargets (..), PeerSelectionView (..), + TracePeerSelection (..), peerSelectionStateToCounters) import Ouroboros.Network.PeerSelection.LedgerPeers import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.PeerSelection.PeerStateActions (PeerSelectionActionsTrace (..)) @@ -89,7 +88,7 @@ import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers import Ouroboros.Network.PeerSelection.State.KnownPeers (KnownPeerInfo (..)) import qualified Ouroboros.Network.PeerSelection.State.KnownPeers as KnownPeers import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), - LocalRootPeers, WarmValency (..), LocalRootConfig (..)) + LocalRootConfig (..), LocalRootPeers, WarmValency (..)) import qualified Ouroboros.Network.PeerSelection.State.LocalRootPeers as LocalRootPeers import Ouroboros.Network.PeerSelection.Types (PeerStatus (..)) import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch, Message (..)) @@ -140,7 +139,11 @@ import Network.Socket (SockAddr (..)) import Network.TypedProtocol.Codec (AnyMessage (AnyMessageAndAgency)) import qualified Network.TypedProtocol.Stateful.Codec as Stateful -{- HLINT ignore "Use record patterns" -} +import qualified LeiosDemoOnlyTestFetch as LF +import qualified LeiosDemoOnlyTestNotify as LN +import LeiosDemoTypes (EbHash (..), LeiosEb, LeiosPoint (..), LeiosTx, TraceLeiosKernel, + TraceLeiosPeer, messageLeiosFetchToObject, prettyEbHash, + traceLeiosKernelToObject, traceLeiosPeerToObject) -- -- * instances of @HasPrivacyAnnotation@ and @HasSeverityAnnotation@ @@ -1437,19 +1440,21 @@ instance (ToJSON peer, ConvertRawHash header) instance ToObject (AnyMessage ps) => ToObject (TraceSendRecv ps) where - toObject verb (TraceSendMsg m) = mconcat - [ "kind" .= String "Send" , "msg" .= toObject verb m ] - toObject verb (TraceRecvMsg m) = mconcat - [ "kind" .= String "Recv" , "msg" .= toObject verb m ] + toObject verb (TraceSendMsg tm m) = mconcat + [ "kind" .= String "Send" , "msg" .= toObject verb m, "mux_at" .= jsonTime tm ] + toObject verb (TraceRecvMsg mbTm m) = mconcat + [ "kind" .= String "Recv" , "msg" .= toObject verb m, "mux_at" Aeson..?= fmap jsonTime mbTm ] instance ToObject (Stateful.AnyMessage ps f) => ToObject (Stateful.TraceSendRecv ps f) where - toObject verb (Stateful.TraceSendMsg m) = mconcat - [ "kind" .= String "Send" , "msg" .= toObject verb m ] - toObject verb (Stateful.TraceRecvMsg m) = mconcat - [ "kind" .= String "Recv" , "msg" .= toObject verb m ] + toObject verb (Stateful.TraceSendMsg tm m) = mconcat + [ "kind" .= String "Send" , "msg" .= toObject verb m, "mux_at" .= jsonTime tm ] + toObject verb (Stateful.TraceRecvMsg mbTm m) = mconcat + [ "kind" .= String "Recv" , "msg" .= toObject verb m, "mux_at" Aeson..?= fmap jsonTime mbTm ] +jsonTime :: Time -> Double +jsonTime (Time x) = realToFrac x instance ToObject (TraceTxSubmissionInbound txid tx) where toObject _verb (TraceTxSubmissionCollected count) = @@ -2871,3 +2876,72 @@ instance FromJSON PeerTrustable where instance ToJSON PeerTrustable where toJSON IsTrustable = Bool True toJSON IsNotTrustable = Bool False + +----- + +instance ToJSON EbHash where toJSON = toJSON . prettyEbHash + +instance ToObject peer + => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (LN.LeiosNotify LeiosPoint ()))) where + trTransformer = trStructured + +instance ToObject (AnyMessage (LN.LeiosNotify LeiosPoint ())) where + toObject _verb (AnyMessageAndAgency _stok msg) = case msg of + + LN.MsgLeiosNotificationRequestNext -> + mconcat [ "kind" .= String "MsgLeiosNotificationRequestNext" + ] + + LN.MsgLeiosBlockAnnouncement () -> + mconcat [ "kind" .= String "MsgLeiosBlockAnnouncement" + ] + LN.MsgLeiosBlockOffer (MkLeiosPoint ebSlot ebHash) ebBytesSize -> + mconcat [ "kind" .= String "MsgLeiosBlockOffer" + , "ebSlot" .= ebSlot + , "ebHash" .= ebHash + , "ebBytesSize" .= ebBytesSize + ] + LN.MsgLeiosBlockTxsOffer (MkLeiosPoint ebSlot ebHash) -> + mconcat [ "kind" .= String "MsgLeiosBlockTxsOffer" + , "ebSlot" .= ebSlot + , "ebHash" .= ebHash + ] + + LN.MsgDone -> + mconcat [ "kind" .= String "MsgDone" + ] + +-- where +-- agency :: Aeson.Object +-- agency = "agency" .= show stok + +instance ToObject peer + => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (LF.LeiosFetch LeiosPoint LeiosEb LeiosTx))) where + trTransformer = trStructured + +instance ToObject (AnyMessage (LF.LeiosFetch LeiosPoint LeiosEb LeiosTx)) where + toObject _verb (AnyMessageAndAgency _stok msg) = + messageLeiosFetchToObject msg + +instance Transformable Text IO TraceLeiosKernel where + trTransformer = trStructured + +instance ToObject TraceLeiosKernel where + toObject _verb = traceLeiosKernelToObject + +instance HasPrivacyAnnotation TraceLeiosKernel + +instance HasSeverityAnnotation TraceLeiosKernel where + getSeverityAnnotation _ = Debug + +instance ToObject peer + => Transformable Text IO (TraceLabelPeer peer TraceLeiosPeer) where + trTransformer = trStructured + +instance ToObject TraceLeiosPeer where + toObject _verb = traceLeiosPeerToObject + +instance HasPrivacyAnnotation TraceLeiosPeer + +instance HasSeverityAnnotation TraceLeiosPeer where + getSeverityAnnotation _ = Debug diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index 8a8d9bab3f6..5154aeb95c4 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -556,6 +556,8 @@ mkTracers _ _ _ _ _ enableP2P = , Consensus.gsmTracer = nullTracer , Consensus.csjTracer = nullTracer , Consensus.dbfTracer = nullTracer + , Consensus.leiosKernelTracer = nullTracer + , Consensus.leiosPeerTracer = nullTracer } , nodeToClientTracers = NodeToClient.Tracers { NodeToClient.tChainSyncTracer = nullTracer @@ -571,6 +573,8 @@ mkTracers _ _ _ _ _ enableP2P = , NodeToNode.tTxSubmission2Tracer = nullTracer , NodeToNode.tKeepAliveTracer = nullTracer , NodeToNode.tPeerSharingTracer = nullTracer + , NodeToNode.tLeiosNotifyTracer = nullTracer + , NodeToNode.tLeiosFetchTracer = nullTracer } , diffusionTracers = Diffusion.nullTracers , diffusionTracersExtra = @@ -862,6 +866,8 @@ mkConsensusTracers mbEKGDirect trSel verb tr nodeKern fStats = do , Consensus.gsmTracer = tracerOnOff (traceGsm trSel) verb "GSM" tr , Consensus.csjTracer = tracerOnOff (traceCsj trSel) verb "CSJ" tr , Consensus.dbfTracer = tracerOnOff (traceDevotedBlockFetch trSel) verb "DevotedBlockFetch" tr + , Consensus.leiosKernelTracer = tracerOnOff (traceLeiosKernel trSel) verb "LeiosKernel" tr + , Consensus.leiosPeerTracer = tracerOnOff (traceLeiosPeer trSel) verb "LeiosPeer" tr } where mkForgeTracers :: IO ForgeTracers @@ -1513,6 +1519,12 @@ nodeToNodeTracers' trSel verb tr = , NodeToNode.tPeerSharingTracer = tracerOnOff (tracePeerSharingProtocol trSel) verb "PeerSharingPrototocol" tr + , NodeToNode.tLeiosNotifyTracer = + tracerOnOff (traceLeiosNotifyProtocol trSel) + verb "LeiosNotifyPrototocol" tr + , NodeToNode.tLeiosFetchTracer = + tracerOnOff (traceLeiosFetchProtocol trSel) + verb "LeiosFetchPrototocol" tr } -- TODO @ouroboros-network diff --git a/trace-dispatcher/src/Cardano/Logging/Formatter.hs b/trace-dispatcher/src/Cardano/Logging/Formatter.hs index 16de345dd87..aa7b0ef04ed 100644 --- a/trace-dispatcher/src/Cardano/Logging/Formatter.hs +++ b/trace-dispatcher/src/Cardano/Logging/Formatter.hs @@ -26,17 +26,22 @@ import qualified Control.Tracer as T import Data.Aeson ((.=)) import qualified Data.Aeson as AE import qualified Data.Aeson.Encoding as AE +import qualified Data.Aeson.KeyMap as AE import Data.Functor.Contravariant import Data.Maybe (fromMaybe) import Data.Text as T (Text, intercalate, null, pack) import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder as TB import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime) +import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime) +import GHC.Clock (getMonotonicTime) import Network.HostName import System.IO.Unsafe (unsafePerformIO) +data I a = I a +instance Functor I where fmap f (I x) = I (f x) + encodingToText :: AE.Encoding -> Text {-# INLINE encodingToText #-} encodingToText = toStrict . decodeUtf8 . AE.encodingToLazyByteString @@ -45,6 +50,10 @@ timeFormatted :: UTCTime -> Text {-# INLINE timeFormatted #-} timeFormatted = pack . formatTime defaultTimeLocale "%F %H:%M:%S%4QZ" +timeFormattedT :: UTCTime -> Text +{-# INLINE timeFormattedT #-} +timeFormattedT = pack . formatTime defaultTimeLocale "%FT%H:%M:%S%8QZ" + -- If the hostname in the logs should be anything different from the system reported hostname, -- a new field would need to be added to PreFormatted to carry a new hostname argument to preFormatted. hostname :: Text @@ -84,13 +93,21 @@ preFormatted withForHuman = flip contramapM (\case (lc, Right msg) -> do + tm <- liftIO getMonotonicTime time <- liftIO getCurrentTime + let tmf tm' = flip addUTCTime time $ fromRational $ tm' - toRational tm threadId <- liftIO myThreadId let ns' = lcNSPrefix lc ++ lcNSInner lc threadTextShortened = T.pack $ drop 9 $ show threadId -- drop "ThreadId " prefix details = fromMaybe DNormal (lcDetails lc) condForHuman = let txt = forHuman msg in if T.null txt then Nothing else Just txt - machineFormatted = AE.toEncoding $ forMachine details msg + obj = forMachine details msg + -- nasty special case for a numeric "mux_tm" field + I obj' = (\f -> AE.alterF f "mux_at" obj) $ \case + Nothing -> I Nothing + Just (AE.Number tm') -> I $ Just $ AE.String $ timeFormattedT $ tmf $ toRational tm' + Just x -> I $ Just x + machineFormatted = AE.toEncoding $ obj' pure (lc, Right (PreFormatted { pfForHuman = if withForHuman then condForHuman else Nothing