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) =<<)