{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableSuperClasses #-}

-- | Besides capturing all configuration that is necessary to progress to a specific era,
-- this interface also provides fast forward functionality that is used in testing and
-- benchmarking in order to initilize a chain in a particular era without going through
-- the trouble of generating all the history for preceeding eras.
module Cardano.Ledger.Shelley.Transition (
  EraTransition (..),
  tcInitialFundsL,
  tcInitialStakingL,
  mkShelleyTransitionConfig,
  createInitialState,
  registerInitialFundsThenStaking,
  toShelleyTransitionConfigPairs,
  protectMainnet,
  protectMainnetLens,
) where

import Cardano.Ledger.Address
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.CertState
import Cardano.Ledger.Coin
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.Crypto
import Cardano.Ledger.EpochBoundary
import Cardano.Ledger.Genesis (EraGenesis)
import Cardano.Ledger.Keys
import Cardano.Ledger.PoolDistr
import Cardano.Ledger.Shelley.Era
import Cardano.Ledger.Shelley.Genesis
import Cardano.Ledger.Shelley.Governance
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Translation (
  FromByronTranslationContext (..),
  toFromByronTranslationContext,
 )
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.UTxO
import Cardano.Ledger.Val
import Data.Aeson (FromJSON (..), KeyValue (..), ToJSON (..), object, pairs, withObject, (.:))
import Data.Default.Class
import Data.Kind
import qualified Data.ListMap as LM
import qualified Data.ListMap as ListMap
import qualified Data.Map.Strict as Map
import Data.Void (Void)
import GHC.Generics (Generic)
import GHC.Stack
import Lens.Micro
import NoThunks.Class (NoThunks (..))

class
  ( EraTxOut era
  , EraGov era
  , EraGenesis era
  , ToJSON (TransitionConfig era)
  , FromJSON (TransitionConfig era)
  , Default (StashedAVVMAddresses era)
  ) =>
  EraTransition era
  where
  -- | Cumulative configuration that is needed to be able to start in a current era
  data TransitionConfig era :: Type

  mkTransitionConfig ::
    -- | Translation context necessary for advancing from previous era into the current
    -- one. This will usually be the contents of genesis file, if one exists for the
    -- current era
    TranslationContext era ->
    -- | Transition configuration for the previous era.
    TransitionConfig (PreviousEra era) ->
    TransitionConfig era

  injectIntoTestState ::
    -- | Extract data from the given transition configuration and store it in the given state.
    --
    -- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
    -- when 'NetworkId' is set to 'Mainnet'.
    TransitionConfig era ->
    NewEpochState era ->
    NewEpochState era

  -- | In case when a previous era is available, we should always be able to access
  -- `TransitionConfig` for the previous era, from within the current era's
  -- `TransitionConfig`
  tcPreviousEraConfigL ::
    EraTransition (PreviousEra era) =>
    Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))

  -- | Lens for the `TranslationContext` for the current era from the `TransitionConfig`
  -- Translation context is a different name for the Genesis type for each era, they are
  -- one and the same concept.
  tcTranslationContextL ::
    Lens' (TransitionConfig era) (TranslationContext era)

  -- | Lens for the `ShelleyGenesis` from the `TransitionConfig`. Default implementation
  -- looks in the previous era's config
  tcShelleyGenesisL :: Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
  default tcShelleyGenesisL ::
    (EraTransition (PreviousEra era), EraCrypto (PreviousEra era) ~ EraCrypto era) =>
    Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
  tcShelleyGenesisL = forall era.
(EraTransition era, EraTransition (PreviousEra era)) =>
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
tcPreviousEraConfigL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTransition era =>
Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
tcShelleyGenesisL

  -- | Get the initial PParams for the current era from the `TransitionConfig`. Note that
  -- this is only useful for testing and fast forward functionality, because this function
  -- assumes no on-chain changes to PParams through PParamsUpdate functionality.
  --
  -- Default implementation will use the PParams from the Previous era and the current
  -- `TranslationContext` to construct PParams for the current era.
  --
  -- /Warning/ - Should only be used in testing and benchmarking
  tcInitialPParamsG :: SimpleGetter (TransitionConfig era) (PParams era)
  default tcInitialPParamsG ::
    ( EraTransition (PreviousEra era)
    , TranslateEra era PParams
    , TranslationError era PParams ~ Void
    ) =>
    SimpleGetter (TransitionConfig era) (PParams era)
  tcInitialPParamsG =
    forall s a. (s -> a) -> SimpleGetter s a
