{-# LANGUAGE DataKinds               #-}
{-# LANGUAGE DuplicateRecordFields   #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE GADTs                   #-}
{-# LANGUAGE MultiParamTypeClasses   #-}
{-# LANGUAGE NamedFieldPuns          #-}
{-# LANGUAGE OverloadedStrings       #-}
{-# LANGUAGE PolyKinds               #-}
{-# LANGUAGE RecordWildCards         #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# LANGUAGE TypeApplications        #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE TypeOperators           #-}
{-# LANGUAGE UndecidableInstances    #-}
{-# LANGUAGE UndecidableSuperClasses #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Node.TPraos (
    MaxMajorProtVer (..)
  , ProtocolParamsAllegra (..)
  , ProtocolParamsAlonzo (..)
  , ProtocolParamsMary (..)
  , ProtocolParamsShelley (..)
  , ProtocolParamsShelleyBased (..)
  , SL.Nonce (..)
  , SL.ProtVer (..)
  , SL.ShelleyGenesis (..)
  , SL.ShelleyGenesisStaking (..)
  , SL.emptyGenesisStaking
  , ShelleyLeaderCredentials (..)
  , protocolInfoShelley
  , protocolInfoTPraosShelleyBased
  , registerGenesisStaking
  , registerInitialFunds
  , shelleyBlockForging
  , shelleySharedBlockForging
  , validateGenesis
  ) where

import           Control.Monad.Except (Except)
import           Data.Bifunctor (first)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.SOP.Strict
import qualified Data.Text as Text
import           GHC.Stack (HasCallStack)

import qualified Cardano.Crypto.VRF as VRF
import           Cardano.Slotting.EpochInfo
import           Cardano.Slotting.Time (mkSlotLength)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import qualified Ouroboros.Consensus.HardFork.History as History
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Mempool.TxLimits (TxLimits)
import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Util.Assert
import           Ouroboros.Consensus.Util.IOLike

import qualified Cardano.Ledger.Era as Core
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.Shelley.Constraints as SL (makeTxOut)
import qualified Cardano.Ledger.Shelley.LedgerState as SL
                     (incrementalStakeDistr, updateStakeDistribution)
import           Cardano.Ledger.Val (coin, inject, (<->))
import qualified Cardano.Protocol.TPraos.API as SL
import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..))

import qualified Cardano.Protocol.TPraos.OCert as SL
import qualified Data.UMap as UM
import           Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey)
import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
import           Ouroboros.Consensus.Protocol.Praos.Common
import           Ouroboros.Consensus.Protocol.TPraos
import           Ouroboros.Consensus.Shelley.Eras
import           Ouroboros.Consensus.Shelley.Ledger
import           Ouroboros.Consensus.Shelley.Ledger.Inspect ()
import           Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion ()
import           Ouroboros.Consensus.Shelley.Node.Common
                     (ProtocolParamsShelleyBased (..), ShelleyEraWithCrypto,
                     ShelleyLeaderCredentials (..), shelleyBlockIssuerVKey)
import           Ouroboros.Consensus.Shelley.Node.Serialisation ()
import           Ouroboros.Consensus.Shelley.Protocol.TPraos ()

{-------------------------------------------------------------------------------
  BlockForging
-------------------------------------------------------------------------------}

-- | Create a 'BlockForging' record for a single era.
--
-- In case the same credentials should be shared across multiple Shelley-based
-- eras, use 'shelleySharedBlockForging'.
shelleyBlockForging ::
     forall m era c.
      ( ShelleyCompatible (TPraos c) era
      , PraosCrypto c
      , c ~ EraCrypto era
      , TxLimits (ShelleyBlock (TPraos c) era)
      , IOLike m
      )
  => TPraosParams
  -> TxLimits.Overrides (ShelleyBlock (TPraos c) era)
  -> ShelleyLeaderCredentials (EraCrypto era)
  -> m (BlockForging m (ShelleyBlock (TPraos c) era))
shelleyBlockForging :: TPraosParams
-> Overrides (ShelleyBlock (TPraos c) era)
-> ShelleyLeaderCredentials (EraCrypto era)
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
shelleyBlockForging TPraosParams
tpraosParams Overrides (ShelleyBlock (TPraos c) era)
maxTxCapacityOverrides ShelleyLeaderCredentials (EraCrypto era)
credentials = do
    HotKey c m
hotKey <- SignKeyKES c -> KESPeriod -> Word64 -> m (HotKey c m)
forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
SignKeyKES c -> KESPeriod -> Word64 -> m (HotKey c m)
HotKey.mkHotKey @m @c SignKeyKES c
initSignKey KESPeriod
startPeriod Word64
tpraosMaxKESEvo
    BlockForging m (ShelleyBlock (TPraos c) era)
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockForging m (ShelleyBlock (TPraos c) era)
 -> m (BlockForging m (ShelleyBlock (TPraos c) era)))
-> BlockForging m (ShelleyBlock (TPraos c) era)
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
forall a b. (a -> b) -> a -> b
$ HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> Overrides (ShelleyBlock (TPraos c) era)
-> BlockForging m (ShelleyBlock (TPraos c) era)
forall (m :: * -> *) c era.
(PraosCrypto c, ShelleyEraWithCrypto c (TPraos c) era, IOLike m) =>
HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> Overrides (ShelleyBlock (TPraos c) era)
-> BlockForging m (ShelleyBlock (TPraos c) era)
shelleySharedBlockForging HotKey c m
hotKey SlotNo -> KESPeriod
slotToPeriod ShelleyLeaderCredentials c
ShelleyLeaderCredentials (EraCrypto era)
credentials Overrides (ShelleyBlock (TPraos c) era)
maxTxCapacityOverrides
  where
    TPraosParams {Word64
tpraosMaxKESEvo :: TPraosParams -> Word64
tpraosMaxKESEvo :: Word64
tpraosMaxKESEvo, Word64
tpraosSlotsPerKESPeriod :: TPraosParams -> Word64
tpraosSlotsPerKESPeriod :: Word64
tpraosSlotsPerKESPeriod} = TPraosParams
tpraosParams

    ShelleyLeaderCredentials {
        shelleyLeaderCredentialsInitSignKey :: forall c. ShelleyLeaderCredentials c -> SignKeyKES c
shelleyLeaderCredentialsInitSignKey = SignKeyKES c
initSignKey
      , shelleyLeaderCredentialsCanBeLeader :: forall c. ShelleyLeaderCredentials c -> PraosCanBeLeader c
shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader c
canBeLeader
      } = ShelleyLeaderCredentials c
ShelleyLeaderCredentials (EraCrypto era)
credentials

    startPeriod :: Absolute.KESPeriod
    startPeriod :: KESPeriod
startPeriod = OCert c -> KESPeriod
forall crypto. OCert crypto -> KESPeriod
SL.ocertKESPeriod (OCert c -> KESPeriod) -> OCert c -> KESPeriod
forall a b. (a -> b) -> a -> b
$ PraosCanBeLeader c -> OCert c
forall c. PraosCanBeLeader c -> OCert c
praosCanBeLeaderOpCert PraosCanBeLeader c
canBeLeader

    slotToPeriod :: SlotNo -> Absolute.KESPeriod
    slotToPeriod :: SlotNo -> KESPeriod
slotToPeriod (SlotNo Word64
slot) =
      Word -> KESPeriod
SL.KESPeriod (Word -> KESPeriod) -> Word -> KESPeriod
forall a b. (a -> b) -> a -> b
$ Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word) -> Word64 -> Word
forall a b. (a -> b) -> a -> b
$ Word64
slot Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
tpraosSlotsPerKESPeriod

-- | Create a 'BlockForging' record safely using a given 'Hotkey'.
--
-- The name of the era (separated by a @_@) will be appended to each
-- 'forgeLabel'.
shelleySharedBlockForging ::
     forall m c era.
     ( PraosCrypto c
     , ShelleyEraWithCrypto c (TPraos c) era
     , IOLike m
     )
  => HotKey c m
  -> (SlotNo -> Absolute.KESPeriod)
  -> ShelleyLeaderCredentials c
  -> TxLimits.Overrides (ShelleyBlock (TPraos c) era)
  -> BlockForging m     (ShelleyBlock (TPraos c) era)
shelleySharedBlockForging :: HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> Overrides (ShelleyBlock (TPraos c) era)
-> BlockForging m (ShelleyBlock (TPraos c) era)
shelleySharedBlockForging HotKey c m
hotKey SlotNo -> KESPeriod
slotToPeriod ShelleyLeaderCredentials c
credentials Overrides (ShelleyBlock (TPraos c) era)
maxTxCapacityOverrides =
    BlockForging :: forall (m :: * -> *) blk.
Text
-> CanBeLeader (BlockProtocol blk)
-> (TopLevelConfig blk
    -> SlotNo
    -> Ticked (ChainDepState (BlockProtocol blk))
    -> m (ForgeStateUpdateInfo blk))
-> (TopLevelConfig blk
    -> SlotNo
    -> Ticked (ChainDepState (BlockProtocol blk))
    -> IsLeader (BlockProtocol blk)
    -> ForgeStateInfo blk
    -> Either (CannotForge blk) ())
-> (TopLevelConfig blk
    -> BlockNo
    -> SlotNo
    -> TickedLedgerState blk
    -> [Validated (GenTx blk)]
    -> IsLeader (BlockProtocol blk)
    -> m blk)
-> BlockForging m blk
BlockForging {
        forgeLabel :: Text
forgeLabel       = Text
label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Proxy era -> Text
forall era (proxy :: * -> *).
ShelleyBasedEra era =>
proxy era -> Text
shelleyBasedEraName (Proxy era
forall k (t :: k). Proxy t
Proxy @era)
      , canBeLeader :: CanBeLeader (BlockProtocol (ShelleyBlock (TPraos c) era))
canBeLeader      = CanBeLeader (BlockProtocol (ShelleyBlock (TPraos c) era))
PraosCanBeLeader c
canBeLeader
      , updateForgeState :: TopLevelConfig (ShelleyBlock (TPraos c) era)
-> SlotNo
-> Ticked
     (ChainDepState (BlockProtocol (ShelleyBlock (TPraos c) era)))
-> m (ForgeStateUpdateInfo (ShelleyBlock (TPraos c) era))
updateForgeState = \TopLevelConfig (ShelleyBlock (TPraos c) era)
_ SlotNo
curSlot Ticked
  (ChainDepState (BlockProtocol (ShelleyBlock (TPraos c) era)))
_ ->
                               UpdateInfo KESInfo KESEvolutionError
-> ForgeStateUpdateInfo (ShelleyBlock (TPraos c) era)
forall blk.
UpdateInfo (ForgeStateInfo blk) (ForgeStateUpdateError blk)
-> ForgeStateUpdateInfo blk
forgeStateUpdateInfoFromUpdateInfo (UpdateInfo KESInfo KESEvolutionError
 -> ForgeStateUpdateInfo (ShelleyBlock (TPraos c) era))
-> m (UpdateInfo KESInfo KESEvolutionError)
-> m (ForgeStateUpdateInfo (ShelleyBlock (TPraos c) era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                 HotKey c m -> KESPeriod -> m (UpdateInfo KESInfo KESEvolutionError)
forall c (m :: * -> *).
HotKey c m -> KESPeriod -> m (UpdateInfo KESInfo KESEvolutionError)
HotKey.evolve HotKey c m
hotKey (SlotNo -> KESPeriod
slotToPeriod SlotNo
curSlot)
      , checkCanForge :: TopLevelConfig (ShelleyBlock (TPraos c) era)
-> SlotNo
-> Ticked
     (ChainDepState (BlockProtocol (ShelleyBlock (TPraos c) era)))
-> IsLeader (BlockProtocol (ShelleyBlock (TPraos c) era))
-> ForgeStateInfo (ShelleyBlock (TPraos c) era)
-> Either (CannotForge (ShelleyBlock (TPraos c) era)) ()
checkCanForge    = \TopLevelConfig (ShelleyBlock (TPraos c) era)
cfg SlotNo
curSlot Ticked
  (ChainDepState (BlockProtocol (ShelleyBlock (TPraos c) era)))
_tickedChainDepState ->
                               ConsensusConfig (TPraos c)
-> Hash c (VerKeyVRF c)
-> SlotNo
-> IsLeader (TPraos c)
-> KESInfo
-> Either (TPraosCannotForge c) ()
forall c.
ConsensusConfig (TPraos c)
-> Hash c (VerKeyVRF c)
-> SlotNo
-> IsLeader (TPraos c)
-> KESInfo
-> Either (TPraosCannotForge c) ()
tpraosCheckCanForge
                                 (TopLevelConfig (ShelleyBlock (TPraos c) era)
-> ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig (ShelleyBlock (TPraos c) era)
cfg)
                                 Hash c (VerKeyVRF c)
forgingVRFHash
                                 SlotNo
curSlot
      , forgeBlock :: TopLevelConfig (ShelleyBlock (TPraos c) era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock (TPraos c) era)
-> [Validated (GenTx (ShelleyBlock (TPraos c) era))]
-> IsLeader (BlockProtocol (ShelleyBlock (TPraos c) era))
-> m (ShelleyBlock (TPraos c) era)
forgeBlock       = \TopLevelConfig (ShelleyBlock (TPraos c) era)
cfg ->
          HotKey (EraCrypto era) m
-> CanBeLeader (TPraos c)
-> TopLevelConfig (ShelleyBlock (TPraos c) era)
-> Overrides (ShelleyBlock (TPraos c) era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock (TPraos c) era)
-> [Validated (GenTx (ShelleyBlock (TPraos c) era))]
-> IsLeader (TPraos c)
-> m (ShelleyBlock (TPraos c) era)
forall (m :: * -> *) era proto.
(ShelleyCompatible proto era, TxLimits (ShelleyBlock proto era),
 Monad m) =>
HotKey (EraCrypto era) m
-> CanBeLeader proto
-> TopLevelConfig (ShelleyBlock proto era)
-> Overrides (ShelleyBlock proto era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock proto era)
-> [Validated (GenTx (ShelleyBlock proto era))]
-> IsLeader proto
-> m (ShelleyBlock proto era)
forgeShelleyBlock
            HotKey c m
HotKey (EraCrypto era) m
hotKey
            CanBeLeader (TPraos c)
PraosCanBeLeader c
canBeLeader
            TopLevelConfig (ShelleyBlock (TPraos c) era)
cfg
            Overrides (ShelleyBlock (TPraos c) era)
maxTxCapacityOverrides
      }
  where
    ShelleyLeaderCredentials {
        shelleyLeaderCredentialsCanBeLeader :: forall c. ShelleyLeaderCredentials c -> PraosCanBeLeader c
shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader c
canBeLeader
      , shelleyLeaderCredentialsLabel :: forall c. ShelleyLeaderCredentials c -> Text
shelleyLeaderCredentialsLabel       = Text
label
      } = ShelleyLeaderCredentials c
credentials

    forgingVRFHash :: SL.Hash c (SL.VerKeyVRF c)
    forgingVRFHash :: Hash c (VerKeyVRF c)
forgingVRFHash =
          VerKeyVRF c -> Hash c (VerKeyVRF c)
forall v h.
(VRFAlgorithm v, HashAlgorithm h) =>
VerKeyVRF v -> Hash h (VerKeyVRF v)
SL.hashVerKeyVRF
        (VerKeyVRF c -> Hash c (VerKeyVRF c))
-> (PraosCanBeLeader c -> VerKeyVRF c)
-> PraosCanBeLeader c
-> Hash c (VerKeyVRF c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignKeyVRF (VRF c) -> VerKeyVRF c
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
VRF.deriveVerKeyVRF
        (SignKeyVRF (VRF c) -> VerKeyVRF c)
-> (PraosCanBeLeader c -> SignKeyVRF (VRF c))
-> PraosCanBeLeader c
-> VerKeyVRF c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PraosCanBeLeader c -> SignKeyVRF (VRF c)
forall c. PraosCanBeLeader c -> SignKeyVRF c
praosCanBeLeaderSignKeyVRF
        (PraosCanBeLeader c -> Hash c (VerKeyVRF c))
-> PraosCanBeLeader c -> Hash c (VerKeyVRF c)
forall a b. (a -> b) -> a -> b
$ PraosCanBeLeader c
canBeLeader

{-------------------------------------------------------------------------------
  ProtocolInfo
-------------------------------------------------------------------------------}

-- | Check the validity of the genesis config. To be used in conjunction with
-- 'assertWithMsg'.
validateGenesis ::
     ShelleyBasedEra era
  => SL.ShelleyGenesis era -> Either String ()
validateGenesis :: ShelleyGenesis era -> Either String ()
validateGenesis = ([ValidationErr] -> String)
-> Either [ValidationErr] () -> Either String ()
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [ValidationErr] -> String
errsToString (Either [ValidationErr] () -> Either String ())
-> (ShelleyGenesis era -> Either [ValidationErr] ())
-> ShelleyGenesis era
-> Either String ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesis era -> Either [ValidationErr] ()
forall era.
Era era =>
ShelleyGenesis era -> Either [ValidationErr] ()
SL.validateGenesis
  where
    errsToString :: [SL.ValidationErr] -> String
    errsToString :: [ValidationErr] -> String
errsToString [ValidationErr]
errs =
        Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines
          (Text
"Invalid genesis config:" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (ValidationErr -> Text) -> [ValidationErr] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ValidationErr -> Text
SL.describeValidationErr [ValidationErr]
errs)

-- | Parameters needed to run Shelley
data ProtocolParamsShelley c = ProtocolParamsShelley {
      ProtocolParamsShelley c -> ProtVer
shelleyProtVer                :: SL.ProtVer
    , ProtocolParamsShelley c
-> Overrides (ShelleyBlock (TPraos c) (ShelleyEra c))
shelleyMaxTxCapacityOverrides :: TxLimits.Overrides (ShelleyBlock(TPraos c) (ShelleyEra c) )
    }

-- | Parameters needed to run Allegra
data ProtocolParamsAllegra c = ProtocolParamsAllegra {
      ProtocolParamsAllegra c -> ProtVer
allegraProtVer                :: SL.ProtVer
    , ProtocolParamsAllegra c
-> Overrides (ShelleyBlock (TPraos c) (AllegraEra c))
allegraMaxTxCapacityOverrides :: TxLimits.Overrides (ShelleyBlock (TPraos c) (AllegraEra c) )
    }

-- | Parameters needed to run Mary
data ProtocolParamsMary c = ProtocolParamsMary {
      ProtocolParamsMary c -> ProtVer
maryProtVer                :: SL.ProtVer
    , ProtocolParamsMary c
-> Overrides (ShelleyBlock (TPraos c) (MaryEra c))
maryMaxTxCapacityOverrides :: TxLimits.Overrides (ShelleyBlock (TPraos c) (MaryEra c) )
    }

-- | Parameters needed to run Alonzo
data ProtocolParamsAlonzo c = ProtocolParamsAlonzo {
      ProtocolParamsAlonzo c -> ProtVer
alonzoProtVer                :: SL.ProtVer
    , ProtocolParamsAlonzo c
-> Overrides (ShelleyBlock (TPraos c) (AlonzoEra c))
alonzoMaxTxCapacityOverrides :: TxLimits.Overrides (ShelleyBlock (TPraos c) (AlonzoEra c) )
    }

protocolInfoShelley ::
     forall m c.
      ( IOLike m
      , PraosCrypto c
      , ShelleyCompatible (TPraos c) (ShelleyEra c)
      , TxLimits (ShelleyBlock (TPraos c) (ShelleyEra c))
      )
  => ProtocolParamsShelleyBased (ShelleyEra c)
  -> ProtocolParamsShelley c
  -> ProtocolInfo m (ShelleyBlock (TPraos c)(ShelleyEra c) )
protocolInfoShelley :: ProtocolParamsShelleyBased (ShelleyEra c)
-> ProtocolParamsShelley c
-> ProtocolInfo m (ShelleyBlock (TPraos c) (ShelleyEra c))
protocolInfoShelley ProtocolParamsShelleyBased (ShelleyEra c)
protocolParamsShelleyBased
                    ProtocolParamsShelley {
                        $sel:shelleyProtVer:ProtocolParamsShelley :: forall c. ProtocolParamsShelley c -> ProtVer
shelleyProtVer                = ProtVer
protVer
                      , $sel:shelleyMaxTxCapacityOverrides:ProtocolParamsShelley :: forall c.
ProtocolParamsShelley c
-> Overrides (ShelleyBlock (TPraos c) (ShelleyEra c))
shelleyMaxTxCapacityOverrides = Overrides (ShelleyBlock (TPraos c) (ShelleyEra c))
maxTxCapacityOverrides
                      } =
    ProtocolParamsShelleyBased (ShelleyEra c)
-> TranslationContext (ShelleyEra c)
-> ProtVer
-> Overrides (ShelleyBlock (TPraos c) (ShelleyEra c))
-> ProtocolInfo m (ShelleyBlock (TPraos c) (ShelleyEra c))
forall (m :: * -> *) era c.
(IOLike m, PraosCrypto c, ShelleyCompatible (TPraos c) era,
 TxLimits (ShelleyBlock (TPraos c) era), c ~ EraCrypto era) =>
ProtocolParamsShelleyBased era
-> TranslationContext era
-> ProtVer
-> Overrides (ShelleyBlock (TPraos c) era)
-> ProtocolInfo m (ShelleyBlock (TPraos c) era)
protocolInfoTPraosShelleyBased
      ProtocolParamsShelleyBased (ShelleyEra c)
protocolParamsShelleyBased
      ()  -- trivial translation context
      ProtVer
protVer
      Overrides (ShelleyBlock (TPraos c) (ShelleyEra c))
maxTxCapacityOverrides

protocolInfoTPraosShelleyBased ::
     forall m era c.
      ( IOLike m
      , PraosCrypto c
      , ShelleyCompatible (TPraos c) era
      , TxLimits (ShelleyBlock (TPraos c) era)
      , c ~ EraCrypto era
      )
  => ProtocolParamsShelleyBased era
  -> Core.TranslationContext era
  -> SL.ProtVer
  -> TxLimits.Overrides (ShelleyBlock (TPraos c) era)
  -> ProtocolInfo m     (ShelleyBlock (TPraos c) era)
protocolInfoTPraosShelleyBased :: ProtocolParamsShelleyBased era
-> TranslationContext era
-> ProtVer
-> Overrides (ShelleyBlock (TPraos c) era)
-> ProtocolInfo m (ShelleyBlock (TPraos c) era)
protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased {
                             shelleyBasedGenesis :: forall era. ProtocolParamsShelleyBased era -> ShelleyGenesis era
shelleyBasedGenesis           = ShelleyGenesis era
genesis
                           , shelleyBasedInitialNonce :: forall era. ProtocolParamsShelleyBased era -> Nonce
shelleyBasedInitialNonce      = Nonce
initialNonce
                           , shelleyBasedLeaderCredentials :: forall era.
ProtocolParamsShelleyBased era
-> [ShelleyLeaderCredentials (EraCrypto era)]
shelleyBasedLeaderCredentials = [ShelleyLeaderCredentials (EraCrypto era)]
credentialss
                           }
                         TranslationContext era
transCtxt
                         ProtVer
protVer
                         Overrides (ShelleyBlock (TPraos c) era)
maxTxCapacityOverrides =
    Either String ()
-> ProtocolInfo m (ShelleyBlock (TPraos c) era)
-> ProtocolInfo m (ShelleyBlock (TPraos c) era)
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg (ShelleyGenesis era -> Either String ()
forall era.
ShelleyBasedEra era =>
ShelleyGenesis era -> Either String ()
validateGenesis ShelleyGenesis era
genesis) (ProtocolInfo m (ShelleyBlock (TPraos c) era)
 -> ProtocolInfo m (ShelleyBlock (TPraos c) era))
-> ProtocolInfo m (ShelleyBlock (TPraos c) era)
-> ProtocolInfo m (ShelleyBlock (TPraos c) era)
forall a b. (a -> b) -> a -> b
$
    ProtocolInfo :: forall (m :: * -> *) b.
TopLevelConfig b
-> ExtLedgerState b -> m [BlockForging m b] -> ProtocolInfo m b
ProtocolInfo {
        pInfoConfig :: TopLevelConfig (ShelleyBlock (TPraos c) era)
pInfoConfig       = TopLevelConfig (ShelleyBlock (TPraos c) era)
topLevelConfig
      , pInfoInitLedger :: ExtLedgerState (ShelleyBlock (TPraos c) era)
pInfoInitLedger   = ExtLedgerState (ShelleyBlock (TPraos c) era)
initExtLedgerState
      , pInfoBlockForging :: m [BlockForging m (ShelleyBlock (TPraos c) era)]
pInfoBlockForging =
          (ShelleyLeaderCredentials c
 -> m (BlockForging m (ShelleyBlock (TPraos c) era)))
-> [ShelleyLeaderCredentials c]
-> m [BlockForging m (ShelleyBlock (TPraos c) era)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
            (TPraosParams
-> Overrides (ShelleyBlock (TPraos c) era)
-> ShelleyLeaderCredentials (EraCrypto era)
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
forall (m :: * -> *) era c.
(ShelleyCompatible (TPraos c) era, PraosCrypto c,
 c ~ EraCrypto era, TxLimits (ShelleyBlock (TPraos c) era),
 IOLike m) =>
TPraosParams
-> Overrides (ShelleyBlock (TPraos c) era)
-> ShelleyLeaderCredentials (EraCrypto era)
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
shelleyBlockForging TPraosParams
tpraosParams Overrides (ShelleyBlock (TPraos c) era)
maxTxCapacityOverrides)
            [ShelleyLeaderCredentials c]
[ShelleyLeaderCredentials (EraCrypto era)]
credentialss
      }
  where

    -- | Currently for all existing eras in ledger-specs (Shelley, Allegra, Mary
    -- and Alonzo) it happens to be the case that AdditionalGenesisConfig and
    -- TranslationContext are instantiated to the same type.
    -- We take advantage of this fact below to simplify our code, but we are
    -- aware that this might change in future (for new eras), breaking this
    -- code.
    --
    -- see type equality constraint in
    -- Ouroboros.Consensus.Shelley.Eras.ShelleyBasedEra
    additionalGenesisConfig :: SL.AdditionalGenesisConfig era
    additionalGenesisConfig :: AdditionalGenesisConfig era
additionalGenesisConfig = TranslationContext era
AdditionalGenesisConfig era
transCtxt

    maxMajorProtVer :: MaxMajorProtVer
    maxMajorProtVer :: MaxMajorProtVer
maxMajorProtVer = Natural -> MaxMajorProtVer
MaxMajorProtVer (Natural -> MaxMajorProtVer) -> Natural -> MaxMajorProtVer
forall a b. (a -> b) -> a -> b
$ ProtVer -> Natural
SL.pvMajor ProtVer
protVer

    topLevelConfig :: TopLevelConfig (ShelleyBlock (TPraos c) era)
    topLevelConfig :: TopLevelConfig (ShelleyBlock (TPraos c) era)
topLevelConfig = TopLevelConfig :: forall blk.
ConsensusConfig (BlockProtocol blk)
-> LedgerConfig blk
-> BlockConfig blk
-> CodecConfig blk
-> StorageConfig blk
-> TopLevelConfig blk
TopLevelConfig {
        topLevelConfigProtocol :: ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))
topLevelConfigProtocol = ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))
consensusConfig
      , topLevelConfigLedger :: LedgerConfig (ShelleyBlock (TPraos c) era)
topLevelConfigLedger   = LedgerConfig (ShelleyBlock (TPraos c) era)
ledgerConfig
      , topLevelConfigBlock :: BlockConfig (ShelleyBlock (TPraos c) era)
topLevelConfigBlock    = BlockConfig (ShelleyBlock (TPraos c) era)
blockConfig
      , topLevelConfigCodec :: CodecConfig (ShelleyBlock (TPraos c) era)
topLevelConfigCodec    = CodecConfig (ShelleyBlock (TPraos c) era)
forall proto era. CodecConfig (ShelleyBlock proto era)
ShelleyCodecConfig
      , topLevelConfigStorage :: StorageConfig (ShelleyBlock (TPraos c) era)
topLevelConfigStorage  = StorageConfig (ShelleyBlock (TPraos c) era)
storageConfig
      }

    consensusConfig :: ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))
    consensusConfig :: ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))
