Mm/proposal procedures

cooked-validators.cabal

@@ -34,6 +34,12 @@ library
       Cooked.MockChain.BlockChain
       Cooked.MockChain.Direct
       Cooked.MockChain.GenerateTx
+      Cooked.MockChain.GenerateTx.Collateral
+      Cooked.MockChain.GenerateTx.Common
+      Cooked.MockChain.GenerateTx.Input
+      Cooked.MockChain.GenerateTx.Output
+      Cooked.MockChain.GenerateTx.Proposal
+      Cooked.MockChain.GenerateTx.Witness
       Cooked.MockChain.MinAda
       Cooked.MockChain.Staged
       Cooked.MockChain.Testing
@@ -101,13 +107,21 @@ library
     , bytestring
     , cardano-api
     , cardano-crypto
+    , cardano-data
+    , cardano-ledger-conway
+    , cardano-ledger-core
     , cardano-ledger-shelley
     , cardano-node-emulator
+    , cardano-strict-containers
     , containers
     , data-default
     , either
+    , exceptions
     , flat
+    , http-conduit
+    , lens
     , list-t
+    , microlens
     , monad-control
     , mtl
     , nonempty-containers
@@ -146,6 +160,7 @@ test-suite spec
       Cooked.MinAdaSpec
       Cooked.MockChain.BlockChainSpec
       Cooked.MockChainSpec
+      Cooked.ProposingScriptSpec
       Cooked.ReferenceInputsSpec
       Cooked.ReferenceScriptsSpec
       Cooked.ShowBSSpec
@@ -185,14 +200,22 @@ test-suite spec
     , bytestring
     , cardano-api
     , cardano-crypto
+    , cardano-data
+    , cardano-ledger-conway
+    , cardano-ledger-core
     , cardano-ledger-shelley
     , cardano-node-emulator
+    , cardano-strict-containers
     , containers
     , cooked-validators
     , data-default
     , either
+    , exceptions
     , flat
+    , http-conduit
+    , lens
     , list-t
+    , microlens
     , monad-control
     , mtl
     , nonempty-containers

doc/IMPORTS.md

@@ -39,6 +39,7 @@ dependencies:
 ### [`cardano-ledger`](https://github.com/IntersectMBO/cardano-ledger)
 
 - package `cardano-ledger-shelley`, prefix `Shelley`
+- package `cardano-ledger-conway`, prefix `Conway`
 
 ### Exception
 

package.yaml

@@ -10,13 +10,21 @@ dependencies:
   - bytestring
   - cardano-api
   - cardano-crypto
+  - cardano-data
+  - cardano-ledger-core
   - cardano-ledger-shelley
+  - cardano-ledger-conway
   - cardano-node-emulator
+  - cardano-strict-containers
   - containers
   - data-default
   - either
+  - exceptions
   - flat
+  - http-conduit
+  - lens
   - list-t
+  - microlens
   - monad-control
   - mtl
   - nonempty-containers

src/Cooked/Conversion/ToCredential.hs

@@ -13,6 +13,9 @@ class ToCredential a where
 instance ToCredential Api.Credential where
   toCredential = id
 
+instance ToCredential Api.Address where
+  toCredential (Api.Address cred _) = cred
+
 instance ToCredential Api.PubKeyHash where
   toCredential = Api.PubKeyCredential
 

src/Cooked/Conversion/ToScriptHash.hs

@@ -4,6 +4,7 @@ module Cooked.Conversion.ToScriptHash where
 import Cooked.Conversion.ToScript
 import Plutus.Script.Utils.Scripts qualified as Script
 import Plutus.Script.Utils.Typed qualified as Script
+import Plutus.Script.Utils.V3.Scripts qualified
 import PlutusLedgerApi.V3 qualified as Api
 
 class ToScriptHash a where
@@ -12,6 +13,12 @@ class ToScriptHash a where
 instance ToScriptHash Api.ScriptHash where
   toScriptHash = id
 
+instance ToScriptHash Script.Script where
+  toScriptHash = Plutus.Script.Utils.V3.Scripts.scriptHash
+
+instance ToScriptHash Api.SerialisedScript where
+  toScriptHash = toScriptHash . Script.Script
+
 instance ToScriptHash Script.ValidatorHash where
   toScriptHash (Script.ValidatorHash h) = Script.ScriptHash h
 

src/Cooked/Conversion/ToValue.hs

@@ -16,3 +16,6 @@ instance ToValue Script.Ada where
 
 instance ToValue Cardano.Coin where
   toValue (Cardano.Coin x) = toValue (Script.Lovelace x)
+
+instance ToValue Api.Lovelace where
+  toValue (Api.Lovelace lv) = toValue (Script.Lovelace lv)

src/Cooked/MockChain/Balancing.hs

