Other.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Cardano.Db.Mock.Unit.Conway.Other (
  -- * Different configs
  configNoPools,
  configNoStakes,

  -- * Pools and smash
  poolReg,
  nonexistentPoolQuery,
  poolDeReg,
  poolDeRegMany,
  poolDelist,

  -- * Hard fork
  forkFixedEpoch,
  rollbackFork,
  forkParam,
) where

import qualified Cardano.Db as DB
import Cardano.DbSync.Era.Shelley.Generic.Util (unKeyHashRaw)
import Cardano.Ledger.BaseTypes (EpochNo (..))
import Cardano.Ledger.Conway.TxCert (ConwayTxCert (..))
import Cardano.Ledger.Core (PoolCert (..))
import Cardano.Ledger.Credential (StakeCredential)
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
import Cardano.Mock.ChainSync.Server (IOManager (), addBlock)
import Cardano.Mock.Forging.Interpreter (forgeNext, getCurrentEpoch)
import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage
import qualified Cardano.Mock.Forging.Tx.Conway as Conway
import Cardano.Mock.Forging.Tx.Generic (resolvePool)
import Cardano.Mock.Forging.Types
import Cardano.Prelude hiding (from)
import Cardano.SMASH.Server.PoolDataLayer (PoolDataLayer (..), toDbPoolId)
import Cardano.SMASH.Server.Types (DBFail (..))
import Data.List (last)
import Ouroboros.Consensus.Shelley.Eras (ConwayEra ())
import Ouroboros.Network.Block (blockPoint)
import Test.Cardano.Db.Mock.Config
import Test.Cardano.Db.Mock.Examples (mockBlock0)
import qualified Test.Cardano.Db.Mock.UnifiedApi as Api
import Test.Cardano.Db.Mock.Validate
import Test.Tasty.HUnit (Assertion (), assertEqual, assertFailure)
import Prelude ()

configNoPools :: IOManager -> [(Text, Text)] -> Assertion
configNoPools =
  withFullConfig "config-conway-no-pools" testLabel $ \_ _ dbSync -> do
    startDBSync dbSync

    -- Wait for it to sync
    assertBlocksCount dbSync 2
    assertTxCount dbSync 6

    -- Restart
    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

    -- Verify it's still running
    checkStillRuns dbSync
    -- Verify the initial blocks again
    assertBlocksCount dbSync 2
    assertTxCount dbSync 6
  where
    testLabel = "conwayConfigNoPools"

configNoStakes :: IOManager -> [(Text, Text)] -> Assertion
configNoStakes =
  withFullConfig "config-conway-no-stakes" testLabel $ \interpreter _ dbSync -> do
    startDBSync dbSync

    -- Wait for it to sync
    assertBlocksCount dbSync 2
    assertTxCount dbSync 7

    -- Restart
    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

    -- Verify it's still running
    checkStillRuns dbSync
    -- Verify the initial blocks again
    assertBlocksCount dbSync 2
    assertTxCount dbSync 7

    -- Try to forge a block (expected to fail)
    errBlk <- try $ forgeNext interpreter mockBlock0
    case errBlk of
      Right _ -> assertFailure "expected to fail"
      -- A pool with no stakes can't create blocks
      Left WentTooFar {} -> pure ()
      -- TODO add an option to disable fingerprint validation for tests like this.
      Left (EmptyFingerprint _ _) -> pure ()
      Left err -> assertFailure $ "Expected WentTooFar, got " <> show err
  where
    testLabel = "conwayConfigNoStakes"

poolReg :: IOManager -> [(Text, Text)] -> Assertion
poolReg =
  withFullConfigDropDB conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do
    startDBSync dbSync

    -- Forge a block
    void $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer []
    -- Wait for it to sync
    assertBlockNoBackoff dbSync 1
    -- Verify initial pool counts:
    -- (poolHashes, poolMetadataRefs, poolUpdates, poolOwners, poolRetires, poolRelays)
    initCounter <- runQuery dbSync poolCountersQuery
    assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter

    -- Forge a pool registration
    void $
      Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $
        Conway.mkDCertPoolTx
          [
            ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2]
            , PoolIndexNew 0
            , Conway.consTxCertPool
            )
          ]

    -- Verify pool counts
    assertBlockNoBackoff dbSync 2
    -- We should have added two owners
    assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 0, 1) initCounter)
    state' <- Api.getConwayLedgerState interpreter
    -- Should not be retired or delisted
    assertPoolLayerCounters dbSync (0, 0) [(PoolIndexNew 0, (Right False, False, True))] state'
  where
    testLabel = "conwayPoolReg"

