An experimental cardano-node version

bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs

@@ -45,7 +45,7 @@ import           Cardano.Tracing.OrphanInstances.Consensus ()
 import           Cardano.Tracing.OrphanInstances.Network ()
 import           Cardano.Tracing.OrphanInstances.Shelley ()
 
-import           Ouroboros.Network.Protocol.TxSubmission2.Type (TokBlockingStyle (..))
+import           Ouroboros.Network.Protocol.TxSubmission2.Type (SingBlockingStyle (..))
 
 import           Cardano.Api hiding (Active)
 import           Cardano.TxGenerator.Types (TPSRate, TxGenError)
@@ -124,11 +124,11 @@ mkSubmissionSummary startTime reportsRefs
 txStreamSource :: forall era. MVar (StreamState (TxStream IO era)) -> TpsThrottle -> TxSource era
 txStreamSource streamRef tpsThrottle = Active worker
  where
-  worker :: forall m blocking . MonadIO m => TokBlockingStyle blocking -> Req -> m (TxSource era, [Tx era])
+  worker :: forall m blocking . MonadIO m => SingBlockingStyle blocking -> Req -> m (TxSource era, [Tx era])
   worker blocking req = do
     (done, txCount) <- case blocking of
-       TokBlocking -> liftIO $ consumeTxsBlocking tpsThrottle req
-       TokNonBlocking -> liftIO $ consumeTxsNonBlocking tpsThrottle req
+       SingBlocking -> liftIO $ consumeTxsBlocking tpsThrottle req
+       SingNonBlocking -> liftIO $ consumeTxsNonBlocking tpsThrottle req
     txList <- liftIO $ unFold txCount
     case done of
       Stop -> return (Exhausted, txList)

bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs

@@ -50,10 +50,12 @@
 import qualified Ouroboros.Consensus.Cardano.Block as Block
                    (TxId (GenTxIdAllegra, GenTxIdAlonzo, GenTxIdBabbage, GenTxIdConway, GenTxIdMary, GenTxIdShelley))
 
+import           Ouroboros.Network.Protocol.TxSubmission2.Type
+                   (NumTxIdsToAck (..), NumTxIdsToReq (..))
 import           Ouroboros.Network.Protocol.TxSubmission2.Client (ClientStIdle (..),
                    ClientStTxIds (..), ClientStTxs (..), TxSubmissionClient (..))
 import           Ouroboros.Network.Protocol.TxSubmission2.Type (BlockingReplyList (..),
-                   TokBlockingStyle (..), TxSizeInBytes)
+                   SingBlockingStyle (..), TxSizeInBytes)
 
 import           Cardano.Api hiding (Active)
 import           Cardano.Api.Shelley (fromShelleyTxId, toConsensusGenTx)
@@ -75,14 +77,14 @@
   = Exhausted
   | Active (ProduceNextTxs era)
 
-type ProduceNextTxs era = (forall m blocking . MonadIO m => TokBlockingStyle blocking -> Req -> m (TxSource era, [Tx era]))
+type ProduceNextTxs era = (forall m blocking . MonadIO m => SingBlockingStyle blocking -> Req -> m (TxSource era, [Tx era]))
 
-produceNextTxs :: forall m blocking era . MonadIO m => TokBlockingStyle blocking -> Req -> LocalState era -> m (LocalState era, [Tx era])
+produceNextTxs :: forall m blocking era . MonadIO m => SingBlockingStyle blocking -> Req -> LocalState era -> m (LocalState era, [Tx era])
 produceNextTxs blocking req (txProducer, unack, stats) = do
   (newTxProducer, txList) <- produceNextTxs' blocking req txProducer
   return ((newTxProducer, unack, stats), txList)
 
-produceNextTxs' :: forall m blocking era . MonadIO m => TokBlockingStyle blocking -> Req -> TxSource era -> m (TxSource era, [Tx era])
+produceNextTxs' :: forall m blocking era . MonadIO m => SingBlockingStyle blocking -> Req -> TxSource era -> m (TxSource era, [Tx era])
 produceNextTxs' _ _ Exhausted = return (Exhausted, [])
 produceNextTxs' blocking req (Active callback) = callback blocking req
 
@@ -104,10 +106,10 @@
   TxSubmissionClient $
     pure $ client (initialTxSource, UnAcked [], SubmissionThreadStats 0 0 0)
  where
-  discardAcknowledged :: TokBlockingStyle a -> Ack -> LocalState era -> m (LocalState era)
+  discardAcknowledged :: SingBlockingStyle a -> Ack -> LocalState era -> m (LocalState era)
   discardAcknowledged blocking (Ack ack) (txSource, UnAcked unAcked, stats) = do
     when (tokIsBlocking blocking && ack /= length unAcked) $ do
