From 61f6feed912942ce64c0b14678d6828467a4ae8c Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 4 Mar 2026 14:38:26 -0400 Subject: [PATCH] Fix Dijkstra-era script purpose rendering --- .../src/Cardano/Node/Tracing/Render.hs | 300 ++++++++++-------- 1 file changed, 167 insertions(+), 133 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Tracing/Render.hs b/cardano-node/src/Cardano/Node/Tracing/Render.hs index 3f3538457a6..2ca36f5db09 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Render.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Render.hs @@ -34,26 +34,35 @@ module Cardano.Node.Tracing.Render import qualified Cardano.Api as Api import qualified Cardano.Crypto.Hash.Class as Crypto -import Cardano.Ledger.Alonzo.Scripts (AlonzoPlutusPurpose (..), AsItem (..), - PlutusPurpose) +import Cardano.Ledger.Alonzo.Scripts ( + AlonzoPlutusPurpose (..), + AsItem (..), + PlutusPurpose, + ) import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import Cardano.Ledger.BaseTypes (Mismatch (..), Relation (..)) import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..)) import qualified Cardano.Ledger.Core as Ledger +import Cardano.Ledger.Dijkstra.Scripts (DijkstraPlutusPurpose (..)) import qualified Cardano.Ledger.Hashes as Hashes -import Cardano.Logging -import Cardano.Node.Queries (ConvertTxId (..)) -import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) -import Ouroboros.Consensus.Block (BlockNo (..), ConvertRawHash (..), RealPoint (..)) -import Ouroboros.Consensus.Block.Abstract (Point (..)) -import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, TxId) +import Cardano.Logging +import Cardano.Node.Queries (ConvertTxId (..)) +import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) +import Ouroboros.Consensus.Block (BlockNo (..), ConvertRawHash (..), RealPoint (..)) +import Ouroboros.Consensus.Block.Abstract (Point (..)) +import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, TxId) import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmDB -import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (ChunkNo (..)) -import Ouroboros.Consensus.Util.Condense (Condense, condense) -import Ouroboros.Network.Block (ChainHash (..), HeaderHash, StandardHash, Tip, - getTipPoint) - -import Data.Aeson ((.=)) +import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (ChunkNo (..)) +import Ouroboros.Consensus.Util.Condense (Condense, condense) +import Ouroboros.Network.Block ( + ChainHash (..), + HeaderHash, + StandardHash, + Tip, + getTipPoint, + ) + +import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Key as Aeson import qualified Data.Aeson.Types as Aeson @@ -77,17 +86,17 @@ renderChunkNo = Text.pack . show . unChunkNo renderTipBlockNo :: ImmDB.Tip blk -> Text renderTipBlockNo = Text.pack . show . unBlockNo . ImmDB.tipBlockNo -renderTipHash :: StandardHash blk => ImmDB.Tip blk -> Text +renderTipHash :: (StandardHash blk) => ImmDB.Tip blk -> Text renderTipHash tInfo = Text.pack . show $ ImmDB.tipHash tInfo -renderTxIdForDetails - :: ConvertTxId blk - => DetailLevel - -> TxId (GenTx blk) - -> Text +renderTxIdForDetails :: + (ConvertTxId blk) => + DetailLevel -> + TxId (GenTx blk) -> + Text renderTxIdForDetails dtal = trimHashTextForDetails dtal . renderTxId -renderTxId :: ConvertTxId blk => TxId (GenTx blk) -> Text +renderTxId :: (ConvertTxId blk) => TxId (GenTx blk) -> Text renderTxId = Text.decodeLatin1 . B16.encode . txIdToRawBytes renderWithOrigin :: (a -> Text) -> WithOrigin a -> Text @@ -97,80 +106,81 @@ renderWithOrigin render (At a) = render a renderSlotNo :: SlotNo -> Text renderSlotNo = Text.pack . show . unSlotNo -renderRealPoint - :: forall blk. - ConvertRawHash blk - => RealPoint blk - -> Text +renderRealPoint :: + forall blk. + (ConvertRawHash blk) => + RealPoint blk -> + Text renderRealPoint (RealPoint slotNo headerHash) = - renderHeaderHash (Proxy @blk) headerHash - <> "@" - <> renderSlotNo slotNo - --- | Render a short phrase describing a 'RealPoint'. --- e.g. "62292d753b2ee7e903095bc5f10b03cf4209f456ea08f55308e0aaab4350dda4 at --- slot 39920" -renderRealPointAsPhrase - :: forall blk. - ConvertRawHash blk - => RealPoint blk - -> Text + renderHeaderHash (Proxy @blk) headerHash + <> "@" + <> renderSlotNo slotNo + +{- | Render a short phrase describing a 'RealPoint'. +e.g. "62292d753b2ee7e903095bc5f10b03cf4209f456ea08f55308e0aaab4350dda4 at +slot 39920" +-} +renderRealPointAsPhrase :: + forall blk. + (ConvertRawHash blk) => + RealPoint blk -> + Text renderRealPointAsPhrase (RealPoint slotNo headerHash) = - renderHeaderHash (Proxy @blk) headerHash - <> " at slot " - <> renderSlotNo slotNo - -renderPointForDetails - :: forall blk. - ConvertRawHash blk - => DetailLevel - -> Point blk - -> Text + renderHeaderHash (Proxy @blk) headerHash + <> " at slot " + <> renderSlotNo slotNo + +renderPointForDetails :: + forall blk. + (ConvertRawHash blk) => + DetailLevel -> + Point blk -> + Text renderPointForDetails dtal point = - case point of - GenesisPoint -> "genesis (origin)" - BlockPoint slot h -> - renderHeaderHashForDetails (Proxy @blk) dtal h - <> "@" - <> renderSlotNo slot - -renderPoint :: ConvertRawHash blk => Point blk -> Text + case point of + GenesisPoint -> "genesis (origin)" + BlockPoint slot h -> + renderHeaderHashForDetails (Proxy @blk) dtal h + <> "@" + <> renderSlotNo slot + +renderPoint :: (ConvertRawHash blk) => Point blk -> Text renderPoint = renderPointForDetails DDetailed --- | Render a short phrase describing a 'Point'. --- e.g. "62292d753b2ee7e903095bc5f10b03cf4209f456ea08f55308e0aaab4350dda4 at --- slot 39920" or "genesis (origin)" in the case of a genesis point. -renderPointAsPhrase :: forall blk. ConvertRawHash blk => Point blk -> Text +{- | Render a short phrase describing a 'Point'. +e.g. "62292d753b2ee7e903095bc5f10b03cf4209f456ea08f55308e0aaab4350dda4 at +slot 39920" or "genesis (origin)" in the case of a genesis point. +-} +renderPointAsPhrase :: forall blk. (ConvertRawHash blk) => Point blk -> Text renderPointAsPhrase point = - case point of - GenesisPoint -> "genesis (origin)" - BlockPoint slot h -> - renderHeaderHash (Proxy @blk) h - <> " at slot " - <> renderSlotNo slot - -renderTipForDetails - :: ConvertRawHash blk - => DetailLevel - -> Tip blk - -> Text + case point of + GenesisPoint -> "genesis (origin)" + BlockPoint slot h -> + renderHeaderHash (Proxy @blk) h + <> " at slot " + <> renderSlotNo slot + +renderTipForDetails :: + (ConvertRawHash blk) => + DetailLevel -> + Tip blk -> + Text renderTipForDetails dtal = renderPointForDetails dtal . getTipPoint -renderTip :: ConvertRawHash blk => Tip blk -> Text +renderTip :: (ConvertRawHash blk) => Tip blk -> Text renderTip = renderTipForDetails DDetailed -renderHeaderHashForDetails - :: ConvertRawHash blk - => proxy blk - -> DetailLevel - -> HeaderHash blk - -> Text +renderHeaderHashForDetails :: + (ConvertRawHash blk) => + proxy blk -> + DetailLevel -> + HeaderHash blk -> + Text renderHeaderHashForDetails p dtal = - trimHashTextForDetails dtal . renderHeaderHash p - + trimHashTextForDetails dtal . renderHeaderHash p -- | Hex encode and render a 'HeaderHash' as text. -renderHeaderHash :: ConvertRawHash blk => proxy blk -> HeaderHash blk -> Text +renderHeaderHash :: (ConvertRawHash blk) => proxy blk -> HeaderHash blk -> Text renderHeaderHash p = Text.decodeLatin1 . B16.encode . toRawHash p renderChainHash :: (HeaderHash blk -> Text) -> ChainHash blk -> Text @@ -179,13 +189,13 @@ renderChainHash p (BlockHash hash) = p hash trimHashTextForDetails :: DetailLevel -> Text -> Text trimHashTextForDetails dtal = - case dtal of - DMinimal -> Text.take 7 - _ -> id + case dtal of + DMinimal -> Text.take 7 + _ -> id renderScriptIntegrityHash :: Maybe Alonzo.ScriptIntegrityHash -> Aeson.Value renderScriptIntegrityHash (Just witPPDataHash) = - Aeson.String . Crypto.hashToTextAsHex $ Hashes.extractHash witPPDataHash + Aeson.String . Crypto.hashToTextAsHex $ Hashes.extractHash witPPDataHash renderScriptIntegrityHash Nothing = Aeson.Null @@ -195,11 +205,12 @@ renderMissingRedeemers :: forall era. () -> Aeson.Value renderMissingRedeemers sbe scripts = Aeson.object $ NonEmpty.toList $ NonEmpty.map renderTuple scripts where - renderTuple :: () - => (PlutusPurpose AsItem (Api.ShelleyLedgerEra era), Ledger.ScriptHash) - -> Aeson.Pair + renderTuple :: + () => + (PlutusPurpose AsItem (Api.ShelleyLedgerEra era), Ledger.ScriptHash) -> + Aeson.Pair renderTuple (scriptPurpose, sHash) = - Aeson.fromText (renderScriptHash sHash) .= renderScriptPurpose sbe scriptPurpose + Aeson.fromText (renderScriptHash sHash) .= renderScriptPurpose sbe scriptPurpose renderIncompleteWithdrawals :: forall payload. Show payload => NonEmptyMap Ledger.AccountAddress (Mismatch RelEQ payload) @@ -214,49 +225,72 @@ renderIncompleteWithdrawals payload = renderScriptHash :: Ledger.ScriptHash -> Text renderScriptHash = Api.serialiseToRawBytesHexText . Api.fromShelleyScriptHash -renderScriptPurpose :: () - => Api.ShelleyBasedEra era - -> PlutusPurpose AsItem (Api.ShelleyLedgerEra era) - -> Aeson.Value +renderScriptPurpose :: + () => + Api.ShelleyBasedEra era -> + PlutusPurpose AsItem (Api.ShelleyLedgerEra era) -> + Aeson.Value renderScriptPurpose = - Api.caseShelleyToMaryOrAlonzoEraOnwards - (const (const Aeson.Null)) - (\case - Api.AlonzoEraOnwardsAlonzo -> renderAlonzoPlutusPurpose - Api.AlonzoEraOnwardsBabbage -> renderAlonzoPlutusPurpose - Api.AlonzoEraOnwardsConway -> renderConwayPlutusPurpose - -- TODO: fix - Api.AlonzoEraOnwardsDijkstra -> undefined - ) - -renderAlonzoPlutusPurpose :: () - => Aeson.ToJSON (Ledger.TxCert era) - => AlonzoPlutusPurpose AsItem era - -> Aeson.Value + Api.caseShelleyToMaryOrAlonzoEraOnwards + (const (const Aeson.Null)) + ( \case + Api.AlonzoEraOnwardsAlonzo -> renderAlonzoPlutusPurpose + Api.AlonzoEraOnwardsBabbage -> renderAlonzoPlutusPurpose + Api.AlonzoEraOnwardsConway -> renderConwayPlutusPurpose + Api.AlonzoEraOnwardsDijkstra -> renderDijkstraPlutusPurpose + ) + +renderAlonzoPlutusPurpose :: + () => + (Aeson.ToJSON (Ledger.TxCert era)) => + AlonzoPlutusPurpose AsItem era -> + Aeson.Value renderAlonzoPlutusPurpose = \case - AlonzoSpending (AsItem txin) -> - Aeson.object ["spending" .= Api.fromShelleyTxIn txin] - AlonzoMinting pid -> - Aeson.object ["minting" .= Aeson.toJSON pid] - AlonzoRewarding (AsItem rwdAcct) -> - Aeson.object ["rewarding" .= Aeson.String (Api.serialiseAddress $ Api.fromShelleyStakeAddr rwdAcct)] - AlonzoCertifying cert -> - Aeson.object ["certifying" .= Aeson.toJSON cert] - -renderConwayPlutusPurpose :: () - => (Ledger.EraPParams era, Aeson.ToJSON (Ledger.TxCert era)) - => ConwayPlutusPurpose AsItem era - -> Aeson.Value + AlonzoSpending (AsItem txin) -> + Aeson.object ["spending" .= Api.fromShelleyTxIn txin] + AlonzoMinting pid -> + Aeson.object ["minting" .= Aeson.toJSON pid] + AlonzoRewarding (AsItem rwdAcct) -> + Aeson.object ["rewarding" .= Aeson.String (Api.serialiseAddress $ Api.fromShelleyStakeAddr rwdAcct)] + AlonzoCertifying cert -> + Aeson.object ["certifying" .= Aeson.toJSON cert] + +renderConwayPlutusPurpose :: + () => + (Ledger.EraPParams era, Aeson.ToJSON (Ledger.TxCert era)) => + ConwayPlutusPurpose AsItem era -> + Aeson.Value renderConwayPlutusPurpose = \case - ConwaySpending (AsItem txin) -> - Aeson.object ["spending" .= Api.fromShelleyTxIn txin] - ConwayMinting pid -> - Aeson.object ["minting" .= Aeson.toJSON pid] - ConwayRewarding (AsItem rwdAcct) -> - Aeson.object ["rewarding" .= Aeson.String (Api.serialiseAddress $ Api.fromShelleyStakeAddr rwdAcct)] - ConwayCertifying cert -> - Aeson.object ["certifying" .= Aeson.toJSON cert] - ConwayVoting voter -> - Aeson.object ["voting" .= Aeson.toJSON voter] - ConwayProposing proposal -> - Aeson.object ["proposing" .= Aeson.toJSON proposal] + ConwaySpending (AsItem txin) -> + Aeson.object ["spending" .= Api.fromShelleyTxIn txin] + ConwayMinting pid -> + Aeson.object ["minting" .= Aeson.toJSON pid] + ConwayRewarding (AsItem rwdAcct) -> + Aeson.object ["rewarding" .= Aeson.String (Api.serialiseAddress $ Api.fromShelleyStakeAddr rwdAcct)] + ConwayCertifying cert -> + Aeson.object ["certifying" .= Aeson.toJSON cert] + ConwayVoting voter -> + Aeson.object ["voting" .= Aeson.toJSON voter] + ConwayProposing proposal -> + Aeson.object ["proposing" .= Aeson.toJSON proposal] + +renderDijkstraPlutusPurpose :: + () => + (Ledger.EraPParams era, Aeson.ToJSON (Ledger.TxCert era)) => + DijkstraPlutusPurpose AsItem era -> + Aeson.Value +renderDijkstraPlutusPurpose = \case + DijkstraSpending (AsItem txin) -> + Aeson.object ["spending" .= Api.fromShelleyTxIn txin] + DijkstraMinting pid -> + Aeson.object ["minting" .= Aeson.toJSON pid] + DijkstraRewarding (AsItem rwdAcct) -> + Aeson.object ["rewarding" .= Aeson.String (Api.serialiseAddress $ Api.fromShelleyStakeAddr rwdAcct)] + DijkstraCertifying cert -> + Aeson.object ["certifying" .= Aeson.toJSON cert] + DijkstraVoting voter -> + Aeson.object ["voting" .= Aeson.toJSON voter] + DijkstraProposing proposal -> + Aeson.object ["proposing" .= Aeson.toJSON proposal] + DijkstraGuarding sHash -> + Aeson.object ["guarding" .= Aeson.toJSON sHash]