-- Issue https://github.com/IntersectMBO/cardano-db-sync/issues/997
nonexistentPoolQuery :: IOManager -> [(Text, Text)] -> Assertion
nonexistentPoolQuery =
  withFullConfig conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do
    startDBSync dbSync

    -- Forge a block
    void $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer []
    -- Wait for it to sync
    assertBlockNoBackoff dbSync 1

    -- Verify pool layer counts
    state' <- Api.getConwayLedgerState interpreter
    -- Should not exist
    assertPoolLayerCounters
      dbSync
      (0, 0)
      [(PoolIndex 0, (Left RecordDoesNotExist, False, False))]
      state'
  where
    testLabel = "conwayNonexistentPoolQuery"

poolDeReg :: IOManager -> [(Text, Text)] -> Assertion
poolDeReg =
  withFullConfig conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do
    startDBSync dbSync

    -- Forge a block
    void $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer []
    -- Wait for it to sync
    assertBlockNoBackoff dbSync 1
    -- Verify initial pool counts:
    -- (poolHashes, poolMetadataRefs, poolUpdates, poolOwners, poolRetires, poolRelays)
    initCounter <- runQuery dbSync poolCountersQuery
    assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter

    -- Forge a registration/deregistration
    void $
      Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $
        Conway.mkDCertPoolTx
          [ -- Register a pool

            ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2]
            , PoolIndexNew 0
            , Conway.consTxCertPool
            )
          , -- Retire it
            ([], PoolIndexNew 0, \_ poolId -> ConwayTxCertPool $ RetirePool poolId (EpochNo 1))
          ]
    -- Wait for it to sync
    assertBlockNoBackoff dbSync 2
    -- Should have added two pool owners
    assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 1, 1) initCounter)

    state' <- Api.getConwayLedgerState interpreter
    -- Not retired yet, because epoch hasn't changed
    assertPoolLayerCounters
      dbSync
      (0, 0)
      [(PoolIndexNew 0, (Right False, False, True))]
      state'

    -- Get to the next epoch
    blks <- Api.fillUntilNextEpoch interpreter mockServer
    -- Wait for it to sync
    assertBlockNoBackoff dbSync (length blks + 2)
    -- Should not have changed
    assertPoolCounters dbSync (addPoolCounters (1, 1, 1, 2, 1, 1) initCounter)
    -- Should now be retired
    assertPoolLayerCounters
      dbSync
      (1, 0)
      [(PoolIndexNew 0, (Right True, False, False))]
      state'
  where
    testLabel = "conwayPoolDeReg"