-      let err = "decideAnnouncement: TokBlocking, but length unAcked != ack"
+      let err = "decideAnnouncement: SingBlocking, but length unAcked != ack"
       traceWith bmtr (TraceBenchTxSubError err)
       fail (T.unpack err)
     let (stillUnacked, acked) = L.splitAtEnd ack unAcked
@@ -128,9 +130,9 @@
 
   requestTxIds :: forall blocking.
        LocalState era
-    -> TokBlockingStyle blocking
-    -> Word16
-    -> Word16
+    -> SingBlockingStyle blocking
+    -> NumTxIdsToAck
+    -> NumTxIdsToReq
     -> m (ClientStTxIds blocking (GenTxId CardanoBlock) (GenTx CardanoBlock) m ())
   requestTxIds state blocking ackNum reqNum = do
     let ack = Ack $ fromIntegral ackNum
@@ -145,15 +147,15 @@
     traceWith bmtr $ SubmissionClientUnAcked (getTxId . getTxBody <$> outs)
 
     case blocking of
-      TokBlocking -> case NE.nonEmpty newTxs of
+      SingBlocking -> case NE.nonEmpty newTxs of
         Nothing -> do
           traceWith tr EndOfProtocol
           endOfProtocolCallback stats
           pure $ SendMsgDone ()
         (Just txs) -> pure $ SendMsgReplyTxIds
                               (BlockingReply $ txToIdSize <$> txs)
                               (client stateC)
-      TokNonBlocking ->  pure $ SendMsgReplyTxIds
+      SingNonBlocking ->  pure $ SendMsgReplyTxIds
                              (NonBlockingReply $ txToIdSize <$> newTxs)
                              (client stateC)
 
@@ -198,17 +200,17 @@
   fromGenTxId (Block.GenTxIdConway  (Mempool.ShelleyTxId i)) = fromShelleyTxId i
   fromGenTxId _ = error "TODO: fix incomplete match"
 
-  tokIsBlocking :: TokBlockingStyle a -> Bool
+  tokIsBlocking :: SingBlockingStyle a -> Bool
   tokIsBlocking = \case
-    TokBlocking    -> True
-    TokNonBlocking -> False
+    SingBlocking    -> True
+    SingNonBlocking -> False
 
-  reqIdsTrace :: Ack -> Req -> TokBlockingStyle a -> NodeToNodeSubmissionTrace
+  reqIdsTrace :: Ack -> Req -> SingBlockingStyle a -> NodeToNodeSubmissionTrace
   reqIdsTrace ack req = \case
-     TokBlocking    -> ReqIdsBlocking ack req
-     TokNonBlocking -> ReqIdsNonBlocking ack req
+     SingBlocking    -> ReqIdsBlocking ack req
+     SingNonBlocking -> ReqIdsNonBlocking ack req
 
-  idListTrace :: ToAnnce tx -> TokBlockingStyle a -> NodeToNodeSubmissionTrace
+  idListTrace :: ToAnnce tx -> SingBlockingStyle a -> NodeToNodeSubmissionTrace
   idListTrace (ToAnnce toAnn) = \case
-     TokBlocking    -> IdsListBlocking $ length toAnn
-     TokNonBlocking -> IdsListNonBlocking $ length toAnn
+     SingBlocking    -> IdsListBlocking $ length toAnn
+     SingNonBlocking -> IdsListNonBlocking $ length toAnn

cabal.project

@@ -14,7 +14,7 @@ repository cardano-haskell-packages
 -- you need to run if you change them
 index-state:
   , hackage.haskell.org 2024-06-23T23:01:13Z
-  , cardano-haskell-packages 2024-07-24T14:16:32Z
+  , cardano-haskell-packages 2024-07-30T13:21:24Z
 
 packages:
   cardano-node
@@ -65,3 +65,53 @@ allow-newer: katip:Win32
 -- IMPORTANT
 -- Do NOT add more source-repository-package stanzas here unless they are strictly
 -- temporary! Please read the section in CONTRIBUTING about updating dependencies.
+
+-- coot/typed-protocols-new-api
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/typed-protocols
+  tag: f36ac61d188be2252eed859937fdf3f98c9d0bbb
+  --sha256: sha256-QWTulG6okgE5nNbl8l/lkTv7IaxZ/nLHhSsc7Dmhgtc=
+  subdir:
+    typed-protocols
+    typed-protocols-cborg
+    typed-protocols-stateful
+    typed-protocols-stateful-cborg
+    typed-protocols-examples
+
+-- coot/typed-protocols-new-api
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/ouroboros-network
+  tag: 0789fc1e6df63065671eaa5f9845a479bc78518f
+  --sha256: sha256-tOo0OzbtHiwEKEYtFHarCvmXlGLBX1N5kmCMZtI5m9s=
+  subdir: network-mux
+          ouroboros-network
+          ouroboros-network-api
+          ouroboros-network-framework
+          ouroboros-network-protocols
+          ouroboros-network-testing
+
+-- coot/typed-protocols-new-api
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/ouroboros-consensus
+  tag: e237a013d568e106712f2de626886286ca296f83
+  --sha256: sha256-hI+SYQmQoIr01uVsI6g45ih/5evPD8A2HoHS/R7wv94=
+  subdir: ouroboros-consensus
+          ouroboros-consensus-cardano
+          ouroboros-consensus-diffusion
+
+-- coot/typed-protocols-new-api
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/cardano-api
+  tag: 628906befc8587b1061f787875174b0dc6d708fb
+  --sha256: sha256-gVw4aFRB/J5URrpt50AXxIjrT9B4/naQ/xPkSDK+z54=
+  subdir: cardano-api
+
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/ekg-forward
+  tag: 59c99bb78a0f3da8cccc9a0f7a32bc84607e3f58
+  --sha256: sha256-I7xSHeMwH+1RIi0lwlvxaI76uut57gxE8U4klaTSxCM=

