From 688f2bae35345fb33db37a0201b2fbf04dabd2e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Thu, 8 May 2025 15:51:05 +0300 Subject: [PATCH 1/4] Added Dijkstra era --- cabal.project | 1 + eras/dijkstra/CHANGELOG.md | 5 ++ eras/dijkstra/cardano-ledger-dijkstra.cabal | 85 ++++++++++++++++++++ eras/dijkstra/src/Cardano/Ledger/Dijkstra.hs | 1 + eras/dijkstra/test/Main.hs | 5 ++ 5 files changed, 97 insertions(+) create mode 100644 eras/dijkstra/CHANGELOG.md create mode 100644 eras/dijkstra/cardano-ledger-dijkstra.cabal create mode 100644 eras/dijkstra/src/Cardano/Ledger/Dijkstra.hs create mode 100644 eras/dijkstra/test/Main.hs diff --git a/cabal.project b/cabal.project index 2f2d71080fd..18ebd6a3ddc 100644 --- a/cabal.project +++ b/cabal.project @@ -38,6 +38,7 @@ packages: eras/babbage/test-suite eras/conway/impl eras/conway/test-suite + eras/dijkstra eras/mary/impl eras/shelley/impl eras/shelley/test-suite diff --git a/eras/dijkstra/CHANGELOG.md b/eras/dijkstra/CHANGELOG.md new file mode 100644 index 00000000000..4ebf2fc9e66 --- /dev/null +++ b/eras/dijkstra/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for cardano-ledger-dijkstra + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/eras/dijkstra/cardano-ledger-dijkstra.cabal b/eras/dijkstra/cardano-ledger-dijkstra.cabal new file mode 100644 index 00000000000..65cc263cee4 --- /dev/null +++ b/eras/dijkstra/cardano-ledger-dijkstra.cabal @@ -0,0 +1,85 @@ +cabal-version: 3.0 +name: cardano-ledger-dijkstra +version: 0.1.0.0 +license: Apache-2.0 +maintainer: operations@iohk.io +author: IOHK +bug-reports: https://github.com/intersectmbo/cardano-ledger/issues +synopsis: Cardano ledger with nested transactions +description: + This package builds upon the Conway ledger with a nested transactions system. + +category: Network +build-type: Simple +extra-source-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/intersectmbo/cardano-ledger + subdir: eras/dijkstra + +flag asserts + description: Enable assertions + default: False + +library + exposed-modules: + Cardano.Ledger.Dijkstra + hs-source-dirs: src + + default-language: Haskell2010 + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + + build-depends: + base >=4.14 && <5, + if flag(asserts) + ghc-options: -fno-ignore-asserts + +library testlib + exposed-modules: + visibility: public + hs-source-dirs: testlib + other-modules: Paths_cardano_ledger_dijkstra + default-language: Haskell2010 + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + + build-depends: + base, + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: + Paths_cardano_ledger_dijkstra + + default-language: Haskell2010 + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wpartial-fields + -Wunused-packages + -threaded + -rtsopts + -with-rtsopts=-N + + build-depends: + base, + testlib, diff --git a/eras/dijkstra/src/Cardano/Ledger/Dijkstra.hs b/eras/dijkstra/src/Cardano/Ledger/Dijkstra.hs new file mode 100644 index 00000000000..1b143f2662a --- /dev/null +++ b/eras/dijkstra/src/Cardano/Ledger/Dijkstra.hs @@ -0,0 +1 @@ +module Cardano.Ledger.Dijkstra () where diff --git a/eras/dijkstra/test/Main.hs b/eras/dijkstra/test/Main.hs new file mode 100644 index 00000000000..b5536813a16 --- /dev/null +++ b/eras/dijkstra/test/Main.hs @@ -0,0 +1,5 @@ +module Main where + +main :: IO () +main = putStrLn "TODO add a test suite" + From 53de1e319ab16f1ff5577d6f7ee09790354f3969 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Mon, 12 May 2025 14:50:25 +0300 Subject: [PATCH 2/4] WIP --- docs/NewEra.md | 8 ++++++++ eras/dijkstra/cardano-ledger-dijkstra.cabal | 4 ++++ .../src/Cardano/Ledger/Dijkstra/Era.hs | 19 +++++++++++++++++++ hie.yaml | 9 +++++++++ .../src/Cardano/Ledger/Binary/Version.hs | 2 +- 5 files changed, 41 insertions(+), 1 deletion(-) create mode 100644 docs/NewEra.md create mode 100644 eras/dijkstra/src/Cardano/Ledger/Dijkstra/Era.hs diff --git a/docs/NewEra.md b/docs/NewEra.md new file mode 100644 index 00000000000..345fb2a51a1 --- /dev/null +++ b/docs/NewEra.md @@ -0,0 +1,8 @@ +# Adding a new era to `cardano-ledger` + +First you need to crate a new sub-package in the `eras` directory. +It's easiest to just copy the `.cabal` file from the previous era and then make +some changes to that. Change the name of the project to `cardano-ledger-` +and update the description/synopsis. + +Next you'll want to add a datatype to represent the new era (e.g. `ConwayEra`). diff --git a/eras/dijkstra/cardano-ledger-dijkstra.cabal b/eras/dijkstra/cardano-ledger-dijkstra.cabal index 65cc263cee4..35380085026 100644 --- a/eras/dijkstra/cardano-ledger-dijkstra.cabal +++ b/eras/dijkstra/cardano-ledger-dijkstra.cabal @@ -25,6 +25,7 @@ flag asserts library exposed-modules: Cardano.Ledger.Dijkstra + Cardano.Ledger.Dijkstra.Era hs-source-dirs: src default-language: Haskell2010 @@ -39,6 +40,9 @@ library build-depends: base >=4.14 && <5, + cardano-ledger-conway, + cardano-ledger-mary, + cardano-ledger-core, if flag(asserts) ghc-options: -fno-ignore-asserts diff --git a/eras/dijkstra/src/Cardano/Ledger/Dijkstra/Era.hs b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/Era.hs new file mode 100644 index 00000000000..9f056dcf98b --- /dev/null +++ b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/Era.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Ledger.Dijkstra.Era () where + +import Cardano.Ledger.Conway (ConwayEra) +import Cardano.Ledger.Conway.Core (Era (..), Value) +import Cardano.Ledger.Mary (MaryValue) + +data DijkstraEra + +instance Era DijkstraEra where + type PreviousEra DijkstraEra = ConwayEra + type ProtVerLow DijkstraEra = 12 + type ProtVerHigh DijkstraEra = 12 + + eraName = "Dijkstra" + +type instance Value DijkstraEra = MaryValue diff --git a/hie.yaml b/hie.yaml index d400951404f..e0ec259e688 100644 --- a/hie.yaml +++ b/hie.yaml @@ -129,6 +129,15 @@ cradle: - path: "eras/conway/test-suite/test" component: "cardano-ledger-conway-test:test:cardano-ledger-conway-test" + - path: "eras/dijkstra/src" + component: "lib:cardano-ledger-dijkstra" + + - path: "eras/dijkstra/testlib" + component: "cardano-ledger-dijkstra:lib:testlib" + + - path: "eras/dijkstra/test" + component: "cardano-ledger-dijkstra:test:tests" + - path: "eras/mary/impl/src" component: "lib:cardano-ledger-mary" diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Version.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Version.hs index 372148b8ae6..bb1bc51a805 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Version.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Version.hs @@ -51,7 +51,7 @@ type MinVersion = 0 -- | Maximum supported version. This is the major protocol version of the latest known -- protocol version that we want to support, including for development and testing. -type MaxVersion = 12 +type MaxVersion = 13 instance Enum Version where toEnum = errorFail . mkVersion From 8a75dc3922c2542a42494aa4331671e85022bb26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Mon, 12 May 2025 16:37:29 +0300 Subject: [PATCH 3/4] WIP --- eras/dijkstra/cardano-ledger-dijkstra.cabal | 2 +- eras/dijkstra/src/Cardano/Ledger/Dijkstra.hs | 4 ++- .../src/Cardano/Ledger/Dijkstra/Era.hs | 4 ++- eras/dijkstra/test/Main.hs | 30 ++++++++++++++++++- 4 files changed, 36 insertions(+), 4 deletions(-) diff --git a/eras/dijkstra/cardano-ledger-dijkstra.cabal b/eras/dijkstra/cardano-ledger-dijkstra.cabal index 35380085026..e58613458ee 100644 --- a/eras/dijkstra/cardano-ledger-dijkstra.cabal +++ b/eras/dijkstra/cardano-ledger-dijkstra.cabal @@ -86,4 +86,4 @@ test-suite tests build-depends: base, - testlib, + cardano-ledger-dijkstra:{cardano-ledger-dijkstra, testlib}, diff --git a/eras/dijkstra/src/Cardano/Ledger/Dijkstra.hs b/eras/dijkstra/src/Cardano/Ledger/Dijkstra.hs index 1b143f2662a..4e9c5dd0e55 100644 --- a/eras/dijkstra/src/Cardano/Ledger/Dijkstra.hs +++ b/eras/dijkstra/src/Cardano/Ledger/Dijkstra.hs @@ -1 +1,3 @@ -module Cardano.Ledger.Dijkstra () where +module Cardano.Ledger.Dijkstra (module X) where + +import Cardano.Ledger.Dijkstra.Era as X diff --git a/eras/dijkstra/src/Cardano/Ledger/Dijkstra/Era.hs b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/Era.hs index 9f056dcf98b..7df5311a178 100644 --- a/eras/dijkstra/src/Cardano/Ledger/Dijkstra/Era.hs +++ b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/Era.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} -module Cardano.Ledger.Dijkstra.Era () where +module Cardano.Ledger.Dijkstra.Era ( + DijkstraEra, +) where import Cardano.Ledger.Conway (ConwayEra) import Cardano.Ledger.Conway.Core (Era (..), Value) diff --git a/eras/dijkstra/test/Main.hs b/eras/dijkstra/test/Main.hs index b5536813a16..a63469dbe96 100644 --- a/eras/dijkstra/test/Main.hs +++ b/eras/dijkstra/test/Main.hs @@ -1,5 +1,33 @@ +{-# LANGUAGE TypeApplications #-} + module Main where +import Cardano.Ledger.Dijkstra (DijkstraEra) + main :: IO () -main = putStrLn "TODO add a test suite" +main = + ledgerTestMain $ + describe "Dijkstra" $ do + GoldenTranslation.spec + Golden.spec + Spec.spec + Proposals.spec + Binary.spec + Cddl.spec + DRepRatify.spec + CommitteeRatify.spec + SPORatifySpec.spec + Genesis.spec + GovActionReorder.spec + roundTripJsonEraSpec @DijkstraEra + describe "Imp" $ + Imp.spec @DijkstraEra + describe "CostModels" $ do + CostModelsSpec.spec @DijkstraEra + describe "TxWits" $ do + TxWitsSpec.spec @DijkstraEra + describe "Plutus" $ do + PlutusSpec.spec + Regression.spec @DijkstraEra + TxInfo.spec From c416a5ab48d2dc42efcf620abceae99a2891f45b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Tue, 13 May 2025 19:01:00 +0300 Subject: [PATCH 4/4] Added DijkstraTxBody, Certs, Scripts, TxOut --- docs/NewEra.md | 12 +- .../impl/src/Cardano/Ledger/Conway/PParams.hs | 12 +- .../impl/src/Cardano/Ledger/Conway/TxBody.hs | 12 +- eras/dijkstra/cardano-ledger-dijkstra.cabal | 24 +- .../src/Cardano/Ledger/Dijkstra/PParams.hs | 164 ++++++++ .../src/Cardano/Ledger/Dijkstra/Scripts.hs | 134 +++++++ .../src/Cardano/Ledger/Dijkstra/TxBody.hs | 362 ++++++++++++++++++ .../src/Cardano/Ledger/Dijkstra/TxCert.hs | 134 +++++++ .../src/Cardano/Ledger/Dijkstra/TxOut.hs | 33 ++ eras/dijkstra/test/Main.hs | 19 + .../Ledger/Dijkstra/Binary/CddlSpec.hs | 105 +++++ libs/cardano-data/src/Data/OSet/Strict.hs | 15 +- .../Cardano/Ledger/Binary/Decoding/Sized.hs | 11 + 13 files changed, 1023 insertions(+), 14 deletions(-) create mode 100644 eras/dijkstra/src/Cardano/Ledger/Dijkstra/PParams.hs create mode 100644 eras/dijkstra/src/Cardano/Ledger/Dijkstra/Scripts.hs create mode 100644 eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxBody.hs create mode 100644 eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxCert.hs create mode 100644 eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxOut.hs create mode 100644 eras/dijkstra/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs diff --git a/docs/NewEra.md b/docs/NewEra.md index 345fb2a51a1..b64cbfeade3 100644 --- a/docs/NewEra.md +++ b/docs/NewEra.md @@ -5,4 +5,14 @@ It's easiest to just copy the `.cabal` file from the previous era and then make some changes to that. Change the name of the project to `cardano-ledger-` and update the description/synopsis. -Next you'll want to add a datatype to represent the new era (e.g. `ConwayEra`). +Next you'll want to add a datatype to represent the new era (e.g. `ConwayEra`). +Then copy over the entire test suite from the previous era and substitute the +era types for the newly added era type. Once the tests are in place, the type +checker will guide you to add all the necessary type family and type class +instances. + +It's a good idea to re-use the data types defined in the previous era at first. +You might need to use `coerce` in a couple of places to change the era parameter +when translating these types. Also, there might be some constraints that expect +the era to be exactly the previous era, you will probably be able to generalize +these functions and type class instances to make them compatible with the new era. diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs index f92dcb20910..1d563fb121b 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs @@ -70,6 +70,11 @@ module Cardano.Ledger.Conway.PParams ( conwayModifiedPPGroups, pvtHardForkInitiationL, pvtMotionNoConfidenceL, + conwayApplyPPUpdates, + emptyConwayPParams, + emptyConwayPParamsUpdate, + asNaturalHKD, + asBoundedIntegralHKD, ) where @@ -922,7 +927,12 @@ instance Era era => DecCBOR (ConwayPParams Identity era) where instance Era era => FromCBOR (ConwayPParams Identity era) where fromCBOR = fromEraCBOR @era -instance ToJSON (ConwayPParams Identity ConwayEra) where +instance + ( ConwayEraPParams era + , PParamsHKD Identity era ~ ConwayPParams Identity era + ) => + ToJSON (ConwayPParams Identity era) + where toJSON = object . conwayPParamsPairs toEncoding = pairs . mconcat . conwayPParamsPairs diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs index 9e967c7f3e5..c7fb9deec5f 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs @@ -338,11 +338,7 @@ instance EraTxBody ConwayEra where pure $ ConwayTxBody { ctbSpendInputs = btbInputs btb - , ctbOutputs = - mkSized (eraProtVerLow @ConwayEra) - . upgradeTxOut - . sizedValue - <$> btbOutputs btb + , ctbOutputs = unsafeMapSized upgradeTxOut <$> btbOutputs btb , ctbCerts = certsOSet , ctbWithdrawals = btbWithdrawals btb , ctbTxfee = btbTxFee btb @@ -354,11 +350,7 @@ instance EraTxBody ConwayEra where , ctbScriptIntegrityHash = btbScriptIntegrityHash btb , ctbTxNetworkId = btbTxNetworkId btb , ctbReferenceInputs = btbReferenceInputs btb - , ctbCollateralReturn = - mkSized (eraProtVerLow @ConwayEra) - . upgradeTxOut - . sizedValue - <$> btbCollateralReturn btb + , ctbCollateralReturn = unsafeMapSized upgradeTxOut $ btbCollateralReturn btb , ctbTotalCollateral = btbTotalCollateral btb , ctbCurrentTreasuryValue = SNothing , ctbProposalProcedures = OSet.empty diff --git a/eras/dijkstra/cardano-ledger-dijkstra.cabal b/eras/dijkstra/cardano-ledger-dijkstra.cabal index e58613458ee..1541c63e5dc 100644 --- a/eras/dijkstra/cardano-ledger-dijkstra.cabal +++ b/eras/dijkstra/cardano-ledger-dijkstra.cabal @@ -26,6 +26,11 @@ library exposed-modules: Cardano.Ledger.Dijkstra Cardano.Ledger.Dijkstra.Era + Cardano.Ledger.Dijkstra.TxBody + Cardano.Ledger.Dijkstra.TxCert + Cardano.Ledger.Dijkstra.TxOut + Cardano.Ledger.Dijkstra.PParams + Cardano.Ledger.Dijkstra.Scripts hs-source-dirs: src default-language: Haskell2010 @@ -40,9 +45,21 @@ library build-depends: base >=4.14 && <5, + containers, + cardano-strict-containers, + cardano-ledger-shelley, + cardano-ledger-allegra, + cardano-ledger-alonzo, + cardano-ledger-babbage, cardano-ledger-conway, cardano-ledger-mary, cardano-ledger-core, + cardano-ledger-binary, + cardano-data, + deepseq, + mempack, + microlens, + nothunks, if flag(asserts) ghc-options: -fno-ignore-asserts @@ -86,4 +103,9 @@ test-suite tests build-depends: base, - cardano-ledger-dijkstra:{cardano-ledger-dijkstra, testlib}, + cardano-ledger-allegra, + cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib}, + cardano-ledger-conway:{cardano-ledger-conway, testlib}, + cardano-ledger-dijkstra, + cardano-ledger-core:{cardano-ledger-core, testlib}, + cardano-ledger-binary:testlib, diff --git a/eras/dijkstra/src/Cardano/Ledger/Dijkstra/PParams.hs b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/PParams.hs new file mode 100644 index 00000000000..001be5a4703 --- /dev/null +++ b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/PParams.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Dijkstra.PParams () where + +import Cardano.Ledger.Alonzo.PParams ( + AlonzoEraPParams (..), + OrdExUnits (..), + ppuCollateralPercentageL, + ppuMaxValSizeL, + ) +import Cardano.Ledger.BaseTypes (EpochInterval (..), StrictMaybe (..)) +import Cardano.Ledger.Conway.Core ( + BabbageEraPParams (..), + ppuCoinsPerUTxOByteL, + ppuCommitteeMaxTermLengthL, + ppuDRepDepositL, + ppuGovActionDepositL, + ppuGovActionLifetimeL, + unCoinPerByte, + ) +import Cardano.Ledger.Conway.PParams ( + ConwayEraPParams (..), + ConwayPParams (..), + THKD (..), + asBoundedIntegralHKD, + asNaturalHKD, + conwayApplyPPUpdates, + conwayModifiedPPGroups, + emptyConwayPParams, + emptyConwayPParamsUpdate, + ) +import Cardano.Ledger.Core +import Cardano.Ledger.Dijkstra (DijkstraEra) +import Cardano.Ledger.HKD (HKD, HKDFunctor (..)) +import Cardano.Ledger.Plutus (ExUnits) +import Cardano.Ledger.Val (Val (..)) +import Data.Coerce (coerce) +import Data.Data (Proxy (..)) +import Data.Word (Word16, Word32) +import Lens.Micro (Lens', lens, to, (^.)) +import Numeric.Natural (Natural) + +instance EraPParams DijkstraEra where + type PParamsHKD f DijkstraEra = ConwayPParams f DijkstraEra + type UpgradePParams f DijkstraEra = () + type DowngradePParams f DijkstraEra = () + + applyPPUpdates (PParams pp) (PParamsUpdate ppu) = + PParams $ conwayApplyPPUpdates pp ppu + + emptyPParamsIdentity = emptyConwayPParams + emptyPParamsStrictMaybe = emptyConwayPParamsUpdate + + upgradePParamsHKD () = coerce + downgradePParamsHKD () = coerce + + hkdMinFeeAL = lens (unTHKD . cppMinFeeA) $ \pp x -> pp {cppMinFeeA = THKD x} + hkdMinFeeBL = lens (unTHKD . cppMinFeeB) $ \pp x -> pp {cppMinFeeB = THKD x} + hkdMaxBBSizeL = lens (unTHKD . cppMaxBBSize) $ \pp x -> pp {cppMaxBBSize = THKD x} + hkdMaxTxSizeL = lens (unTHKD . cppMaxTxSize) $ \pp x -> pp {cppMaxTxSize = THKD x} + hkdMaxBHSizeL = lens (unTHKD . cppMaxBHSize) $ \pp x -> pp {cppMaxBHSize = THKD x} + hkdKeyDepositL = lens (unTHKD . cppKeyDeposit) $ \pp x -> pp {cppKeyDeposit = THKD x} + hkdPoolDepositL = lens (unTHKD . cppPoolDeposit) $ \pp x -> pp {cppPoolDeposit = THKD x} + hkdEMaxL = lens (unTHKD . cppEMax) $ \pp x -> pp {cppEMax = THKD x} + hkdNOptL = lens (unTHKD . cppNOpt) $ \pp x -> pp {cppNOpt = THKD x} + hkdA0L = lens (unTHKD . cppA0) $ \pp x -> pp {cppA0 = THKD x} + hkdRhoL = lens (unTHKD . cppRho) $ \pp x -> pp {cppRho = THKD x} + hkdTauL = lens (unTHKD . cppTau) $ \pp x -> pp {cppTau = THKD x} + hkdProtocolVersionL = notSupportedInThisEraL + hkdMinPoolCostL = lens (unTHKD . cppMinPoolCost) $ \pp x -> pp {cppMinPoolCost = THKD x} + ppProtocolVersionL = ppLens . lens cppProtocolVersion (\pp x -> pp {cppProtocolVersion = x}) + + ppDG = to (const minBound) + ppuProtocolVersionL = notSupportedInThisEraL + hkdDL = notSupportedInThisEraL + hkdExtraEntropyL = notSupportedInThisEraL + hkdMinUTxOValueL = notSupportedInThisEraL + +instance AlonzoEraPParams DijkstraEra where + hkdCoinsPerUTxOWordL = notSupportedInThisEraL + hkdCostModelsL = lens (unTHKD . cppCostModels) $ \pp x -> pp {cppCostModels = THKD x} + hkdPricesL = lens (unTHKD . cppPrices) $ \pp x -> pp {cppPrices = THKD x} + + hkdMaxTxExUnitsL :: forall f. HKDFunctor f => Lens' (PParamsHKD f DijkstraEra) (HKD f ExUnits) + hkdMaxTxExUnitsL = + lens (hkdMap (Proxy @f) unOrdExUnits . unTHKD . cppMaxTxExUnits) $ \pp x -> + pp {cppMaxTxExUnits = THKD $ hkdMap (Proxy @f) OrdExUnits x} + hkdMaxBlockExUnitsL :: forall f. HKDFunctor f => Lens' (PParamsHKD f DijkstraEra) (HKD f ExUnits) + hkdMaxBlockExUnitsL = + lens (hkdMap (Proxy @f) unOrdExUnits . unTHKD . cppMaxBlockExUnits) $ \pp x -> + pp {cppMaxBlockExUnits = THKD $ hkdMap (Proxy @f) OrdExUnits x} + hkdMaxValSizeL :: forall f. HKDFunctor f => Lens' (PParamsHKD f DijkstraEra) (HKD f Natural) + hkdMaxValSizeL = + lens (asNaturalHKD @f @Word32 . (unTHKD . cppMaxValSize)) $ + \pp x -> pp {cppMaxValSize = THKD (asBoundedIntegralHKD @f @Natural @Word32 x)} + hkdCollateralPercentageL :: + forall f. HKDFunctor f => Lens' (PParamsHKD f DijkstraEra) (HKD f Natural) + hkdCollateralPercentageL = + lens (asNaturalHKD @f @Word16 . (unTHKD . cppCollateralPercentage)) $ + \pp x -> pp {cppCollateralPercentage = THKD (asBoundedIntegralHKD @f @Natural @Word16 x)} + hkdMaxCollateralInputsL :: + forall f. HKDFunctor f => Lens' (PParamsHKD f DijkstraEra) (HKD f Natural) + hkdMaxCollateralInputsL = + lens (asNaturalHKD @f @Word16 . (unTHKD . cppMaxCollateralInputs)) $ + \pp x -> pp {cppMaxCollateralInputs = THKD (asBoundedIntegralHKD @f @Natural @Word16 x)} + +instance BabbageEraPParams DijkstraEra where + hkdCoinsPerUTxOByteL = + lens (unTHKD . cppCoinsPerUTxOByte) $ \pp x -> pp {cppCoinsPerUTxOByte = THKD x} + +instance ConwayEraPParams DijkstraEra where + modifiedPPGroups (PParamsUpdate ppu) = conwayModifiedPPGroups ppu + ppuWellFormed _pv ppu = + and + [ -- Numbers + isValid (/= 0) ppuMaxBBSizeL + , isValid (/= 0) ppuMaxTxSizeL + , isValid (/= 0) ppuMaxBHSizeL + , isValid (/= 0) ppuMaxValSizeL + , isValid (/= 0) ppuCollateralPercentageL + , isValid (/= EpochInterval 0) ppuCommitteeMaxTermLengthL + , isValid (/= EpochInterval 0) ppuGovActionLifetimeL + , -- Coins + isValid (/= zero) ppuPoolDepositL + , isValid (/= zero) ppuGovActionDepositL + , isValid (/= zero) ppuDRepDepositL + , isValid ((/= zero) . unCoinPerByte) ppuCoinsPerUTxOByteL + , ppu /= emptyPParamsUpdate + ] + where + isValid :: + (t -> Bool) -> + Lens' (PParamsUpdate DijkstraEra) (StrictMaybe t) -> + Bool + isValid p l = case ppu ^. l of + SJust x -> p x + SNothing -> True + hkdPoolVotingThresholdsL = + lens (unTHKD . cppPoolVotingThresholds) $ \pp x -> pp {cppPoolVotingThresholds = THKD x} + hkdDRepVotingThresholdsL = + lens (unTHKD . cppDRepVotingThresholds) $ \pp x -> pp {cppDRepVotingThresholds = THKD x} + hkdCommitteeMinSizeL :: forall f. HKDFunctor f => Lens' (PParamsHKD f DijkstraEra) (HKD f Natural) + hkdCommitteeMinSizeL = + lens (asNaturalHKD @f @Word16 . (unTHKD . cppCommitteeMinSize)) $ + \pp x -> pp {cppCommitteeMinSize = THKD (asBoundedIntegralHKD @f @Natural @Word16 x)} + hkdCommitteeMaxTermLengthL = + lens (unTHKD . cppCommitteeMaxTermLength) $ \pp x -> pp {cppCommitteeMaxTermLength = THKD x} + hkdGovActionLifetimeL = + lens (unTHKD . cppGovActionLifetime) $ \pp x -> pp {cppGovActionLifetime = THKD x} + hkdGovActionDepositL = + lens (unTHKD . cppGovActionDeposit) $ \pp x -> pp {cppGovActionDeposit = THKD x} + hkdDRepDepositL = + lens (unTHKD . cppDRepDeposit) $ \pp x -> pp {cppDRepDeposit = THKD x} + hkdDRepActivityL = + lens (unTHKD . cppDRepActivity) $ \pp x -> pp {cppDRepActivity = THKD x} + hkdMinFeeRefScriptCostPerByteL = + lens (unTHKD . cppMinFeeRefScriptCostPerByte) $ \pp x -> pp {cppMinFeeRefScriptCostPerByte = THKD x} diff --git a/eras/dijkstra/src/Cardano/Ledger/Dijkstra/Scripts.hs b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/Scripts.hs new file mode 100644 index 00000000000..7e6e89962a8 --- /dev/null +++ b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/Scripts.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Dijkstra.Scripts () where + +import Cardano.Ledger.Allegra.Scripts ( + AllegraEraScript (..), + Timelock, + getRequireAllOfTimelock, + getRequireAnyOfTimelock, + getRequireMOfTimelock, + getRequireSignatureTimelock, + getTimeExpireTimelock, + getTimeStartTimelock, + mkRequireAllOfTimelock, + mkRequireAnyOfTimelock, + mkRequireMOfTimelock, + mkRequireSignatureTimelock, + mkTimeExpireTimelock, + mkTimeStartTimelock, + ) +import Cardano.Ledger.Alonzo (AlonzoScript) +import Cardano.Ledger.Alonzo.Scripts ( + AlonzoEraScript (..), + AlonzoScript (..), + alonzoScriptPrefixTag, + ) +import Cardano.Ledger.Conway (ConwayEra) +import Cardano.Ledger.Conway.Scripts (ConwayEraScript (..), ConwayPlutusPurpose (..)) +import Cardano.Ledger.Core (EraScript (..), SafeToHash) +import Cardano.Ledger.Dijkstra (DijkstraEra) +import Cardano.Ledger.Dijkstra.PParams () +import Cardano.Ledger.Dijkstra.TxCert () +import Cardano.Ledger.Plutus (Language (..)) +import Cardano.Ledger.Shelley.Scripts (ShelleyEraScript (..)) +import Control.DeepSeq (NFData) +import Data.MemPack (MemPack (..)) +import NoThunks.Class (NoThunks) + +instance EraScript DijkstraEra where + type Script DijkstraEra = AlonzoScript DijkstraEra + type NativeScript DijkstraEra = Timelock DijkstraEra + + upgradeScript = undefined + + scriptPrefixTag = alonzoScriptPrefixTag + + getNativeScript (TimelockScript ts) = Just ts + getNativeScript _ = Nothing + + fromNativeScript = TimelockScript + +instance MemPack (PlutusScript DijkstraEra) where + packedByteCount = undefined + packM = undefined + unpackM = undefined + +instance AlonzoEraScript DijkstraEra where + newtype PlutusScript DijkstraEra = MkDijkstraPlutusScript (PlutusScript ConwayEra) + deriving newtype (SafeToHash, Show, NFData, NoThunks, Eq, Ord) + + type PlutusPurpose f DijkstraEra = ConwayPlutusPurpose f DijkstraEra + + eraMaxLanguage = PlutusV3 + + mkPlutusScript = fmap MkDijkstraPlutusScript . mkPlutusScript + + withPlutusScript (MkDijkstraPlutusScript s) = withPlutusScript s + + hoistPlutusPurpose f = \case + ConwaySpending x -> ConwaySpending $ f x + ConwayMinting x -> ConwayMinting $ f x + ConwayCertifying x -> ConwayCertifying $ f x + ConwayRewarding x -> ConwayRewarding $ f x + ConwayVoting x -> ConwayVoting $ f x + ConwayProposing x -> ConwayProposing $ f x + + mkSpendingPurpose = ConwaySpending + + toSpendingPurpose (ConwaySpending i) = Just i + toSpendingPurpose _ = Nothing + + mkMintingPurpose = ConwayMinting + + toMintingPurpose (ConwayMinting i) = Just i + toMintingPurpose _ = Nothing + + mkCertifyingPurpose = ConwayCertifying + + toCertifyingPurpose (ConwayCertifying i) = Just i + toCertifyingPurpose _ = Nothing + + mkRewardingPurpose = ConwayRewarding + + toRewardingPurpose (ConwayRewarding i) = Just i + toRewardingPurpose _ = Nothing + + upgradePlutusPurposeAsIx = undefined + +instance ConwayEraScript DijkstraEra where + mkVotingPurpose = ConwayVoting + + toVotingPurpose (ConwayVoting i) = Just i + toVotingPurpose _ = Nothing + + mkProposingPurpose = ConwayProposing + + toProposingPurpose (ConwayProposing i) = Just i + toProposingPurpose _ = Nothing + +instance ShelleyEraScript DijkstraEra where + mkRequireSignature = mkRequireSignatureTimelock + getRequireSignature = getRequireSignatureTimelock + + mkRequireAllOf = mkRequireAllOfTimelock + getRequireAllOf = getRequireAllOfTimelock + + mkRequireAnyOf = mkRequireAnyOfTimelock + getRequireAnyOf = getRequireAnyOfTimelock + + mkRequireMOf = mkRequireMOfTimelock + getRequireMOf = getRequireMOfTimelock + +instance AllegraEraScript DijkstraEra where + mkTimeStart = mkTimeStartTimelock + getTimeStart = getTimeStartTimelock + + mkTimeExpire = mkTimeExpireTimelock + getTimeExpire = getTimeExpireTimelock diff --git a/eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxBody.hs b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxBody.hs new file mode 100644 index 00000000000..6ada172a1bb --- /dev/null +++ b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxBody.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Dijkstra.TxBody () where + +import Cardano.Ledger.BaseTypes (Network, StrictMaybe, fromSMaybe) +import Cardano.Ledger.Binary (DecCBOR (..), Sized (..), mkSized) +import Cardano.Ledger.Binary.Coders ( + Decode (..), + Field, + decode, + field, + fieldGuarded, + invalidField, + ofield, + ) +import Cardano.Ledger.Coin (Coin, decodePositiveCoin) +import Cardano.Ledger.Conway.Core +import Cardano.Ledger.Conway.Governance (ProposalProcedure, VotingProcedures (..)) +import Cardano.Ledger.Conway.TxBody (TxBody (..), conwayTotalDepositsTxBody) +import Cardano.Ledger.Dijkstra (DijkstraEra) +import Cardano.Ledger.Dijkstra.PParams () +import Cardano.Ledger.Dijkstra.Scripts () +import Cardano.Ledger.Dijkstra.TxOut () +import Cardano.Ledger.Mary.Value (MultiAsset) +import Cardano.Ledger.TxIn (TxIn) +import Cardano.Ledger.Val (Val (..)) +import Control.DeepSeq (NFData) +import qualified Data.OSet.Strict as OSet +import Data.Sequence.Strict (StrictSeq) +import Data.Set (Set) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Cardano.Ledger.MemoBytes (getMemoRawType, MemoBytes, mkMemoizedEra, Memoized (..), lensMemoRawType) +import Cardano.Ledger.Babbage.TxBody (babbageSpendableInputsTxBodyF, babbageAllInputsTxBodyF) +import Lens.Micro ((^.)) +import Data.Coerce (coerce) + +data DijkstraTxBodyRaw = DijkstraTxBodyRaw + { dtbrSpendInputs :: !(Set TxIn) + , dtbrCollateralInputs :: !(Set TxIn) + , dtbrReferenceInputs :: !(Set TxIn) + , dtbrOutputs :: !(StrictSeq (Sized (TxOut DijkstraEra))) + , dtbrCollateralReturn :: !(StrictMaybe (Sized (TxOut DijkstraEra))) + , dtbrTotalCollateral :: !(StrictMaybe Coin) + , dtbrCerts :: !(OSet.OSet (TxCert DijkstraEra)) + , dtbrWithdrawals :: !Withdrawals + , dtbrFee :: !Coin + , dtbrVldt :: !ValidityInterval + , dtbrReqSignerHashes :: !(Set (KeyHash 'Witness)) + , dtbrMint :: !MultiAsset + , dtbrScriptIntegrityHash :: !(StrictMaybe ScriptIntegrityHash) + , dtbrAuxDataHash :: !(StrictMaybe TxAuxDataHash) + , dtbrNetworkId :: !(StrictMaybe Network) + , dtbrVotingProcedures :: !(VotingProcedures DijkstraEra) + , dtbrProposalProcedures :: !(OSet.OSet (ProposalProcedure DijkstraEra)) + , dtbrCurrentTreasuryValue :: !(StrictMaybe Coin) + , dtbrTreasuryDonation :: !Coin + } + deriving (Generic) + +deriving instance Eq DijkstraTxBodyRaw + +instance NoThunks DijkstraTxBodyRaw + +instance NFData DijkstraTxBodyRaw + +deriving instance Show DijkstraTxBodyRaw + +basicDijkstraTxBodyRaw :: DijkstraTxBodyRaw +basicDijkstraTxBodyRaw = undefined + +instance DecCBOR DijkstraTxBodyRaw where + decCBOR = + decode $ + SparseKeyed + "TxBodyRaw" + basicDijkstraTxBodyRaw + bodyFields + requiredFields + where + bodyFields :: Word -> Field DijkstraTxBodyRaw + bodyFields 0 = field (\x tx -> tx {dtbrSpendInputs = x}) From + bodyFields 1 = field (\x tx -> tx {dtbrOutputs = x}) From + bodyFields 2 = field (\x tx -> tx {dtbrFee = x}) From + bodyFields 3 = + ofield + (\x tx -> tx {dtbrVldt = (dtbrVldt tx) {invalidHereafter = x}}) + From + bodyFields 4 = + fieldGuarded + (emptyFailure "Certificates" "non-empty") + OSet.null + (\x tx -> tx {dtbrCerts = x}) + From + bodyFields 5 = + fieldGuarded + (emptyFailure "Withdrawals" "non-empty") + (null . unWithdrawals) + (\x tx -> tx {dtbrWithdrawals = x}) + From + bodyFields 7 = ofield (\x tx -> tx {dtbrAuxDataHash = x}) From + bodyFields 8 = + ofield + (\x tx -> tx {dtbrVldt = (dtbrVldt tx) {invalidBefore = x}}) + From + bodyFields 9 = + fieldGuarded + (emptyFailure "Mint" "non-empty") + (== mempty) + (\x tx -> tx {dtbrMint = x}) + From + bodyFields 11 = ofield (\x tx -> tx {dtbrScriptIntegrityHash = x}) From + bodyFields 13 = + fieldGuarded + (emptyFailure "Collateral Inputs" "non-empty") + null + (\x tx -> tx {dtbrCollateralInputs = x}) + From + bodyFields 14 = + fieldGuarded + (emptyFailure "Required Signer Hashes" "non-empty") + null + (\x tx -> tx {dtbrReqSignerHashes = x}) + From + bodyFields 15 = ofield (\x tx -> tx {dtbrNetworkId = x}) From + bodyFields 16 = ofield (\x tx -> tx {dtbrCollateralReturn = x}) From + bodyFields 17 = ofield (\x tx -> tx {dtbrTotalCollateral = x}) From + bodyFields 18 = + fieldGuarded + (emptyFailure "Reference Inputs" "non-empty") + null + (\x tx -> tx {dtbrReferenceInputs = x}) + From + bodyFields 19 = + fieldGuarded + (emptyFailure "VotingProcedures" "non-empty") + (null . unVotingProcedures) + (\x tx -> tx {dtbrVotingProcedures = x}) + From + bodyFields 20 = + fieldGuarded + (emptyFailure "ProposalProcedures" "non-empty") + OSet.null + (\x tx -> tx {dtbrProposalProcedures = x}) + From + bodyFields 21 = ofield (\x tx -> tx {dtbrCurrentTreasuryValue = x}) From + bodyFields 22 = + ofield + (\x tx -> tx {dtbrTreasuryDonation = fromSMaybe zero x}) + (D (decodePositiveCoin $ emptyFailure "Treasury Donation" "non-zero")) + bodyFields n = invalidField n + requiredFields :: [(Word, String)] + requiredFields = + [ (0, "inputs") + , (1, "outputs") + , (2, "fee") + ] + emptyFailure fieldName requirement = + "TxBody: '" <> fieldName <> "' must be " <> requirement <> " when supplied" + +deriving newtype instance DecCBOR (TxBody DijkstraEra) + +deriving instance NoThunks (TxBody DijkstraEra) + +deriving instance Eq (TxBody DijkstraEra) + +deriving newtype instance NFData (TxBody DijkstraEra) + +deriving instance Show (TxBody DijkstraEra) + +pattern DijkstraTxBody :: + Set TxIn -> + Set TxIn -> + Set TxIn -> + StrictSeq (Sized (TxOut DijkstraEra)) -> + StrictMaybe (Sized (TxOut DijkstraEra)) -> + StrictMaybe Coin -> + OSet.OSet (TxCert DijkstraEra) -> + Withdrawals -> + Coin -> + ValidityInterval -> + Set (KeyHash 'Witness) -> + MultiAsset -> + StrictMaybe ScriptIntegrityHash -> + StrictMaybe TxAuxDataHash -> + StrictMaybe Network -> + VotingProcedures DijkstraEra -> + OSet.OSet (ProposalProcedure DijkstraEra) -> + StrictMaybe Coin -> + Coin -> + TxBody DijkstraEra +pattern DijkstraTxBody + { dtbSpendInputs + , dtbCollateralInputs + , dtbReferenceInputs + , dtbOutputs + , dtbCollateralReturn + , dtbTotalCollateral + , dtbCerts + , dtbWithdrawals + , dtbTxfee + , dtbVldt + , dtbReqSignerHashes + , dtbMint + , dtbScriptIntegrityHash + , dtbAdHash + , dtbTxNetworkId + , dtbVotingProcedures + , dtbProposalProcedures + , dtbCurrentTreasuryValue + , dtbTreasuryDonation + } <- + ( getMemoRawType -> + DijkstraTxBodyRaw + { dtbrSpendInputs = dtbSpendInputs + , dtbrCollateralInputs = dtbCollateralInputs + , dtbrReferenceInputs = dtbReferenceInputs + , dtbrOutputs = dtbOutputs + , dtbrCollateralReturn = dtbCollateralReturn + , dtbrTotalCollateral = dtbTotalCollateral + , dtbrCerts = dtbCerts + , dtbrWithdrawals = dtbWithdrawals + , dtbrFee = dtbTxfee + , dtbrVldt = dtbVldt + , dtbrReqSignerHashes = dtbReqSignerHashes + , dtbrMint = dtbMint + , dtbrScriptIntegrityHash = dtbScriptIntegrityHash + , dtbrAuxDataHash = dtbAdHash + , dtbrNetworkId = dtbTxNetworkId + , dtbrVotingProcedures = dtbVotingProcedures + , dtbrProposalProcedures = dtbProposalProcedures + , dtbrCurrentTreasuryValue = dtbCurrentTreasuryValue + , dtbrTreasuryDonation = dtbTreasuryDonation + } + ) + where + DijkstraTxBody + inputsX + collateralX + referenceInputsX + outputsX + collateralReturnX + totalCollateralX + certsX + withdrawalsX + txfeeX + vldtX + reqSignerHashesX + mintX + scriptIntegrityHashX + adHashX + txnetworkidX + votingProcedures + proposalProcedures + currentTreasuryValue + treasuryDonation = + mkMemoizedEra @DijkstraEra $ + DijkstraTxBodyRaw + inputsX + collateralX + referenceInputsX + outputsX + collateralReturnX + totalCollateralX + certsX + withdrawalsX + txfeeX + vldtX + reqSignerHashesX + mintX + scriptIntegrityHashX + adHashX + txnetworkidX + votingProcedures + proposalProcedures + currentTreasuryValue + treasuryDonation + +{-# COMPLETE DijkstraTxBody #-} + +instance Memoized (TxBody DijkstraEra) where + type RawType (TxBody DijkstraEra) = DijkstraTxBodyRaw + +instance EraTxBody DijkstraEra where + newtype TxBody DijkstraEra = MkDijkstraTxBody (MemoBytes DijkstraTxBodyRaw) + + mkBasicTxBody = mkMemoizedEra @DijkstraEra basicDijkstraTxBodyRaw + + inputsTxBodyL = lensMemoRawType @DijkstraEra dtbrSpendInputs $ + \txb x -> txb {dtbrSpendInputs = x} + {-# INLINE inputsTxBodyL #-} + + outputsTxBodyL = + lensMemoRawType @DijkstraEra (fmap sizedValue . dtbrOutputs) $ + \txb x -> txb {dtbrOutputs = mkSized (eraProtVerLow @DijkstraEra) <$> x} + {-# INLINE outputsTxBodyL #-} + + feeTxBodyL = lensMemoRawType @DijkstraEra dtbrFee (\txb x -> txb {dtbrFee = x}) + {-# INLINE feeTxBodyL #-} + + auxDataHashTxBodyL = lensMemoRawType @DijkstraEra dtbrAuxDataHash $ + \txb x -> txb {dtbrAuxDataHash = x} + {-# INLINE auxDataHashTxBodyL #-} + + spendableInputsTxBodyF = babbageSpendableInputsTxBodyF + {-# INLINE spendableInputsTxBodyF #-} + + allInputsTxBodyF = babbageAllInputsTxBodyF + {-# INLINE allInputsTxBodyF #-} + + withdrawalsTxBodyL = lensMemoRawType @DijkstraEra dtbrWithdrawals $ + \txb x -> txb {dtbrWithdrawals = x} + {-# INLINE withdrawalsTxBodyL #-} + + certsTxBodyL = + lensMemoRawType @DijkstraEra (OSet.toStrictSeq . dtbrCerts) $ + \txb x -> txb {dtbrCerts = OSet.fromStrictSeq x} + {-# INLINE certsTxBodyL #-} + + getTotalDepositsTxBody = dijkstraTotalDepositsTxBody + + getTotalRefundsTxBody pp lookupStakingDeposit lookupDRepDeposit txBody = + getTotalRefundsTxCerts pp lookupStakingDeposit lookupDRepDeposit (txBody ^. certsTxBodyL) + + upgradeTxBody ConwayTxBody {..} = do + pure $ + DijkstraTxBody + { dtbSpendInputs = ctbSpendInputs + , dtbOutputs = undefined <$> ctbOutputs + , dtbCerts = OSet.mapL coerce ctbCerts + , dtbWithdrawals = ctbWithdrawals + , dtbTxfee = ctbTxfee + , dtbVldt = ctbVldt + , dtbAdHash = ctbAdHash + , dtbMint = ctbMint + , dtbCollateralInputs = ctbCollateralInputs + , dtbReqSignerHashes = ctbReqSignerHashes + , dtbScriptIntegrityHash = ctbScriptIntegrityHash + , dtbTxNetworkId = ctbTxNetworkId + , dtbReferenceInputs = ctbReferenceInputs + , dtbCollateralReturn = fmap upgradeTxOut <$> ctbCollateralReturn + , dtbTotalCollateral = ctbTotalCollateral + , dtbCurrentTreasuryValue = ctbCurrentTreasuryValue + , dtbProposalProcedures = undefined <$> ctbProposalProcedures + , dtbVotingProcedures = coerce ctbVotingProcedures + , dtbTreasuryDonation = ctbTreasuryDonation + } + +dijkstraTotalDepositsTxBody :: PParams DijkstraEra -> (KeyHash StakePool -> Bool) -> TxBody DijkstraEra -> Coin +dijkstraTotalDepositsTxBody = undefined + diff --git a/eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxCert.hs b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxCert.hs new file mode 100644 index 00000000000..4bca57141f4 --- /dev/null +++ b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxCert.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Dijkstra.TxCert () where + +import Cardano.Ledger.Conway.Core ( + ConwayEraTxCert, + ShelleyEraTxCert (..), + notSupportedInThisEra, + pattern RegDepositDelegTxCert, + pattern RegDepositTxCert, + pattern RegTxCert, + pattern UnRegDepositTxCert, + pattern UnRegTxCert, + ) +import Cardano.Ledger.Conway.TxCert ( + ConwayDelegCert (..), + ConwayGovCert (..), + ConwayTxCert (..), + conwayTotalDepositsTxCerts, + conwayTotalRefundsTxCerts, + getScriptWitnessConwayTxCert, + getVKeyWitnessConwayTxCert, + pattern ConwayRegCert, + pattern DelegStake, ConwayEraTxCert (..), + ) +import Cardano.Ledger.Core (EraTxCert (..), PoolCert (..)) +import Cardano.Ledger.Dijkstra (DijkstraEra) +import Data.Coerce (coerce) +import Data.Maybe.Strict (StrictMaybe (..)) +import Data.Void (Void) +import Cardano.Ledger.Dijkstra.PParams () + +instance EraTxCert DijkstraEra where + type TxCert DijkstraEra = ConwayTxCert DijkstraEra + + type TxCertUpgradeError DijkstraEra = Void + + upgradeTxCert = Right . coerce + + getVKeyWitnessTxCert = getVKeyWitnessConwayTxCert + + getScriptWitnessTxCert = getScriptWitnessConwayTxCert + + mkRegPoolTxCert = ConwayTxCertPool . RegPool + + getRegPoolTxCert (ConwayTxCertPool (RegPool poolParams)) = Just poolParams + getRegPoolTxCert _ = Nothing + + mkRetirePoolTxCert poolId epochNo = ConwayTxCertPool $ RetirePool poolId epochNo + + getRetirePoolTxCert (ConwayTxCertPool (RetirePool poolId epochNo)) = Just (poolId, epochNo) + getRetirePoolTxCert _ = Nothing + + lookupRegStakeTxCert = \case + RegTxCert c -> Just c + RegDepositTxCert c _ -> Just c + RegDepositDelegTxCert c _ _ -> Just c + _ -> Nothing + lookupUnRegStakeTxCert = \case + UnRegTxCert c -> Just c + UnRegDepositTxCert c _ -> Just c + _ -> Nothing + + getTotalRefundsTxCerts = conwayTotalRefundsTxCerts + + getTotalDepositsTxCerts = conwayTotalDepositsTxCerts + +instance ShelleyEraTxCert DijkstraEra where + mkRegTxCert c = ConwayTxCertDeleg $ ConwayRegCert c SNothing + + getRegTxCert (ConwayTxCertDeleg (ConwayRegCert c SNothing)) = Just c + getRegTxCert _ = Nothing + + mkUnRegTxCert c = ConwayTxCertDeleg $ ConwayUnRegCert c SNothing + + getUnRegTxCert (ConwayTxCertDeleg (ConwayUnRegCert c SNothing)) = Just c + getUnRegTxCert _ = Nothing + + mkDelegStakeTxCert c kh = ConwayTxCertDeleg $ ConwayDelegCert c (DelegStake kh) + + getDelegStakeTxCert (ConwayTxCertDeleg (ConwayDelegCert c (DelegStake kh))) = Just (c, kh) + getDelegStakeTxCert _ = Nothing + + mkGenesisDelegTxCert = notSupportedInThisEra + getGenesisDelegTxCert _ = Nothing + + mkMirTxCert = notSupportedInThisEra + getMirTxCert = const Nothing + +instance ConwayEraTxCert DijkstraEra where + mkRegDepositTxCert cred c = ConwayTxCertDeleg $ ConwayRegCert cred $ SJust c + + getRegDepositTxCert (ConwayTxCertDeleg (ConwayRegCert cred (SJust c))) = Just (cred, c) + getRegDepositTxCert _ = Nothing + + mkUnRegDepositTxCert cred c = ConwayTxCertDeleg $ ConwayUnRegCert cred (SJust c) + getUnRegDepositTxCert (ConwayTxCertDeleg (ConwayUnRegCert cred (SJust c))) = Just (cred, c) + getUnRegDepositTxCert _ = Nothing + + mkDelegTxCert cred d = ConwayTxCertDeleg $ ConwayDelegCert cred d + getDelegTxCert (ConwayTxCertDeleg (ConwayDelegCert cred d)) = Just (cred, d) + getDelegTxCert _ = Nothing + + mkRegDepositDelegTxCert cred d c = ConwayTxCertDeleg $ ConwayRegDelegCert cred d c + getRegDepositDelegTxCert (ConwayTxCertDeleg (ConwayRegDelegCert cred d c)) = Just (cred, d, c) + getRegDepositDelegTxCert _ = Nothing + + mkAuthCommitteeHotKeyTxCert ck hk = ConwayTxCertGov $ ConwayAuthCommitteeHotKey ck hk + getAuthCommitteeHotKeyTxCert (ConwayTxCertGov (ConwayAuthCommitteeHotKey ck hk)) = Just (ck, hk) + getAuthCommitteeHotKeyTxCert _ = Nothing + + mkResignCommitteeColdTxCert ck a = ConwayTxCertGov $ ConwayResignCommitteeColdKey ck a + getResignCommitteeColdTxCert (ConwayTxCertGov (ConwayResignCommitteeColdKey ck a)) = Just (ck, a) + getResignCommitteeColdTxCert _ = Nothing + + mkRegDRepTxCert cred deposit mAnchor = ConwayTxCertGov $ ConwayRegDRep cred deposit mAnchor + getRegDRepTxCert = \case + ConwayTxCertGov (ConwayRegDRep cred deposit mAnchor) -> Just (cred, deposit, mAnchor) + _ -> Nothing + + mkUnRegDRepTxCert cred deposit = ConwayTxCertGov $ ConwayUnRegDRep cred deposit + getUnRegDRepTxCert = \case + ConwayTxCertGov (ConwayUnRegDRep cred deposit) -> Just (cred, deposit) + _ -> Nothing + + mkUpdateDRepTxCert cred mAnchor = ConwayTxCertGov $ ConwayUpdateDRep cred mAnchor + getUpdateDRepTxCert = \case + ConwayTxCertGov (ConwayUpdateDRep cred mAnchor) -> Just (cred, mAnchor) + _ -> Nothing diff --git a/eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxOut.hs b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxOut.hs new file mode 100644 index 00000000000..aadd6841d79 --- /dev/null +++ b/eras/dijkstra/src/Cardano/Ledger/Dijkstra/TxOut.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Dijkstra.TxOut () where + +import Cardano.Ledger.Babbage (BabbageTxOut) +import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) +import Cardano.Ledger.Babbage.TxOut ( + addrEitherBabbageTxOutL, + babbageMinUTxOValue, + valueEitherBabbageTxOutL, + ) +import Cardano.Ledger.Core (EraScript (..), EraTxOut (..)) +import Cardano.Ledger.Dijkstra (DijkstraEra) +import Cardano.Ledger.Plutus (Datum (..), translateDatum) +import Data.Maybe.Strict (StrictMaybe (..)) +import Cardano.Ledger.Dijkstra.Scripts () + +instance EraTxOut DijkstraEra where + type TxOut DijkstraEra = BabbageTxOut DijkstraEra + + mkBasicTxOut addr vl = BabbageTxOut addr vl NoDatum SNothing + + upgradeTxOut (BabbageTxOut addr value d s) = + BabbageTxOut addr value (translateDatum d) (upgradeScript <$> s) + + addrEitherTxOutL = addrEitherBabbageTxOutL + {-# INLINE addrEitherTxOutL #-} + + valueEitherTxOutL = valueEitherBabbageTxOutL + {-# INLINE valueEitherTxOutL #-} + + getMinCoinSizedTxOut = babbageMinUTxOValue diff --git a/eras/dijkstra/test/Main.hs b/eras/dijkstra/test/Main.hs index a63469dbe96..ddc05c9f2a8 100644 --- a/eras/dijkstra/test/Main.hs +++ b/eras/dijkstra/test/Main.hs @@ -3,6 +3,25 @@ module Main where import Cardano.Ledger.Dijkstra (DijkstraEra) +import qualified Test.Cardano.Ledger.Alonzo.Binary.CostModelsSpec as CostModelsSpec +import qualified Test.Cardano.Ledger.Alonzo.Binary.TxWitsSpec as TxWitsSpec +import Test.Cardano.Ledger.Common +import qualified Test.Cardano.Ledger.Conway.Binary.CddlSpec as Cddl +import qualified Test.Cardano.Ledger.Conway.Binary.Regression as Regression +import qualified Test.Cardano.Ledger.Conway.BinarySpec as Binary +import qualified Test.Cardano.Ledger.Conway.CommitteeRatifySpec as CommitteeRatify +import qualified Test.Cardano.Ledger.Conway.DRepRatifySpec as DRepRatify +import qualified Test.Cardano.Ledger.Conway.GenesisSpec as Genesis +import Test.Cardano.Ledger.Conway.GoldenSpec as Golden +import qualified Test.Cardano.Ledger.Conway.GoldenTranslation as GoldenTranslation +import qualified Test.Cardano.Ledger.Conway.GovActionReorderSpec as GovActionReorder +import qualified Test.Cardano.Ledger.Conway.Imp as Imp +import Test.Cardano.Ledger.Conway.Plutus.PlutusSpec as PlutusSpec +import qualified Test.Cardano.Ledger.Conway.Proposals as Proposals +import qualified Test.Cardano.Ledger.Conway.SPORatifySpec as SPORatifySpec +import qualified Test.Cardano.Ledger.Conway.Spec as Spec +import qualified Test.Cardano.Ledger.Conway.TxInfoSpec as TxInfo +import Test.Cardano.Ledger.Core.JSON (roundTripJsonEraSpec) main :: IO () main = diff --git a/eras/dijkstra/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs b/eras/dijkstra/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs new file mode 100644 index 00000000000..ea327f91a73 --- /dev/null +++ b/eras/dijkstra/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Conway.Binary.CddlSpec (spec) where + +import Cardano.Ledger.Allegra.Scripts +import Cardano.Ledger.Alonzo.Scripts (CostModels) +import Cardano.Ledger.Alonzo.TxWits (Redeemers) +import Cardano.Ledger.Dijkstra (DijkstraEra) +import Cardano.Ledger.Conway.Governance (GovAction, ProposalProcedure, VotingProcedure) +import Cardano.Ledger.Core +import Cardano.Ledger.Plutus.Data (Data, Datum) +import Test.Cardano.Ledger.Binary.Cddl ( + beforeAllCddlFile, + cddlDecoderEquivalenceSpec, + cddlRoundTripAnnCborSpec, + cddlRoundTripCborSpec, + ) +import Test.Cardano.Ledger.Binary.Cuddle ( + huddleDecoderEquivalenceSpec, + huddleRoundTripAnnCborSpec, + huddleRoundTripCborSpec, + specWithHuddle, + ) +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Conway.Binary.Annotator () +import Test.Cardano.Ledger.Conway.Binary.Cddl (readConwayCddlFiles) +import Test.Cardano.Ledger.Conway.CDDL (conwayCDDL) + +spec :: Spec +spec = do + describe "CDDL" $ do + let v = eraProtVerHigh @DijkstraEra + describe "Ruby-based" $ beforeAllCddlFile 3 readConwayCddlFiles $ do + cddlRoundTripCborSpec @(Value DijkstraEra) v "positive_coin" + cddlRoundTripCborSpec @(Value DijkstraEra) v "value" + cddlRoundTripAnnCborSpec @(TxBody DijkstraEra) v "transaction_body" + cddlRoundTripCborSpec @(TxBody DijkstraEra) v "transaction_body" + cddlRoundTripAnnCborSpec @(TxAuxData DijkstraEra) v "auxiliary_data" + cddlRoundTripCborSpec @(TxAuxData DijkstraEra) v "auxiliary_data" + cddlRoundTripAnnCborSpec @(Timelock DijkstraEra) v "native_script" + cddlRoundTripCborSpec @(Timelock DijkstraEra) v "native_script" + cddlRoundTripAnnCborSpec @(Data DijkstraEra) v "plutus_data" + cddlRoundTripCborSpec @(Data DijkstraEra) v "plutus_data" + cddlRoundTripCborSpec @(TxOut DijkstraEra) v "transaction_output" + cddlRoundTripAnnCborSpec @(Script DijkstraEra) v "script" + cddlRoundTripCborSpec @(Script DijkstraEra) v "script" + cddlRoundTripCborSpec @(Datum DijkstraEra) v "datum_option" + cddlRoundTripAnnCborSpec @(TxWits DijkstraEra) v "transaction_witness_set" + cddlRoundTripCborSpec @(TxWits DijkstraEra) v "transaction_witness_set" + cddlRoundTripCborSpec @(PParamsUpdate DijkstraEra) v "protocol_param_update" + cddlRoundTripCborSpec @CostModels v "cost_models" + cddlRoundTripAnnCborSpec @(Redeemers DijkstraEra) v "redeemers" + cddlRoundTripCborSpec @(Redeemers DijkstraEra) v "redeemers" + cddlRoundTripAnnCborSpec @(Tx DijkstraEra) v "transaction" + cddlRoundTripCborSpec @(Tx DijkstraEra) v "transaction" + cddlRoundTripCborSpec @(VotingProcedure DijkstraEra) v "voting_procedure" + cddlRoundTripCborSpec @(ProposalProcedure DijkstraEra) v "proposal_procedure" + cddlRoundTripCborSpec @(GovAction DijkstraEra) v "gov_action" + cddlRoundTripCborSpec @(TxCert DijkstraEra) v "certificate" + describe "DecCBOR instances equivalence via CDDL" $ do + cddlDecoderEquivalenceSpec @(TxBody DijkstraEra) v "transaction_body" + cddlDecoderEquivalenceSpec @(TxAuxData DijkstraEra) v "auxiliary_data" + cddlDecoderEquivalenceSpec @(Timelock DijkstraEra) v "native_script" + cddlDecoderEquivalenceSpec @(Data DijkstraEra) v "plutus_data" + cddlDecoderEquivalenceSpec @(Script DijkstraEra) v "script" + cddlDecoderEquivalenceSpec @(TxWits DijkstraEra) v "transaction_witness_set" + cddlDecoderEquivalenceSpec @(Redeemers DijkstraEra) v "redeemers" + cddlDecoderEquivalenceSpec @(Tx DijkstraEra) v "transaction" + describe "Huddle" $ specWithHuddle conwayCDDL 100 $ do + huddleRoundTripCborSpec @(Value DijkstraEra) v "positive_coin" + huddleRoundTripCborSpec @(Value DijkstraEra) v "value" + huddleRoundTripAnnCborSpec @(TxBody DijkstraEra) v "transaction_body" + huddleRoundTripCborSpec @(TxBody DijkstraEra) v "transaction_body" + huddleRoundTripAnnCborSpec @(TxAuxData DijkstraEra) v "auxiliary_data" + huddleRoundTripCborSpec @(TxAuxData DijkstraEra) v "auxiliary_data" + huddleRoundTripAnnCborSpec @(Timelock DijkstraEra) v "native_script" + huddleRoundTripCborSpec @(Timelock DijkstraEra) v "native_script" + huddleRoundTripAnnCborSpec @(Data DijkstraEra) v "plutus_data" + huddleRoundTripCborSpec @(Data DijkstraEra) v "plutus_data" + huddleRoundTripCborSpec @(TxOut DijkstraEra) v "transaction_output" + huddleRoundTripAnnCborSpec @(Script DijkstraEra) v "script" + huddleRoundTripCborSpec @(Script DijkstraEra) v "script" + huddleRoundTripCborSpec @(Datum DijkstraEra) v "datum_option" + huddleRoundTripAnnCborSpec @(TxWits DijkstraEra) v "transaction_witness_set" + huddleRoundTripCborSpec @(TxWits DijkstraEra) v "transaction_witness_set" + huddleRoundTripCborSpec @(PParamsUpdate DijkstraEra) v "protocol_param_update" + huddleRoundTripCborSpec @CostModels v "cost_models" + huddleRoundTripAnnCborSpec @(Redeemers DijkstraEra) v "redeemers" + huddleRoundTripCborSpec @(Redeemers DijkstraEra) v "redeemers" + huddleRoundTripAnnCborSpec @(Tx DijkstraEra) v "transaction" + huddleRoundTripCborSpec @(Tx DijkstraEra) v "transaction" + huddleRoundTripCborSpec @(VotingProcedure DijkstraEra) v "voting_procedure" + huddleRoundTripCborSpec @(ProposalProcedure DijkstraEra) v "proposal_procedure" + huddleRoundTripCborSpec @(GovAction DijkstraEra) v "gov_action" + huddleRoundTripCborSpec @(TxCert DijkstraEra) v "certificate" + describe "DecCBOR instances equivalence via CDDL" $ do + huddleDecoderEquivalenceSpec @(TxBody DijkstraEra) v "transaction_body" + huddleDecoderEquivalenceSpec @(TxAuxData DijkstraEra) v "auxiliary_data" + huddleDecoderEquivalenceSpec @(Timelock DijkstraEra) v "native_script" + huddleDecoderEquivalenceSpec @(Data DijkstraEra) v "plutus_data" + huddleDecoderEquivalenceSpec @(Script DijkstraEra) v "script" + huddleDecoderEquivalenceSpec @(TxWits DijkstraEra) v "transaction_witness_set" + huddleDecoderEquivalenceSpec @(Redeemers DijkstraEra) v "redeemers" + huddleDecoderEquivalenceSpec @(Tx DijkstraEra) v "transaction" diff --git a/libs/cardano-data/src/Data/OSet/Strict.hs b/libs/cardano-data/src/Data/OSet/Strict.hs index 851654ecf3c..9ddefc2127b 100644 --- a/libs/cardano-data/src/Data/OSet/Strict.hs +++ b/libs/cardano-data/src/Data/OSet/Strict.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} @@ -10,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} module Data.OSet.Strict ( OSet (Empty, (:<|:), (:|>:)), @@ -35,6 +35,8 @@ module Data.OSet.Strict ( (|><), (><|), filter, + mapL, + mapR, ) where @@ -48,6 +50,7 @@ import Cardano.Ledger.Binary ( ) import Control.DeepSeq (NFData) import Data.Aeson (ToJSON (toJSON)) +import Data.Foldable (Foldable (foldr', foldl')) import Data.Foldable qualified as F import Data.Sequence.Strict qualified as SSeq import Data.Set qualified as Set @@ -278,3 +281,13 @@ osetl ><| osetr = case osetl of ls :|>: l -> ls ><| (l <| osetr) infixr 5 ><| + +-- | Map over the elements, preferring the leftmost element in case there are +-- duplicates +mapR :: Ord b => (a -> b) -> OSet a -> OSet b +mapR f = foldr' ((:<|:) . f) Empty + +-- | Map over the elements, preferring the rightmost element in case there are +-- duplicates +mapL :: Ord b => (a -> b) -> OSet a -> OSet b +mapL f = foldl' (\x y -> x :|>: f y) Empty diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sized.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sized.hs index 552599db57c..01c94380a7b 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sized.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sized.hs @@ -1,11 +1,14 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NamedFieldPuns #-} module Cardano.Ledger.Binary.Decoding.Sized ( Sized (..), mkSized, decodeSized, toSizedL, + mapSized, + unsafeMapSized, ) where @@ -34,6 +37,14 @@ data Sized a = Sized } deriving (Eq, Show, Generic) +-- | Map a function over `Sized` and recompute the size +mapSized :: EncCBOR b => Version -> (a -> b) -> Sized a -> Sized b +mapSized v f (Sized val _) = mkSized v (f val) + +-- | Maps a function over the value, but does not recompute the size +unsafeMapSized :: (a -> b) -> Sized a -> Sized b +unsafeMapSized f s@Sized {sizedValue} = s {sizedValue = f sizedValue} + instance NoThunks a => NoThunks (Sized a) instance NFData a => NFData (Sized a) where