poolDeRegMany :: IOManager -> [(Text, Text)] -> Assertion
poolDeRegMany =
  withFullConfig conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do
    startDBSync dbSync

    -- Forge a block
    void $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer []
    -- Wait for it to sync
    assertBlockNoBackoff dbSync 1
    -- Verify initial pool counts
    -- (poolHashes, poolMetadataRefs, poolUpdates, poolOwners, poolRetires, poolRelays)
    initCounter <- runQuery dbSync poolCountersQuery
    assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter

    -- Forge pool registrations and deregistrations
    void $
      Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $
        Conway.mkDCertPoolTx
          [ -- Register

            ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2]
            , PoolIndexNew 0
            , Conway.consTxCertPool
            )
          , -- Deregister
            ([], PoolIndexNew 0, mkPoolDereg (EpochNo 4))
          , -- Register--this will be deduplicated by the ledger, so counts
            -- below will not include this cert

            ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2]
            , PoolIndexNew 0
            , Conway.consTxCertPool
            )
          , -- Register with different owner and reward address

            ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 0]
            , PoolIndexNew 0
            , Conway.consTxCertPool
            )
          ]

    -- Forge another block with more reg/dereg
    void $ Api.withConwayFindLeaderAndSubmit interpreter mockServer $ \state' ->
      sequence
        [ Conway.mkDCertPoolTx
            [ -- Register

              ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 2]
              , PoolIndexNew 0
              , Conway.consTxCertPool
              )
            ]
            state'
        , Conway.mkDCertPoolTx
            [ -- Deregister
              ([], PoolIndexNew 0, mkPoolDereg (EpochNo 4))
            , -- Register

              ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2]
              , PoolIndexNew 0
              , Conway.consTxCertPool
              )
            , -- Deregister
              ([], PoolIndexNew 0, mkPoolDereg (EpochNo 1))
            ]
            state'
        ]

    -- Wait for it to sync
    assertBlockNoBackoff dbSync 3
    -- Verify pool counts
    -- (poolHashes, poolMetadataRefs, poolUpdates, poolOwners, poolRetires, poolRelays)
    -- TODO fix PoolOwner and PoolRelay unique key
    assertPoolCounters dbSync (addPoolCounters (1, 4, 4, 8, 3, 4) initCounter)

    state' <- Api.getConwayLedgerState interpreter
    -- Not retired yet, because epoch hasn't changed
    assertPoolLayerCounters
      dbSync
      (0, 0)
      [(PoolIndexNew 0, (Right False, False, True))]
      state'

    -- Get to the next epoch
    blks <- Api.fillUntilNextEpoch interpreter mockServer
    -- Wait for it to sync
    assertBlockNoBackoff dbSync (length blks + 3)
    -- Pool counts should not have changed
    assertPoolCounters dbSync (addPoolCounters (1, 4, 4, 8, 3, 4) initCounter)
    -- Only the latest certificate matters, so it should be retired in epoch 0
    assertPoolLayerCounters
      dbSync
      (1, 0)
      [(PoolIndexNew 0, (Right True, False, False))]
      state'
  where
    testLabel = "conwayPoolDeRegMany"

poolDelist :: IOManager -> [(Text, Text)] -> Assertion
poolDelist =
  withFullConfig conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do
    startDBSync dbSync

    -- Forge a block
    void $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer []
    -- Wait for it to sync
    assertBlockNoBackoff dbSync 1
    -- Verify initial pool counts
    -- (poolHashes, poolMetadataRefs, poolUpdates, poolOwners, poolRetires, poolRelays)
    initCounter <- runQuery dbSync poolCountersQuery
    assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter

    -- Register a new pool
    void $
      Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $
        Conway.mkDCertPoolTx
          [ -- Register

            ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2]
            , PoolIndexNew 0
            , Conway.consTxCertPool
            )
          ]

    -- Forge another block
    void $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer []
    -- Wait for it to sync
    assertBlockNoBackoff dbSync 3
    -- Should not be retired/delisted
    state' <- Api.getConwayLedgerState interpreter
    assertPoolLayerCounters
      dbSync
      (0, 0)
      [(PoolIndexNew 0, (Right False, False, True))]
      state'

    -- Delist the pool
    let poolKeyHash = resolvePool (PoolIndexNew 0) state'
        poolId = toDbPoolId (unKeyHashRaw poolKeyHash)
    poolLayer <- getPoolLayer dbSync
    void $ dlAddDelistedPool poolLayer poolId

    -- This is not async, so we don't need to do exponential backoff
    -- Should now be delisted
    assertPoolLayerCounters
      dbSync
      (0, 1)
      [(PoolIndexNew 0, (Right False, True, True))]
      state'

    void $
      Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $
        Conway.mkDCertPoolTx [([], PoolIndexNew 0, mkPoolDereg (EpochNo 1))]

    void $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer []
  where
    testLabel = "conwayPoolDelist"

mkPoolDereg ::
  EpochNo ->
  [StakeCredential] ->
  KeyHash 'StakePool ->
  ConwayTxCert ConwayEra
mkPoolDereg epochNo _ keyHash = ConwayTxCertPool (RetirePool keyHash epochNo)

