Merge remote-tracking branch 'upstream/master'

cardano-chain-gen/cardano-chain-gen.cabal

@@ -52,6 +52,7 @@ library
                         Cardano.Mock.Forging.Tx.Babbage
                         Cardano.Mock.Forging.Tx.Babbage.Scenarios
                         Cardano.Mock.Forging.Tx.Conway
+                        Cardano.Mock.Forging.Tx.Conway.Scenarios
                         Cardano.Mock.Forging.Tx.Generic
                         Cardano.Mock.Forging.Tx.Shelley
                         Cardano.Mock.Forging.Types
@@ -151,7 +152,12 @@ test-suite cardano-chain-gen
                         Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.ForceIndex
                         Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.MigrateConsumedPruneTxOut
                         Test.Cardano.Db.Mock.Unit.Conway.Config
+                        Test.Cardano.Db.Mock.Unit.Conway.Other
+                        Test.Cardano.Db.Mock.Unit.Conway.Reward
+                        Test.Cardano.Db.Mock.Unit.Conway.Rollback
                         Test.Cardano.Db.Mock.Unit.Conway.Simple
+                        Test.Cardano.Db.Mock.Unit.Conway.Stake
+                        Test.Cardano.Db.Mock.Unit.Conway.Tx
                         Test.Cardano.Db.Mock.UnifiedApi
                         Test.Cardano.Db.Mock.Validate
 
@@ -165,13 +171,15 @@ test-suite cardano-chain-gen
                       , cardano-db-sync
                       , cardano-chain-gen
                       , cardano-ledger-alonzo
+                      , cardano-ledger-conway
                       , cardano-ledger-core
                       , cardano-ledger-mary
                       , cardano-ledger-shelley
                       , cardano-node
                       , cardano-prelude
                       , cardano-slotting
                       , cardano-smash-server
+                      , cardano-strict-containers
                       , containers
                       , contra-tracer
                       , directory

cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs

@@ -41,6 +41,7 @@ import qualified Cardano.Ledger.TxIn as Ledger
 import Cardano.Mock.ChainDB
 import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo
 import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage
+import qualified Cardano.Mock.Forging.Tx.Conway as Conway
 import qualified Cardano.Mock.Forging.Tx.Shelley as Shelley
 import Cardano.Mock.Forging.Types
 import Cardano.Prelude (bimap, throwIO)
@@ -296,6 +297,7 @@ forgeWithStakeCreds inter = do
     LedgerStateShelley sts -> either throwIO (pure . TxShelley) $ Shelley.mkDCertTxPools sts
     LedgerStateAlonzo sta -> either throwIO (pure . TxAlonzo) $ Alonzo.mkDCertTxPools sta
     LedgerStateBabbage stb -> either throwIO (pure . TxBabbage) $ Babbage.mkDCertTxPools stb
+    LedgerStateConway stc -> either throwIO (pure . TxConway) $ Conway.mkDCertTxPools stc
     _ -> throwIO UnexpectedEra
   forgeNextFindLeader inter [tx]
 

cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs

@@ -98,16 +98,15 @@ consTxBody ins cols outs fees minted certs wdrl =
     (Strict.SJust Testnet)
 
 addValidityInterval ::
+  AlonzoEraTxBody era =>
   SlotNo ->
