Typed Protocols: new API

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.Shelley.Ledger.Mempool as Mempool (TxId (Sh
 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 @@ data TxSource era
   = 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 tr bmtr initialTxSource endOfProtocolCallback =
   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 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback =
 
   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 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback =
     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 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback =
   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,54 @@ 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: 782bc02602a81bb655e6d0bbcec4a8d3302e7cd8
+  --sha256: sha256-nyhIb3Bchi8ixN+VppvGbipae5MqiRCMooIo1PEeWDc=
+  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: a1b3b754460b096c7ef33aecaf2127e8cd9dd6bf
+  --sha256: sha256-9C/IXKt/ZJ1rDfkIE53+X66EEj6kSnS/krUIKdobXsE=
+  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/Protocol/Byron.hs

@@ -31,7 +31,6 @@ import           Cardano.Tracing.OrphanInstances.HardFork ()
 import           Cardano.Tracing.OrphanInstances.Shelley ()
 import           Ouroboros.Consensus.Cardano
 import qualified Ouroboros.Consensus.Cardano as Consensus
-import qualified Ouroboros.Consensus.Mempool.Capacity as TxLimits
 
 import qualified Data.ByteString.Lazy as LB
 import           Data.Maybe (fromMaybe)
@@ -80,9 +79,7 @@ mkSomeConsensusProtocolByron NodeByronProtocolConfiguration {
             npcByronSupportedProtocolVersionAlt,
         byronSoftwareVersion = softwareVersion,
         byronLeaderCredentials =
-          optionalLeaderCredentials,
-        byronMaxTxCapacityOverrides =
-          TxLimits.mkOverrides TxLimits.noOverridesMeasure
+          optionalLeaderCredentials
         }
 
 readGenesis :: GenesisFile

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

@@ -35,7 +35,6 @@ import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus
 import           Ouroboros.Consensus.Cardano.Condense ()
 import           Ouroboros.Consensus.Config (emptyCheckpointsMap)
 import           Ouroboros.Consensus.HardFork.Combinator.Condense ()
-import qualified Ouroboros.Consensus.Mempool.Capacity as TxLimits
 import qualified Ouroboros.Consensus.Shelley.Node.Praos as Praos
 
 import           Prelude
@@ -167,9 +166,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration {
               npcByronSupportedProtocolVersionAlt,
           byronSoftwareVersion = Byron.softwareVersion,
           byronLeaderCredentials =
-            byronLeaderCredentials,
-          byronMaxTxCapacityOverrides =
-            TxLimits.mkOverrides TxLimits.noOverridesMeasure
+            byronLeaderCredentials
         }
       , paramsShelleyBased =
         Consensus.ProtocolParamsShelleyBased {
@@ -184,9 +181,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration {
           -- is in the Shelley era. That is, it is the version of protocol
           -- /after/ Shelley, i.e. Allegra.
           shelleyProtVer =
-            ProtVer (natVersion @3) 0,
-          shelleyMaxTxCapacityOverrides =
-            TxLimits.mkOverrides TxLimits.noOverridesMeasure
+            ProtVer (natVersion @3) 0
         }
       , paramsAllegra =
         Consensus.ProtocolParamsAllegra {
@@ -195,19 +190,15 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration {
           -- is in the Allegra era. That is, it is the version of protocol
           -- /after/ Allegra, i.e. Mary.
           allegraProtVer =
-            ProtVer (natVersion @4) 0,
-          allegraMaxTxCapacityOverrides =
-            TxLimits.mkOverrides TxLimits.noOverridesMeasure
+            ProtVer (natVersion @4) 0
         }
       , paramsMary =
         Consensus.ProtocolParamsMary {
           -- This is /not/ the Mary protocol version. It is the protocol
           -- version that this node will declare that it understands, when it
           -- is in the Mary era. That is, it is the version of protocol
           -- /after/ Mary, i.e. Alonzo.
-          maryProtVer = ProtVer (natVersion @5) 0,
-          maryMaxTxCapacityOverrides =
-            TxLimits.mkOverrides TxLimits.noOverridesMeasure
+          maryProtVer = ProtVer (natVersion @5) 0
         }
       , paramsAlonzo =
         Consensus.ProtocolParamsAlonzo {
@@ -220,9 +211,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration {
           -- this is a HACK so that we can distinguish between others
           -- versions of the node that are broadcasting major version 7.
           -- We intentionally broadcast 7.0 starting in Babbage.
-          alonzoProtVer = ProtVer (natVersion @7) 2,
-          alonzoMaxTxCapacityOverrides =
-            TxLimits.mkOverrides TxLimits.noOverridesMeasure
+          alonzoProtVer = ProtVer (natVersion @7) 2
         }
       , paramsBabbage =
         Praos.ProtocolParamsBabbage {
@@ -233,9 +222,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration {
           -- version. It is the protocol version that this node will declare
           -- that it understands during the Babbage era. That is, it is the
           -- version of protocol /after/ Babbage, i.e. Conway.
-          Praos.babbageProtVer = ProtVer (natVersion @9) 1,
-          Praos.babbageMaxTxCapacityOverrides =
-            TxLimits.mkOverrides TxLimits.noOverridesMeasure
+          Praos.babbageProtVer = ProtVer (natVersion @9) 1
         }
       , paramsConway =
         Praos.ProtocolParamsConway {
@@ -244,9 +231,7 @@ mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration {
           Praos.conwayProtVer =
             if npcExperimentalHardForksEnabled
             then ProtVer (natVersion @10) 0
-            else ProtVer (natVersion @9) 1,
-          Praos.conwayMaxTxCapacityOverrides =
-            TxLimits.mkOverrides TxLimits.noOverridesMeasure
+            else ProtVer (natVersion @9) 1
         }
         -- The remaining arguments specify the parameters needed to transition between two eras
       , ledgerTransitionConfig =

cardano-node/src/Cardano/Node/Protocol/Shelley.hs

@@ -39,7 +39,6 @@ import           Cardano.Node.Types
 import           Cardano.Tracing.OrphanInstances.HardFork ()
 import           Cardano.Tracing.OrphanInstances.Shelley ()
 import qualified Ouroboros.Consensus.Cardano as Consensus
-import qualified Ouroboros.Consensus.Mempool.Capacity as TxLimits
 import           Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader (..))
 import           Ouroboros.Consensus.Shelley.Node (Nonce (..), ProtocolParams (..),
                    ProtocolParamsShelleyBased (..), ShelleyLeaderCredentials (..))
@@ -85,9 +84,7 @@ mkSomeConsensusProtocolShelley NodeShelleyProtocolConfiguration {
       }
       Consensus.ProtocolParamsShelley {
         shelleyProtVer =
-          ProtVer (natVersion @2) 0,
-        shelleyMaxTxCapacityOverrides =
-          TxLimits.mkOverrides TxLimits.noOverridesMeasure
+          ProtVer (natVersion @2) 0
       }
 
 genesisHashToPraosNonce :: GenesisHash -> Nonce

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

@@ -64,7 +64,7 @@ import           Ouroboros.Network.NodeToNode (RemoteAddress)
 
 import           Codec.CBOR.Read (DeserialiseFailure)
 import           Control.Monad (unless)
-import           "contra-tracer" Control.Tracer (Tracer (..))
+import           "contra-tracer" Control.Tracer (Tracer (..), nullTracer)
 import           Data.Proxy (Proxy (..))
 import           Network.Mux.Trace (TraceLabelPeer (..))
 
@@ -361,6 +361,8 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf
           traceWith consensusStartupErrorTr . ConsensusStartupException
       , Consensus.gsmTracer = Tracer $
           traceWith consensusGsmTr
+      , Consensus.consensusSanityCheckTracer = nullTracer
+      , Consensus.gddTracer = nullTracer
       }
 
 mkNodeToClientTracers :: forall blk.
@@ -445,6 +447,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 +463,8 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon
           traceWith blockFetchSerialisedTr
       , NtN.tTxSubmission2Tracer = Tracer $
           traceWith txSubmission2Tracer
+      , NtN.tKeepAliveTracer = Tracer $
+          traceWith keepAliveTracer
       }
 
 mkDiffusionTracers