consensusConfig = TPraosConfig :: forall c.
TPraosParams
-> EpochInfo (Except PastHorizonException)
-> ConsensusConfig (TPraos c)
TPraosConfig {
        TPraosParams
tpraosParams :: TPraosParams
tpraosParams :: TPraosParams
tpraosParams
      , tpraosEpochInfo :: EpochInfo (Except PastHorizonException)
tpraosEpochInfo = EpochInfo (Except PastHorizonException)
epochInfo
      }

    ledgerConfig :: LedgerConfig (ShelleyBlock (TPraos c) era)
    ledgerConfig :: LedgerConfig (ShelleyBlock (TPraos c) era)
ledgerConfig = ShelleyGenesis era
-> TranslationContext era
-> EpochInfo (Except PastHorizonException)
-> MaxMajorProtVer
-> ShelleyLedgerConfig era
forall era.
ShelleyGenesis era
-> TranslationContext era
-> EpochInfo (Except PastHorizonException)
-> MaxMajorProtVer
-> ShelleyLedgerConfig era
mkShelleyLedgerConfig ShelleyGenesis era
genesis TranslationContext era
transCtxt EpochInfo (Except PastHorizonException)
epochInfo MaxMajorProtVer
maxMajorProtVer

    epochInfo :: EpochInfo (Except History.PastHorizonException)
    epochInfo :: EpochInfo (Except PastHorizonException)
