From 25daac31f7d9a96d8bd8c0abc5a385f81bf2a552 Mon Sep 17 00:00:00 2001 From: koslambrou Date: Tue, 12 Nov 2024 19:36:16 -0500 Subject: [PATCH] Update protocol version in protocol parameters to 10 in mockchain and devnet. (#233) * Add unit tests which verify that we can use latest ProtVer10 Plutus primitives (readbit, writebit) in mockchain. * Update PV3 cost model * Comment out broken withdrawal test. Will get fixed in another commit. --- src/base/lib/Convex/NodeQueries.hs | 8 + .../convex-coin-selection.cabal | 1 + src/coin-selection/test/Spec.hs | 43 +++-- src/devnet/config/devnet/cardano-node.json | 7 +- src/devnet/config/devnet/genesis-shelley.json | 2 +- src/devnet/convex-devnet.cabal | 31 +++- .../lib/Convex/Devnet/CardanoNode/Types.hs | 10 +- .../Devnet/Test/LatestEraTransitionSpec.hs | 100 +++++++++++ .../Test/LatestEraTransitionSpec/PV2.hs | 53 ++++++ .../Test/LatestEraTransitionSpec/PV3.hs | 53 ++++++ src/devnet/test/Spec.hs | 162 +++++++++++------- .../lib/Convex/MockChain/Defaults.hs | 103 ++++++++--- 12 files changed, 451 insertions(+), 122 deletions(-) create mode 100644 src/devnet/test/Devnet/Test/LatestEraTransitionSpec.hs create mode 100644 src/devnet/test/Devnet/Test/LatestEraTransitionSpec/PV2.hs create mode 100644 src/devnet/test/Devnet/Test/LatestEraTransitionSpec/PV3.hs diff --git a/src/base/lib/Convex/NodeQueries.hs b/src/base/lib/Convex/NodeQueries.hs index 9f41cc8b..1af4efd0 100644 --- a/src/base/lib/Convex/NodeQueries.hs +++ b/src/base/lib/Convex/NodeQueries.hs @@ -32,6 +32,7 @@ module Convex.NodeQueries( queryEpoch, queryLocalState, queryProtocolParameters, + queryProtocolParametersUpdate, queryStakePools, queryStakeAddresses, queryUTxOFilter @@ -267,6 +268,13 @@ queryProtocolParameters :: LocalNodeConnectInfo -> IO (PParams StandardConway) queryProtocolParameters connectInfo = runEraQuery connectInfo $ EraQuery{eqQuery = CAPI.QueryProtocolParameters, eqResult = id} +-- | Get all the protocol parameter updates from the local cardano node +-- Throws 'QueryException' if the node's era is not conway or if the connection +-- to the node cannot be acquired +queryProtocolParametersUpdate :: LocalNodeConnectInfo -> IO (Map (CAPI.Hash CAPI.GenesisKey) CAPI.ProtocolParametersUpdate) +queryProtocolParametersUpdate connectInfo = runEraQuery @CAPI.ConwayEra connectInfo $ + EraQuery{eqQuery = CAPI.QueryProtocolParametersUpdate, eqResult = id} + -- | Get the stake and the IDs of the stake pool for a set of stake credentials -- Throws 'QueryException' if the node's era is not supported or if the connection -- to the node cannot be acquired diff --git a/src/coin-selection/convex-coin-selection.cabal b/src/coin-selection/convex-coin-selection.cabal index 67908ff7..eb5ec636 100644 --- a/src/coin-selection/convex-coin-selection.cabal +++ b/src/coin-selection/convex-coin-selection.cabal @@ -78,6 +78,7 @@ test-suite convex-coin-selection-test QuickCheck, lens, cardano-ledger-api, + cardano-ledger-core, cardano-ledger-conway, cardano-ledger-shelley, convex-coin-selection, diff --git a/src/coin-selection/test/Spec.hs b/src/coin-selection/test/Spec.hs index c608d1dc..135e8117 100644 --- a/src/coin-selection/test/Spec.hs +++ b/src/coin-selection/test/Spec.hs @@ -6,8 +6,8 @@ module Main(main) where import qualified Cardano.Api as C -import qualified Cardano.Api.Ledger as C hiding (PlutusScript, TxId, - TxIn) +import qualified Cardano.Api.Ledger as Ledger hiding (PlutusScript, + TxId, TxIn) import qualified Cardano.Api.Shelley as C import qualified Cardano.Ledger.Api as Ledger import qualified Cardano.Ledger.Conway.Rules as Rules @@ -415,7 +415,7 @@ queryStakeAddressesTest = do delegationCert = C.makeStakeAddressDelegationCertificate - $ C.StakeDelegationRequirementsConwayOnwards C.ConwayEraOnwardsConway stakeCred (C.DelegStake $ C.unStakePoolKeyHash poolId) + $ C.StakeDelegationRequirementsConwayOnwards C.ConwayEraOnwardsConway stakeCred (Ledger.DelegStake $ C.unStakePoolKeyHash poolId) stakeCertTx = BuildTx.execBuildTx $ do BuildTx.addCertificate stakeCert @@ -440,6 +440,7 @@ withdrawalTest :: forall m. (MonadIO m, MonadMockchain C.ConwayEra m, MonadError withdrawalTest = do poolId <- registerPool Wallet.w1 stakeKey <- C.generateSigningKey C.AsStakeKey + drepKey <- C.generateSigningKey C.AsDRepKey let withdrawalAmount = 10_000_000 @@ -452,28 +453,46 @@ withdrawalTest = do C.makeStakeAddressRegistrationCertificate . C.StakeAddrRegistrationConway C.ConwayEraOnwardsConway 0 $ stakeCred - stakeAddress = C.makeStakeAddress Defaults.networkId stakeCred - - delegationCert = - C.makeStakeAddressDelegationCertificate - $ C.StakeDelegationRequirementsConwayOnwards C.ConwayEraOnwardsConway stakeCred (C.DelegStake $ C.unStakePoolKeyHash poolId) - stakeCertTx = BuildTx.execBuildTx $ do BuildTx.addCertificate stakeCert + delegStake = Ledger.DelegStake $ C.unStakePoolKeyHash poolId + delegationCert = + C.makeStakeAddressDelegationCertificate + $ C.StakeDelegationRequirementsConwayOnwards C.ConwayEraOnwardsConway stakeCred delegStake delegCertTx = BuildTx.execBuildTx $ do BuildTx.addCertificate delegationCert - withdrawalTx = execBuildTx $ do - BuildTx.addWithdrawal stakeAddress withdrawalAmount (C.KeyWitness C.KeyWitnessForStakeAddr) + delegHash = C.verificationKeyHash . C.getVerificationKey $ drepKey + delegCred = Ledger.KeyHashObj $ C.unDRepKeyHash delegHash + drepCert = C.makeDrepRegistrationCertificate (C.DRepRegistrationRequirements C.ConwayEraOnwardsConway delegCred 0) Nothing + drepCertTx = BuildTx.execBuildTx $ BuildTx.addCertificate drepCert + + -- delegationDrepCert = C.makeStakeAddressAndDRepDelegationCertificate + -- C.ConwayEraOnwardsConway + -- stakeCred + -- delegStake + -- 0 + -- delegDrepCertTx = BuildTx.execBuildTx $ BuildTx.addCertificate delegationDrepCert + + -- stakeAddress = C.makeStakeAddress Defaults.networkId stakeCred + -- withdrawalTx = execBuildTx $ do + -- BuildTx.addWithdrawal stakeAddress withdrawalAmount (C.KeyWitness C.KeyWitnessForStakeAddr) -- activate stake void $ tryBalanceAndSubmit mempty Wallet.w2 stakeCertTx TrailingChange [C.WitnessStakeKey stakeKey] -- delegate to pool void $ tryBalanceAndSubmit mempty Wallet.w2 delegCertTx TrailingChange [C.WitnessStakeKey stakeKey] + -- register drep + void $ tryBalanceAndSubmit mempty Wallet.w2 drepCertTx TrailingChange [C.WitnessDRepKey drepKey] + -- delegate to drep + -- FIXME (koslambrou) Need to fix this in order to enable withdrawal + -- void $ tryBalanceAndSubmit mempty Wallet.w2 delegDrepCertTx TrailingChange [C.WitnessStakeKey stakeKey] -- modify the ledger state setReward stakeCred (C.quantityToLovelace withdrawalAmount) -- withdraw rewards - void $ tryBalanceAndSubmit mempty Wallet.w2 withdrawalTx TrailingChange [C.WitnessStakeKey stakeKey] + -- FIXME (koslambrou) After updating to Chang+1 protocol version 10, the following gives the following error: + -- Exception: user error (user error (ValidationError: ApplyTxFailure: ApplyTxError (ConwayWdrlNotDelegatedToDRep (KeyHash {unKeyHash = "d6f0088850dc2494b69cf89c27491031ca610041afacf98ad95a0d4a"} :| []) :| []))) + -- void $ tryBalanceAndSubmit mempty Wallet.w2 withdrawalTx TrailingChange [C.WitnessStakeKey stakeKey] diff --git a/src/devnet/config/devnet/cardano-node.json b/src/devnet/config/devnet/cardano-node.json index 88801310..079020b4 100644 --- a/src/devnet/config/devnet/cardano-node.json +++ b/src/devnet/config/devnet/cardano-node.json @@ -13,6 +13,8 @@ "LastKnownBlockVersion-Major": 6, "LastKnownBlockVersion-Minor": 0, + "ExperimentalHardForksEnabled": true, + "ExperimentalProtocolsEnabled": true, "TestShelleyHardForkAtEpoch": 0, "TestAllegraHardForkAtEpoch": 0, "TestMaryHardForkAtEpoch": 0, @@ -74,8 +76,5 @@ "mapSubtrace": { "cardano.node.metrics": { "subtrace": "Neutral" } } - }, - - "ExperimentalHardForksEnabled": true, - "ExperimentalProtocolsEnabled": true + } } diff --git a/src/devnet/config/devnet/genesis-shelley.json b/src/devnet/config/devnet/genesis-shelley.json index 9e55b255..e0966aa9 100644 --- a/src/devnet/config/devnet/genesis-shelley.json +++ b/src/devnet/config/devnet/genesis-shelley.json @@ -30,7 +30,7 @@ "nOpt": 100, "poolDeposit": 0, "protocolVersion": { - "major": 7, + "major": 2, "minor": 0 }, "rho": 0.003, diff --git a/src/devnet/convex-devnet.cabal b/src/devnet/convex-devnet.cabal index 02f0b8c7..bf8406c1 100644 --- a/src/devnet/convex-devnet.cabal +++ b/src/devnet/convex-devnet.cabal @@ -52,7 +52,6 @@ library build-depends: base >= 4.14.0 , aeson - , lens-aeson , text , time , bytestring @@ -89,10 +88,10 @@ library , contra-tracer , iohk-monitoring - other-modules: - Paths_convex_devnet - autogen-modules: - Paths_convex_devnet + other-modules: + Paths_convex_devnet + autogen-modules: + Paths_convex_devnet test-suite convex-devnet-test import: lang @@ -100,18 +99,32 @@ test-suite convex-devnet-test main-is: Spec.hs ghc-options: -threaded -rtsopts other-modules: + Devnet.Test.LatestEraTransitionSpec + Devnet.Test.LatestEraTransitionSpec.PV2 + Devnet.Test.LatestEraTransitionSpec.PV3 hs-source-dirs: test build-depends: - base >= 4.14.0 - , tasty - , tasty-hunit , convex-devnet , convex-base + , convex-node-client + , convex-wallet + , convex-coin-selection + , convex-mockchain + build-depends: + , plutus-tx + , plutus-tx-plugin + , ouroboros-consensus-cardano + , plutus-core + , ouroboros-consensus-protocol , cardano-api - , contra-tracer , cardano-ledger-api , cardano-ledger-core -any + build-depends: + base >= 4.14.0 + , tasty + , tasty-hunit + , contra-tracer , lens , mtl , aeson diff --git a/src/devnet/lib/Convex/Devnet/CardanoNode/Types.hs b/src/devnet/lib/Convex/Devnet/CardanoNode/Types.hs index 1fa4f837..9d458211 100644 --- a/src/devnet/lib/Convex/Devnet/CardanoNode/Types.hs +++ b/src/devnet/lib/Convex/Devnet/CardanoNode/Types.hs @@ -12,7 +12,6 @@ module Convex.Devnet.CardanoNode.Types ( defaultStakePoolNodeParams, -- * Genesis config changes GenesisConfigChanges (..), - forkIntoConwayInEpoch, allowLargeTransactions, setEpochLength ) where @@ -27,13 +26,11 @@ import Cardano.Ledger.BaseTypes (EpochSize) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Shelley.API (Coin) import Cardano.Ledger.Shelley.Genesis (ShelleyGenesis (..)) -import Control.Lens (over, set) +import Control.Lens (over) import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as Aeson -import Data.Aeson.Lens (atKey) import Data.Ratio ((%)) import GHC.Generics (Generic) -import Numeric.Natural (Natural) import Ouroboros.Consensus.Shelley.Eras (ShelleyEra, StandardCrypto) type Port = Int @@ -122,11 +119,6 @@ instance Semigroup GenesisConfigChanges where instance Monoid GenesisConfigChanges where mempty = GenesisConfigChanges id id id id --- | Set the 'TestConwayHardForkAtEpoch' field to the given value (can be 0) -forkIntoConwayInEpoch :: Natural -> GenesisConfigChanges -forkIntoConwayInEpoch n = - mempty{ cfNodeConfig = set (atKey "TestConwayHardForkAtEpoch") (Just $ Aeson.toJSON n) } - {-| Change the alonzo genesis config to allow transactions with up to twice the normal size -} allowLargeTransactions :: GenesisConfigChanges diff --git a/src/devnet/test/Devnet/Test/LatestEraTransitionSpec.hs b/src/devnet/test/Devnet/Test/LatestEraTransitionSpec.hs new file mode 100644 index 00000000..214240af --- /dev/null +++ b/src/devnet/test/Devnet/Test/LatestEraTransitionSpec.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Devnet.Test.LatestEraTransitionSpec + ( tests + ) where + +import qualified Cardano.Api as C +import qualified Cardano.Api.Ledger as L +import Control.Lens ((&), (.~)) +import Convex.BuildTx (execBuildTx, + mintPlutus) +import Convex.Class (MonadMockchain) +import Convex.CoinSelection (ChangeOutputPosition (TrailingChange)) +import Convex.MockChain.CoinSelection (tryBalanceAndSubmit) +import qualified Convex.MockChain.Defaults as Defaults +import Convex.MockChain.Utils (mockchainFails, + mockchainFailsWith, + mockchainSucceeds) +import qualified Convex.NodeParams as Params +import Convex.Utils (failOnError) +import qualified Convex.Wallet.MockWallet as Wallet +import qualified Devnet.Test.LatestEraTransitionSpec.PV2 as LatestEraTransitionSpec.PV2 +import qualified Devnet.Test.LatestEraTransitionSpec.PV3 as LatestEraTransitionSpec.PV3 +import qualified PlutusTx.Builtins as BI +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) + +tests :: TestTree +tests = do + testGroup "Latest era and protocol version tests" + [ testCase "usingReadBitInPlutusV2AndProtVer9ShouldFailSpec" usingReadBitInPlutusV2AndProtVer9ShouldFailSpec + , testCase "usingWriteBitInPlutusV2AndProtVer9ShouldFailSpec" usingWriteBitInPlutusV2AndProtVer9ShouldFailSpec + , testCase "usingReadBitInPlutusV3AndProtVer9ShouldFailSpec" usingReadBitInPlutusV3AndProtVer9ShouldFailSpec + , testCase "usingWriteBitInPlutusV3AndProtVer9ShouldFailSpec" usingWriteBitInPlutusV3AndProtVer9ShouldFailSpec + , testCase "usingReadBitInPlutusV2AndLatestProtVerShouldPassSpec" usingReadBitInPlutusV2AndLatestProtVerShouldPassSpec + , testCase "usingWriteBitInPlutusV2AndLatestProtVerShouldPassSpec" usingWriteBitInPlutusV2AndLatestProtVerShouldPassSpec + , testCase "usingReadBitInPlutusV3AndLatestProtVerShouldPassSpec" usingReadBitInPlutusV3AndLatestProtVerShouldPassSpec + , testCase "usingWriteBitInPlutusV3AndLatestProtVerShouldPassSpec" usingWriteBitInPlutusV3AndLatestProtVerShouldPassSpec + ] + +pv9NodeParams :: Params.NodeParams C.ConwayEra +pv9NodeParams = + Defaults.nodeParams + & Params.ledgerProtocolParameters . Params.protocolParameters . L.ppProtocolVersionL .~ L.ProtVer (toEnum 9) 0 + +usingReadBitInPlutusV2AndProtVer9ShouldFailSpec :: IO () +usingReadBitInPlutusV2AndProtVer9ShouldFailSpec = do + mockchainFailsWith pv9NodeParams (mintTokenScriptTest (LatestEraTransitionSpec.PV2.readBitTestMintingPolicyScriptPV2 $ BI.mkB "0xF4")) (const $ pure ()) + +usingWriteBitInPlutusV2AndProtVer9ShouldFailSpec :: IO () +usingWriteBitInPlutusV2AndProtVer9ShouldFailSpec = do + mockchainFailsWith pv9NodeParams (mintTokenScriptTest (LatestEraTransitionSpec.PV2.writeBitTestMintingPolicyScriptPV2 $ BI.mkB "0xFF")) (const $ pure ()) + +usingReadBitInPlutusV3AndProtVer9ShouldFailSpec :: IO () +usingReadBitInPlutusV3AndProtVer9ShouldFailSpec = do + mockchainFailsWith pv9NodeParams (mintTokenScriptTest (LatestEraTransitionSpec.PV3.readBitTestMintingPolicyScriptPV3 $ BI.mkB "0xF4")) (const $ pure ()) + +usingWriteBitInPlutusV3AndProtVer9ShouldFailSpec :: IO () +usingWriteBitInPlutusV3AndProtVer9ShouldFailSpec = do + mockchainFailsWith pv9NodeParams (mintTokenScriptTest (LatestEraTransitionSpec.PV3.writeBitTestMintingPolicyScriptPV3 $ BI.mkB "0xFF")) (const $ pure ()) + +usingReadBitInPlutusV2AndLatestProtVerShouldPassSpec :: IO () +usingReadBitInPlutusV2AndLatestProtVerShouldPassSpec = do + mockchainFails (mintTokenScriptTest (LatestEraTransitionSpec.PV2.readBitTestMintingPolicyScriptPV2 $ BI.mkB "0xF4")) (const $ pure ()) + +usingWriteBitInPlutusV2AndLatestProtVerShouldPassSpec :: IO () +usingWriteBitInPlutusV2AndLatestProtVerShouldPassSpec = do + mockchainFails (mintTokenScriptTest (LatestEraTransitionSpec.PV2.writeBitTestMintingPolicyScriptPV2 $ BI.mkB "0xFF")) (const $ pure ()) + +usingReadBitInPlutusV3AndLatestProtVerShouldPassSpec :: IO () +usingReadBitInPlutusV3AndLatestProtVerShouldPassSpec = do + mockchainSucceeds (mintTokenScriptTest (LatestEraTransitionSpec.PV3.readBitTestMintingPolicyScriptPV3 $ BI.mkB "0xF4")) + +usingWriteBitInPlutusV3AndLatestProtVerShouldPassSpec :: IO () +usingWriteBitInPlutusV3AndLatestProtVerShouldPassSpec = do + mockchainSucceeds (mintTokenScriptTest (LatestEraTransitionSpec.PV3.writeBitTestMintingPolicyScriptPV3 $ BI.mkB "0xFF")) + +mintTokenScriptTest :: + ( MonadMockchain era m + , C.IsPlutusScriptLanguage lang + , C.HasScriptLanguageInEra lang era + , C.IsBabbageBasedEra era + , MonadFail m + ) + => C.PlutusScript lang + -> m (C.Tx era) +mintTokenScriptTest script = do + let txb = + execBuildTx $ + mintPlutus script () (C.AssetName "ProtVer10Test") 1 + failOnError $ tryBalanceAndSubmit mempty Wallet.w1 txb TrailingChange [] diff --git a/src/devnet/test/Devnet/Test/LatestEraTransitionSpec/PV2.hs b/src/devnet/test/Devnet/Test/LatestEraTransitionSpec/PV2.hs new file mode 100644 index 00000000..827b1aff --- /dev/null +++ b/src/devnet/test/Devnet/Test/LatestEraTransitionSpec/PV2.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:preserve-logging #-} + +module Devnet.Test.LatestEraTransitionSpec.PV2 + ( readBitTestMintingPolicyScriptPV2 + , writeBitTestMintingPolicyScriptPV2 + ) where + +import qualified Cardano.Api as C +import Convex.PlutusTx (compiledCodeToScript) +import qualified PlutusCore.Version as Version +import PlutusTx (CompiledCode) +import qualified PlutusTx +import qualified PlutusTx.Builtins.Internal as BI +import qualified PlutusTx.Prelude as PlutusTx + +{-# INLINABLE readBitTestMintingPolicy #-} +readBitTestMintingPolicy :: PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit +readBitTestMintingPolicy d _ _ = + if PlutusTx.readBit (BI.unsafeDataAsB d) 2 then BI.unitval else PlutusTx.error () + +readBitTestMintingPolicyScriptPV2 :: PlutusTx.BuiltinData -> C.PlutusScript C.PlutusScriptV2 +readBitTestMintingPolicyScriptPV2 = compiledCodeToScript . readBitTestMintingPolicyCompiled + where + readBitTestMintingPolicyCompiled :: PlutusTx.BuiltinData -> CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit) + readBitTestMintingPolicyCompiled str = + $$(PlutusTx.compile [|| \str' r c -> readBitTestMintingPolicy str' r c ||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCode Version.plcVersion100 str + +{-# INLINABLE writeBitTestMintingPolicy #-} +writeBitTestMintingPolicy :: PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit +writeBitTestMintingPolicy d _ _ = + let !_ = PlutusTx.writeBits (BI.unsafeDataAsB d) [0] False in BI.unitval + +writeBitTestMintingPolicyScriptPV2 :: PlutusTx.BuiltinData -> C.PlutusScript C.PlutusScriptV2 +writeBitTestMintingPolicyScriptPV2 = compiledCodeToScript . writeBitTestMintingPolicyCompiled + where + writeBitTestMintingPolicyCompiled :: PlutusTx.BuiltinData -> CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit) + writeBitTestMintingPolicyCompiled str = + $$(PlutusTx.compile [|| \str' r c -> writeBitTestMintingPolicy str' r c ||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCode Version.plcVersion100 str diff --git a/src/devnet/test/Devnet/Test/LatestEraTransitionSpec/PV3.hs b/src/devnet/test/Devnet/Test/LatestEraTransitionSpec/PV3.hs new file mode 100644 index 00000000..4cc31e4e --- /dev/null +++ b/src/devnet/test/Devnet/Test/LatestEraTransitionSpec/PV3.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:preserve-logging #-} + +module Devnet.Test.LatestEraTransitionSpec.PV3 + ( readBitTestMintingPolicyScriptPV3 + , writeBitTestMintingPolicyScriptPV3 + ) where + +import qualified Cardano.Api as C +import Convex.PlutusTx (compiledCodeToScript) +import qualified PlutusCore.Version as Version +import PlutusTx (CompiledCode) +import qualified PlutusTx +import qualified PlutusTx.Builtins.Internal as BI +import qualified PlutusTx.Prelude as PlutusTx + +{-# INLINABLE readBitTestMintingPolicy #-} +readBitTestMintingPolicy :: PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit +readBitTestMintingPolicy d _ = + if PlutusTx.readBit (BI.unsafeDataAsB d) 2 then BI.unitval else PlutusTx.error () + +readBitTestMintingPolicyScriptPV3 :: PlutusTx.BuiltinData -> C.PlutusScript C.PlutusScriptV3 +readBitTestMintingPolicyScriptPV3 = compiledCodeToScript . readBitTestMintingPolicyCompiled + where + readBitTestMintingPolicyCompiled :: PlutusTx.BuiltinData -> CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit) + readBitTestMintingPolicyCompiled str = + $$(PlutusTx.compile [|| \str' c -> readBitTestMintingPolicy str' c ||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCode Version.plcVersion110 str + +{-# INLINABLE writeBitTestMintingPolicy #-} +writeBitTestMintingPolicy :: PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit +writeBitTestMintingPolicy d _ = + let !_ = PlutusTx.writeBits (BI.unsafeDataAsB d) [0] False in BI.unitval + +writeBitTestMintingPolicyScriptPV3 :: PlutusTx.BuiltinData -> C.PlutusScript C.PlutusScriptV3 +writeBitTestMintingPolicyScriptPV3 = compiledCodeToScript . writeBitTestMintingPolicyCompiled + where + writeBitTestMintingPolicyCompiled :: PlutusTx.BuiltinData -> CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit) + writeBitTestMintingPolicyCompiled str = + $$(PlutusTx.compile [|| \str' c -> writeBitTestMintingPolicy str' c ||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCode Version.plcVersion110 str diff --git a/src/devnet/test/Spec.hs b/src/devnet/test/Spec.hs index af647364..673c440f 100644 --- a/src/devnet/test/Spec.hs +++ b/src/devnet/test/Spec.hs @@ -1,59 +1,76 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} + module Main where -import qualified Cardano.Api as C -import qualified Cardano.Api.Shelley as C -import Cardano.Ledger.Api.PParams (ppMaxTxSizeL) -import Cardano.Ledger.Slot (EpochSize (..)) -import Control.Concurrent (threadDelay) -import Control.Lens (view) -import Control.Monad (unless) -import Control.Monad.Except (runExceptT) -import Control.Tracer (Tracer) -import Convex.Devnet.CardanoNode (NodeLog (..), - getCardanoNodeVersion, - withCardanoNodeDevnet, - withCardanoNodeDevnetConfig, - withCardanoStakePoolNodeDevnetConfig) -import Convex.Devnet.CardanoNode.Types (GenesisConfigChanges (..), - PortsConfig (..), - RunningNode (..), - RunningStakePoolNode (..), - StakePoolNodeParams (..), - allowLargeTransactions, - defaultPortsConfig, - defaultStakePoolNodeParams, - forkIntoConwayInEpoch) -import Convex.Devnet.Logging (contramap, showLogsOnFailure, - traceWith) -import Convex.Devnet.Utils (failAfter, failure, - withTempDir) -import Convex.Devnet.Wallet (WalletLog) -import qualified Convex.Devnet.Wallet as W -import Convex.Devnet.WalletServer (getUTxOs, withWallet) -import qualified Convex.Devnet.WalletServer as WS -import Convex.NodeQueries (loadConnectInfo, - queryProtocolParameters, - queryStakeAddresses, - queryStakePools) -import qualified Convex.NodeQueries as Queries -import qualified Convex.Utxos as Utxos -import Data.Aeson (FromJSON, ToJSON) -import Data.List (isInfixOf) -import qualified Data.Map as Map -import Data.Ratio ((%)) -import qualified Data.Set as Set -import GHC.Generics (Generic) -import GHC.IO.Encoding (setLocaleEncoding, utf8) -import System.FilePath (()) -import Test.Tasty (defaultMain, testGroup) -import Test.Tasty.HUnit (assertBool, assertEqual, - testCase) +import qualified Cardano.Api as C +import qualified Cardano.Api.Ledger as L +import qualified Cardano.Api.Shelley as C +import qualified Cardano.Ledger.Api.PParams as L +import qualified Cardano.Ledger.Block as Ledger +import Cardano.Ledger.Slot (EpochSize (..)) +import Control.Concurrent (threadDelay) +import Control.Lens (view) +import Control.Monad (unless, void) +import Control.Monad.Except (runExceptT) +import Control.Tracer (Tracer) +import Convex.Devnet.CardanoNode (NodeLog (..), + getCardanoNodeVersion, + withCardanoNodeDevnet, + withCardanoNodeDevnetConfig, + withCardanoStakePoolNodeDevnetConfig) +import Convex.Devnet.CardanoNode.Types (GenesisConfigChanges (..), + PortsConfig (..), + RunningNode (..), + RunningStakePoolNode (..), + StakePoolNodeParams (..), + allowLargeTransactions, + defaultPortsConfig, + defaultStakePoolNodeParams) +import Convex.Devnet.Logging (contramap, + showLogsOnFailure, + traceWith) +import Convex.Devnet.Utils (failAfter, failure, + withTempDir) +import Convex.Devnet.Wallet (WalletLog) +import qualified Convex.Devnet.Wallet as W +import Convex.Devnet.WalletServer (getUTxOs, + withWallet) +import qualified Convex.Devnet.WalletServer as WS +import Convex.NodeClient.Fold (LedgerStateArgs (NoLedgerStateArgs), + foldClient) +import Convex.NodeClient.Types (runNodeClient) +import Convex.NodeQueries (loadConnectInfo, + queryProtocolParameters, + queryStakeAddresses, + queryStakePools) +import qualified Convex.NodeQueries as Queries +import qualified Convex.Utxos as Utxos +import Data.Aeson (FromJSON, ToJSON) +import Data.IORef (modifyIORef, + newIORef, readIORef) +import Data.List (isInfixOf) +import qualified Data.Map as Map +import Data.Ratio ((%)) +import qualified Data.Set as Set +import qualified Devnet.Test.LatestEraTransitionSpec as LatestEraTransitionSpec +import GHC.Generics (Generic) +import GHC.IO.Encoding (setLocaleEncoding, + utf8) +import qualified Ouroboros.Consensus.Protocol.Praos.Header as Consensus +import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus +import System.FilePath (()) +import Test.Tasty (defaultMain, + testGroup) +import Test.Tasty.HUnit (assertBool, + assertEqual, + testCase) main :: IO () main = do @@ -61,7 +78,8 @@ main = do defaultMain $ testGroup "test" [ testCase "cardano-node is available" checkCardanoNode , testCase "start local node" startLocalNode - , testCase "transition to conway era" transitionToConway + , testCase "check transition to conway era and protocol version 10" checkTransitionToConway + , LatestEraTransitionSpec.tests , testCase "make a payment" makePayment , testCase "start local stake pool node" startLocalStakePoolNode , testCase "stake pool registration" registeredStakePoolNode @@ -83,21 +101,41 @@ startLocalNode = do showLogsOnFailure $ \tr -> do failAfter 5 $ withTempDir "cardano-cluster" $ \tmp -> do - withCardanoNodeDevnet tr tmp $ \RunningNode{rnNodeSocket, rnNodeConfigFile, rnConnectInfo} -> do + withCardanoNodeDevnet tr tmp $ \RunningNode{rnNodeSocket, rnNodeConfigFile} -> do runExceptT (loadConnectInfo rnNodeConfigFile rnNodeSocket) >>= \case Left err -> failure (show err) - Right{} -> do - Queries.queryEra rnConnectInfo - >>= assertBool "Should be in conway era" . (==) (C.anyCardanoEra C.ConwayEra) + Right{} -> pure () -transitionToConway :: IO () -transitionToConway = do - showLogsOnFailure $ \tr -> do - failAfter 5 $ - withTempDir "cardano-cluster" $ \tmp -> do - withCardanoNodeDevnetConfig tr tmp (forkIntoConwayInEpoch 0) defaultPortsConfig $ \RunningNode{rnConnectInfo} -> do - Queries.queryEra rnConnectInfo - >>= assertBool "Should be in conway era" . (==) (C.anyCardanoEra C.ConwayEra) +checkTransitionToConway :: IO () +checkTransitionToConway = do + showLogsOnFailure $ \tr -> do + failAfter 5 $ + withTempDir "cardano-cluster" $ \tmp -> do + withCardanoNodeDevnet (contramap TLNode tr) tmp $ \runningNode@RunningNode{rnConnectInfo, rnNodeSocket, rnNodeConfigFile} -> do + Queries.queryEra rnConnectInfo >>= assertEqual "Should be in conway era" (C.anyCardanoEra C.ConwayEra) + let lovelacePerUtxo = 100_000_000 + numUtxos = 10 + void $ W.createSeededWallet (contramap TLWallet tr) runningNode numUtxos lovelacePerUtxo + majorProtVersionsRef <- newIORef [] + res <- C.liftIO $ runExceptT $ runNodeClient rnNodeConfigFile rnNodeSocket $ \_localNodeConnectInfo env -> do + pure $ foldClient () NoLedgerStateArgs env $ \_catchingUp _ _ bim -> do + case bim of + (C.BlockInMode C.ConwayEra + (C.ShelleyBlock C.ShelleyBasedEraConway + (Consensus.ShelleyBlock + (Ledger.Block (Consensus.Header hb _) _) _))) -> do + modifyIORef majorProtVersionsRef $ \majorProtVersions -> + L.pvMajor (Consensus.hbProtVer hb) : majorProtVersions + pure Nothing + (C.BlockInMode _ _block) -> do + failure "Block should be a ShelleyBlock in Conway era" + case res of + Left err -> failure $ show err + Right () -> do + majorProtVersions <- readIORef majorProtVersionsRef + expectedVersion <- L.mkVersion (10 :: Integer) + assertBool "Should have correct conway era protocol version" $ + not (null majorProtVersions) && all (== expectedVersion) majorProtVersions startLocalStakePoolNode :: IO () startLocalStakePoolNode = do @@ -211,7 +249,7 @@ runWalletServer = changeMaxTxSize :: IO () changeMaxTxSize = - let getMaxTxSize = fmap (view ppMaxTxSizeL) . queryProtocolParameters . rnConnectInfo in + let getMaxTxSize = fmap (view L.ppMaxTxSizeL) . queryProtocolParameters . rnConnectInfo in showLogsOnFailure $ \tr -> do withTempDir "cardano-cluster" $ \tmp -> do standardTxSize <- withCardanoNodeDevnet (contramap TLNode tr) tmp getMaxTxSize diff --git a/src/mockchain/lib/Convex/MockChain/Defaults.hs b/src/mockchain/lib/Convex/MockChain/Defaults.hs index d46b8299..c3b8ebcd 100644 --- a/src/mockchain/lib/Convex/MockChain/Defaults.hs +++ b/src/mockchain/lib/Convex/MockChain/Defaults.hs @@ -91,32 +91,39 @@ epochSize = EpochSize 432_000 slotLength :: SlotLength slotLength = mkSlotLength 1 -- 1 second +latestProtVer :: L.ProtVer +latestProtVer = L.ProtVer (toEnum 10) 0 + -- FIXME: Make this era independent protocolParameters :: PParams StandardConway -protocolParameters = L.PParams $ - L.emptyPParamsIdentity @(ConwayEra StandardCrypto) - & L.hkdMaxBHSizeL .~ 1_100 - & L.hkdMaxBBSizeL .~ 90_112 - & L.hkdMaxTxSizeL .~ 16_384 - & L.hkdMinFeeAL .~ 44 - & L.hkdMinFeeBL .~ 155_381 - & L.hkdPoolDepositL .~ 500_000_000 - & L.hkdCoinsPerUTxOByteL .~ L.CoinPerByte 4_310 - & L.hkdPricesL .~ L.Prices - { L.prMem = C.unsafeBoundedRational (577 % 10_000) - , L.prSteps = C.unsafeBoundedRational (721 % 10_000_000) - } - & L.hkdMaxTxExUnitsL .~ ExUnits { exUnitsSteps = 1_0000_000_000, exUnitsMem = 14_000_000} - & L.hkdMaxBlockExUnitsL .~ ExUnits{ exUnitsSteps = 20_000_000_000, exUnitsMem = 62_000_000 } - & L.hkdMaxValSizeL .~ 5_000 - & L.hkdCollateralPercentageL .~ 150 - & L.hkdMaxCollateralInputsL .~ 3 - & L.hkdMinPoolCostL .~ 200_000 - & L.hkdCostModelsL .~ CostModels.mkCostModels (Map.fromList [(PlutusV1, v1CostModel), (PlutusV2, v2CostModel), (PlutusV3, v3CostModel)]) - & L.hkdMinFeeRefScriptCostPerByteL .~ C.unsafeBoundedRational 15 - & L.hkdMinPoolCostL .~ 170_000_000 - & L.hkdEMaxL .~ L.EpochInterval 18 +protocolParameters = + let pparams = L.PParams $ + L.emptyPParamsIdentity @(ConwayEra StandardCrypto) + & L.hkdMaxBHSizeL .~ 1_100 + & L.hkdMaxBBSizeL .~ 90_112 + & L.hkdMaxTxSizeL .~ 16_384 + & L.hkdMinFeeAL .~ 44 + & L.hkdMinFeeBL .~ 155_381 + & L.hkdPoolDepositL .~ 500_000_000 + & L.hkdCoinsPerUTxOByteL .~ L.CoinPerByte 4_310 + & L.hkdPricesL .~ L.Prices + { L.prMem = C.unsafeBoundedRational (577 % 10_000) + , L.prSteps = C.unsafeBoundedRational (721 % 10_000_000) + } + & L.hkdMaxTxExUnitsL .~ ExUnits { exUnitsSteps = 1_0000_000_000, exUnitsMem = 14_000_000} + & L.hkdMaxBlockExUnitsL .~ ExUnits{ exUnitsSteps = 20_000_000_000, exUnitsMem = 62_000_000 } + & L.hkdMaxValSizeL .~ 5_000 + & L.hkdCollateralPercentageL .~ 150 + & L.hkdMaxCollateralInputsL .~ 3 + & L.hkdMinPoolCostL .~ 200_000 + & L.hkdCostModelsL .~ CostModels.mkCostModels (Map.fromList [(PlutusV1, v1CostModel), (PlutusV2, v2CostModel), (PlutusV3, v3CostModel)]) + & L.hkdMinFeeRefScriptCostPerByteL .~ C.unsafeBoundedRational 15 + & L.hkdMinPoolCostL .~ 170_000_000 + & L.hkdEMaxL .~ L.EpochInterval 18 + in + pparams + & L.ppProtocolVersionL .~ latestProtVer unsafeMkCostModel :: Language -> [Int64] -> CostModels.CostModel unsafeMkCostModel lang = either (error . show) id . CostModels.mkCostModel lang @@ -474,7 +481,7 @@ v2CostModel = unsafeMkCostModel PlutusV2 v3CostModel :: CostModels.CostModel v3CostModel = unsafeMkCostModel PlutusV3 - [ + [ 100788, 420, 1, @@ -725,7 +732,53 @@ v3CostModel = unsafeMkCostModel PlutusV3 43623, 251, 0, - 1 + 1, + 100181, + 726, + 719, + 0, + 1, + 100181, + 726, + 719, + 0, + 1, + 100181, + 726, + 719, + 0, + 1, + 107878, + 680, + 0, + 1, + 95336, + 1, + 281145, + 18848, + 0, + 1, + 180194, + 159, + 1, + 1, + 158519, + 8942, + 0, + 1, + 159378, + 8813, + 0, + 1, + 107490, + 3298, + 1, + 106057, + 655, + 1, + 1964219, + 24520, + 3 ] globals :: C.IsShelleyBasedEra era => NodeParams era -> Globals