to forall a b. (a -> b) -> a -> b
$ \TransitionConfig era
tc ->
      forall era (f :: * -> *).
(TranslateEra era f, TranslationError era f ~ Void) =>
TranslationContext era -> f (PreviousEra era) -> f era
translateEra'
        (TransitionConfig era
tc forall s a. s -> Getting a s a -> a
^. forall era.
EraTransition era =>
Lens' (TransitionConfig era) (TranslationContext era)
tcTranslationContextL)
        (TransitionConfig era
tc forall s a. s -> Getting a s a -> a
^. forall era.
(EraTransition era, EraTransition (PreviousEra era)) =>
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
tcPreviousEraConfigL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTransition era =>
SimpleGetter (TransitionConfig era) (PParams era)
tcInitialPParamsG)

tcNetworkIDG :: EraTransition era => SimpleGetter (TransitionConfig era) Network
tcNetworkIDG :: forall era.
EraTransition era =>
SimpleGetter (TransitionConfig era) Network
tcNetworkIDG = forall era.
EraTransition era =>
Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
tcShelleyGenesisL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to forall c. ShelleyGenesis c -> Network
sgNetworkId

registerInitialFundsThenStaking ::
  EraTransition era =>
  TransitionConfig era ->
  NewEpochState era ->
  NewEpochState era
registerInitialFundsThenStaking :: forall era.
EraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialFundsThenStaking TransitionConfig era
cfg =
  -- We must first register the initial funds, because the stake
  -- information depends on it.
  forall era.
(HasCallStack, EraTransition era) =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialStaking TransitionConfig era
cfg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(EraTransition era, HasCallStack) =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialFunds TransitionConfig era
cfg

instance Crypto c => EraTransition (ShelleyEra c) where
  newtype TransitionConfig (ShelleyEra c) = ShelleyTransitionConfig
    { forall c. TransitionConfig (ShelleyEra c) -> ShelleyGenesis c
stcShelleyGenesis :: ShelleyGenesis c
    }
    deriving (TransitionConfig (ShelleyEra c)
-> TransitionConfig (ShelleyEra c) -> Bool
forall c.
Crypto c =>
TransitionConfig (ShelleyEra c)
-> TransitionConfig (ShelleyEra c) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransitionConfig (ShelleyEra c)
-> TransitionConfig (ShelleyEra c) -> Bool
$c/= :: forall c.
Crypto c =>
TransitionConfig (ShelleyEra c)
-> TransitionConfig (ShelleyEra c) -> Bool
== :: TransitionConfig (ShelleyEra c)
-> TransitionConfig (ShelleyEra c) -> Bool
$c== :: forall c.
Crypto c =>
TransitionConfig (ShelleyEra c)
-> TransitionConfig (ShelleyEra c) -> Bool
Eq, Int -> TransitionConfig (ShelleyEra c) -> ShowS
forall c.
Crypto c =>
Int -> TransitionConfig (ShelleyEra c) -> ShowS
forall c. Crypto c => [TransitionConfig (ShelleyEra c)] -> ShowS
forall c. Crypto c => TransitionConfig (ShelleyEra c) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransitionConfig (ShelleyEra c)] -> ShowS
$cshowList :: forall c. Crypto c => [TransitionConfig (ShelleyEra c)] -> ShowS
show :: TransitionConfig (ShelleyEra c) -> String
$cshow :: forall c. Crypto c => TransitionConfig (ShelleyEra c) -> String
showsPrec :: Int -> TransitionConfig (ShelleyEra c) -> ShowS
$cshowsPrec :: forall c.
Crypto c =>
Int -> TransitionConfig (ShelleyEra c) -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (TransitionConfig (ShelleyEra c)) x
-> TransitionConfig (ShelleyEra c)
forall c x.
TransitionConfig (ShelleyEra c)
-> Rep (TransitionConfig (ShelleyEra c)) x
$cto :: forall c x.
Rep (TransitionConfig (ShelleyEra c)) x
-> TransitionConfig (ShelleyEra c)
$cfrom :: forall c x.
TransitionConfig (ShelleyEra c)
-> Rep (TransitionConfig (ShelleyEra c)) x
Generic)

  mkTransitionConfig :: TranslationContext (ShelleyEra c)
