From 628fd7490598765e3f0a22faca4ba3791933545b Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 08:33:13 -0400 Subject: [PATCH 01/26] Add `DijkstraEra era` to `CardanoEra era` --- cardano-api/src/Cardano/Api/Era/Internal/Core.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Core.hs b/cardano-api/src/Cardano/Api/Era/Internal/Core.hs index bc6dadeca4..1594f882c4 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Core.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Core.hs @@ -19,6 +19,7 @@ module Cardano.Api.Era.Internal.Core , AlonzoEra , BabbageEra , ConwayEra + , DijkstraEra -- * CardanoEra , CardanoEra (..) @@ -87,6 +88,9 @@ data BabbageEra -- | A type used as a tag to distinguish the Conway era. data ConwayEra +-- | A type used as a tag to distinguish the DijkstraEra era. +data DijkstraEra + instance HasTypeProxy ByronEra where data AsType ByronEra = AsByronEra proxyToAsType _ = AsByronEra @@ -115,6 +119,10 @@ instance HasTypeProxy ConwayEra where data AsType ConwayEra = AsConwayEra proxyToAsType _ = AsConwayEra +instance HasTypeProxy DijkstraEra where + data AsType DijkstraEra = AsDijkstraEra + proxyToAsType _ = AsDijkstraEra + -- ---------------------------------------------------------------------------- -- Eon @@ -263,6 +271,7 @@ data CardanoEra era where AlonzoEra :: CardanoEra AlonzoEra BabbageEra :: CardanoEra BabbageEra ConwayEra :: CardanoEra ConwayEra + DijkstraEra :: CardanoEra DijkstraEra -- when you add era here, change `instance Bounded AnyCardanoEra` @@ -321,6 +330,9 @@ instance IsCardanoEra BabbageEra where instance IsCardanoEra ConwayEra where cardanoEra = ConwayEra +instance IsCardanoEra DijkstraEra where + cardanoEra = DijkstraEra + type CardanoEraConstraints era = ( Typeable era , IsCardanoEra era @@ -339,6 +351,7 @@ cardanoEraConstraints = \case AlonzoEra -> id BabbageEra -> id ConwayEra -> id + DijkstraEra -> id data AnyCardanoEra where AnyCardanoEra @@ -372,6 +385,7 @@ instance Enum AnyCardanoEra where AnyCardanoEra AlonzoEra -> 4 AnyCardanoEra BabbageEra -> 5 AnyCardanoEra ConwayEra -> 6 + AnyCardanoEra DijkstraEra -> 7 toEnum = \case 0 -> AnyCardanoEra ByronEra @@ -409,6 +423,7 @@ cardanoEraToStringLike = \case AlonzoEra -> "Alonzo" BabbageEra -> "Babbage" ConwayEra -> "Conway" + DijkstraEra -> "Dijkstra" anyCardanoEraFromStringLike :: (IsString a, Eq a) => a -> Either a AnyCardanoEra {-# INLINE anyCardanoEraFromStringLike #-} @@ -433,6 +448,7 @@ anyCardanoEra = \case AlonzoEra -> AnyCardanoEra AlonzoEra BabbageEra -> AnyCardanoEra BabbageEra ConwayEra -> AnyCardanoEra ConwayEra + DijkstraEra -> AnyCardanoEra DijkstraEra -- | This pairs up some era-dependent type with a 'CardanoEra' value that tells -- us what era it is, but hides the era type. This is useful when the era is From 7746b91e3e2813f823a1987d03d2eb11914d5b3a Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 08:34:25 -0400 Subject: [PATCH 02/26] Add `ShelleyBasedEraDijkstra` to `ShelleyBasedEra era` --- .../Cardano/Api/Era/Internal/Eon/ShelleyBasedEra.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyBasedEra.hs b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyBasedEra.hs index 92e25e505c..1b12a17d70 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyBasedEra.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyBasedEra.hs @@ -128,6 +128,7 @@ data ShelleyBasedEra era where ShelleyBasedEraAlonzo :: ShelleyBasedEra AlonzoEra ShelleyBasedEraBabbage :: ShelleyBasedEra BabbageEra ShelleyBasedEraConway :: ShelleyBasedEra ConwayEra + ShelleyBasedEraDijkstra :: ShelleyBasedEra DijkstraEra instance NFData (ShelleyBasedEra era) where rnf = \case @@ -137,6 +138,7 @@ instance NFData (ShelleyBasedEra era) where ShelleyBasedEraAlonzo -> () ShelleyBasedEraBabbage -> () ShelleyBasedEraConway -> () + ShelleyBasedEraDijkstra -> () deriving instance Eq (ShelleyBasedEra era) @@ -168,6 +170,7 @@ instance Eon ShelleyBasedEra where AlonzoEra -> yes ShelleyBasedEraAlonzo BabbageEra -> yes ShelleyBasedEraBabbage ConwayEra -> yes ShelleyBasedEraConway + DijkstraEra -> yes ShelleyBasedEraDijkstra instance ToCardanoEra ShelleyBasedEra where toCardanoEra = \case @@ -177,6 +180,7 @@ instance ToCardanoEra ShelleyBasedEra where ShelleyBasedEraAlonzo -> AlonzoEra ShelleyBasedEraBabbage -> BabbageEra ShelleyBasedEraConway -> ConwayEra + ShelleyBasedEraDijkstra -> DijkstraEra instance Convert ShelleyBasedEra CardanoEra where convert = toCardanoEra @@ -205,6 +209,9 @@ instance IsShelleyBasedEra BabbageEra where instance IsShelleyBasedEra ConwayEra where shelleyBasedEra = ShelleyBasedEraConway +instance IsShelleyBasedEra DijkstraEra where + shelleyBasedEra = ShelleyBasedEraDijkstra + type ShelleyBasedEraConstraints era = ( C.HashAlgorithm L.HASH , C.Signable (L.VRF L.StandardCrypto) L.Seed @@ -245,6 +252,7 @@ shelleyBasedEraConstraints = \case ShelleyBasedEraAlonzo -> id ShelleyBasedEraBabbage -> id ShelleyBasedEraConway -> id + ShelleyBasedEraDijkstra -> id data AnyShelleyBasedEra where AnyShelleyBasedEra @@ -274,6 +282,7 @@ instance Enum AnyShelleyBasedEra where AnyShelleyBasedEra ShelleyBasedEraAlonzo -> 4 AnyShelleyBasedEra ShelleyBasedEraBabbage -> 5 AnyShelleyBasedEra ShelleyBasedEraConway -> 6 + AnyShelleyBasedEra ShelleyBasedEraDijkstra -> 7 toEnum = \case 1 -> AnyShelleyBasedEra ShelleyBasedEraShelley @@ -337,6 +346,7 @@ type family ShelleyLedgerEra era = ledgerera | ledgerera -> era where ShelleyLedgerEra AlonzoEra = L.AlonzoEra ShelleyLedgerEra BabbageEra = L.BabbageEra ShelleyLedgerEra ConwayEra = L.ConwayEra + ShelleyLedgerEra DijkstraEra = L.DijkstraEra -- | Lookup the lower major protocol version for the shelley based era. In other words -- this is the major protocol version that the era has started in. @@ -348,6 +358,7 @@ eraProtVerLow = \case ShelleyBasedEraAlonzo -> L.eraProtVerLow @L.AlonzoEra ShelleyBasedEraBabbage -> L.eraProtVerLow @L.BabbageEra ShelleyBasedEraConway -> L.eraProtVerLow @L.ConwayEra + ShelleyBasedEraDijkstra -> L.eraProtVerLow @L.DijkstraEra requireShelleyBasedEra :: () From 0a5c6ad1402f8aedeb6a0091c46dfc210055ba25 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 08:35:30 -0400 Subject: [PATCH 03/26] Add Dijkstra era to eons --- cardano-api/src/Cardano/Api/Era/Internal/Case.hs | 10 ++++++++++ .../Api/Era/Internal/Eon/AllegraEraOnwards.hs | 5 +++++ .../Cardano/Api/Era/Internal/Eon/AlonzoEraOnwards.hs | 5 +++++ .../Api/Era/Internal/Eon/BabbageEraOnwards.hs | 7 +++++++ .../Cardano/Api/Era/Internal/Eon/ByronToAlonzoEra.hs | 1 + .../Cardano/Api/Era/Internal/Eon/ConwayEraOnwards.hs | 12 ++++++++++-- .../Cardano/Api/Era/Internal/Eon/MaryEraOnwards.hs | 5 +++++ .../Cardano/Api/Era/Internal/Eon/ShelleyEraOnly.hs | 1 + .../Api/Era/Internal/Eon/ShelleyToAllegraEra.hs | 1 + .../Api/Era/Internal/Eon/ShelleyToAlonzoEra.hs | 1 + .../Api/Era/Internal/Eon/ShelleyToBabbageEra.hs | 1 + .../Cardano/Api/Era/Internal/Eon/ShelleyToMaryEra.hs | 1 + 12 files changed, 48 insertions(+), 2 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Case.hs b/cardano-api/src/Cardano/Api/Era/Internal/Case.hs index a7049a6d6e..d78672ee55 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Case.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Case.hs @@ -52,6 +52,7 @@ caseByronOrShelleyBasedEra l r = \case AlonzoEra -> r ShelleyBasedEraAlonzo BabbageEra -> r ShelleyBasedEraBabbage ConwayEra -> r ShelleyBasedEraConway + DijkstraEra -> r ShelleyBasedEraDijkstra -- | @caseByronToAlonzoOrBabbageEraOnwards f g era@ applies @f@ to byron, shelley, allegra, mary, and alonzo; -- and @g@ to babbage and later eras. @@ -69,6 +70,7 @@ caseByronToAlonzoOrBabbageEraOnwards l r = \case AlonzoEra -> l ByronToAlonzoEraAlonzo BabbageEra -> r BabbageEraOnwardsBabbage ConwayEra -> r BabbageEraOnwardsConway + DijkstraEra -> r BabbageEraOnwardsDijkstra -- | @caseShelleyEraOnlyOrAllegraEraOnwards f g era@ applies @f@ to shelley; -- and applies @g@ to allegra and later eras. @@ -85,6 +87,7 @@ caseShelleyEraOnlyOrAllegraEraOnwards l r = \case ShelleyBasedEraAlonzo -> r AllegraEraOnwardsAlonzo ShelleyBasedEraBabbage -> r AllegraEraOnwardsBabbage ShelleyBasedEraConway -> r AllegraEraOnwardsConway + ShelleyBasedEraDijkstra -> r AllegraEraOnwardsDijkstra -- | @caseShelleyToAllegraOrMaryEraOnwards f g era@ applies @f@ to shelley and allegra; -- and applies @g@ to mary and later eras. @@ -101,6 +104,7 @@ caseShelleyToAllegraOrMaryEraOnwards l r = \case ShelleyBasedEraAlonzo -> r MaryEraOnwardsAlonzo ShelleyBasedEraBabbage -> r MaryEraOnwardsBabbage ShelleyBasedEraConway -> r MaryEraOnwardsConway + ShelleyBasedEraDijkstra -> r MaryEraOnwardsDijkstra -- | @caseShelleyToMaryOrAlonzoEraOnwards f g era@ applies @f@ to shelley, allegra, and mary; -- and applies @g@ to alonzo and later eras. @@ -117,6 +121,7 @@ caseShelleyToMaryOrAlonzoEraOnwards l r = \case ShelleyBasedEraAlonzo -> r AlonzoEraOnwardsAlonzo ShelleyBasedEraBabbage -> r AlonzoEraOnwardsBabbage ShelleyBasedEraConway -> r AlonzoEraOnwardsConway + ShelleyBasedEraDijkstra -> r AlonzoEraOnwardsDijkstra -- | @caseShelleyToAlonzoOrBabbageEraOnwards f g era@ applies @f@ to shelley, allegra, mary, and alonzo; -- and applies @g@ to babbage and later eras. @@ -133,6 +138,7 @@ caseShelleyToAlonzoOrBabbageEraOnwards l r = \case ShelleyBasedEraAlonzo -> l ShelleyToAlonzoEraAlonzo ShelleyBasedEraBabbage -> r BabbageEraOnwardsBabbage ShelleyBasedEraConway -> r BabbageEraOnwardsConway + ShelleyBasedEraDijkstra -> r BabbageEraOnwardsDijkstra -- | @caseShelleyToBabbageOrConwayEraOnwards f g era@ applies @f@ to eras before conway; -- and applies @g@ to conway and later eras. @@ -149,6 +155,7 @@ caseShelleyToBabbageOrConwayEraOnwards l r = \case ShelleyBasedEraAlonzo -> l ShelleyToBabbageEraAlonzo ShelleyBasedEraBabbage -> l ShelleyToBabbageEraBabbage ShelleyBasedEraConway -> r ConwayEraOnwardsConway + ShelleyBasedEraDijkstra -> r ConwayEraOnwardsDijkstra {-# DEPRECATED shelleyToAlonzoEraToShelleyToBabbageEra "Use convert instead" #-} shelleyToAlonzoEraToShelleyToBabbageEra @@ -170,6 +177,7 @@ alonzoEraOnwardsToMaryEraOnwards = \case AlonzoEraOnwardsAlonzo -> MaryEraOnwardsAlonzo AlonzoEraOnwardsBabbage -> MaryEraOnwardsBabbage AlonzoEraOnwardsConway -> MaryEraOnwardsConway + AlonzoEraOnwardsDijkstra -> MaryEraOnwardsDijkstra {-# DEPRECATED babbageEraOnwardsToMaryEraOnwards "Use convert instead" #-} babbageEraOnwardsToMaryEraOnwards @@ -179,6 +187,7 @@ babbageEraOnwardsToMaryEraOnwards babbageEraOnwardsToMaryEraOnwards = \case BabbageEraOnwardsBabbage -> MaryEraOnwardsBabbage BabbageEraOnwardsConway -> MaryEraOnwardsConway + BabbageEraOnwardsDijkstra -> MaryEraOnwardsDijkstra {-# DEPRECATED babbageEraOnwardsToAlonzoEraOnwards "Use convert instead" #-} babbageEraOnwardsToAlonzoEraOnwards @@ -188,3 +197,4 @@ babbageEraOnwardsToAlonzoEraOnwards babbageEraOnwardsToAlonzoEraOnwards = \case BabbageEraOnwardsBabbage -> AlonzoEraOnwardsBabbage BabbageEraOnwardsConway -> AlonzoEraOnwardsConway + BabbageEraOnwardsDijkstra -> AlonzoEraOnwardsDijkstra diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Eon/AllegraEraOnwards.hs b/cardano-api/src/Cardano/Api/Era/Internal/Eon/AllegraEraOnwards.hs index 709c3fee0a..a59a731a3e 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Eon/AllegraEraOnwards.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Eon/AllegraEraOnwards.hs @@ -46,6 +46,7 @@ data AllegraEraOnwards era where AllegraEraOnwardsAlonzo :: AllegraEraOnwards AlonzoEra AllegraEraOnwardsBabbage :: AllegraEraOnwards BabbageEra AllegraEraOnwardsConway :: AllegraEraOnwards ConwayEra + AllegraEraOnwardsDijkstra :: AllegraEraOnwards DijkstraEra deriving instance Show (AllegraEraOnwards era) @@ -60,6 +61,7 @@ instance Eon AllegraEraOnwards where AlonzoEra -> yes AllegraEraOnwardsAlonzo BabbageEra -> yes AllegraEraOnwardsBabbage ConwayEra -> yes AllegraEraOnwardsConway + DijkstraEra -> yes AllegraEraOnwardsDijkstra instance ToCardanoEra AllegraEraOnwards where toCardanoEra = \case @@ -68,6 +70,7 @@ instance ToCardanoEra AllegraEraOnwards where AllegraEraOnwardsAlonzo -> AlonzoEra AllegraEraOnwardsBabbage -> BabbageEra AllegraEraOnwardsConway -> ConwayEra + AllegraEraOnwardsDijkstra -> DijkstraEra instance Convert AllegraEraOnwards CardanoEra where convert = toCardanoEra @@ -79,6 +82,7 @@ instance Convert AllegraEraOnwards ShelleyBasedEra where AllegraEraOnwardsAlonzo -> ShelleyBasedEraAlonzo AllegraEraOnwardsBabbage -> ShelleyBasedEraBabbage AllegraEraOnwardsConway -> ShelleyBasedEraConway + AllegraEraOnwardsDijkstra -> ShelleyBasedEraDijkstra type AllegraEraOnwardsConstraints era = ( C.HashAlgorithm L.HASH @@ -116,6 +120,7 @@ allegraEraOnwardsConstraints = \case AllegraEraOnwardsAlonzo -> id AllegraEraOnwardsBabbage -> id AllegraEraOnwardsConway -> id + AllegraEraOnwardsDijkstra -> id {-# DEPRECATED allegraEraOnwardsToShelleyBasedEra "Use 'convert' instead." #-} allegraEraOnwardsToShelleyBasedEra :: AllegraEraOnwards era -> ShelleyBasedEra era diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Eon/AlonzoEraOnwards.hs b/cardano-api/src/Cardano/Api/Era/Internal/Eon/AlonzoEraOnwards.hs index 5c688eeac0..ac9ba0de4f 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Eon/AlonzoEraOnwards.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Eon/AlonzoEraOnwards.hs @@ -53,6 +53,7 @@ data AlonzoEraOnwards era where AlonzoEraOnwardsAlonzo :: AlonzoEraOnwards AlonzoEra AlonzoEraOnwardsBabbage :: AlonzoEraOnwards BabbageEra AlonzoEraOnwardsConway :: AlonzoEraOnwards ConwayEra + AlonzoEraOnwardsDijkstra :: AlonzoEraOnwards DijkstraEra deriving instance Show (AlonzoEraOnwards era) @@ -67,12 +68,14 @@ instance Eon AlonzoEraOnwards where AlonzoEra -> yes AlonzoEraOnwardsAlonzo BabbageEra -> yes AlonzoEraOnwardsBabbage ConwayEra -> yes AlonzoEraOnwardsConway + DijkstraEra -> yes AlonzoEraOnwardsDijkstra instance ToCardanoEra AlonzoEraOnwards where toCardanoEra = \case AlonzoEraOnwardsAlonzo -> AlonzoEra AlonzoEraOnwardsBabbage -> BabbageEra AlonzoEraOnwardsConway -> ConwayEra + AlonzoEraOnwardsDijkstra -> DijkstraEra instance Convert AlonzoEraOnwards CardanoEra where convert = toCardanoEra @@ -82,6 +85,7 @@ instance Convert AlonzoEraOnwards ShelleyBasedEra where AlonzoEraOnwardsAlonzo -> ShelleyBasedEraAlonzo AlonzoEraOnwardsBabbage -> ShelleyBasedEraBabbage AlonzoEraOnwardsConway -> ShelleyBasedEraConway + AlonzoEraOnwardsDijkstra -> ShelleyBasedEraDijkstra type AlonzoEraOnwardsConstraints era = ( C.HashAlgorithm L.HASH @@ -127,6 +131,7 @@ alonzoEraOnwardsConstraints = \case AlonzoEraOnwardsAlonzo -> id AlonzoEraOnwardsBabbage -> id AlonzoEraOnwardsConway -> id + AlonzoEraOnwardsDijkstra -> id {-# DEPRECATED alonzoEraOnwardsToShelleyBasedEra "Use 'convert' instead." #-} alonzoEraOnwardsToShelleyBasedEra :: AlonzoEraOnwards era -> ShelleyBasedEra era diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Eon/BabbageEraOnwards.hs b/cardano-api/src/Cardano/Api/Era/Internal/Eon/BabbageEraOnwards.hs index de9d823caa..4be939edf0 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Eon/BabbageEraOnwards.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Eon/BabbageEraOnwards.hs @@ -51,6 +51,7 @@ import Data.Typeable (Typeable) data BabbageEraOnwards era where BabbageEraOnwardsBabbage :: BabbageEraOnwards BabbageEra BabbageEraOnwardsConway :: BabbageEraOnwards ConwayEra + BabbageEraOnwardsDijkstra :: BabbageEraOnwards DijkstraEra deriving instance Show (BabbageEraOnwards era) @@ -65,11 +66,13 @@ instance Eon BabbageEraOnwards where AlonzoEra -> no BabbageEra -> yes BabbageEraOnwardsBabbage ConwayEra -> yes BabbageEraOnwardsConway + DijkstraEra -> yes BabbageEraOnwardsDijkstra instance ToCardanoEra BabbageEraOnwards where toCardanoEra = \case BabbageEraOnwardsBabbage -> BabbageEra BabbageEraOnwardsConway -> ConwayEra + BabbageEraOnwardsDijkstra -> DijkstraEra instance Convert BabbageEraOnwards CardanoEra where convert = toCardanoEra @@ -78,16 +81,19 @@ instance Convert BabbageEraOnwards ShelleyBasedEra where convert = \case BabbageEraOnwardsBabbage -> ShelleyBasedEraBabbage BabbageEraOnwardsConway -> ShelleyBasedEraConway + BabbageEraOnwardsDijkstra -> ShelleyBasedEraDijkstra instance Convert BabbageEraOnwards MaryEraOnwards where convert = \case BabbageEraOnwardsBabbage -> MaryEraOnwardsBabbage BabbageEraOnwardsConway -> MaryEraOnwardsConway + BabbageEraOnwardsDijkstra -> MaryEraOnwardsDijkstra instance Convert BabbageEraOnwards AlonzoEraOnwards where convert = \case BabbageEraOnwardsBabbage -> AlonzoEraOnwardsBabbage BabbageEraOnwardsConway -> AlonzoEraOnwardsConway + BabbageEraOnwardsDijkstra -> AlonzoEraOnwardsDijkstra type BabbageEraOnwardsConstraints era = ( C.HashAlgorithm L.HASH @@ -131,6 +137,7 @@ babbageEraOnwardsConstraints babbageEraOnwardsConstraints = \case BabbageEraOnwardsBabbage -> id BabbageEraOnwardsConway -> id + BabbageEraOnwardsDijkstra -> id {-# DEPRECATED babbageEraOnwardsToShelleyBasedEra "Use 'convert' instead." #-} babbageEraOnwardsToShelleyBasedEra :: BabbageEraOnwards era -> ShelleyBasedEra era diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ByronToAlonzoEra.hs b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ByronToAlonzoEra.hs index e5b31553cb..318ea303df 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ByronToAlonzoEra.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ByronToAlonzoEra.hs @@ -40,6 +40,7 @@ instance Eon ByronToAlonzoEra where AlonzoEra -> yes ByronToAlonzoEraAlonzo BabbageEra -> no ConwayEra -> no + DijkstraEra -> no instance ToCardanoEra ByronToAlonzoEra where toCardanoEra = \case diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ConwayEraOnwards.hs b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ConwayEraOnwards.hs index cb698488ea..da2e2a9f5b 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ConwayEraOnwards.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ConwayEraOnwards.hs @@ -37,9 +37,9 @@ import Cardano.Ledger.Api qualified as L import Cardano.Ledger.BaseTypes qualified as L import Cardano.Ledger.Conway.Core qualified as L import Cardano.Ledger.Conway.Governance qualified as L +import Cardano.Ledger.Conway.State qualified as L import Cardano.Ledger.Conway.TxCert qualified as L import Cardano.Ledger.Mary.Value qualified as L -import Cardano.Ledger.State qualified as L import Cardano.Protocol.Crypto qualified as L import Ouroboros.Consensus.Protocol.Abstract qualified as Consensus import Ouroboros.Consensus.Protocol.Praos.Common qualified as Consensus @@ -51,6 +51,7 @@ import Data.Typeable (Typeable) data ConwayEraOnwards era where ConwayEraOnwardsConway :: ConwayEraOnwards ConwayEra + ConwayEraOnwardsDijkstra :: ConwayEraOnwards DijkstraEra deriving instance Show (ConwayEraOnwards era) @@ -67,10 +68,12 @@ instance Eon ConwayEraOnwards where AlonzoEra -> no BabbageEra -> no ConwayEra -> yes ConwayEraOnwardsConway + DijkstraEra -> yes ConwayEraOnwardsDijkstra instance ToCardanoEra ConwayEraOnwards where toCardanoEra = \case ConwayEraOnwardsConway -> ConwayEra + ConwayEraOnwardsDijkstra -> DijkstraEra instance Convert ConwayEraOnwards CardanoEra where convert = toCardanoEra @@ -78,17 +81,21 @@ instance Convert ConwayEraOnwards CardanoEra where instance Convert ConwayEraOnwards ShelleyBasedEra where convert = \case ConwayEraOnwardsConway -> ShelleyBasedEraConway + ConwayEraOnwardsDijkstra -> ShelleyBasedEraDijkstra instance Convert ConwayEraOnwards AllegraEraOnwards where convert = \case ConwayEraOnwardsConway -> AllegraEraOnwardsConway + ConwayEraOnwardsDijkstra -> AllegraEraOnwardsDijkstra instance Convert ConwayEraOnwards BabbageEraOnwards where convert = \case ConwayEraOnwardsConway -> BabbageEraOnwardsConway + ConwayEraOnwardsDijkstra -> BabbageEraOnwardsDijkstra type ConwayEraOnwardsConstraints era = - ( C.HashAlgorithm L.HASH + ( L.ConwayEraCertState (ShelleyLedgerEra era) + , C.HashAlgorithm L.HASH , C.Signable (L.VRF L.StandardCrypto) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) , Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era) ~ ConsensusBlockForEra era @@ -133,6 +140,7 @@ conwayEraOnwardsConstraints -> a conwayEraOnwardsConstraints = \case ConwayEraOnwardsConway -> id + ConwayEraOnwardsDijkstra -> id {-# DEPRECATED conwayEraOnwardsToShelleyBasedEra "Use 'convert' instead." #-} conwayEraOnwardsToShelleyBasedEra :: ConwayEraOnwards era -> ShelleyBasedEra era diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Eon/MaryEraOnwards.hs b/cardano-api/src/Cardano/Api/Era/Internal/Eon/MaryEraOnwards.hs index 2e93bca9fe..5be4ebe10d 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Eon/MaryEraOnwards.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Eon/MaryEraOnwards.hs @@ -48,6 +48,7 @@ data MaryEraOnwards era where MaryEraOnwardsAlonzo :: MaryEraOnwards AlonzoEra MaryEraOnwardsBabbage :: MaryEraOnwards BabbageEra MaryEraOnwardsConway :: MaryEraOnwards ConwayEra + MaryEraOnwardsDijkstra :: MaryEraOnwards DijkstraEra deriving instance Show (MaryEraOnwards era) @@ -62,6 +63,7 @@ instance Eon MaryEraOnwards where AlonzoEra -> yes MaryEraOnwardsAlonzo BabbageEra -> yes MaryEraOnwardsBabbage ConwayEra -> yes MaryEraOnwardsConway + DijkstraEra -> yes MaryEraOnwardsDijkstra instance ToCardanoEra MaryEraOnwards where toCardanoEra = \case @@ -69,6 +71,7 @@ instance ToCardanoEra MaryEraOnwards where MaryEraOnwardsAlonzo -> AlonzoEra MaryEraOnwardsBabbage -> BabbageEra MaryEraOnwardsConway -> ConwayEra + MaryEraOnwardsDijkstra -> DijkstraEra instance Convert MaryEraOnwards CardanoEra where convert = toCardanoEra @@ -79,6 +82,7 @@ instance Convert MaryEraOnwards ShelleyBasedEra where MaryEraOnwardsAlonzo -> ShelleyBasedEraAlonzo MaryEraOnwardsBabbage -> ShelleyBasedEraBabbage MaryEraOnwardsConway -> ShelleyBasedEraConway + MaryEraOnwardsDijkstra -> ShelleyBasedEraDijkstra type MaryEraOnwardsConstraints era = ( C.HashAlgorithm L.HASH @@ -117,6 +121,7 @@ maryEraOnwardsConstraints = \case MaryEraOnwardsAlonzo -> id MaryEraOnwardsBabbage -> id MaryEraOnwardsConway -> id + MaryEraOnwardsDijkstra -> id {-# DEPRECATED maryEraOnwardsToShelleyBasedEra "Use 'convert' instead." #-} maryEraOnwardsToShelleyBasedEra :: MaryEraOnwards era -> ShelleyBasedEra era diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyEraOnly.hs b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyEraOnly.hs index cdbc90c9db..8e5d76de09 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyEraOnly.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyEraOnly.hs @@ -57,6 +57,7 @@ instance Eon ShelleyEraOnly where AlonzoEra -> no BabbageEra -> no ConwayEra -> no + DijkstraEra -> no instance ToCardanoEra ShelleyEraOnly where toCardanoEra = \case diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToAllegraEra.hs b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToAllegraEra.hs index 73ebb6fb06..529487624c 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToAllegraEra.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToAllegraEra.hs @@ -59,6 +59,7 @@ instance Eon ShelleyToAllegraEra where AlonzoEra -> no BabbageEra -> no ConwayEra -> no + DijkstraEra -> no instance ToCardanoEra ShelleyToAllegraEra where toCardanoEra = \case diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToAlonzoEra.hs b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToAlonzoEra.hs index 9d7c425cb2..8c38e43e91 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToAlonzoEra.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToAlonzoEra.hs @@ -59,6 +59,7 @@ instance Eon ShelleyToAlonzoEra where AlonzoEra -> yes ShelleyToAlonzoEraAlonzo BabbageEra -> no ConwayEra -> no + DijkstraEra -> no instance ToCardanoEra ShelleyToAlonzoEra where toCardanoEra = \case diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToBabbageEra.hs b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToBabbageEra.hs index f40f67799b..0eede2a88d 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToBabbageEra.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToBabbageEra.hs @@ -62,6 +62,7 @@ instance Eon ShelleyToBabbageEra where AlonzoEra -> yes ShelleyToBabbageEraAlonzo BabbageEra -> yes ShelleyToBabbageEraBabbage ConwayEra -> no + DijkstraEra -> no instance ToCardanoEra ShelleyToBabbageEra where toCardanoEra = \case diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToMaryEra.hs b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToMaryEra.hs index ed504a4783..c8219bdd5a 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToMaryEra.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Eon/ShelleyToMaryEra.hs @@ -59,6 +59,7 @@ instance Eon ShelleyToMaryEra where AlonzoEra -> no BabbageEra -> no ConwayEra -> no + DijkstraEra -> no instance ToCardanoEra ShelleyToMaryEra where toCardanoEra = \case From d94e84373142cd22c814963c4ea7a396c22f6065 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 08:42:06 -0400 Subject: [PATCH 04/26] Add `DijkstraEra` to `Era era` --- .../src/Cardano/Api/Experimental/Era.hs | 22 ++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/cardano-api/src/Cardano/Api/Experimental/Era.hs b/cardano-api/src/Cardano/Api/Experimental/Era.hs index 8c1c87fe32..0e0051a0bb 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Era.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Era.hs @@ -34,7 +34,7 @@ where import Cardano.Api.Consensus import Cardano.Api.Era qualified as Api -import Cardano.Api.Era.Internal.Core (BabbageEra, ConwayEra, Eon (..)) +import Cardano.Api.Era.Internal.Core (BabbageEra, ConwayEra, DijkstraEra, Eon (..)) import Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards import Cardano.Api.Era.Internal.Eon.BabbageEraOnwards import Cardano.Api.Era.Internal.Eon.Convert @@ -70,6 +70,7 @@ import Prettyprinter -- and the next (upcoming) era. type family LedgerEra era = (r :: Type) | r -> era where LedgerEra ConwayEra = Ledger.ConwayEra + LedgerEra DijkstraEra = L.DijkstraEra -- | An existential wrapper for types of kind @k -> Type@. It can hold any -- era, for example, @Some Era@. The era witness can be brought back into scope, @@ -98,6 +99,7 @@ data Some (f :: k -> Type) where data Era era where -- | The currently active era on the Cardano mainnet. ConwayEra :: Era ConwayEra + DijkstraEra :: Era DijkstraEra deriving instance Show (Era era) @@ -108,6 +110,8 @@ instance Pretty (Era era) where instance TestEquality Era where testEquality ConwayEra ConwayEra = Just Refl + testEquality DijkstraEra DijkstraEra = Just Refl + testEquality _ _ = Nothing instance ToJSON (Era era) where toJSON = eraToStringLike @@ -126,6 +130,7 @@ instance Enum (Some Era) where toEnum 0 = Some ConwayEra toEnum i = error $ "Enum.toEnum: invalid argument " <> show i <> " - does not correspond to any era" fromEnum (Some ConwayEra) = 0 + fromEnum (Some DijkstraEra) = 1 instance Ord (Some Era) where compare e1 e2 = compare (fromEnum e1) (fromEnum e2) @@ -155,16 +160,19 @@ instance Eon Era where instance Api.ToCardanoEra Era where toCardanoEra = \case ConwayEra -> Api.ConwayEra + DijkstraEra -> Api.DijkstraEra eraToStringLike :: IsString a => Era era -> a {-# INLINE eraToStringLike #-} eraToStringLike = \case ConwayEra -> "Conway" + DijkstraEra -> "Dijkstra" eraFromStringLike :: (IsString a, Eq a) => a -> Either a (Some Era) {-# INLINE eraFromStringLike #-} eraFromStringLike = \case "Conway" -> pure $ Some ConwayEra + "Dijkstra" -> pure $ Some DijkstraEra wrong -> Left wrong -- | How to deprecate an era: @@ -205,30 +213,37 @@ eraToSbe = convert instance Convert Era Api.CardanoEra where convert = \case ConwayEra -> Api.ConwayEra + DijkstraEra -> Api.DijkstraEra instance Convert Era ShelleyBasedEra where convert = \case ConwayEra -> ShelleyBasedEraConway + DijkstraEra -> ShelleyBasedEraDijkstra instance Convert Era AlonzoEraOnwards where convert = \case ConwayEra -> AlonzoEraOnwardsConway + DijkstraEra -> AlonzoEraOnwardsDijkstra instance Convert Era BabbageEraOnwards where convert = \case ConwayEra -> BabbageEraOnwardsConway + DijkstraEra -> BabbageEraOnwardsDijkstra instance Convert Era MaryEraOnwards where convert = \case ConwayEra -> MaryEraOnwardsConway + DijkstraEra -> MaryEraOnwardsDijkstra instance Convert Era ConwayEraOnwards where convert = \case ConwayEra -> ConwayEraOnwardsConway + DijkstraEra -> ConwayEraOnwardsDijkstra instance Convert ConwayEraOnwards Era where convert = \case ConwayEraOnwardsConway -> ConwayEra + ConwayEraOnwardsDijkstra -> DijkstraEra newtype DeprecatedEra era = DeprecatedEra (ShelleyBasedEra era) @@ -245,6 +260,7 @@ sbeToEra => ShelleyBasedEra era -> m (Era era) sbeToEra ShelleyBasedEraConway = return ConwayEra +sbeToEra ShelleyBasedEraDijkstra = return DijkstraEra sbeToEra e@ShelleyBasedEraBabbage = throwError $ DeprecatedEra e sbeToEra e@ShelleyBasedEraAlonzo = throwError $ DeprecatedEra e sbeToEra e@ShelleyBasedEraMary = throwError $ DeprecatedEra e @@ -264,11 +280,15 @@ class IsEra era where instance IsEra ConwayEra where useEra = ConwayEra +instance IsEra DijkstraEra where + useEra = DijkstraEra + obtainCommonConstraints :: Era era -> (EraCommonConstraints era => a) -> a obtainCommonConstraints ConwayEra x = x +obtainCommonConstraints DijkstraEra x = x type EraCommonConstraints era = ( L.AllegraEraScript (LedgerEra era) From 5f1ca691e8b28a4fda8ee4c24f746ed8f3d44e9e Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 09:18:36 -0400 Subject: [PATCH 05/26] COMBINE ME: cabal file updates --- cardano-api/cardano-api.cabal | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 31f195933b..6c7188d518 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -128,9 +128,10 @@ library cardano-ledger-api >=1.11, cardano-ledger-babbage >=1.11, cardano-ledger-binary >=1.6, - cardano-ledger-byron >=1.1, + cardano-ledger-byron >=1.2, cardano-ledger-conway >=1.19, cardano-ledger-core:{cardano-ledger-core, testlib} >=1.17, + cardano-ledger-dijkstra >= 0.1, cardano-ledger-mary >=1.8, cardano-ledger-shelley >=1.16, cardano-protocol-tpraos >=1.4, @@ -168,7 +169,7 @@ library ouroboros-network-framework, ouroboros-network-protocols >=0.14, parsec, - plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib} ^>=1.45, + plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib} ^>=1.50, pretty-simple, prettyprinter, prettyprinter-ansi-terminal, @@ -186,7 +187,7 @@ library time, transformers, transformers-except ^>=0.1.3, - typed-protocols ^>=0.3, + typed-protocols ^>= 1, vector, yaml, @@ -428,7 +429,7 @@ test-suite cardano-api-golden hedgehog >=1.1, hedgehog-extras ^>=0.8, microlens, - plutus-core ^>=1.45, + plutus-core ^>=1.50, plutus-ledger-api, tasty, tasty-discover, From b7dde5417ce35035af5a92c69834614b78668945 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 09:20:52 -0400 Subject: [PATCH 06/26] Update `QueryInShelleyBasedEra era result` - QueryAccountState returns `ChainAccountState` instead of `AccountState` - Use updated consensus queries `GetStakeDistribution2` and `GetPoolDistr2` --- cardano-api/src/Cardano/Api/Block.hs | 10 ++++- .../Api/Query/Internal/Type/QueryInMode.hs | 43 ++++++++++++------- 2 files changed, 36 insertions(+), 17 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Block.hs b/cardano-api/src/Cardano/Api/Block.hs index 8760593873..20ccaaea70 100644 --- a/cardano-api/src/Cardano/Api/Block.hs +++ b/cardano-api/src/Cardano/Api/Block.hs @@ -72,7 +72,6 @@ import Ouroboros.Consensus.Byron.Ledger qualified as Consensus import Ouroboros.Consensus.Cardano.Block qualified as Consensus import Ouroboros.Consensus.HardFork.Combinator qualified as Consensus import Ouroboros.Consensus.Shelley.Ledger qualified as Consensus -import Ouroboros.Consensus.Shelley.Protocol.Abstract qualified as Consensus import Ouroboros.Network.Block qualified as Consensus import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.=)) @@ -153,6 +152,12 @@ instance Show (Block era) where ( showString "ShelleyBlock ShelleyBasedEraConway " . showsPrec 11 block ) + showsPrec p (ShelleyBlock ShelleyBasedEraDijkstra block) = + showParen + (p >= 11) + ( showString "ShelleyBlock ShelleyBasedEraDijkstra " + . showsPrec 11 block + ) getBlockTxs :: forall era. Block era -> [Tx era] getBlockTxs = \case @@ -167,7 +172,6 @@ getShelleyBlockTxs :: forall era ledgerera blockheader . ShelleyLedgerEra era ~ ledgerera => Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera - => Consensus.ShelleyProtocolHeader (ConsensusProtocol era) ~ blockheader => ShelleyBasedEra era -> Ledger.Block blockheader ledgerera -> [Tx era] @@ -203,6 +207,7 @@ fromConsensusBlock = \case Consensus.BlockAlonzo b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraAlonzo b' Consensus.BlockBabbage b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraBabbage b' Consensus.BlockConway b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraConway b' + Consensus.BlockDijkstra b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraDijkstra b' toConsensusBlock :: () @@ -217,6 +222,7 @@ toConsensusBlock = \case BlockInMode _ (ShelleyBlock ShelleyBasedEraAlonzo b') -> Consensus.BlockAlonzo b' BlockInMode _ (ShelleyBlock ShelleyBasedEraBabbage b') -> Consensus.BlockBabbage b' BlockInMode _ (ShelleyBlock ShelleyBasedEraConway b') -> Consensus.BlockConway b' + BlockInMode _ (ShelleyBlock ShelleyBasedEraDijkstra b') -> Consensus.BlockDijkstra b' -- ---------------------------------------------------------------------------- -- Block headers diff --git a/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs b/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs index e9b7913450..9b815ef809 100644 --- a/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs +++ b/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs @@ -72,6 +72,7 @@ import Cardano.Api.Certificate.Internal import Cardano.Api.Consensus.Internal.Mode import Cardano.Api.Era.Internal.Case import Cardano.Api.Era.Internal.Core +import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra import Cardano.Api.Genesis.Internal.Parameters import Cardano.Api.HasTypeProxy (HasTypeProxy (..), Proxy) @@ -93,12 +94,11 @@ import Cardano.Ledger.Api qualified as L import Cardano.Ledger.Api.State.Query qualified as L import Cardano.Ledger.Binary import Cardano.Ledger.Binary.Plain qualified as Plain -import Cardano.Ledger.CertState qualified as L import Cardano.Ledger.Coin qualified as L +import Cardano.Ledger.Conway.State qualified as L import Cardano.Ledger.Credential qualified as Shelley import Cardano.Ledger.Shelley.API qualified as Shelley import Cardano.Ledger.Shelley.Core qualified as Core -import Cardano.Ledger.Shelley.LedgerState qualified as L import Cardano.Slotting.EpochInfo (hoistEpochInfo) import Cardano.Slotting.Slot (WithOrigin (..)) import Cardano.Slotting.Time (SystemStart (..)) @@ -116,9 +116,8 @@ import Ouroboros.Consensus.Ledger.Query qualified as Consensus import Ouroboros.Consensus.Protocol.Abstract qualified as Consensus import Ouroboros.Consensus.Shelley.Ledger qualified as Consensus import Ouroboros.Consensus.Shelley.Ledger.Query.Types qualified as Consensus -import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) import Ouroboros.Network.Block (Serialised (..)) -import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type import Ouroboros.Network.Protocol.LocalStateQuery.Client (Some (..)) import Codec.Serialise qualified as CBOR @@ -286,7 +285,7 @@ data QueryInShelleyBasedEra era result where :: Set StakeCredential -> QueryInShelleyBasedEra era (Map StakeCredential L.Coin) QueryAccountState - :: QueryInShelleyBasedEra era L.AccountState + :: QueryInShelleyBasedEra era L.ChainAccountState QueryConstitution :: QueryInShelleyBasedEra era (L.Constitution (ShelleyLedgerEra era)) QueryGovState @@ -406,7 +405,7 @@ decodePoolState (SerialisedPoolState (Serialised ls)) = newtype SerialisedPoolDistribution era = SerialisedPoolDistribution - (Serialised (Consensus.PoolDistr StandardCrypto)) + (Serialised Shelley.PoolDistr) newtype PoolDistribution era = PoolDistribution { unPoolDistr :: Consensus.PoolDistr StandardCrypto @@ -477,15 +476,15 @@ fromLedgerUTxO sbe (Shelley.UTxO utxo) = $ utxo fromShelleyPoolDistr - :: Consensus.PoolDistr StandardCrypto + :: Shelley.PoolDistr -> Map (Hash StakePoolKey) Rational fromShelleyPoolDistr = -- TODO: write an appropriate property to show it is safe to use -- Map.fromListAsc or to use Map.mapKeysMonotonic fromList - . map (bimap StakePoolKeyHash Consensus.individualPoolStake) + . map (bimap StakePoolKeyHash Shelley.individualPoolStake) . toList - . Consensus.unPoolDistr + . Shelley.unPoolDistr fromShelleyDelegations :: Map @@ -564,7 +563,7 @@ toConsensusQueryShelleyBased sbe = \case QueryProtocolParameters -> Some (consensusQueryInEraInMode era Consensus.GetCurrentPParams) QueryStakeDistribution -> - Some (consensusQueryInEraInMode era Consensus.GetStakeDistribution) + Some (consensusQueryInEraInMode era Consensus.GetStakeDistribution2) QueryUTxO QueryUTxOWhole -> Some (consensusQueryInEraInMode era Consensus.GetUTxOWhole) QueryUTxO (QueryUTxOByAddress addrs) -> @@ -613,7 +612,7 @@ toConsensusQueryShelleyBased sbe = \case ) QueryPoolDistribution poolIds -> Some - (consensusQueryInEraInMode era (Consensus.GetCBOR (Consensus.GetPoolDistr (getPoolIds <$> poolIds)))) + (consensusQueryInEraInMode era (Consensus.GetCBOR (Consensus.GetPoolDistr2 (getPoolIds <$> poolIds)))) where getPoolIds :: Set PoolId -> Set (Shelley.KeyHash Shelley.StakePool) getPoolIds = Set.map (\(StakePoolKeyHash kh) -> kh) @@ -640,7 +639,9 @@ toConsensusQueryShelleyBased sbe = \case QueryDRepState creds -> caseShelleyToBabbageOrConwayEraOnwards (const $ error "toConsensusQueryShelleyBased: QueryDRepState is only available in the Conway era") - (const $ Some (consensusQueryInEraInMode era (Consensus.GetDRepState creds))) + ( \w -> + Some (consensusQueryInEraInMode era (conwayEraOnwardsConstraints w $ Consensus.GetDRepState creds)) + ) sbe QueryDRepStakeDistr dreps -> caseShelleyToBabbageOrConwayEraOnwards @@ -727,6 +728,7 @@ consensusQueryInEraInMode erainmode b = AlonzoEra -> Consensus.QueryIfCurrentAlonzo b BabbageEra -> Consensus.QueryIfCurrentBabbage b ConwayEra -> Consensus.QueryIfCurrentConway b + DijkstraEra -> Consensus.QueryIfCurrentDijkstra b -- ---------------------------------------------------------------------------- -- Conversions of query results from the consensus types. @@ -849,6 +851,18 @@ fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraConw ) r' _ -> fromConsensusQueryResultMismatch +fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraDijkstra q)) q' r' = + case q' of + Consensus.BlockQuery (Consensus.QueryIfCurrentDijkstra q'') -> + bimap + fromConsensusEraMismatch + ( fromConsensusQueryResultShelleyBased + ShelleyBasedEraDijkstra + q + q'' + ) + r' + _ -> fromConsensusQueryResultMismatch -- This function is written like this so that we have exhaustive pattern checking -- on the @QueryInShelleyBasedEra era result@ value. Don't change the top-level @@ -858,7 +872,6 @@ fromConsensusQueryResultShelleyBased . HasCallStack => ShelleyLedgerEra era ~ ledgerera => ConsensusProtocol era ~ protocol - => ProtoCrypto protocol ~ StandardCrypto => ShelleyBasedEra era -> QueryInShelleyBasedEra era result -> Consensus.BlockQuery (Consensus.ShelleyBlock protocol ledgerera) fp result' @@ -884,7 +897,7 @@ fromConsensusQueryResultShelleyBased sbe sbeQuery q' r' = _ -> fromConsensusQueryResultMismatch QueryStakeDistribution -> case q' of - Consensus.GetStakeDistribution -> fromShelleyPoolDistr r' + Consensus.GetStakeDistribution2 -> fromShelleyPoolDistr r' _ -> fromConsensusQueryResultMismatch QueryUTxO QueryUTxOWhole -> case q' of @@ -939,7 +952,7 @@ fromConsensusQueryResultShelleyBased sbe sbeQuery q' r' = _ -> fromConsensusQueryResultMismatch QueryPoolDistribution{} -> case q' of - Consensus.GetCBOR Consensus.GetPoolDistr{} -> + Consensus.GetCBOR Consensus.GetPoolDistr2{} -> SerialisedPoolDistribution r' _ -> fromConsensusQueryResultMismatch QueryStakeSnapshot{} -> From 02d5c73e554cee7cf27bc2879c05feb70476fa8f Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 09:23:51 -0400 Subject: [PATCH 07/26] Update `makeShelleyTransactionBody` with Dijkstra era --- .../src/Cardano/Api/Tx/Internal/Body.hs | 210 ++++++++++++++++-- 1 file changed, 196 insertions(+), 14 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs index 61dff7f7ad..a2f75f7c59 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Body.hs @@ -280,7 +280,6 @@ import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import Cardano.Ledger.Binary (Annotated (..)) import Cardano.Ledger.Binary qualified as CBOR import Cardano.Ledger.Coin qualified as L -import Cardano.Ledger.Conway.Core qualified as L import Cardano.Ledger.Core () import Cardano.Ledger.Core qualified as Ledger import Cardano.Ledger.Credential qualified as Shelley @@ -1426,6 +1425,13 @@ validateTxBodyContent validateMetadata txMetadata validateTxInsCollateral txInsCollateral languages validateProtocolParameters txProtocolParams languages + ShelleyBasedEraDijkstra -> do + validateTxIns txIns + first TxBodyOutputError $ + validateTxOuts sbe txOuts + validateMetadata txMetadata + validateTxInsCollateral txInsCollateral languages + validateProtocolParameters txProtocolParams languages validateMetadata :: TxMetadataInEra era -> Either TxBodyError () validateMetadata txMetadata = @@ -1590,6 +1596,7 @@ fromLedgerTxIns sbe body = inputs_ ShelleyBasedEraAlonzo = view L.inputsTxBodyL inputs_ ShelleyBasedEraBabbage = view L.inputsTxBodyL inputs_ ShelleyBasedEraConway = view L.inputsTxBodyL + inputs_ ShelleyBasedEraDijkstra = view L.inputsTxBodyL fromLedgerTxInsCollateral :: forall era @@ -1696,6 +1703,11 @@ fromLedgerAuxiliaryData ShelleyBasedEraConway txAuxData = , fromShelleyBasedScript ShelleyBasedEraConway <$> toList (L.getAlonzoTxAuxDataScripts txAuxData) ) +fromLedgerAuxiliaryData ShelleyBasedEraDijkstra txAuxData = + ( fromShelleyMetadata (L.atadMetadata txAuxData) + , fromShelleyBasedScript ShelleyBasedEraDijkstra + <$> toList (L.getAlonzoTxAuxDataScripts txAuxData) + ) fromLedgerTxAuxiliaryData :: ShelleyBasedEra era @@ -2033,7 +2045,10 @@ mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData = & L.auxDataHashTxBodyL .~ maybe SNothing (SJust . Ledger.hashTxAuxData) txAuxData -{-# DEPRECATED makeShelleyTransactionBody "Use 'createTransactionBody' instead." #-} +{-# DEPRECATED + makeShelleyTransactionBody + "Use 'createTransactionBody' instead. 'makeShelleyTransactionBody' will be removed after 11.0.0.0 release" + #-} makeShelleyTransactionBody :: forall era . () @@ -2593,6 +2608,159 @@ makeShelleyTransactionBody txAuxData :: Maybe (L.TxAuxData E.ConwayEra) txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts +makeShelleyTransactionBody + sbe@ShelleyBasedEraDijkstra + txbodycontent@TxBodyContent + { txIns + , txInsCollateral + , txInsReference + , txReturnCollateral + , txTotalCollateral + , txOuts + , txFee + , txValidityLowerBound + , txValidityUpperBound + , txMetadata + , txAuxScripts + , txExtraKeyWits + , txProtocolParams + , txWithdrawals + , txCertificates + , txMintValue + , txScriptValidity + , txProposalProcedures + , txVotingProcedures + , txCurrentTreasuryValue + , txTreasuryDonation + } = do + let aOn = AllegraEraOnwardsDijkstra + let cOn = ConwayEraOnwardsDijkstra + let mOn = MaryEraOnwardsDijkstra + let bOn = BabbageEraOnwardsDijkstra + validateTxBodyContent sbe txbodycontent + let scriptIntegrityHash = + convPParamsToScriptIntegrityHash + AlonzoEraOnwardsDijkstra + txProtocolParams + redeemers + datums + languages + let txbody = + ( mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData + & A.collateralInputsTxBodyL azOn + .~ case txInsCollateral of + TxInsCollateralNone -> Set.empty + TxInsCollateral _ txins -> fromList (map toShelleyTxIn txins) + & A.referenceInputsTxBodyL bOn + .~ convReferenceInputs txInsReference + & A.collateralReturnTxBodyL bOn + .~ convReturnCollateral sbe txReturnCollateral + & A.totalCollateralTxBodyL bOn + .~ convTotalCollateral txTotalCollateral + & A.certsTxBodyL sbe + .~ convCertificates sbe txCertificates + & A.invalidBeforeTxBodyL aOn + .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe + .~ convValidityUpperBound sbe txValidityUpperBound + & A.reqSignerHashesTxBodyL azOn + .~ convExtraKeyWitnesses txExtraKeyWits + & A.mintTxBodyL mOn + .~ convMintValue txMintValue + & A.scriptIntegrityHashTxBodyL azOn + .~ scriptIntegrityHash + & A.votingProceduresTxBodyL cOn + .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured txVotingProcedures) + & A.proposalProceduresTxBodyL cOn + .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured txProposalProcedures) + & A.currentTreasuryValueTxBodyL cOn + .~ Ledger.maybeToStrictMaybe (unFeatured =<< txCurrentTreasuryValue) + & A.treasuryDonationTxBodyL cOn + .~ maybe (L.Coin 0) unFeatured txTreasuryDonation + -- TODO Conway: support optional network id in TxBodyContent + -- & L.networkIdTxBodyL .~ SNothing + ) + ^. A.txBodyL + return $ + ShelleyTxBody + sbe + txbody + scripts + ( TxBodyScriptData + AlonzoEraOnwardsDijkstra + datums + redeemers + ) + txAuxData + txScriptValidity + where + azOn = AlonzoEraOnwardsDijkstra + + witnesses :: [(ScriptWitnessIndex, AnyScriptWitness DijkstraEra)] + witnesses = collectTxBodyScriptWitnesses sbe txbodycontent + + scripts :: [Ledger.Script L.DijkstraEra] + scripts = + catMaybes + [ toShelleyScript <$> getScriptWitnessScript scriptwitness + | (_, AnyScriptWitness scriptwitness) <- witnesses + ] + + -- Note these do not include inline datums! + datums :: Alonzo.TxDats L.DijkstraEra + datums = + Alonzo.TxDats $ + fromList + [ (L.hashData d, d) + | d <- toAlonzoData <$> scriptdata + ] + + scriptdata :: [HashableScriptData] + scriptdata = + [d | TxOut _ _ (TxOutSupplementalDatum _ d) _ <- txOuts] + <> [ d + | ( _ + , AnyScriptWitness + ( PlutusScriptWitness + _ + _ + _ + (ScriptDatumForTxIn (Just d)) + _ + _ + ) + ) <- + witnesses + ] + + redeemers :: Alonzo.Redeemers L.DijkstraEra + redeemers = + Alonzo.Redeemers $ + fromList + [ (i, (toAlonzoData d, toAlonzoExUnits e)) + | ( idx + , AnyScriptWitness + (PlutusScriptWitness _ _ _ _ d e) + ) <- + witnesses + , Just i <- [fromScriptWitnessIndex azOn idx] + ] + + languages :: Set Plutus.Language + languages = + fromList $ + catMaybes + [ getScriptLanguage sw + | (_, AnyScriptWitness sw) <- witnesses + ] + + getScriptLanguage :: ScriptWitness witctx era -> Maybe Plutus.Language + getScriptLanguage (PlutusScriptWitness _ v _ _ _ _) = + Just $ toAlonzoLanguage (AnyPlutusScriptVersion v) + getScriptLanguage SimpleScriptWitness{} = Nothing + + txAuxData :: Maybe (L.TxAuxData L.DijkstraEra) + txAuxData = toAuxiliaryData sbe txMetadata txAuxScripts -- ---------------------------------------------------------------------------- -- Script witnesses within the tx body @@ -2697,6 +2865,7 @@ fromScriptWitnessIndex aOnwards widx = AlonzoEraOnwardsAlonzo -> fromScriptWitnessIndexAlonzo widx AlonzoEraOnwardsBabbage -> fromScriptWitnessIndexBabbage widx AlonzoEraOnwardsConway -> fromScriptWitnessIndexConway widx + AlonzoEraOnwardsDijkstra -> fromScriptWitnessIndexDijkstra widx fromScriptWitnessIndexAlonzo :: ScriptWitnessIndex -> Maybe (L.PlutusPurpose L.AsIx (ShelleyLedgerEra AlonzoEra)) @@ -2729,6 +2898,17 @@ fromScriptWitnessIndexConway i = ScriptWitnessIndexVoting n -> Just $ L.ConwayVoting (L.AsIx n) ScriptWitnessIndexProposing n -> Just $ L.ConwayProposing (L.AsIx n) +fromScriptWitnessIndexDijkstra + :: ScriptWitnessIndex -> Maybe (L.PlutusPurpose L.AsIx (ShelleyLedgerEra DijkstraEra)) +fromScriptWitnessIndexDijkstra i = + case i of + ScriptWitnessIndexTxIn n -> Just $ L.ConwaySpending (L.AsIx n) + ScriptWitnessIndexMint n -> Just $ L.ConwayMinting (L.AsIx n) + ScriptWitnessIndexCertificate n -> Just $ L.ConwayCertifying (L.AsIx n) + ScriptWitnessIndexWithdrawal n -> Just $ L.ConwayRewarding (L.AsIx n) + ScriptWitnessIndexVoting n -> Just $ L.ConwayVoting (L.AsIx n) + ScriptWitnessIndexProposing n -> Just $ L.ConwayProposing (L.AsIx n) + toScriptIndex :: AlonzoEraOnwards era -> L.PlutusPurpose L.AsIx (ShelleyLedgerEra era) @@ -2738,6 +2918,7 @@ toScriptIndex sbe scriptPurposeIndex = AlonzoEraOnwardsAlonzo -> toScriptIndexAlonzo scriptPurposeIndex AlonzoEraOnwardsBabbage -> toScriptIndexAlonzo scriptPurposeIndex AlonzoEraOnwardsConway -> toScriptIndexConway scriptPurposeIndex + AlonzoEraOnwardsDijkstra -> toScriptIndexConway scriptPurposeIndex toScriptIndexAlonzo :: L.AlonzoPlutusPurpose L.AsIx (ShelleyLedgerEra era) @@ -3002,18 +3183,17 @@ extractWitnessableVotes :: ConwayEraOnwards era -> TxBodyContent BuildTx era -> [(Witnessable VoterItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))] -extractWitnessableVotes e@ConwayEraOnwardsConway TxBodyContent{txVotingProcedures} = +extractWitnessableVotes e TxBodyContent{txVotingProcedures} = List.nub - [ (WitVote vote, BuildTxWith wit) - | (vote, wit) <- getVotes e $ maybe TxVotingProceduresNone unFeatured txVotingProcedures + [ (conwayEraOnwardsConstraints e $ WitVote vote, BuildTxWith wit) + | (vote, wit) <- getVotes $ maybe TxVotingProceduresNone unFeatured txVotingProcedures ] where getVotes - :: ConwayEraOnwards era - -> TxVotingProcedures BuildTx era + :: TxVotingProcedures BuildTx era -> [(L.Voter, Witness WitCtxStake era)] - getVotes ConwayEraOnwardsConway TxVotingProceduresNone = [] - getVotes ConwayEraOnwardsConway (TxVotingProcedures allVotingProcedures (BuildTxWith scriptWitnessedVotes)) = + getVotes TxVotingProceduresNone = [] + getVotes (TxVotingProcedures allVotingProcedures (BuildTxWith scriptWitnessedVotes)) = [ (voter, wit) | (voter, _) <- toList $ L.unVotingProcedures allVotingProcedures , let wit = case Map.lookup voter scriptWitnessedVotes of @@ -3025,9 +3205,9 @@ extractWitnessableProposals :: ConwayEraOnwards era -> TxBodyContent BuildTx era -> [(Witnessable ProposalItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))] -extractWitnessableProposals e@ConwayEraOnwardsConway TxBodyContent{txProposalProcedures} = +extractWitnessableProposals e TxBodyContent{txProposalProcedures} = List.nub - [ (WitProposal prop, BuildTxWith wit) + [ (conwayEraOnwardsConstraints e $ WitProposal prop, BuildTxWith wit) | (Proposal prop, wit) <- getProposals e $ maybe TxProposalProceduresNone unFeatured txProposalProcedures ] @@ -3036,9 +3216,9 @@ extractWitnessableProposals e@ConwayEraOnwardsConway TxBodyContent{txProposalPro :: ConwayEraOnwards era -> TxProposalProcedures BuildTx era -> [(Proposal era, Witness WitCtxStake era)] - getProposals ConwayEraOnwardsConway TxProposalProceduresNone = [] - getProposals ConwayEraOnwardsConway (TxProposalProcedures txps) = - [ (Proposal p, wit) + getProposals _ TxProposalProceduresNone = [] + getProposals w (TxProposalProcedures txps) = + [ (conwayEraOnwardsConstraints w $ Proposal p, wit) | (p, BuildTxWith mScriptWit) <- toList txps , let wit = case mScriptWit of Just sWit -> ScriptWitness ScriptWitnessForStakeAddr sWit @@ -3089,6 +3269,8 @@ toAuxiliaryData sbe txMetadata txAuxScripts = guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss ShelleyBasedEraConway -> guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss + ShelleyBasedEraDijkstra -> + guard (not (Map.null ms && null ss)) $> L.mkAlonzoTxAuxData ms ss -- ---------------------------------------------------------------------------- -- Other utilities helpful with making transaction bodies From 8dc13ee9459321fc10ce3cd203071e2cb6c75bf1 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 09:27:30 -0400 Subject: [PATCH 08/26] Update ledger types `PParamUpdatePurpose`, `CommitteePurpose` and `ConstitutionPurpose` --- .../Governance/Internal/Action/ProposalProcedure.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Governance/Internal/Action/ProposalProcedure.hs b/cardano-api/src/Cardano/Api/Governance/Internal/Action/ProposalProcedure.hs index f1b6002bb4..6ca5b03cfb 100644 --- a/cardano-api/src/Cardano/Api/Governance/Internal/Action/ProposalProcedure.hs +++ b/cardano-api/src/Cardano/Api/Governance/Internal/Action/ProposalProcedure.hs @@ -44,13 +44,13 @@ data AnyGovernanceAction = forall era. AnyGovernanceAction (Gov.GovAction era) -- TODO: Conway - Transitiion to Ledger.GovAction data GovernanceAction era = MotionOfNoConfidence - (StrictMaybe (Ledger.GovPurposeId Ledger.CommitteePurpose (ShelleyLedgerEra era))) + (StrictMaybe (Ledger.GovPurposeId Ledger.CommitteePurpose)) | ProposeNewConstitution - (StrictMaybe (Ledger.GovPurposeId Ledger.ConstitutionPurpose (ShelleyLedgerEra era))) + (StrictMaybe (Ledger.GovPurposeId Ledger.ConstitutionPurpose)) Ledger.Anchor (StrictMaybe Shelley.ScriptHash) | ProposeNewCommittee - (StrictMaybe (Ledger.GovPurposeId Ledger.CommitteePurpose (ShelleyLedgerEra era))) + (StrictMaybe (Ledger.GovPurposeId Ledger.CommitteePurpose)) [L.Credential ColdCommitteeRole] -- ^ Old constitutional committee (Map (L.Credential ColdCommitteeRole) EpochNo) @@ -63,11 +63,11 @@ data GovernanceAction era [(Network, StakeCredential, L.Coin)] !(StrictMaybe Shelley.ScriptHash) | InitiateHardfork - (StrictMaybe (Ledger.GovPurposeId Ledger.HardForkPurpose (ShelleyLedgerEra era))) + (StrictMaybe (Ledger.GovPurposeId Ledger.HardForkPurpose)) ProtVer | -- | Governance policy UpdatePParams - (StrictMaybe (Ledger.GovPurposeId Ledger.PParamUpdatePurpose (ShelleyLedgerEra era))) + (StrictMaybe (Ledger.GovPurposeId Ledger.PParamUpdatePurpose)) (Ledger.PParamsUpdate (ShelleyLedgerEra era)) !(StrictMaybe Shelley.ScriptHash) From 78c18d7b8fbc5c6cfc1c46d9a18fbdf97371a736 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 09:29:25 -0400 Subject: [PATCH 09/26] Propagate `ChainAccountState` --- cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs | 6 +++--- cardano-api/src/Cardano/Api/Query/Internal/Convenience.hs | 7 +++---- cardano-api/src/Cardano/Api/Query/Internal/Expr.hs | 5 ++--- 3 files changed, 8 insertions(+), 10 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs b/cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs index 2f9e04bbaf..9119706bfa 100644 --- a/cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs +++ b/cardano-api/src/Cardano/Api/Ledger/Internal/Reexport.hs @@ -112,7 +112,7 @@ module Cardano.Api.Ledger.Internal.Reexport , toPlainDecoder -- Shelley , secondsToNominalDiffTimeMicro - , AccountState (..) + , AccountState , NewEpochState (..) , ShelleyGenesisStaking (..) -- Babbage @@ -266,7 +266,6 @@ import Cardano.Ledger.Binary , toPlainDecoder ) import Cardano.Ledger.Binary.Plain (Decoder, serializeAsHexText) -import Cardano.Ledger.CertState (DRepState (..), csCommitteeCredsL) import Cardano.Ledger.Coin (Coin (..), addDeltaCoin, toDeltaCoin) import Cardano.Ledger.Conway.Core ( DRepVotingThresholds (..) @@ -293,6 +292,7 @@ import Cardano.Ledger.Conway.Governance ) import Cardano.Ledger.Conway.PParams (UpgradeConwayPParams (..)) import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..)) +import Cardano.Ledger.Conway.State (DRepState (..), csCommitteeCredsL) import Cardano.Ledger.Conway.TxCert ( ConwayDelegCert (..) , ConwayEraTxCert (..) @@ -336,7 +336,7 @@ import Cardano.Ledger.Plutus.Data (Data (..), unData) import Cardano.Ledger.Plutus.Language (Language, Plutus, languageToText, plutusBinary) import Cardano.Ledger.PoolParams (PoolMetadata (..), PoolParams (..), StakePoolRelay (..)) import Cardano.Ledger.Shelley.API - ( AccountState (..) + ( AccountState , GenDelegPair (..) , NewEpochState (..) , StakeReference (..) diff --git a/cardano-api/src/Cardano/Api/Query/Internal/Convenience.hs b/cardano-api/src/Cardano/Api/Query/Internal/Convenience.hs index b85c89e1f4..8772226334 100644 --- a/cardano-api/src/Cardano/Api/Query/Internal/Convenience.hs +++ b/cardano-api/src/Cardano/Api/Query/Internal/Convenience.hs @@ -36,11 +36,10 @@ import Cardano.Api.Query.Internal.Type.QueryInMode import Cardano.Api.Tx.Internal.Body import Cardano.Api.UTxO (UTxO (..)) -import Cardano.Ledger.CertState (DRepState (..)) import Cardano.Ledger.Coin qualified as L +import Cardano.Ledger.Conway.State (ChainAccountState (..), DRepState (..)) import Cardano.Ledger.Credential qualified as L import Cardano.Ledger.Keys qualified as L -import Cardano.Ledger.Shelley.LedgerState qualified as L import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch (..)) import Ouroboros.Network.Protocol.LocalStateQuery.Type (Target (..)) @@ -168,11 +167,11 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do caseShelleyToBabbageOrConwayEraOnwards (const $ pure Nothing) ( \cOnwards -> do - L.AccountState{L.asTreasury} <- + chainAccountState <- lift (queryAccountState cOnwards) & onLeft (left . QceUnsupportedNtcVersion) & onLeft (left . QueryEraMismatch) - let txCurrentTreasuryValue = TxCurrentTreasuryValue asTreasury + let txCurrentTreasuryValue = TxCurrentTreasuryValue $ casTreasury chainAccountState return $ Just $ Featured cOnwards txCurrentTreasuryValue ) sbe diff --git a/cardano-api/src/Cardano/Api/Query/Internal/Expr.hs b/cardano-api/src/Cardano/Api/Query/Internal/Expr.hs index 46f0b305dd..a29834edee 100644 --- a/cardano-api/src/Cardano/Api/Query/Internal/Expr.hs +++ b/cardano-api/src/Cardano/Api/Query/Internal/Expr.hs @@ -59,12 +59,11 @@ import Cardano.Api.UTxO import Cardano.Ledger.Api qualified as L import Cardano.Ledger.Api.State.Query qualified as L -import Cardano.Ledger.CertState qualified as L import Cardano.Ledger.Coin qualified as L +import Cardano.Ledger.Conway.State qualified as L import Cardano.Ledger.Credential qualified as L import Cardano.Ledger.Hashes hiding (Hash) import Cardano.Ledger.Keys qualified as L -import Cardano.Ledger.Shelley.LedgerState qualified as L import Cardano.Slotting.Slot import Ouroboros.Consensus.Cardano.Block qualified as Consensus import Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus @@ -484,7 +483,7 @@ queryAccountState QueryInMode r IO - (Either UnsupportedNtcVersionError (Either EraMismatch L.AccountState)) + (Either UnsupportedNtcVersionError (Either EraMismatch L.ChainAccountState)) queryAccountState eon = querySbe eon QueryAccountState queryProposals From 0c45a9b5e53f7f6864a42ffa493fb2e25f0b2e78 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 09:33:02 -0400 Subject: [PATCH 10/26] Consensus related Dijkstra changes --- .../src/Cardano/Api/Consensus/Internal/InMode.hs | 15 +++++++++++++++ .../src/Cardano/Api/Consensus/Internal/Mode.hs | 7 +++++++ 2 files changed, 22 insertions(+) diff --git a/cardano-api/src/Cardano/Api/Consensus/Internal/InMode.hs b/cardano-api/src/Cardano/Api/Consensus/Internal/InMode.hs index ca10b1abd5..8fea91d371 100644 --- a/cardano-api/src/Cardano/Api/Consensus/Internal/InMode.hs +++ b/cardano-api/src/Cardano/Api/Consensus/Internal/InMode.hs @@ -100,6 +100,9 @@ fromConsensusGenTx = \case Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (Z tx')))))))) -> let Consensus.ShelleyTx _txid shelleyEraTx = tx' in TxInMode ShelleyBasedEraConway (ShelleyTx ShelleyBasedEraConway shelleyEraTx) + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (S (Z tx'))))))))) -> + let Consensus.ShelleyTx _txid shelleyEraTx = tx' + in TxInMode ShelleyBasedEraDijkstra (ShelleyTx ShelleyBasedEraDijkstra shelleyEraTx) toConsensusGenTx :: () @@ -132,6 +135,10 @@ toConsensusGenTx (TxInMode ShelleyBasedEraConway (ShelleyTx _ tx)) = Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (Z tx')))))))) where tx' = Consensus.mkShelleyTx tx +toConsensusGenTx (TxInMode ShelleyBasedEraDijkstra (ShelleyTx _ tx)) = + Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (S (Z tx'))))))))) + where + tx' = Consensus.mkShelleyTx tx -- ---------------------------------------------------------------------------- -- Transaction ids in the context of a consensus mode @@ -193,6 +200,12 @@ toConsensusTxId (TxIdInMode ConwayEra txid) = where txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardConwayBlock) txid' = Consensus.ShelleyTxId $ toShelleyTxId txid +toConsensusTxId (TxIdInMode DijkstraEra txid) = + Consensus.HardForkGenTxId + (Consensus.OneEraGenTxId (S (S (S (S (S (S (S (Z (Consensus.WrapGenTxId txid')))))))))) + where + txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardDijkstraBlock) + txid' = Consensus.ShelleyTxId $ toShelleyTxId txid -- ---------------------------------------------------------------------------- -- Transaction validation errors in the context of eras and consensus modes @@ -300,5 +313,7 @@ fromConsensusApplyTxErr = \case TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraBabbage err Consensus.ApplyTxErrConway err -> TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraConway err + Consensus.ApplyTxErrDijkstra err -> + TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraDijkstra err Consensus.ApplyTxErrWrongEra err -> TxValidationEraMismatch err diff --git a/cardano-api/src/Cardano/Api/Consensus/Internal/Mode.hs b/cardano-api/src/Cardano/Api/Consensus/Internal/Mode.hs index c4e4100c16..a51cf0f26e 100644 --- a/cardano-api/src/Cardano/Api/Consensus/Internal/Mode.hs +++ b/cardano-api/src/Cardano/Api/Consensus/Internal/Mode.hs @@ -83,6 +83,7 @@ type family ConsensusBlockForEra era where ConsensusBlockForEra AlonzoEra = Consensus.StandardAlonzoBlock ConsensusBlockForEra BabbageEra = Consensus.StandardBabbageBlock ConsensusBlockForEra ConwayEra = Consensus.StandardConwayBlock + ConsensusBlockForEra DijkstraEra = Consensus.StandardDijkstraBlock type family ConsensusCryptoForBlock block where ConsensusCryptoForBlock Consensus.ByronBlockHFC = StandardCrypto @@ -98,6 +99,7 @@ type family ConsensusProtocol era where ConsensusProtocol AlonzoEra = Consensus.TPraos StandardCrypto ConsensusProtocol BabbageEra = Consensus.Praos StandardCrypto ConsensusProtocol ConwayEra = Consensus.Praos StandardCrypto + ConsensusProtocol DijkstraEra = Consensus.Praos StandardCrypto type family ChainDepStateProtocol era where ChainDepStateProtocol ShelleyEra = Consensus.TPraosState @@ -128,6 +130,9 @@ eraIndex5 = eraIndexSucc eraIndex4 eraIndex6 :: Consensus.EraIndex (x6 : x5 : x4 : x3 : x2 : x1 : x0 : xs) eraIndex6 = eraIndexSucc eraIndex5 +eraIndex7 :: Consensus.EraIndex (x7 : x6 : x5 : x4 : x3 : x2 : x1 : x0 : xs) +eraIndex7 = eraIndexSucc eraIndex6 + toConsensusEraIndex :: () => Consensus.CardanoBlock StandardCrypto ~ Consensus.HardForkBlock xs @@ -141,6 +146,7 @@ toConsensusEraIndex = \case AlonzoEra -> eraIndex4 BabbageEra -> eraIndex5 ConwayEra -> eraIndex6 + DijkstraEra -> eraIndex7 fromConsensusEraIndex :: () @@ -161,3 +167,4 @@ fromConsensusEraIndex = \case AnyCardanoEra BabbageEra Consensus.EraIndex (S (S (S (S (S (S (Z (K ())))))))) -> AnyCardanoEra ConwayEra + Consensus.EraIndex (S (S (S (S (S (S (S _))))))) -> error "dijkstra" From 57f3e4271e46bb77304af42786dc79998ecdba36 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 09:33:58 -0400 Subject: [PATCH 11/26] Temporary Cardano.Api.LedgerState Dijkstra update Dijkstra genesis file needs to be parseable --- cardano-api/src/Cardano/Api/LedgerState.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index 382da1e351..eef2df7e8c 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -159,6 +159,7 @@ import Cardano.Ledger.BaseTypes qualified as Ledger import Cardano.Ledger.Binary (DecoderError) import Cardano.Ledger.Coin qualified as SL import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) +import Cardano.Ledger.Dijkstra.Genesis import Cardano.Ledger.Keys qualified as SL import Cardano.Ledger.Shelley.API qualified as ShelleyAPI import Cardano.Ledger.Shelley.Core qualified as Core @@ -1147,6 +1148,7 @@ instance FromJSON NodeConfig where <*> parseAlonzoHardForkEpoch o <*> parseBabbageHardForkEpoch o <*> parseConwayHardForkEpoch o + <*> error "dijkstra" parseShelleyHardForkEpoch :: Object -> Parser (Consensus.CardanoHardForkTrigger blk) parseShelleyHardForkEpoch o = @@ -1363,7 +1365,7 @@ encodeLedgerState (LedgerState hst@(HFC.HardForkLedgerState st) tbs) = mconcat [ CBOR.encodeListLen 2 , HFC.encodeTelescope - (byron :* shelley :* allegra :* mary :* alonzo :* babbage :* conway :* Nil) + (byron :* shelley :* allegra :* mary :* alonzo :* babbage :* conway :* dijkstra :* Nil) st , Ledger.valuesMKEncoder hst tbs ] @@ -1375,13 +1377,15 @@ encodeLedgerState (LedgerState hst@(HFC.HardForkLedgerState st) tbs) = alonzo = fn (K . Shelley.encodeShelleyLedgerState . unFlip) babbage = fn (K . Shelley.encodeShelleyLedgerState . unFlip) conway = fn (K . Shelley.encodeShelleyLedgerState . unFlip) + dijkstra = fn (K . Shelley.encodeShelleyLedgerState . unFlip) decodeLedgerState :: forall s. CBOR.Decoder s LedgerState decodeLedgerState = do 2 <- CBOR.decodeListLen hst <- HFC.HardForkLedgerState - <$> HFC.decodeTelescope (byron :* shelley :* allegra :* mary :* alonzo :* babbage :* conway :* Nil) + <$> HFC.decodeTelescope + (byron :* shelley :* allegra :* mary :* alonzo :* babbage :* conway :* dijkstra :* Nil) tbs <- Ledger.valuesMKDecoder hst pure (LedgerState hst tbs) where @@ -1392,6 +1396,7 @@ decodeLedgerState = do alonzo = Comp $ Flip <$> Shelley.decodeShelleyLedgerState babbage = Comp $ Flip <$> Shelley.decodeShelleyLedgerState conway = Comp $ Flip <$> Shelley.decodeShelleyLedgerState + dijkstra = Comp $ Flip <$> Shelley.decodeShelleyLedgerState type LedgerStateEvents = (LedgerState, [LedgerEvent]) @@ -1477,7 +1482,8 @@ readCardanoGenesisConfig mEra enc = do ShelleyConfig shelleyGenesis shelleyGenesisHash <- readShelleyGenesisConfig enc alonzoGenesis <- readAlonzoGenesisConfig mEra enc conwayGenesis <- readConwayGenesisConfig enc - let transCfg = Ledger.mkLatestTransitionConfig shelleyGenesis alonzoGenesis conwayGenesis + let dijkstraGenesis = DijkstraGenesis $ error "dijkstra" + let transCfg = Ledger.mkLatestTransitionConfig shelleyGenesis alonzoGenesis conwayGenesis dijkstraGenesis pure $ GenesisCardano enc byronGenesis shelleyGenesisHash transCfg data GenesisConfigError From 25e69dcee3b61d2fc3663ccc4996990b6d3fe3c0 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 09:50:05 -0400 Subject: [PATCH 12/26] Update TxOut rendering to handle Dijkstra era --- .../src/Cardano/Api/Tx/Internal/Output.hs | 125 ++++++++++++++++-- 1 file changed, 113 insertions(+), 12 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs index c000b7dead..f09fbd76dc 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs @@ -60,6 +60,7 @@ import Cardano.Api.Era.Internal.Core import Cardano.Api.Era.Internal.Eon.AlonzoEraOnwards import Cardano.Api.Era.Internal.Eon.BabbageEraOnwards import Cardano.Api.Era.Internal.Eon.Convert +import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra import Cardano.Api.Error (Error (..), displayError) import Cardano.Api.Hash @@ -209,6 +210,14 @@ fromLedgerTxOuts sbe body scriptdata = | let txdatums = selectTxDatums scriptdata , txouts <- toList (body ^. L.outputsTxBodyL) ] + ShelleyBasedEraDijkstra -> + [ fromBabbageTxOut + BabbageEraOnwardsDijkstra + txdatums + txouts + | let txdatums = selectTxDatums scriptdata + , txouts <- toList (body ^. L.outputsTxBodyL) + ] validateTxOuts :: ShelleyBasedEra era -> [TxOut CtxTx era] -> Either TxOutputError () validateTxOuts sbe txOuts = do @@ -349,6 +358,16 @@ txOutToJsonValue era (TxOut addr val dat refScript) = , "inlineDatumRaw" .= inlineDatumRawJsonCbor dat , "referenceScript" .= refScriptJsonVal refScript ] + DijkstraEra -> + object + [ "address" .= addr + , "value" .= val + , datHashJsonVal dat + , "datum" .= datJsonVal dat + , "inlineDatum" .= inlineDatumJsonVal dat + , "inlineDatumRaw" .= inlineDatumRawJsonCbor dat + , "referenceScript" .= refScriptJsonVal refScript + ] where datHashJsonVal :: TxOutDatum ctx era -> Aeson.Pair datHashJsonVal d = @@ -466,7 +485,31 @@ instance IsShelleyBasedEra era => FromJSON (TxOut CtxTx era) where mReferenceScript <- o .:? "referenceScript" - reconcileConway alonzoTxOutInConway mInlineDatum mReferenceScript + reconcileConway ConwayEraOnwardsConway alonzoTxOutInConway mInlineDatum mReferenceScript + ShelleyBasedEraDijkstra -> do + alonzoTxOutInConway <- alonzoTxOutParser AlonzoEraOnwardsDijkstra o + + -- We check for the existence of inline datums + inlineDatumHash <- o .:? "inlineDatumhash" + inlineDatum <- o .:? "inlineDatum" + mInlineDatum <- + case (inlineDatum, inlineDatumHash) of + (Just dVal, Just h) -> + case scriptDataFromJson ScriptDataJsonDetailedSchema dVal of + Left err -> + fail $ "Error parsing TxOut JSON: " <> displayError err + Right sData -> + if hashScriptDataBytes sData /= h + then fail "Inline datum not equivalent to inline datum hash" + else return $ TxOutDatumInline BabbageEraOnwardsDijkstra sData + (Nothing, Nothing) -> return TxOutDatumNone + (_, _) -> + fail + "Should not be possible to create a tx output with either an inline datum hash or an inline datum" + + mReferenceScript <- o .:? "referenceScript" + + reconcileConway ConwayEraOnwardsDijkstra alonzoTxOutInConway mInlineDatum mReferenceScript where reconcileBabbage :: TxOut CtxTx BabbageEra @@ -496,13 +539,14 @@ instance IsShelleyBasedEra era => FromJSON (TxOut CtxTx era) where return $ TxOut addr v finalDat finalRefScript reconcileConway - :: TxOut CtxTx ConwayEra + :: ConwayEraOnwards era + -> TxOut CtxTx era -- \^ Alonzo era datum in Conway era - -> TxOutDatum CtxTx ConwayEra + -> TxOutDatum CtxTx era -- \^ Babbage inline datum -> Maybe ScriptInAnyLang - -> Aeson.Parser (TxOut CtxTx ConwayEra) - reconcileConway top@(TxOut addr v dat r) babbageDatum mBabRefScript = do + -> Aeson.Parser (TxOut CtxTx era) + reconcileConway w top@(TxOut addr v dat r) babbageDatum mBabRefScript = do -- We check for conflicting datums finalDat <- case (dat, babbageDatum) of (TxOutDatumNone, bDatum) -> return bDatum @@ -519,7 +563,7 @@ instance IsShelleyBasedEra era => FromJSON (TxOut CtxTx era) where finalRefScript <- case mBabRefScript of Nothing -> return r Just anyScript -> - return $ ReferenceScript BabbageEraOnwardsConway anyScript + return $ ReferenceScript (convert w) anyScript return $ TxOut addr v finalDat finalRefScript alonzoTxOutParser @@ -622,7 +666,32 @@ instance IsShelleyBasedEra era => FromJSON (TxOut CtxUTxO era) where -- We check for a reference script mReferenceScript <- o .:? "referenceScript" - reconcileConway alonzoTxOutInConway mInlineDatum mReferenceScript + reconcileConway ConwayEraOnwardsConway alonzoTxOutInConway mInlineDatum mReferenceScript + ShelleyBasedEraDijkstra -> do + alonzoTxOutInConway <- alonzoTxOutParser AlonzoEraOnwardsDijkstra o + + -- We check for the existence of inline datums + inlineDatumHash <- o .:? "inlineDatumhash" + inlineDatum <- o .:? "inlineDatum" + mInlineDatum <- + case (inlineDatum, inlineDatumHash) of + (Just dVal, Just h) -> + case scriptDataFromJson ScriptDataJsonDetailedSchema dVal of + Left err -> + fail $ "Error parsing TxOut JSON: " <> displayError err + Right sData -> + if hashScriptDataBytes sData /= h + then fail "Inline datum not equivalent to inline datum hash" + else return $ TxOutDatumInline BabbageEraOnwardsDijkstra sData + (Nothing, Nothing) -> return TxOutDatumNone + (_, _) -> + fail + "Should not be possible to create a tx output with either an inline datum hash or an inline datum" + + -- We check for a reference script + mReferenceScript <- o .:? "referenceScript" + + reconcileConway ConwayEraOnwardsDijkstra alonzoTxOutInConway mInlineDatum mReferenceScript where reconcileBabbage :: TxOut CtxUTxO BabbageEra @@ -645,13 +714,14 @@ instance IsShelleyBasedEra era => FromJSON (TxOut CtxUTxO era) where return $ TxOut addr v finalDat finalRefScript reconcileConway - :: TxOut CtxUTxO ConwayEra + :: ConwayEraOnwards era + -> TxOut CtxUTxO era -- \^ Alonzo era datum in Conway era - -> TxOutDatum CtxUTxO ConwayEra + -> TxOutDatum CtxUTxO era -- \^ Babbage inline datum -> Maybe ScriptInAnyLang - -> Aeson.Parser (TxOut CtxUTxO ConwayEra) - reconcileConway (TxOut addr v dat r) babbageDatum mBabRefScript = do + -> Aeson.Parser (TxOut CtxUTxO era) + reconcileConway w (TxOut addr v dat r) babbageDatum mBabRefScript = do -- We check for conflicting datums finalDat <- case (dat, babbageDatum) of (TxOutDatumNone, bDatum) -> return bDatum @@ -660,7 +730,7 @@ instance IsShelleyBasedEra era => FromJSON (TxOut CtxUTxO era) where finalRefScript <- case mBabRefScript of Nothing -> return r Just anyScript -> - return $ ReferenceScript BabbageEraOnwardsConway anyScript + return $ ReferenceScript (convert w) anyScript return $ TxOut addr v finalDat finalRefScript @@ -723,6 +793,12 @@ toShelleyTxOut sbe = shelleyBasedEraConstraints sbe $ \case .~ toBabbageTxOutDatumUTxO txoutdata & L.referenceScriptTxOutL .~ refScriptToShelleyScript sbe refScript + AlonzoEraOnwardsDijkstra -> + L.mkBasicTxOut (toShelleyAddr addr) value + & L.datumTxOutL + .~ toBabbageTxOutDatumUTxO txoutdata + & L.referenceScriptTxOutL + .~ refScriptToShelleyScript sbe refScript ) sbe @@ -757,6 +833,12 @@ toShelleyTxOutAny sbe = shelleyBasedEraConstraints sbe $ \case .~ toBabbageTxOutDatum txoutdata & L.referenceScriptTxOutL .~ refScriptToShelleyScript sbe refScript + AlonzoEraOnwardsDijkstra -> + L.mkBasicTxOut (toShelleyAddr addr) value + & L.datumTxOutL + .~ toBabbageTxOutDatum txoutdata + & L.referenceScriptTxOutL + .~ refScriptToShelleyScript sbe refScript ) sbe @@ -819,6 +901,23 @@ fromShelleyTxOut sbe ledgerTxOut = shelleyBasedEraConstraints sbe $ do where datum = ledgerTxOut ^. L.datumTxOutL mRefScript = ledgerTxOut ^. L.referenceScriptTxOutL + ShelleyBasedEraDijkstra -> + TxOut + addressInEra + txOutValue + ( fromBabbageTxOutDatum + AlonzoEraOnwardsDijkstra + BabbageEraOnwardsDijkstra + datum + ) + ( case mRefScript of + SNothing -> ReferenceScriptNone + SJust refScript -> + fromShelleyScriptToReferenceScript ShelleyBasedEraDijkstra refScript + ) + where + datum = ledgerTxOut ^. L.datumTxOutL + mRefScript = ledgerTxOut ^. L.referenceScriptTxOutL -- ---------------------------------------------------------------------------- -- Transaction output values (era-dependent) @@ -1026,6 +1125,8 @@ binaryDataToScriptData BabbageEraOnwardsBabbage d = fromAlonzoData $ L.binaryDataToData d binaryDataToScriptData BabbageEraOnwardsConway d = fromAlonzoData $ L.binaryDataToData d +binaryDataToScriptData BabbageEraOnwardsDijkstra d = + fromAlonzoData $ L.binaryDataToData d data TxOutputError = TxOutputNegative !Quantity !TxOutInAnyEra From 30923afa9382502163a2bc430fc0ffd490ba2d82 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 09:51:25 -0400 Subject: [PATCH 13/26] Update `eraSpecificLedgerTxBody` with Dijkstra era --- .../src/Cardano/Api/Experimental/Tx.hs | 38 ++++++++++--------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx.hs b/cardano-api/src/Cardano/Api/Experimental/Tx.hs index eb42aa7ba6..5e032e20ec 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx.hs @@ -167,7 +167,6 @@ import Cardano.Crypto.Hash qualified as Hash import Cardano.Ledger.Alonzo.TxBody qualified as L import Cardano.Ledger.Api qualified as L import Cardano.Ledger.Binary qualified as Ledger -import Cardano.Ledger.Conway.TxBody qualified as L import Cardano.Ledger.Core qualified as Ledger import Cardano.Ledger.Hashes qualified as L hiding (Hash) @@ -285,7 +284,7 @@ makeUnsignedTx era bc = obtainCommonConstraints era $ do & L.datsTxWitsL .~ datums & L.rdmrsTxWitsL .~ redeemers - eraSpecificTxBody <- eraSpecificLedgerTxBody era ledgerTxBody bc + let eraSpecificTxBody = eraSpecificLedgerTxBody era ledgerTxBody bc return . UnsignedTx $ L.mkBasicTx eraSpecificTxBody @@ -297,22 +296,25 @@ eraSpecificLedgerTxBody :: Era era -> Ledger.TxBody (LedgerEra era) -> TxBodyContent BuildTx era - -> Either TxBodyError (Ledger.TxBody (LedgerEra era)) -eraSpecificLedgerTxBody ConwayEra ledgerbody bc = - let propProcedures = txProposalProcedures bc - voteProcedures = txVotingProcedures bc - treasuryDonation = txTreasuryDonation bc - currentTresuryValue = txCurrentTreasuryValue bc - in return $ - ledgerbody - & L.proposalProceduresTxBodyL - .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured propProcedures) - & L.votingProceduresTxBodyL - .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures) - & L.treasuryDonationTxBodyL - .~ maybe (L.Coin 0) unFeatured treasuryDonation - & L.currentTreasuryValueTxBodyL - .~ L.maybeToStrictMaybe (unFeatured =<< currentTresuryValue) + -> Ledger.TxBody (LedgerEra era) +eraSpecificLedgerTxBody era ledgerbody bc = + body era + where + body e = + let propProcedures = txProposalProcedures bc + voteProcedures = txVotingProcedures bc + treasuryDonation = txTreasuryDonation bc + currentTresuryValue = txCurrentTreasuryValue bc + in obtainCommonConstraints e $ + ledgerbody + & L.proposalProceduresTxBodyL + .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured propProcedures) + & L.votingProceduresTxBodyL + .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures) + & L.treasuryDonationTxBodyL + .~ maybe (L.Coin 0) unFeatured treasuryDonation + & L.currentTreasuryValueTxBodyL + .~ L.maybeToStrictMaybe (unFeatured =<< currentTresuryValue) hashTxBody :: L.HashAnnotated (Ledger.TxBody era) L.EraIndependentTxBody From 866190279956a3e1baf72d58c53ea64ee6b6d5f5 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 12:02:06 -0400 Subject: [PATCH 14/26] Update `decodeBigLedgerPeerSnapshot` to support snapshot SRV names --- .../Cardano/Api/Query/Internal/Type/QueryInMode.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs b/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs index 9b815ef809..7e8bba93d3 100644 --- a/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs +++ b/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs @@ -432,9 +432,16 @@ decodeStakeSnapshot decodeStakeSnapshot (SerialisedStakeSnapshots (Serialised ls)) = StakeSnapshot <$> Plain.decodeFull ls decodeBigLedgerPeerSnapshot - :: Serialised LedgerPeerSnapshot + :: Consensus.ShelleyNodeToClientVersion + -> Serialised LedgerPeerSnapshot -> Either (LBS.ByteString, DecoderError) LedgerPeerSnapshot -decodeBigLedgerPeerSnapshot (Serialised lps) = first (lps,) (Plain.decodeFull lps) +decodeBigLedgerPeerSnapshot ntcV (Serialised lps) = + first + (lps,) + $ Plain.decodeFullDecoder + "LedgerPeerSnapshot" + (decodeLedgerPeerSnapshot $ Consensus.ledgerPeerSnapshotSupportsSRV ntcV) + lps toShelleyAddrSet :: CardanoEra era From f396d6b3718dccfa35034ce7b39b550795d3c88f Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 14:02:59 -0400 Subject: [PATCH 15/26] Update generators with PlutusScriptV4 Implement orphan DijkstraPParams Arbitrary instances --- cardano-api/gen/Test/Gen/Cardano/Api/Era.hs | 4 +++ .../gen/Test/Gen/Cardano/Api/Orphans.hs | 24 +++++++++++++ cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 35 +++++++++++++++++++ 3 files changed, 63 insertions(+) create mode 100644 cardano-api/gen/Test/Gen/Cardano/Api/Orphans.hs diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Era.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Era.hs index d877866925..ddd943db47 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Era.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Era.hs @@ -17,6 +17,8 @@ import Cardano.Ledger.Core qualified as Ledger import Data.Functor.Identity qualified as Ledger +import Test.Gen.Cardano.Api.Orphans () + import Test.Cardano.Ledger.Conway.Arbitrary () import Test.Cardano.Ledger.Core.Arbitrary () @@ -39,6 +41,7 @@ shelleyBasedEraTestConstraints = \case ShelleyBasedEraAlonzo -> id ShelleyBasedEraBabbage -> id ShelleyBasedEraConway -> id + ShelleyBasedEraDijkstra -> id shelleyToBabbageEraTestConstraints :: () @@ -69,3 +72,4 @@ conwayEraOnwardsTestConstraints -> a conwayEraOnwardsTestConstraints = \case ConwayEraOnwardsConway -> id + ConwayEraOnwardsDijkstra -> id diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Orphans.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Orphans.hs new file mode 100644 index 0000000000..b2162f21ad --- /dev/null +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Orphans.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Gen.Cardano.Api.Orphans + ( + ) +where + +import Cardano.Ledger.BaseTypes (StrictMaybe) +import Cardano.Ledger.Dijkstra (DijkstraEra) +import Cardano.Ledger.Dijkstra.PParams (DijkstraPParams) + +import Data.Functor.Identity (Identity) +import Generic.Random (genericArbitraryU) +import Test.Cardano.Ledger.Common (Arbitrary (..)) +import Test.Cardano.Ledger.Conway.Arbitrary () + + +instance Arbitrary (DijkstraPParams Identity DijkstraEra) where + arbitrary = genericArbitraryU + +instance Arbitrary (DijkstraPParams StrictMaybe DijkstraEra) where + arbitrary = genericArbitraryU \ No newline at end of file diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 89a25fd9c1..b9c6231449 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -296,6 +296,9 @@ genPlutusScript l = PlutusScriptV3 -> do PlutusScript _ s <- genPlutusV3Script return s + PlutusScriptV4 -> do + PlutusScript _ s <- genPlutusV4Script + return s genValidPlutusScript :: PlutusScriptVersion lang -> Gen (PlutusScript lang) genValidPlutusScript l = @@ -309,6 +312,9 @@ genValidPlutusScript l = PlutusScriptV3 -> do PlutusScript _ s <- genValidPlutusV3Script return s + PlutusScriptV4 -> do + PlutusScript _ s <- genValidPlutusV4Script + return s genPlutusV1Script :: Gen (Script PlutusScriptV1) genPlutusV1Script = do @@ -341,6 +347,14 @@ genPlutusV3Script = do let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes +-- TODO: This is not generating v4 scripts. +genPlutusV4Script :: Gen (Script PlutusScriptV4) +genPlutusV4Script = do + v3AlwaysSucceedsPlutusScriptHex <- + Gen.element [v3AlwaysSucceedsPlutusScriptDoubleEncoded, v3AlwaysSucceedsPlutusScript] + let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex + return . PlutusScript PlutusScriptV4 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes + genValidPlutusV3Script :: Gen (Script PlutusScriptV3) genValidPlutusV3Script = do v3AlwaysSucceedsPlutusScriptHex <- @@ -348,6 +362,14 @@ genValidPlutusV3Script = do let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes +-- TODO: This is not generating v4 scripts. +genValidPlutusV4Script :: Gen (Script PlutusScriptV4) +genValidPlutusV4Script = do + v3AlwaysSucceedsPlutusScriptHex <- + Gen.element [v3AlwaysSucceedsPlutusScript] + let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex + return . PlutusScript PlutusScriptV4 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes + genScriptDataSchema :: Gen ScriptDataJsonSchema genScriptDataSchema = Gen.element [ScriptDataJsonNoSchema, ScriptDataJsonDetailedSchema] @@ -1327,6 +1349,13 @@ genTxOutDatumHashTxContext era = case era of , TxOutSupplementalDatum AlonzoEraOnwardsConway <$> genHashableScriptData , TxOutDatumInline BabbageEraOnwardsConway <$> genHashableScriptData ] + ShelleyBasedEraDijkstra -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsDijkstra <$> genHashScriptData + , TxOutSupplementalDatum AlonzoEraOnwardsDijkstra <$> genHashableScriptData + , TxOutDatumInline BabbageEraOnwardsDijkstra <$> genHashableScriptData + ] genTxOutDatumHashUTxOContext :: ShelleyBasedEra era -> Gen (TxOutDatum CtxUTxO era) genTxOutDatumHashUTxOContext era = case era of @@ -1350,6 +1379,12 @@ genTxOutDatumHashUTxOContext era = case era of , TxOutDatumHash AlonzoEraOnwardsConway <$> genHashScriptData , TxOutDatumInline BabbageEraOnwardsConway <$> genHashableScriptData ] + ShelleyBasedEraDijkstra -> + Gen.choice + [ pure TxOutDatumNone + , TxOutDatumHash AlonzoEraOnwardsDijkstra <$> genHashScriptData + , TxOutDatumInline BabbageEraOnwardsDijkstra <$> genHashableScriptData + ] mkDummyHash :: forall h a. CRYPTO.HashAlgorithm h => Int -> CRYPTO.Hash h a mkDummyHash = coerce . CRYPTO.hashWithSerialiser @h CBOR.toCBOR From 5b3c1ea5171607d89f5236cfcfd5360f075d77cc Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 14:05:31 -0400 Subject: [PATCH 16/26] Introduce PlutusScriptV4 --- .../src/Cardano/Api/Plutus/Internal/Script.hs | 100 ++++++++++++++++++ .../src/Cardano/Api/ProtocolParameters.hs | 4 + .../src/Cardano/Api/Tx/Internal/Body/Lens.hs | 1 - 3 files changed, 104 insertions(+), 1 deletion(-) diff --git a/cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs b/cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs index 34e236ca71..aeaaa25da3 100644 --- a/cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs +++ b/cardano-api/src/Cardano/Api/Plutus/Internal/Script.hs @@ -24,6 +24,7 @@ module Cardano.Api.Plutus.Internal.Script , PlutusScriptV1 , PlutusScriptV2 , PlutusScriptV3 + , PlutusScriptV4 , ScriptLanguage (..) , PlutusScriptVersion (..) , AnyScriptLanguage (..) @@ -149,6 +150,7 @@ import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import Cardano.Ledger.Binary qualified as Binary (decCBOR, decodeFullAnnotator) import Cardano.Ledger.Conway.Scripts qualified as Conway import Cardano.Ledger.Core qualified as Ledger +import Cardano.Ledger.Dijkstra.Scripts qualified as Dijkstra import Cardano.Ledger.Keys qualified as Shelley import Cardano.Ledger.Plutus.Language qualified as Plutus import Cardano.Ledger.Shelley.Scripts qualified as Shelley @@ -212,6 +214,8 @@ data PlutusScriptV2 data PlutusScriptV3 +data PlutusScriptV4 + instance HasTypeProxy SimpleScript' where data AsType SimpleScript' = AsSimpleScript proxyToAsType _ = AsSimpleScript @@ -229,6 +233,10 @@ instance HasTypeProxy PlutusScriptV3 where data AsType PlutusScriptV3 = AsPlutusScriptV3 proxyToAsType _ = AsPlutusScriptV3 +instance HasTypeProxy PlutusScriptV4 where + data AsType PlutusScriptV4 = AsPlutusScriptV4 + proxyToAsType _ = AsPlutusScriptV4 + -- ---------------------------------------------------------------------------- -- Value level representation for script languages -- @@ -252,6 +260,7 @@ data PlutusScriptVersion lang where PlutusScriptV1 :: PlutusScriptVersion PlutusScriptV1 PlutusScriptV2 :: PlutusScriptVersion PlutusScriptV2 PlutusScriptV3 :: PlutusScriptVersion PlutusScriptV3 + PlutusScriptV4 :: PlutusScriptVersion PlutusScriptV4 deriving instance (Eq (PlutusScriptVersion lang)) @@ -261,6 +270,7 @@ instance TestEquality PlutusScriptVersion where testEquality PlutusScriptV1 PlutusScriptV1 = Just Refl testEquality PlutusScriptV2 PlutusScriptV2 = Just Refl testEquality PlutusScriptV3 PlutusScriptV3 = Just Refl + testEquality PlutusScriptV4 PlutusScriptV4 = Just Refl testEquality _ _ = Nothing data AnyScriptLanguage where @@ -285,6 +295,7 @@ instance Enum AnyScriptLanguage where fromEnum (AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV1)) = 1 fromEnum (AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV2)) = 2 fromEnum (AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV3)) = 3 + fromEnum (AnyScriptLanguage (PlutusScriptLanguage PlutusScriptV4)) = 4 instance Bounded AnyScriptLanguage where minBound = AnyScriptLanguage SimpleScriptLanguage @@ -313,6 +324,7 @@ instance Enum AnyPlutusScriptVersion where fromEnum (AnyPlutusScriptVersion PlutusScriptV1) = 0 fromEnum (AnyPlutusScriptVersion PlutusScriptV2) = 1 fromEnum (AnyPlutusScriptVersion PlutusScriptV3) = 2 + fromEnum (AnyPlutusScriptVersion PlutusScriptV4) = 3 instance Bounded AnyPlutusScriptVersion where minBound = AnyPlutusScriptVersion PlutusScriptV1 @@ -336,6 +348,8 @@ instance ToJSON AnyPlutusScriptVersion where Aeson.String "PlutusScriptV2" toJSON (AnyPlutusScriptVersion PlutusScriptV3) = Aeson.String "PlutusScriptV3" + toJSON (AnyPlutusScriptVersion PlutusScriptV4) = + Aeson.String "PlutusScriptV4" parsePlutusScriptVersion :: Text -> Aeson.Parser AnyPlutusScriptVersion parsePlutusScriptVersion t = @@ -358,16 +372,19 @@ instance Aeson.ToJSONKey AnyPlutusScriptVersion where toText (AnyPlutusScriptVersion PlutusScriptV1) = "PlutusScriptV1" toText (AnyPlutusScriptVersion PlutusScriptV2) = "PlutusScriptV2" toText (AnyPlutusScriptVersion PlutusScriptV3) = "PlutusScriptV3" + toText (AnyPlutusScriptVersion PlutusScriptV4) = "PlutusScriptV4" toAlonzoLanguage :: AnyPlutusScriptVersion -> Plutus.Language toAlonzoLanguage (AnyPlutusScriptVersion PlutusScriptV1) = Plutus.PlutusV1 toAlonzoLanguage (AnyPlutusScriptVersion PlutusScriptV2) = Plutus.PlutusV2 toAlonzoLanguage (AnyPlutusScriptVersion PlutusScriptV3) = Plutus.PlutusV3 +toAlonzoLanguage (AnyPlutusScriptVersion PlutusScriptV4) = Plutus.PlutusV4 fromAlonzoLanguage :: Plutus.Language -> AnyPlutusScriptVersion fromAlonzoLanguage Plutus.PlutusV1 = AnyPlutusScriptVersion PlutusScriptV1 fromAlonzoLanguage Plutus.PlutusV2 = AnyPlutusScriptVersion PlutusScriptV2 fromAlonzoLanguage Plutus.PlutusV3 = AnyPlutusScriptVersion PlutusScriptV3 +fromAlonzoLanguage Plutus.PlutusV4 = AnyPlutusScriptVersion PlutusScriptV3 class HasTypeProxy lang => IsScriptLanguage lang where scriptLanguage :: ScriptLanguage lang @@ -384,6 +401,9 @@ instance IsScriptLanguage PlutusScriptV2 where instance IsScriptLanguage PlutusScriptV3 where scriptLanguage = PlutusScriptLanguage PlutusScriptV3 +instance IsScriptLanguage PlutusScriptV4 where + scriptLanguage = PlutusScriptLanguage PlutusScriptV4 + class IsScriptLanguage lang => IsPlutusScriptLanguage lang where plutusScriptVersion :: PlutusScriptVersion lang @@ -396,6 +416,9 @@ instance IsPlutusScriptLanguage PlutusScriptV2 where instance IsPlutusScriptLanguage PlutusScriptV3 where plutusScriptVersion = PlutusScriptV3 +instance IsPlutusScriptLanguage PlutusScriptV4 where + plutusScriptVersion = PlutusScriptV4 + -- ---------------------------------------------------------------------------- -- Script type: covering all script languages -- @@ -437,6 +460,8 @@ instance IsScriptLanguage lang => SerialiseAsCBOR (Script lang) where SBS.fromShort s serialiseToCBOR (PlutusScript PlutusScriptV3 (PlutusScriptSerialised s)) = SBS.fromShort s + serialiseToCBOR (PlutusScript PlutusScriptV4 (PlutusScriptSerialised s)) = + SBS.fromShort s deserialiseFromCBOR _ bs = case scriptLanguage :: ScriptLanguage lang of @@ -453,6 +478,9 @@ instance IsScriptLanguage lang => SerialiseAsCBOR (Script lang) where PlutusScriptLanguage PlutusScriptV3 -> PlutusScript PlutusScriptV3 <$> deserialiseFromCBOR (AsPlutusScript AsPlutusScriptV3) bs + PlutusScriptLanguage PlutusScriptV4 -> + PlutusScript PlutusScriptV4 + <$> deserialiseFromCBOR (AsPlutusScript AsPlutusScriptV4) bs -- | Previously we were double encoding the plutus script -- bytes. This function removes a layer of encoding to return @@ -476,6 +504,7 @@ instance IsScriptLanguage lang => HasTextEnvelope (Script lang) where PlutusScriptLanguage PlutusScriptV1 -> "PlutusScriptV1" PlutusScriptLanguage PlutusScriptV2 -> "PlutusScriptV2" PlutusScriptLanguage PlutusScriptV3 -> "PlutusScriptV3" + PlutusScriptLanguage PlutusScriptV4 -> "PlutusScriptV4" -- ---------------------------------------------------------------------------- -- Scripts in any language @@ -521,6 +550,7 @@ instance ToJSON ScriptInAnyLang where obtainScriptLangConstraint (PlutusScriptLanguage PlutusScriptV1) f = f obtainScriptLangConstraint (PlutusScriptLanguage PlutusScriptV2) f = f obtainScriptLangConstraint (PlutusScriptLanguage PlutusScriptV3) f = f + obtainScriptLangConstraint (PlutusScriptLanguage PlutusScriptV4) f = f instance FromJSON ScriptInAnyLang where parseJSON = Aeson.withObject "ScriptInAnyLang" $ \o -> do @@ -574,12 +604,16 @@ data ScriptLanguageInEra lang era where SimpleScriptInAlonzo :: ScriptLanguageInEra SimpleScript' AlonzoEra SimpleScriptInBabbage :: ScriptLanguageInEra SimpleScript' BabbageEra SimpleScriptInConway :: ScriptLanguageInEra SimpleScript' ConwayEra + SimpleScriptInDijkstra :: ScriptLanguageInEra SimpleScript' DijkstraEra PlutusScriptV1InAlonzo :: ScriptLanguageInEra PlutusScriptV1 AlonzoEra PlutusScriptV1InBabbage :: ScriptLanguageInEra PlutusScriptV1 BabbageEra PlutusScriptV1InConway :: ScriptLanguageInEra PlutusScriptV1 ConwayEra + PlutusScriptV1InDijkstra :: ScriptLanguageInEra PlutusScriptV1 DijkstraEra PlutusScriptV2InBabbage :: ScriptLanguageInEra PlutusScriptV2 BabbageEra PlutusScriptV2InConway :: ScriptLanguageInEra PlutusScriptV2 ConwayEra + PlutusScriptV2InDijkstra :: ScriptLanguageInEra PlutusScriptV2 DijkstraEra PlutusScriptV3InConway :: ScriptLanguageInEra PlutusScriptV3 ConwayEra + PlutusScriptV3InDijkstra :: ScriptLanguageInEra PlutusScriptV3 DijkstraEra deriving instance Eq (ScriptLanguageInEra lang era) @@ -629,12 +663,16 @@ languageOfScriptLanguageInEra langInEra = SimpleScriptInAlonzo -> SimpleScriptLanguage SimpleScriptInBabbage -> SimpleScriptLanguage SimpleScriptInConway -> SimpleScriptLanguage + SimpleScriptInDijkstra -> SimpleScriptLanguage PlutusScriptV1InAlonzo -> PlutusScriptLanguage PlutusScriptV1 PlutusScriptV1InBabbage -> PlutusScriptLanguage PlutusScriptV1 PlutusScriptV1InConway -> PlutusScriptLanguage PlutusScriptV1 + PlutusScriptV1InDijkstra -> PlutusScriptLanguage PlutusScriptV1 PlutusScriptV2InBabbage -> PlutusScriptLanguage PlutusScriptV2 PlutusScriptV2InConway -> PlutusScriptLanguage PlutusScriptV2 + PlutusScriptV2InDijkstra -> PlutusScriptLanguage PlutusScriptV2 PlutusScriptV3InConway -> PlutusScriptLanguage PlutusScriptV3 + PlutusScriptV3InDijkstra -> PlutusScriptLanguage PlutusScriptV3 sbeToSimpleScriptLanguageInEra :: ShelleyBasedEra era @@ -646,6 +684,7 @@ sbeToSimpleScriptLanguageInEra = \case ShelleyBasedEraAlonzo -> SimpleScriptInAlonzo ShelleyBasedEraBabbage -> SimpleScriptInBabbage ShelleyBasedEraConway -> SimpleScriptInConway + ShelleyBasedEraDijkstra -> SimpleScriptInDijkstra eraOfScriptLanguageInEra :: ScriptLanguageInEra lang era @@ -657,12 +696,16 @@ eraOfScriptLanguageInEra = \case SimpleScriptInAlonzo -> ShelleyBasedEraAlonzo SimpleScriptInBabbage -> ShelleyBasedEraBabbage SimpleScriptInConway -> ShelleyBasedEraConway + SimpleScriptInDijkstra -> ShelleyBasedEraDijkstra PlutusScriptV1InAlonzo -> ShelleyBasedEraAlonzo PlutusScriptV1InBabbage -> ShelleyBasedEraBabbage PlutusScriptV1InConway -> ShelleyBasedEraConway + PlutusScriptV1InDijkstra -> ShelleyBasedEraDijkstra PlutusScriptV2InBabbage -> ShelleyBasedEraBabbage PlutusScriptV2InConway -> ShelleyBasedEraConway + PlutusScriptV2InDijkstra -> ShelleyBasedEraDijkstra PlutusScriptV3InConway -> ShelleyBasedEraConway + PlutusScriptV3InDijkstra -> ShelleyBasedEraDijkstra -- | Given a target era and a script in some language, check if the language is -- supported in that era, and if so return a 'ScriptInEra'. @@ -1007,6 +1050,14 @@ hashScript (PlutusScript PlutusScriptV3 (PlutusScriptSerialised script)) = . Conway.ConwayPlutusV3 . Plutus.Plutus $ Plutus.PlutusBinary script +hashScript (PlutusScript PlutusScriptV4 (PlutusScriptSerialised script)) = + ScriptHash + . Ledger.hashScript @(ShelleyLedgerEra DijkstraEra) + . Alonzo.PlutusScript + . Dijkstra.MkDijkstraPlutusScript + . Conway.ConwayPlutusV3 + . Plutus.Plutus + $ Plutus.PlutusBinary script toShelleyScriptHash :: ScriptHash -> Ledger.ScriptHash toShelleyScriptHash (ScriptHash h) = h @@ -1066,6 +1117,7 @@ instance IsPlutusScriptLanguage lang => HasTextEnvelope (PlutusScript lang) wher PlutusScriptV1 -> "PlutusScriptV1" PlutusScriptV2 -> "PlutusScriptV2" PlutusScriptV3 -> "PlutusScriptV3" + PlutusScriptV4 -> "PlutusScriptV4" -- | Smart-constructor for 'ScriptLanguageInEra' to write functions -- manipulating scripts that do not commit to a particular era. @@ -1169,6 +1221,7 @@ toShelleyScript (ScriptInEra langInEra (SimpleScript script)) = SimpleScriptInAlonzo -> Alonzo.TimelockScript (toAllegraTimelock script) SimpleScriptInBabbage -> Alonzo.TimelockScript (toAllegraTimelock script) SimpleScriptInConway -> Alonzo.TimelockScript (toAllegraTimelock script) + SimpleScriptInDijkstra -> Alonzo.TimelockScript (toAllegraTimelock script) toShelleyScript ( ScriptInEra langInEra @@ -1184,6 +1237,9 @@ toShelleyScript Alonzo.PlutusScript . Babbage.BabbagePlutusV1 . Plutus.Plutus $ Plutus.PlutusBinary script PlutusScriptV1InConway -> Alonzo.PlutusScript . Conway.ConwayPlutusV1 . Plutus.Plutus $ Plutus.PlutusBinary script + PlutusScriptV1InDijkstra -> + Alonzo.PlutusScript . Dijkstra.MkDijkstraPlutusScript . Conway.ConwayPlutusV1 . Plutus.Plutus $ + Plutus.PlutusBinary script toShelleyScript ( ScriptInEra langInEra @@ -1197,6 +1253,9 @@ toShelleyScript Alonzo.PlutusScript . Babbage.BabbagePlutusV2 . Plutus.Plutus $ Plutus.PlutusBinary script PlutusScriptV2InConway -> Alonzo.PlutusScript . Conway.ConwayPlutusV2 . Plutus.Plutus $ Plutus.PlutusBinary script + PlutusScriptV2InDijkstra -> + Alonzo.PlutusScript . Dijkstra.MkDijkstraPlutusScript . Conway.ConwayPlutusV2 . Plutus.Plutus $ + Plutus.PlutusBinary script toShelleyScript ( ScriptInEra langInEra @@ -1208,6 +1267,25 @@ toShelleyScript case langInEra of PlutusScriptV3InConway -> Alonzo.PlutusScript . Conway.ConwayPlutusV3 . Plutus.Plutus $ Plutus.PlutusBinary script + PlutusScriptV3InDijkstra -> + Alonzo.PlutusScript . Dijkstra.MkDijkstraPlutusScript . Conway.ConwayPlutusV3 . Plutus.Plutus $ + Plutus.PlutusBinary script +toShelleyScript + ( ScriptInEra + _langInEra + ( PlutusScript + PlutusScriptV4 + (PlutusScriptSerialised _script) + ) + ) = error "toShelleyScript: PlutusV4 not implemented yet." + +-- TODO: Ledger needs to introduce a plutusV4 constructor +-- case langInEra of +-- PlutusScriptV4InConway -> +-- Alonzo.PlutusScript . Conway.ConwayPlutusV3 . Plutus.Plutus $ Plutus.PlutusBinary script +-- PlutusScriptV4InDijkstra -> +-- Alonzo.PlutusScript . Dijkstra.MkDijkstraPlutusScript . Conway.ConwayPlutusV3 . Plutus.Plutus $ +-- Plutus.PlutusBinary script fromShelleyBasedScript :: ShelleyBasedEra era @@ -1273,6 +1351,26 @@ fromShelleyBasedScript sbe script = ScriptInEra SimpleScriptInConway . SimpleScript $ fromAllegraTimelock s + ShelleyBasedEraDijkstra -> + case script of + (Alonzo.PlutusScript (Dijkstra.MkDijkstraPlutusScript plutusV)) -> + case plutusV of + Conway.ConwayPlutusV1 (PlutusScriptBinary s) -> + ScriptInEra PlutusScriptV1InDijkstra + . PlutusScript PlutusScriptV1 + $ PlutusScriptSerialised s + Conway.ConwayPlutusV2 (PlutusScriptBinary s) -> + ScriptInEra PlutusScriptV2InDijkstra + . PlutusScript PlutusScriptV2 + $ PlutusScriptSerialised s + Conway.ConwayPlutusV3 (PlutusScriptBinary s) -> + ScriptInEra PlutusScriptV3InDijkstra + . PlutusScript PlutusScriptV3 + $ PlutusScriptSerialised s + Alonzo.TimelockScript s -> + ScriptInEra SimpleScriptInDijkstra + . SimpleScript + $ fromAllegraTimelock s data MultiSigError = MultiSigErrorTimelockNotsupported deriving Show @@ -1334,11 +1432,13 @@ fromAllegraTimelock = go go (Shelley.RequireAllOf s) = RequireAllOf (map go (toList s)) go (Shelley.RequireAnyOf s) = RequireAnyOf (map go (toList s)) go (Shelley.RequireMOf i s) = RequireMOf i (map go (toList s)) + go _ = error "dijkstra" type family ToLedgerPlutusLanguage lang where ToLedgerPlutusLanguage PlutusScriptV1 = Plutus.PlutusV1 ToLedgerPlutusLanguage PlutusScriptV2 = Plutus.PlutusV2 ToLedgerPlutusLanguage PlutusScriptV3 = Plutus.PlutusV3 + ToLedgerPlutusLanguage PlutusScriptV4 = Plutus.PlutusV4 data PlutusScriptInEra era lang where PlutusScriptInEra :: PlutusScript lang -> PlutusScriptInEra era lang diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index 12df9d4206..1182cdd8f6 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -1024,11 +1024,13 @@ toAlonzoScriptLanguage :: AnyPlutusScriptVersion -> Plutus.Language toAlonzoScriptLanguage (AnyPlutusScriptVersion PlutusScriptV1) = Plutus.PlutusV1 toAlonzoScriptLanguage (AnyPlutusScriptVersion PlutusScriptV2) = Plutus.PlutusV2 toAlonzoScriptLanguage (AnyPlutusScriptVersion PlutusScriptV3) = Plutus.PlutusV3 +toAlonzoScriptLanguage (AnyPlutusScriptVersion PlutusScriptV4) = Plutus.PlutusV4 fromAlonzoScriptLanguage :: Plutus.Language -> AnyPlutusScriptVersion fromAlonzoScriptLanguage Plutus.PlutusV1 = AnyPlutusScriptVersion PlutusScriptV1 fromAlonzoScriptLanguage Plutus.PlutusV2 = AnyPlutusScriptVersion PlutusScriptV2 fromAlonzoScriptLanguage Plutus.PlutusV3 = AnyPlutusScriptVersion PlutusScriptV3 +fromAlonzoScriptLanguage Plutus.PlutusV4 = AnyPlutusScriptVersion PlutusScriptV4 toAlonzoCostModel :: CostModel -> Plutus.Language -> Either ProtocolParametersConversionError Alonzo.CostModel @@ -1111,6 +1113,7 @@ toLedgerPParamsUpdate ShelleyBasedEraMary = toShelleyPParamsUpdate toLedgerPParamsUpdate ShelleyBasedEraAlonzo = toAlonzoPParamsUpdate toLedgerPParamsUpdate ShelleyBasedEraBabbage = toBabbagePParamsUpdate toLedgerPParamsUpdate ShelleyBasedEraConway = toConwayPParamsUpdate +toLedgerPParamsUpdate ShelleyBasedEraDijkstra = toConwayPParamsUpdate toShelleyCommonPParamsUpdate :: EraPParams ledgerera @@ -1310,6 +1313,7 @@ fromLedgerPParamsUpdate ShelleyBasedEraMary = fromShelleyPParamsUpdate fromLedgerPParamsUpdate ShelleyBasedEraAlonzo = fromAlonzoPParamsUpdate fromLedgerPParamsUpdate ShelleyBasedEraBabbage = fromBabbagePParamsUpdate fromLedgerPParamsUpdate ShelleyBasedEraConway = fromConwayPParamsUpdate +fromLedgerPParamsUpdate ShelleyBasedEraDijkstra = fromConwayPParamsUpdate fromShelleyCommonPParamsUpdate :: EraPParams ledgerera diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Body/Lens.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Body/Lens.hs index 3565f8f272..cbaaa9d0c4 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Body/Lens.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Body/Lens.hs @@ -58,7 +58,6 @@ import Cardano.Ledger.Alonzo.Core qualified as L import Cardano.Ledger.Api qualified as L import Cardano.Ledger.BaseTypes (SlotNo, StrictMaybe (..)) import Cardano.Ledger.Coin qualified as L -import Cardano.Ledger.Conway.Core qualified as L import Cardano.Ledger.Mary.Value qualified as L import Cardano.Ledger.Shelley.PParams qualified as L import Cardano.Ledger.TxIn qualified as L From 1f8213c620e74f30bf68b6e0430a891349f47b93 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 14:11:05 -0400 Subject: [PATCH 17/26] Propagate Dijkstra era --- .../src/Cardano/Api/Certificate/Internal.hs | 6 +++ .../src/Cardano/Api/Experimental/Era.hs | 1 + .../Internal/IndexedPlutusScriptWitness.hs | 1 + .../Internal/TxScriptWitnessRequirements.hs | 8 ++++ cardano-api/src/Cardano/Api/LedgerState.hs | 16 +++++++ .../src/Cardano/Api/Tx/Internal/Sign.hs | 44 ++++++++++++++++++- .../Cardano/Api/Transaction/Autobalance.hs | 1 + 7 files changed, 75 insertions(+), 2 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Certificate/Internal.hs b/cardano-api/src/Cardano/Api/Certificate/Internal.hs index 24d91fd65c..2bd8f9c43c 100644 --- a/cardano-api/src/Cardano/Api/Certificate/Internal.hs +++ b/cardano-api/src/Cardano/Api/Certificate/Internal.hs @@ -234,6 +234,7 @@ certificateToTxCert c = ConwayCertificate eon cert -> case eon of ConwayEraOnwardsConway -> cert + ConwayEraOnwardsDijkstra -> cert -- ---------------------------------------------------------------------------- -- Stake pool parameters @@ -576,6 +577,7 @@ filterUnRegCreds = Ledger.RetirePoolTxCert _ _ -> Nothing Ledger.MirTxCert _ -> Nothing Ledger.GenesisDelegTxCert{} -> Nothing + _ -> error "dijkstra" ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $ case conwayCert of Ledger.RegPoolTxCert _ -> Nothing @@ -593,6 +595,7 @@ filterUnRegCreds = Ledger.RegTxCert _ -> Nothing -- stake cred deregistration w/o deposit Ledger.UnRegTxCert cred -> Just cred + _ -> error "dijkstra" filterUnRegDRepCreds :: Certificate era -> Maybe (Ledger.Credential Ledger.DRepRole) @@ -615,6 +618,7 @@ filterUnRegDRepCreds = \case Ledger.RegTxCert _ -> Nothing -- stake cred deregistration w/o deposit Ledger.UnRegTxCert _ -> Nothing + _ -> error "dijkstra" -- ---------------------------------------------------------------------------- -- Internal conversion functions @@ -803,6 +807,7 @@ getAnchorDataFromCertificate c = Ledger.RetirePoolTxCert _ _ -> return Nothing Ledger.GenesisDelegTxCert{} -> return Nothing Ledger.MirTxCert _ -> return Nothing + _ -> error "dijkstra" ConwayCertificate ceo ccert -> conwayEraOnwardsConstraints ceo $ case ccert of @@ -819,6 +824,7 @@ getAnchorDataFromCertificate c = Ledger.UpdateDRepTxCert _ mAnchor -> return $ Ledger.strictMaybeToMaybe mAnchor Ledger.AuthCommitteeHotKeyTxCert _ _ -> return Nothing Ledger.ResignCommitteeColdTxCert _ mAnchor -> return $ Ledger.strictMaybeToMaybe mAnchor + _ -> error "dijkstra" where anchorDataFromPoolMetadata :: MonadError AnchorDataFromCertificateError m diff --git a/cardano-api/src/Cardano/Api/Experimental/Era.hs b/cardano-api/src/Cardano/Api/Experimental/Era.hs index 0e0051a0bb..000cd2d72b 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Era.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Era.hs @@ -295,6 +295,7 @@ type EraCommonConstraints era = , L.AlonzoEraTx (LedgerEra era) , L.BabbageEraPParams (LedgerEra era) , L.BabbageEraTxBody (LedgerEra era) + , L.ConwayEraTxBody (LedgerEra era) , L.ConwayEraTxCert (LedgerEra era) , L.TxCert (LedgerEra era) ~ L.ConwayTxCert (LedgerEra era) , L.Era (LedgerEra era) diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/IndexedPlutusScriptWitness.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/IndexedPlutusScriptWitness.hs index c0c5d1530c..12a2206a07 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/IndexedPlutusScriptWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/IndexedPlutusScriptWitness.hs @@ -211,3 +211,4 @@ obtainAlonzoScriptPurposeConstraints v = AlonzoEraOnwardsAlonzo -> id AlonzoEraOnwardsBabbage -> id AlonzoEraOnwardsConway -> id + AlonzoEraOnwardsDijkstra -> id diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/TxScriptWitnessRequirements.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/TxScriptWitnessRequirements.hs index a458bd3e8f..b73287832f 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/TxScriptWitnessRequirements.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/TxScriptWitnessRequirements.hs @@ -61,6 +61,13 @@ instance Semigroup (TxScriptWitnessRequirements L.ConwayEra) where instance Monoid (TxScriptWitnessRequirements L.ConwayEra) where mempty = TxScriptWitnessRequirements mempty mempty mempty mempty +instance Semigroup (TxScriptWitnessRequirements L.DijkstraEra) where + (<>) (TxScriptWitnessRequirements l1 s1 d1 r1) (TxScriptWitnessRequirements l2 s2 d2 r2) = + TxScriptWitnessRequirements (l1 <> l2) (s1 <> s2) (d1 <> d2) (r1 <> r2) + +instance Monoid (TxScriptWitnessRequirements L.DijkstraEra) where + mempty = TxScriptWitnessRequirements mempty mempty mempty mempty + getTxScriptWitnessRequirements :: AlonzoEraOnwards era -> [(Witnessable witnessable (ShelleyLedgerEra era), AnyWitness (ShelleyLedgerEra era))] @@ -93,6 +100,7 @@ obtainMonoidConstraint eon = case eon of AlonzoEraOnwardsAlonzo -> id AlonzoEraOnwardsBabbage -> id AlonzoEraOnwardsConway -> id + AlonzoEraOnwardsDijkstra -> id extractExecutionUnits :: TxScriptWitnessRequirements era -> [ExecutionUnits] extractExecutionUnits (TxScriptWitnessRequirements _ _ _ redeemers) = diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index eef2df7e8c..4e1d0560b8 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -1290,6 +1290,11 @@ getNewEpochState era x = do ConwayLedgerState conwayCurrent -> pure $ Shelley.shelleyLedgerState $ unFlip $ currentState conwayCurrent _ -> Left err + ShelleyBasedEraDijkstra -> + case tip of + DijkstraLedgerState dijkstraCurrent -> + pure $ Shelley.shelleyLedgerState $ unFlip $ currentState dijkstraCurrent + _ -> Left err {-# COMPLETE ShelleyLedgerState @@ -1360,6 +1365,16 @@ pattern ConwayLedgerState -> NS (Current (Flip Consensus.LedgerState mk)) (Consensus.CardanoEras Consensus.StandardCrypto) pattern ConwayLedgerState x = S (S (S (S (S (S (Z x)))))) +pattern DijkstraLedgerState + :: Current + (Flip Consensus.LedgerState mk) + ( Shelley.ShelleyBlock + (Praos.Praos Ledger.StandardCrypto) + Consensus.DijkstraEra + ) + -> NS (Current (Flip Consensus.LedgerState mk)) (Consensus.CardanoEras Consensus.StandardCrypto) +pattern DijkstraLedgerState x = S (S (S (S (S (S (S (Z x))))))) + encodeLedgerState :: LedgerState -> CBOR.Encoding encodeLedgerState (LedgerState hst@(HFC.HardForkLedgerState st) tbs) = mconcat @@ -2267,6 +2282,7 @@ getLedgerTablesUTxOValues sbe tbs = ShelleyBasedEraAlonzo -> ejectTables (IS (IS (IS (IS IZ)))) ShelleyBasedEraBabbage -> ejectTables (IS (IS (IS (IS (IS IZ))))) ShelleyBasedEraConway -> ejectTables (IS (IS (IS (IS (IS (IS IZ)))))) + ShelleyBasedEraDijkstra -> ejectTables (IS (IS (IS (IS (IS (IS (IS IZ))))))) -- | Reconstructs the ledger's new epoch state and applies a supplied condition to it for every block. This -- function only terminates if the condition is met or we have reached the termination epoch. We need to diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Sign.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Sign.hs index 1f2c8df849..fbbc085959 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Sign.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Sign.hs @@ -179,6 +179,10 @@ instance Show (Tx era) where showParen (p >= 11) $ showString "ShelleyTx ShelleyBasedEraConway " . showsPrec 11 tx + showsPrec p (ShelleyTx ShelleyBasedEraDijkstra tx) = + showParen (p >= 11) $ + showString "ShelleyTx ShelleyBasedEraDijkstra " + . showsPrec 11 tx instance HasTypeProxy era => HasTypeProxy (Tx era) where data AsType (Tx era) = AsTx (AsType era) @@ -277,6 +281,7 @@ instance IsShelleyBasedEra era => HasTextEnvelope (Tx era) where ShelleyBasedEraAlonzo -> "Tx AlonzoEra" ShelleyBasedEraBabbage -> "Tx BabbageEra" ShelleyBasedEraConway -> "Tx ConwayEra" + ShelleyBasedEraDijkstra -> "Tx DijkstraEra" -- ---------------------------------------------------------------------------- -- Transaction bodies @@ -472,6 +477,29 @@ instance Show (TxBody era) where . showChar ' ' . showsPrec 11 scriptValidity ) + showsPrec + p + ( ShelleyTxBody + ShelleyBasedEraDijkstra + txbody + txscripts + redeemers + txmetadata + scriptValidity + ) = + showParen + (p >= 11) + ( showString "ShelleyTxBody ShelleyBasedEraDijkstra " + . showsPrec 11 txbody + . showChar ' ' + . showsPrec 11 txscripts + . showChar ' ' + . showsPrec 11 redeemers + . showChar ' ' + . showsPrec 11 txmetadata + . showChar ' ' + . showsPrec 11 scriptValidity + ) instance HasTypeProxy era => HasTypeProxy (TxBody era) where data AsType (TxBody era) = AsTxBody (AsType era) @@ -513,6 +541,7 @@ instance IsShelleyBasedEra era => HasTextEnvelope (TxBody era) where ShelleyBasedEraAlonzo -> "TxBodyAlonzo" ShelleyBasedEraBabbage -> "TxBodyBabbage" ShelleyBasedEraConway -> "TxBodyConway" + ShelleyBasedEraDijkstra -> "TxBodyDijkstra" data TxBodyScriptData era where TxBodyNoScriptData :: TxBodyScriptData era @@ -531,7 +560,7 @@ selectTxDatums :: TxBodyScriptData era -> Map L.DataHash (L.Data (ShelleyLedgerEra era)) selectTxDatums TxBodyNoScriptData = Map.empty -selectTxDatums (TxBodyScriptData _ (Alonzo.TxDats' datums) _) = datums +selectTxDatums (TxBodyScriptData _ (Alonzo.TxDats datums) _) = datums -- | Indicates whether a script is expected to fail or pass validation. data ScriptValidity @@ -642,6 +671,10 @@ instance Show (KeyWitness era) where showParen (p >= 11) $ showString "ShelleyBootstrapWitness ShelleyBasedEraConway " . showsPrec 11 tx + showsPrec p (ShelleyBootstrapWitness ShelleyBasedEraDijkstra tx) = + showParen (p >= 11) $ + showString "ShelleyBootstrapWitness ShelleyBasedEraDijkstra " + . showsPrec 11 tx showsPrec p (ShelleyKeyWitness ShelleyBasedEraShelley tx) = showParen (p >= 11) $ showString "ShelleyKeyWitness ShelleyBasedEraShelley " @@ -666,6 +699,10 @@ instance Show (KeyWitness era) where showParen (p >= 11) $ showString "ShelleyKeyWitness ShelleyBasedEraConway " . showsPrec 11 tx + showsPrec p (ShelleyKeyWitness ShelleyBasedEraDijkstra tx) = + showParen (p >= 11) $ + showString "ShelleyKeyWitness ShelleyBasedEraDijkstra " + . showsPrec 11 tx instance HasTypeProxy era => HasTypeProxy (KeyWitness era) where data AsType (KeyWitness era) = AsKeyWitness (AsType era) @@ -707,6 +744,7 @@ instance IsCardanoEra era => SerialiseAsCBOR (KeyWitness era) where AlonzoEra -> decodeShelleyBasedWitness ShelleyBasedEraAlonzo bs BabbageEra -> decodeShelleyBasedWitness ShelleyBasedEraBabbage bs ConwayEra -> decodeShelleyBasedWitness ShelleyBasedEraConway bs + DijkstraEra -> decodeShelleyBasedWitness ShelleyBasedEraDijkstra bs encodeShelleyBasedKeyWitness :: CBOR.EncCBOR w => w -> CBOR.Encoding encodeShelleyBasedKeyWitness wit = @@ -752,6 +790,7 @@ instance IsCardanoEra era => HasTextEnvelope (KeyWitness era) where AlonzoEra -> "TxWitness AlonzoEra" BabbageEra -> "TxWitness BabbageEra" ConwayEra -> "TxWitness ConwayEra" + DijkstraEra -> "TxWitness DijkstraEra" getTxBodyAndWitnesses :: Tx era -> (TxBody era, [KeyWitness era]) getTxBodyAndWitnesses tx = (getTxBody tx, getTxWitnesses tx) @@ -905,6 +944,7 @@ makeSignedTransaction ShelleyBasedEraAlonzo -> alonzoSignedTransaction ShelleyBasedEraBabbage -> alonzoSignedTransaction ShelleyBasedEraConway -> alonzoSignedTransaction + ShelleyBasedEraDijkstra -> alonzoSignedTransaction where txCommon :: forall ledgerera @@ -1025,7 +1065,7 @@ makeShelleyBasedBootstrapWitness sbe nwOrAddr txbody (ByronSigningKey sk) = -- Byron era witnesses were weird. This reveals all that weirdness. Shelley.BootstrapWitness { Shelley.bwKey = vk - , Shelley.bwSig = signature + , Shelley.bwSignature = signature , Shelley.bwChainCode = chainCode , Shelley.bwAttributes = attributes } diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs index 7fb9c0f70d..c5148d3290 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Autobalance.hs @@ -651,6 +651,7 @@ loadPlutusWitness ceo = do H.leftFail $ deserialiseFromTextEnvelopeAnyOf textEnvTypes envelope let scriptLangInEra = case ceo of ConwayEraOnwardsConway -> PlutusScriptV3InConway + ConwayEraOnwardsDijkstra -> PlutusScriptV3InDijkstra pure ( hashScript s , PlutusScriptWitness From 71f4fe1304ed53656e5c230b48ef81764b227f57 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 14:29:59 -0400 Subject: [PATCH 18/26] Merge with PlutusV4 intro --- .../Plutus/Internal/ScriptWitness.hs | 7 ++++++ .../Plutus/Internal/Shim/LegacyScripts.hs | 4 ++++ .../Experimental/Tx/Internal/AnyWitness.hs | 23 +++++++++++++++++++ cardano-api/src/Cardano/Api/Plutus.hs | 1 + 4 files changed, 35 insertions(+) diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs index 77fce5c280..7dbcfd1787 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs @@ -74,6 +74,7 @@ getPlutusScriptWitnessLanguage (PlutusScriptWitness l _ _ _ _) = L.SPlutusV1 -> L.plutusLanguage l L.SPlutusV2 -> L.plutusLanguage l L.SPlutusV3 -> L.plutusLanguage l + L.SPlutusV4 -> L.plutusLanguage l -- | Every Plutus script has a purpose that indicates -- what that script is witnessing. @@ -100,21 +101,27 @@ type family PlutusScriptDatumF (lang :: L.Language) (purpose :: PlutusScriptPurp PlutusScriptDatumF L.PlutusV1 SpendingScript = HashableScriptData PlutusScriptDatumF L.PlutusV2 SpendingScript = HashableScriptData PlutusScriptDatumF L.PlutusV3 SpendingScript = Maybe HashableScriptData -- CIP-69 + PlutusScriptDatumF L.PlutusV4 SpendingScript = Maybe HashableScriptData -- CIP-69 PlutusScriptDatumF L.PlutusV1 MintingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV2 MintingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV3 MintingScript = NoScriptDatum + PlutusScriptDatumF L.PlutusV4 MintingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV1 WithdrawingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV2 WithdrawingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV3 WithdrawingScript = NoScriptDatum + PlutusScriptDatumF L.PlutusV4 WithdrawingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV1 CertifyingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV2 CertifyingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV3 CertifyingScript = NoScriptDatum + PlutusScriptDatumF L.PlutusV4 CertifyingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV1 ProposingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV2 ProposingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV3 ProposingScript = NoScriptDatum + PlutusScriptDatumF L.PlutusV4 ProposingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV1 VotingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV2 VotingScript = NoScriptDatum PlutusScriptDatumF L.PlutusV3 VotingScript = NoScriptDatum + PlutusScriptDatumF L.PlutusV4 VotingScript = NoScriptDatum data PlutusScriptDatum (lang :: L.Language) (purpose :: PlutusScriptPurpose) where SpendingScriptDatum diff --git a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs index 88a69f6570..009a701f74 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs @@ -119,11 +119,13 @@ toPlutusScriptDatum -> Old.ScriptDatum Old.WitCtxTxIn -> PlutusScriptDatum (Old.ToLedgerPlutusLanguage lang) (ToPlutusScriptPurpose TxInItem) -- ^ Encapsulates CIP-69: V3 spending script datums are optional +toPlutusScriptDatum WitTxIn{} Old.PlutusScriptV4 (Old.ScriptDatumForTxIn r) = SpendingScriptDatum r toPlutusScriptDatum WitTxIn{} Old.PlutusScriptV3 (Old.ScriptDatumForTxIn r) = SpendingScriptDatum r -- \^ V2 and V1 spending script datums are required toPlutusScriptDatum WitTxIn{} Old.PlutusScriptV2 (Old.ScriptDatumForTxIn (Just r)) = SpendingScriptDatum r toPlutusScriptDatum WitTxIn{} Old.PlutusScriptV1 (Old.ScriptDatumForTxIn (Just r)) = SpendingScriptDatum r -- \^ V2 and V3 scripts can have inline datums +toPlutusScriptDatum WitTxIn{} Old.PlutusScriptV4 Old.InlineScriptDatum = InlineDatum toPlutusScriptDatum WitTxIn{} Old.PlutusScriptV3 Old.InlineScriptDatum = InlineDatum toPlutusScriptDatum WitTxIn{} Old.PlutusScriptV2 Old.InlineScriptDatum = InlineDatum -- \^ Everything else is not allowed. The old api does not prevent these invalid combinations. @@ -206,6 +208,7 @@ obtainConstraints v = Old.PlutusScriptV1 -> id Old.PlutusScriptV2 -> id Old.PlutusScriptV3 -> id + Old.PlutusScriptV4 -> id toPlutusSLanguage :: Old.PlutusScriptVersion lang -> L.SLanguage (Old.ToLedgerPlutusLanguage lang) @@ -213,3 +216,4 @@ toPlutusSLanguage = \case Old.PlutusScriptV1 -> L.SPlutusV1 Old.PlutusScriptV2 -> L.SPlutusV2 Old.PlutusScriptV3 -> L.SPlutusV3 + Old.PlutusScriptV4 -> L.SPlutusV4 diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs index 24536ba065..3a3cd517c9 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs @@ -29,6 +29,7 @@ import Cardano.Ledger.Alonzo.Scripts qualified as L import Cardano.Ledger.Babbage.Scripts qualified as L import Cardano.Ledger.Conway.Scripts qualified as L import Cardano.Ledger.Core qualified as L +import Cardano.Ledger.Dijkstra.Scripts qualified as Dijkstra import Cardano.Ledger.Plutus.Data qualified as L import Cardano.Ledger.Plutus.Language qualified as L @@ -101,12 +102,14 @@ getAnyWitnessScript era ss@(AnySimpleScriptWitness{}) = ShelleyBasedEraAlonzo -> L.TimelockScript <$> getAnyWitnessSimpleScript ss ShelleyBasedEraBabbage -> L.TimelockScript <$> getAnyWitnessSimpleScript ss ShelleyBasedEraConway -> L.TimelockScript <$> getAnyWitnessSimpleScript ss + ShelleyBasedEraDijkstra -> L.TimelockScript <$> getAnyWitnessSimpleScript ss getAnyWitnessScript era ps@(AnyPlutusScriptWitness{}) = forShelleyBasedEraInEon era Nothing $ \aEon -> case aEon of AlonzoEraOnwardsAlonzo -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps AlonzoEraOnwardsBabbage -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps AlonzoEraOnwardsConway -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps + AlonzoEraOnwardsDijkstra -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps -- It should be noted that 'PlutusRunnable' is constructed via deserialization. The deserialization -- instance lives in ledger and will fail for an invalid script language/era pairing. Therefore @@ -127,6 +130,9 @@ fromPlutusRunnable L.SPlutusV1 eon runnable = AlonzoEraOnwardsConway -> let plutusScript = L.plutusFromRunnable runnable in Just $ L.ConwayPlutusV1 plutusScript + AlonzoEraOnwardsDijkstra -> + let plutusScript = L.plutusFromRunnable runnable + in Just $ Dijkstra.MkDijkstraPlutusScript $ L.ConwayPlutusV1 plutusScript fromPlutusRunnable L.SPlutusV2 eon runnable = case eon of AlonzoEraOnwardsAlonzo -> Nothing @@ -136,6 +142,9 @@ fromPlutusRunnable L.SPlutusV2 eon runnable = AlonzoEraOnwardsConway -> let plutusScript = L.plutusFromRunnable runnable in Just $ L.ConwayPlutusV2 plutusScript + AlonzoEraOnwardsDijkstra -> + let plutusScript = L.plutusFromRunnable runnable + in Just $ Dijkstra.MkDijkstraPlutusScript $ L.ConwayPlutusV2 plutusScript fromPlutusRunnable L.SPlutusV3 eon runnable = case eon of AlonzoEraOnwardsAlonzo -> Nothing @@ -143,6 +152,19 @@ fromPlutusRunnable L.SPlutusV3 eon runnable = AlonzoEraOnwardsConway -> let plutusScript = L.plutusFromRunnable runnable in Just $ L.ConwayPlutusV3 plutusScript + AlonzoEraOnwardsDijkstra -> + let plutusScript = L.plutusFromRunnable runnable + in Just $ Dijkstra.MkDijkstraPlutusScript $ L.ConwayPlutusV3 plutusScript +fromPlutusRunnable L.SPlutusV4 eon runnable = + case eon of + AlonzoEraOnwardsAlonzo -> Nothing + AlonzoEraOnwardsBabbage -> Nothing + AlonzoEraOnwardsConway -> + let plutusScript = L.plutusFromRunnable runnable + in Just $ (error "fromPlutusRunnable: ConwayPlutusV4") plutusScript + AlonzoEraOnwardsDijkstra -> + let plutusScript = L.plutusFromRunnable runnable + in Just $ Dijkstra.MkDijkstraPlutusScript $ (error "fromPlutusRunnable: DijkstraPlutusV4") plutusScript toAlonzoDatum :: AlonzoEraOnwards era @@ -160,5 +182,6 @@ getPlutusDatum getPlutusDatum L.SPlutusV1 (SpendingScriptDatum d) = Just d getPlutusDatum L.SPlutusV2 (SpendingScriptDatum d) = Just d getPlutusDatum L.SPlutusV3 (SpendingScriptDatum d) = d +getPlutusDatum L.SPlutusV4 (SpendingScriptDatum _d) = error "dijkstra" getPlutusDatum _ InlineDatum = Nothing getPlutusDatum _ NoScriptDatum = Nothing diff --git a/cardano-api/src/Cardano/Api/Plutus.hs b/cardano-api/src/Cardano/Api/Plutus.hs index 2c5a7fe96d..4b6674cc56 100644 --- a/cardano-api/src/Cardano/Api/Plutus.hs +++ b/cardano-api/src/Cardano/Api/Plutus.hs @@ -4,6 +4,7 @@ module Cardano.Api.Plutus , PlutusScriptV1 , PlutusScriptV2 , PlutusScriptV3 + , PlutusScriptV4 , ScriptLanguage (..) , PlutusScriptVersion (..) , AnyScriptLanguage (..) From 423d91c201ea5b5affd6aaa0689eff2711e46641 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 14:30:14 -0400 Subject: [PATCH 19/26] Merge with propagate Dikstra --- cardano-api/cardano-api.cabal | 3 + .../Experimental/Tx/Internal/Certificate.hs | 95 +++++++++++++------ .../Api/LedgerState/Internal/LedgerEvent.hs | 4 +- .../src/Cardano/Api/Network/IPC/Internal.hs | 3 +- .../cardano-api-test/Test/Cardano/Api/CBOR.hs | 1 + 5 files changed, 73 insertions(+), 33 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 6c7188d518..e7a7adf0c6 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -296,6 +296,7 @@ library gen Test.Gen.Cardano.Api.Era Test.Gen.Cardano.Api.Hardcoded Test.Gen.Cardano.Api.Metadata + Test.Gen.Cardano.Api.Orphans Test.Gen.Cardano.Api.ProtocolParameters Test.Gen.Cardano.Api.Typed Test.Gen.Cardano.Crypto.Seed @@ -316,9 +317,11 @@ library gen cardano-ledger-byron-test >=1.5, cardano-ledger-conway:testlib, cardano-ledger-core:{cardano-ledger-core, testlib} >=1.14, + cardano-ledger-dijkstra >=0.1, cardano-ledger-shelley >=1.13, containers, filepath, + generic-random, hedgehog >=1.1, hedgehog-extras, hedgehog-quickcheck, diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Certificate.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Certificate.hs index 90e9a7ec9d..a792f5e7c0 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Certificate.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Certificate.hs @@ -15,8 +15,8 @@ where import Cardano.Api.Address qualified as Api import Cardano.Api.Certificate.Internal qualified as Api +import Cardano.Api.Era.Internal.Core (DijkstraEra) import Cardano.Api.Era.Internal.Eon.Convert -import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards import Cardano.Api.Era.Internal.Eon.ShelleyToBabbageEra qualified as Api import Cardano.Api.Experimental.Era import Cardano.Api.Experimental.Plutus.Internal.Script qualified as Exp @@ -45,13 +45,18 @@ deriving instance Eq (Certificate era) deriving instance Ord (Certificate era) convertToOldApiCertificate :: Era era -> Certificate (LedgerEra era) -> Api.Certificate era -convertToOldApiCertificate ConwayEra (Certificate cert) = - Api.ConwayCertificate ConwayEraOnwardsConway cert +convertToOldApiCertificate e (Certificate cert) = + obtainCommonConstraints e $ Api.ConwayCertificate (convert e) cert convertToNewCertificate :: Era era -> Api.Certificate era -> Certificate (LedgerEra era) -convertToNewCertificate ConwayEra (Api.ConwayCertificate _ cert) = Certificate cert -convertToNewCertificate ConwayEra (Api.ShelleyRelatedCertificate sToBab _) = - case sToBab :: Api.ShelleyToBabbageEra ConwayEra of {} +convertToNewCertificate era (Api.ConwayCertificate _ cert) = + case era of + ConwayEra -> Certificate cert + DijkstraEra -> Certificate cert +convertToNewCertificate era (Api.ShelleyRelatedCertificate sToBab _) = + case era of + ConwayEra -> case sToBab :: Api.ShelleyToBabbageEra ConwayEra of {} + DijkstraEra -> case sToBab :: Api.ShelleyToBabbageEra DijkstraEra of {} mkTxCertificates :: forall era @@ -61,29 +66,29 @@ mkTxCertificates mkTxCertificates [] = TxCertificatesNone mkTxCertificates certs = TxCertificates (convert useEra) $ fromList $ map (getStakeCred useEra) certs - where - getStakeCred - :: Era era - -> (Certificate (LedgerEra era), AnyWitness (LedgerEra era)) - -> ( Api.Certificate era - , Api.BuildTxWith - Api.BuildTx - (Maybe (Api.StakeCredential, Api.Witness Api.WitCtxStake era)) - ) - getStakeCred era (Certificate cert, witness) = - case era of - ConwayEra -> do - let oldApiCert = Api.ConwayCertificate (convert era) cert - mStakeCred = Api.selectStakeCredentialWitness oldApiCert - wit = - case witness of - AnyKeyWitnessPlaceholder -> Api.KeyWitness Api.KeyWitnessForStakeAddr - AnySimpleScriptWitness ss -> - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ newToOldSimpleScriptWitness era ss - AnyPlutusScriptWitness psw -> - Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ - newToOldPlutusCertificateScriptWitness ConwayEra psw - (oldApiCert, pure $ (,wit) <$> mStakeCred) + +getStakeCred + :: Era era + -> (Certificate (LedgerEra era), AnyWitness (LedgerEra era)) + -> ( Api.Certificate era + , Api.BuildTxWith + Api.BuildTx + (Maybe (Api.StakeCredential, Api.Witness Api.WitCtxStake era)) + ) +getStakeCred e (Certificate cert, witness) = do + let oldApiCert = obtainCommonConstraints e $ Api.ConwayCertificate (convert e) cert + mStakeCred = Api.selectStakeCredentialWitness oldApiCert + wit = + case witness of + AnyKeyWitnessPlaceholder -> Api.KeyWitness Api.KeyWitnessForStakeAddr + AnySimpleScriptWitness ss -> + Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ + obtainCommonConstraints e $ + newToOldSimpleScriptWitness e ss + AnyPlutusScriptWitness psw -> + Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ + newToOldPlutusCertificateScriptWitness e psw + (oldApiCert, pure $ (,wit) <$> mStakeCred) newToOldSimpleScriptWitness :: L.AllegraEraScript (LedgerEra era) @@ -127,12 +132,40 @@ newToOldPlutusCertificateScriptWitness ConwayEra (Exp.PlutusScriptWitness Plutus Api.NoScriptDatumForStake redeemer execUnits +newToOldPlutusCertificateScriptWitness ConwayEra (Exp.PlutusScriptWitness Plutus.SPlutusV4 _scriptOrRef _ _redeemer _execUnits) = + error "dijkstra" +newToOldPlutusCertificateScriptWitness DijkstraEra (Exp.PlutusScriptWitness Plutus.SPlutusV1 scriptOrRef _ redeemer execUnits) = + Api.PlutusScriptWitness + Api.PlutusScriptV1InDijkstra + Api.PlutusScriptV1 + (newToOldPlutusScriptOrReferenceInput DijkstraEra scriptOrRef) + Api.NoScriptDatumForStake + redeemer + execUnits +newToOldPlutusCertificateScriptWitness DijkstraEra (Exp.PlutusScriptWitness Plutus.SPlutusV2 scriptOrRef _ redeemer execUnits) = + Api.PlutusScriptWitness + Api.PlutusScriptV2InDijkstra + Api.PlutusScriptV2 + (newToOldPlutusScriptOrReferenceInput DijkstraEra scriptOrRef) + Api.NoScriptDatumForStake + redeemer + execUnits +newToOldPlutusCertificateScriptWitness DijkstraEra (Exp.PlutusScriptWitness Plutus.SPlutusV3 scriptOrRef _ redeemer execUnits) = + Api.PlutusScriptWitness + Api.PlutusScriptV3InDijkstra + Api.PlutusScriptV3 + (newToOldPlutusScriptOrReferenceInput DijkstraEra scriptOrRef) + Api.NoScriptDatumForStake + redeemer + execUnits +newToOldPlutusCertificateScriptWitness DijkstraEra (Exp.PlutusScriptWitness Plutus.SPlutusV4 _scriptOrRef _ _redeemer _execUnits) = + error "dijkstra" newToOldPlutusScriptOrReferenceInput :: Era era -> Exp.PlutusScriptOrReferenceInput lang (LedgerEra era) -> Api.PlutusScriptOrReferenceInput oldlang -newToOldPlutusScriptOrReferenceInput ConwayEra (Exp.PReferenceScript txin) = Api.PReferenceScript txin -newToOldPlutusScriptOrReferenceInput ConwayEra (Exp.PScript (Exp.PlutusScriptInEra plutusRunnable)) = +newToOldPlutusScriptOrReferenceInput _ (Exp.PReferenceScript txin) = Api.PReferenceScript txin +newToOldPlutusScriptOrReferenceInput _ (Exp.PScript (Exp.PlutusScriptInEra plutusRunnable)) = let oldScript = L.unPlutusBinary . L.plutusBinary $ L.plutusFromRunnable plutusRunnable in Api.PScript $ Api.PlutusScriptSerialised oldScript diff --git a/cardano-api/src/Cardano/Api/LedgerState/Internal/LedgerEvent.hs b/cardano-api/src/Cardano/Api/LedgerState/Internal/LedgerEvent.hs index aba7ff0737..4e12859834 100644 --- a/cardano-api/src/Cardano/Api/LedgerState/Internal/LedgerEvent.hs +++ b/cardano-api/src/Cardano/Api/LedgerState/Internal/LedgerEvent.hs @@ -20,6 +20,7 @@ import Cardano.Api.Key.Internal (Hash (..), StakePoolKey) import Cardano.Ledger.Coin qualified as L import Cardano.Ledger.Coin qualified as Ledger +import Cardano.Ledger.Compactible qualified as Ledger import Cardano.Ledger.Conway.Governance qualified as Ledger import Cardano.Ledger.Core qualified as Ledger.Core import Cardano.Ledger.Credential qualified as Ledger @@ -110,8 +111,9 @@ data PoolReapDetails = PoolReapDetails convertRetiredPoolsMap :: Map Ledger.StakeCredential - (Map (Ledger.KeyHash Ledger.StakePool) Ledger.Coin) + (Map (Ledger.KeyHash Ledger.StakePool) (Ledger.CompactForm Ledger.Coin)) -> Map StakeCredential (Map (Hash StakePoolKey) L.Coin) convertRetiredPoolsMap = Map.mapKeys fromShelleyStakeCredential . fmap (Map.mapKeys StakePoolKeyHash) + . (fmap . fmap) Ledger.fromCompact diff --git a/cardano-api/src/Cardano/Api/Network/IPC/Internal.hs b/cardano-api/src/Cardano/Api/Network/IPC/Internal.hs index 1b095bb73a..bfd4945148 100644 --- a/cardano-api/src/Cardano/Api/Network/IPC/Internal.hs +++ b/cardano-api/src/Cardano/Api/Network/IPC/Internal.hs @@ -132,6 +132,7 @@ import Data.ByteString.Lazy qualified as LBS import Data.Void (Void) import GHC.Exts (IsList (..)) import Network.Mux qualified as Net +import Network.Mux.Trace (nullTracers) -- ---------------------------------------------------------------------------- -- The types for the client side of the node-to-client IPC protocols @@ -211,7 +212,7 @@ connectToLocalNodeWithVersion Net.connectTo (Net.localSnocket iomgr) Net.NetworkConnectTracers - { Net.nctMuxTracer = nullTracer + { Net.nctMuxTracers = nullTracers , Net.nctHandshakeTracer = nullTracer } versionedProtocls diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs index f94c86be7a..0b2b8b644b 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs @@ -77,6 +77,7 @@ prop_txbody_backwards_compatibility = H.property $ do ShelleyBasedEraAlonzo -> "Tx AlonzoEra" ShelleyBasedEraBabbage -> "Tx BabbageEra" ShelleyBasedEraConway -> "Tx ConwayEra" + ShelleyBasedEraDijkstra -> "Tx DijkstraEra" prop_text_envelope_roundtrip_txbody_CBOR :: Property prop_text_envelope_roundtrip_txbody_CBOR = H.property $ do From 9be9a3783488808674e08b9512f14581b188d843 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 14:30:27 -0400 Subject: [PATCH 20/26] REMOVE ME: Add ledger and consensus SRPs --- cabal.project | 54 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 52 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 00318cf5ad..7a8a7a468e 100644 --- a/cabal.project +++ b/cabal.project @@ -13,8 +13,8 @@ repository cardano-haskell-packages -- See CONTRIBUTING for information about these, including some Nix commands -- you need to run if you change them index-state: - , hackage.haskell.org 2025-06-22T20:18:27Z - , cardano-haskell-packages 2025-06-20T09:11:51Z + , hackage.haskell.org 2025-07-22T09:13:54Z + , cardano-haskell-packages 2025-07-28T14:33:19Z packages: cardano-api @@ -61,6 +61,50 @@ if impl (ghc >= 9.12) -- https://github.com/kapralVV/Unique/issues/11 , Unique:hashable +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus + tag: 15fc8c4fee64473350e1904347bfd5852f9cdbfa + --sha256: sha256-Tvw0dLGZkBAflpvcEwl7Acnrux9H5UaniW5YwMvIeIs= + subdir: + ouroboros-consensus + ouroboros-consensus-cardano + ouroboros-consensus-diffusion + ouroboros-consensus-protocol + sop-extras + strict-sop-core + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger + tag: 20485948f78ab139d246695e540f9ec00963a16e + --sha256: sha256-SHnyp+GvNeR82UXoKeDEgsp1AUE2yF5dGL4HIZm0zK8= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/alonzo/test-suite + eras/babbage/impl + eras/babbage/test-suite + eras/byron/chain/executable-spec + eras/byron/crypto + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/conway/impl + eras/dijkstra + eras/mary/impl + eras/shelley/impl + eras/shelley-ma/test-suite + eras/shelley/test-suite + libs/cardano-data + libs/cardano-ledger-api + libs/cardano-ledger-binary + libs/cardano-ledger-core + libs/cardano-protocol-tpraos + libs/non-integral + libs/set-algebra + libs/small-steps + libs/vector-map + -- WASM compilation specific if arch(wasm32) @@ -161,3 +205,9 @@ if arch(wasm32) -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. +allow-newer: + , cardano-ledger-byron + -- https://github.com/phadej/vec/issues/121 + , ral:QuickCheck + , fin:QuickCheck + , bin:QuickCheck \ No newline at end of file From c2aa9bca64b20818c89a0d7b687b281e3d1d9fd9 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 30 Jul 2025 08:30:52 -0400 Subject: [PATCH 21/26] Update nix flake --- flake.lock | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/flake.lock b/flake.lock index 3b72672e95..736b33c347 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1750412109, - "narHash": "sha256-v5AlraKLH2Rgl3HRJb/DciXIkOlF5pD/RewHB6nDlrM=", + "lastModified": 1753894642, + "narHash": "sha256-7TP8sGtytiHNWdphUZ2j44oy/4tCEqq19BdE7nc1LB8=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "25868b1d259155d46b8c0089f12076f1c7f94cab", + "rev": "8d401eefedf9b1a8703594b3d33165fdb7ee8f69", "type": "github" }, "original": { From 27111c3eca7b20b5bc4c62ed60bc5bc38aa5cc9d Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 31 Jul 2025 14:46:30 -0400 Subject: [PATCH 22/26] Update cardano-rpc with PlutusV4 --- cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto | 1 + cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs | 2 ++ .../cardano-rpc-test/Test/Cardano/Rpc/ProtocolParameters.hs | 1 - 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto b/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto index 7a7a5e1bab..1f27530506 100644 --- a/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto +++ b/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto @@ -40,6 +40,7 @@ message Script { bytes plutus_v1 = 2; // Plutus V1 script. bytes plutus_v2 = 3; // Plutus V2 script. bytes plutus_v3 = 4; // Plutus V3 script. + bytes plutus_v4 = 5; // Plutus V3 script. } } diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs index efde50a6be..266aafea2c 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs +++ b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs @@ -86,6 +86,8 @@ instance Inject (ReferenceScript era) (Proto UtxoRpc.Script) where defMessage & #plutusV2 .~ serialiseToRawBytes ps PlutusScript PlutusScriptV3 ps -> defMessage & #plutusV3 .~ serialiseToRawBytes ps + PlutusScript PlutusScriptV4 ps -> + defMessage & #plutusV4 .~ serialiseToRawBytes ps instance IsCardanoEra era => Inject (UTxO era) [Proto UtxoRpc.AnyUtxoData] where inject utxo = diff --git a/cardano-rpc/test/cardano-rpc-test/Test/Cardano/Rpc/ProtocolParameters.hs b/cardano-rpc/test/cardano-rpc-test/Test/Cardano/Rpc/ProtocolParameters.hs index 3564e5f88f..16efc7fd8b 100644 --- a/cardano-rpc/test/cardano-rpc-test/Test/Cardano/Rpc/ProtocolParameters.hs +++ b/cardano-rpc/test/cardano-rpc-test/Test/Cardano/Rpc/ProtocolParameters.hs @@ -35,7 +35,6 @@ hprop_roundtrip_protocol_parameters = H.property $ do pp <- fmap unLedgerProtocolParameters . H.forAll $ genValidProtocolParameters (convert era) let costModels = L.costModelsValid $ pp ^. L.ppCostModelsL mCms = map (`M.lookup` costModels) [minBound .. maxBound] - nonEmptyCostModels = fromList . flip mapMaybe mCms $ \mCm -> mCm >>= \cm -> From cf8bab890edcacdb3681ac81354869c23b5c1927 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 31 Jul 2025 10:38:48 -0400 Subject: [PATCH 23/26] Implement `executeLocalStateQueryExprWithVersion` --- cardano-api/src/Cardano/Api/Network/IPC.hs | 1 + .../Cardano/Api/Network/IPC/Internal/Monad.hs | 26 +++++++++++++++++++ 2 files changed, 27 insertions(+) diff --git a/cardano-api/src/Cardano/Api/Network/IPC.hs b/cardano-api/src/Cardano/Api/Network/IPC.hs index f896d2f2c1..1e05eeacef 100644 --- a/cardano-api/src/Cardano/Api/Network/IPC.hs +++ b/cardano-api/src/Cardano/Api/Network/IPC.hs @@ -219,6 +219,7 @@ module Cardano.Api.Network.IPC -- **** Query monad , LocalStateQueryExpr , executeLocalStateQueryExpr + , executeLocalStateQueryExprWithVersion , queryExpr -- *** Local tx monitoring diff --git a/cardano-api/src/Cardano/Api/Network/IPC/Internal/Monad.hs b/cardano-api/src/Cardano/Api/Network/IPC/Internal/Monad.hs index b294a364d3..648dfabc8d 100644 --- a/cardano-api/src/Cardano/Api/Network/IPC/Internal/Monad.hs +++ b/cardano-api/src/Cardano/Api/Network/IPC/Internal/Monad.hs @@ -5,6 +5,7 @@ module Cardano.Api.Network.IPC.Internal.Monad ( LocalStateQueryExpr , executeLocalStateQueryExpr + , executeLocalStateQueryExprWithVersion , queryExpr ) where @@ -44,6 +45,31 @@ newtype LocalStateQueryExpr block point query r m a = LocalStateQueryExpr } deriving (Functor, Applicative, Monad, MonadReader NodeToClientVersion, MonadIO) +-- | Execute a local state query expression. +executeLocalStateQueryExprWithVersion + :: () + => LocalNodeConnectInfo + -> Net.Query.Target ChainPoint + -> (NodeToClientVersion -> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a) + -> IO (Either AcquiringFailure a) +executeLocalStateQueryExprWithVersion connectInfo target f = do + tmvResultLocalState <- newEmptyTMVarIO + let waitResult = readTMVar tmvResultLocalState + + connectToLocalNodeWithVersion + connectInfo + ( \ntcVersion -> + LocalNodeClientProtocols + { localChainSyncClient = NoLocalChainSyncClient + , localStateQueryClient = + Just $ setupLocalStateQueryExpr waitResult target tmvResultLocalState ntcVersion (f ntcVersion) + , localTxSubmissionClient = Nothing + , localTxMonitoringClient = Nothing + } + ) + + atomically waitResult + -- | Execute a local state query expression. executeLocalStateQueryExpr :: () From 076f7e966ec1d6457b1b9ec5ceee0f9e598fed12 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 31 Jul 2025 15:41:06 -0400 Subject: [PATCH 24/26] Fix parseHardForkTriggers --- cardano-api/src/Cardano/Api/LedgerState.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index 4e1d0560b8..1fe7045308 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -1148,8 +1148,7 @@ instance FromJSON NodeConfig where <*> parseAlonzoHardForkEpoch o <*> parseBabbageHardForkEpoch o <*> parseConwayHardForkEpoch o - <*> error "dijkstra" - + <*> (pure Consensus.CardanoTriggerHardForkAtDefaultVersion) -- TODO: Dijkstra parseShelleyHardForkEpoch :: Object -> Parser (Consensus.CardanoHardForkTrigger blk) parseShelleyHardForkEpoch o = asum From 2f49a12354e238b419031019fcd7dc162c04e338 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 1 Aug 2025 10:31:03 +0200 Subject: [PATCH 25/26] Fix cardano-rpc-test for protocol parameters roundtrip --- cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto | 5 +++-- cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs | 1 + cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs | 3 ++- 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto b/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto index 1f27530506..1b12afe39e 100644 --- a/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto +++ b/cardano-rpc/proto/utxorpc/v1alpha/cardano/cardano.proto @@ -33,14 +33,14 @@ message MultiAsset { } // Represents a script in Cardano. -// TODO u5c: removed native script representation +// TODO u5c: removed native script representation, added plutus_v4 message Script { oneof script { bytes native = 1; // Native script. bytes plutus_v1 = 2; // Plutus V1 script. bytes plutus_v2 = 3; // Plutus V2 script. bytes plutus_v3 = 4; // Plutus V3 script. - bytes plutus_v4 = 5; // Plutus V3 script. + bytes plutus_v4 = 5; // Plutus V4 script. } } @@ -77,6 +77,7 @@ message CostModels { CostModel plutus_v1 = 1; CostModel plutus_v2 = 2; CostModel plutus_v3 = 3; + CostModel plutus_v4 = 4; } message VotingThresholds { diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs index 266aafea2c..3f727afd26 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs +++ b/cardano-rpc/src/Cardano/Rpc/Server/Internal/Orphans.hs @@ -163,6 +163,7 @@ instance L.ConwayEraPParams lera => Inject (L.PParams lera) (Proto UtxoRpc.PPara & #costModels . #plutusV1 . #values .~ (join . maybeToList) (M.lookup L.PlutusV1 pparamsCostModels) & #costModels . #plutusV2 . #values .~ (join . maybeToList) (M.lookup L.PlutusV2 pparamsCostModels) & #costModels . #plutusV3 . #values .~ (join . maybeToList) (M.lookup L.PlutusV3 pparamsCostModels) + & #costModels . #plutusV4 . #values .~ (join . maybeToList) (M.lookup L.PlutusV4 pparamsCostModels) & #prices . #steps .~ pparams ^. L.ppPricesL . to L.prSteps . to L.unboundRational . to inject & #prices . #memory .~ pparams ^. L.ppPricesL . to L.prMem . to L.unboundRational . to inject & #maxExecutionUnitsPerTransaction .~ pparams ^. L.ppMaxTxExUnitsL . to inject diff --git a/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs b/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs index 4cc5d56939..9a4e8f9f82 100644 --- a/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs +++ b/cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Type.hs @@ -83,9 +83,10 @@ utxoRpcPParamsToProtocolParams era pp = conwayEraOnwardsConstraints (convert era cm1 <- L.mkCostModel L.PlutusV1 $ pp ^. #costModels . #plutusV1 . #values cm2 <- L.mkCostModel L.PlutusV2 $ pp ^. #costModels . #plutusV2 . #values cm3 <- L.mkCostModel L.PlutusV3 $ pp ^. #costModels . #plutusV3 . #values + cm4 <- L.mkCostModel L.PlutusV4 $ pp ^. #costModels . #plutusV4 . #values -- do not add empty cost models let nonEmptyCostModels = - fromList . flip mapMaybe [cm1, cm2, cm3] $ \cm -> + fromList . flip mapMaybe [cm1, cm2, cm3, cm4] $ \cm -> if not (null $ L.getCostModelParams cm) then Just (L.getCostModelLanguage cm, cm) else Nothing From 79b751a77ef2a4ecda563b6ec1855c7ef4653046 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 1 Aug 2025 11:38:14 +0200 Subject: [PATCH 26/26] Do not use GetCBOR for LedgerPeerSnapshot --- cardano-api/src/Cardano/Api/Query/Internal/Expr.hs | 3 +-- .../src/Cardano/Api/Query/Internal/Type/QueryInMode.hs | 4 ++-- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Query/Internal/Expr.hs b/cardano-api/src/Cardano/Api/Query/Internal/Expr.hs index a29834edee..d2d3884be5 100644 --- a/cardano-api/src/Cardano/Api/Query/Internal/Expr.hs +++ b/cardano-api/src/Cardano/Api/Query/Internal/Expr.hs @@ -67,7 +67,6 @@ import Cardano.Ledger.Keys qualified as L import Cardano.Slotting.Slot import Ouroboros.Consensus.Cardano.Block qualified as Consensus import Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus -import Ouroboros.Network.Block (Serialised) import Ouroboros.Network.PeerSelection.LedgerPeers (LedgerPeerSnapshot) import Data.Map (Map) @@ -159,7 +158,7 @@ queryLedgerPeerSnapshot QueryInMode r IO - (Either UnsupportedNtcVersionError (Either EraMismatch (Serialised LedgerPeerSnapshot))) + (Either UnsupportedNtcVersionError (Either EraMismatch LedgerPeerSnapshot)) queryLedgerPeerSnapshot eon = querySbe eon QueryLedgerPeerSnapshot queryEraHistory diff --git a/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs b/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs index 7e8bba93d3..4aca66f4da 100644 --- a/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs +++ b/cardano-api/src/Cardano/Api/Query/Internal/Type/QueryInMode.hs @@ -317,7 +317,7 @@ data QueryInShelleyBasedEra era result where :: Set L.GovActionId -> QueryInShelleyBasedEra era (Seq (L.GovActionState (ShelleyLedgerEra era))) QueryLedgerPeerSnapshot - :: QueryInShelleyBasedEra era (Serialised LedgerPeerSnapshot) + :: QueryInShelleyBasedEra era LedgerPeerSnapshot QueryStakePoolDefaultVote :: Ledger.KeyHash 'Ledger.StakePool -> QueryInShelleyBasedEra era L.DefaultVote @@ -1024,7 +1024,7 @@ fromConsensusQueryResultShelleyBased sbe sbeQuery q' r' = _ -> fromConsensusQueryResultMismatch QueryLedgerPeerSnapshot{} -> case q' of - Consensus.GetCBOR Consensus.GetBigLedgerPeerSnapshot -> + Consensus.GetBigLedgerPeerSnapshot -> r' _ -> fromConsensusQueryResultMismatch QueryStakePoolDefaultVote{} ->