forkFixedEpoch :: IOManager -> [(Text, Text)] -> Assertion
forkFixedEpoch =
  withFullConfigDropDB configDir testLabel $ \interpreter mockServer dbSync -> do
    startDBSync dbSync

    -- Add a Babbage tx
    void $
      Api.withBabbageFindLeaderAndSubmitTx interpreter mockServer $
        Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500

    -- Initiate a hard fork
    epochs0 <- Api.fillEpochs interpreter mockServer 2
    -- Add a simple Conway tx
    void $
      Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $
        Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0
    -- Fill the rest of the epoch
    epochs1 <- Api.fillUntilNextEpoch interpreter mockServer

    -- Verify block count
    assertBlockNoBackoff dbSync $ 2 + length (epochs0 <> epochs1)
  where
    configDir = "config-conway-hf-epoch1"
    testLabel = "conwayForkFixedEpoch"

rollbackFork :: IOManager -> [(Text, Text)] -> Assertion
rollbackFork =
  withFullConfig configDir testLabel $ \interpreter mockServer dbSync -> do
    startDBSync dbSync

    -- Forge a Babbage tx
    void $
      Api.withBabbageFindLeaderAndSubmitTx interpreter mockServer $
        Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500
    -- Fill the rest of the epoch
    epoch0 <- Api.fillUntilNextEpoch interpreter mockServer
    -- Create a point to rollback to
    epoch1 <- Api.fillEpochPercentage interpreter mockServer 85
    -- Fill the rest of the epoch
    epoch1' <- Api.fillUntilNextEpoch interpreter mockServer
    -- Forge a Conway tx
    blk <-
      Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $
        Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0

    -- Wait for it to sync
    assertBlockNoBackoff dbSync $ 1 + length (epoch0 <> epoch1 <> epoch1' <> [blk])
    -- Rollback
    rollbackBlocks <- Api.rollbackTo interpreter mockServer (blockPoint $ last epoch1)
    -- Replay remaining blocks
    forM_ (epoch1' <> [blk]) (atomically . addBlock mockServer)

    -- Verify block count
    assertBlockNoBackoff dbSync $ length (epoch0 <> epoch1 <> rollbackBlocks <> epoch1' <> [blk])
  where
    configDir = "config-conway-hf-epoch1"
    testLabel = "conwayRollbackFork"

forkParam :: IOManager -> [(Text, Text)] -> Assertion
forkParam =
  withFullConfig configDir testLabel $ \interpreter mockServer dbSync -> do
    startDBSync dbSync

    -- Protocol params aren't added to the DB until the following epoch
    epoch0 <- Api.fillUntilNextEpoch interpreter mockServer
    -- Wait for it to sync
    assertBlockNoBackoff dbSync (length epoch0)
    -- Protocol major version should still match config
    assertEqBackoff
      dbSync
      (queryCurrentMajVer interpreter)
      (Just 7)
      []
      "Unexpected protocol major version"

    -- Propose a parameter update
    void $
      Api.withBabbageFindLeaderAndSubmitTx interpreter mockServer $
        const Babbage.mkParamUpdateTx
    -- Wait for it to sync
    assertBlockNoBackoff dbSync (1 + length epoch0)
    -- Query protocol param proposals
    assertEqBackoff
      dbSync
      (queryMajVerProposal interpreter)
      (Just 9)
      []
      "Unexpected protocol major version proposal"

    -- The fork will be applied on the first block of the next epoch
    epoch1 <- Api.fillUntilNextEpoch interpreter mockServer
    -- Wait for it to sync
    assertBlockNoBackoff dbSync $ 1 + length (epoch0 <> epoch1)
    -- Protocol major version should now be updated
    assertEqBackoff
      dbSync
      (queryCurrentMajVer interpreter)
      (Just 9)
      []
      "Unexpected protocol major version"

    -- Add a simple Conway tx
    void $
      Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $
        Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0
    -- Wait for it to sync
    assertBlockNoBackoff dbSync $ 2 + length (epoch0 <> epoch1)
  where
    testLabel = "conwayForkParam"
    configDir = babbageConfigDir
    queryCurrentMajVer interpreter = do
      epochNo <- getEpochNo interpreter
      mEpochParam <- DB.queryEpochParamWithEpochNo epochNo
      pure $ DB.epochParamProtocolMajor <$> mEpochParam
    queryMajVerProposal interpreter = do
      epochNo <- getEpochNo interpreter
      prop <- DB.queryParamProposalWithEpochNo epochNo
      pure (DB.paramProposalProtocolMajor =<< prop)
    getEpochNo = fmap unEpochNo . liftIO . getCurrentEpoch