-> TransitionConfig (PreviousEra (ShelleyEra c))
-> TransitionConfig (ShelleyEra c)
mkTransitionConfig =
    forall a. HasCallStack => String -> a
error String
"Impossible: There is no EraTransition instance for ByronEra"

  injectIntoTestState :: TransitionConfig (ShelleyEra c)
-> NewEpochState (ShelleyEra c) -> NewEpochState (ShelleyEra c)
injectIntoTestState = forall era.
EraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialFundsThenStaking

  tcPreviousEraConfigL :: EraTransition (PreviousEra (ShelleyEra c)) =>
Lens'
  (TransitionConfig (ShelleyEra c))
  (TransitionConfig (PreviousEra (ShelleyEra c)))
tcPreviousEraConfigL = forall a b. HasCallStack => Lens' a b
notSupportedInThisEraL

  tcTranslationContextL :: Lens'
  (TransitionConfig (ShelleyEra c))
  (TranslationContext (ShelleyEra c))
tcTranslationContextL =
    forall era.
EraTransition era =>
Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
tcShelleyGenesisL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c. ShelleyGenesis c -> FromByronTranslationContext c
toFromByronTranslationContext forall {c}.
ShelleyGenesis c
-> FromByronTranslationContext c -> ShelleyGenesis c
setFBTC
    where
      setFBTC :: ShelleyGenesis c