epochInfo =
        EpochSize -> SlotLength -> EpochInfo (Except PastHorizonException)
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo
          (ShelleyGenesis era -> EpochSize
forall era. ShelleyGenesis era -> EpochSize
SL.sgEpochLength ShelleyGenesis era
genesis)
          (NominalDiffTime -> SlotLength
mkSlotLength (NominalDiffTime -> SlotLength) -> NominalDiffTime -> SlotLength
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis era -> NominalDiffTime
forall era. ShelleyGenesis era -> NominalDiffTime
SL.sgSlotLength ShelleyGenesis era
genesis)

    tpraosParams :: TPraosParams
    tpraosParams :: TPraosParams
tpraosParams = MaxMajorProtVer -> Nonce -> ShelleyGenesis era -> TPraosParams
forall era.
MaxMajorProtVer -> Nonce -> ShelleyGenesis era -> TPraosParams
mkTPraosParams MaxMajorProtVer
maxMajorProtVer Nonce
initialNonce ShelleyGenesis era
genesis

    blockConfig :: BlockConfig (ShelleyBlock (TPraos c) era)
    blockConfig :: BlockConfig (ShelleyBlock (TPraos c) era)
blockConfig =
        ProtVer
-> ShelleyGenesis era
-> [VKey 'BlockIssuer (EraCrypto era)]
-> BlockConfig (ShelleyBlock (TPraos c) era)
forall era proto.
ShelleyBasedEra era =>
ProtVer
-> ShelleyGenesis era
-> [VKey 'BlockIssuer (EraCrypto era)]
-> BlockConfig (ShelleyBlock proto era)
mkShelleyBlockConfig
          ProtVer
protVer
          ShelleyGenesis era
genesis
          (ShelleyLeaderCredentials c -> VKey 'BlockIssuer c
forall c. ShelleyLeaderCredentials c -> VKey 'BlockIssuer c
shelleyBlockIssuerVKey (ShelleyLeaderCredentials c -> VKey 'BlockIssuer c)
-> [ShelleyLeaderCredentials c] -> [VKey 'BlockIssuer c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ShelleyLeaderCredentials c]
[ShelleyLeaderCredentials (EraCrypto era)]
credentialss)

    storageConfig :: StorageConfig (ShelleyBlock (TPraos c) era)
    storageConfig :: StorageConfig (ShelleyBlock (TPraos c) era)
storageConfig = ShelleyStorageConfig :: forall proto era.
Word64 -> SecurityParam -> StorageConfig (ShelleyBlock proto era)
ShelleyStorageConfig {
          shelleyStorageConfigSlotsPerKESPeriod :: Word64
shelleyStorageConfigSlotsPerKESPeriod = TPraosParams -> Word64
tpraosSlotsPerKESPeriod TPraosParams
tpraosParams
        , shelleyStorageConfigSecurityParam :: SecurityParam
shelleyStorageConfigSecurityParam     = TPraosParams -> SecurityParam
tpraosSecurityParam     TPraosParams
tpraosParams
        }

    initLedgerState :: LedgerState (ShelleyBlock (TPraos c) era)
    initLedgerState :: LedgerState (ShelleyBlock (TPraos c) era)
initLedgerState = ShelleyLedgerState :: forall proto era.
WithOrigin (ShelleyTip proto era)
-> NewEpochState era
-> ShelleyTransition
-> LedgerState (ShelleyBlock proto era)
ShelleyLedgerState {
        shelleyLedgerTip :: WithOrigin (ShelleyTip (TPraos c) era)
shelleyLedgerTip        = WithOrigin (ShelleyTip (TPraos c) era)
forall t. WithOrigin t
Origin
      , shelleyLedgerState :: NewEpochState era
shelleyLedgerState      =
          ShelleyGenesisStaking (EraCrypto era)
-> NewEpochState era -> NewEpochState era
forall era.
ShelleyBasedEra era =>
ShelleyGenesisStaking (EraCrypto era)
-> NewEpochState era -> NewEpochState era
registerGenesisStaking (ShelleyGenesis era -> ShelleyGenesisStaking (EraCrypto era)
forall era.
ShelleyGenesis era -> ShelleyGenesisStaking (Crypto era)
SL.sgStaking ShelleyGenesis era
genesis) (NewEpochState era -> NewEpochState era)
-> NewEpochState era -> NewEpochState era
forall a b. (a -> b) -> a -> b
$
            ShelleyGenesis era
-> AdditionalGenesisConfig era -> NewEpochState era
forall era.
CanStartFromGenesis era =>
ShelleyGenesis era
-> AdditionalGenesisConfig era -> NewEpochState era
SL.initialState ShelleyGenesis era
genesis AdditionalGenesisConfig era
additionalGenesisConfig
      , shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition = ShelleyTransitionInfo :: Word32 -> ShelleyTransition
ShelleyTransitionInfo {shelleyAfterVoting :: Word32
shelleyAfterVoting = Word32
0}
      }

    initChainDepState :: TPraosState c
    initChainDepState :: TPraosState c
initChainDepState = WithOrigin SlotNo -> ChainDepState c -> TPraosState c
forall c. WithOrigin SlotNo -> ChainDepState c -> TPraosState c
TPraosState WithOrigin SlotNo
forall t. WithOrigin t
Origin (ChainDepState c -> TPraosState c)
-> ChainDepState c -> TPraosState c
forall a b. (a -> b) -> a -> b
$
      Nonce
-> Map (KeyHash 'Genesis c) (GenDelegPair c) -> ChainDepState c
forall crypto.
Nonce
-> Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> ChainDepState crypto
SL.initialChainDepState Nonce
initialNonce (ShelleyGenesis era
-> Map
     (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
forall era.
ShelleyGenesis era
-> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
SL.sgGenDelegs ShelleyGenesis era
genesis)

    initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era)
    initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era)
initExtLedgerState = ExtLedgerState :: forall blk.
LedgerState blk -> HeaderState blk -> ExtLedgerState blk
ExtLedgerState {
        ledgerState :: LedgerState (ShelleyBlock (TPraos c) era)
ledgerState = LedgerState (ShelleyBlock (TPraos c) era)
initLedgerState
      , headerState :: HeaderState (ShelleyBlock (TPraos c) era)
headerState = ChainDepState (BlockProtocol (ShelleyBlock (TPraos c) era))
-> HeaderState (ShelleyBlock (TPraos c) era)
forall blk. ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState ChainDepState (BlockProtocol (ShelleyBlock (TPraos c) era))
TPraosState c
initChainDepState
      }

{-------------------------------------------------------------------------------
  Register genesis staking
-------------------------------------------------------------------------------}

-- | Register the initial staking information in the 'SL.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.
--
-- TODO adapt and reuse @registerGenesisStaking@ from @cardano-ledger-specs@.
registerGenesisStaking ::
     forall era. ShelleyBasedEra era
  => SL.ShelleyGenesisStaking (EraCrypto era)
  -> SL.NewEpochState era
  -> SL.NewEpochState era
registerGenesisStaking :: ShelleyGenesisStaking (EraCrypto era)
-> NewEpochState era -> NewEpochState era
registerGenesisStaking ShelleyGenesisStaking (EraCrypto era)
staking NewEpochState era
nes = NewEpochState era
nes {
      nesEs :: EpochState era
SL.nesEs = EpochState era
epochState {
          esLState :: LedgerState era
SL.esLState = LedgerState era
ledgerState {
          lsDPState :: DPState (EraCrypto era)
SL.lsDPState = DPState (EraCrypto era)
dpState {
              dpsDState :: DState (EraCrypto era)
SL.dpsDState = DState (EraCrypto era)
dState'
            , dpsPState :: PState (EraCrypto era)
SL.dpsPState = PState (EraCrypto era)
pState'
            }
        }
        , esSnapshots :: SnapShots (EraCrypto era)
SL.esSnapshots = (EpochState era -> SnapShots (EraCrypto era)
forall era. EpochState era -> SnapShots (Crypto era)
SL.esSnapshots EpochState era
epochState) {
              $sel:_pstakeMark:SnapShots :: SnapShot (EraCrypto era)
SL._pstakeMark = 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)
SL.nesPd = SnapShot (EraCrypto era) -> PoolDistr (EraCrypto era)
forall crypto. SnapShot crypto -> PoolDistr crypto
SL.calculatePoolDistr SnapShot (EraCrypto era)
initSnapShot
    }
  where
    SL.ShelleyGenesisStaking { Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
sgsPools :: forall crypto.
ShelleyGenesisStaking crypto
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
sgsPools :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
sgsPools, Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
sgsStake :: forall crypto.
ShelleyGenesisStaking crypto
-> Map (KeyHash 'Staking crypto) (KeyHash 'StakePool crypto)
sgsStake :: Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
sgsStake } = ShelleyGenesisStaking (EraCrypto era)
staking
    SL.NewEpochState { nesEs :: forall era. NewEpochState era -> EpochState era
nesEs = EpochState era
epochState } = NewEpochState era
nes
    ledgerState :: LedgerState era
ledgerState = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
SL.esLState EpochState era
epochState
    dpState :: DPState (EraCrypto era)
dpState = LedgerState era -> DPState (EraCrypto era)
forall era. LedgerState era -> DPState (Crypto era)
SL.lsDPState 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' :: SL.DState (EraCrypto era)
    dState' :: DState (EraCrypto era)
dState' = (DPState (EraCrypto era) -> DState (EraCrypto era)
forall crypto. DPState crypto -> DState crypto
SL.dpsDState DPState (EraCrypto era)
dpState) {
          _unified :: UnifiedMap (EraCrypto era)
SL._unified = Map (Credential 'Staking (EraCrypto era)) Coin
-> Map
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Map Ptr (Credential 'Staking (EraCrypto era))
-> UnifiedMap (EraCrypto era)
forall coin cred ptr pool.
(Monoid coin, Ord cred, Ord ptr) =>
Map cred coin
-> Map cred pool -> Map ptr cred -> UMap coin cred pool ptr
UM.unify
            ( (KeyHash 'StakePool (EraCrypto era) -> Coin)
-> Map
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Map (Credential 'Staking (EraCrypto era)) Coin
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Coin -> KeyHash 'StakePool (EraCrypto era) -> Coin
forall a b. a -> b -> a
const (Coin -> KeyHash 'StakePool (EraCrypto era) -> Coin)
-> Coin -> KeyHash 'StakePool (EraCrypto era) -> Coin
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
SL.Coin Integer
0)
                      (Map
   (Credential 'Staking (EraCrypto era))
   (KeyHash 'StakePool (EraCrypto era))
 -> Map (Credential 'Staking (EraCrypto era)) Coin)
-> (Map
      (KeyHash 'Staking (EraCrypto era))
      (KeyHash 'StakePool (EraCrypto era))
    -> Map
         (Credential 'Staking (EraCrypto era))
         (KeyHash 'StakePool (EraCrypto era)))
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Map (Credential 'Staking (EraCrypto era)) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyHash 'Staking (EraCrypto era)
 -> Credential 'Staking (EraCrypto era))
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Map
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys KeyHash 'Staking (EraCrypto era)
-> Credential 'Staking (EraCrypto era)
forall (kr :: KeyRole) crypto.
KeyHash kr crypto -> Credential kr crypto
SL.KeyHashObj
                      (Map
   (KeyHash 'Staking (EraCrypto era))
   (KeyHash 'StakePool (EraCrypto era))
 -> Map (Credential 'Staking (EraCrypto era)) Coin)
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Map (Credential 'Staking (EraCrypto era)) Coin
forall a b. (a -> b) -> a -> b
$ Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
sgsStake)
            ( (KeyHash 'Staking (EraCrypto era)
 -> Credential 'Staking (EraCrypto era))
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
-> Map
     (Credential 'Staking (EraCrypto era))
     (KeyHash 'StakePool (EraCrypto era))
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys KeyHash 'Staking (EraCrypto era)
-> Credential 'Staking (EraCrypto era)
forall (kr :: KeyRole) crypto.
KeyHash kr crypto -> Credential kr crypto
SL.KeyHashObj Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
sgsStake )
            Map Ptr (Credential 'Staking (EraCrypto era))
forall a. Monoid a => a
mempty
        }

    -- We consider pools as having been registered in slot 0
    -- See STS POOL for details
    pState' :: SL.PState (EraCrypto era)
    pState' :: PState (EraCrypto era)
pState' = (DPState (EraCrypto era) -> PState (EraCrypto era)
forall crypto. DPState crypto -> PState crypto
SL.dpsPState DPState (EraCrypto era)
dpState) {
          _pParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
SL._pParams = Map
  (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 :: SL.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.
      IncrementalStake (EraCrypto era)
-> DState (EraCrypto era)
-> PState (EraCrypto era)
-> SnapShot (EraCrypto era)
forall crypto.
IncrementalStake crypto
-> DState crypto -> PState crypto -> SnapShot crypto
SL.incrementalStakeDistr
        -- 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.
        (IncrementalStake (EraCrypto era)
-> UTxO era -> UTxO era -> IncrementalStake (EraCrypto era)
forall era.
Era era =>
IncrementalStake (Crypto era)
-> UTxO era -> UTxO era -> IncrementalStake (Crypto era)
SL.updateStakeDistribution IncrementalStake (EraCrypto era)
forall a. Monoid a => a
mempty UTxO era
forall a. Monoid a => a
mempty (UTxOState era -> UTxO era
forall era. UTxOState era -> UTxO era
SL._utxo (LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
SL.lsUTxOState LedgerState era
ledgerState)))
        DState (EraCrypto era)
dState'
        PState (EraCrypto era)
pState'

-- | Register the initial funds in the 'SL.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 (SL.initialFundsPseudoTxIn addr) existingUTxO
--
-- PROPERTY:
-- >    genesisUTxO genesis
-- > == <genesisUTxO'> (sgInitialFunds genesis)
-- > == <extractUTxO> (registerInitialFunds (sgInitialFunds genesis)
-- >                                        <empty NewEpochState>)
--
-- TODO move to @cardano-ledger-specs@.
registerInitialFunds ::
     forall era.
     ( ShelleyBasedEra era
     , HasCallStack
     )
  => Map (SL.Addr (EraCrypto era)) SL.Coin
  -> SL.NewEpochState era
  -> SL.NewEpochState era
registerInitialFunds :: Map (Addr (EraCrypto era)) Coin
-> NewEpochState era -> NewEpochState era
registerInitialFunds Map (Addr (EraCrypto era)) Coin
initialFunds NewEpochState era
nes = NewEpochState era
nes {
      nesEs :: EpochState era
SL.nesEs = EpochState era
epochState {
          esAccountState :: AccountState
SL.esAccountState = AccountState
accountState'
        , esLState :: LedgerState era
SL.esLState       = LedgerState era
ledgerState'
        }
    }
  where
    epochState :: EpochState era
epochState   = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
SL.nesEs          NewEpochState era
nes
    accountState :: AccountState
accountState = EpochState era -> AccountState
forall era. EpochState era -> AccountState
SL.esAccountState EpochState era
epochState
    ledgerState :: LedgerState era
ledgerState  = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
SL.esLState       EpochState era
epochState
    utxoState :: UTxOState era
utxoState    = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
SL.lsUTxOState     LedgerState era
ledgerState
    utxo :: UTxO era
utxo         = UTxOState era -> UTxO era
forall era. UTxOState era -> UTxO era
SL._utxo          UTxOState era
utxoState
    reserves :: Coin
reserves     = AccountState -> Coin
SL._reserves      AccountState
accountState

    initialFundsUtxo :: SL.UTxO era
    initialFundsUtxo :: UTxO era
initialFundsUtxo = Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
SL.UTxO (Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era)
-> Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$ [(TxIn (EraCrypto era), TxOut era)]
-> Map (TxIn (EraCrypto era)) (TxOut era)
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) <- Map (Addr (EraCrypto era)) Coin -> [(Addr (EraCrypto era), Coin)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Addr (EraCrypto era)) Coin
initialFunds
        ,  let txIn :: TxIn (EraCrypto era)
txIn  = Addr (EraCrypto era) -> TxIn (EraCrypto era)
forall crypto. Crypto crypto => Addr crypto -> TxIn crypto
SL.initialFundsPseudoTxIn Addr (EraCrypto era)
addr
               txOut :: TxOut era
txOut = Proxy era -> Addr (EraCrypto era) -> Value era -> TxOut era
forall era.
UsesTxOut era =>
Proxy era -> Addr (Crypto era) -> Value era -> TxOut era
SL.makeTxOut (Proxy era
forall k (t :: k). Proxy t
Proxy @era) Addr (EraCrypto era)
addr (Coin -> Value era
forall t. Val t => Coin -> t
inject Coin
amount)
        ]

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

    -- Update the reserves
    accountState' :: AccountState
accountState' = AccountState
accountState {
          _reserves :: Coin
SL._reserves = Coin
reserves Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Value era -> Coin
forall t. Val t => t -> Coin
coin (UTxO era -> Value era
forall era. Era era => UTxO era -> Value era
SL.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     = Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
SL.UTxO Map (TxIn (Crypto era)) (TxOut era)
forall a. Monoid a => a
mempty
    ledgerState' :: LedgerState era
ledgerState'  = LedgerState era
ledgerState {
          lsUTxOState :: UTxOState era
SL.lsUTxOState = UTxOState era
utxoState {
              _utxo :: UTxO era
SL._utxo        = 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.
              _stakeDistro :: IncrementalStake (EraCrypto era)
SL._stakeDistro = IncrementalStake (EraCrypto era)
-> UTxO era -> UTxO era -> IncrementalStake (EraCrypto era)
forall era.
Era era =>
IncrementalStake (Crypto era)
-> UTxO era -> UTxO era -> IncrementalStake (Crypto era)
SL.updateStakeDistribution IncrementalStake (EraCrypto era)
forall a. Monoid a => a
mempty UTxO era
forall era. UTxO era
utxoToDel UTxO era
utxo'
            }
        }

    -- | Merge two UTxOs, throw an 'error' in case of overlap
    mergeUtxoNoOverlap ::
         HasCallStack
      => SL.UTxO era -> SL.UTxO era -> SL.UTxO era
    mergeUtxoNoOverlap :: UTxO era -> UTxO era -> UTxO era
mergeUtxoNoOverlap (SL.UTxO Map (TxIn (EraCrypto era)) (TxOut era)
m1) (SL.UTxO Map (TxIn (EraCrypto era)) (TxOut era)
m2) = Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
SL.UTxO (Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era)
-> Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$
        (TxIn (EraCrypto era) -> TxOut era -> TxOut era -> TxOut era)
-> Map (TxIn (EraCrypto era)) (TxOut era)
-> Map (TxIn (EraCrypto era)) (TxOut era)
-> Map (TxIn (EraCrypto era)) (TxOut era)
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
_ -> String -> TxOut era
forall a. HasCallStack => String -> a
error (String -> TxOut era) -> String -> TxOut era
forall a b. (a -> b) -> a -> b
$ String
"initial fund part of UTxO: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxIn (EraCrypto era) -> String
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