Mid: Ensure proposal and voting trigger

dev-local/Main.hs

@@ -19,6 +19,7 @@ import Options.Applicative hiding (str)
 import Populate
 import Streamly.Console.Stdio qualified as Console
 import Streamly.Unicode.String (str)
+import System.Directory (withCurrentDirectory)
 import System.Environment (setEnv)
 import System.FilePath ((</>))
 import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
@@ -146,6 +147,41 @@ scripts:
 #{escrowV2}
 |]
 
+createProposalConfig :: String -> IO ()
+createProposalConfig scriptsDirName =
+    withCurrentDirectory scriptsDirPath $ do
+        -- NOTE: create-info does not trigger the proposal script so we use a treasure
+        -- withdrawal instead.
+        -- NOTE: key-reg-deposit-amt == 1_000_000 comes from the ".dRepDeposit"
+        -- in the protocol-parameters.
+        policyHash <- getPolicyId "policy.plutus"
+        govDrepRegCert
+            [ opt "drep-script-hash" policyHash
+            , opt "key-reg-deposit-amt" (1_000_000 :: Int)
+            , opt' "out-file" "drep.cert"
+            ]
+        -- NOTE: 1_000_000 comes from the ".govActionDeposit" in the
+        -- protocol-parameters.
+        govCreateTreasureWithdrawal
+            [ opt "governance-action-deposit" (1_000_000 :: Int)
+            , opt' "deposit-return-stake-script-file" "policy.plutus"
+            , opt' "anchor-url" anchorUrl
+            , opt' "anchor-data-hash" anchorHash
+            , opt' "funds-receiving-stake-script-file" "policy.plutus"
+            , opt "transfer" (100_000 :: Int)
+            , opt' "out-file" "action.proposal"
+            ]
+        govDrepRegCert
+            [ opt "drep-script-hash" policyHash
+            , opt "key-reg-deposit-amt" (1_000_000 :: Int)
+            , opt' "out-file" "drep.cert"
+            ]
+  where
+    anchorUrl = "https://raw.githubusercontent.com/tweag/plutus-reexec/61e7ccd35bac5613c6a7cbe40b74278034c0a802/docs/proposal.md"
+    anchorHash = "6323dfff0b94a16e1964235c9625798e476dfd88879240e94d891066b14d4a90"
+    opt' a b = opt a (b :: String)
+    scriptsDirPath = env_LOCAL_CONFIG_DIR </> scriptsDirName
+
 createTracingConfig ::
     (IsPlutusScriptLanguage lang) =>
     String ->
@@ -213,6 +249,7 @@ createConfig = do
         ReleaseV3.tracingScript
         DebugV3.tracingScript
         DebugV3.tracingScript
+    createProposalConfig "tracing-plutus-v3"
 
     createTracingConfig
         "tracing-plutus-v2"

dev-local/Populate.hs

@@ -17,6 +17,12 @@ module Populate (
     buildStakeAddress,
     genRegCertStakeAddress,
     genDeregCertStakeAddress,
+    govDrepRegCert,
+    hashAnchorData,
+    govCreateInfo,
+    govCreateTreasureWithdrawal,
+    keygenStake,
+    voteCreate,
     -- Globals
     env_LOCAL_CONFIG_DIR,
     env_POPULATE_WORK_DIR,
@@ -150,6 +156,9 @@ opt a b = (a, Just (quoted b))
 flg :: String -> CmdOption
 flg a = (a, Nothing)
 
+optTestnet :: CmdOption
+optTestnet = flg "testnet"
+
 optNetwork :: CmdOption
 optNetwork = opt "testnet-magic" env_CARDANO_TESTNET_MAGIC
 
@@ -263,6 +272,41 @@ getUtxoListAt walletAddr =
         & nonEmptyLines
         & Stream.fold Fold.toList
 
+hashAnchorData :: [CmdOption] -> IO ()
+hashAnchorData args =
+    runCmd
+        "cardano-cli hash anchor-data"
+        args
+        & drain
+
+govDrepRegCert :: [CmdOption] -> IO ()
+govDrepRegCert args =
+    runCmd
+        "cardano-cli conway governance drep registration-certificate"
+        args
+        & drain
+
+voteCreate :: [CmdOption] -> IO ()
+voteCreate args =
+    runCmd
+        "cardano-cli conway governance vote create"
+        args
+        & drain
+
+govCreateTreasureWithdrawal :: [CmdOption] -> IO ()
+govCreateTreasureWithdrawal args =
+    runCmd
+        "cardano-cli conway governance action create-treasury-withdrawal"
+        (optTestnet : args)
+        & drain
+
+govCreateInfo :: [CmdOption] -> IO ()
+govCreateInfo args =
+    runCmd
+        "cardano-cli conway governance action create-info"
+        (optTestnet : args)
+        & drain
+
 nullUtxo :: String -> IO Bool
 nullUtxo utxo =
     runCmd
@@ -284,6 +328,15 @@ keygen vkey skey =
         ]
         & drain
 
