{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- Allow for an orphan HasTrace instance for CHAIN, since HasTrace only pertains to tests
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Shelley.Generator.Trace.Chain where

import Cardano.Ledger.BHeaderView (BHeaderView (..))
import Cardano.Ledger.Shelley.API
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL)
import Cardano.Ledger.Shelley.Rules (
  BbodyEnv,
  ShelleyBbodyState,
 )
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Slot (
  BlockNo (..),
  EpochNo (..),
  SlotNo (..),
 )
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val ((<->))
import Cardano.Protocol.TPraos.API
import Cardano.Protocol.TPraos.BHeader (
  HashHeader (..),
  LastAppliedBlock (..),
  hashHeaderToNonce,
 )
import Cardano.Protocol.TPraos.Rules.Tickn (
  TicknEnv,
  TicknState,
 )
import Cardano.Slotting.Slot (WithOrigin (..))
import Control.Monad.Trans.Reader (runReaderT)
import Control.State.Transition
import Data.Functor.Identity (runIdentity)
import qualified Data.ListMap as LM
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
import Lens.Micro ((&), (.~), (^.))
import Lens.Micro.Extras (view)
import Numeric.Natural (Natural)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Generator.Block (genBlock)
import Test.Cardano.Ledger.Shelley.Generator.Core (GenEnv (..))
import Test.Cardano.Ledger.Shelley.Generator.EraGen (
  EraGen (..),
  MinCHAIN_STS,
  MinLEDGER_STS,
  genUtxo0,
 )
import Test.Cardano.Ledger.Shelley.Generator.Presets (genesisDelegs0)
import Test.Cardano.Ledger.Shelley.Rules.Chain (
  CHAIN,
  ChainState (..),
  initialShelleyState,
 )
import qualified Test.Cardano.Ledger.Shelley.Rules.Chain as STS (ChainState (ChainState))
import Test.Cardano.Ledger.Shelley.Utils (maxLLSupply, mkHash)
import Test.Control.State.Transition.Trace.Generator.QuickCheck (
  BaseEnv,
  HasTrace,
  envGen,
  interpretSTS,
  sigGen,
 )
import qualified Test.Control.State.Transition.Trace.Generator.QuickCheck as QC
import Test.QuickCheck (Gen)

-- ======================================================

-- The CHAIN STS at the root of the STS allows for generating blocks of transactions
-- with meaningful delegation certificates, protocol and application updates, withdrawals etc.
instance
  ( EraGen era
  , EraSegWits era
  , ApplyBlock era
  , GetLedgerView era
  , MinLEDGER_STS era
  , MinCHAIN_STS era
  , Embed (EraRule "BBODY" era) (CHAIN era)
  , Environment (EraRule "BBODY" era) ~ BbodyEnv era
  , State (EraRule "BBODY" era) ~ ShelleyBbodyState era
  , Signal (EraRule "BBODY" era) ~ Block BHeaderView era
  , Embed (EraRule "TICKN" era) (CHAIN era)
  , Environment (EraRule "TICKN" era) ~ TicknEnv
  , State (EraRule "TICKN" era) ~ TicknState
  , Signal (EraRule "TICKN" era) ~ Bool
  , Embed (EraRule "TICK" era) (CHAIN era)
  , Environment (EraRule "TICK" era) ~ ()
  , State (EraRule "TICK" era) ~ NewEpochState era
  , Signal (EraRule "TICK" era) ~ SlotNo
  , QC.HasTrace (EraRule "LEDGERS" era) (GenEnv MockCrypto era)
  ) =>
  HasTrace (CHAIN era) (GenEnv MockCrypto era)
  where
  envGen :: HasCallStack =>
GenEnv MockCrypto era -> Gen (Environment (CHAIN era))
envGen GenEnv MockCrypto era
_ = () -> Gen ()
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  sigGen :: HasCallStack =>
GenEnv MockCrypto era
-> Environment (CHAIN era)
-> State (CHAIN era)
-> Gen (Signal (CHAIN era))
sigGen GenEnv MockCrypto era
ge Environment (CHAIN era)
_env State (CHAIN era)
st = GenEnv MockCrypto era
-> ChainState era -> Gen (Block (BHeader MockCrypto) era)
forall era c.
(MinLEDGER_STS era, ApplyBlock era, GetLedgerView era,
 HasTrace (EraRule "LEDGERS" era) (GenEnv c era), EraGen era,
 PraosCrypto c) =>
GenEnv c era -> ChainState era -> Gen (Block (BHeader c) era)
genBlock GenEnv MockCrypto era
ge State (CHAIN era)
ChainState era
st

  shrinkSignal :: HasCallStack => Signal (CHAIN era) -> [Signal (CHAIN era)]