-  AlonzoTx StandardAlonzo ->
-  AlonzoTx StandardAlonzo
+  AlonzoTx era ->
+  AlonzoTx era
 addValidityInterval slotNo tx =
   tx {body = txBody'}
   where
     interval = ValidityInterval Strict.SNothing (Strict.SJust slotNo)
-    -- TxBody has a restricted export via pattern synonyms, there is no better way to do this.
-    AlonzoTxBody a b c d e f _ h i j k l m = body tx
-    txBody' = AlonzoTxBody a b c d e f interval h i j k l m
+    txBody' = set vldtTxBodyL interval (body tx)
 
 consPaymentTxBody ::
   Set (TxIn StandardCrypto) ->

cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs

@@ -73,7 +73,7 @@ import Cardano.Ledger.Shelley.TxCert
 import Cardano.Ledger.Shelley.UTxO
 import Cardano.Ledger.TxIn (TxIn (..))
 import Cardano.Ledger.Val
-import Cardano.Mock.Forging.Tx.Alonzo (mkUTxOAlonzo, mkWitnesses)
+import Cardano.Mock.Forging.Tx.Alonzo (addValidityInterval, mkUTxOAlonzo, mkWitnesses)
 import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples
 import Cardano.Mock.Forging.Tx.Generic
 import Cardano.Mock.Forging.Types
@@ -137,16 +137,6 @@ consTxBody ins cols ref outs collOut fees minted certs wdrl =
     Strict.SNothing
     (Strict.SJust Testnet)
 
-addValidityInterval ::
-  SlotNo ->
-  AlonzoTx StandardBabbage ->
-  AlonzoTx StandardBabbage
-addValidityInterval slotNo tx =
-  tx {body = txBody'}
-  where
-    interval = ValidityInterval SNothing (SJust slotNo)
-    txBody' = set vldtTxBodyL interval $ body tx
-
 consPaymentTxBody ::
   Set (TxIn StandardCrypto) ->
   Set (TxIn StandardCrypto) ->

cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs

@@ -5,13 +5,25 @@
 
 module Cardano.Mock.Forging.Tx.Conway (
   consTxBody,
+  consCertTxBody,
+  consPoolParams,
   mkPaymentTx,
+  mkPaymentTx',
   mkSimpleTx,
+  mkDCertTx,
+  mkDCertTxPools,
+  mkSimpleDCertTx,
+  mkDepositTxPools,
+  mkDummyRegisterTx,
+  mkTxDelegCert,
+  mkRegTxCert,
+  mkUnRegTxCert,
+  mkDelegTxCert,
   mkFullTx,
-  consPoolParams,
   mkScriptInp,
   mkWitnesses,
   mkUTxOConway,
+  addValidityInterval,
 ) where
 
 import Cardano.Ledger.Address (Addr (..), RewardAcnt (..), Withdrawals (..))
@@ -25,20 +37,25 @@ import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Conway.Governance (VotingProcedures (..))
 import Cardano.Ledger.Conway.Tx (AlonzoTx (..))
 import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..))
-import Cardano.Ledger.Conway.TxCert
+import Cardano.Ledger.Conway.TxCert hiding (mkDelegTxCert)
 import Cardano.Ledger.Conway.TxOut (BabbageTxOut (..))
 import qualified Cardano.Ledger.Core as Core
-import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
+import Cardano.Ledger.Credential (Credential (..), StakeCredential, StakeReference (..))
+import Cardano.Ledger.Crypto (ADDRHASH ())
+import Cardano.Ledger.Keys (KeyHash (..))
 import Cardano.Ledger.Language (Language (..))
 import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..), valueFromList)
+import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState
 import Cardano.Ledger.Shelley.TxAuxData (Metadatum (..))
 import Cardano.Ledger.TxIn (TxIn (..))
-import Cardano.Mock.Forging.Tx.Alonzo (mkUTxOAlonzo, mkWitnesses)
+import Cardano.Ledger.Val (coin)
+import Cardano.Mock.Forging.Tx.Alonzo (addValidityInterval, mkUTxOAlonzo, mkWitnesses)
 import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples
 import Cardano.Mock.Forging.Tx.Babbage (mkScriptInp)
 import Cardano.Mock.Forging.Tx.Generic
 import Cardano.Mock.Forging.Types
 import Cardano.Prelude
+import Data.List (nub)
 import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Map as Map
 import Data.Maybe.Strict (StrictMaybe (..), maybeToStrictMaybe)
@@ -48,6 +65,7 @@ import qualified Data.Set as Set
 import Ouroboros.Consensus.Cardano.Block (LedgerState ())
 import Ouroboros.Consensus.Shelley.Eras (StandardConway (), StandardCrypto ())
 import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