+keygenStake :: FilePath -> FilePath -> IO ()
+keygenStake vkey skey =
+    runCmd
+        "cardano-cli conway stake-address key-gen"
+        [ opt "verification-key-file" vkey
+        , opt "signing-key-file" skey
+        ]
+        & drain
+
 data Wallet
     = Wallet
     { wVKeyFile :: FilePath
@@ -356,6 +409,7 @@ data AppEnv = AppEnv
     , stakeAddrFilePath :: FilePath
     , regCertFilePath :: FilePath
     , deregCertFilePath :: FilePath
+    , proposalFilePath :: FilePath
     , numIterations :: Int
     , assetAmount :: String
     }
@@ -368,6 +422,7 @@ makeAppEnv scriptsDirName = do
         stakeAddrFilePath = scriptsDirPath </> "script.stake.addr"
         regCertFilePath = scriptsDirPath </> "registration.cert"
         deregCertFilePath = scriptsDirPath </> "deregistration.cert"
+        proposalFilePath = scriptsDirPath </> "action.proposal"
         tokenName = "TEST_TOKEN"
         assetAmount = "100"
         numIterations = 10
@@ -393,6 +448,7 @@ makeAppEnv scriptsDirName = do
             , stakeAddrFilePath = stakeAddrFilePath
             , regCertFilePath = regCertFilePath
             , deregCertFilePath = deregCertFilePath
+            , proposalFilePath = proposalFilePath
             }
 
 finalizeCurrentTransaction :: IO ()
@@ -480,6 +536,8 @@ runBurn AppEnv{..} lockedUtxo = do
 
 runCertifyReg :: AppEnv -> IO ()
 runCertifyReg AppEnv{..} = do
+    ensureBlankWorkDir
+
     printStep "Certify - Reg"
 
     faucetUtxo <- getFirstUtxoAt faucetAddr
@@ -499,6 +557,8 @@ runCertifyReg AppEnv{..} = do
 
 runCertifyDereg :: AppEnv -> IO ()
 runCertifyDereg AppEnv{..} = do
+    ensureBlankWorkDir
+
     printStep "Certify - Dereg"
 
     faucetUtxo <- getFirstUtxoAt faucetAddr
@@ -516,8 +576,32 @@ runCertifyDereg AppEnv{..} = do
     waitTillExists $ fstOutput txId
     printVar "runCertifyDereg.txId" txId
 
+runVoterReg :: AppEnv -> IO ()
+runVoterReg AppEnv{..} = do
+    ensureBlankWorkDir
+
+    printStep "Voter - Reg"
+
+    let certFile = env_LOCAL_CONFIG_DIR </> "tracing-plutus-v3/drep.cert"
+    faucetUtxo <- getFirstUtxoAt faucetAddr
+    buildTransaction
+        [ opt "tx-in" faucetUtxo
+        , opt "tx-in-collateral" faucetUtxo
+        , opt "change-address" faucetAddr
+        , opt "certificate-file" certFile
+        , opt "certificate-script-file" policyFilePath
+        , opt "certificate-redeemer-value" (13 :: Int)
+        , opt "out-file" env_TX_UNSIGNED
+        ]
+    finalizeCurrentTransaction
+    txId <- getTransactionId env_TX_SIGNED
+    waitTillExists $ fstOutput txId
+    printVar "runVoterReg.txId" txId
+
 runReward :: AppEnv -> IO ()
 runReward AppEnv{..} = do
+    ensureBlankWorkDir
+
     printStep "Reward"
 
     faucetUtxo <- getFirstUtxoAt faucetAddr
@@ -538,6 +622,52 @@ runReward AppEnv{..} = do
     waitTillExists $ fstOutput txId
     printVar "runReward.txId" txId
 