shrinkSignal = (\Signal (CHAIN era)
_x -> []) -- shrinkBlock -- TO DO FIX ME

  type BaseEnv (CHAIN era) = Globals
  interpretSTS :: forall a.
HasCallStack =>
BaseEnv (CHAIN era) -> BaseM (CHAIN era) a -> a
interpretSTS BaseEnv (CHAIN era)
globals BaseM (CHAIN era) a
act = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> Identity a -> a
forall a b. (a -> b) -> a -> b
$ ReaderT Globals Identity a -> Globals -> Identity a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Globals Identity a
BaseM (CHAIN era) a
act Globals
BaseEnv (CHAIN era)
globals

-- | The first block of the Shelley era will point back to the last block of the Byron era.
-- For our purposes we can bootstrap the chain by just coercing the value.
-- When this transition actually occurs, the consensus layer will do the work of making
-- sure that the hash gets translated across the fork
lastByronHeaderHash :: forall proxy era. proxy era -> HashHeader
lastByronHeaderHash :: forall (proxy :: * -> *) era. proxy era -> HashHeader
lastByronHeaderHash proxy era
_ = Hash HASH EraIndependentBlockHeader -> HashHeader
HashHeader (Hash HASH EraIndependentBlockHeader -> HashHeader)
-> Hash HASH EraIndependentBlockHeader -> HashHeader
forall a b. (a -> b) -> a -> b
$ Int -> Hash HASH EraIndependentBlockHeader
forall a h. HashAlgorithm h => Int -> Hash h a
mkHash Int
0

-- Note: this function must be usable in place of 'applySTS' and needs to align
-- with the signature 'RuleContext sts -> Gen (Either [[PredicateFailure sts]] (State sts))'.
-- To achieve this we (1) use 'IRC CHAIN' (the "initial rule context") instead of simply 'Chain Env'
-- and (2) always return Right (since this function does not raise predicate failures).
mkGenesisChainState ::
  forall era a c.
  ( EraGen era
  , EraGov era
  , EraStake era
  ) =>
  GenEnv c era ->
  IRC (CHAIN era) ->
  Gen (Either a (ChainState era))
mkGenesisChainState :: forall era a c.
(EraGen era, EraGov era, EraStake era) =>
GenEnv c era -> IRC (CHAIN era) -> Gen (Either a (ChainState era))
mkGenesisChainState ge :: GenEnv c era
ge@(GenEnv KeySpace c era
_ ScriptSpace era
_ Constants
constants) (IRC Environment (CHAIN era)
_slotNo) = do
  UTxO era
utxo0 <- GenEnv c era -> Gen (UTxO era)
forall era c. EraGen era => GenEnv c era -> Gen (UTxO era)
genUtxo0 GenEnv c era
ge

  PParams era