+import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Consensus
 import Prelude ((!!))
 import qualified Prelude
 
@@ -88,32 +106,74 @@ consTxBody ins cols ref outs colOut fees minted certs withdrawals =
     , ctbTreasuryDonation = Coin 0
     }
 
+consCertTxBody ::
+  Maybe (TxIn StandardCrypto) ->
+  [ConwayTxCert StandardConway] ->
+  Withdrawals StandardCrypto ->
+  ConwayTxBody StandardConway
+consCertTxBody ref = consTxBody mempty mempty (toSet ref) mempty SNothing (Coin 0) mempty
+  where
+    toSet Nothing = mempty
+    toSet (Just a) = Set.singleton a
+
 mkPaymentTx ::
   ConwayUTxOIndex ->
   ConwayUTxOIndex ->
   Integer ->
   Integer ->
   ConwayLedgerState ->
   Either ForgingError (AlonzoTx StandardConway)
-mkPaymentTx inputIndex outputIndex amount fees state' = do
+mkPaymentTx inputIndex outputIndex amount = mkPaymentTx' inputIndex outputIndices
+  where
+    outputIndices = [(outputIndex, valueFromList amount [])]
+
+mkPaymentTx' ::
+  ConwayUTxOIndex ->
+  [(ConwayUTxOIndex, MaryValue StandardCrypto)] ->
+  Integer ->
+  ConwayLedgerState ->
+  Either ForgingError (AlonzoTx StandardConway)
+mkPaymentTx' inputIndex outputIndices fees state' = do
   (inputPair, _) <- resolveUTxOIndex inputIndex state'
-  addr <- resolveAddress outputIndex state'
+  outputs <- mapM mkOutputs outputIndices
 
-  let input = Set.singleton $ fst inputPair
-      output = BabbageTxOut addr (valueFromList (fromIntegral amount) []) NoDatum SNothing
+  let inputs = Set.singleton (fst inputPair)
+      outValue = sum $ map (unCoin . coin . snd) outputIndices
       BabbageTxOut addr' (MaryValue inputValue _) _ _ = snd inputPair
-      change = BabbageTxOut addr' (valueFromList (fromIntegral $ fromInteger inputValue - amount - fees) []) NoDatum SNothing
+      change =
+        BabbageTxOut
+          addr'
+          (valueFromList (fromIntegral $ fromIntegral inputValue - outValue - fees) [])
+          NoDatum
+          SNothing
 
   pure $
     mkSimpleTx True $
       consPaymentTxBody
-        input
+        inputs
         mempty
         mempty
-        (StrictSeq.fromList [output, change])
+        (StrictSeq.fromList $ outputs <> [change])
         SNothing
         (Coin fees)
         mempty
+  where
+    mkOutputs (outIx, val) = do
+      addr <- resolveAddress outIx state'
+      pure (BabbageTxOut addr val NoDatum SNothing)
+
+mkDCertTx ::
+  [ConwayTxCert StandardConway] ->
+  Withdrawals StandardCrypto ->
+  Maybe (TxIn StandardCrypto) ->
+  Either ForgingError (AlonzoTx StandardConway)
+mkDCertTx certs wdrl ref = Right (mkSimpleTx True $ consCertTxBody ref certs wdrl)
+
+mkDCertTxPools :: ConwayLedgerState -> Either ForgingError (AlonzoTx StandardConway)
+mkDCertTxPools state' =
+  Right $
+    mkSimpleTx True $
+      consCertTxBody Nothing (allPoolStakeCert' state') (Withdrawals mempty)
 
 mkSimpleTx :: Bool -> ConwayTxBody StandardConway -> AlonzoTx StandardConway
 mkSimpleTx isValid' txBody =
@@ -124,6 +184,81 @@ mkSimpleTx isValid' txBody =
     , auxiliaryData = maybeToStrictMaybe Nothing
     }
 
