{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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, incrementalStakeDistr)
import Cardano.Ledger.Shelley.Rules (
  BbodyEnv,
  ShelleyBbodyState,
 )
import Cardano.Ledger.Slot (
  BlockNo (..),
  EpochNo (..),
  SlotNo (..),
 )
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val ((<->))
import qualified Cardano.Ledger.Val as 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 (Mock)
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
  , Mock (EraCrypto 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 (EraCrypto era)) 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 era)
  ) =>
  HasTrace (CHAIN era) (GenEnv era)
  where
  envGen :: HasCallStack => GenEnv era -> Gen (Environment (CHAIN era))
envGen GenEnv era
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  sigGen :: HasCallStack =>
GenEnv era
-> Environment (CHAIN era)
-> State (CHAIN era)
-> Gen (Signal (CHAIN era))
sigGen GenEnv era
ge Environment (CHAIN era)
_env State (CHAIN era)
st = forall era.
(MinLEDGER_STS era, ApplyBlock era, Mock (EraCrypto era),
 GetLedgerView era, HasTrace (EraRule "LEDGERS" era) (GenEnv era),
 EraGen era) =>
GenEnv era
-> ChainState era -> Gen (Block (BHeader (EraCrypto era)) era)
genBlock GenEnv era
ge State (CHAIN 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 = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT BaseM (CHAIN era) a
act 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. Era era => proxy era -> HashHeader (EraCrypto era)
lastByronHeaderHash :: forall (proxy :: * -> *) era.
Era era =>
proxy era -> HashHeader (EraCrypto era)
lastByronHeaderHash proxy era
_ = forall c. Hash c EraIndependentBlockHeader -> HashHeader c
HashHeader forall a b. (a -> b) -> a -> b
$ 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.
  ( EraGen era
  , EraGov era
  ) =>
  GenEnv era ->
  IRC (CHAIN era) ->
  Gen (Either a (ChainState era))
mkGenesisChainState :: forall era a.
(EraGen era, EraGov era) =>
GenEnv era -> IRC (CHAIN era) -> Gen (Either a (ChainState era))
mkGenesisChainState ge :: GenEnv era
ge@(GenEnv KeySpace era
_ ScriptSpace era
_ Constants
constants) (IRC Environment (CHAIN era)
_slotNo) = do
  UTxO era
utxo0 <- forall era. EraGen era => GenEnv era -> Gen (UTxO era)
genUtxo0 GenEnv era
ge

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

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h. ChainState h -> ChainState h
withRewards forall a b. (a -> b) -> a -> b
$
    forall era.
(EraTxOut era, EraGov era, Default (StashedAVVMAddresses era)) =>
WithOrigin (LastAppliedBlock (EraCrypto era))
-> EpochNo
-> UTxO era
-> Coin
-> Map
     (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
-> PParams era
-> Nonce
-> ChainState era
initialShelleyState @era
      (forall t. t -> WithOrigin t
At forall a b. (a -> b) -> a -> b
$ forall c. BlockNo -> SlotNo -> HashHeader c -> LastAppliedBlock c
LastAppliedBlock (Word64 -> BlockNo
BlockNo Word64
0) (Word64 -> SlotNo
SlotNo Word64
0) (forall (proxy :: * -> *) era.
Era era =>
proxy era -> HashHeader (EraCrypto era)
lastByronHeaderHash Proxy era
p))
      EpochNo
epoch0
      UTxO era
utxo0
      (Coin
maxLLSupply forall t. Val t => t -> t -> t
<-> forall t. Val t => t -> Coin
Val.coin (forall era. EraTxOut era => UTxO era -> Value era
balance UTxO era
utxo0))
      Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
delegs0
      PParams era
pParams
      (forall c. HashHeader c -> Nonce
hashHeaderToNonce (forall (proxy :: * -> *) era.
Era era =>
proxy era -> HashHeader (EraCrypto era)
lastByronHeaderHash Proxy era
p))
  where
    epoch0 :: EpochNo
epoch0 = Word64 -> EpochNo
EpochNo Word64
0
    delegs0 :: Map
  (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
delegs0 = forall c.
Crypto c =>
Constants -> Map (KeyHash 'Genesis c) (GenDelegPair c)
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 (EraCrypto h)) Word64
Nonce
WithOrigin (LastAppliedBlock (EraCrypto h))
NewEpochState h
chainLastAppliedBlock :: forall era.
ChainState era -> WithOrigin (LastAppliedBlock (EraCrypto era))
chainPrevEpochNonce :: forall era. ChainState era -> Nonce
chainCandidateNonce :: forall era. ChainState era -> Nonce
chainEvolvingNonce :: forall era. ChainState era -> Nonce
chainEpochNonce :: forall era. ChainState era -> Nonce
chainOCertIssue :: forall era.
ChainState era -> Map (KeyHash 'BlockIssuer (EraCrypto era)) Word64
chainNes :: forall era. ChainState era -> NewEpochState era
chainLastAppliedBlock :: WithOrigin (LastAppliedBlock (EraCrypto h))
chainPrevEpochNonce :: Nonce
chainCandidateNonce :: Nonce
chainEvolvingNonce :: Nonce
chainEpochNonce :: Nonce
chainOCertIssue :: Map (KeyHash 'BlockIssuer (EraCrypto h)) Word64
chainNes :: NewEpochState h
..} =
      ChainState h
st
        { chainNes :: NewEpochState h
chainNes =
            NewEpochState h
chainNes
              { nesEs :: EpochState h
nesEs =
                  (forall era. NewEpochState era -> EpochState era
nesEs NewEpochState h
chainNes)
                    { esAccountState :: AccountState
esAccountState =
                        (forall era. EpochState era -> AccountState
esAccountState (forall era. NewEpochState era -> EpochState era
nesEs NewEpochState h
chainNes))
                          { asTreasury :: Coin
asTreasury = Integer -> Coin
Coin Integer
1000000
                          }
                    }
              }
        }
    p :: Proxy era
    p :: Proxy era
p = forall {k} (t :: k). Proxy t
Proxy

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

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

      newChainNes :: NewEpochState era
newChainNes =
        NewEpochState era
oldChainNes
          { nesEs :: EpochState era
nesEs = EpochState era
newEpochState
          , nesPd :: PoolDistr (EraCrypto era)
nesPd = PoolDistr (EraCrypto era)
newPoolDistr
          }
      newEpochState :: EpochState era
newEpochState =
        EpochState era
oldEpochState
          { esLState :: LedgerState era
esLState = LedgerState era
newLedgerState
          , esSnapshots :: SnapShots (EraCrypto era)
esSnapshots =
              (forall era. EpochState era -> SnapShots (EraCrypto era)
esSnapshots EpochState era
oldEpochState)
                { $sel:ssStakeMark:SnapShots :: SnapShot (EraCrypto era)
ssStakeMark = SnapShot (EraCrypto era)
initSnapShot
                , $sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr (EraCrypto era)
ssStakeMarkPoolDistr = PoolDistr (EraCrypto era)
newPoolDistr
                }
          }
      newLedgerState :: LedgerState era
newLedgerState =
        LedgerState era
oldLedgerState
          { lsCertState :: CertState era
lsCertState = CertState era
newCertState
          }
      newCertState :: CertState era
newCertState =
        CertState era
oldCertState
          { certDState :: DState era
certDState = DState era
newDState
          , certPState :: PState era
certPState = 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 :: DState era
newDState =
        (forall era. CertState era -> DState era
certDState CertState era
oldCertState)
          { dsUnified :: UMap (EraCrypto era)
dsUnified =
              forall c.
Map (Credential 'Staking c) RDPair
-> Map Ptr (Credential 'Staking c)
-> Map (Credential 'Staking c) (KeyHash 'StakePool c)
-> Map (Credential 'Staking c) (DRep c)
-> UMap c
UM.unify
                (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall {p}. p -> RDPair
pairWithDepositsButNoRewards forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => ListMap k v -> Map k v
LM.toMap forall a b. (a -> b) -> a -> b
$ ListMap
  (KeyHash 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
sgsStake)
                (forall c. UMap c -> Map Ptr (Credential 'Staking c)
UM.ptrMap (forall era. DState era -> UMap (EraCrypto era)
dsUnified (forall era. CertState era -> DState era
certDState CertState era
oldCertState)))
                (forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall a b. (a -> b) -> a -> b
$ forall k v. Ord k => ListMap k v -> Map k v
LM.toMap ListMap
  (KeyHash 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
sgsStake)
                forall k a. Map k a
Map.empty
          }

      -- We consider pools as having been registered in slot 0
      -- See STS POOL for details
      newPState :: PState era
      newPState :: PState era
newPState =
        (forall era. CertState era -> PState era
certPState CertState era
oldCertState)
          { psStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams = forall k v. Ord k => ListMap k v -> Map k v
LM.toMap ListMap
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
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 (EraCrypto era)
initSnapShot =
        forall era.
EraPParams era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> DState era
-> PState era
-> SnapShot (EraCrypto era)
incrementalStakeDistr
          (EpochState era
newEpochState forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL)
          (forall era. UTxOState era -> IncrementalStake (EraCrypto era)
utxosStakeDistr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> UTxOState era
lsUTxOState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall a b. (a -> b) -> a -> b
$ EpochState era
oldEpochState)
          DState era
newDState
          PState era
newPState