+runProposal :: AppEnv -> IO String
+runProposal AppEnv{..} = do
+    ensureBlankWorkDir
+    printStep "Proposal"
+    faucetUtxo <- getFirstUtxoAt faucetAddr
+    buildTransaction
+        [ opt "tx-in" faucetUtxo
+        , opt "change-address" faucetAddr
+        , opt "proposal-file" proposalFilePath
+        , -- , opt "proposal-script-file" policyFilePath
+          -- , opt "proposal-redeemer-value" (11 :: Int)
+          opt "out-file" env_TX_UNSIGNED
+        ]
+    finalizeCurrentTransaction
+    txId <- getTransactionId env_TX_SIGNED
+    waitTillExists $ fstOutput txId
+    printVar "runProposal.txId" txId
+    pure txId
+
+runVoting :: AppEnv -> String -> IO ()
+runVoting AppEnv{..} govActTxid = do
+    ensureBlankWorkDir
+    printStep "Voting"
+    faucetUtxo <- getFirstUtxoAt faucetAddr
+    policyHash <- getPolicyId policyFilePath
+    voteCreate
+        [ flg "yes"
+        , opt "governance-action-tx-id" govActTxid
+        , opt "governance-action-index" (0 :: Int)
+        , opt "drep-script-hash" policyHash
+        , opt "out-file" (env_POPULATE_WORK_DIR </> "script.vote")
+        ]
+    buildTransaction
+        [ opt "tx-in" faucetUtxo
+        , opt "tx-in-collateral" faucetUtxo
+        , opt "change-address" faucetAddr
+        , opt "vote-file" (env_POPULATE_WORK_DIR </> "script.vote")
+        , opt "vote-script-file" policyFilePath
+        , opt "vote-redeemer-value" (11 :: Int)
+        , opt "out-file" env_TX_UNSIGNED
+        ]
+    finalizeCurrentTransaction
+    txId <- getTransactionId env_TX_SIGNED
+    waitTillExists $ fstOutput txId
+    printVar "runVoting.txId" txId
+
 testScriptTriggerWith :: AppEnv -> IO ()
 testScriptTriggerWith appEnv = do
     utxo0 <- fstOutput <$> runMint appEnv
@@ -549,8 +679,14 @@ testScriptTriggerWith appEnv = do
 
 testScriptTrigger :: IO ()
 testScriptTrigger = do
-    testScriptTriggerWith =<< makeAppEnv "tracing-plutus-v2"
-    testScriptTriggerWith =<< makeAppEnv "tracing-plutus-v3"
+    -- testScriptTriggerWith =<< makeAppEnv "tracing-plutus-v2"
+
+    v3Env <- makeAppEnv "tracing-plutus-v3"
+    -- testScriptTriggerWith v3Env
+    runCertifyReg v3Env
+    runVoterReg v3Env
+    runProposal v3Env >>= runVoting v3Env
+    runCertifyDereg v3Env
 
 --------------------------------------------------------------------------------
 -- Escrow

lib/PSR/ContextBuilder.hs

@@ -128,6 +128,21 @@ getInputScriptAddrs utxoMap tx =
     let utxoList = Map.elems $ Map.restrictKeys utxoMap $ getTxInSet tx
      in Set.fromList $ mapMaybe getTxOutScriptAddr utxoList
 
+getProposingScriptHashes :: C.Tx era -> Set C.ScriptHash
+getProposingScriptHashes tx =
+    case C.txProposalProcedures (C.getTxBodyContent (C.getTxBody tx)) of
+        Nothing -> Set.empty
+        Just (C.Featured _ C.TxProposalProceduresNone) -> Set.empty
+        Just (C.Featured _ (C.TxProposalProcedures proMap)) ->
+            Set.fromAscList . mapMaybe unwrapAndExtract . map fst $
+                OMap.toAscList proMap
+  where
+    -- unwrapAndExtract :: C.ProposalProcedure era -> Maybe C.ScriptHash
+    unwrapAndExtract pp =
+        case L.raCredential (L.pProcReturnAddr pp) of
+            L.ScriptHashObj hash -> Just $ C.fromShelleyScriptHash hash
+            L.KeyHashObj _ -> Nothing
+
 getCertifyingScriptHashes :: C.Tx era -> Set C.ScriptHash
 getCertifyingScriptHashes tx =
     case C.txCertificates (C.getTxBodyContent (C.getTxBody tx)) of
@@ -181,6 +196,7 @@ getNonEmptyIntersection ConfigMap{..} BlockContext{..} tx = do
                     , getInputScriptAddrs inpUtxoMap tx
                     , getCertifyingScriptHashes tx
                     , getRewardingScriptHashes tx
+                    , getProposingScriptHashes tx
                     ]
     guard (not $ Map.null interestingScripts)
     pure interestingScripts
@@ -191,6 +207,7 @@ mkTransactionContext ::
     ContextBuilderMetrics -> ConfigMap -> BlockContext era -> C.Tx era -> IO (Maybe (TransactionContext era))
 mkTransactionContext metrics cm bc tx =
     observeDuration metrics.mkTransactionContext_runtime $ do
+        print (show (getProposingScriptHashes tx))
         let res = mkTransactionContext' cm bc tx
         -- Ensure the result is actually forced so the metrics are accurate
         !_ <- evaluate (maybe () forceExecutionResults res)

plutus-script-reexecutor.cabal

@@ -141,6 +141,7 @@ executable dev-local
   build-depends:
     , base
     , cardano-api
+    , directory
     , filepath
     , onchain
     , optparse-applicative