-> FromByronTranslationContext c -> ShelleyGenesis c
setFBTC ShelleyGenesis c
shelleyGenesis FromByronTranslationContext {Word64
Map (KeyHash 'Genesis c) (GenDelegPair c)
PParams (ShelleyEra c)
fbtcMaxLovelaceSupply :: forall c. FromByronTranslationContext c -> Word64
fbtcProtocolParams :: forall c. FromByronTranslationContext c -> PParams (ShelleyEra c)
fbtcGenDelegs :: forall c.
FromByronTranslationContext c
-> Map (KeyHash 'Genesis c) (GenDelegPair c)
fbtcMaxLovelaceSupply :: Word64
fbtcProtocolParams :: PParams (ShelleyEra c)
fbtcGenDelegs :: Map (KeyHash 'Genesis c) (GenDelegPair c)
..} =
        ShelleyGenesis c
shelleyGenesis
          { sgGenDelegs :: Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs = Map (KeyHash 'Genesis c) (GenDelegPair c)
fbtcGenDelegs
          , sgProtocolParams :: PParams (ShelleyEra c)
sgProtocolParams = PParams (ShelleyEra c)
fbtcProtocolParams
          , sgMaxLovelaceSupply :: Word64
sgMaxLovelaceSupply = Word64
fbtcMaxLovelaceSupply
          }

  tcShelleyGenesisL :: Lens'
  (TransitionConfig (ShelleyEra c))
  (ShelleyGenesis (EraCrypto (ShelleyEra c)))
tcShelleyGenesisL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c. TransitionConfig (ShelleyEra c) -> ShelleyGenesis c
stcShelleyGenesis (\TransitionConfig (ShelleyEra c)
tc ShelleyGenesis c
sg -> TransitionConfig (ShelleyEra c)
tc {stcShelleyGenesis :: ShelleyGenesis c
stcShelleyGenesis = ShelleyGenesis c
sg})

  tcInitialPParamsG :: SimpleGetter
  (TransitionConfig (ShelleyEra c)) (PParams (ShelleyEra c))
tcInitialPParamsG = forall s a. (s -> a) -> SimpleGetter s a
to (forall c. ShelleyGenesis c -> PParams (ShelleyEra c)
sgProtocolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. TransitionConfig (ShelleyEra c) -> ShelleyGenesis c
stcShelleyGenesis)

-- | Get the initial funds from the `TransitionConfig`. This value must be non-empty
-- only during testing and benchmarking, it must never contain anything on a real system.
--
-- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
-- when NetworkId is set to Mainnet
tcInitialFundsL ::
  (HasCallStack, EraTransition era) =>
  Lens' (TransitionConfig era) (LM.ListMap (Addr (EraCrypto era)) Coin)
tcInitialFundsL :: forall era.
(HasCallStack, EraTransition era) =>
Lens' (TransitionConfig era) (ListMap (Addr (EraCrypto era)) Coin)
tcInitialFundsL =
  forall era a.
(HasCallStack, EraTransition era) =>
String
-> (a -> Bool)
-> Lens' (TransitionConfig era) a
-> Lens' (TransitionConfig era) a
protectMainnetLens String
"InitialFunds" forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$
    forall era.
EraTransition era =>
Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
tcShelleyGenesisL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Lens' (ShelleyGenesis c) (ListMap (Addr c) Coin)
sgInitialFundsL

-- | Get the initial staking from the `TransitionConfig`. This value must be non-empty
-- only during testing and benchmarking, it must never contain anything on a real system.
--
-- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
-- when NetworkId is set to Mainnet
tcInitialStakingL ::
  (HasCallStack, EraTransition era) =>
  Lens' (TransitionConfig era) (ShelleyGenesisStaking (EraCrypto era))
tcInitialStakingL :: forall era.
(HasCallStack, EraTransition era) =>
Lens'
  (TransitionConfig era) (ShelleyGenesisStaking (EraCrypto era))
tcInitialStakingL =
  forall era a.
(HasCallStack, EraTransition era) =>
String
-> (a -> Bool)
-> Lens' (TransitionConfig era) a
-> Lens' (TransitionConfig era) a
protectMainnetLens String
"InitialStaking" (forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$
    forall era.
EraTransition era =>
Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
tcShelleyGenesisL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Lens' (ShelleyGenesis c) (ShelleyGenesisStaking c)
sgStakingL

-- | Constructor for the base Shelley `TransitionConfig`
mkShelleyTransitionConfig :: ShelleyGenesis c -> TransitionConfig (ShelleyEra c)
mkShelleyTransitionConfig :: forall c. ShelleyGenesis c -> TransitionConfig (ShelleyEra c)
mkShelleyTransitionConfig = forall c. ShelleyGenesis c -> TransitionConfig (ShelleyEra c)
ShelleyTransitionConfig

protectMainnetLens ::
  (HasCallStack, EraTransition era) =>
  String ->
  (a -> Bool) ->
  Lens' (TransitionConfig era) a ->
  Lens' (TransitionConfig era) a
protectMainnetLens :: forall era a.
(HasCallStack, EraTransition era) =>
String
-> (a -> Bool)
-> Lens' (TransitionConfig era) a
-> Lens' (TransitionConfig era) a
protectMainnetLens String
name a -> Bool
isMainnetSafe Lens' (TransitionConfig era) a
l =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (\TransitionConfig era
g -> forall era a.
(HasCallStack, EraTransition era) =>
String -> TransitionConfig era -> (a -> Bool) -> a -> a
protectMainnet String
name TransitionConfig era
g a -> Bool
isMainnetSafe forall a b. (a -> b) -> a -> b
$ TransitionConfig era
g forall s a. s -> Getting a s a -> a
^. Lens' (TransitionConfig era) a
l)
    (\TransitionConfig era
g a
x -> TransitionConfig era
g forall a b. a -> (a -> b) -> b
& Lens' (TransitionConfig era) a
l forall s t a b. ASetter s t a b -> b -> s -> t
.~ a
x)

protectMainnet ::
  (HasCallStack, EraTransition era) =>
  String ->
  TransitionConfig era ->
  (a -> Bool) ->
  a ->
  a
protectMainnet :: forall era a.
(HasCallStack, EraTransition era) =>
String -> TransitionConfig era -> (a -> Bool) -> a -> a
protectMainnet String
name TransitionConfig era
g a -> Bool
isMainnetSafe a
m =
  if TransitionConfig era
g forall s a. s -> Getting a s a -> a
^. forall era.
EraTransition era =>
SimpleGetter (TransitionConfig era) Network
tcNetworkIDG forall a. Eq a => a -> a -> Bool
== Network
Mainnet Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
isMainnetSafe a
m)
    then forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Injection of " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" is not possible on Mainnet"
    else a
m

deriving instance Crypto c => NoThunks (TransitionConfig (ShelleyEra c))

instance Crypto c => ToJSON (TransitionConfig (ShelleyEra c)) where
  toJSON :: TransitionConfig (ShelleyEra c) -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a c.
(KeyValue e a, Crypto c) =>
TransitionConfig (ShelleyEra c) -> [a]
toShelleyTransitionConfigPairs
  toEncoding :: TransitionConfig (ShelleyEra c) -> Encoding
toEncoding = Series -> Encoding
pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a c.
(KeyValue e a, Crypto c) =>
TransitionConfig (ShelleyEra c) -> [a]
toShelleyTransitionConfigPairs

instance Crypto c => FromJSON (TransitionConfig (ShelleyEra c)) where
  parseJSON :: Value -> Parser (TransitionConfig (ShelleyEra c))
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ShelleyTransitionConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    ShelleyGenesis c
sg <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"shelley"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ShelleyTransitionConfig {stcShelleyGenesis :: ShelleyGenesis c
stcShelleyGenesis = ShelleyGenesis c
sg}

toShelleyTransitionConfigPairs ::
  (KeyValue e a, Crypto c) =>
  TransitionConfig (ShelleyEra c) ->
  [a]
toShelleyTransitionConfigPairs :: forall e a c.
(KeyValue e a, Crypto c) =>
TransitionConfig (ShelleyEra c) -> [a]
toShelleyTransitionConfigPairs stc :: TransitionConfig (ShelleyEra c)
stc@(ShelleyTransitionConfig ShelleyGenesis c
_) =
  [Key
"shelley" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object (forall e a c. (KeyValue e a, Crypto c) => ShelleyGenesis c -> [a]
toShelleyGenesisPairs (forall c. TransitionConfig (ShelleyEra c) -> ShelleyGenesis c
stcShelleyGenesis TransitionConfig (ShelleyEra c)
stc))]

-- | Helper function for constructing the initial state for any era
--
-- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
-- when NetworkId is set to Mainnet
--
-- This function does not register any initial funds or delegates.
createInitialState ::
  forall era.
  (EraTransition era, HasCallStack) =>
  TransitionConfig era ->
  NewEpochState era
createInitialState :: forall era.
(EraTransition era, HasCallStack) =>
TransitionConfig era -> NewEpochState era
createInitialState TransitionConfig era
tc =
  forall era a.
(HasCallStack, EraTransition era) =>
String -> TransitionConfig era -> (a -> Bool) -> a -> a
protectMainnet
    String
"InitialState"
    TransitionConfig era
tc
    (forall a b. a -> b -> a
const Bool
False)
    NewEpochState
      { nesEL :: EpochNo
nesEL = EpochNo
initialEpochNo
      , nesBprev :: BlocksMade (EraCrypto era)
nesBprev = forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
BlocksMade forall k a. Map k a
Map.empty
      , nesBcur :: BlocksMade (EraCrypto era)
nesBcur = forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
BlocksMade forall k a. Map k a
Map.empty
      , nesEs :: EpochState era
nesEs =
          EpochState
            { esAccountState :: AccountState
esAccountState = Coin -> Coin -> AccountState
AccountState forall t. Val t => t
zero Coin
reserves
            , esSnapshots :: SnapShots (EraCrypto era)
esSnapshots = forall c. SnapShots c
emptySnapShots
            , esLState :: LedgerState era
esLState =
                LedgerState
                  { lsUTxOState :: UTxOState era
lsUTxOState =
                      forall era.
EraTxOut era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState PParams era
pp UTxO era
initialUtxo forall t. Val t => t
zero forall t. Val t => t
zero GovState era
govState forall t. Val t => t
zero
                  , lsCertState :: CertState era
lsCertState =
                      CertState
                        { certDState :: DState era
certDState = DState era
dState {dsGenDelegs :: GenDelegs (EraCrypto era)
dsGenDelegs = forall c. Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
GenDelegs (forall c.
ShelleyGenesis c -> Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs ShelleyGenesis (EraCrypto era)
sg)}
                        , certPState :: PState era
certPState = forall a. Default a => a
def
                        , certVState :: VState era
certVState = forall a. Default a => a
def
                        }
                  }
            , esNonMyopic :: NonMyopic (EraCrypto era)
esNonMyopic = forall a. Default a => a
def
            }
      , nesRu :: StrictMaybe (PulsingRewUpdate (EraCrypto era))
nesRu = forall a. StrictMaybe a
SNothing
      , nesPd :: PoolDistr (EraCrypto era)
nesPd = forall c.
Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-> CompactForm Coin -> PoolDistr c
PoolDistr forall k a. Map k a
Map.empty forall a. Monoid a => a
mempty
      , stashedAVVMAddresses :: StashedAVVMAddresses era
stashedAVVMAddresses = forall a. Default a => a
def
      }
  where
    dState :: DState era
    dState :: DState era
dState = forall a. Default a => a
def
    govState :: GovState era
    govState :: GovState era
govState =
      forall era. EraGov era => GovState era
emptyGovState
        forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (GovState era) (PParams era)
curPParamsGovStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
pp
        forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (GovState era) (PParams era)
prevPParamsGovStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
pp
    pp :: PParams era
    pp :: PParams era
pp = TransitionConfig era
tc forall s a. s -> Getting a s a -> a
^. forall era.
EraTransition era =>
SimpleGetter (TransitionConfig era) (PParams era)
tcInitialPParamsG
    sg :: ShelleyGenesis (EraCrypto era)
    sg :: ShelleyGenesis (EraCrypto era)
sg = TransitionConfig era
tc forall s a. s -> Getting a s a -> a
^. forall era.
EraTransition era =>
Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
tcShelleyGenesisL
    initialEpochNo :: EpochNo
    initialEpochNo :: EpochNo
initialEpochNo = Word64 -> EpochNo
EpochNo Word64
0
    initialUtxo :: UTxO era
    initialUtxo :: UTxO era
initialUtxo = forall a. Monoid a => a
mempty
    reserves :: Coin
    reserves :: Coin
reserves = Word64 -> Coin
word64ToCoin (forall c. ShelleyGenesis c -> Word64
sgMaxLovelaceSupply ShelleyGenesis (EraCrypto era)
sg) forall t. Val t => t -> t -> t
<-> forall era. EraTxOut era => UTxO era -> Coin
coinBalance UTxO era
initialUtxo

-- | Register the initial staking information in the 'NewEpochState'.
--
-- HERE BE DRAGONS! This function is intended to help in testing.
--
-- In production, the genesis should /not/ contain any initial staking.
--
-- Any existing staking information is overridden, but the UTxO is left
-- untouched.
--
-- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
-- when NetworkId is set to Mainnet
registerInitialStaking ::
  forall era.
  (HasCallStack, EraTransition era) =>
  TransitionConfig era ->
  NewEpochState era ->
  NewEpochState era
registerInitialStaking :: forall era.
(HasCallStack, EraTransition era) =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialStaking TransitionConfig era
tc NewEpochState era
nes =
  NewEpochState era
nes
    { nesEs :: EpochState era
nesEs =
        EpochState era
epochState
          { esLState :: LedgerState era
esLState =
              LedgerState era
ledgerState
                { lsCertState :: CertState era
lsCertState =
                    CertState era
dpState
                      { certDState :: DState era
certDState = DState era
dState'
                      , certPState :: PState era
certPState = PState era
pState'
                      }
                }
          , esSnapshots :: SnapShots (EraCrypto era)
esSnapshots =
              (forall era. EpochState era -> SnapShots (EraCrypto era)
esSnapshots EpochState era
epochState)
                { $sel:ssStakeMark:SnapShots :: SnapShot (EraCrypto era)
ssStakeMark = SnapShot (EraCrypto era)
initSnapShot
                , $sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr (EraCrypto era)
ssStakeMarkPoolDistr = forall c. SnapShot c -> PoolDistr c
calculatePoolDistr SnapShot (EraCrypto era)
initSnapShot
                }
          }
    , -- 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.
      nesPd :: PoolDistr (EraCrypto era)
nesPd = forall c. SnapShot c -> PoolDistr c
calculatePoolDistr SnapShot (EraCrypto era)
initSnapShot
    }
  where
    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} = TransitionConfig era
tc forall s a. s -> Getting a s a -> a
^. forall era.
(HasCallStack, EraTransition era) =>
Lens'
  (TransitionConfig era) (ShelleyGenesisStaking (EraCrypto era))
tcInitialStakingL
    NewEpochState {nesEs :: forall era. NewEpochState era -> EpochState era
nesEs = EpochState era
epochState} = NewEpochState era
nes
    ledgerState :: LedgerState era
ledgerState = forall era. EpochState era -> LedgerState era
esLState EpochState era
epochState
    dpState :: CertState era
dpState = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ledgerState

    -- New delegation state. Since we're using base addresses, we only care
    -- about updating the '_delegations' field.
    --
    -- See STS DELEG for details
    dState' :: DState era
    dState' :: DState era
dState' =
      (forall era. CertState era -> DState era
certDState CertState era
dpState)
        { 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 a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (Word64 -> CompactForm Coin
CompactCoin Word64
0) (Word64 -> CompactForm Coin
CompactCoin Word64
0))
                  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 a b. (a -> b) -> a -> b
$ Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
sgsStakeMap
              )
              forall a. Monoid a => a
mempty
              (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 Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
sgsStakeMap)
              forall a. Monoid a => a
mempty
        }
      where
        sgsStakeMap :: Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
sgsStakeMap = forall k v. Ord k => ListMap k v -> Map k v
ListMap.toMap ListMap
  (KeyHash 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
sgsStake

    -- We consider pools as having been registered in slot 0
    -- See STS POOL for details
    pState' :: PState era
    pState' :: PState era
pState' =
      (forall era. CertState era -> PState era
certPState CertState era
dpState)
        { psStakePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams = forall k v. Ord k => ListMap k v -> Map k v
ListMap.toMap ListMap
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
sgsPools
        }

    pp :: PParams era
pp = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL

    -- 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 :: SnapShot (EraCrypto era)
initSnapShot =
      -- Since we build a stake from nothing, we first initialise an
      -- 'IncrementalStake' as empty, and then:
      --
      -- 1. Add the initial UTxO, whilst deleting nothing.
      -- 2. Update the stake map given the initial delegation.
      forall era.
EraPParams era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> DState era
-> PState era
-> SnapShot (EraCrypto era)
incrementalStakeDistr
        PParams era
pp
        -- Note that 'updateStakeDistribution' takes first the set of UTxO to
        -- delete, and then the set to add. In our case, there is nothing to
        -- delete, since this is an initial UTxO set.
        (forall era.
EraTxOut era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> UTxO era
-> UTxO era
-> IncrementalStake (EraCrypto era)
updateStakeDistribution PParams era
pp forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty (forall era. UTxOState era -> UTxO era
utxosUtxo (forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ledgerState)))
        DState era
dState'
        PState era
pState'

-- | Register the initial funds in the 'NewEpochState'.
--
-- HERE BE DRAGONS! This function is intended to help in testing.
--
-- In production, the genesis should /not/ contain any initial funds.
--
-- The given funds are /added/ to the existing UTxO.
--
-- PRECONDITION: the given funds must not be part of the existing UTxO.
-- > forall (addr, _) in initialFunds.
-- >    Map.notElem (initialFundsPseudoTxIn addr) existingUTxO
--
-- PROPERTY:
-- >    genesisUTxO genesis
-- > == <genesisUTxO'> (sgInitialFunds genesis)
-- > == <extractUTxO> (registerInitialFunds (sgInitialFunds genesis)
-- >                                        <empty NewEpochState>)
--
-- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
-- when NetworkId is set to Mainnet
registerInitialFunds ::
  forall era.
  ( EraTransition era
  , HasCallStack
  ) =>
  TransitionConfig era ->
  NewEpochState era ->
  NewEpochState era
registerInitialFunds :: forall era.
(EraTransition era, HasCallStack) =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialFunds TransitionConfig era
tc NewEpochState era
nes =
  NewEpochState era
nes
    { nesEs :: EpochState era
nesEs =
        EpochState era
epochState
          { esAccountState :: AccountState
esAccountState = AccountState
accountState'
          , esLState :: LedgerState era
esLState = LedgerState era
ledgerState'
          }
    }
  where
    epochState :: EpochState era
epochState = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    accountState :: AccountState
accountState = forall era. EpochState era -> AccountState
esAccountState EpochState era
epochState
    ledgerState :: LedgerState era
ledgerState = forall era. EpochState era -> LedgerState era
esLState EpochState era
epochState
    utxoState :: UTxOState era
utxoState = forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ledgerState
    utxo :: UTxO era
utxo = forall era. UTxOState era -> UTxO era
utxosUtxo UTxOState era
utxoState
    reserves :: Coin
reserves = AccountState -> Coin
asReserves AccountState
accountState

    initialFundsUtxo :: UTxO era
    initialFundsUtxo :: UTxO era
initialFundsUtxo =
      forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (TxIn (EraCrypto era)
txIn, TxOut era
txOut)
          | (Addr (EraCrypto era)
addr, Coin
amount) <- forall k v. ListMap k v -> [(k, v)]
ListMap.toList (TransitionConfig era
tc forall s a. s -> Getting a s a -> a
^. forall era.
(HasCallStack, EraTransition era) =>
Lens' (TransitionConfig era) (ListMap (Addr (EraCrypto era)) Coin)
tcInitialFundsL)
          , let txIn :: TxIn (EraCrypto era)
txIn = forall c. Crypto c => Addr c -> TxIn c
initialFundsPseudoTxIn Addr (EraCrypto era)
addr
                txOut :: TxOut era
txOut = forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr (EraCrypto era)
addr (forall t s. Inject t s => t -> s
inject Coin
amount)
          ]

    utxo' :: UTxO era
utxo' = HasCallStack => UTxO era -> UTxO era -> UTxO era
mergeUtxoNoOverlap UTxO era
utxo UTxO era
initialFundsUtxo

    -- Update the reserves
    accountState' :: AccountState
accountState' =
      AccountState
accountState
        { asReserves :: Coin
asReserves = Coin
reserves forall t. Val t => t -> t -> t
<-> forall t. Val t => t -> Coin
coin (forall era. EraTxOut era => UTxO era -> Value era
balance UTxO era
initialFundsUtxo)
        }

    -- Since we only add entries to our UTxO, rather than spending them, there
    -- is nothing to delete in the incremental update.
    utxoToDel :: UTxO era
utxoToDel = forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO forall a. Monoid a => a
mempty
    ledgerState' :: LedgerState era
ledgerState' =
      LedgerState era
ledgerState
        { lsUTxOState :: UTxOState era
lsUTxOState =
            UTxOState era
utxoState
              { utxosUtxo :: UTxO era
utxosUtxo = UTxO era
utxo'
              , -- Normally we would incrementally update here. But since we pass
                -- the full UTxO as "toAdd" rather than a delta, we simply
                -- reinitialise the full incremental stake.
                utxosStakeDistr :: IncrementalStake (EraCrypto era)
utxosStakeDistr =
                  forall era.
EraTxOut era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> UTxO era
-> UTxO era
-> IncrementalStake (EraCrypto era)
updateStakeDistribution
                    (NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL)
                    forall a. Monoid a => a
mempty
                    forall {era}. UTxO era
utxoToDel
                    UTxO era
utxo'
              }
        }

    -- Merge two UTxOs, throw an 'error' in case of overlap
    mergeUtxoNoOverlap ::
      HasCallStack =>
      UTxO era ->
      UTxO era ->
      UTxO era
    mergeUtxoNoOverlap :: HasCallStack => UTxO era -> UTxO era -> UTxO era
mergeUtxoNoOverlap (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
m1) (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
m2) =
      forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
        forall k a.
Ord k =>
(k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWithKey
          (\TxIn (EraCrypto era)
k TxOut era
_ TxOut era
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"initial fund part of UTxO: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TxIn (EraCrypto era)
k)
          Map (TxIn (EraCrypto era)) (TxOut era)
m1
          Map (TxIn (EraCrypto era)) (TxOut era)
m2