From 024fd281f67a4877ec302355cc3ae704e8a2376b Mon Sep 17 00:00:00 2001 From: Cmdv Date: Tue, 21 Jan 2025 15:36:33 +0000 Subject: [PATCH] add back tests --- cardano-chain-gen/cardano-chain-gen.cabal | 12 +- .../src/Cardano/Mock/Forging/Tx/Babbage.hs | 2 +- .../src/Cardano/Mock/Forging/Tx/Conway.hs | 146 ++--- .../Mock/Forging/Tx/Conway/Scenarios.hs | 4 +- cardano-chain-gen/src/Cardano/Mock/Query.hs | 34 +- cardano-chain-gen/test/Main.hs | 6 +- .../test/Test/Cardano/Db/Mock/Unit/Alonzo.hs | 43 ++ .../Cardano/Db/Mock/Unit/Alonzo/Plutus.hs | 467 ---------------- .../Db/Mock/Unit/Alonzo/PoolAndSmash.hs | 273 ---------- .../Cardano/Db/Mock/Unit/Alonzo/Reward.hs | 486 ----------------- .../Test/Cardano/Db/Mock/Unit/Alonzo/Stake.hs | 340 ------------ .../test/Test/Cardano/Db/Mock/Unit/Babbage.hs | 55 ++ .../Unit/Babbage/CommandLineArg/ConfigFile.hs | 20 - .../Babbage/CommandLineArg/EpochDisabled.hs | 50 -- .../Config/MigrateConsumedPruneTxOut.hs | 413 -------------- .../Db/Mock/Unit/Babbage/Config/Parse.hs | 41 -- .../Mock/Unit/Babbage/InlineAndReference.hs | 434 --------------- .../Cardano/Db/Mock/Unit/Babbage/Other.hs | 392 -------------- .../Cardano/Db/Mock/Unit/Babbage/Plutus.hs | 508 ------------------ .../Cardano/Db/Mock/Unit/Babbage/Rollback.hs | 257 --------- .../Cardano/Db/Mock/Unit/Babbage/Stake.hs | 340 ------------ 21 files changed, 207 insertions(+), 4116 deletions(-) create mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Plutus.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/PoolAndSmash.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Reward.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Stake.hs create mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/ConfigFile.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/EpochDisabled.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/MigrateConsumedPruneTxOut.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/Parse.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/InlineAndReference.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Other.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Plutus.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Rollback.hs delete mode 100644 cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Stake.hs diff --git a/cardano-chain-gen/cardano-chain-gen.cabal b/cardano-chain-gen/cardano-chain-gen.cabal index 1b3997b34..36a56c253 100644 --- a/cardano-chain-gen/cardano-chain-gen.cabal +++ b/cardano-chain-gen/cardano-chain-gen.cabal @@ -130,12 +130,21 @@ test-suite cardano-chain-gen other-modules: Test.Cardano.Db.Mock.Config Test.Cardano.Db.Mock.Examples Test.Cardano.Db.Mock.Property.Property + Test.Cardano.Db.Mock.UnifiedApi + Test.Cardano.Db.Mock.Unit.Alonzo + Test.Cardano.Db.Mock.Unit.Alonzo.Config + Test.Cardano.Db.Mock.Unit.Alonzo.Simple + Test.Cardano.Db.Mock.Unit.Alonzo.Tx + Test.Cardano.Db.Mock.Unit.Babbage + Test.Cardano.Db.Mock.Unit.Babbage.Reward + Test.Cardano.Db.Mock.Unit.Babbage.Simple + Test.Cardano.Db.Mock.Unit.Babbage.Tx Test.Cardano.Db.Mock.Unit.Conway Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.ConfigFile Test.Cardano.Db.Mock.Unit.Conway.CommandLineArg.EpochDisabled Test.Cardano.Db.Mock.Unit.Conway.Config.JsonbInSchema - Test.Cardano.Db.Mock.Unit.Conway.Config.Parse Test.Cardano.Db.Mock.Unit.Conway.Config.MigrateConsumedPruneTxOut + Test.Cardano.Db.Mock.Unit.Conway.Config.Parse Test.Cardano.Db.Mock.Unit.Conway.Governance Test.Cardano.Db.Mock.Unit.Conway.InlineAndReference Test.Cardano.Db.Mock.Unit.Conway.Other @@ -145,7 +154,6 @@ test-suite cardano-chain-gen 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 build-depends: aeson diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs index f3dcd1156..af2a8d068 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs @@ -462,7 +462,7 @@ mkUTxOBabbage :: AlonzoTx StandardBabbage -> [(TxIn StandardCrypto, BabbageTxOut mkUTxOBabbage = mkUTxOAlonzo mkUTxOCollBabbage :: - (BabbageEraTxBody era) => + BabbageEraTxBody era => AlonzoTx era -> [(TxIn (EraCrypto era), TxOut era)] mkUTxOCollBabbage tx = Map.toList $ unUTxO $ collOuts $ getField @"body" tx diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs index 92595988c..6df2adf87 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs @@ -227,17 +227,17 @@ mkPaymentTx' inputIndex outputIndices fees donation state' = do NoDatum SNothing - pure $ - mkSimpleTx True $ - consPaymentTxBody - inputs - mempty - mempty - (StrictSeq.fromList $ outputs <> [change]) - SNothing - (Coin fees) - mempty - (Coin donation) + pure + $ mkSimpleTx True + $ consPaymentTxBody + inputs + mempty + mempty + (StrictSeq.fromList $ outputs <> [change]) + SNothing + (Coin fees) + mempty + (Coin donation) where mkOutputs (outIx, val) = do addr <- resolveAddress outIx state' @@ -268,17 +268,17 @@ mkLockByScriptTx inputIndex txOutTypes amount fees state' = do NoDatum SNothing - pure $ - mkSimpleTx True $ - consPaymentTxBody - inputs - mempty - mempty - (StrictSeq.fromList $ outputs <> [change]) - SNothing - (Coin fees) - mempty - (Coin 0) + pure + $ mkSimpleTx True + $ consPaymentTxBody + inputs + mempty + mempty + (StrictSeq.fromList $ outputs <> [change]) + SNothing + (Coin fees) + mempty + (Coin 0) mkUnlockScriptTx :: [ConwayUTxOIndex] -> @@ -348,9 +348,9 @@ mkDCertPoolTx consDCert state' = do mkDCertTxPools :: ConwayLedgerState -> Either ForgingError (AlonzoTx StandardConway) mkDCertTxPools state' = - Right $ - mkSimpleTx True $ - consCertTxBody Nothing (allPoolStakeCert' state') (Withdrawals mempty) + Right + $ mkSimpleTx True + $ consCertTxBody Nothing (allPoolStakeCert' state') (Withdrawals mempty) mkSimpleTx :: Bool -> ConwayTxBody StandardConway -> AlonzoTx StandardConway mkSimpleTx isValid' txBody = @@ -394,9 +394,9 @@ mkScriptDCertTx consCert isValid' state' = do cred <- resolveStakeCreds stakeIndex state' pure $ mkDCert cred - pure $ - mkScriptTx isValid' (mapMaybe prepareRedeemer . zip [0 ..] $ consCert) $ - consCertTxBody Nothing dcerts (Withdrawals mempty) + pure + $ mkScriptTx isValid' (mapMaybe prepareRedeemer . zip [0 ..] $ consCert) + $ consCertTxBody Nothing dcerts (Withdrawals mempty) where prepareRedeemer (n, (StakeIndexScript bl, shouldAddRedeemer, _)) | not shouldAddRedeemer = Nothing @@ -428,24 +428,24 @@ mkMultiAssetsScriptTx inputIx colInputIx outputIx refInput minted succeeds fees refInputs' = Set.fromList $ map (fst . fst) refs colInputs' = Set.singleton $ fst colInput - pure $ - mkScriptTx succeeds (mkScriptInps (map fst inputs) ++ mkScriptMint' minted) $ - consTxBody - inputs' - colInputs' - refInputs' - (StrictSeq.fromList outputs) - SNothing - (Coin fees) - mempty - mempty -- TODO[sgillespie]: minted? - (Withdrawals mempty) - (Coin 0) + pure + $ mkScriptTx succeeds (mkScriptInps (map fst inputs) ++ mkScriptMint' minted) + $ consTxBody + inputs' + colInputs' + refInputs' + (StrictSeq.fromList outputs) + SNothing + (Coin fees) + mempty + mempty -- TODO[sgillespie]: minted? + (Withdrawals mempty) + (Coin 0) where mkOuts (outIx, val) = do addr <- resolveAddress outIx state' - pure $ - BabbageTxOut + pure + $ BabbageTxOut addr val (DatumHash $ hashData @StandardConway plutusDataList) @@ -468,19 +468,19 @@ mkDepositTxPools inputIndex deposit state' = do NoDatum SNothing - pure $ - mkSimpleTx True $ - consTxBody - input - mempty - mempty - (StrictSeq.fromList [change]) - SNothing - (Coin 0) - mempty - (allPoolStakeCert' state') - (Withdrawals mempty) - (Coin 0) + pure + $ mkSimpleTx True + $ consTxBody + input + mempty + mempty + (StrictSeq.fromList [change]) + SNothing + (Coin 0) + mempty + (allPoolStakeCert' state') + (Withdrawals mempty) + (Coin 0) mkRegisterDRepTx :: Credential 'DRepRole StandardCrypto -> @@ -663,8 +663,8 @@ mkFullTx n m state' = do refInputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` state') refInputs collateralInput <- Set.singleton . fst . fst <$> resolveUTxOIndex collateralInputs state' - pure $ - AlonzoTx + pure + $ AlonzoTx { body = txBody (mkInputs inputPairs) @@ -748,8 +748,8 @@ mkFullTx n m state' = do , ConwayTxCertPool $ Core.RegPool poolParams1 , ConwayTxCertPool $ Core.RetirePool (Prelude.head unregisteredPools) (EpochNo 0) , ConwayTxCertDeleg $ ConwayUnRegCert (unregisteredStakeCredentials !! 2) SNothing - , ConwayTxCertDeleg $ - ConwayDelegCert + , ConwayTxCertDeleg + $ ConwayDelegCert (unregisteredStakeCredentials !! 1) (DelegStake $ unregisteredPools !! 2) ] @@ -766,8 +766,8 @@ mkFullTx n m state' = do -- Withdrawals withdrawals = - Withdrawals $ - Map.fromList + Withdrawals + $ Map.fromList [ (RewardAccount Testnet (unregisteredStakeCredentials !! 1), Coin 100) , (RewardAccount Testnet (unregisteredStakeCredentials !! 1), Coin 100) ] @@ -899,17 +899,17 @@ mkUnlockScriptTx' inputIndex colInputIndex outputIndex refInput colOut succeeds NoDatum SNothing - pure $ - mkScriptTx succeeds (mkScriptInps inputPairs) $ - consPaymentTxBody - inputs - colInputs - refInputs - (StrictSeq.singleton output) - (maybeToStrictMaybe colOut) - (Coin fees) - mempty - (Coin 0) + pure + $ mkScriptTx succeeds (mkScriptInps inputPairs) + $ consPaymentTxBody + inputs + colInputs + refInputs + (StrictSeq.singleton output) + (maybeToStrictMaybe colOut) + (Coin fees) + mempty + (Coin 0) allPoolStakeCert' :: ConwayLedgerState -> [ConwayTxCert StandardConway] allPoolStakeCert' st = map (mkRegTxCert SNothing) (getCreds st) diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs index f3a3c4fba..9db1691d6 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs @@ -97,8 +97,8 @@ forgeBlocksChunked interpreter vs f = forM (chunksOf 500 vs) $ \blockCreds -> do registerDRepsAndDelegateVotes :: Interpreter -> IO CardanoBlock registerDRepsAndDelegateVotes interpreter = do blockTxs <- - withConwayLedgerState interpreter $ - registerDRepAndDelegateVotes' + withConwayLedgerState interpreter + $ registerDRepAndDelegateVotes' (Prelude.head unregisteredDRepIds) (StakeIndex 4) diff --git a/cardano-chain-gen/src/Cardano/Mock/Query.hs b/cardano-chain-gen/src/Cardano/Mock/Query.hs index a9ae27cde..4a6bd2727 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Query.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Query.hs @@ -98,8 +98,8 @@ queryDRepDistrAmount drepHash epochNo = do (distr :& hash) <- from $ table @Db.DrepDistr - `innerJoin` table @Db.DrepHash - `on` (\(distr :& hash) -> (hash ^. Db.DrepHashId) ==. (distr ^. Db.DrepDistrHashId)) + `innerJoin` table @Db.DrepHash + `on` (\(distr :& hash) -> (hash ^. Db.DrepHashId) ==. (distr ^. Db.DrepDistrHashId)) where_ $ hash ^. Db.DrepHashRaw ==. just (val drepHash) where_ $ distr ^. Db.DrepDistrEpochNo ==. val epochNo @@ -140,14 +140,14 @@ queryConstitutionAnchor epochNo = do (_ :& anchor :& epochState) <- from $ table @Db.Constitution - `innerJoin` table @Db.VotingAnchor - `on` ( \(constit :& anchor) -> - (constit ^. Db.ConstitutionVotingAnchorId) ==. (anchor ^. Db.VotingAnchorId) - ) - `innerJoin` table @Db.EpochState - `on` ( \(constit :& _ :& epoch) -> - just (constit ^. Db.ConstitutionId) ==. (epoch ^. Db.EpochStateConstitutionId) - ) + `innerJoin` table @Db.VotingAnchor + `on` ( \(constit :& anchor) -> + (constit ^. Db.ConstitutionVotingAnchorId) ==. (anchor ^. Db.VotingAnchorId) + ) + `innerJoin` table @Db.EpochState + `on` ( \(constit :& _ :& epoch) -> + just (constit ^. Db.ConstitutionId) ==. (epoch ^. Db.EpochStateConstitutionId) + ) where_ (epochState ^. Db.EpochStateEpochNo ==. val epochNo) @@ -193,11 +193,13 @@ queryVoteCounts txHash idx = do (vote :& tx) <- from $ table @Db.VotingProcedure - `innerJoin` table @Db.Tx - `on` (\(vote :& tx) -> vote ^. Db.VotingProcedureTxId ==. tx ^. Db.TxId) - where_ $ - vote ^. Db.VotingProcedureVote ==. val v - &&. tx ^. Db.TxHash ==. val txHash - &&. vote ^. Db.VotingProcedureIndex ==. val idx + `innerJoin` table @Db.Tx + `on` (\(vote :& tx) -> vote ^. Db.VotingProcedureTxId ==. tx ^. Db.TxId) + where_ + $ vote + ^. Db.VotingProcedureVote + ==. val v + &&. tx ^. Db.TxHash ==. val txHash + &&. vote ^. Db.VotingProcedureIndex ==. val idx pure countRows pure (maybe 0 unValue res) diff --git a/cardano-chain-gen/test/Main.hs b/cardano-chain-gen/test/Main.hs index 034615d02..5d63e1ae0 100644 --- a/cardano-chain-gen/test/Main.hs +++ b/cardano-chain-gen/test/Main.hs @@ -7,6 +7,8 @@ import System.Directory (getCurrentDirectory) import System.Environment (lookupEnv, setEnv) import System.FilePath (()) import qualified Test.Cardano.Db.Mock.Property.Property as Property +import qualified Test.Cardano.Db.Mock.Unit.Alonzo as Alonzo +import qualified Test.Cardano.Db.Mock.Unit.Babbage as Babbage import qualified Test.Cardano.Db.Mock.Unit.Conway as Conway import Test.Tasty import Test.Tasty.QuickCheck (testProperty) @@ -27,7 +29,9 @@ tests iom = do pure $ testGroup "cardano-chain-gen" - [ Conway.unitTests iom knownMigrationsPlain + [ Babbage.unitTests iom knownMigrationsPlain + , Alonzo.unitTests iom knownMigrationsPlain + , Conway.unitTests iom knownMigrationsPlain , testProperty "QSM" $ Property.prop_empty_blocks iom knownMigrationsPlain ] where diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs new file mode 100644 index 000000000..21413ffe6 --- /dev/null +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Cardano.Db.Mock.Unit.Alonzo ( + unitTests, +) where + +import Cardano.Mock.ChainSync.Server (IOManager) +import Data.Text (Text) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase) + +import qualified Test.Cardano.Db.Mock.Unit.Alonzo.Config as AlzConfig +import qualified Test.Cardano.Db.Mock.Unit.Alonzo.Simple as AlzSimple +import qualified Test.Cardano.Db.Mock.Unit.Alonzo.Tx as AlzTx + +{- HLINT ignore "Reduce duplication" -} + +unitTests :: IOManager -> [(Text, Text)] -> TestTree +unitTests iom knownMigrations = + testGroup + "Alonzo unit tests" + [ testGroup + "config" + [ testCase "default insert config" AlzConfig.defaultInsertConfig + , testCase "insert config" AlzConfig.insertConfig + ] + , testGroup + "simple" + [ test "simple forge blocks" AlzSimple.forgeBlocks + , test "sync one block" AlzSimple.addSimple + , test "restart db-sync" AlzSimple.restartDBSync + , test "sync small chain" AlzSimple.addSimpleChain + ] + , testGroup + "blocks with txs" + [ test "simple tx" AlzTx.addSimpleTx + , test "consume utxo same block" AlzTx.consumeSameBlock + ] + ] + where + test :: String -> (IOManager -> [(Text, Text)] -> Assertion) -> TestTree + test str action = testCase str (action iom knownMigrations) diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Plutus.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Plutus.hs deleted file mode 100644 index c066fc90c..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Plutus.hs +++ /dev/null @@ -1,467 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeApplications #-} - -#if __GLASGOW_HASKELL__ >= 908 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif - -module Test.Cardano.Db.Mock.Unit.Alonzo.Plutus ( - -- plutus spend scripts - simpleScript, - unlockScriptSameBlock, - failedScript, - failedScriptSameBlock, - multipleScripts, - multipleScriptsSameBlock, - multipleScriptsFailed, - multipleScriptsFailedSameBlock, - -- plutus cert scripts - registrationScriptTx, - deregistrationScriptTx, - deregistrationsScriptTxs, - deregistrationsScriptTx, - deregistrationsScriptTx', - deregistrationsScriptTx'', - -- plutus multiAsset scripts - mintMultiAsset, - mintMultiAssets, - swapMultiAssets, -) where - -import qualified Cardano.Crypto.Hash as Crypto -import Cardano.Db (TxOutTableType (..)) -import qualified Cardano.Db as DB -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V -import Cardano.DbSync.Era.Shelley.Generic.Util (renderAddress) -import Cardano.Ledger.Coin -import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..)) -import Cardano.Ledger.Plutus.Data (hashData) -import Cardano.Ledger.SafeHash (extractHash) -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager) -import Cardano.Mock.Forging.Interpreter (withAlonzoLedgerState) -import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo -import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples ( - alwaysMintScriptAddr, - alwaysMintScriptHash, - alwaysSucceedsScriptAddr, - alwaysSucceedsScriptHash, - assetNames, - plutusDataList, - ) -import Cardano.Mock.Forging.Types ( - MockBlock (..), - NodeId (..), - StakeIndex (..), - TxEra (..), - UTxOIndex (..), - ) -import Control.Monad (void) -import qualified Data.Map as Map -import Data.Text (Text) -import Ouroboros.Consensus.Cardano.Block (StandardAlonzo) -import Test.Cardano.Db.Mock.Config (alonzoConfigDir, startDBSync, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillUntilNextEpoch, - forgeNextAndSubmit, - registerAllStakeCreds, - withAlonzoFindLeaderAndSubmit, - withAlonzoFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate ( - assertAlonzoCounts, - assertBlockNoBackoff, - assertEqQuery, - assertScriptCert, - ) -import Test.Tasty.HUnit (Assertion) - ----------------------------------------------------------------------------------------------------------- --- Plutus Spend Scripts ----------------------------------------------------------------------------------------------------------- -simpleScript :: IOManager -> [(Text, Text)] -> Assertion -simpleScript = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - a <- fillUntilNextEpoch interpreter mockServer - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) - assertEqQuery dbSync (fmap getOutFields <$> DB.queryScriptOutputs TxOutCore) [expectedFields] "Unexpected script outputs" - where - testLabel = "simpleScript-alonzo" - getOutFields txOutW = case txOutW of - DB.CTxOutW txOut -> - ( C.txOutAddress txOut - , C.txOutAddressHasScript txOut - , C.txOutValue txOut - , C.txOutDataHash txOut - ) - DB.VTxOutW txout mAddress -> case mAddress of - Just address -> - ( V.addressAddress address - , V.addressHasScript address - , V.txOutValue txout - , V.txOutDataHash txout - ) - Nothing -> error "AlonzoSimpleScript: expected an address" - expectedFields = - ( renderAddress alwaysSucceedsScriptAddr - , True - , DB.DbLovelace 20000 - , Just $ Crypto.hashToBytes (extractHash $ hashData @StandardAlonzo plutusDataList) - ) - -_unlockScript :: IOManager -> [(Text, Text)] -> Assertion -_unlockScript = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- We don't use withAlonzoFindLeaderAndSubmitTx here, because we want access to the tx. - tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) - - let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 - - assertBlockNoBackoff dbSync 3 - assertAlonzoCounts dbSync (1, 1, 1, 1, 1, 1, 0, 0) - where - testLabel = "unlockScript-alonzo" - -unlockScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion -unlockScriptSameBlock = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [True] 20000 20000 st - let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) - tx1 <- Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (1, 1, 1, 1, 1, 1, 0, 0) - where - testLabel = "unlockScriptSameBlock-alonzo" - -failedScript :: IOManager -> [(Text, Text)] -> Assertion -failedScript = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [False] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) - - let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) - where - testLabel = "failedScript-alonzo" - -failedScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion -failedScriptSameBlock = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [False] 20000 20000 st - let utxo0 = head (Alonzo.mkUTxOAlonzo tx0) - tx1 <- Alonzo.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) - where - testLabel = "failedScriptSameBlock-alonzo" - -multipleScripts :: IOManager -> [(Text, Text)] -> Assertion -multipleScripts = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 - let utxo = Alonzo.mkUTxOAlonzo tx0 - pair1 = head utxo - pair2 = utxo !! 2 - tx1 <- - withAlonzoLedgerState interpreter $ - Alonzo.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 - - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx1] (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) - where - testLabel = "multipleScripts-alonzo" - -multipleScriptsSameBlock :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsSameBlock = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 st - let utxo = Alonzo.mkUTxOAlonzo tx0 - pair1 = head utxo - pair2 = utxo !! 2 - tx1 <- Alonzo.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) - where - testLabel = "multipleScriptsSameBlock-alonzo" - -multipleScriptsFailed :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsFailed = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withAlonzoLedgerState interpreter $ Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx0] (NodeId 1) - - let utxos = Alonzo.mkUTxOAlonzo tx0 - tx1 <- - withAlonzoLedgerState interpreter $ - Alonzo.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxAlonzo tx1] (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 3, 0, 1, 1) - where - testLabel = "multipleScriptsFailed-alonzo" - -multipleScriptsFailedSameBlock :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsFailedSameBlock = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkLockByScriptTx (UTxOIndex 0) [True, False, True] 20000 20000 st - - let utxos = tail $ Alonzo.mkUTxOAlonzo tx0 - tx1 <- Alonzo.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (0, 0, 0, 0, 3, 0, 1, 1) - where - testLabel = "multipleScriptsFailedSameBlock-alonzo" - ----------------------------------------------------------------------------------------------------------- --- Plutus Cert Scripts ----------------------------------------------------------------------------------------------------------- - -registrationScriptTx :: IOManager -> [(Text, Text)] -> Assertion -registrationScriptTx = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (0, 0, 0, 1) - where - testLabel = "registrationScriptTx-alonzo" - -deregistrationScriptTx :: IOManager -> [(Text, Text)] -> Assertion -deregistrationScriptTx = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- Alonzo.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (1, 0, 0, 1) - where - testLabel = "deregistrationScriptTx-alonzo" - -deregistrationsScriptTxs :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTxs = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- Alonzo.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st - tx2 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx3 <- Alonzo.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st - pure [tx0, tx1, Alonzo.addValidityInterval 1000 tx2, Alonzo.addValidityInterval 2000 tx3] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (2, 0, 0, 1) - assertAlonzoCounts dbSync (1, 2, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTxs-alonzo" - -deregistrationsScriptTx :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTx = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- - Alonzo.mkScriptDCertTx - [ (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - True - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (2, 0, 0, 1) - assertAlonzoCounts dbSync (1, 2, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTx-alonzo" - --- Like previous but missing a redeemer. This is a known ledger issue -deregistrationsScriptTx' :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTx' = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- - Alonzo.mkScriptDCertTx - [ (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - True - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - -- TODO: This is a bug! The first field should be 2. However the deregistrations - -- are missing the redeemers - assertScriptCert dbSync (0, 0, 0, 1) - assertAlonzoCounts dbSync (1, 1, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTx'-alonzo" - --- Like previous but missing the other redeemer. This is a known ledger issue -deregistrationsScriptTx'' :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTx'' = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- - Alonzo.mkScriptDCertTx - [ (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - True - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (2, 0, 0, 1) - assertAlonzoCounts dbSync (1, 1, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTx''-alonzo" - ----------------------------------------------------------------------------------------------------------- --- Plutus MultiAsset Scripts ----------------------------------------------------------------------------------------------------------- - -mintMultiAsset :: IOManager -> [(Text, Text)] -> Assertion -mintMultiAsset = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \st -> do - let val0 = MultiAsset $ Map.singleton (PolicyID alwaysMintScriptHash) (Map.singleton (head assetNames) 1) - Alonzo.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] val0 True 100 st - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (1, 1, 1, 1, 0, 0, 0, 0) - where - testLabel = "mintMultiAsset-alonzo" - -mintMultiAssets :: IOManager -> [(Text, Text)] -> Assertion -mintMultiAssets = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - let assets0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] - let policy0 = PolicyID alwaysMintScriptHash - let policy1 = PolicyID alwaysSucceedsScriptHash - let val1 = MultiAsset $ Map.fromList [(policy0, assets0), (policy1, assets0)] - tx0 <- Alonzo.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] val1 True 100 st - tx1 <- Alonzo.mkMAssetsScriptTx [UTxOIndex 2] (UTxOIndex 3) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] val1 True 200 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (2, 4, 1, 2, 0, 0, 0, 0) - where - testLabel = "mintMultiAssets-alonzo" - -swapMultiAssets :: IOManager -> [(Text, Text)] -> Assertion -swapMultiAssets = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - let assetsMinted0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] - let policy0 = PolicyID alwaysMintScriptHash - let policy1 = PolicyID alwaysSucceedsScriptHash - let mintValue0 = MultiAsset $ Map.fromList [(policy0, assetsMinted0), (policy1, assetsMinted0)] - let assets0 = Map.fromList [(head assetNames, 5), (assetNames !! 1, 2)] - let outValue0 = MaryValue (Coin 20) $ MultiAsset $ Map.fromList [(policy0, assets0), (policy1, assets0)] - - tx0 <- - Alonzo.mkMAssetsScriptTx - [UTxOIndex 0] - (UTxOIndex 1) - [(UTxOAddress alwaysSucceedsScriptAddr, outValue0), (UTxOAddress alwaysMintScriptAddr, outValue0)] - mintValue0 - True - 100 - st - - let utxos = Alonzo.mkUTxOAlonzo tx0 - tx1 <- - Alonzo.mkMAssetsScriptTx - [UTxOPair (head utxos), UTxOPair (utxos !! 1), UTxOIndex 2] - (UTxOIndex 3) - [ (UTxOAddress alwaysSucceedsScriptAddr, outValue0) - , (UTxOAddress alwaysMintScriptAddr, outValue0) - , (UTxOAddressNew 0, outValue0) - , (UTxOAddressNew 0, outValue0) - ] - mintValue0 - True - 200 - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (2, 6, 1, 2, 4, 2, 0, 0) - where - testLabel = "swapMultiAssets-alonzo" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/PoolAndSmash.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/PoolAndSmash.hs deleted file mode 100644 index 42cc82004..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/PoolAndSmash.hs +++ /dev/null @@ -1,273 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} - -module Test.Cardano.Db.Mock.Unit.Alonzo.PoolAndSmash ( - poolReg, - nonexistantPoolQuery, - poolDeReg, - poolDeRegMany, - poolDelist, -) where - -import Cardano.DbSync.Era.Shelley.Generic.Util (unKeyHashRaw) -import Cardano.Ledger.BaseTypes (EpochNo) -import Cardano.Ledger.Credential (StakeCredential) -import Cardano.Ledger.Keys (KeyHash, KeyRole (StakePool)) -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager) -import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo -import Cardano.Mock.Forging.Tx.Generic (resolvePool) -import Cardano.Mock.Forging.Types (PoolIndex (..), StakeIndex (..)) -import Cardano.SMASH.Server.PoolDataLayer (PoolDataLayer (..), dbToServantPoolId) -import Cardano.SMASH.Server.Types (DBFail (RecordDoesNotExist)) -import Cardano.Slotting.Slot (EpochNo (..)) -import Control.Monad (void) -import Data.Text (Text) -import Ouroboros.Consensus.Cardano.Block (StandardAlonzo, StandardCrypto) -import Test.Cardano.Db.Mock.Config ( - alonzoConfigDir, - getPoolLayer, - startDBSync, - withFullConfig, - withFullConfigAndDropDB, - ) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillUntilNextEpoch, - forgeNextFindLeaderAndSubmit, - getAlonzoLedgerState, - withAlonzoFindLeaderAndSubmit, - withAlonzoFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate ( - addPoolCounters, - assertBlockNoBackoff, - assertPoolCounters, - assertPoolLayerCounters, - poolCountersQuery, - runQuery, - ) -import Test.Tasty.HUnit (Assertion, assertEqual) - -poolReg :: IOManager -> [(Text, Text)] -> Assertion -poolReg = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - ] - - assertBlockNoBackoff dbSync 2 - assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 0, 1) initCounter) - st <- getAlonzoLedgerState interpreter - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - where - testLabel = "poolReg-alonzo" - --- Issue https://github.com/IntersectMBO/cardano-db-sync/issues/997 -nonexistantPoolQuery :: IOManager -> [(Text, Text)] -> Assertion -nonexistantPoolQuery = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - - st <- getAlonzoLedgerState interpreter - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Left RecordDoesNotExist, False, False))] st - where - testLabel = "nonexistantPoolQuery-alonzo" - -poolDeReg :: IOManager -> [(Text, Text)] -> Assertion -poolDeReg = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - , ([], PoolIndexNew 0, \_ poolId -> ShelleyTxCertPool $ RetirePool poolId (EpochNo 1)) - ] - - assertBlockNoBackoff dbSync 2 - assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 1, 1) initCounter) - - st <- getAlonzoLedgerState interpreter - -- Not retired yet, because epoch has not changed - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - - -- change epoch - a <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) - -- these counters are the same - assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 1, 1) initCounter) - - -- the pool is now retired, since the epoch changed. - assertPoolLayerCounters dbSync (1, 0) [(PoolIndexNew 0, (Right True, False, False))] st - where - testLabel = "poolDeReg-alonzo" - -poolDeRegMany :: IOManager -> [(Text, Text)] -> Assertion -poolDeRegMany = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDCertPoolTx - [ -- register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - , -- de register - ([], PoolIndexNew 0, mkPoolDereg (EpochNo 4)) - , -- register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - , -- register with different owner and reward address - - ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 0] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - ] - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- - Alonzo.mkDCertPoolTx - [ -- register - - ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - ] - st - - tx1 <- - Alonzo.mkDCertPoolTx - [ -- deregister - ([] :: [StakeIndex], PoolIndexNew 0, mkPoolDereg (EpochNo 4)) - , -- register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - , -- deregister - ([] :: [StakeIndex], PoolIndexNew 0, mkPoolDereg (EpochNo 1)) - ] - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 3 - -- TODO fix PoolOwner and PoolRelay unique key - assertPoolCounters dbSync (addPoolCounters (1, 5, 5, 10, 3, 5) initCounter) - - st <- getAlonzoLedgerState interpreter - -- Not retired yet, because epoch has not changed - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - - -- change epoch - a <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync (fromIntegral $ length a + 3) - -- these counters are the same - assertPoolCounters dbSync (addPoolCounters (1, 5, 5, 10, 3, 5) initCounter) - - -- from all these certificates only the latest matters. So it will retire - -- on epoch 0 - assertPoolLayerCounters dbSync (1, 0) [(PoolIndexNew 0, (Right True, False, False))] st - where - testLabel = "poolDeRegMany-alonzo" - mkPoolDereg :: - EpochNo -> - [StakeCredential StandardCrypto] -> - KeyHash 'StakePool StandardCrypto -> - ShelleyTxCert StandardAlonzo - mkPoolDereg epochNo _creds keyHash = ShelleyTxCertPool $ RetirePool keyHash epochNo - -poolDelist :: IOManager -> [(Text, Text)] -> Assertion -poolDelist = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Alonzo.consPoolParamsTwoOwners - ) - ] - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 3 - st <- getAlonzoLedgerState interpreter - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - - let poolKeyHash = resolvePool (PoolIndexNew 0) st - let poolId = dbToServantPoolId $ unKeyHashRaw poolKeyHash - poolLayer <- getPoolLayer dbSync - void $ dlAddDelistedPool poolLayer poolId - - -- This is not async, so we don't need to do exponential backoff - -- delisted not retired - assertPoolLayerCounters dbSync (0, 1) [(PoolIndexNew 0, (Right False, True, True))] st - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDCertPoolTx - [([], PoolIndexNew 0, \_ poolHash -> ShelleyTxCertPool $ RetirePool poolHash (EpochNo 1))] - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 5 - -- delisted and pending retirement - assertPoolLayerCounters dbSync (0, 1) [(PoolIndexNew 0, (Right False, True, True))] st - - a <- fillUntilNextEpoch interpreter mockServer - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ 5 + length a + 1) - -- delisted and retired - assertPoolLayerCounters dbSync (1, 1) [(PoolIndexNew 0, (Right True, True, False))] st - where - testLabel = "poolDelist-alonzo" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Reward.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Reward.hs deleted file mode 100644 index 9f8067e04..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Reward.hs +++ /dev/null @@ -1,486 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Cardano.Db.Mock.Unit.Alonzo.Reward ( - simpleRewards, - rewardsDeregistration, - rewardsReregistration, - mirReward, - mirRewardRollback, - mirRewardDereg, - rollbackBoundary, - singleMIRCertMultiOut, -) where - -import Cardano.Ledger.Coin (Coin (Coin), DeltaCoin (DeltaCoin)) -import Cardano.Ledger.Keys (KeyHash (KeyHash)) -import Cardano.Ledger.Shelley.TxBody (Withdrawals (Withdrawals)) -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager, addBlock, rollback) -import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo -import Cardano.Mock.Forging.Tx.Alonzo.Scenarios (delegateAndSendBlocks) -import Cardano.Mock.Forging.Tx.Generic (resolvePool, resolveStakeCreds) -import Cardano.Mock.Forging.Types ( - PoolIndex (PoolIndex, PoolIndexId), - StakeIndex ( - StakeIndex, - StakeIndexNew, - StakeIndexPoolLeader, - StakeIndexPoolMember - ), - UTxOIndex (UTxOAddressNewWithStake, UTxOIndex), - ) -import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM (atomically)) -import Control.Monad (forM_, void) -import qualified Data.Map as Map -import Data.Text (Text) -import Ouroboros.Network.Block (blockPoint) -import Test.Cardano.Db.Mock.Config ( - alonzoConfigDir, - startDBSync, - stopDBSync, - withFullConfig, - withFullConfigAndDropDB, - ) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillEpochPercentage, - fillEpochs, - fillUntilNextEpoch, - forgeAndSubmitBlocks, - getAlonzoLedgerState, - registerAllStakeCreds, - skipUntilNextEpoch, - withAlonzoFindLeaderAndSubmit, - withAlonzoFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate (assertBlockNoBackoff, assertRewardCount, assertRewardCounts, assertRewardRestCount) -import Test.Tasty.HUnit (Assertion) - -simpleRewards :: IOManager -> [(Text, Text)] -> Assertion -simpleRewards = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- Pools are not registered yet, this takes 2 epochs. So fees of this tx - -- should not create any rewards. - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 2) (UTxOIndex 1) 10000 10000 - - a <- fillEpochs interpreter mockServer 3 - assertBlockNoBackoff dbSync (fromIntegral $ 2 + length a) - - -- The pool leaders take leader rewards with value 0 - assertRewardCount dbSync 3 - - st <- getAlonzoLedgerState interpreter - -- False indicates that we provide the full expected list of addresses with rewards. - assertRewardCounts - dbSync - st - False - (Just 3) - [ (StakeIndexPoolLeader (PoolIndex 0), (1, 0, 0, 0, 0)) - , (StakeIndexPoolLeader (PoolIndex 1), (1, 0, 0, 0, 0)) - , (StakeIndexPoolLeader (PoolIndex 2), (1, 0, 0, 0, 0)) - ] - - -- Now that pools are registered, we add a tx to fill the fees pot. - -- Rewards will be distributed. - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 2) (UTxOIndex 1) 10000 10000 - - b <- fillEpochs interpreter mockServer 2 - - assertBlockNoBackoff dbSync (fromIntegral $ 1 + length a + 2 + length b) - assertRewardCount dbSync 14 - assertRewardCounts - dbSync - st - True - (Just 5) - -- 2 pool leaders also delegate to pools. - [ (StakeIndexPoolLeader (PoolIndexId $ KeyHash "9f1b441b9b781b3c3abb43b25679dc17dbaaf116dddca1ad09dc1de0"), (1, 0, 0, 0, 0)) - , (StakeIndexPoolLeader (PoolIndexId $ KeyHash "5af582399de8c226391bfd21424f34d0b053419c4d93975802b7d107"), (1, 1, 0, 0, 0)) - , (StakeIndexPoolLeader (PoolIndexId $ KeyHash "58eef2925db2789f76ea057c51069e52c5e0a44550f853c6cdf620f8"), (1, 1, 0, 0, 0)) - , (StakeIndexPoolMember 0 (PoolIndex 0), (0, 1, 0, 0, 0)) - , (StakeIndexPoolMember 0 (PoolIndex 1), (0, 1, 0, 0, 0)) - ] - where - testLabel = "simpleRewards-alonzo" - -rewardsDeregistration :: IOManager -> [(Text, Text)] -> Assertion -rewardsDeregistration = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDepositTxPools (UTxOIndex 1) 20000 - - -- first move to treasury from reserves - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Withdrawals mempty) - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - -- register the stake address and delegate to a pool - let poolId = resolvePool (PoolIndex 0) st - tx1 <- - Alonzo.mkSimpleDCertTx - [ (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, \stCred -> ShelleyTxCertDelegCert $ ShelleyDelegCert stCred poolId) - ] - st - -- send some funds to the address so - tx2 <- Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithStake 0 (StakeIndexNew 1)) 100000 5000 st - Right [tx1, tx2] - - a <- fillEpochs interpreter mockServer 3 - assertBlockNoBackoff dbSync (fromIntegral $ 3 + length a) - - st <- getAlonzoLedgerState interpreter - - -- Now that pools are registered, we add a tx to fill the fees pot. - -- Rewards will be distributed. - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - - b <- fillEpochs interpreter mockServer 2 - - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length a + length b) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 1, 0, 0, 0))] - - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 - - c <- fillEpochs interpreter mockServer 2 - - assertBlockNoBackoff dbSync (fromIntegral $ 5 + length a + length b + length c) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 2, 0, 0, 0))] - - d <- fillEpochs interpreter mockServer 1 - e <- fillEpochPercentage interpreter mockServer 85 - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - - f <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync (fromIntegral $ 6 + length (a <> b <> c <> d <> e <> f)) - -- stays at 2, since it's deregistered. - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 2, 0, 0, 0))] - - g <- fillEpochs interpreter mockServer 2 - assertBlockNoBackoff dbSync (fromIntegral $ 6 + length (a <> b <> c <> d <> e <> f <> g)) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 2, 0, 0, 0))] - where - testLabel = "rewardsDeregistration-alonzo" - --- This is a fix of the reward issue fix in Babbage described in the Babbage specs --- If a stake address is deregistered during the reward computation initialisation, --- and is registered later it doesn't receive rewards before Babbage. It does receive --- on Babbage. See the same test on Alonzo. -rewardsReregistration :: IOManager -> [(Text, Text)] -> Assertion -rewardsReregistration = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkDepositTxPools (UTxOIndex 1) 20000 - - -- first move to treasury from reserves - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Withdrawals mempty) - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - -- register the stake address and delegate to a pool - let poolId = resolvePool (PoolIndex 0) st - tx1 <- - Alonzo.mkSimpleDCertTx - [ (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, \stCred -> ShelleyTxCertDelegCert $ ShelleyDelegCert stCred poolId) - ] - st - -- send some funds to the address so - tx2 <- Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithStake 0 (StakeIndexNew 1)) 100000 5000 st - Right [tx1, tx2] - - a <- fillEpochs interpreter mockServer 3 - assertBlockNoBackoff dbSync (fromIntegral $ 3 + length a) - - st <- getAlonzoLedgerState interpreter - - -- Now that pools are registered, we add a tx to fill the fees pot. - -- Rewards will be distributed. - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - - b <- fillEpochs interpreter mockServer 2 - - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length a + length b) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 1, 0, 0, 0))] - - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 - - b' <- fillEpochs interpreter mockServer 1 - c <- fillEpochPercentage interpreter mockServer 10 - -- deregister before the 40% of the epoch - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - d <- fillEpochPercentage interpreter mockServer 60 - -- register after 40% and before epoch boundary. - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - e <- fillUntilNextEpoch interpreter mockServer - assertBlockNoBackoff dbSync (fromIntegral $ 7 + length (a <> b <> b' <> c <> d <> e)) - -- This is 2 in Babbage - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 1, 0, 0, 0))] - where - testLabel = "rewardsReregistration-Alonzo" - -mirReward :: IOManager -> [(Text, Text)] -> Assertion -mirReward = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- first move to treasury from reserves - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Withdrawals mempty) - - void $ fillEpochPercentage interpreter mockServer 50 - - -- mir from treasury - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx1 <- - Alonzo.mkSimpleDCertTx - [ - ( StakeIndex 1 - , \cred -> ShelleyTxCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 100))) - ) - ] - st - tx2 <- - Alonzo.mkSimpleDCertTx - [ - ( StakeIndex 1 - , \cred -> ShelleyTxCertMir $ MIRCert ReservesMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 200))) - ) - ] - st - tx3 <- - Alonzo.mkSimpleDCertTx - [ - ( StakeIndex 1 - , \cred -> ShelleyTxCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 300))) - ) - ] - st - pure [tx1, tx2, tx3] - - void $ fillUntilNextEpoch interpreter mockServer - - st <- getAlonzoLedgerState interpreter - -- 2 mir rewards from treasury are sumed - assertRewardCounts dbSync st True Nothing [(StakeIndex 1, (0, 0, 1, 1, 0))] - where - testLabel = "mirReward-alonzo" - -mirRewardRollback :: IOManager -> [(Text, Text)] -> Assertion -mirRewardRollback = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- first move to treasury from reserves - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Withdrawals mempty) - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - a <- fillUntilNextEpoch interpreter mockServer - b <- fillEpochPercentage interpreter mockServer 5 - -- mir from treasury - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx - [ - ( StakeIndexNew 1 - , \cred -> ShelleyTxCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 1000))) - ) - ] - c <- fillEpochPercentage interpreter mockServer 50 - d <- fillUntilNextEpoch interpreter mockServer - - st <- getAlonzoLedgerState interpreter - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b <> c <> d)) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 0, 0, 1, 0))] - - atomically $ rollback mockServer (blockPoint $ last c) - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b <> c <> d)) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 0, 0, 1, 0))] - stopDBSync dbSync - startDBSync dbSync - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b <> c <> d)) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 0, 0, 1, 0))] - - forM_ d $ atomically . addBlock mockServer - e <- fillEpochPercentage interpreter mockServer 5 - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b <> c <> d <> e)) - assertRewardCounts dbSync st True Nothing [(StakeIndexNew 1, (0, 0, 0, 1, 0))] - where - testLabel = "mirRewardRollback-alonzo" - -mirRewardDereg :: IOManager -> [(Text, Text)] -> Assertion -mirRewardDereg = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- first move to treasury from reserves - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Withdrawals mempty) - - a <- fillUntilNextEpoch interpreter mockServer - - -- mir from treasury - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx1 <- - Alonzo.mkSimpleDCertTx - [ - ( StakeIndex 1 - , \cred -> ShelleyTxCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 100))) - ) - ] - st - tx2 <- - Alonzo.mkSimpleDCertTx - [ - ( StakeIndex 1 - , \cred -> ShelleyTxCertMir $ MIRCert ReservesMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 200))) - ) - ] - st - tx3 <- - Alonzo.mkSimpleDCertTx - [ - ( StakeIndex 1 - , \cred -> ShelleyTxCertMir $ MIRCert TreasuryMIR (StakeAddressesMIR (Map.singleton cred (DeltaCoin 300))) - ) - ] - st - pure [tx1, tx2, tx3] - - b <- fillEpochPercentage interpreter mockServer 20 - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndex 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - - assertBlockNoBackoff dbSync (fromIntegral $ 4 + length (a <> b)) - -- deregistration means empty rewards - st <- getAlonzoLedgerState interpreter - assertRewardCounts dbSync st False Nothing [] - where - testLabel = "mirRewardDereg-alonzo" - -_rewardsEmptyChainLast :: IOManager -> [(Text, Text)] -> Assertion -_rewardsEmptyChainLast = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - a <- fillEpochs interpreter mockServer 3 - assertRewardCount dbSync 3 - - -- Now that pools are registered, we add a tx to fill the fees pot. - -- Rewards will be distributed. - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - - b <- fillUntilNextEpoch interpreter mockServer - assertRewardCount dbSync 6 - - c <- fillEpochPercentage interpreter mockServer 68 - - -- Skip a percentage of the epoch epoch - void $ skipUntilNextEpoch interpreter mockServer [] - d <- fillUntilNextEpoch interpreter mockServer - assertBlockNoBackoff dbSync (fromIntegral $ 1 + length a + 1 + length b + length c + 1 + length d) - assertRewardCount dbSync 17 - where - testLabel = "rewardsEmptyChainLast-alonzo" - -_rewardsDelta :: IOManager -> [(Text, Text)] -> Assertion -_rewardsDelta = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - -- These delegation push the computation of the 3 leader - -- rewards toward the 8k/f slot, so it can be delayed even more - -- with the missing blocks and create the delta reward. - -- This trick may break at some point in the future. - a <- delegateAndSendBlocks 1000 interpreter - forM_ a $ atomically . addBlock mockServer - void $ registerAllStakeCreds interpreter mockServer - b <- fillEpochs interpreter mockServer 3 - assertRewardCount dbSync 3 - - c <- fillUntilNextEpoch interpreter mockServer - assertRewardCount dbSync 6 - - d <- fillEpochPercentage interpreter mockServer 68 - assertRewardCount dbSync 6 - - -- Skip a percentage of the epoch epoch - void $ skipUntilNextEpoch interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ 1 + length a + length b + length c + 1 + length d) - -- These are delta rewards aka rewards that were added at the epoch boundary, because the reward - -- update was not complete on time, due to missing blocks. - assertRewardCount dbSync 9 - where - testLabel = "rewardsDelta-alonzo" - -rollbackBoundary :: IOManager -> [(Text, Text)] -> Assertion -rollbackBoundary = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - a <- fillEpochs interpreter mockServer 2 - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - - blks <- forgeAndSubmitBlocks interpreter mockServer 50 - blks' <- fillUntilNextEpoch interpreter mockServer - - assertRewardCount dbSync 3 - atomically $ rollback mockServer (blockPoint $ last blks) - assertBlockNoBackoff dbSync (2 + length a + length blks + length blks') - forM_ blks' $ atomically . addBlock mockServer - assertBlockNoBackoff dbSync (2 + length a + length blks + length blks') - assertRewardCount dbSync 3 - blks'' <- fillUntilNextEpoch interpreter mockServer - assertBlockNoBackoff dbSync (2 + length a + length blks + length blks' + length blks'') - where - testLabel = "rollbackBoundary-alonzo" - -singleMIRCertMultiOut :: IOManager -> [(Text, Text)] -> Assertion -singleMIRCertMultiOut = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR (SendToOppositePotMIR (Coin 100000))] (Withdrawals mempty) - - a <- fillUntilNextEpoch interpreter mockServer - - void $ withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ \state -> do - stakeAddr0 <- resolveStakeCreds (StakeIndex 0) state - stakeAddr1 <- resolveStakeCreds (StakeIndex 1) state - let saMIR = StakeAddressesMIR (Map.fromList [(stakeAddr0, DeltaCoin 10), (stakeAddr1, DeltaCoin 20)]) - Alonzo.mkDCertTx [ShelleyTxCertMir $ MIRCert ReservesMIR saMIR, ShelleyTxCertMir $ MIRCert TreasuryMIR saMIR] (Withdrawals mempty) - - b <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync (2 + length a + length b) - assertRewardRestCount dbSync 4 - where - testLabel = "singleMIRCertMultiOut-alonzo" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Stake.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Stake.hs deleted file mode 100644 index 3f5fdd0c4..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Alonzo/Stake.hs +++ /dev/null @@ -1,340 +0,0 @@ -module Test.Cardano.Db.Mock.Unit.Alonzo.Stake ( - -- stake addresses - registrationTx, - registrationsSameBlock, - registrationsSameTx, - stakeAddressPtr, - stakeAddressPtrDereg, - stakeAddressPtrUseBefore, - -- stake distribution - stakeDistGenesis, - delegations2000, - delegations2001, - delegations8000, - delegationsMany, - delegationsManyNotDense, -) where - -import qualified Cardano.Db as DB -import Cardano.Ledger.BaseTypes (CertIx (CertIx), TxIx (TxIx)) -import Cardano.Ledger.Credential -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager, addBlock) -import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo -import Cardano.Mock.Forging.Tx.Alonzo.Scenarios (delegateAndSendBlocks) -import Cardano.Mock.Forging.Types (StakeIndex (..), UTxOIndex (..)) -import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM (atomically)) -import Control.Monad (forM_, replicateM_, void) -import Data.Text (Text) -import Ouroboros.Network.Block (blockSlot) -import Test.Cardano.Db.Mock.Config (alonzoConfigDir, startDBSync, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillEpochs, - fillUntilNextEpoch, - forgeAndSubmitBlocks, - forgeNextFindLeaderAndSubmit, - forgeNextSkipSlotsFindLeaderAndSubmit, - getAlonzoLedgerState, - withAlonzoFindLeaderAndSubmit, - withAlonzoFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate ( - assertAddrValues, - assertBlockNoBackoff, - assertBlockNoBackoffTimes, - assertCertCounts, - assertEpochStake, - assertEpochStakeEpoch, - ) -import Test.Tasty.HUnit (Assertion) - ----------------------------------------------------------------------------------------------------------- --- Stake Addresses ----------------------------------------------------------------------------------------------------------- - -registrationTx :: IOManager -> [(Text, Text)] -> Assertion -registrationTx = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - - -- We add interval or else the txs would have the same id - void $ - withAlonzoFindLeaderAndSubmitTx - interpreter - mockServer - ( fmap (Alonzo.addValidityInterval 1000) - . Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - ) - - void $ - withAlonzoFindLeaderAndSubmitTx - interpreter - mockServer - ( fmap (Alonzo.addValidityInterval 2000) - . Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - ) - - assertBlockNoBackoff dbSync 4 - assertCertCounts dbSync (2, 2, 0, 0) - where - testLabel = "registrationTx-alonzo" - -registrationsSameBlock :: IOManager -> [(Text, Text)] -> Assertion -registrationsSameBlock = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] st - tx2 <- Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx3 <- Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] st - Right [tx0, tx1, Alonzo.addValidityInterval 1000 tx2, Alonzo.addValidityInterval 2000 tx3] - - assertBlockNoBackoff dbSync 1 - assertCertCounts dbSync (2, 2, 0, 0) - where - testLabel = "registrationsSameBlock-alonzo" - -registrationsSameTx :: IOManager -> [(Text, Text)] -> Assertion -registrationsSameTx = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx - [ (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - - assertBlockNoBackoff dbSync 1 - assertCertCounts dbSync (2, 2, 0, 0) - where - testLabel = "registrationsSameTx-alonzo" - -stakeAddressPtr :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressPtr = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - blk <- - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20000 20000 - - assertBlockNoBackoff dbSync 2 - assertCertCounts dbSync (1, 0, 0, 0) - where - testLabel = "stakeAddressPtr-alonzo" - -stakeAddressPtrDereg :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressPtrDereg = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - blk <- - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyRegCert)] - - let ptr0 = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - - blk' <- withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr0) 20000 20000 st - tx1 <- - Alonzo.mkSimpleDCertTx - [ (StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyRegCert) - ] - st - pure [tx0, tx1] - - let ptr1 = Ptr (blockSlot blk') (TxIx 1) (CertIx 1) - - void $ withAlonzoFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOAddressNewWithPtr 0 ptr1) 20000 20000 st - tx1 <- Alonzo.mkPaymentTx (UTxOIndex 2) (UTxOAddressNewWithPtr 0 ptr0) 20000 20000 st - pure [tx0, tx1] - - st <- getAlonzoLedgerState interpreter - assertBlockNoBackoff dbSync 3 - assertCertCounts dbSync (2, 1, 0, 0) - -- The 2 addresses have the same payment credentials and they reference the same - -- stake credentials, however they have - assertAddrValues dbSync (UTxOAddressNewWithPtr 0 ptr0) (DB.DbLovelace 40000) st - assertAddrValues dbSync (UTxOAddressNewWithPtr 0 ptr1) (DB.DbLovelace 20000) st - where - testLabel = "stakeAddressPtrDereg-alonzo" - -stakeAddressPtrUseBefore :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressPtrUseBefore = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - -- first use this stake credential - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 1) (UTxOAddressNewWithStake 0 (StakeIndexNew 1)) 10000 500 - - -- and then register it - blk <- - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20000 20000 - - assertBlockNoBackoff dbSync 3 - assertCertCounts dbSync (1, 0, 0, 0) - where - testLabel = "stakeAddressPtrUseBefore-alonzo" - ----------------------------------------------------------------------------------------------------------- --- Stake Distribution ----------------------------------------------------------------------------------------------------------- - -stakeDistGenesis :: IOManager -> [(Text, Text)] -> Assertion -stakeDistGenesis = - withFullConfigAndDropDB alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- fillUntilNextEpoch interpreter mockServer - assertBlockNoBackoff dbSync (fromIntegral $ length a) - -- There are 5 delegations in genesis - assertEpochStake dbSync 5 - where - testLabel = "stakeDistGenesis-alonzo" - -delegations2000 :: IOManager -> [(Text, Text)] -> Assertion -delegations2000 = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 1995 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillUntilNextEpoch interpreter mockServer - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) - -- There are exactly 2000 entries on the second epoch, 5 from genesis and 1995 manually added - assertEpochStakeEpoch dbSync 2 2000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 1) - assertEpochStakeEpoch dbSync 2 2000 - where - testLabel = "delegations2000-alonzo" - -delegations2001 :: IOManager -> [(Text, Text)] -> Assertion -delegations2001 = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 1996 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillUntilNextEpoch interpreter mockServer - c <- forgeAndSubmitBlocks interpreter mockServer 9 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) - assertEpochStakeEpoch dbSync 2 0 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 1) - assertEpochStakeEpoch dbSync 2 2000 - -- The remaining entry is inserted on the next block. - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 2) - assertEpochStakeEpoch dbSync 2 2001 - where - testLabel = "delegations2001-alonzo" - -delegations8000 :: IOManager -> [(Text, Text)] -> Assertion -delegations8000 = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 7995 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillEpochs interpreter mockServer 2 - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) - assertEpochStakeEpoch dbSync 3 2000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 4000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 6000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 8000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 8000 - where - testLabel = "delegations8000-alonzo" - -delegationsMany :: IOManager -> [(Text, Text)] -> Assertion -delegationsMany = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 40000 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillEpochs interpreter mockServer 4 - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - -- too long. We cannot use default delays - assertBlockNoBackoffTimes (repeat 10) dbSync (fromIntegral $ length a + length b + length c) - -- The slice size here is - -- 1 + div (delegationsLen * 5) expectedBlocks = 2001 - -- instead of 2000, because there are many delegations - assertEpochStakeEpoch dbSync 7 2001 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 7 4002 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 7 6003 - where - testLabel = "delegationsMany-alonzo" - -delegationsManyNotDense :: IOManager -> [(Text, Text)] -> Assertion -delegationsManyNotDense = - withFullConfig alonzoConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 40000 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillEpochs interpreter mockServer 4 - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - -- too long. We cannot use default delays - assertBlockNoBackoffTimes (repeat 10) dbSync (fromIntegral $ length a + length b + length c) - -- The slice size here is - -- 1 + div (delegationsLen * 5) expectedBlocks = 2001 - -- instead of 2000, because there are many delegations - assertEpochStakeEpoch dbSync 7 2001 - - -- Blocks come on average every 5 slots. If we skip 15 slots before each block, - -- we are expected to get only 1/4 of the expected blocks. The adjusted slices - -- should still be long enough to cover everything. - replicateM_ 40 $ - forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer 15 [] - - -- Even if the chain is sparse, all distributions are inserted. - assertEpochStakeEpoch dbSync 7 40005 - where - testLabel = "delegationsManyNotDense-alonzo" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs new file mode 100644 index 000000000..c37d9a97d --- /dev/null +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Test.Cardano.Db.Mock.Unit.Babbage ( + unitTests, +) where + +import Cardano.Mock.ChainSync.Server (IOManager) +import Data.Text (Text) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase) + +import qualified Test.Cardano.Db.Mock.Unit.Babbage.Reward as BabReward +import qualified Test.Cardano.Db.Mock.Unit.Babbage.Simple as BabSimple +import qualified Test.Cardano.Db.Mock.Unit.Babbage.Tx as BabTx + +unitTests :: IOManager -> [(Text, Text)] -> TestTree +unitTests iom knownMigrations = + testGroup + "Babbage unit tests" + [ testGroup + "simple" + [ test "simple forge blocks" BabSimple.forgeBlocks + , test "sync one block" BabSimple.addSimple + , test "sync small chain" BabSimple.addSimpleChain + , test "restart db-sync" BabSimple.restartDBSync + , test "node restart" BabSimple.nodeRestart + , test "node restart boundary" BabSimple.nodeRestartBoundary + ] + , testGroup + "blocks with txs" + [ test "simple tx" BabTx.addSimpleTx + , test "simple tx in Shelley era" BabTx.addSimpleTxShelley + , test "consume utxo same block" BabTx.consumeSameBlock + ] + , testGroup + "rewards" + [ test "rewards simple" BabReward.simpleRewards + , test "shelley rewards from multiple sources" BabReward.rewardsShelley + , test "rewards with deregistration" BabReward.rewardsDeregistration + , test "rewards with reregistration. Fixed in Babbage." BabReward.rewardsReregistration + , test "Mir Cert" BabReward.mirReward + , -- , test "Mir rollback" mirRewardRollback + test "Mir Cert Shelley" BabReward.mirRewardShelley + , test "Mir Cert deregistration" BabReward.mirRewardDereg + , -- , test "test rewards empty last part of epoch" rewardsEmptyChainLast + -- , test "test delta rewards" rewardsDelta -- We disable the test. See in the test for more. + test "rollback on epoch boundary" BabReward.rollbackBoundary + , test "single MIR Cert multiple outputs" BabReward.singleMIRCertMultiOut + ] + ] + where + test :: String -> (IOManager -> [(Text, Text)] -> Assertion) -> TestTree + test str action = testCase str (action iom knownMigrations) diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/ConfigFile.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/ConfigFile.hs deleted file mode 100644 index 601d74f79..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/ConfigFile.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Test.Cardano.Db.Mock.Unit.Babbage.CommandLineArg.ConfigFile ( - checkConfigFileArg, -) -where - -import Cardano.Mock.ChainSync.Server (IOManager) -import Data.Text (Text) -import Test.Cardano.Db.Mock.Config (CommandLineArgs (..), babbageConfigDir, initCommandLineArgs, withCustomConfig) -import Test.Cardano.Db.Mock.Validate (checkStillRuns) -import Test.Tasty.HUnit (Assertion) - --- this test fails as incorrect configuration file given -checkConfigFileArg :: IOManager -> [(Text, Text)] -> Assertion -checkConfigFileArg = - withCustomConfig commandLineConfigArgs Nothing babbageConfigDir testLabel $ \_ _ dbSyncEnv -> do - -- poll dbSync to see if it's running, which it shouldn't - checkStillRuns dbSyncEnv - where - testLabel = "CLAcheckConfigFileArg" - commandLineConfigArgs = initCommandLineArgs {claConfigFilename = "does-not-exist"} diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/EpochDisabled.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/EpochDisabled.hs deleted file mode 100644 index adba8272f..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/CommandLineArg/EpochDisabled.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Test.Cardano.Db.Mock.Unit.Babbage.CommandLineArg.EpochDisabled ( - checkEpochDisabledArg, - checkEpochEnabled, -) -where - -import qualified Cardano.Db as DB -import Cardano.Mock.ChainSync.Server (IOManager) -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Types (UTxOIndex (..)) -import Control.Monad (void) -import Data.Text (Text) -import Test.Cardano.Db.Mock.Config (CommandLineArgs (..), babbageConfigDir, initCommandLineArgs, startDBSync, withCustomConfig, withCustomConfigAndDropDB) -import Test.Cardano.Db.Mock.UnifiedApi (forgeAndSubmitBlocks, withBabbageFindLeaderAndSubmitTx) -import Test.Cardano.Db.Mock.Validate (assertBlockNoBackoff, assertEqQuery) -import Test.Tasty.HUnit (Assertion) - -mkCommandLineArgs :: Bool -> CommandLineArgs -mkCommandLineArgs epochDisabled = initCommandLineArgs {claEpochDisabled = epochDisabled} - --- this test fails as incorrect configuration file given -checkEpochDisabledArg :: IOManager -> [(Text, Text)] -> Assertion -checkEpochDisabledArg = - withCustomConfigAndDropDB (mkCommandLineArgs True) Nothing babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - b1 <- forgeAndSubmitBlocks interpreter mockServer 50 - -- add 2 blocks with tx - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 - b2 <- forgeAndSubmitBlocks interpreter mockServer 60 - - assertBlockNoBackoff dbSyncEnv (fromIntegral $ length (b1 <> b2) + 2) - assertEqQuery dbSyncEnv DB.queryEpochCount 0 "new epoch didn't prune tx_out column that are null" - where - testLabel = "CLAcheckEpochDisabledArg " - -checkEpochEnabled :: IOManager -> [(Text, Text)] -> Assertion -checkEpochEnabled = - withCustomConfig (mkCommandLineArgs False) Nothing babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - b1 <- forgeAndSubmitBlocks interpreter mockServer 50 - -- add 2 blocks with tx - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 - b2 <- forgeAndSubmitBlocks interpreter mockServer 60 - - assertBlockNoBackoff dbSyncEnv (fromIntegral $ length (b1 <> b2) + 2) - assertEqQuery dbSyncEnv DB.queryEpochCount 1 "new epoch didn't prune tx_out column that are null" - where - testLabel = "CLAcheckEpochDisabledArg " diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/MigrateConsumedPruneTxOut.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/MigrateConsumedPruneTxOut.hs deleted file mode 100644 index 6f385c06f..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/MigrateConsumedPruneTxOut.hs +++ /dev/null @@ -1,413 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -#if __GLASGOW_HASKELL__ >= 908 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif - -module Test.Cardano.Db.Mock.Unit.Babbage.Config.MigrateConsumedPruneTxOut ( - basicPrune, - basicPruneWithAddress, - pruneWithSimpleRollback, - pruneWithSimpleRollbackWithAddress, - pruneWithFullTxRollback, - pruneWithFullTxRollbackWithAddress, - pruningShouldKeepSomeTx, - pruningShouldKeepSomeTxWithAddress, - pruneAndRollBackOneBlock, - pruneAndRollBackOneBlockWithAddress, - noPruneAndRollBack, - noPruneAndRollBackWithAddress, - pruneSameBlock, - pruneSameBlockWithAddress, - noPruneSameBlock, - noPruneSameBlockWithAddress, - migrateAndPruneRestart, - migrateAndPruneRestartWithAddress, - pruneRestartMissingFlag, - pruneRestartMissingFlagWithAddress, - bootstrapRestartMissingFlag, - bootstrapRestartMissingFlagWithAddress, -) where - -import Cardano.Db (TxOutTableType (..)) -import qualified Cardano.Db as DB -import Cardano.Mock.ChainSync.Server (IOManager, addBlock) -import Cardano.Mock.Forging.Interpreter (forgeNext) -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Types (UTxOIndex (..)) -import Control.Concurrent (threadDelay) -import Control.Concurrent.Class.MonadSTM.Strict (atomically) -import Control.Monad (void) -import Data.Text (Text) -import Ouroboros.Consensus.Block (blockPoint) -import Test.Cardano.Db.Mock.Config ( - babbageConfigDir, - configBootstrap, - configConsume, - configPrune, - configPruneForceTxIn, - initCommandLineArgs, - replaceConfigFile, - startDBSync, - stopDBSync, - txOutTableTypeFromConfig, - withCustomConfigAndDropDB, - ) -import Test.Cardano.Db.Mock.Examples (mockBlock0, mockBlock1) -import Test.Cardano.Db.Mock.UnifiedApi ( - forgeAndSubmitBlocks, - forgeNextFindLeaderAndSubmit, - getBabbageLedgerState, - rollbackTo, - withBabbageFindLeaderAndSubmit, - withBabbageFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate (assertBlockNoBackoff, assertEqQuery, assertTxCount, assertTxInCount, assertTxOutCount, assertUnspentTx, checkStillRuns) -import Test.Tasty.HUnit (Assertion) - ------------------------------------------------------------------------------- --- Tests ------------------------------------------------------------------------------- -basicPrune :: IOManager -> [(Text, Text)] -> Assertion -basicPrune = peformBasicPrune False - -basicPruneWithAddress :: IOManager -> [(Text, Text)] -> Assertion -basicPruneWithAddress = peformBasicPrune True - -peformBasicPrune :: Bool -> IOManager -> [(Text, Text)] -> Assertion -peformBasicPrune useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - startDBSync dbSyncEnv - -- add 50 block - b1 <- forgeAndSubmitBlocks interpreter mockServer 50 - -- add 2 blocks with tx - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 - assertBlockNoBackoff dbSyncEnv (fromIntegral $ length b1 + 2) - -- check tx-out count before any pruning has happened - assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 14 "new epoch didn't prune tx_out column that are null" - -- add other blocks to instantiate the pruning - b2 <- forgeAndSubmitBlocks interpreter mockServer 48 - assertBlockNoBackoff dbSyncEnv (fromIntegral $ length (b1 <> b2) + 2) - - -- check that the tx_out has been pruned - assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 12 "the pruning didn't work correctly as the tx-out count is incorrect" - -- check Unspent tx match after pruning - assertUnspentTx dbSyncEnv - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPrune" - -pruneWithSimpleRollback :: IOManager -> [(Text, Text)] -> Assertion -pruneWithSimpleRollback = peformPruneWithSimpleRollback False - -pruneWithSimpleRollbackWithAddress :: IOManager -> [(Text, Text)] -> Assertion -pruneWithSimpleRollbackWithAddress = peformPruneWithSimpleRollback True - -peformPruneWithSimpleRollback :: Bool -> IOManager -> [(Text, Text)] -> Assertion -peformPruneWithSimpleRollback useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - blk0 <- forgeNext interpreter mockBlock0 - blk1 <- forgeNext interpreter mockBlock1 - atomically $ addBlock mockServer blk0 - startDBSync dbSyncEnv - atomically $ addBlock mockServer blk1 - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10000 10000 - assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 14 "" - b1 <- forgeAndSubmitBlocks interpreter mockServer 96 - assertBlockNoBackoff dbSyncEnv (fullBlockSize b1) - assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 12 "the txOut count is incorrect" - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after prune" - assertUnspentTx dbSyncEnv - - rollbackTo interpreter mockServer (blockPoint blk1) - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId cout after rollback" - assertBlockNoBackoff dbSyncEnv $ fullBlockSize b1 - where - fullBlockSize b = fromIntegral $ length b + 4 - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneSimpleRollback" - -pruneWithFullTxRollback :: IOManager -> [(Text, Text)] -> Assertion -pruneWithFullTxRollback = performPruneWithFullTxRollback False - -pruneWithFullTxRollbackWithAddress :: IOManager -> [(Text, Text)] -> Assertion -pruneWithFullTxRollbackWithAddress = performPruneWithFullTxRollback True - -performPruneWithFullTxRollback :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performPruneWithFullTxRollback useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - startDBSync dbSyncEnv - blk0 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkFullTx 0 100 st - tx1 <- Babbage.mkFullTx 1 200 st - pure [tx0, tx1] - assertBlockNoBackoff dbSyncEnv 2 - assertTxCount dbSyncEnv 13 - assertUnspentTx dbSyncEnv - assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 14 "new epoch didn't prune tx_out column that are null" - rollbackTo interpreter mockServer $ blockPoint blk0 - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkFullTx 0 100 st - tx1 <- Babbage.mkFullTx 1 200 st - tx2 <- Babbage.mkFullTx 2 200 st - pure [tx1, tx2, tx0] - assertBlockNoBackoff dbSyncEnv 2 - assertTxCount dbSyncEnv 14 - assertEqQuery dbSyncEnv (DB.queryTxOutCount txOutTableType) 16 "new epoch didn't prune tx_out column that are null" - assertUnspentTx dbSyncEnv - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneOnFullRollback" - --- The tx in the last, 2 x securityParam worth of blocks should not be pruned. --- In these tests, 2 x securityParam = 20 blocks. -pruningShouldKeepSomeTx :: IOManager -> [(Text, Text)] -> Assertion -pruningShouldKeepSomeTx = performPruningShouldKeepSomeTx False - -pruningShouldKeepSomeTxWithAddress :: IOManager -> [(Text, Text)] -> Assertion -pruningShouldKeepSomeTxWithAddress = performPruningShouldKeepSomeTx True - -performPruningShouldKeepSomeTx :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performPruningShouldKeepSomeTx useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configPrune useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - b1 <- forgeAndSubmitBlocks interpreter mockServer 80 - -- these two blocs + tx will fall withing the last 20 blocks so should not be pruned - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 2) (UTxOIndex 3) 10000 10000 - b2 <- forgeAndSubmitBlocks interpreter mockServer 18 - assertBlockNoBackoff dbSyncEnv (fromIntegral $ length (b1 <> b2) + 2) - -- the two marked TxOutConsumedByTxId should not be pruned - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount TxOutCore) 2 "Unexpected TxOutConsumedByTxId count after prune" - -- add more blocks to instantiate another prune - b3 <- forgeAndSubmitBlocks interpreter mockServer 110 - assertBlockNoBackoff dbSyncEnv (fromIntegral $ length (b1 <> b2 <> b3) + 2) - -- the prune should have removed all - assertTxInCount dbSyncEnv 0 - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after prune" - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneCorrectAmount" - --- prune with rollback -pruneAndRollBackOneBlock :: IOManager -> [(Text, Text)] -> Assertion -pruneAndRollBackOneBlock = performPruneAndRollBackOneBlock False - -pruneAndRollBackOneBlockWithAddress :: IOManager -> [(Text, Text)] -> Assertion -pruneAndRollBackOneBlockWithAddress = performPruneAndRollBackOneBlock True - -performPruneAndRollBackOneBlock :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performPruneAndRollBackOneBlock useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 98 - -- add 2 blocks with tx - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - -- add an empty block then fill it with a tx so we can use blk100 as point to rollback - blk100 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - st <- getBabbageLedgerState interpreter - let Right tx1 = Babbage.mkPaymentTx (UTxOIndex 2) (UTxOIndex 3) 10000 500 st - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \_st -> - Right [tx1] - assertBlockNoBackoff dbSyncEnv 101 - -- the 2 tx have been marked but not pruned as they are withing the last 20 blocks - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId count before rollback" - rollbackTo interpreter mockServer $ blockPoint blk100 - -- add an empty block - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSyncEnv 101 - -- there should only be 1 tx marked now as the other was deleted in rollback - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" - -- cause another prune - void $ forgeAndSubmitBlocks interpreter mockServer 102 - assertBlockNoBackoff dbSyncEnv 203 - -- everything should be pruned - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId count after rollback" - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneAndRollBack" - --- consume with rollback -noPruneAndRollBack :: IOManager -> [(Text, Text)] -> Assertion -noPruneAndRollBack = performNoPruneAndRollBack False - -noPruneAndRollBackWithAddress :: IOManager -> [(Text, Text)] -> Assertion -noPruneAndRollBackWithAddress = performNoPruneAndRollBack True - -performNoPruneAndRollBack :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performNoPruneAndRollBack useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 98 - -- add 2 blocks with tx - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 10000 - -- add an empty block then fill it with a tx so we can use blk100 as point to rollback - blk100 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - st <- getBabbageLedgerState interpreter - let Right tx1 = Babbage.mkPaymentTx (UTxOIndex 2) (UTxOIndex 3) 10000 500 st - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \_st -> - Right [tx1] - assertBlockNoBackoff dbSyncEnv 101 - -- the 2 tx have been marked but not pruned as they are withing the last 20 blocks - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId count before rollback" - rollbackTo interpreter mockServer $ blockPoint blk100 - -- add an empty block - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSyncEnv 101 - -- there should only be 1 tx marked now as the other was deleted in rollback - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" - -- cause another prune - void $ forgeAndSubmitBlocks interpreter mockServer 102 - assertBlockNoBackoff dbSyncEnv 203 - -- everything should be pruned - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 1 "Unexpected TxOutConsumedByTxId count after rollback" - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneAndRollBack" - -pruneSameBlock :: IOManager -> [(Text, Text)] -> Assertion -pruneSameBlock = performPruneSameBlock False - -pruneSameBlockWithAddress :: IOManager -> [(Text, Text)] -> Assertion -pruneSameBlockWithAddress = performPruneSameBlock True - -performPruneSameBlock :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performPruneSameBlock useTxOutAddress = - withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 76 - blk77 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 20000 20000 st - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- Babbage.mkPaymentTx (UTxOPair utxo0) (UTxOIndex 2) 10000 500 st - pure [tx0, tx1] - assertBlockNoBackoff dbSyncEnv 78 - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 2 "Unexpected TxOutConsumedByTxId before rollback" - void $ forgeAndSubmitBlocks interpreter mockServer 22 - assertBlockNoBackoff dbSyncEnv 100 - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId after prune" - rollbackTo interpreter mockServer (blockPoint blk77) - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSyncEnv 78 - assertTxInCount dbSyncEnv 0 - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId after rollback" - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneSameBlock" - -noPruneSameBlock :: IOManager -> [(Text, Text)] -> Assertion -noPruneSameBlock = performNoPruneSameBlock False - -noPruneSameBlockWithAddress :: IOManager -> [(Text, Text)] -> Assertion -noPruneSameBlockWithAddress = performNoPruneSameBlock True - -performNoPruneSameBlock :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performNoPruneSameBlock useTxOutAddress = - withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - let txOutTableType = txOutTableTypeFromConfig dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 96 - blk97 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 20000 20000 st - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- Babbage.mkPaymentTx (UTxOPair utxo0) (UTxOIndex 2) 10000 500 st - pure [tx0, tx1] - void $ forgeAndSubmitBlocks interpreter mockServer 2 - assertBlockNoBackoff dbSyncEnv 100 - rollbackTo interpreter mockServer (blockPoint blk97) - assertBlockNoBackoff dbSyncEnv 100 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSyncEnv 98 - assertEqQuery dbSyncEnv (DB.queryTxOutConsumedCount txOutTableType) 0 "Unexpected TxOutConsumedByTxId after rollback" - where - cmdLineArgs = initCommandLineArgs - testLabel = "configNoPruneSameBlock" - -migrateAndPruneRestart :: IOManager -> [(Text, Text)] -> Assertion -migrateAndPruneRestart = performMigrateAndPruneRestart False - -migrateAndPruneRestartWithAddress :: IOManager -> [(Text, Text)] -> Assertion -migrateAndPruneRestartWithAddress = performMigrateAndPruneRestart True - -performMigrateAndPruneRestart :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performMigrateAndPruneRestart useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configConsume useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 50 - assertBlockNoBackoff dbSyncEnv 50 - -- stop - stopDBSync dbSyncEnv - -- update the syncParams to include new params - newEnv <- replaceConfigFile "test-db-sync-config.json" dbSyncEnv - startDBSync newEnv - -- there is a slight delay before flag is checked - threadDelay 6000000 - -- checkStillRuns uses `poll` due to this being inside Async and passes along our thrown exception - checkStillRuns dbSyncEnv - where - cmdLineArgs = initCommandLineArgs - testLabel = "configMigrateAndPruneRestart" - -pruneRestartMissingFlag :: IOManager -> [(Text, Text)] -> Assertion -pruneRestartMissingFlag = performPruneRestartMissingFlag False - -pruneRestartMissingFlagWithAddress :: IOManager -> [(Text, Text)] -> Assertion -pruneRestartMissingFlagWithAddress = performPruneRestartMissingFlag True - -performPruneRestartMissingFlag :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performPruneRestartMissingFlag useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configPruneForceTxIn useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 50 - assertBlockNoBackoff dbSyncEnv 50 - -- stop - stopDBSync dbSyncEnv - -- update the syncParams to include new params - newEnv <- replaceConfigFile "test-db-sync-config.json" dbSyncEnv - startDBSync newEnv - -- there is a slight delay before flag is checked - threadDelay 6000000 - -- checkStillRuns uses `poll` due to this being inside Async and passes along our thrown exception - checkStillRuns dbSyncEnv - where - cmdLineArgs = initCommandLineArgs - testLabel = "configPruneRestartMissingFlag" - -bootstrapRestartMissingFlag :: IOManager -> [(Text, Text)] -> Assertion -bootstrapRestartMissingFlag = performBootstrapRestartMissingFlag False - -bootstrapRestartMissingFlagWithAddress :: IOManager -> [(Text, Text)] -> Assertion -bootstrapRestartMissingFlagWithAddress = performBootstrapRestartMissingFlag True - -performBootstrapRestartMissingFlag :: Bool -> IOManager -> [(Text, Text)] -> Assertion -performBootstrapRestartMissingFlag useTxOutAddress = do - withCustomConfigAndDropDB cmdLineArgs (Just $ configBootstrap useTxOutAddress) babbageConfigDir testLabel $ \interpreter mockServer dbSyncEnv -> do - startDBSync dbSyncEnv - void $ forgeAndSubmitBlocks interpreter mockServer 50 - assertBlockNoBackoff dbSyncEnv 50 - assertTxOutCount dbSyncEnv 0 - -- stop - stopDBSync dbSyncEnv - -- update the syncParams to include new params - newEnv <- replaceConfigFile "test-db-sync-config.json" dbSyncEnv - startDBSync newEnv - -- there is a slight delay before flag is checked - threadDelay 6000000 - -- checkStillRuns uses `poll` due to this being inside Async and passes along our thrown exception - checkStillRuns dbSyncEnv - where - cmdLineArgs = initCommandLineArgs - testLabel = "configBootstrapRestartMissingFlag" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/Parse.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/Parse.hs deleted file mode 100644 index 3c75ffcf8..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Config/Parse.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Test.Cardano.Db.Mock.Unit.Babbage.Config.Parse ( - defaultInsertConfig, - insertConfig, -) where - -import Cardano.DbSync.Config -import Cardano.DbSync.Config.Types -import Cardano.Prelude -import Data.Default.Class (Default (..)) -import Test.Cardano.Db.Mock.Config -import Test.Tasty.HUnit (Assertion (), (@?=)) -import Prelude () - -defaultInsertConfig :: Assertion -defaultInsertConfig = do - cfg <- mkSyncNodeConfig babbageConfigDir initCommandLineArgs - dncInsertOptions cfg @?= def - -insertConfig :: Assertion -insertConfig = do - cfg <- mkSyncNodeConfig configDir initCommandLineArgs - let expected = - SyncInsertOptions - { sioTxCBOR = TxCBORConfig False - , sioTxOut = TxOutDisable - , sioLedger = LedgerDisable - , sioShelley = ShelleyDisable - , sioRewards = RewardsConfig True - , sioMultiAsset = MultiAssetDisable - , sioMetadata = MetadataDisable - , sioPlutus = PlutusDisable - , sioGovernance = GovernanceConfig False - , sioOffchainPoolData = OffchainPoolDataConfig False - , sioPoolStats = PoolStatsConfig False - , sioJsonType = JsonTypeDisable - , sioRemoveJsonbFromSchema = RemoveJsonbFromSchemaConfig False - } - - dncInsertOptions cfg @?= expected - where - configDir = "config-babbage-insert-options" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/InlineAndReference.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/InlineAndReference.hs deleted file mode 100644 index f114e9d88..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/InlineAndReference.hs +++ /dev/null @@ -1,434 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -#if __GLASGOW_HASKELL__ >= 908 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif - -module Test.Cardano.Db.Mock.Unit.Babbage.InlineAndReference ( - unlockDatumOutput, - unlockDatumOutputSameBlock, - inlineDatumCBOR, - spendRefScript, - spendRefScriptSameBlock, - spendCollateralOutput, - spendCollateralOutputRollback, - spendCollateralOutputSameBlock, - referenceInputUnspend, - supplyScriptsTwoWays, - supplyScriptsTwoWaysSameBlock, - referenceMintingScript, - referenceDelegation, -) where - -import Cardano.Ledger.Coin -import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..)) -import Cardano.Mock.ChainSync.Server (IOManager) -import Cardano.Mock.Forging.Interpreter (withBabbageLedgerState) -import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples ( - alwaysSucceedsScriptAddr, - alwaysSucceedsScriptHash, - assetNames, - plutusDataEncLen, - ) -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Types ( - MockBlock (..), - NodeId (..), - TxEra (..), - UTxOIndex (..), - ) -import Control.Monad (void) -import qualified Data.ByteString.Short as SBS -import qualified Data.Map as Map -import Data.Text (Text) -import Ouroboros.Network.Block (blockPoint) -import Test.Cardano.Db.Mock.Config (babbageConfigDir, startDBSync, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.UnifiedApi ( - forgeNextAndSubmit, - forgeNextFindLeaderAndSubmit, - registerAllStakeCreds, - rollbackTo, - withBabbageFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate (assertBabbageCounts, assertBlockNoBackoff, assertDatumCBOR) -import Test.Tasty.HUnit (Assertion) - -unlockDatumOutput :: IOManager -> [(Text, Text)] -> Assertion -unlockDatumOutput = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- We don't use withBabbageFindLeaderAndSubmitTx here, because we want access to the tx. - tx0 <- - withBabbageLedgerState interpreter $ - Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutInline True Babbage.InlineDatum Babbage.NoReferenceScript] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] False True 10000 500 - - assertBlockNoBackoff dbSync 3 - assertBabbageCounts dbSync (1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 0) - where - testLabel = "unlockDatumOutput" - -unlockDatumOutputSameBlock :: IOManager -> [(Text, Text)] -> Assertion -unlockDatumOutputSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- We try to make this test as crazy as possible, by keeping inputs and outputs in the same blocks, using unnecessary reference - -- inputs and adding unnnecessary fields to the collateral output. - txs' <- withBabbageLedgerState interpreter $ \st -> do - tx0 <- - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [Babbage.TxOutInline True Babbage.InlineDatum Babbage.NoReferenceScript, Babbage.TxOutInline True Babbage.NotInlineDatum (Babbage.ReferenceScript False)] - 20000 - 20000 - st - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- - Babbage.mkUnlockScriptTxBabbage - [UTxOPair utxo0] - (UTxOIndex 1) - (UTxOIndex 2) - [UTxOPair utxo0, UTxOIndex 2] - True - True - 10000 - 500 - st - pure [tx0, tx1] - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock (TxBabbage <$> txs') (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (2, 1, 1, 1, 2, 1, 0, 0, 1, 2, 1, 1, 1) - where - testLabel = "unlockDatumOutputSameBlock" - -inlineDatumCBOR :: IOManager -> [(Text, Text)] -> Assertion -inlineDatumCBOR = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- We don't use withBabbageFindLeaderAndSubmitTx here, because we want access to the tx. - tx0 <- - withBabbageLedgerState interpreter $ - Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutInline True (Babbage.InlineDatumCBOR plutusDataEncLen) Babbage.NoReferenceScript] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertDatumCBOR dbSync $ SBS.fromShort plutusDataEncLen - where - testLabel = "inlineDatumCBOR" - -spendRefScript :: IOManager -> [(Text, Text)] -> Assertion -spendRefScript = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - -- We don't use withBabbageFindLeaderAndSubmitTx here, because we want access to the tx. - tx0 <- - withBabbageLedgerState interpreter $ - Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutInline True Babbage.NotInlineDatum (Babbage.ReferenceScript True)] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo0] (UTxOIndex 1) (UTxOAddress alwaysSucceedsScriptAddr) [UTxOPair utxo0] False True 10000 500 - - assertBlockNoBackoff dbSync 3 - assertBabbageCounts dbSync (1, 1, 1, 1, 2, 1, 0, 0, 1, 1, 1, 0, 1) - where - testLabel = "spendRefScript" - -spendRefScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion -spendRefScriptSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - txs' <- withBabbageLedgerState interpreter $ \st -> do - tx0 <- - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [ Babbage.TxOutInline True Babbage.NotInlineDatum (Babbage.ReferenceScript True) - , Babbage.TxOutInline True Babbage.NotInlineDatum (Babbage.ReferenceScript False) - ] - 20000 - 20000 - st - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- - Babbage.mkUnlockScriptTxBabbage - [UTxOPair utxo0] - (UTxOIndex 1) - (UTxOIndex 2) - [UTxOPair utxo0, UTxOIndex 2] - True - True - 10000 - 500 - st - pure [tx0, tx1] - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock (TxBabbage <$> txs') (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (2, 1, 1, 1, 2, 1, 0, 0, 1, 2, 1, 0, 2) - where - testLabel = "spendRefScriptSameBlock" - -spendCollateralOutput :: IOManager -> [(Text, Text)] -> Assertion -spendCollateralOutput = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - tx0 <- - withBabbageLedgerState interpreter $ - Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx0] - - -- tx fails so its collateral output become actual output. - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTxBabbage [UTxOInput (fst utxo0)] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] True False 10000 500 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx1] - assertBlockNoBackoff dbSync 3 - - let utxo1 = head (Babbage.mkUTxOCollBabbage tx1) - tx2 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo1] (UTxOIndex 3) (UTxOIndex 1) [UTxOPair utxo1] False True 10000 500 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx2] - - assertBlockNoBackoff dbSync 4 - assertBabbageCounts dbSync (1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1) - where - testLabel = "spendCollateralOutput" - -spendCollateralOutputRollback :: IOManager -> [(Text, Text)] -> Assertion -spendCollateralOutputRollback = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - blk0 <- registerAllStakeCreds interpreter mockServer - action interpreter mockServer dbSync 0 - rollbackTo interpreter mockServer (blockPoint blk0) - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - action interpreter mockServer dbSync 1 - where - testLabel = "spendCollateralOutputRollback" - action interpreter mockServer dbSync n = do - tx0 <- - withBabbageLedgerState interpreter $ - Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx0] - - -- tx fails so its collateral output become actual output. - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTxBabbage [UTxOInput (fst utxo0)] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] True False 10000 500 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx1] - assertBlockNoBackoff dbSync $ n + 3 - - let utxo1 = head (Babbage.mkUTxOCollBabbage tx1) - tx2 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo1] (UTxOIndex 3) (UTxOIndex 1) [UTxOPair utxo1] False True 10000 500 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx2] - - assertBlockNoBackoff dbSync $ n + 4 - assertBabbageCounts dbSync (1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1) - -spendCollateralOutputSameBlock :: IOManager -> [(Text, Text)] -> Assertion -spendCollateralOutputSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - txs' <- withBabbageLedgerState interpreter $ \st -> do - tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 st - - -- tx fails so its collateral output become actual output. - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] True False 10000 500 st - let utxo1 = head (Babbage.mkUTxOCollBabbage tx1) - tx2 <- Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo1] (UTxOIndex 3) (UTxOIndex 4) [UTxOPair utxo1] False True 10000 500 st - pure [tx0, tx1, tx2] - void $ forgeNextFindLeaderAndSubmit interpreter mockServer (TxBabbage <$> txs') - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1) - where - testLabel = "spendCollateralOutputSameBlock" - -referenceInputUnspend :: IOManager -> [(Text, Text)] -> Assertion -referenceInputUnspend = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - txs' <- withBabbageLedgerState interpreter $ \st -> do - tx0 <- - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [ Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True) - , Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True) - ] - 20000 - 20000 - st - - let (utxo0 : utxo1 : _) = Babbage.mkUTxOBabbage tx0 - -- use a reference to an input which is not spend. - tx1 <- Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo1] False True 10000 500 st - pure [tx0, tx1] - void $ forgeNextFindLeaderAndSubmit interpreter mockServer (TxBabbage <$> txs') - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (1, 1, 1, 1, 2, 1, 0, 0, 1, 1, 1, 2, 2) - where - testLabel = "referenceInputUnspend" - -supplyScriptsTwoWays :: IOManager -> [(Text, Text)] -> Assertion -supplyScriptsTwoWays = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - tx0 <- - withBabbageLedgerState interpreter $ - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [ Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True) - , Babbage.TxOutNoInline True - ] - 20000 - 20000 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx0] - - let (utxo0 : utxo1 : _) = Babbage.mkUTxOBabbage tx0 - -- use a reference to an input which is not spend. - tx1 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo0, UTxOPair utxo1] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] False True 10000 500 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [TxBabbage tx1] - - assertBlockNoBackoff dbSync 3 - assertBabbageCounts dbSync (1, 2, 1, 1, 2, 2, 0, 0, 1, 1, 1, 1, 1) - where - testLabel = "supplyScriptsTwoWays" - -supplyScriptsTwoWaysSameBlock :: IOManager -> [(Text, Text)] -> Assertion -supplyScriptsTwoWaysSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - txs' <- withBabbageLedgerState interpreter $ \st -> do - -- one script referenced and one for the witnesses - tx0 <- - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [ Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True) - , Babbage.TxOutNoInline True - ] - 20000 - 20000 - st - - let (utxo0 : utxo1 : _) = Babbage.mkUTxOBabbage tx0 - -- use a reference to an input which is not spend. - tx1 <- Babbage.mkUnlockScriptTxBabbage [UTxOPair utxo0, UTxOPair utxo1] (UTxOIndex 1) (UTxOIndex 2) [UTxOPair utxo0] False True 10000 500 st - pure [tx0, tx1] - void $ forgeNextFindLeaderAndSubmit interpreter mockServer (TxBabbage <$> txs') - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (1, 2, 1, 1, 2, 2, 0, 0, 1, 1, 1, 1, 1) - where - testLabel = "supplyScriptsTwoWaysSameBlock" - -referenceMintingScript :: IOManager -> [(Text, Text)] -> Assertion -referenceMintingScript = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - txs' <- withBabbageLedgerState interpreter $ \st -> do - -- one script referenced and one for the witnesses - tx0 <- - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True)] - 20000 - 20000 - st - - let utxo0 = head $ Babbage.mkUTxOBabbage tx0 - -- use a reference to an output which has a minting script. - let val0 = MultiAsset $ Map.singleton (PolicyID alwaysSucceedsScriptHash) (Map.singleton (head assetNames) 1) - tx1 <- - Babbage.mkMAssetsScriptTx - [UTxOIndex 0] - (UTxOIndex 1) - [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] - [UTxOPair utxo0] - val0 - True - 100 - st - pure [tx0, tx1] - void $ forgeNextFindLeaderAndSubmit interpreter mockServer (TxBabbage <$> txs') - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (1, 1, 1, 1, 1, 0, 0, 0, 1, 1, 0, 1, 1) - where - testLabel = "referenceMintingScript" - -referenceDelegation :: IOManager -> [(Text, Text)] -> Assertion -referenceDelegation = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - txs' <- withBabbageLedgerState interpreter $ \st -> do - -- one script referenced and one for the witnesses - tx0 <- - Babbage.mkLockByScriptTx - (UTxOIndex 0) - [Babbage.TxOutInline True Babbage.InlineDatum (Babbage.ReferenceScript True)] - 20000 - 20000 - st - - let utxo0 = head $ Babbage.mkUTxOBabbage tx0 - -- use a reference to an output which has a minting script. - let val0 = MultiAsset $ Map.singleton (PolicyID alwaysSucceedsScriptHash) (Map.singleton (head assetNames) 1) - tx1 <- - Babbage.mkMAssetsScriptTx - [UTxOIndex 0] - (UTxOIndex 1) - [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] - [UTxOPair utxo0] - val0 - True - 100 - st - pure [tx0, tx1] - void $ forgeNextFindLeaderAndSubmit interpreter mockServer (TxBabbage <$> txs') - - assertBlockNoBackoff dbSync 2 - assertBabbageCounts dbSync (1, 1, 1, 1, 1, 0, 0, 0, 1, 1, 0, 1, 1) - where - testLabel = "referenceDelegation" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Other.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Other.hs deleted file mode 100644 index 7c179557e..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Other.hs +++ /dev/null @@ -1,392 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Test.Cardano.Db.Mock.Unit.Babbage.Other ( - -- different configs - configNoPools, - configNoStakes, - -- pools and smash - poolReg, - nonexistantPoolQuery, - poolDeReg, - poolDeRegMany, - poolDelist, - -- hard fork - forkFixedEpoch, - rollbackFork, -) where - -import Cardano.DbSync.Era.Shelley.Generic.Util (unKeyHashRaw) -import Cardano.Ledger.BaseTypes (EpochNo) -import Cardano.Ledger.Credential (StakeCredential) -import Cardano.Ledger.Keys (KeyHash, KeyRole (StakePool)) -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager, addBlock, rollback) -import Cardano.Mock.Forging.Interpreter (forgeNext) -import qualified Cardano.Mock.Forging.Tx.Alonzo as Alonzo -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Tx.Generic (resolvePool) -import Cardano.Mock.Forging.Types ( - ForgingError (..), - PoolIndex (..), - StakeIndex (..), - UTxOIndex (..), - ) -import Cardano.SMASH.Server.PoolDataLayer (PoolDataLayer (..), dbToServantPoolId) -import Cardano.SMASH.Server.Types (DBFail (..)) -import Cardano.Slotting.Slot (EpochNo (..)) -import Control.Concurrent (threadDelay) -import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM (atomically)) -import Control.Exception (try) -import Control.Monad (forM_, void) -import Data.Text (Text) -import Ouroboros.Consensus.Cardano.Block (StandardBabbage, StandardCrypto) -import Ouroboros.Network.Block (blockPoint) -import Test.Cardano.Db.Mock.Config (babbageConfigDir, getPoolLayer, startDBSync, stopDBSync, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.Examples (mockBlock0) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillEpochPercentage, - fillEpochs, - fillUntilNextEpoch, - forgeNextFindLeaderAndSubmit, - getBabbageLedgerState, - withAlonzoFindLeaderAndSubmitTx, - withBabbageFindLeaderAndSubmit, - withBabbageFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate ( - addPoolCounters, - assertBlockNoBackoff, - assertBlocksCount, - assertPoolCounters, - assertPoolLayerCounters, - assertTxCount, - checkStillRuns, - poolCountersQuery, - runQuery, - ) -import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure) - -{- HLINT ignore "Use underscore" -} - ----------------------------------------------------------------------------------------------------------- --- Different Configs ----------------------------------------------------------------------------------------------------------- - -configNoPools :: IOManager -> [(Text, Text)] -> Assertion -configNoPools = - withFullConfig "config2" testLabel $ \_ _ dbSync -> do - startDBSync dbSync - assertBlocksCount dbSync 2 - assertTxCount dbSync 6 - stopDBSync dbSync - startDBSync dbSync - -- Nothing changes, so polling assertions doesn't help here - -- We have to pause and check if anything crashed. - threadDelay 3_000_000 - checkStillRuns dbSync - assertBlocksCount dbSync 2 -- 2 genesis blocks - assertTxCount dbSync 6 - where - testLabel = "configNoPools" - -configNoStakes :: IOManager -> [(Text, Text)] -> Assertion -configNoStakes = - withFullConfig "config3" testLabel $ \interpreter _ dbSync -> do - startDBSync dbSync - assertBlocksCount dbSync 2 - assertTxCount dbSync 7 - stopDBSync dbSync - startDBSync dbSync - -- Nothing changes, so polling assertions don't help here - -- We have to pause and check if anything crashed. - threadDelay 3_000_000 - checkStillRuns dbSync - assertBlocksCount dbSync 2 - assertTxCount dbSync 7 - -- A pool with no stakes can't create a block. - eblk <- try $ forgeNext interpreter mockBlock0 - case eblk of - Right _ -> assertFailure "should fail" - Left WentTooFar {} -> pure () - -- TODO add an option to disable fingerprint validation for tests like this. - Left (EmptyFingerprint _ _) -> pure () - Left err -> assertFailure $ "got " <> show err <> " instead of WentTooFar" - where - testLabel = "configNoStakes" - ----------------------------------------------------------------------------------------------------------- --- Pools and Smash ----------------------------------------------------------------------------------------------------------- - -poolReg :: IOManager -> [(Text, Text)] -> Assertion -poolReg = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - ] - - assertBlockNoBackoff dbSync 2 - assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 0, 1) initCounter) - st <- getBabbageLedgerState interpreter - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - where - testLabel = "poolReg" - --- Issue https://github.com/IntersectMBO/cardano-db-sync/issues/997 -nonexistantPoolQuery :: IOManager -> [(Text, Text)] -> Assertion -nonexistantPoolQuery = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - - st <- getBabbageLedgerState interpreter - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Left RecordDoesNotExist, False, False))] st - where - testLabel = "nonexistantPoolQuery" - -poolDeReg :: IOManager -> [(Text, Text)] -> Assertion -poolDeReg = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - , ([], PoolIndexNew 0, \_ poolId -> ShelleyTxCertPool $ RetirePool poolId (EpochNo 1)) - ] - - assertBlockNoBackoff dbSync 2 - assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 1, 1) initCounter) - - st <- getBabbageLedgerState interpreter - -- Not retired yet, because epoch has not changed - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - - -- change epoch - a <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) - -- these counters are the same - assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 1, 1) initCounter) - - -- the pool is now retired, since the epoch changed. - assertPoolLayerCounters dbSync (1, 0) [(PoolIndexNew 0, (Right True, False, False))] st - where - testLabel = "poolDeReg" - -poolDeRegMany :: IOManager -> [(Text, Text)] -> Assertion -poolDeRegMany = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkDCertPoolTx - [ -- register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - , -- de register - ([], PoolIndexNew 0, mkPoolDereg (EpochNo 4)) - , -- register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - , -- register with different owner and reward address - - ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 0] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - ] - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- - Babbage.mkDCertPoolTx - [ -- register - - ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - ] - st - - tx1 <- - Babbage.mkDCertPoolTx - [ -- deregister - ([] :: [StakeIndex], PoolIndexNew 0, mkPoolDereg (EpochNo 4)) - , -- register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - , -- deregister - ([] :: [StakeIndex], PoolIndexNew 0, mkPoolDereg (EpochNo 1)) - ] - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 3 - -- TODO fix PoolOwner and PoolRelay unique key - assertPoolCounters dbSync (addPoolCounters (1, 5, 5, 10, 3, 5) initCounter) - - st <- getBabbageLedgerState interpreter - -- Not retired yet, because epoch has not changed - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - - -- change epoch - a <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync (fromIntegral $ length a + 3) - -- these counters are the same - assertPoolCounters dbSync (addPoolCounters (1, 5, 5, 10, 3, 5) initCounter) - - -- from all these certificates only the latest matters. So it will retire - -- on epoch 0 - assertPoolLayerCounters dbSync (1, 0) [(PoolIndexNew 0, (Right True, False, False))] st - where - testLabel = "poolDeRegMany" - mkPoolDereg :: - EpochNo -> - [StakeCredential StandardCrypto] -> - KeyHash 'StakePool StandardCrypto -> - ShelleyTxCert StandardBabbage - mkPoolDereg epochNo _creds keyHash = ShelleyTxCertPool $ RetirePool keyHash epochNo - -poolDelist :: IOManager -> [(Text, Text)] -> Assertion -poolDelist = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 1 - initCounter <- runQuery dbSync poolCountersQuery - assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Babbage.consPoolParamsTwoOwners - ) - ] - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 3 - st <- getBabbageLedgerState interpreter - assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] st - - let poolKeyHash = resolvePool (PoolIndexNew 0) st - let poolId = dbToServantPoolId $ unKeyHashRaw poolKeyHash - poolLayer <- getPoolLayer dbSync - void $ dlAddDelistedPool poolLayer poolId - - -- This is not async, so we don't need to do exponential backoff - -- delisted not retired - assertPoolLayerCounters dbSync (0, 1) [(PoolIndexNew 0, (Right False, True, True))] st - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkDCertPoolTx - [([], PoolIndexNew 0, \_ poolHash -> ShelleyTxCertPool $ RetirePool poolHash (EpochNo 1))] - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 5 - -- delisted and pending retirement - assertPoolLayerCounters dbSync (0, 1) [(PoolIndexNew 0, (Right False, True, True))] st - - a <- fillUntilNextEpoch interpreter mockServer - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ 5 + length a + 1) - -- delisted and retired - assertPoolLayerCounters dbSync (1, 1) [(PoolIndexNew 0, (Right True, True, False))] st - where - testLabel = "poolDelist" - ----------------------------------------------------------------------------------------------------------- --- Hard Fork ----------------------------------------------------------------------------------------------------------- - -forkFixedEpoch :: IOManager -> [(Text, Text)] -> Assertion -forkFixedEpoch = - withFullConfigAndDropDB "config-hf-epoch1" testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 - - a <- fillEpochs interpreter mockServer 2 - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 - - b <- fillUntilNextEpoch interpreter mockServer - - assertBlockNoBackoff dbSync $ 2 + length (a <> b) - where - testLabel = "forkFixedEpoch" - -rollbackFork :: IOManager -> [(Text, Text)] -> Assertion -rollbackFork = - withFullConfig "config-hf-epoch1" testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ - withAlonzoFindLeaderAndSubmitTx interpreter mockServer $ - Alonzo.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 - a <- fillUntilNextEpoch interpreter mockServer - b <- fillEpochPercentage interpreter mockServer 85 - c <- fillUntilNextEpoch interpreter mockServer - blk <- - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 - - assertBlockNoBackoff dbSync $ 2 + length (a <> b <> c) - atomically $ rollback mockServer (blockPoint $ last b) - - forM_ (c <> [blk]) $ atomically . addBlock mockServer - - assertBlockNoBackoff dbSync $ 2 + length (a <> b <> c) - where - testLabel = "rollbackFork" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Plutus.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Plutus.hs deleted file mode 100644 index 2135f8056..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Plutus.hs +++ /dev/null @@ -1,508 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeApplications #-} - -#if __GLASGOW_HASKELL__ >= 908 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif - -module Test.Cardano.Db.Mock.Unit.Babbage.Plutus ( - -- plutus spend scripts - simpleScript, - unlockScriptSameBlock, - failedScript, - failedScriptFees, - failedScriptSameBlock, - multipleScripts, - multipleScriptsRollback, - multipleScriptsSameBlock, - multipleScriptsFailed, - multipleScriptsFailedSameBlock, - -- plutus cert scripts - registrationScriptTx, - deregistrationsScriptTx, - deregistrationScriptTx, - deregistrationsScriptTxs, - deregistrationsScriptTx', - deregistrationsScriptTx'', - -- plutus MultiAsset scripts - mintMultiAsset, - mintMultiAssets, - swapMultiAssets, -) where - -import qualified Cardano.Crypto.Hash as Crypto -import qualified Cardano.Db as DB -import qualified Cardano.Db.Schema.Core.TxOut as C -import qualified Cardano.Db.Schema.Variant.TxOut as V -import Cardano.DbSync.Era.Shelley.Generic.Util (renderAddress) -import Cardano.Ledger.Coin -import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..)) -import Cardano.Ledger.Plutus.Data (hashData) -import Cardano.Ledger.SafeHash (extractHash) -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager) -import Cardano.Mock.Forging.Interpreter (withBabbageLedgerState) -import Cardano.Mock.Forging.Tx.Alonzo.ScriptsExamples ( - alwaysMintScriptAddr, - alwaysMintScriptHash, - alwaysSucceedsScriptAddr, - alwaysSucceedsScriptHash, - assetNames, - plutusDataList, - ) -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Types ( - MockBlock (..), - NodeId (..), - StakeIndex (..), - TxEra (..), - UTxOIndex (..), - ) -import Control.Monad (void) -import qualified Data.Map as Map -import Data.Text (Text) -import Ouroboros.Consensus.Cardano.Block (StandardBabbage) -import Ouroboros.Network.Block (genesisPoint) -import Test.Cardano.Db.Mock.Config (babbageConfigDir, startDBSync, txOutTableTypeFromConfig, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillUntilNextEpoch, - forgeNextAndSubmit, - forgeNextFindLeaderAndSubmit, - registerAllStakeCreds, - rollbackTo, - withBabbageFindLeaderAndSubmit, - withBabbageFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate ( - assertAlonzoCounts, - assertBlockNoBackoff, - assertEqQuery, - assertNonZeroFeesContract, - assertScriptCert, - ) -import Test.Tasty.HUnit (Assertion) - ----------------------------------------------------------------------------------------------------------- --- Plutus Spend Scripts ----------------------------------------------------------------------------------------------------------- - -simpleScript :: IOManager -> [(Text, Text)] -> Assertion -simpleScript = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - let txOutTableType = txOutTableTypeFromConfig dbSync - void $ registerAllStakeCreds interpreter mockServer - - a <- fillUntilNextEpoch interpreter mockServer - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline True] 20000 20000 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + 2) - assertEqQuery dbSync (fmap getOutFields <$> DB.queryScriptOutputs txOutTableType) [expectedFields] "Unexpected script outputs" - where - testLabel = "simpleScript" - getOutFields txOutW = - case txOutW of - DB.CTxOutW txOut -> - ( C.txOutAddress txOut - , C.txOutAddressHasScript txOut - , C.txOutValue txOut - , C.txOutDataHash txOut - ) - DB.VTxOutW txOut mAddress -> case mAddress of - Just address -> - ( V.addressAddress address - , V.addressHasScript address - , V.txOutValue txOut - , V.txOutDataHash txOut - ) - Nothing -> error "BabbageSimpleScript: expected an address" - - expectedFields = - ( renderAddress alwaysSucceedsScriptAddr - , True - , DB.DbLovelace 20000 - , Just $ Crypto.hashToBytes (extractHash $ hashData @StandardBabbage plutusDataList) - ) - -unlockScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion -unlockScriptSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline True] 20000 20000 st - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- Babbage.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (1, 1, 1, 1, 1, 1, 0, 0) - where - testLabel = "unlockScriptSameBlock" - -failedScript :: IOManager -> [(Text, Text)] -> Assertion -failedScript = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) - where - testLabel = "failedScript" - -failedScriptFees :: IOManager -> [(Text, Text)] -> Assertion -failedScriptFees = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) - assertNonZeroFeesContract dbSync - where - testLabel = "failedScriptFees" - -failedScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion -failedScriptSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ registerAllStakeCreds interpreter mockServer - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) [Babbage.TxOutNoInline False] 20000 20000 st - let utxo0 = head (Babbage.mkUTxOBabbage tx0) - tx1 <- Babbage.mkUnlockScriptTx [UTxOPair utxo0] (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 1, 0, 1, 1) - where - testLabel = "failedScriptSameBlock" - -multipleScripts :: IOManager -> [(Text, Text)] -> Assertion -multipleScripts = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 - let utxo = Babbage.mkUTxOBabbage tx0 - pair1 = head utxo - pair2 = utxo !! 2 - tx1 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 - - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) - where - testLabel = "multipleScripts" - -multipleScriptsRollback :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsRollback = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 - let utxo = Babbage.mkUTxOBabbage tx0 - pair1 = head utxo - pair2 = utxo !! 2 - tx1 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 - - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) - - rollbackTo interpreter mockServer genesisPoint - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1) - assertBlockNoBackoff dbSync 3 - - assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) - where - testLabel = "multipleScriptsRollback" - -multipleScriptsSameBlock :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 st - let utxo = Babbage.mkUTxOBabbage tx0 - pair1 = head utxo - pair2 = utxo !! 2 - tx1 <- Babbage.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) True 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (1, 2, 1, 1, 3, 2, 0, 0) - where - testLabel = "multipleScriptsSameBlock" - -multipleScriptsFailed :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsFailed = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - tx0 <- withBabbageLedgerState interpreter $ Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx0] (NodeId 1) - - let utxos = Babbage.mkUTxOBabbage tx0 - tx1 <- - withBabbageLedgerState interpreter $ - Babbage.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 - void $ forgeNextAndSubmit interpreter mockServer $ MockBlock [TxBabbage tx1] (NodeId 1) - - assertBlockNoBackoff dbSync 2 - assertAlonzoCounts dbSync (0, 0, 0, 0, 3, 0, 1, 1) - where - testLabel = "multipleScriptsFailed" - -multipleScriptsFailedSameBlock :: IOManager -> [(Text, Text)] -> Assertion -multipleScriptsFailedSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkLockByScriptTx (UTxOIndex 0) (Babbage.TxOutNoInline <$> [True, False, True]) 20000 20000 st - - let utxos = tail $ Babbage.mkUTxOBabbage tx0 - tx1 <- Babbage.mkUnlockScriptTx (UTxOPair <$> [head utxos, utxos !! 1, utxos !! 2]) (UTxOIndex 1) (UTxOIndex 2) False 10000 500 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (0, 0, 0, 0, 3, 0, 1, 1) - where - testLabel = "multipleScriptsFailedSameBlock" - ----------------------------------------------------------------------------------------------------------- --- Plutus Cert Scripts ----------------------------------------------------------------------------------------------------------- - -registrationScriptTx :: IOManager -> [(Text, Text)] -> Assertion -registrationScriptTx = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (0, 0, 0, 1) - where - testLabel = "registrationScriptTx" - -deregistrationScriptTx :: IOManager -> [(Text, Text)] -> Assertion -deregistrationScriptTx = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- Babbage.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (1, 0, 0, 1) - where - testLabel = "deregistrationScriptTx" - -deregistrationsScriptTxs :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTxs = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- Babbage.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st - tx2 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx3 <- Babbage.mkScriptDCertTx [(StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert)] True st - pure [tx0, tx1, Babbage.addValidityInterval 1000 tx2, Babbage.addValidityInterval 2000 tx3] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (2, 0, 0, 1) - assertAlonzoCounts dbSync (1, 2, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTxs" - -deregistrationsScriptTx :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTx = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- - Babbage.mkScriptDCertTx - [ (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - True - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (2, 0, 0, 1) - assertAlonzoCounts dbSync (1, 2, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTx" - --- Like previous but missing a redeemer. This is a known ledger issue -deregistrationsScriptTx' :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTx' = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- - Babbage.mkScriptDCertTx - [ (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - True - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - -- TODO: This is a bug! The first field should be 2. However the deregistrations - -- are missing the redeemers - assertScriptCert dbSync (0, 0, 0, 1) - assertAlonzoCounts dbSync (1, 1, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTx'" - --- Like previous but missing the other redeemer. This is a known ledger issue -deregistrationsScriptTx'' :: IOManager -> [(Text, Text)] -> Assertion -deregistrationsScriptTx'' = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexScript True, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- - Babbage.mkScriptDCertTx - [ (StakeIndexScript True, True, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexScript True, False, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - True - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertScriptCert dbSync (2, 0, 0, 1) - assertAlonzoCounts dbSync (1, 1, 1, 0, 0, 0, 0, 0) - where - testLabel = "deregistrationsScriptTx''" - ----------------------------------------------------------------------------------------------------------- --- Plutus MultiAsset Scripts ----------------------------------------------------------------------------------------------------------- - -mintMultiAsset :: IOManager -> [(Text, Text)] -> Assertion -mintMultiAsset = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ \st -> do - let val0 = MultiAsset $ Map.singleton (PolicyID alwaysMintScriptHash) (Map.singleton (head assetNames) 1) - Babbage.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] [] val0 True 100 st - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (1, 1, 1, 1, 0, 0, 0, 0) - where - testLabel = "mintMultiAsset" - -mintMultiAssets :: IOManager -> [(Text, Text)] -> Assertion -mintMultiAssets = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - let assets0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] - let policy0 = PolicyID alwaysMintScriptHash - let policy1 = PolicyID alwaysSucceedsScriptHash - let val1 = MultiAsset $ Map.fromList [(policy0, assets0), (policy1, assets0)] - tx0 <- Babbage.mkMAssetsScriptTx [UTxOIndex 0] (UTxOIndex 1) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] [] val1 True 100 st - tx1 <- Babbage.mkMAssetsScriptTx [UTxOIndex 2] (UTxOIndex 3) [(UTxOAddressNew 0, MaryValue (Coin 10000) mempty)] [] val1 True 200 st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (2, 4, 1, 2, 0, 0, 0, 0) - where - testLabel = "mintMultiAssets" - -swapMultiAssets :: IOManager -> [(Text, Text)] -> Assertion -swapMultiAssets = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - let assetsMinted0 = Map.fromList [(head assetNames, 10), (assetNames !! 1, 4)] - let policy0 = PolicyID alwaysMintScriptHash - let policy1 = PolicyID alwaysSucceedsScriptHash - let mintValue0 = MultiAsset $ Map.fromList [(policy0, assetsMinted0), (policy1, assetsMinted0)] - let assets0 = Map.fromList [(head assetNames, 5), (assetNames !! 1, 2)] - let outValue0 = MaryValue (Coin 20) $ MultiAsset $ Map.fromList [(policy0, assets0), (policy1, assets0)] - - tx0 <- - Babbage.mkMAssetsScriptTx - [UTxOIndex 0] - (UTxOIndex 1) - [(UTxOAddress alwaysSucceedsScriptAddr, outValue0), (UTxOAddress alwaysMintScriptAddr, outValue0)] - [] - mintValue0 - True - 100 - st - - let utxos = Babbage.mkUTxOBabbage tx0 - tx1 <- - Babbage.mkMAssetsScriptTx - [UTxOPair (head utxos), UTxOPair (utxos !! 1), UTxOIndex 2] - (UTxOIndex 3) - [ (UTxOAddress alwaysSucceedsScriptAddr, outValue0) - , (UTxOAddress alwaysMintScriptAddr, outValue0) - , (UTxOAddressNew 0, outValue0) - , (UTxOAddressNew 0, outValue0) - ] - [] - mintValue0 - True - 200 - st - pure [tx0, tx1] - - assertBlockNoBackoff dbSync 1 - assertAlonzoCounts dbSync (2, 6, 1, 2, 4, 2, 0, 0) - where - testLabel = "swapMultiAssets" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Rollback.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Rollback.hs deleted file mode 100644 index 79ec2843b..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Rollback.hs +++ /dev/null @@ -1,257 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Test.Cardano.Db.Mock.Unit.Babbage.Rollback ( - simpleRollback, - bigChain, - restartAndRollback, - lazyRollback, - lazyRollbackRestart, - doubleRollback, - stakeAddressRollback, - rollbackChangeTxOrder, - rollbackFullTx, -) -where - -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager, addBlock, rollback) -import Cardano.Mock.Forging.Interpreter (forgeNext) -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Tx.Generic (resolvePool) -import Cardano.Mock.Forging.Types (PoolIndex (..), StakeIndex (..), UTxOIndex (..)) -import Control.Concurrent.Class.MonadSTM.Strict (atomically) -import Control.Monad (forM, forM_, void) -import Data.Text (Text) -import Ouroboros.Network.Block (blockPoint) -import Test.Cardano.Db.Mock.Config (babbageConfigDir, startDBSync, stopDBSync, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.Examples (mockBlock0, mockBlock1, mockBlock2) -import Test.Cardano.Db.Mock.UnifiedApi (forgeAndSubmitBlocks, forgeNextAndSubmit, forgeNextFindLeaderAndSubmit, getBabbageLedgerState, rollbackTo, withBabbageFindLeaderAndSubmit, withBabbageFindLeaderAndSubmitTx) -import Test.Cardano.Db.Mock.Validate (assertBlockNoBackoff, assertTxCount) -import Test.Tasty.HUnit (Assertion) - -simpleRollback :: IOManager -> [(Text, Text)] -> Assertion -simpleRollback = do - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - blk0 <- forgeNext interpreter mockBlock0 - blk1 <- forgeNext interpreter mockBlock1 - blk2 <- forgeNext interpreter mockBlock2 - atomically $ addBlock mockServer blk0 - startDBSync dbSync - atomically $ addBlock mockServer blk1 - atomically $ addBlock mockServer blk2 - assertBlockNoBackoff dbSync 3 - - atomically $ rollback mockServer (blockPoint blk1) - assertBlockNoBackoff dbSync 3 -- rollbacks effects are now delayed - where - testLabel = "simpleRollback" - -bigChain :: IOManager -> [(Text, Text)] -> Assertion -bigChain = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - forM_ (replicate 101 mockBlock0) (forgeNextAndSubmit interpreter mockServer) - startDBSync dbSync - assertBlockNoBackoff dbSync 101 - - blks' <- forM (replicate 100 mockBlock1) (forgeNextAndSubmit interpreter mockServer) - assertBlockNoBackoff dbSync 201 - - forM_ (replicate 5 mockBlock2) (forgeNextAndSubmit interpreter mockServer) - assertBlockNoBackoff dbSync 206 - - atomically $ rollback mockServer (blockPoint $ last blks') - assertBlockNoBackoff dbSync 206 - where - testLabel = "bigChain" - -restartAndRollback :: IOManager -> [(Text, Text)] -> Assertion -restartAndRollback = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - forM_ (replicate 101 mockBlock0) (forgeNextAndSubmit interpreter mockServer) - startDBSync dbSync - assertBlockNoBackoff dbSync 101 - - blks <- forM (replicate 100 mockBlock0) (forgeNextAndSubmit interpreter mockServer) - assertBlockNoBackoff dbSync 201 - - forM_ (replicate 5 mockBlock2) (forgeNextAndSubmit interpreter mockServer) - assertBlockNoBackoff dbSync 206 - - stopDBSync dbSync - atomically $ rollback mockServer (blockPoint $ last blks) - startDBSync dbSync - assertBlockNoBackoff dbSync 206 - where - testLabel = "restartAndRollback" - --- wibble -{-} -rollbackFurther :: IOManager -> [(Text, Text)] -> Assertion -rollbackFurther = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - blks <- replicateM 80 (forgeNextFindLeaderAndSubmit interpreter mockServer []) - startDBSync dbSync - assertBlockNoBackoff dbSync 80 - - -- We want to test that db-sync rollbacks temporarily to block 34 - -- and then syncs further. We add references to blocks 34 and 35, to - -- validate later that one is deleted through cascade, but the other was not - -- because a checkpoint was found. - let blockHash1 = hfBlockHash (blks !! 33) - Right bid1 <- queryDBSync dbSync $ DB.queryBlockId blockHash1 - cm1 <- queryDBSync dbSync $ DB.insertAdaPots $ - DB.AdaPots 0 1 (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) bid1 - - let blockHash2 = hfBlockHash (blks !! 34) - Right bid2 <- queryDBSync dbSync $ DB.queryBlockId blockHash2 - cm2 <- queryDBSync dbSync $ DB.insertAdaPots $ - DB.AdaPots 0 1 (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) (DB.DbLovelace 0) bid2 - - -- Note that there is no epoch change, which would add a new entry, since we have - -- 80 blocks and not 100, which is the expected blocks/epoch. This also means there - -- no epoch snapshots - assertEqQuery dbSync DB.queryCostModel [cm1, cm2] "Unexpected CostModels" - - -- server tells db-sync to rollback to point 50. However db-sync only has - -- a snapshot at block 34, so it will go there first. There is no proper way - -- to test that db-sync temporarily is there, that's why we have this trick - -- with references. - atomically $ rollback mockServer (blockPoint $ blks !! 50) - assertBlockNoBackoff dbSync 51 - - assertEqQuery dbSync DB.queryCostModel [cm1] "Unexpected CostModel" - where - testLabel = "rollbackFurther" --} - -lazyRollback :: IOManager -> [(Text, Text)] -> Assertion -lazyRollback = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - lastBlk <- last <$> forgeAndSubmitBlocks interpreter mockServer 200 - void $ forgeAndSubmitBlocks interpreter mockServer 70 - assertBlockNoBackoff dbSync 270 - rollbackTo interpreter mockServer (blockPoint lastBlk) - -- Here we create the fork. - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - void $ forgeAndSubmitBlocks interpreter mockServer 40 - assertBlockNoBackoff dbSync 241 - where - testLabel = "lazyRollback" - -lazyRollbackRestart :: IOManager -> [(Text, Text)] -> Assertion -lazyRollbackRestart = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - lastBlk <- last <$> forgeAndSubmitBlocks interpreter mockServer 220 - void $ forgeAndSubmitBlocks interpreter mockServer 60 - assertBlockNoBackoff dbSync 280 - - stopDBSync dbSync - rollbackTo interpreter mockServer (blockPoint lastBlk) - - startDBSync dbSync - -- Here we create the fork. - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - void $ forgeAndSubmitBlocks interpreter mockServer 30 - assertBlockNoBackoff dbSync 251 - where - testLabel = "lazyRollbackRestart" - -doubleRollback :: IOManager -> [(Text, Text)] -> Assertion -doubleRollback = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - lastBlk1 <- last <$> forgeAndSubmitBlocks interpreter mockServer 150 - lastBlk2 <- last <$> forgeAndSubmitBlocks interpreter mockServer 100 - void $ forgeAndSubmitBlocks interpreter mockServer 100 - assertBlockNoBackoff dbSync 350 - - rollbackTo interpreter mockServer (blockPoint lastBlk2) - -- Here we create the fork. - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - void $ forgeAndSubmitBlocks interpreter mockServer 50 - - rollbackTo interpreter mockServer (blockPoint lastBlk1) - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyRegCert)] - void $ forgeAndSubmitBlocks interpreter mockServer 50 - - assertBlockNoBackoff dbSync 201 - where - testLabel = "doubleRollback" - -stakeAddressRollback :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressRollback = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - blk <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - let poolId = resolvePool (PoolIndex 0) st - tx1 <- - Babbage.mkSimpleDCertTx - [ (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, \stCred -> ShelleyTxCertDelegCert $ ShelleyDelegCert stCred poolId) - ] - st - Right [tx1] - assertBlockNoBackoff dbSync 2 - rollbackTo interpreter mockServer (blockPoint blk) - void $ withBabbageFindLeaderAndSubmitTx interpreter mockServer $ \_ -> - Babbage.mkDummyRegisterTx 1 2 - assertBlockNoBackoff dbSync 2 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync 3 - where - testLabel = "stakeAddressRollback" - -rollbackChangeTxOrder :: IOManager -> [(Text, Text)] -> Assertion -rollbackChangeTxOrder = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - blk0 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - st <- getBabbageLedgerState interpreter - let Right tx0 = Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10000 500 st - let Right tx1 = Babbage.mkPaymentTx (UTxOIndex 2) (UTxOIndex 3) 10000 500 st - let Right tx2 = Babbage.mkPaymentTx (UTxOIndex 4) (UTxOIndex 5) 10000 500 st - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \_st -> - Right [tx0, tx1] - assertBlockNoBackoff dbSync 2 - assertTxCount dbSync 13 - rollbackTo interpreter mockServer $ blockPoint blk0 - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \_st -> - Right [tx1, tx0, tx2] - assertBlockNoBackoff dbSync 2 - assertTxCount dbSync 14 - where - testLabel = "rollbackChangeTxOrder" - -rollbackFullTx :: IOManager -> [(Text, Text)] -> Assertion -rollbackFullTx = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - blk0 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkFullTx 0 100 st - tx1 <- Babbage.mkFullTx 1 200 st - pure [tx0, tx1] - assertBlockNoBackoff dbSync 2 - assertTxCount dbSync 13 - rollbackTo interpreter mockServer $ blockPoint blk0 - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkFullTx 0 100 st - tx1 <- Babbage.mkFullTx 1 200 st - tx2 <- Babbage.mkFullTx 2 200 st - pure [tx1, tx2, tx0] - assertBlockNoBackoff dbSync 2 - assertTxCount dbSync 14 - where - testLabel = "rollbackFullTx" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Stake.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Stake.hs deleted file mode 100644 index 6a7f51a68..000000000 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Stake.hs +++ /dev/null @@ -1,340 +0,0 @@ -module Test.Cardano.Db.Mock.Unit.Babbage.Stake ( - -- stake address - registrationTx, - registrationsSameBlock, - registrationsSameTx, - stakeAddressPtr, - stakeAddressPtrDereg, - stakeAddressPtrUseBefore, - -- stake distribution - stakeDistGenesis, - delegations2000, - delegations2001, - delegations8000, - delegationsMany, - delegationsManyNotDense, -) -where - -import qualified Cardano.Db as DB -import Cardano.Ledger.BaseTypes (CertIx (CertIx), TxIx (TxIx)) -import Cardano.Ledger.Credential (Ptr (..)) -import Cardano.Ledger.Shelley.TxCert -import Cardano.Mock.ChainSync.Server (IOManager, addBlock) -import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage -import Cardano.Mock.Forging.Tx.Babbage.Scenarios (delegateAndSendBlocks) -import Cardano.Mock.Forging.Types (StakeIndex (..), UTxOIndex (..)) -import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM (..)) -import Control.Monad (forM_, replicateM_, void) -import Data.Text (Text) -import Ouroboros.Network.Block (blockSlot) -import Test.Cardano.Db.Mock.Config (babbageConfigDir, startDBSync, withFullConfig, withFullConfigAndDropDB) -import Test.Cardano.Db.Mock.UnifiedApi ( - fillEpochs, - fillUntilNextEpoch, - forgeAndSubmitBlocks, - forgeNextFindLeaderAndSubmit, - forgeNextSkipSlotsFindLeaderAndSubmit, - getBabbageLedgerState, - withBabbageFindLeaderAndSubmit, - withBabbageFindLeaderAndSubmitTx, - ) -import Test.Cardano.Db.Mock.Validate ( - assertAddrValues, - assertBlockNoBackoff, - assertBlockNoBackoffTimes, - assertCertCounts, - assertEpochStake, - assertEpochStakeEpoch, - ) -import Test.Tasty.HUnit (Assertion) - ----------------------------------------------------------------------------------------------------------- --- Stake Address ----------------------------------------------------------------------------------------------------------- - -registrationTx :: IOManager -> [(Text, Text)] -> Assertion -registrationTx = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - - -- We add interval or else the txs would have the same id - void $ - withBabbageFindLeaderAndSubmitTx - interpreter - mockServer - ( fmap (Babbage.addValidityInterval 1000) - . Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - ) - - void $ - withBabbageFindLeaderAndSubmitTx - interpreter - mockServer - ( fmap (Babbage.addValidityInterval 2000) - . Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] - ) - - assertBlockNoBackoff dbSync 4 - assertCertCounts dbSync (2, 2, 0, 0) - where - testLabel = "registrationTx" - -registrationsSameBlock :: IOManager -> [(Text, Text)] -> Assertion -registrationsSameBlock = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx1 <- Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] st - tx2 <- Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] st - tx3 <- Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert)] st - Right [tx0, tx1, Babbage.addValidityInterval 1000 tx2, Babbage.addValidityInterval 2000 tx3] - - assertBlockNoBackoff dbSync 1 - assertCertCounts dbSync (2, 2, 0, 0) - where - testLabel = "registrationsSameBlock" - -registrationsSameTx :: IOManager -> [(Text, Text)] -> Assertion -registrationsSameTx = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx - [ (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert) - , (StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyUnRegCert) - ] - - assertBlockNoBackoff dbSync 1 - assertCertCounts dbSync (2, 2, 0, 0) - where - testLabel = "registrationsSameTx" - -stakeAddressPtr :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressPtr = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - blk <- - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20000 20000 - - assertBlockNoBackoff dbSync 2 - assertCertCounts dbSync (1, 0, 0, 0) - where - testLabel = "stakeAddressPtr" - -stakeAddressPtrDereg :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressPtrDereg = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - blk <- - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyRegCert)] - - let ptr0 = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - - blk' <- withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr0) 20000 20000 st - tx1 <- - Babbage.mkSimpleDCertTx - [ (StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyUnRegCert) - , (StakeIndexNew 0, ShelleyTxCertDelegCert . ShelleyRegCert) - ] - st - pure [tx0, tx1] - - let ptr1 = Ptr (blockSlot blk') (TxIx 1) (CertIx 1) - - void $ withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do - tx0 <- Babbage.mkPaymentTx (UTxOIndex 1) (UTxOAddressNewWithPtr 0 ptr1) 20000 20000 st - tx1 <- Babbage.mkPaymentTx (UTxOIndex 2) (UTxOAddressNewWithPtr 0 ptr0) 20000 20000 st - pure [tx0, tx1] - - st <- getBabbageLedgerState interpreter - assertBlockNoBackoff dbSync 3 - assertCertCounts dbSync (2, 1, 0, 0) - -- The 2 addresses have the same payment credentials and they reference the same - -- stake credentials, however they have - assertAddrValues dbSync (UTxOAddressNewWithPtr 0 ptr0) (DB.DbLovelace 40000) st - assertAddrValues dbSync (UTxOAddressNewWithPtr 0 ptr1) (DB.DbLovelace 20000) st - where - testLabel = "stakeAddressPtrDereg" - -stakeAddressPtrUseBefore :: IOManager -> [(Text, Text)] -> Assertion -stakeAddressPtrUseBefore = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - - -- first use this stake credential - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 1) (UTxOAddressNewWithStake 0 (StakeIndexNew 1)) 10000 500 - - -- and then register it - blk <- - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkSimpleDCertTx [(StakeIndexNew 1, ShelleyTxCertDelegCert . ShelleyRegCert)] - - let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - - void $ - withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20000 20000 - - assertBlockNoBackoff dbSync 3 - assertCertCounts dbSync (1, 0, 0, 0) - where - testLabel = "stakeAddressPtrUseBefore" - ----------------------------------------------------------------------------------------------------------- --- Stake Distribution ----------------------------------------------------------------------------------------------------------- -stakeDistGenesis :: IOManager -> [(Text, Text)] -> Assertion -stakeDistGenesis = - withFullConfigAndDropDB babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- fillUntilNextEpoch interpreter mockServer - assertBlockNoBackoff dbSync (fromIntegral $ length a) - -- There are 5 delegations in genesis - assertEpochStake dbSync 5 - where - testLabel = "stakeDistGenesis" - -delegations2000 :: IOManager -> [(Text, Text)] -> Assertion -delegations2000 = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 1995 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillUntilNextEpoch interpreter mockServer - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) - -- There are exactly 2000 entries on the second epoch, 5 from genesis and 1995 manually added - assertEpochStakeEpoch dbSync 2 2000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 1) - assertEpochStakeEpoch dbSync 2 2000 - where - testLabel = "delegations2000" - -delegations2001 :: IOManager -> [(Text, Text)] -> Assertion -delegations2001 = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 1996 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillUntilNextEpoch interpreter mockServer - c <- forgeAndSubmitBlocks interpreter mockServer 9 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) - assertEpochStakeEpoch dbSync 2 0 - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 1) - assertEpochStakeEpoch dbSync 2 2000 - -- The remaining entry is inserted on the next block. - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c + 2) - assertEpochStakeEpoch dbSync 2 2001 - where - testLabel = "delegations2001" - -delegations8000 :: IOManager -> [(Text, Text)] -> Assertion -delegations8000 = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 7995 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillEpochs interpreter mockServer 2 - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - assertBlockNoBackoff dbSync (fromIntegral $ length a + length b + length c) - assertEpochStakeEpoch dbSync 3 2000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 4000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 6000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 8000 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 3 8000 - where - testLabel = "delegations8000" - -delegationsMany :: IOManager -> [(Text, Text)] -> Assertion -delegationsMany = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 40000 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillEpochs interpreter mockServer 4 - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - -- too long. We cannot use default delays - assertBlockNoBackoffTimes (repeat 10) dbSync (fromIntegral $ length a + length b + length c) - -- The slice size here is - -- 1 + div (delegationsLen * 5) expectedBlocks = 2001 - -- instead of 2000, because there are many delegations - assertEpochStakeEpoch dbSync 7 2001 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 7 4002 - - void $ forgeNextFindLeaderAndSubmit interpreter mockServer [] - assertEpochStakeEpoch dbSync 7 6003 - where - testLabel = "delegationsMany" - -delegationsManyNotDense :: IOManager -> [(Text, Text)] -> Assertion -delegationsManyNotDense = - withFullConfig babbageConfigDir testLabel $ \interpreter mockServer dbSync -> do - startDBSync dbSync - a <- delegateAndSendBlocks 40000 interpreter - forM_ a $ atomically . addBlock mockServer - b <- fillEpochs interpreter mockServer 4 - c <- forgeAndSubmitBlocks interpreter mockServer 10 - - -- too long. We cannot use default delays - assertBlockNoBackoffTimes (repeat 10) dbSync (fromIntegral $ length a + length b + length c) - -- The slice size here is - -- 1 + div (delegationsLen * 5) expectedBlocks = 2001 - -- instead of 2000, because there are many delegations - assertEpochStakeEpoch dbSync 7 2001 - - -- Blocks come on average every 5 slots. If we skip 15 slots before each block, - -- we are expected to get only 1/4 of the expected blocks. The adjusted slices - -- should still be long enough to cover everything. - replicateM_ 40 $ - forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer 15 [] - - -- Even if the chain is sparse, all distributions are inserted. - assertEpochStakeEpoch dbSync 7 40005 - where - testLabel = "delegationsManyNotDense"