Implement various orphan instances and propagate the new ShelleyBlock

type in cardano-node

cardano-api/src/Cardano/Api/InMode.hs

@@ -214,8 +214,11 @@ toConsensusTxId (TxIdInMode txid AlonzoEraInCardanoMode) =
   txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardAlonzoBlock)
   txid' = Consensus.ShelleyTxId $ toShelleyTxId txid
 
-toConsensusTxId (TxIdInMode _txid BabbageEraInCardanoMode) =
-  error "TODO: Babbage era - depends on consensus exposing a babbage era"
+toConsensusTxId (TxIdInMode txid BabbageEraInCardanoMode) =
+  Consensus.HardForkGenTxId (Consensus.OneEraGenTxId (S (S (S (S (S (Z (Consensus.WrapGenTxId txid'))))))))
+ where
+  txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardBabbageBlock)
+  txid' = Consensus.ShelleyTxId $ toShelleyTxId txid
 
 -- ----------------------------------------------------------------------------
 -- Transaction validation errors in the context of eras and consensus modes

cardano-node/cardano-node.cabal

@@ -135,6 +135,7 @@ library
                       , cardano-crypto-class
                       , cardano-crypto-wrapper
                       , cardano-ledger-alonzo
+                      , cardano-ledger-babbage
                       , cardano-ledger-byron
                       , cardano-ledger-core
                       , cardano-ledger-shelley-ma

cardano-node/src/Cardano/Node/Configuration/Logging.hs

@@ -333,12 +333,14 @@ nodeBasicInfo nc (SomeConsensusProtocol whichP pForInfo) nodeStartTime' = do
             let DegenLedgerConfig cfgShelley = Consensus.configLedger cfg
             in getGenesisValues "Shelley" cfgShelley
           CardanoBlockType ->
-            let CardanoLedgerConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo = Consensus.configLedger cfg
+            let CardanoLedgerConfig cfgByron cfgShelley cfgAllegra
+                                    cfgMary cfgAlonzo cfgBabbage = Consensus.configLedger cfg
             in getGenesisValuesByron cfg cfgByron
                ++ getGenesisValues "Shelley" cfgShelley
                ++ getGenesisValues "Allegra" cfgAllegra
                ++ getGenesisValues "Mary"    cfgMary
                ++ getGenesisValues "Alonzo"  cfgAlonzo
+               ++ getGenesisValues "Babbage"  cfgBabbage
       items = nub $
         [ ("protocol",      pack . show $ ncProtocol nc)
         , ("version",       pack . showVersion $ version)

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

@@ -99,7 +99,7 @@ instance ConvertTxId ByronBlock where
   txIdToRawBytes (ByronUpdateVoteId voteId) =
     Byron.Crypto.abstractHashToBytes voteId
 
-instance ConvertTxId (ShelleyBlock c) where
+instance ConvertTxId (ShelleyBlock protocol c) where
   txIdToRawBytes (ShelleyTxId txId) =
     Crypto.hashToBytes . Ledger.extractHash . Ledger._unTxId $ txId
 
@@ -128,7 +128,7 @@ class HasKESInfo blk where
   getKESInfo :: Proxy blk -> ForgeStateUpdateError blk -> Maybe HotKey.KESInfo
   getKESInfo _ _ = Nothing
 
-instance HasKESInfo (ShelleyBlock era) where
+instance HasKESInfo (ShelleyBlock protocol era) where
   getKESInfo _ (HotKey.KESCouldNotEvolve ki _) = Just ki
   getKESInfo _ (HotKey.KESKeyAlreadyPoisoned ki _) = Just ki
 
@@ -169,7 +169,7 @@ class HasKESMetricsData blk where
   -- Default to 'NoKESMetricsData'
   getKESMetricsData _ _ = NoKESMetricsData
 
-instance HasKESMetricsData (ShelleyBlock c) where
+instance HasKESMetricsData (ShelleyBlock protocol c) where
   getKESMetricsData _ forgeStateInfo =
       TPraosKESMetricsData currKesPeriod maxKesEvos oCertStartKesPeriod
     where
@@ -208,7 +208,7 @@ class GetKESInfo blk where
   getKESInfoFromStateInfo :: Proxy blk -> ForgeStateInfo blk -> Maybe HotKey.KESInfo
   getKESInfoFromStateInfo _ _ = Nothing
 
-instance GetKESInfo (ShelleyBlock era) where
+instance GetKESInfo (ShelleyBlock protocol era) where
   getKESInfoFromStateInfo _ = Just
 
 instance GetKESInfo ByronBlock
@@ -239,7 +239,7 @@ instance LedgerQueries Byron.ByronBlock where
   ledgerUtxoSize = Map.size . Byron.unUTxO . Byron.cvsUtxo . Byron.byronLedgerState
   ledgerDelegMapSize _ = 0
 
-instance LedgerQueries (Shelley.ShelleyBlock era) where
+instance LedgerQueries (Shelley.ShelleyBlock protocol era) where
   ledgerUtxoSize =
       (\(Shelley.UTxO xs)-> SplitMap.size xs)
     . Shelley._utxo
@@ -269,13 +269,14 @@ instance LedgerQueries (Cardano.CardanoBlock c) where
     Cardano.LedgerStateAllegra ledgerAllegra -> ledgerUtxoSize ledgerAllegra
     Cardano.LedgerStateMary    ledgerMary    -> ledgerUtxoSize ledgerMary
     Cardano.LedgerStateAlonzo  ledgerAlonzo  -> ledgerUtxoSize ledgerAlonzo
+    Cardano.LedgerStateBabbage ledgerBabbage -> ledgerUtxoSize ledgerBabbage
   ledgerDelegMapSize = \case
     Cardano.LedgerStateByron   ledgerByron   -> ledgerDelegMapSize ledgerByron
     Cardano.LedgerStateShelley ledgerShelley -> ledgerDelegMapSize ledgerShelley
     Cardano.LedgerStateAllegra ledgerAllegra -> ledgerDelegMapSize ledgerAllegra
     Cardano.LedgerStateMary    ledgerMary    -> ledgerDelegMapSize ledgerMary
     Cardano.LedgerStateAlonzo  ledgerAlonzo  -> ledgerDelegMapSize ledgerAlonzo
-
+    Cardano.LedgerStateBabbage ledgerBabbage -> ledgerDelegMapSize ledgerBabbage
 --
 -- * Node kernel
 --

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

@@ -189,12 +189,13 @@ prepareNodeInfo ptcl (SomeConsensusProtocol whichP pForInfo) tc nodeStartTime =
         let DegenLedgerConfig cfgShelley = configLedger cfg
         in getSystemStartShelley cfgShelley
       CardanoBlockType ->
-        let CardanoLedgerConfig _ cfgShelley cfgAllegra cfgMary cfgAlonzo = configLedger cfg
+        let CardanoLedgerConfig _ cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage = configLedger cfg
         in minimum [ getSystemStartByron
                    , getSystemStartShelley cfgShelley
                    , getSystemStartShelley cfgAllegra
                    , getSystemStartShelley cfgMary
                    , getSystemStartShelley cfgAlonzo
+                   , getSystemStartShelley cfgBabbage
                    ]
 
   getSystemStartByron = WCT.getSystemStart . getSystemStart . configBlock $ cfg

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

@@ -106,6 +106,8 @@ import           Ouroboros.Network.Subscription.Worker (SubscriptionTrace (..))
 import           Ouroboros.Network.TxSubmission.Inbound (TraceTxSubmissionInbound)
 import           Ouroboros.Network.TxSubmission.Outbound (TraceTxSubmissionOutbound)
 
+import           Cardano.Api.Orphans ()
+
 data TraceDocumentationCmd
   = TraceDocumentationCmd
     { tdcConfigFile :: FilePath

cardano-node/src/Cardano/Node/Tracing/Era/Shelley.hs

@@ -33,30 +33,35 @@ import           Cardano.Slotting.Block (BlockNo (..))
 import           Ouroboros.Network.Block (SlotNo (..), blockHash, blockNo, blockSlot)
 import           Ouroboros.Network.Point (WithOrigin, withOriginToMaybe)
 
+import qualified Cardano.Ledger.Babbage.Rules.Utxo as Babbage
 import           Ouroboros.Consensus.Ledger.SupportsMempool (txId)
 import qualified Ouroboros.Consensus.Ledger.SupportsMempool as SupportsMempool
 import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
+import qualified Ouroboros.Consensus.Protocol.Praos as Praos
 import           Ouroboros.Consensus.Protocol.TPraos (TPraosCannotForge (..))
 import           Ouroboros.Consensus.Shelley.Ledger hiding (TxId)
 import           Ouroboros.Consensus.Shelley.Ledger.Inspect
+import qualified Ouroboros.Consensus.Shelley.Protocol.Praos as Praos
 import           Ouroboros.Consensus.Util.Condense (condense)
 
+
 import           Cardano.Protocol.TPraos.BHeader (LastAppliedBlock, labBlockNo)
 import           Cardano.Protocol.TPraos.Rules.OCert
 import           Cardano.Protocol.TPraos.Rules.Overlay
-import           Cardano.Protocol.TPraos.Rules.Updn
+import           Cardano.Protocol.TPraos.Rules.Updn (UpdnPredicateFailure)
 
 
-import qualified Cardano.Ledger.Alonzo as Alonzo
+import qualified Cardano.Ledger.Alonzo.PlutusScriptApi as Alonzo
 import           Cardano.Ledger.Alonzo.Rules.Bbody (AlonzoBbodyPredFail)
 import qualified Cardano.Ledger.Alonzo.Rules.Utxo as Alonzo
 import qualified Cardano.Ledger.Alonzo.Rules.Utxos as Alonzo
 import           Cardano.Ledger.Alonzo.Rules.Utxow (UtxowPredicateFail (..))
 import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
 import qualified Cardano.Ledger.AuxiliaryData as Core
-import           Cardano.Ledger.BaseTypes (strictMaybeToMaybe)
+import           Cardano.Ledger.BaseTypes (activeSlotLog, strictMaybeToMaybe)
 import           Cardano.Ledger.Chain
 import qualified Cardano.Ledger.Core as Core
+import qualified Cardano.Ledger.Core as Ledger
 import qualified Cardano.Ledger.Crypto as Core
 import qualified Cardano.Ledger.Era as Ledger
 import qualified Cardano.Ledger.SafeHash as SafeHash
@@ -102,15 +107,15 @@ import qualified Data.Aeson.Key as Aeson
 --
 -- NOTE: this list is sorted in roughly topological order.
 
-instance (  ToJSON (SupportsMempool.TxId (GenTx (ShelleyBlock era)))
+instance (  ToJSON (SupportsMempool.TxId (GenTx (ShelleyBlock protocol era)))
          ,  ShelleyBasedEra era)
-         => LogFormatting (GenTx (ShelleyBlock era)) where
+         => LogFormatting (GenTx (ShelleyBlock protocol era)) where
   forMachine dtal tx =
     mconcat $
         ( "txid" .= txId tx )
       : [ "tx"   .= condense tx | dtal == DDetailed ]
 
-instance ShelleyBasedEra era => LogFormatting (Header (ShelleyBlock era)) where
+instance ShelleyCompatible protocol era => LogFormatting (Header (ShelleyBlock protocol era)) where
   forMachine _dtal b = mconcat
         [ "kind" .= String "ShelleyBlock"
         , "hash" .= condense (blockHash b)
@@ -346,7 +351,13 @@ instance ( ShelleyBasedEra era
   forMachine dtal (UtxowFailure f)  = forMachine dtal f
   forMachine dtal (DelegsFailure f) = forMachine dtal f
 
-instance LogFormatting (UtxowPredicateFail (Alonzo.AlonzoEra StandardCrypto)) where
+instance ( ShelleyBasedEra era
+         , ToJSON (Ledger.Value era)
+         , ToJSON (Ledger.TxOut era)
+         , Ledger.Crypto era ~ StandardCrypto
+         , LogFormatting (PredicateFailure (Ledger.EraRule "PPUP" era))
+         , LogFormatting (PredicateFailure (Ledger.EraRule "UTXO" era))
+         ) => LogFormatting (UtxowPredicateFail era) where
   forMachine dtal (WrappedShelleyEraFailure utxoPredFail) =
     forMachine dtal utxoPredFail
   forMachine _ (MissingRedeemers scripts) =
@@ -919,8 +930,13 @@ instance LogFormatting (UpecPredicateFailure era) where
 --------------------------------------------------------------------------------
 -- Alonzo related
 --------------------------------------------------------------------------------
-
-instance LogFormatting (Alonzo.UtxoPredicateFailure (Alonzo.AlonzoEra StandardCrypto)) where
+instance ( Ledger.Era era
+         , ShelleyBasedEra era
+         , ToJSON (Ledger.Value era)
+         , ToJSON (Ledger.TxOut era)
+         , Show (Ledger.Value era)
+         , LogFormatting (PredicateFailure (Ledger.EraRule "UTXOS" era))
+         ) => LogFormatting (Alonzo.UtxoPredicateFailure era) where
   forMachine _dtal (Alonzo.BadInputsUTxO badInputs) =
     mconcat [ "kind" .= String "BadInputsUTxO"
              , "badInputs" .= badInputs
@@ -1014,7 +1030,9 @@ instance LogFormatting (Alonzo.UtxoPredicateFailure (Alonzo.AlonzoEra StandardCr
   forMachine _dtal Alonzo.NoCollateralInputs =
     mconcat [ "kind" .= String "NoCollateralInputs" ]
 
-instance LogFormatting (Alonzo.UtxosPredicateFailure (Alonzo.AlonzoEra StandardCrypto)) where
+instance ( ToJSON (Alonzo.CollectError (Ledger.Crypto era))
+         , LogFormatting (PredicateFailure (Ledger.EraRule "PPUP" era))
+         ) => LogFormatting (Alonzo.UtxosPredicateFailure era) where
   forMachine _ (Alonzo.ValidationTagMismatch isValidating reason) =
     mconcat [ "kind" .= String "ValidationTagMismatch"
              , "isvalidating" .= isValidating
@@ -1027,10 +1045,135 @@ instance LogFormatting (Alonzo.UtxosPredicateFailure (Alonzo.AlonzoEra StandardC
   forMachine dtal (Alonzo.UpdateFailure pFailure) =
     forMachine dtal pFailure
 
-instance LogFormatting (AlonzoBbodyPredFail (Alonzo.AlonzoEra StandardCrypto)) where
+instance ( Ledger.Era era
+         , Show (PredicateFailure (Ledger.EraRule "LEDGERS" era))
+         ) => LogFormatting (AlonzoBbodyPredFail era) where
   forMachine _ err = mconcat [ "kind" .= String "AlonzoBbodyPredFail"
                             , "error" .= String (show err)
                             ]
+--------------------------------------------------------------------------------
+-- Babbage related
+--------------------------------------------------------------------------------
+
+
+instance ( Ledger.Era era
+         , LogFormatting (Alonzo.UtxoPredicateFailure era)
+         , LogFormatting (UtxowPredicateFail era)
+         , ToJSON (Ledger.TxOut era)
+         ) => LogFormatting (Babbage.BabbageUtxoPred era) where
+  forMachine v err =
+    case err of
+      Babbage.FromAlonzoUtxoFail alonzoFail ->
+        forMachine v alonzoFail
+      Babbage.FromAlonzoUtxowFail alonzoFail->
+        forMachine v alonzoFail
+
+      Babbage.UnequalCollateralReturn bal totalCol ->
+        mconcat [ "kind" .= String "UnequalCollateralReturn"
+                , "calculatedTotalCollateral" .= bal
+                , "txIndicatedTotalCollateral" .= totalCol
+                ]
+      -- TODO: Plutus team needs to expose a better error
+      -- type.
+      Babbage.MalformedScripts s ->
+        mconcat [ "kind" .= String "MalformedScripts"
+                , "scripts" .= s
+                ]
+      -- The transaction contains outputs that are too small
+      Babbage.BabbageOutputTooSmallUTxO outputs ->
+        mconcat [ "kind" .= String "OutputTooSmall"
+                , "outputs" .= outputs
+                ]
+
+instance Core.Crypto crypto => LogFormatting (Praos.PraosValidationErr crypto) where
+  forMachine _ err' =
+    case err' of
+      Praos.VRFKeyUnknown unknownKeyHash ->
+        mconcat [ "kind" .= String "VRFKeyUnknown"
+                , "vrfKey" .= unknownKeyHash
+                ]
+      Praos.VRFKeyWrongVRFKey stakePoolKeyHash registeredVrfForSaidStakepool wrongKeyHashInBlockHeader ->
+        mconcat [ "kind" .= String "VRFKeyWrongVRFKey"
+                , "stakePoolKeyHash" .= stakePoolKeyHash
+                , "stakePoolVrfKey" .= registeredVrfForSaidStakepool
+                , "blockHeaderVrfKey" .= wrongKeyHashInBlockHeader
+                ]
+      Praos.VRFKeyBadProof slotNo nonce vrfCalculatedVal->
+        mconcat [ "kind" .= String "VRFKeyBadProof"
+                , "slotNumberUsedInVrfCalculation" .= slotNo
+                , "nonceUsedInVrfCalculation" .= nonce
+                , "calculatedVrfValue" .= String (show vrfCalculatedVal)
+                ]
+      Praos.VRFLeaderValueTooBig leaderValue sigma f->
+        mconcat [ "kind" .= String "VRFLeaderValueTooBig"
+                , "leaderValue" .= leaderValue
+                , "sigma" .= sigma
+                , "f" .= activeSlotLog f
+                ]
+      Praos.KESBeforeStartOCERT startKesPeriod currKesPeriod ->
+        mconcat [ "kind" .= String "KESBeforeStartOCERT"
+                , "opCertStartingKesPeriod" .= startKesPeriod
+                , "currentKesPeriod" .= currKesPeriod
+                ]
+      Praos.KESAfterEndOCERT currKesPeriod startKesPeriod maxKesKeyEvos ->
+        mconcat [ "kind" .= String "KESAfterEndOCERT"
+                , "opCertStartingKesPeriod" .= startKesPeriod
+                , "currentKesPeriod" .= currKesPeriod
+                , "maxKesKeyEvolutions" .= maxKesKeyEvos
+                ]
+      Praos.CounterTooSmallOCERT lastCounter currentCounter ->
+        mconcat [ "kind" .= String "CounterTooSmallOCERT"
+                , "lastCounter" .= lastCounter
+                , "currentCounter" .= currentCounter
+                ]
+      Praos.CounterOverIncrementedOCERT lastCounter currentCounter ->
+        mconcat [ "kind" .= String "CounterOverIncrementedOCERT"
+                , "lastCounter" .= lastCounter
+                , "currentCounter" .= currentCounter
+                ]
+      Praos.InvalidSignatureOCERT counter oCertStartKesPeriod err ->
+        mconcat [ "kind" .= String "InvalidSignatureOCERT"
+                , "counter" .= counter
+                , "opCertStartingKesPeriod" .= oCertStartKesPeriod
+                , "error" .= err
+                ]
+      Praos.InvalidKesSignatureOCERT currentKesPeriod opCertStartKesPeriod expectedKesEvos err ->
+        mconcat [ "kind" .= String "InvalidKesSignatureOCERT"
+                , "currentKesPeriod" .= currentKesPeriod
+                , "opCertStartingKesPeriod" .= opCertStartKesPeriod
+                , "expectedKesEvolutions" .= expectedKesEvos
+                , "error" .= err
+                ]
+      Praos.NoCounterForKeyHashOCERT stakePoolKeyHash->
+        mconcat [ "kind" .= String "NoCounterForKeyHashOCERT"
+                , "stakePoolKeyHash" .= stakePoolKeyHash
+                ]
+
+instance LogFormatting (Praos.PraosCannotForge crypto) where
+  forMachine _ (Praos.PraosCannotForgeKeyNotUsableYet currentKesPeriod startingKesPeriod) =
+    mconcat [ "kind" .= String "PraosCannotForgeKeyNotUsableYet"
+            , "currentKesPeriod" .= currentKesPeriod
+            , "opCertStartingKesPeriod" .= startingKesPeriod
+            ]
+
+instance LogFormatting Praos.PraosEnvelopeError where
+  forMachine _ err' =
+    case err' of
+      Praos.ObsoleteNode maxPtclVersionFromPparams blkHeaderPtclVersion ->
+        mconcat [ "kind" .= String "ObsoleteNode"
+                , "maxMajorProtocolVersion" .= maxPtclVersionFromPparams
+                , "headerProtocolVersion" .= blkHeaderPtclVersion
+                ]
+      Praos.HeaderSizeTooLarge headerSize ledgerViewMaxHeaderSize ->
+        mconcat [ "kind" .= String "HeaderSizeTooLarge"
+                , "maxHeaderSize" .= ledgerViewMaxHeaderSize
+                , "headerSize" .= headerSize
+                ]
+      Praos.BlockSizeTooLarge blockSize ledgerViewMaxBlockSize ->
+        mconcat [ "kind" .= String "BlockSizeTooLarge"
+                , "maxBlockSize" .= ledgerViewMaxBlockSize
+                , "blockSize" .= blockSize
+                ]
 
 
 --------------------------------------------------------------------------------

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

@@ -18,8 +18,8 @@ module Cardano.Node.Tracing.StateRep
   , traceNodeStateShutdown
   ) where
 
-import           Cardano.Prelude
 import           Cardano.Logging
+import           Cardano.Prelude
 import           Data.Aeson
 import           Data.Time.Clock
 
@@ -199,13 +199,15 @@ getSlotForNow (SomeConsensusProtocol whichP pInfo) s = do
           nowSinceSystemStart = now `diffUTCTime` getSystemStartTime cfgShelley
       return . SlotNo $ floor nowSinceSystemStart
     CardanoBlockType -> do
-      let CardanoLedgerConfig _ cfgShelley cfgAllegra cfgMary cfgAlonzo =
+      let CardanoLedgerConfig _ cfgShelley cfgAllegra cfgMary
+                                cfgAlonzo cfgBabbage =
             Consensus.configLedger cfg
           latestNowSinceSystemStart = minimum
             [ now `diffUTCTime` getSystemStartTime cfgShelley
             , now `diffUTCTime` getSystemStartTime cfgAllegra
             , now `diffUTCTime` getSystemStartTime cfgMary
             , now `diffUTCTime` getSystemStartTime cfgAlonzo
+            , now `diffUTCTime` getSystemStartTime cfgBabbage
             ]
       return . SlotNo $ floor latestNowSinceSystemStart
     _ ->

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

@@ -54,8 +54,6 @@ import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
 import           Ouroboros.Network.Driver.Simple (TraceSendRecv (..))
 import           Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch (..), Message (..))
 import           Ouroboros.Network.Protocol.ChainSync.Type as ChainSync
---import           Ouroboros.Network.Protocol.TxSubmission2.Type (ClientHasAgency (..), Message (..),
---                   ServerHasAgency (..), TxSubmission2)
 import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as STX
 import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as TXS