|
| 1 | +{-# LANGUAGE DataKinds #-} |
| 2 | +{-# LANGUAGE GADTs #-} |
| 3 | +{-# LANGUAGE NamedFieldPuns #-} |
| 4 | +{-# LANGUAGE OverloadedStrings #-} |
| 5 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 6 | +{-# LANGUAGE TypeApplications #-} |
| 7 | + |
| 8 | +module Cardano.Testnet.Test.LedgerEvents.Gov.ProposeNewConstitutionSPO |
| 9 | + ( hprop_ledger_events_propose_new_constitution_spo |
| 10 | + ) where |
| 11 | + |
| 12 | +import Cardano.Api |
| 13 | + |
| 14 | +import Cardano.Testnet |
| 15 | + |
| 16 | +import Prelude |
| 17 | + |
| 18 | +import Control.Monad.Trans.Except |
| 19 | +import qualified Data.Map.Strict as Map |
| 20 | +import qualified Data.Text as Text |
| 21 | +import Data.Word |
| 22 | +import GHC.Stack (HasCallStack, withFrozenCallStack) |
| 23 | +import System.FilePath ((</>)) |
| 24 | + |
| 25 | +import Hedgehog |
| 26 | +import qualified Hedgehog.Extras as H |
| 27 | +import qualified Hedgehog.Extras.Stock.IO.Network.Sprocket as IO |
| 28 | +import qualified Testnet.Process.Cli as P |
| 29 | +import qualified Testnet.Process.Run as H |
| 30 | + |
| 31 | +import Control.Monad.IO.Class |
| 32 | +import Data.Data |
| 33 | +import Data.List (isInfixOf) |
| 34 | +import Data.Type.Equality |
| 35 | +import GHC.IORef (newIORef) |
| 36 | +import qualified Hedgehog as H |
| 37 | +import Hedgehog.Extras (Integration) |
| 38 | +import System.Exit (ExitCode (ExitSuccess)) |
| 39 | +import Testnet.Process.Cli (execCliStdoutToJson) |
| 40 | +import qualified Testnet.Property.Utils as H |
| 41 | +import Testnet.Property.Utils (queryUtxos) |
| 42 | +import Testnet.Runtime |
| 43 | + |
| 44 | +import qualified Cardano.Api as Api |
| 45 | +import Cardano.Api.Ledger |
| 46 | +import Cardano.CLI.Types.Output (QueryTipLocalStateOutput (QueryTipLocalStateOutput), |
| 47 | + mEpoch) |
| 48 | +import qualified Cardano.Ledger.Conway.Governance as L |
| 49 | +import qualified Cardano.Ledger.Shelley.LedgerState as L |
| 50 | +import Control.Monad.Trans.State.Strict (put) |
| 51 | +import Data.Bifunctor (Bifunctor (..)) |
| 52 | +import Lens.Micro |
| 53 | + |
| 54 | +-- | Test that SPO cannot vote on a new constitution |
| 55 | +-- Execute me with: |
| 56 | +-- @cabal test cardano-testnet-test --test-options '-p "/ProposeNewConstitutionSPO/"'@ |
| 57 | +hprop_ledger_events_propose_new_constitution_spo :: Property |
| 58 | +hprop_ledger_events_propose_new_constitution_spo = H.integrationWorkspace "propose-new-constitution-spo" $ \tempAbsBasePath' -> do |
| 59 | + conf@Conf { tempAbsPath=tempAbsPath@(TmpAbsolutePath work) } |
| 60 | + <- mkConf tempAbsBasePath' |
| 61 | + let tempAbsPath' = unTmpAbsPath tempAbsPath |
| 62 | + tempBaseAbsPath = makeTmpBaseAbsPath tempAbsPath |
| 63 | + |
| 64 | + utxoFileCounter <- liftIO $ newIORef 1 |
| 65 | + |
| 66 | + let sbe = ShelleyBasedEraConway |
| 67 | + era = toCardanoEra sbe |
| 68 | + cEra = AnyCardanoEra era |
| 69 | + fastTestnetOptions = cardanoDefaultTestnetOptions |
| 70 | + { cardanoEpochLength = 100 |
| 71 | + , cardanoSlotLength = 0.1 |
| 72 | + , cardanoNodeEra = cEra |
| 73 | + } |
| 74 | + |
| 75 | + TestnetRuntime |
| 76 | + { testnetMagic |
| 77 | + , poolNodes |
| 78 | + , wallets |
| 79 | + , configurationFile |
| 80 | + } |
| 81 | + <- cardanoTestnetDefault fastTestnetOptions conf |
| 82 | + |
| 83 | + poolNode1 <- H.headM poolNodes |
| 84 | + poolSprocket1 <- H.noteShow $ nodeSprocket $ poolRuntime poolNode1 |
| 85 | + execConfig <- H.mkExecConfig tempBaseAbsPath poolSprocket1 testnetMagic |
| 86 | + |
| 87 | + let queryAnyUtxo :: Text.Text -> Integration TxIn |
| 88 | + queryAnyUtxo address = withFrozenCallStack $ do |
| 89 | + utxos <- queryUtxos execConfig work utxoFileCounter sbe address |
| 90 | + H.noteShow =<< H.headM (Map.keys utxos) |
| 91 | + socketName' = IO.sprocketName poolSprocket1 |
| 92 | + socketBase = IO.sprocketBase poolSprocket1 -- /tmp |
| 93 | + socketPath = socketBase </> socketName' |
| 94 | + |
| 95 | + H.note_ $ "Sprocket: " <> show poolSprocket1 |
| 96 | + H.note_ $ "Abs path: " <> tempAbsBasePath' |
| 97 | + H.note_ $ "Socketpath: " <> socketPath |
| 98 | + H.note_ $ "Foldblocks config file: " <> configurationFile |
| 99 | + |
| 100 | + -- Create Conway constitution |
| 101 | + gov <- H.createDirectoryIfMissing $ work </> "governance" |
| 102 | + proposalAnchorFile <- H.note $ work </> gov </> "sample-proposal-anchor" |
| 103 | + constitutionFile <- H.note $ work </> gov </> "sample-constitution" |
| 104 | + constitutionActionFp <- H.note $ work </> gov </> "constitution.action" |
| 105 | + |
| 106 | + H.writeFile proposalAnchorFile "dummy anchor data" |
| 107 | + H.writeFile constitutionFile "dummy constitution data" |
| 108 | + constitutionHash <- H.execCli' execConfig |
| 109 | + [ "conway", "governance" |
| 110 | + , "hash", "anchor-data", "--file-text", constitutionFile |
| 111 | + ] |
| 112 | + |
| 113 | + proposalAnchorDataHash <- H.execCli' execConfig |
| 114 | + [ "conway", "governance" |
| 115 | + , "hash", "anchor-data", "--file-text", proposalAnchorFile |
| 116 | + ] |
| 117 | + |
| 118 | + let stakeVkeyFp = gov </> "stake.vkey" |
| 119 | + stakeSKeyFp = gov </> "stake.skey" |
| 120 | + |
| 121 | + _ <- P.cliStakeAddressKeyGen tempAbsPath' |
| 122 | + $ P.KeyNames { P.verificationKeyFile = stakeVkeyFp |
| 123 | + , P.signingKeyFile = stakeSKeyFp |
| 124 | + } |
| 125 | + |
| 126 | + let spoColdVkeyFp :: Int -> FilePath |
| 127 | + spoColdVkeyFp n = tempAbsPath' </> "pools-keys" </> "pool" <> show n </> "cold.vkey" |
| 128 | + |
| 129 | + spoColdSkeyFp :: Int -> FilePath |
| 130 | + spoColdSkeyFp n = tempAbsPath' </> "pools-keys" </> "pool" <> show n </> "cold.skey" |
| 131 | + |
| 132 | + -- Create constitution proposal |
| 133 | + H.noteM_ $ H.execCli' execConfig |
| 134 | + [ "conway", "governance", "action", "create-constitution" |
| 135 | + , "--testnet" |
| 136 | + , "--governance-action-deposit", show @Int 0 -- TODO: Get this from the node |
| 137 | + , "--deposit-return-stake-verification-key-file", stakeVkeyFp |
| 138 | + , "--anchor-url", "https://tinyurl.com/3wrwb2as" |
| 139 | + , "--anchor-data-hash", proposalAnchorDataHash |
| 140 | + , "--constitution-url", "https://tinyurl.com/2pahcy6z" |
| 141 | + , "--constitution-hash", constitutionHash |
| 142 | + , "--out-file", constitutionActionFp |
| 143 | + ] |
| 144 | + |
| 145 | + txbodyFp <- H.note $ work </> "tx.body" |
| 146 | + txbodySignedFp <- H.note $ work </> "tx.body.signed" |
| 147 | + |
| 148 | + txin1 <- queryAnyUtxo . paymentKeyInfoAddr $ head wallets |
| 149 | + |
| 150 | + H.noteM_ $ H.execCli' execConfig |
| 151 | + [ "conway", "transaction", "build" |
| 152 | + , "--tx-in", Text.unpack $ renderTxIn txin1 |
| 153 | + , "--change-address", Text.unpack $ paymentKeyInfoAddr $ head wallets |
| 154 | + , "--proposal-file", constitutionActionFp |
| 155 | + , "--out-file", txbodyFp |
| 156 | + ] |
| 157 | + |
| 158 | + H.noteM_ $ H.execCli' execConfig |
| 159 | + [ "conway", "transaction", "sign" |
| 160 | + , "--tx-body-file", txbodyFp |
| 161 | + , "--signing-key-file", paymentSKey $ paymentKeyInfoPair $ head wallets |
| 162 | + , "--out-file", txbodySignedFp |
| 163 | + ] |
| 164 | + |
| 165 | + H.noteM_ $ H.execCli' execConfig |
| 166 | + [ "conway", "transaction", "submit" |
| 167 | + , "--tx-file", txbodySignedFp |
| 168 | + ] |
| 169 | + |
| 170 | + txidString <- mconcat . lines <$> H.execCli' execConfig |
| 171 | + [ "transaction", "txid" |
| 172 | + , "--tx-file", txbodySignedFp |
| 173 | + ] |
| 174 | + |
| 175 | + QueryTipLocalStateOutput{mEpoch} <- execCliStdoutToJson execConfig [ "query", "tip" ] |
| 176 | + currentEpoch <- H.evalMaybe mEpoch |
| 177 | + -- Proposal should be there already, so don't wait a lot: |
| 178 | + let terminationEpoch = succ . succ $ currentEpoch |
| 179 | + |
| 180 | + mGovActionId <- getConstitutionProposal (Api.File configurationFile) (Api.File socketPath) terminationEpoch |
| 181 | + govActionId <- H.evalMaybe mGovActionId |
| 182 | + -- Proposal was successfully submitted, now we vote on the proposal and confirm it was ratified |
| 183 | + |
| 184 | + let L.GovActionIx governanceActionIndex = L.gaidGovActionIx govActionId |
| 185 | + |
| 186 | + let voteFp :: Int -> FilePath |
| 187 | + voteFp n = work </> gov </> "vote-" <> show n |
| 188 | + |
| 189 | + H.forConcurrently_ [1..3] $ \n -> do |
| 190 | + H.execCli' execConfig |
| 191 | + [ "conway", "governance", "vote", "create" |
| 192 | + , "--yes" |
| 193 | + , "--governance-action-tx-id", txidString |
| 194 | + , "--governance-action-index", show @Word32 governanceActionIndex |
| 195 | + , "--cold-verification-key-file", spoColdVkeyFp n |
| 196 | + , "--out-file", voteFp n |
| 197 | + ] |
| 198 | + |
| 199 | + -- We need more UTxOs |
| 200 | + txin2 <- queryAnyUtxo . paymentKeyInfoAddr $ head wallets |
| 201 | + |
| 202 | + voteTxFp <- H.note $ work </> gov </> "vote.tx" |
| 203 | + voteTxBodyFp <- H.note $ work </> gov </> "vote.txbody" |
| 204 | + |
| 205 | + -- Submit votes |
| 206 | + H.noteM_ $ H.execCli' execConfig |
| 207 | + [ "conway", "transaction", "build" |
| 208 | + , "--tx-in", Text.unpack $ renderTxIn txin2 |
| 209 | + , "--change-address", Text.unpack $ paymentKeyInfoAddr $ head wallets |
| 210 | + , "--vote-file", voteFp 1 |
| 211 | + , "--vote-file", voteFp 2 |
| 212 | + , "--vote-file", voteFp 3 |
| 213 | + , "--witness-override", show @Int 4 |
| 214 | + , "--out-file", voteTxBodyFp |
| 215 | + ] |
| 216 | + |
| 217 | + H.noteM_ $ H.execCli' execConfig |
| 218 | + [ "conway", "transaction", "sign" |
| 219 | + , "--tx-body-file", voteTxBodyFp |
| 220 | + , "--signing-key-file", paymentSKey $ paymentKeyInfoPair $ head wallets |
| 221 | + , "--signing-key-file", spoColdSkeyFp 1 |
| 222 | + , "--signing-key-file", spoColdSkeyFp 2 |
| 223 | + , "--signing-key-file", spoColdSkeyFp 3 |
| 224 | + , "--out-file", voteTxFp |
| 225 | + ] |
| 226 | + |
| 227 | + -- Call should fail, because SPOs are unallowed to vote on the constitution |
| 228 | + (exitCode, _, stderr) <- H.execCliAny execConfig |
| 229 | + [ "conway", "transaction", "submit" |
| 230 | + , "--tx-file", voteTxFp |
| 231 | + ] |
| 232 | + |
| 233 | + exitCode H./== ExitSuccess -- Dit it fail? |
| 234 | + H.assert $ "DisallowedVoters" `isInfixOf` stderr -- Did it fail for the expected reason? |
| 235 | + |
| 236 | +getConstitutionProposal :: |
| 237 | + (HasCallStack, MonadIO m, MonadTest m) |
| 238 | + => NodeConfigFile In |
| 239 | + -> SocketPath |
| 240 | + -> EpochNo -- ^ The termination epoch: the constitution proposal must be found *before* this epoch |
| 241 | + -> m (Maybe (L.GovActionId StandardCrypto)) |
| 242 | +getConstitutionProposal nodeConfigFile socketPath maxEpoch = do |
| 243 | + result <- runExceptT $ checkLedgerStateCondition nodeConfigFile socketPath QuickValidation maxEpoch Nothing |
| 244 | + $ \(AnyNewEpochState actualEra newEpochState) -> do |
| 245 | + case testEquality expectedEra actualEra of |
| 246 | + Just Refl -> do |
| 247 | + let proposals = shelleyBasedEraConstraints expectedEra newEpochState |
| 248 | + ^. L.nesEsL |
| 249 | + . L.esLStateL |
| 250 | + . L.lsUTxOStateL |
| 251 | + . L.utxosGovStateL |
| 252 | + . L.cgProposalsL |
| 253 | + govActions = Map.toList $ L.proposalsActionsMap proposals |
| 254 | + case map (second L.gasAction) govActions of |
| 255 | + (govActionId, L.NewConstitution _ _) : _ -> do |
| 256 | + put $ Just govActionId |
| 257 | + pure ConditionMet |
| 258 | + _ -> |
| 259 | + pure ConditionNotMet |
| 260 | + Nothing -> do |
| 261 | + error $ "Eras mismatch! expected: " <> show expectedEra <> ", actual: " <> show actualEra |
| 262 | + (_, mGovAction) <- H.evalEither result |
| 263 | + return mGovAction |
| 264 | + where |
| 265 | + expectedEra = ShelleyBasedEraConway |
0 commit comments