diff --git a/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/UpdatePParam.hs b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/UpdatePParam.hs new file mode 100644 index 00000000000..6249915ab6b --- /dev/null +++ b/cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/UpdatePParam.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Cardano.Testnet.Test.Gov.UpdatePParam + ( hprop_update_pparam + ) where + +import Cardano.Api as Api +import Cardano.Api.Ledger (EpochInterval (..)) +import qualified Cardano.Api.Ledger as L + +import qualified Cardano.Crypto.Hash as L +import qualified Cardano.Ledger.Conway.Governance as L +import qualified Cardano.Ledger.Conway.Governance as Ledger +import qualified Cardano.Ledger.Conway.PParams as L +import qualified Cardano.Ledger.Core as L +import qualified Cardano.Ledger.Shelley.LedgerState as L +import Cardano.Testnet + +import Prelude + +import Control.Monad +import Control.Monad.State.Strict (StateT) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Bifunctor (first) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Maybe.Strict +import Data.String +import qualified Data.Text as Text +import Data.Word +import GHC.Exts (IsList (..)) +import Lens.Micro +import System.FilePath (()) + +import Testnet.Components.Configuration +import Testnet.Components.DRep (createVotingTxBody, generateVoteFiles, + retrieveTransactionId, signTx, submitTx) +import Testnet.Components.Query +import Testnet.Components.TestWatchdog +import Testnet.Defaults +import qualified Testnet.Process.Cli as P +import qualified Testnet.Process.Run as H +import qualified Testnet.Property.Util as H +import Testnet.Types + +import Hedgehog +import qualified Hedgehog.Extras as H + +-- | Execute me with: +-- @DISABLE_RETRIES=1 cabal test cardano-testnet-test --test-options '-p "/Propose And Ratify New Constitution/"'@ +hprop_update_pparam :: Property +hprop_update_pparam = H.integrationWorkspace "propose-new-constitution" $ \tempAbsBasePath' -> runWithDefaultWatchdog_ $ do + -- Start a local test net + conf@Conf { tempAbsPath } <- mkConf tempAbsBasePath' + let tempAbsPath' = unTmpAbsPath tempAbsPath + tempBaseAbsPath = makeTmpBaseAbsPath tempAbsPath + + work <- H.createDirectoryIfMissing $ tempAbsPath' "work" + + -- Generate model for votes + let allVotes :: [(String, Int)] + allVotes = zip (concatMap (uncurry replicate) [(4, "yes"), (3, "no"), (2, "abstain")]) [1..] + annotateShow allVotes + + let numVotes :: Int + numVotes = length allVotes + annotateShow numVotes + + guardRailScript <- H.note $ work "guard-rail-script.plutusV3" + H.writeFile guardRailScript $ Text.unpack plutusV3NonSpendingScript + + -- TODO: Update help text for policyid. The script hash is not + -- only useful for minting scripts + -- TODO: Left off here. Use offline execConfig function + constitutionScriptHash <- filter (/= '\n') <$> + H.execCli' execConfig + [ anyEraToString cEra, "transaction" + , "policyid" + , "--script-file", guardRailScript + ] + + H.note_ $ "Constitution script hash: " <> constitutionScriptHash + + let ceo = ConwayEraOnwardsConway + sbe = conwayEraOnwardsToShelleyBasedEra ceo + era = toCardanoEra sbe + cEra = AnyCardanoEra era + fastTestnetOptions = cardanoDefaultTestnetOptions + { cardanoEpochLength = 100 + , cardanoNodeEra = cEra + , cardanoNumDReps = numVotes + } + constitution = undefined + + alonzoGenesis <- evalEither $ first prettyError defaultAlonzoGenesis + (startTime, shelleyGenesis') <- getDefaultShelleyGenesis fastTestnetOptions + let conwayGenesisWithCommittee = + defaultConwayGenesis { L.cgConstitution = constitution } + + TestnetRuntime + { testnetMagic + , poolNodes + , wallets=wallet0:_wallet1:_ + , configurationFile + } <- cardanoTestnet + fastTestnetOptions + conf startTime shelleyGenesis' + alonzoGenesis conwayGenesisWithCommittee + + PoolNode{poolRuntime} <- H.headM poolNodes + poolSprocket1 <- H.noteShow $ nodeSprocket poolRuntime + execConfig <- H.mkExecConfig tempBaseAbsPath poolSprocket1 testnetMagic + let socketPath = nodeSocketPath poolRuntime + + epochStateView <- getEpochStateView configurationFile socketPath + + H.note_ $ "Sprocket: " <> show poolSprocket1 + H.note_ $ "Abs path: " <> tempAbsBasePath' + H.note_ $ "Socketpath: " <> unFile socketPath + H.note_ $ "Foldblocks config file: " <> unFile configurationFile + gov <- H.createDirectoryIfMissing $ work "governance" + + proposalAnchorFile <- H.note $ gov "sample-proposal-anchor" + H.writeFile proposalAnchorFile "dummy anchor data" + + proposalAnchorDataHash <- H.execCli' execConfig + [ "conway", "governance" + , "hash", "anchor-data", "--file-text", proposalAnchorFile + ] + + let stakeVkeyFp = gov "stake.vkey" + stakeSKeyFp = gov "stake.skey" + + P.cliStakeAddressKeyGen + $ KeyPair { verificationKey = File stakeVkeyFp + , signingKey = File stakeSKeyFp + } + + -- Attempt a protocol parameters update (witnessed with guard rail script) + let newCommitteeTermLength = 1000 + pparamsUpdateFp <- H.note $ work "protocol-parameters-upate.action" + void $ H.execCli' execConfig + [ anyEraToString cEra, "governance", "action", "create-protocol-parameters-update" + , "--testnet" + , "--governance-action-deposit", show @Int 2_000_000 -- TODO: retrieve this from conway genesis. + , "--deposit-return-stake-verification-key-file", stakeVkeyFp + , "--anchor-url", "https://tinyurl.com/3wrwb2as" + , "--anchor-data-hash", proposalAnchorDataHash + , "--constitution-script-hash", constitutionScriptHash + , "--committee-term-length", show @Word32 newCommitteeTermLength + , "--out-file", pparamsUpdateFp + ] + + updateProposalTxBody <- H.note $ work "update-proposal.txbody" + txin4 <- findLargestUtxoForPaymentKey epochStateView sbe wallet0 + utxo <- findAllUtxos epochStateView sbe + + let utxoJSON1 = encodePretty utxo + H.lbsWriteFile (work "utxo1.json") utxoJSON1 + H.noteShow_ (work "utxo1.json") + + let relevantValue = fromMaybe mempty ((\(TxOut _ txVal _ _) -> txOutValueToValue txVal) <$> Map.lookup txin4 utxo) + adaAtInput = L.unCoin $ selectLovelace relevantValue + + + H.noteShow_ adaAtInput + protocolParametersFile <- H.note $ work "protocol-parameters.json" + void $ H.execCli' execConfig + [ anyEraToString cEra, "query", "protocol-parameters" + , "--out-file", protocolParametersFile + ] + + utxo2 <- findAllUtxos epochStateView sbe + let utxoJSON2 = encodePretty utxo2 + H.lbsWriteFile (work "utxo2.json") utxoJSON2 + H.noteShow_ (work "utxo2.json") + + void $ H.execCli' execConfig + [ anyEraToString cEra, "transaction", "build-estimate" + , "--shelley-key-witnesses", show @Int 1 + , "--total-utxo-value", show @Integer adaAtInput + , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet0 + , "--protocol-params-file", protocolParametersFile + , "--tx-in", Text.unpack $ renderTxIn txin4 + , "--tx-in-collateral", Text.unpack $ renderTxIn txin4 + , "--tx-out", Text.unpack (paymentKeyInfoAddr wallet0) <> "+" <> show @Int 3_000_001 + , "--proposal-file", pparamsUpdateFp + , "--proposal-script-file", guardRailScript + , "--proposal-redeemer-value", "0" + , "--proposal-execution-units", "(2000000,20000000)" + , "--out-file", updateProposalTxBody + ] + + updateProposalTx <- H.note $ work "update-proposal.tx" + + signedPParamsProposalTx <- signTx execConfig cEra work updateProposalTx + (File updateProposalTxBody) [SomeKeyPair $ paymentKeyInfoPair wallet0] + + + void $ H.execCli' execConfig + [ "conway", "transaction", "submit" + , "--tx-file", unFile signedPParamsProposalTx + ] + + -- Need to vote on proposal. Drep threshold must be met + governanceActionTxIdPParamUpdate <- retrieveTransactionId execConfig signedPParamsProposalTx + + !pparamsPropSubmittedResult + <- H.leftFailM $ findCondition + (maybeExtractGovernanceActionIndex (fromString governanceActionTxIdPParamUpdate)) + configurationFile + socketPath + (EpochNo 5) + + governanceActionIndexPParams <- H.nothingFail pparamsPropSubmittedResult + + -- Proposal was successfully submitted, now we vote on the proposal and confirm it was ratified + pparamsVoteFiles <- generateVoteFiles execConfig work "pparams-update-vote-files" + governanceActionTxIdPParamUpdate governanceActionIndexPParams + [(defaultDRepKeyPair idx, vote) | (vote, idx) <- allVotes] + + -- Submit votes + pparamsVoteTxBodyFp <- createVotingTxBody execConfig epochStateView sbe work "pparams-vote-tx-body" + pparamsVoteFiles wallet0 + + + pparamsVoteTxFp <- signTx execConfig cEra work "signed-vote-tx" pparamsVoteTxBodyFp signingKeys + submitTx execConfig cEra pparamsVoteTxFp + + mPParamsUpdate + <- H.leftFailM $ findCondition + (checkPParamsUpdated (EpochInterval newCommitteeTermLength)) + configurationFile socketPath (EpochNo 10) + + H.nothingFail mPParamsUpdate + +checkPParamsUpdated + :: EpochInterval -- ^ The epoch interval to check for in the updated protocol parameters + -> AnyNewEpochState + -> Maybe () +checkPParamsUpdated committeeTermLength (AnyNewEpochState sbe nes) = + let curCommTermLength :: EpochInterval + curCommTermLength = caseShelleyToBabbageOrConwayEraOnwards + (const $ error "Committee max term length only exists in Conway era onwards") + (const $ nes ^. L.newEpochStateGovStateL . L.cgsCurPParamsL . L.ppCommitteeMaxTermLengthL) + sbe + in if curCommTermLength == committeeTermLength + then Just () -- PParams was successfully updated and we terminate the fold. + else Nothing -- PParams was not updated yet, we continue the fold. + +checkConstitutionWasRatified + :: String -- submitted constitution hash + -> String -- submitted guard rail script hash + -> AnyNewEpochState + -> StateT s IO LedgerStateCondition -- ^ Accumulator at block i and fold status +checkConstitutionWasRatified submittedConstitutionHash submittedGuardRailScriptHash anyNewEpochState = + if filterRatificationState submittedConstitutionHash submittedGuardRailScriptHash anyNewEpochState + then return ConditionMet + else return ConditionNotMet + +filterRatificationState + :: String -- ^ Submitted constitution anchor hash + -> String -- ^ Submitted guard rail script hash + -> AnyNewEpochState + -> Bool +filterRatificationState c guardRailScriptHash (AnyNewEpochState sbe newEpochState) = do + caseShelleyToBabbageOrConwayEraOnwards + (const $ error "filterRatificationState: Only conway era supported") + + (const $ do + -- This is the next ratify state! Not the current constitution!!! + let constitution = newEpochState ^. L.newEpochStateGovStateL . L.cgsConstitutionL + constitutionAnchorHash = Ledger.anchorDataHash $ Ledger.constitutionAnchor constitution + L.ScriptHash constitutionScriptHash = fromMaybe (error "filterRatificationState: consitution does not have a guardrail script") + $ strictMaybeToMaybe $ constitution ^. Ledger.constitutionScriptL + Text.pack c == renderSafeHashAsHex constitutionAnchorHash && L.hashToTextAsHex constitutionScriptHash == Text.pack guardRailScriptHash + + ) + sbe +