cardano-node/cardano-node.cabal

@@ -200,6 +200,7 @@ library
                       , safe-exceptions
                       , scientific
                       , si-timers
+                      , singletons
                       , sop-core
                       , stm
                       , strict-sop-core

cardano-node/src/Cardano/Node/TraceConstraints.hs

@@ -7,6 +7,8 @@
 module Cardano.Node.TraceConstraints (TraceConstraints) where
 
 
+import           Prelude (Show)
+
 import           Cardano.BM.Tracing (ToObject)
 import           Cardano.Ledger.Credential
 import           Cardano.Ledger.Crypto (StandardCrypto)
@@ -44,6 +46,8 @@ type TraceConstraints blk =
     , HasKESInfo blk
     , GetKESInfo blk
     , RunNode blk
+    , Show blk
+    , Show (Header blk)
 
     , ToObject (ApplyTxErr blk)
     , ToObject (GenTx blk)

cardano-node/src/Cardano/Node/Tracing/Tracers.hs

@@ -445,6 +445,11 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon
                 ["TxSubmission", "Remote"]
     configureTracers configReflection trConfig [txSubmission2Tracer]
 
+    !keepAliveTracer <- mkCardanoTracer
+                trBase trForward mbTrEKG
+                ["KeepAlive", "Remote"]
+    configureTracers configReflection trConfig [keepAliveTracer]
+
     pure $ NtN.Tracers
       { NtN.tChainSyncTracer = Tracer $
           traceWith chainSyncTracer
@@ -456,6 +461,8 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon
           traceWith blockFetchSerialisedTr
       , NtN.tTxSubmission2Tracer = Tracer $
           traceWith txSubmission2Tracer
+      , NtN.tKeepAliveTracer = Tracer $
+          traceWith keepAliveTracer
       }
 
 mkDiffusionTracers

cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs

@@ -21,7 +21,7 @@ import           Data.Text (pack)
 import           Formatting
 import           Network.Mux (MuxTrace (..), WithMuxBearer (..))
 import           Network.Mux.Types
-import           Network.TypedProtocol.Codec (AnyMessageAndAgency (..))
+import           Network.TypedProtocol.Codec (AnyMessage (..))
 
 import qualified Data.List as List
 import qualified Ouroboros.Network.Diffusion as ND
@@ -527,16 +527,16 @@ instance (Show adr, Show ver) => LogFormatting (NtN.HandshakeTr adr ver) where
     forHuman (WithMuxBearer b ev) = "With mux bearer " <> showT b
                                         <> ". " <> showT ev
 
-instance MetaTrace (AnyMessageAndAgency (HS.Handshake nt term)) where
-    namespaceFor (AnyMessageAndAgency _stok HS.MsgProposeVersions {}) =
+instance MetaTrace (AnyMessage (HS.Handshake nt term)) where
+    namespaceFor (AnyMessage HS.MsgProposeVersions {}) =
       Namespace [] ["ProposeVersions"]
-    namespaceFor (AnyMessageAndAgency _stok HS.MsgReplyVersions {})   =
+    namespaceFor (AnyMessage HS.MsgReplyVersions {})   =
       Namespace [] ["ReplyVersions"]
-    namespaceFor (AnyMessageAndAgency _stok HS.MsgQueryReply {})   =
+    namespaceFor (AnyMessage HS.MsgQueryReply {})   =
       Namespace [] ["MsgQueryReply"]
-    namespaceFor (AnyMessageAndAgency _stok HS.MsgAcceptVersion {})   =
+    namespaceFor (AnyMessage HS.MsgAcceptVersion {})   =
       Namespace [] ["AcceptVersion"]
-    namespaceFor (AnyMessageAndAgency _stok HS.MsgRefuse {})          =
+    namespaceFor (AnyMessage HS.MsgRefuse {})          =
       Namespace [] ["Refuse"]
 
     severityFor (Namespace _ ["ProposeVersions"]) _ = Just Info