+mkSimpleDCertTx ::
+  [(StakeIndex, StakeCredential StandardCrypto -> ConwayTxCert StandardConway)] ->
+  ConwayLedgerState ->
+  Either ForgingError (AlonzoTx StandardConway)
+mkSimpleDCertTx consDCert st = do
+  dcerts <- forM consDCert $ \(stakeIndex, mkDCert) -> do
+    cred <- resolveStakeCreds stakeIndex st
+    pure (mkDCert cred)
+  mkDCertTx dcerts (Withdrawals mempty) Nothing
+
+mkDepositTxPools ::
+  ConwayUTxOIndex ->
+  Integer ->
+  ConwayLedgerState ->
+  Either ForgingError (AlonzoTx StandardConway)
+mkDepositTxPools inputIndex deposit state' = do
+  (inputPair, _) <- resolveUTxOIndex inputIndex state'
+
+  let input = Set.singleton (fst inputPair)
+      BabbageTxOut addr' (MaryValue inputValue _) _ _ = snd inputPair
+      change =
+        BabbageTxOut
+          addr'
+          (valueFromList (fromIntegral $ fromIntegral inputValue - deposit) [])
+          NoDatum
+          SNothing
+
+  pure $
+    mkSimpleTx True $
+      consTxBody
+        input
+        mempty
+        mempty
+        (StrictSeq.fromList [change])
+        SNothing
+        (Coin 0)
+        mempty
+        (allPoolStakeCert' state')
+        (Withdrawals mempty)
+
+mkDummyRegisterTx :: Int -> Int -> Either ForgingError (AlonzoTx StandardConway)
+mkDummyRegisterTx n m = mkDCertTx consDelegCert (Withdrawals mempty) Nothing
+  where
+    consDelegCert =
+      mkRegTxCert SNothing
+        . KeyHashObj
+        . KeyHash
+        . mkDummyHash (Proxy @(ADDRHASH StandardCrypto))
+        . fromIntegral
+        <$> [n, m]
+
+mkRegTxCert ::
+  StrictMaybe Coin ->
+  StakeCredential StandardCrypto ->
+  ConwayTxCert StandardConway
+mkRegTxCert coin' = mkTxDelegCert $ \cred -> ConwayRegCert cred coin'
+
+mkUnRegTxCert ::
+  StrictMaybe Coin ->
+  StakeCredential StandardCrypto ->
+  ConwayTxCert StandardConway
+mkUnRegTxCert coin' = mkTxDelegCert $ \cred -> ConwayUnRegCert cred coin'
+
+mkDelegTxCert ::
+  Delegatee StandardCrypto ->
+  StakeCredential StandardCrypto ->
+  ConwayTxCert StandardConway
+mkDelegTxCert delegatee = mkTxDelegCert $ \cred -> ConwayDelegCert cred delegatee
+
+mkTxDelegCert ::
+  (StakeCredential StandardCrypto -> ConwayDelegCert StandardCrypto) ->
+  StakeCredential StandardCrypto ->
+  ConwayTxCert StandardConway
+mkTxDelegCert f = ConwayTxCertDeleg . f
+
 mkFullTx ::
   Int ->
   Integer ->
@@ -279,3 +414,15 @@ mkUTxOConway ::
   AlonzoTx StandardConway ->
   [(TxIn StandardCrypto, BabbageTxOut StandardConway)]
 mkUTxOConway = mkUTxOAlonzo
+
+allPoolStakeCert' :: ConwayLedgerState -> [ConwayTxCert StandardConway]
+allPoolStakeCert' st = map (mkRegTxCert SNothing) (getCreds st)
+  where
+    getCreds = nub . concatMap getPoolStakeCreds . Map.elems . stakePoolParams
+    stakePoolParams =
+      LedgerState.psStakePoolParams
+        . LedgerState.certPState
+        . LedgerState.lsCertState
+        . LedgerState.esLState
+        . LedgerState.nesEs
+        . Consensus.shelleyLedgerState