@@ -276,18 +276,19 @@ estimateTxSkelFee skel fee collateralIns returnCollateralWallet = do
   -- We return an accurate estimate of the resulting transaction fee
   return $ Emulator.unCoin $ Cardano.evaluateTransactionFee Cardano.ShelleyBasedEraConway (Emulator.pEmulatorPParams params) txBody nkeys 0
 
--- | This creates a balanced skeleton from a given skeleton and fee
--- In other words, this ensures that the following equation holds:
--- input value + minted value = output value + burned value + fee
+-- | This creates a balanced skeleton from a given skeleton and fee In other
+-- words, this ensures that the following equation holds: input value + minted
+-- value = output value + burned value + fee + deposits
 computeBalancedTxSkel :: (MonadBlockChainBalancing m) => Wallet -> BalancingOutputs -> TxSkel -> Fee -> m TxSkel
 computeBalancedTxSkel balancingWallet balancingUtxos txSkel@TxSkel {..} (lovelace -> feeValue) = do
   -- We compute the necessary values from the skeleton that are part of the
   -- equation, except for the `feeValue` which we already have.
   let (burnedValue, mintedValue) = Api.split $ txSkelMintsValue txSkelMints
       outValue = txSkelValueInOutputs txSkel
   inValue <- txSkelInputValue txSkel
+  depositedValue <- toValue <$> txSkelProposalsDeposit txSkel
   -- We compute the values missing in the left and right side of the equation
-  let (missingRight, missingLeft) = Api.split $ outValue <> burnedValue <> feeValue <> PlutusTx.negate (inValue <> mintedValue)
+  let (missingRight, missingLeft) = Api.split $ outValue <> burnedValue <> feeValue <> depositedValue <> PlutusTx.negate (inValue <> mintedValue)
   -- This gives us what we need to run our `reachValue` algorithm and append to
   -- the resulting values whatever payment was missing in the initial skeleton
   let candidatesRaw = second (<> missingRight) <$> reachValue balancingUtxos missingLeft (toInteger $ length balancingUtxos)
@@ -324,5 +325,5 @@ computeBalancedTxSkel balancingWallet balancingUtxos txSkel@TxSkel {..} (lovelac
       -- a new output at the end of the list, to keep the order intact.
       (txOutRefs, val) <- getOptimalCandidate candidatesRaw balancingWallet balancingError
       return (txOutRefs, txSkelOuts ++ [paysPK balancingWallet val])
-  let newTxSkelIns = txSkelIns <> Map.fromList ((,TxSkelNoRedeemerForPK) <$> additionalInsTxOutRefs)
+  let newTxSkelIns = txSkelIns <> Map.fromList ((,TxSkelNoRedeemer) <$> additionalInsTxOutRefs)
   return $ (txSkel & txSkelOutsL .~ newTxSkelOuts) & txSkelInsL .~ newTxSkelIns

src/Cooked/MockChain/BlockChain.hs

@@ -49,12 +49,17 @@ module Cooked.MockChain.BlockChain
     lookupUtxos,
     lookupUtxosPl,
     validateTxSkel',
+    txSkelProposalsDeposit,
+    govActionDeposit,
   )
 where
 
+import Cardano.Api.Ledger qualified as Cardano
+import Cardano.Ledger.Conway.PParams qualified as Conway
 import Cardano.Node.Emulator qualified as Emulator
 import Cardano.Node.Emulator.Internal.Node qualified as Emulator
 import Control.Arrow
+import Control.Lens qualified as Lens
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
@@ -317,6 +322,15 @@ txSkelReferenceInputUtxos :: (MonadBlockChainBalancing m) => TxSkel -> m (Map Ap
 txSkelReferenceInputUtxos TxSkel {..} =
   lookupUtxos $ mapMaybe txSkelReferenceScript (Map.elems txSkelIns) ++ Set.toList txSkelInsReference
 
+-- | Retrieves the required deposit amount for issuing governance actions.
+govActionDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace
+govActionDeposit = Api.Lovelace . Cardano.unCoin . Lens.view Conway.ppGovActionDepositL . Emulator.emulatorPParams <$> getParams
+
+-- | Retrieves the total amount of lovelace deposited in proposals in this
+-- skeleton (equal to `govActionDeposit` times the number of proposals).
+txSkelProposalsDeposit :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Lovelace
+txSkelProposalsDeposit TxSkel {..} = Api.Lovelace . (toInteger (length txSkelProposals) *) . Api.getLovelace <$> govActionDeposit
+
 -- | Helper to convert Nothing to an error
 maybeErrM :: (MonadBlockChainBalancing m) => MockChainError -> (a -> b) -> m (Maybe a) -> m b
 maybeErrM err f = (maybe (throwError err) (return . f) =<<)