pParams <- forall era. EraGen era => Constants -> Gen (PParams era)
genEraPParams @era Constants
constants

  Either a (ChainState era) -> Gen (Either a (ChainState era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a (ChainState era) -> Gen (Either a (ChainState era)))
-> (ChainState era -> Either a (ChainState era))
-> ChainState era
-> Gen (Either a (ChainState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState era -> Either a (ChainState era)
forall a b. b -> Either a b
Right (ChainState era -> Either a (ChainState era))
-> (ChainState era -> ChainState era)
-> ChainState era
-> Either a (ChainState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState era -> ChainState era
forall h. ChainState h -> ChainState h
withRewards (ChainState era -> Gen (Either a (ChainState era)))
-> ChainState era -> Gen (Either a (ChainState era))
forall a b. (a -> b) -> a -> b
$
    forall era.
(EraGov era, EraStake era, EraCertState era,
 Default (StashedAVVMAddresses era)) =>
WithOrigin LastAppliedBlock
-> EpochNo
-> UTxO era
-> Coin
-> Map (KeyHash 'Genesis) GenDelegPair
-> PParams era
-> Nonce
-> ChainState era
initialShelleyState @era
      (LastAppliedBlock -> WithOrigin LastAppliedBlock
forall t. t -> WithOrigin t
At (LastAppliedBlock -> WithOrigin LastAppliedBlock)
-> LastAppliedBlock -> WithOrigin LastAppliedBlock
forall a b. (a -> b) -> a -> b
$ BlockNo -> SlotNo -> HashHeader -> LastAppliedBlock
LastAppliedBlock (Word64 -> BlockNo
BlockNo Word64
0) (Word64 -> SlotNo
SlotNo Word64
0) (Proxy era -> HashHeader
forall (proxy :: * -> *) era. proxy era -> HashHeader
lastByronHeaderHash Proxy era
p))
      EpochNo
epoch0
      UTxO era
utxo0
      (Coin
maxLLSupply Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> UTxO era -> Coin
forall era. EraTxOut era => UTxO era -> Coin
sumCoinUTxO UTxO era
utxo0)
      Map (KeyHash 'Genesis) GenDelegPair
delegs0
      PParams era
pParams
      (HashHeader -> Nonce
hashHeaderToNonce (Proxy era -> HashHeader
forall (proxy :: * -> *) era. proxy era -> HashHeader
lastByronHeaderHash Proxy era
p))
  where
    epoch0 :: EpochNo
epoch0 = Word64 -> EpochNo
EpochNo Word64
0
    delegs0 :: Map (KeyHash 'Genesis) GenDelegPair
delegs0 = Constants -> Map (KeyHash 'Genesis) GenDelegPair
genesisDelegs0 Constants
constants
    -- We preload the initial state with some Treasury to enable generation
    -- of things dependent on Treasury (e.g. MIR Treasury certificates)
    withRewards :: ChainState h -> ChainState h
    withRewards :: forall h. ChainState h -> ChainState h
withRewards st :: ChainState h
st@STS.ChainState {Map (KeyHash 'BlockIssuer) Word64
WithOrigin LastAppliedBlock
Nonce
NewEpochState h
chainNes :: NewEpochState h
chainOCertIssue :: Map (KeyHash 'BlockIssuer) Word64
chainEpochNonce :: Nonce
chainEvolvingNonce :: Nonce
chainCandidateNonce :: Nonce
chainPrevEpochNonce :: Nonce
chainLastAppliedBlock :: WithOrigin LastAppliedBlock
chainNes :: forall era. ChainState era -> NewEpochState era
chainOCertIssue :: forall era. ChainState era -> Map (KeyHash 'BlockIssuer) Word64
chainEpochNonce :: forall era. ChainState era -> Nonce
chainEvolvingNonce :: forall era. ChainState era -> Nonce
chainCandidateNonce :: forall era. ChainState era -> Nonce
chainPrevEpochNonce :: forall era. ChainState era -> Nonce
chainLastAppliedBlock :: forall era. ChainState era -> WithOrigin LastAppliedBlock
..} =
      ChainState h
st
        { chainNes =
            chainNes
              { nesEs =
                  (nesEs chainNes)
                    { esChainAccountState =
                        (esChainAccountState (nesEs chainNes))
                          { casTreasury = Coin 1000000
                          }
                    }
              }
        }
    p :: Proxy era
    p :: Proxy era
p = Proxy era
forall {k} (t :: k). Proxy t
Proxy

mkOCertIssueNos ::
  GenDelegs ->
  Map (KeyHash 'BlockIssuer) Natural
mkOCertIssueNos :: GenDelegs -> Map (KeyHash 'BlockIssuer) Natural
mkOCertIssueNos (GenDelegs Map (KeyHash 'Genesis) GenDelegPair
delegs0) =
  [(KeyHash 'BlockIssuer, Natural)]
-> Map (KeyHash 'BlockIssuer) Natural
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((GenDelegPair -> (KeyHash 'BlockIssuer, Natural))
-> [GenDelegPair] -> [(KeyHash 'BlockIssuer, Natural)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenDelegPair -> (KeyHash 'BlockIssuer, Natural)
forall {b} {r' :: KeyRole}.
Num b =>
GenDelegPair -> (KeyHash r', b)
f (Map (KeyHash 'Genesis) GenDelegPair -> [GenDelegPair]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash 'Genesis) GenDelegPair
delegs0))
  where
    f :: GenDelegPair -> (KeyHash r', b)
f (GenDelegPair KeyHash 'GenesisDelegate
vk VRFVerKeyHash 'GenDelegVRF
_) = (KeyHash 'GenesisDelegate -> KeyHash r'
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'GenesisDelegate
vk, b
0)

-- Register the initial staking.
--
-- This allows stake pools to produce blocks from genesis.
registerGenesisStaking ::
  (EraGov era, EraStake era, EraCertState era) =>
  ShelleyGenesisStaking ->
  ChainState era ->
  ChainState era
registerGenesisStaking :: forall era.
(EraGov era, EraStake era, EraCertState era) =>
ShelleyGenesisStaking -> ChainState era -> ChainState era
registerGenesisStaking
  ShelleyGenesisStaking {ListMap (KeyHash 'StakePool) PoolParams
sgsPools :: ListMap (KeyHash 'StakePool) PoolParams
sgsPools :: ShelleyGenesisStaking -> ListMap (KeyHash 'StakePool) PoolParams
sgsPools, ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake :: ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake :: ShelleyGenesisStaking
-> ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake}
  cs :: ChainState era
cs@STS.ChainState {chainNes :: forall era. ChainState era -> NewEpochState era
chainNes = NewEpochState era
oldChainNes} =
    ChainState era
cs
      { chainNes = newChainNes
      }
    where
      keyDeposit :: UM.CompactForm Coin
      keyDeposit :: CompactForm Coin
keyDeposit = (HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
UM.compactCoinOrError (Coin -> CompactForm Coin)
-> (NewEpochState era -> Coin)
-> NewEpochState era
-> CompactForm Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Coin (PParams era) Coin -> PParams era -> Coin
forall a s. Getting a s a -> s -> a
view Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL (PParams era -> Coin)
-> (NewEpochState era -> PParams era) -> NewEpochState era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (PParams era) (EpochState era) (PParams era)
-> EpochState era -> PParams era
forall a s. Getting a s a -> s -> a
view Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL (EpochState era -> PParams era)
-> (NewEpochState era -> EpochState era)
-> NewEpochState era
-> PParams era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
oldChainNes
      oldEpochState :: EpochState era
oldEpochState = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
oldChainNes
      oldLedgerState :: LedgerState era
oldLedgerState = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
oldEpochState
      oldCertState :: CertState era
oldCertState = LedgerState era -> CertState era
forall era. LedgerState era -> CertState era
lsCertState LedgerState era
oldLedgerState

      -- Note that this is only applicable in the initial configuration where
      -- there is no existing stake distribution, since it would completely
      -- overwrite any such thing.
      newPoolDistr :: PoolDistr
newPoolDistr = SnapShot -> PoolDistr
calculatePoolDistr SnapShot
initSnapShot

      newChainNes :: NewEpochState era
newChainNes =
        NewEpochState era
oldChainNes
          { nesEs = newEpochState
          , nesPd = newPoolDistr
          }
      newEpochState :: EpochState era
newEpochState =
        EpochState era
oldEpochState
          { esLState = newLedgerState
          , esSnapshots =
              (esSnapshots oldEpochState)
                { ssStakeMark = initSnapShot
                , ssStakeMarkPoolDistr = newPoolDistr
                }
          }
      newLedgerState :: LedgerState era
newLedgerState =
        LedgerState era
oldLedgerState
          { lsCertState = newCertState
          }
      newCertState :: CertState era
newCertState =
        CertState era
oldCertState
          CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> DState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DState era
newDState
          CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (PState era -> Identity (PState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Identity (PState era))
 -> CertState era -> Identity (CertState era))
-> PState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PState era
newPState
      -- New delegation state. Since we're using base addresses, we only care
      -- about updating the 'ssDelegations' field.
      --
      -- See STS DELEG for details
      pairWithDepositsButNoRewards :: p -> RDPair
pairWithDepositsButNoRewards p
_ = CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (Word64 -> CompactForm Coin
UM.CompactCoin Word64
0) CompactForm Coin
keyDeposit
      newDState :: DState era
newDState =
        (CertState era
oldCertState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL)
          { dsUnified =
              UM.unify
                (Map.map pairWithDepositsButNoRewards . Map.mapKeys KeyHashObj . LM.toMap $ sgsStake)
                (UM.ptrMap (oldCertState ^. certDStateL . dsUnifiedL))
                (Map.mapKeys KeyHashObj $ LM.toMap sgsStake)
                Map.empty
          }

      -- We consider pools as having been registered in slot 0
      -- See STS POOL for details
      newPState :: PState era
newPState =
        (CertState era
oldCertState CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL)
          { psStakePoolParams = LM.toMap sgsPools
          }

      -- The new stake distribution is made on the basis of a snapshot taken
      -- during the previous epoch. We create a "fake" snapshot in order to
      -- establish an initial stake distribution.
      initSnapShot :: SnapShot
initSnapShot =
        InstantStake era -> DState era -> PState era -> SnapShot
forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> SnapShot
snapShotFromInstantStake (EpochState era
oldEpochState EpochState era
-> Getting (InstantStake era) (EpochState era) (InstantStake era)
-> InstantStake era
forall s a. s -> Getting a s a -> a
^. Getting (InstantStake era) (EpochState era) (InstantStake era)
forall era. SimpleGetter (EpochState era) (InstantStake era)
forall (t :: * -> *) era.
CanGetInstantStake t =>
SimpleGetter (t era) (InstantStake era)
instantStakeG) DState era
newDState PState era
newPState