{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Ledger.Ledger (
    LedgerState (..)
  , ShelleyBasedEra
  , ShelleyLedgerError (..)
  , ShelleyTip (..)
  , ShelleyTransition (..)
  , Ticked (..)
  , castShelleyTip
  , shelleyLedgerTipPoint
  , shelleyTipToPoint
    -- * Ledger config
  , ShelleyLedgerConfig (..)
  , mkShelleyLedgerConfig
  , shelleyEraParams
  , shelleyEraParamsNeverHardForks
  , shelleyLedgerGenesis
    -- * Auxiliary
  , ShelleyLedgerEvent (..)
  , ShelleyReapplyException (..)
  , getPParams
    -- * Serialisation
  , decodeShelleyAnnTip
  , decodeShelleyLedgerState
  , encodeShelleyAnnTip
  , encodeShelleyHeaderState
  , encodeShelleyLedgerState
  ) where

import qualified Cardano.Ledger.BaseTypes as SL (epochInfoPure)
import qualified Cardano.Ledger.BHeaderView as SL (BHeaderView)
import           Cardano.Ledger.Binary.Plain (FromCBOR (..), ToCBOR (..),
                     enforceSize)
import           Cardano.Ledger.Core (Era, ppMaxBHSizeL, ppMaxTxSizeL)
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.Shelley.Governance as SL
import qualified Cardano.Ledger.Shelley.LedgerState as SL
import           Cardano.Slotting.EpochInfo
import           Codec.CBOR.Decoding (Decoder)
import qualified Codec.CBOR.Decoding as CBOR
import           Codec.CBOR.Encoding (Encoding)
import qualified Codec.CBOR.Encoding as CBOR
import           Codec.Serialise (decode, encode)
import           Control.Arrow (left)
import qualified Control.Exception as Exception
import           Control.Monad.Except
import qualified Control.State.Transition.Extended as STS
import           Data.Coerce (coerce)
import           Data.Functor ((<&>))
import           Data.Functor.Identity
import qualified Data.Text as Text
import           Data.Word
import           GHC.Generics (Generic)
import           Lens.Micro.Extras (view)
import           NoThunks.Class (NoThunks (..))
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime.WallClock.Types
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HardFork.Abstract
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import           Ouroboros.Consensus.HardFork.History.Util
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.CommonProtocolParams
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch)
import           Ouroboros.Consensus.Shelley.Eras (EraCrypto)
import           Ouroboros.Consensus.Shelley.Ledger.Block
import           Ouroboros.Consensus.Shelley.Ledger.Config
import           Ouroboros.Consensus.Shelley.Ledger.Protocol ()
import           Ouroboros.Consensus.Shelley.Protocol.Abstract
                     (EnvelopeCheckError, envelopeChecks, mkHeaderView)
import           Ouroboros.Consensus.Util ((..:))
import           Ouroboros.Consensus.Util.CBOR (decodeWithOrigin,
                     encodeWithOrigin)
import           Ouroboros.Consensus.Util.Versioned

{-------------------------------------------------------------------------------
  Ledger errors
-------------------------------------------------------------------------------}

newtype ShelleyLedgerError era = BBodyError (SL.BlockTransitionError era)
  deriving ((forall x.
 ShelleyLedgerError era -> Rep (ShelleyLedgerError era) x)
-> (forall x.
    Rep (ShelleyLedgerError era) x -> ShelleyLedgerError era)
-> Generic (ShelleyLedgerError era)
forall x. Rep (ShelleyLedgerError era) x -> ShelleyLedgerError era
forall x. ShelleyLedgerError era -> Rep (ShelleyLedgerError era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleyLedgerError era) x -> ShelleyLedgerError era
forall era x.
ShelleyLedgerError era -> Rep (ShelleyLedgerError era) x
$cfrom :: forall era x.
ShelleyLedgerError era -> Rep (ShelleyLedgerError era) x
from :: forall x. ShelleyLedgerError era -> Rep (ShelleyLedgerError era) x
$cto :: forall era x.
Rep (ShelleyLedgerError era) x -> ShelleyLedgerError era
to :: forall x. Rep (ShelleyLedgerError era) x -> ShelleyLedgerError era
Generic)

deriving instance ShelleyBasedEra era => Eq   (ShelleyLedgerError era)
deriving instance ShelleyBasedEra era => Show (ShelleyLedgerError era)

instance ShelleyBasedEra era => NoThunks (ShelleyLedgerError era)

{-------------------------------------------------------------------------------
  Config
-------------------------------------------------------------------------------}

data ShelleyLedgerConfig era = ShelleyLedgerConfig {
      forall era.
ShelleyLedgerConfig era -> CompactGenesis (EraCrypto era)
shelleyLedgerCompactGenesis     :: !(CompactGenesis (EraCrypto era))
      -- | Derived from 'shelleyLedgerGenesis' but we store a cached version
      -- because it used very often.
    , forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals            :: !SL.Globals
    , forall era. ShelleyLedgerConfig era -> TranslationContext era
shelleyLedgerTranslationContext :: !(Core.TranslationContext era)
    }
  deriving ((forall x.
 ShelleyLedgerConfig era -> Rep (ShelleyLedgerConfig era) x)
-> (forall x.
    Rep (ShelleyLedgerConfig era) x -> ShelleyLedgerConfig era)
-> Generic (ShelleyLedgerConfig era)
forall x.
Rep (ShelleyLedgerConfig era) x -> ShelleyLedgerConfig era
forall x.
ShelleyLedgerConfig era -> Rep (ShelleyLedgerConfig era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleyLedgerConfig era) x -> ShelleyLedgerConfig era
forall era x.
ShelleyLedgerConfig era -> Rep (ShelleyLedgerConfig era) x
$cfrom :: forall era x.
ShelleyLedgerConfig era -> Rep (ShelleyLedgerConfig era) x
from :: forall x.
ShelleyLedgerConfig era -> Rep (ShelleyLedgerConfig era) x
$cto :: forall era x.
Rep (ShelleyLedgerConfig era) x -> ShelleyLedgerConfig era
to :: forall x.
Rep (ShelleyLedgerConfig era) x -> ShelleyLedgerConfig era
Generic)

deriving instance (NoThunks (Core.TranslationContext era), Era era) =>
    NoThunks (ShelleyLedgerConfig era)

shelleyLedgerGenesis :: ShelleyLedgerConfig era -> SL.ShelleyGenesis (EraCrypto era)
shelleyLedgerGenesis :: forall era.
ShelleyLedgerConfig era -> ShelleyGenesis (EraCrypto era)
shelleyLedgerGenesis = CompactGenesis (EraCrypto era) -> ShelleyGenesis (EraCrypto era)
forall c. CompactGenesis c -> ShelleyGenesis c
getCompactGenesis (CompactGenesis (EraCrypto era) -> ShelleyGenesis (EraCrypto era))
-> (ShelleyLedgerConfig era -> CompactGenesis (EraCrypto era))
-> ShelleyLedgerConfig era
-> ShelleyGenesis (EraCrypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerConfig era -> CompactGenesis (EraCrypto era)
forall era.
ShelleyLedgerConfig era -> CompactGenesis (EraCrypto era)
shelleyLedgerCompactGenesis

shelleyEraParams ::
     SL.ShelleyGenesis c
  -> HardFork.EraParams
shelleyEraParams :: forall c. ShelleyGenesis c -> EraParams
shelleyEraParams ShelleyGenesis c
genesis = HardFork.EraParams {
      eraEpochSize :: EpochSize
eraEpochSize  = ShelleyGenesis c -> EpochSize
forall c. ShelleyGenesis c -> EpochSize
SL.sgEpochLength ShelleyGenesis c
genesis
    , eraSlotLength :: SlotLength
eraSlotLength = NominalDiffTime -> SlotLength
mkSlotLength (NominalDiffTime -> SlotLength) -> NominalDiffTime -> SlotLength
forall a b. (a -> b) -> a -> b
$ NominalDiffTimeMicro -> NominalDiffTime
SL.fromNominalDiffTimeMicro (NominalDiffTimeMicro -> NominalDiffTime)
-> NominalDiffTimeMicro -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis c -> NominalDiffTimeMicro
forall c. ShelleyGenesis c -> NominalDiffTimeMicro
SL.sgSlotLength ShelleyGenesis c
genesis
    , eraSafeZone :: SafeZone
eraSafeZone   = Word64 -> SafeZone
HardFork.StandardSafeZone Word64
stabilityWindow
    , eraGenesisWin :: GenesisWindow
eraGenesisWin = Word64 -> GenesisWindow
GenesisWindow Word64
stabilityWindow
    }
  where
    stabilityWindow :: Word64
stabilityWindow =
        Word64 -> ActiveSlotCoeff -> Word64
SL.computeStabilityWindow
          (ShelleyGenesis c -> Word64
forall c. ShelleyGenesis c -> Word64
SL.sgSecurityParam ShelleyGenesis c
genesis)
          (ShelleyGenesis c -> ActiveSlotCoeff
forall c. ShelleyGenesis c -> ActiveSlotCoeff
SL.sgActiveSlotCoeff ShelleyGenesis c
genesis)

-- | Separate variant of 'shelleyEraParams' to be used for a Shelley-only chain.
shelleyEraParamsNeverHardForks :: SL.ShelleyGenesis c -> HardFork.EraParams
shelleyEraParamsNeverHardForks :: forall c. ShelleyGenesis c -> EraParams
shelleyEraParamsNeverHardForks ShelleyGenesis c
genesis = HardFork.EraParams {
      eraEpochSize :: EpochSize
eraEpochSize  = ShelleyGenesis c -> EpochSize
forall c. ShelleyGenesis c -> EpochSize
SL.sgEpochLength ShelleyGenesis c
genesis
    , eraSlotLength :: SlotLength
eraSlotLength = NominalDiffTime -> SlotLength
mkSlotLength (NominalDiffTime -> SlotLength) -> NominalDiffTime -> SlotLength
forall a b. (a -> b) -> a -> b
$ NominalDiffTimeMicro -> NominalDiffTime
SL.fromNominalDiffTimeMicro (NominalDiffTimeMicro -> NominalDiffTime)
-> NominalDiffTimeMicro -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis c -> NominalDiffTimeMicro
forall c. ShelleyGenesis c -> NominalDiffTimeMicro
SL.sgSlotLength ShelleyGenesis c
genesis
    , eraSafeZone :: SafeZone
eraSafeZone   = SafeZone
HardFork.UnsafeIndefiniteSafeZone
    , eraGenesisWin :: GenesisWindow
eraGenesisWin = Word64 -> GenesisWindow
GenesisWindow Word64
stabilityWindow
    }
  where
    stabilityWindow :: Word64
stabilityWindow =
        Word64 -> ActiveSlotCoeff -> Word64
SL.computeStabilityWindow
          (ShelleyGenesis c -> Word64
forall c. ShelleyGenesis c -> Word64
SL.sgSecurityParam ShelleyGenesis c
genesis)
          (ShelleyGenesis c -> ActiveSlotCoeff
forall c. ShelleyGenesis c -> ActiveSlotCoeff
SL.sgActiveSlotCoeff ShelleyGenesis c
genesis)

mkShelleyLedgerConfig ::
     SL.ShelleyGenesis (EraCrypto era)
  -> Core.TranslationContext era
  -> EpochInfo (Except HardFork.PastHorizonException)
  -> ShelleyLedgerConfig era
mkShelleyLedgerConfig :: forall era.
ShelleyGenesis (EraCrypto era)
-> TranslationContext era
-> EpochInfo (Except PastHorizonException)
-> ShelleyLedgerConfig era
mkShelleyLedgerConfig ShelleyGenesis (EraCrypto era)
genesis TranslationContext era
transCtxt EpochInfo (Except PastHorizonException)
epochInfo =
    ShelleyLedgerConfig {
        shelleyLedgerCompactGenesis :: CompactGenesis (EraCrypto era)
shelleyLedgerCompactGenesis     = ShelleyGenesis (EraCrypto era) -> CompactGenesis (EraCrypto era)
forall c. ShelleyGenesis c -> CompactGenesis c
compactGenesis ShelleyGenesis (EraCrypto era)
genesis
      , shelleyLedgerGlobals :: Globals
shelleyLedgerGlobals            =
          ShelleyGenesis (EraCrypto era)
-> EpochInfo (Either Text) -> Globals
forall c. ShelleyGenesis c -> EpochInfo (Either Text) -> Globals
SL.mkShelleyGlobals
            ShelleyGenesis (EraCrypto era)
genesis
            ((forall a. Except PastHorizonException a -> Either Text a)
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either Text)
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> EpochInfo m -> EpochInfo n
hoistEpochInfo ((PastHorizonException -> Text)
-> Either PastHorizonException a -> Either Text a
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (String -> Text
Text.pack (String -> Text)
-> (PastHorizonException -> String) -> PastHorizonException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PastHorizonException -> String
forall a. Show a => a -> String
show) (Either PastHorizonException a -> Either Text a)
-> (Except PastHorizonException a -> Either PastHorizonException a)
-> Except PastHorizonException a
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except PastHorizonException a -> Either PastHorizonException a
forall e a. Except e a -> Either e a
runExcept) EpochInfo (Except PastHorizonException)
epochInfo)
      , shelleyLedgerTranslationContext :: TranslationContext era
shelleyLedgerTranslationContext = TranslationContext era
transCtxt
      }

type instance LedgerCfg (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerConfig era

{-------------------------------------------------------------------------------
  LedgerState
-------------------------------------------------------------------------------}

data ShelleyTip proto era = ShelleyTip {
      forall proto era. ShelleyTip proto era -> SlotNo
shelleyTipSlotNo  :: !SlotNo
    , forall proto era. ShelleyTip proto era -> BlockNo
shelleyTipBlockNo :: !BlockNo
    , forall proto era.
ShelleyTip proto era -> HeaderHash (ShelleyBlock proto era)
shelleyTipHash    :: !(HeaderHash (ShelleyBlock proto era))
    }
  deriving (ShelleyTip proto era -> ShelleyTip proto era -> Bool
(ShelleyTip proto era -> ShelleyTip proto era -> Bool)
-> (ShelleyTip proto era -> ShelleyTip proto era -> Bool)
-> Eq (ShelleyTip proto era)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall proto era.
ShelleyTip proto era -> ShelleyTip proto era -> Bool
$c== :: forall proto era.
ShelleyTip proto era -> ShelleyTip proto era -> Bool
== :: ShelleyTip proto era -> ShelleyTip proto era -> Bool
$c/= :: forall proto era.
ShelleyTip proto era -> ShelleyTip proto era -> Bool
/= :: ShelleyTip proto era -> ShelleyTip proto era -> Bool
Eq, Int -> ShelleyTip proto era -> ShowS
[ShelleyTip proto era] -> ShowS
ShelleyTip proto era -> String
(Int -> ShelleyTip proto era -> ShowS)
-> (ShelleyTip proto era -> String)
-> ([ShelleyTip proto era] -> ShowS)
-> Show (ShelleyTip proto era)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall proto era. Int -> ShelleyTip proto era -> ShowS
forall proto era. [ShelleyTip proto era] -> ShowS
forall proto era. ShelleyTip proto era -> String
$cshowsPrec :: forall proto era. Int -> ShelleyTip proto era -> ShowS
showsPrec :: Int -> ShelleyTip proto era -> ShowS
$cshow :: forall proto era. ShelleyTip proto era -> String
show :: ShelleyTip proto era -> String
$cshowList :: forall proto era. [ShelleyTip proto era] -> ShowS
showList :: [ShelleyTip proto era] -> ShowS
Show, (forall x. ShelleyTip proto era -> Rep (ShelleyTip proto era) x)
-> (forall x. Rep (ShelleyTip proto era) x -> ShelleyTip proto era)
-> Generic (ShelleyTip proto era)
forall x. Rep (ShelleyTip proto era) x -> ShelleyTip proto era
forall x. ShelleyTip proto era -> Rep (ShelleyTip proto era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era x.
Rep (ShelleyTip proto era) x -> ShelleyTip proto era
forall proto era x.
ShelleyTip proto era -> Rep (ShelleyTip proto era) x
$cfrom :: forall proto era x.
ShelleyTip proto era -> Rep (ShelleyTip proto era) x
from :: forall x. ShelleyTip proto era -> Rep (ShelleyTip proto era) x
$cto :: forall proto era x.
Rep (ShelleyTip proto era) x -> ShelleyTip proto era
to :: forall x. Rep (ShelleyTip proto era) x -> ShelleyTip proto era
Generic, Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
Proxy (ShelleyTip proto era) -> String
(Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo))
-> (Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo))
-> (Proxy (ShelleyTip proto era) -> String)
-> NoThunks (ShelleyTip proto era)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall proto era.
Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
forall proto era. Proxy (ShelleyTip proto era) -> String
$cnoThunks :: forall proto era.
Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
noThunks :: Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall proto era.
Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall proto era. Proxy (ShelleyTip proto era) -> String
showTypeOf :: Proxy (ShelleyTip proto era) -> String
NoThunks)

shelleyTipToPoint :: WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
shelleyTipToPoint :: forall proto era.
WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
shelleyTipToPoint WithOrigin (ShelleyTip proto era)
Origin          = Point (ShelleyBlock proto era)
forall {k} (block :: k). Point block
GenesisPoint
shelleyTipToPoint (NotOrigin ShelleyTip proto era
tip) = SlotNo
-> HeaderHash (ShelleyBlock proto era)
-> Point (ShelleyBlock proto era)
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint (ShelleyTip proto era -> SlotNo
forall proto era. ShelleyTip proto era -> SlotNo
shelleyTipSlotNo ShelleyTip proto era
tip)
                                               (ShelleyTip proto era -> HeaderHash (ShelleyBlock proto era)
forall proto era.
ShelleyTip proto era -> HeaderHash (ShelleyBlock proto era)
shelleyTipHash   ShelleyTip proto era
tip)

castShelleyTip ::
     HeaderHash (ShelleyBlock proto era) ~ HeaderHash (ShelleyBlock proto' era')
  => ShelleyTip proto era -> ShelleyTip proto' era'
castShelleyTip :: forall proto era proto' era'.
(HeaderHash (ShelleyBlock proto era)
 ~ HeaderHash (ShelleyBlock proto' era')) =>
ShelleyTip proto era -> ShelleyTip proto' era'
castShelleyTip (ShelleyTip SlotNo
sn BlockNo
bn HeaderHash (ShelleyBlock proto era)
hh) = ShelleyTip {
      shelleyTipSlotNo :: SlotNo
shelleyTipSlotNo  = SlotNo
sn
    , shelleyTipBlockNo :: BlockNo
shelleyTipBlockNo = BlockNo
bn
    , shelleyTipHash :: HeaderHash (ShelleyBlock proto' era')
shelleyTipHash    = ShelleyHash (ProtoCrypto proto')
-> ShelleyHash (ProtoCrypto proto')
forall a b. Coercible a b => a -> b
coerce HeaderHash (ShelleyBlock proto era)
ShelleyHash (ProtoCrypto proto')
hh
    }

data instance LedgerState (ShelleyBlock proto era) = ShelleyLedgerState {
      forall proto era.
LedgerState (ShelleyBlock proto era)
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip        :: !(WithOrigin (ShelleyTip proto era))
    , forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
shelleyLedgerState      :: !(SL.NewEpochState era)
    , forall proto era.
LedgerState (ShelleyBlock proto era) -> ShelleyTransition
shelleyLedgerTransition :: !ShelleyTransition
    }
  deriving ((forall x.
 LedgerState (ShelleyBlock proto era)
 -> Rep (LedgerState (ShelleyBlock proto era)) x)
-> (forall x.
    Rep (LedgerState (ShelleyBlock proto era)) x
    -> LedgerState (ShelleyBlock proto era))
-> Generic (LedgerState (ShelleyBlock proto era))
forall x.
Rep (LedgerState (ShelleyBlock proto era)) x
-> LedgerState (ShelleyBlock proto era)
forall x.
LedgerState (ShelleyBlock proto era)
-> Rep (LedgerState (ShelleyBlock proto era)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era x.
Rep (LedgerState (ShelleyBlock proto era)) x
-> LedgerState (ShelleyBlock proto era)
forall proto era x.
LedgerState (ShelleyBlock proto era)
-> Rep (LedgerState (ShelleyBlock proto era)) x
$cfrom :: forall proto era x.
LedgerState (ShelleyBlock proto era)
-> Rep (LedgerState (ShelleyBlock proto era)) x
from :: forall x.
LedgerState (ShelleyBlock proto era)
-> Rep (LedgerState (ShelleyBlock proto era)) x
$cto :: forall proto era x.
Rep (LedgerState (ShelleyBlock proto era)) x
-> LedgerState (ShelleyBlock proto era)
to :: forall x.
Rep (LedgerState (ShelleyBlock proto era)) x
-> LedgerState (ShelleyBlock proto era)
Generic)

deriving instance ShelleyBasedEra era => Show     (LedgerState (ShelleyBlock proto era))
deriving instance ShelleyBasedEra era => Eq       (LedgerState (ShelleyBlock proto era))
deriving instance ShelleyBasedEra era => NoThunks (LedgerState (ShelleyBlock proto era))

-- | Information required to determine the hard fork point from Shelley to the
-- next ledger
newtype ShelleyTransition = ShelleyTransitionInfo {
      -- | The number of blocks in this epoch past the voting deadline
      --
      -- We record this to make sure that we can tell the HFC about hard forks
      -- if and only if we are certain:
      --
      -- 1. Blocks that came in within an epoch after the 4k/f voting deadline
      --    are not relevant (10k/f - 2 * 3k/f).
      -- 2. Since there are slots between blocks, we are probably only sure that
      --    there will be no more relevant block when we have seen the first
      --    block after the deadline.
      -- 3. If we count how many blocks we have seen post deadline, and we have
      --    reached k of them, we know that that last pre-deadline block won't
      --    be rolled back anymore.
      -- 4. At this point we can look at the ledger state and see if there is
      --    a new protocol version update scheduled on the next epoch boundary,
      --    and notify the HFC that we need to transition into a new era at that
      --    point.
      ShelleyTransition -> Word32
shelleyAfterVoting :: Word32
    }
  deriving stock   (ShelleyTransition -> ShelleyTransition -> Bool
(ShelleyTransition -> ShelleyTransition -> Bool)
-> (ShelleyTransition -> ShelleyTransition -> Bool)
-> Eq ShelleyTransition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShelleyTransition -> ShelleyTransition -> Bool
== :: ShelleyTransition -> ShelleyTransition -> Bool
$c/= :: ShelleyTransition -> ShelleyTransition -> Bool
/= :: ShelleyTransition -> ShelleyTransition -> Bool
Eq, Int -> ShelleyTransition -> ShowS
[ShelleyTransition] -> ShowS
ShelleyTransition -> String
(Int -> ShelleyTransition -> ShowS)
-> (ShelleyTransition -> String)
-> ([ShelleyTransition] -> ShowS)
-> Show ShelleyTransition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShelleyTransition -> ShowS
showsPrec :: Int -> ShelleyTransition -> ShowS
$cshow :: ShelleyTransition -> String
show :: ShelleyTransition -> String
$cshowList :: [ShelleyTransition] -> ShowS
showList :: [ShelleyTransition] -> ShowS
Show, (forall x. ShelleyTransition -> Rep ShelleyTransition x)
-> (forall x. Rep ShelleyTransition x -> ShelleyTransition)
-> Generic ShelleyTransition
forall x. Rep ShelleyTransition x -> ShelleyTransition
forall x. ShelleyTransition -> Rep ShelleyTransition x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ShelleyTransition -> Rep ShelleyTransition x
from :: forall x. ShelleyTransition -> Rep ShelleyTransition x
$cto :: forall x. Rep ShelleyTransition x -> ShelleyTransition
to :: forall x. Rep ShelleyTransition x -> ShelleyTransition
Generic)
  deriving newtype (Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
Proxy ShelleyTransition -> String
(Context -> ShelleyTransition -> IO (Maybe ThunkInfo))
-> (Context -> ShelleyTransition -> IO (Maybe ThunkInfo))
-> (Proxy ShelleyTransition -> String)
-> NoThunks ShelleyTransition
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
noThunks :: Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ShelleyTransition -> String
showTypeOf :: Proxy ShelleyTransition -> String
NoThunks)

shelleyLedgerTipPoint :: LedgerState (ShelleyBlock proto era) -> Point (ShelleyBlock proto era)
shelleyLedgerTipPoint :: forall proto era.
LedgerState (ShelleyBlock proto era)
-> Point (ShelleyBlock proto era)
shelleyLedgerTipPoint = WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
forall proto era.
WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
shelleyTipToPoint (WithOrigin (ShelleyTip proto era)
 -> Point (ShelleyBlock proto era))
-> (LedgerState (ShelleyBlock proto era)
    -> WithOrigin (ShelleyTip proto era))
-> LedgerState (ShelleyBlock proto era)
-> Point (ShelleyBlock proto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era)
-> WithOrigin (ShelleyTip proto era)
forall proto era.
LedgerState (ShelleyBlock proto era)
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip

instance ShelleyCompatible proto era => UpdateLedger (ShelleyBlock proto era)

{-------------------------------------------------------------------------------
  GetTip
-------------------------------------------------------------------------------}

instance GetTip (LedgerState (ShelleyBlock proto era)) where
  getTip :: LedgerState (ShelleyBlock proto era)
-> Point (LedgerState (ShelleyBlock proto era))
getTip = Point (ShelleyBlock proto era)
-> Point (LedgerState (ShelleyBlock proto era))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (ShelleyBlock proto era)
 -> Point (LedgerState (ShelleyBlock proto era)))
-> (LedgerState (ShelleyBlock proto era)
    -> Point (ShelleyBlock proto era))
-> LedgerState (ShelleyBlock proto era)
-> Point (LedgerState (ShelleyBlock proto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era)
-> Point (ShelleyBlock proto era)
forall proto era.
LedgerState (ShelleyBlock proto era)
-> Point (ShelleyBlock proto era)
shelleyLedgerTipPoint

instance GetTip (Ticked (LedgerState (ShelleyBlock proto era))) where
  getTip :: Ticked (LedgerState (ShelleyBlock proto era))
-> Point (Ticked (LedgerState (ShelleyBlock proto era)))
getTip = Point (ShelleyBlock proto era)
-> Point (Ticked (LedgerState (ShelleyBlock proto era)))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (ShelleyBlock proto era)
 -> Point (Ticked (LedgerState (ShelleyBlock proto era))))
-> (Ticked (LedgerState (ShelleyBlock proto era))
    -> Point (ShelleyBlock proto era))
-> Ticked (LedgerState (ShelleyBlock proto era))
-> Point (Ticked (LedgerState (ShelleyBlock proto era)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (ShelleyBlock proto era))
-> Point (ShelleyBlock proto era)
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era))
-> Point (ShelleyBlock proto era)
untickedShelleyLedgerTipPoint

{-------------------------------------------------------------------------------
  Ticking
-------------------------------------------------------------------------------}

-- | Ticking only affects the state itself
data instance Ticked (LedgerState (ShelleyBlock proto era)) = TickedShelleyLedgerState {
      forall proto era.
Ticked (LedgerState (ShelleyBlock proto era))
-> WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip      :: !(WithOrigin (ShelleyTip proto era))
      -- | We are counting blocks within an epoch, this means:
      --
      -- 1. We are only incrementing this when /applying/ a block, not when ticking.
      -- 2. However, we count within an epoch, which is slot-based. So the count
      --    must be reset when /ticking/, not when applying a block.
    , forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> ShelleyTransition
tickedShelleyLedgerTransition :: !ShelleyTransition
    , forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState      :: !(SL.NewEpochState era)
    }
  deriving ((forall x.
 Ticked (LedgerState (ShelleyBlock proto era))
 -> Rep (Ticked (LedgerState (ShelleyBlock proto era))) x)
-> (forall x.
    Rep (Ticked (LedgerState (ShelleyBlock proto era))) x
    -> Ticked (LedgerState (ShelleyBlock proto era)))
-> Generic (Ticked (LedgerState (ShelleyBlock proto era)))
forall x.
Rep (Ticked (LedgerState (ShelleyBlock proto era))) x
-> Ticked (LedgerState (ShelleyBlock proto era))
forall x.
Ticked (LedgerState (ShelleyBlock proto era))
-> Rep (Ticked (LedgerState (ShelleyBlock proto era))) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era x.
Rep (Ticked (LedgerState (ShelleyBlock proto era))) x
-> Ticked (LedgerState (ShelleyBlock proto era))
forall proto era x.
Ticked (LedgerState (ShelleyBlock proto era))
-> Rep (Ticked (LedgerState (ShelleyBlock proto era))) x
$cfrom :: forall proto era x.
Ticked (LedgerState (ShelleyBlock proto era))
-> Rep (Ticked (LedgerState (ShelleyBlock proto era))) x
from :: forall x.
Ticked (LedgerState (ShelleyBlock proto era))
-> Rep (Ticked (LedgerState (ShelleyBlock proto era))) x
$cto :: forall proto era x.
Rep (Ticked (LedgerState (ShelleyBlock proto era))) x
-> Ticked (LedgerState (ShelleyBlock proto era))
to :: forall x.
Rep (Ticked (LedgerState (ShelleyBlock proto era))) x
-> Ticked (LedgerState (ShelleyBlock proto era))
Generic)

deriving instance ShelleyBasedEra era
               => NoThunks (Ticked (LedgerState (ShelleyBlock proto era)))

untickedShelleyLedgerTipPoint ::
     Ticked (LedgerState (ShelleyBlock proto era))
  -> Point (ShelleyBlock proto era)
untickedShelleyLedgerTipPoint :: forall proto era.
Ticked (LedgerState (ShelleyBlock proto era))
-> Point (ShelleyBlock proto era)
untickedShelleyLedgerTipPoint = WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
forall proto era.
WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
shelleyTipToPoint (WithOrigin (ShelleyTip proto era)
 -> Point (ShelleyBlock proto era))
-> (Ticked (LedgerState (ShelleyBlock proto era))
    -> WithOrigin (ShelleyTip proto era))
-> Ticked (LedgerState (ShelleyBlock proto era))
-> Point (ShelleyBlock proto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (ShelleyBlock proto era))
-> WithOrigin (ShelleyTip proto era)
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era))
-> WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip

instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era)) where
  type LedgerErr (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerError era

  type AuxLedgerEvent (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerEvent era

  applyChainTickLedgerResult :: LedgerCfg (LedgerState (ShelleyBlock proto era))
-> SlotNo
-> LedgerState (ShelleyBlock proto era)
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (Ticked (LedgerState (ShelleyBlock proto era)))
applyChainTickLedgerResult LedgerCfg (LedgerState (ShelleyBlock proto era))
cfg SlotNo
slotNo ShelleyLedgerState{
                                WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: forall proto era.
LedgerState (ShelleyBlock proto era)
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
                              , NewEpochState era
shelleyLedgerState :: forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState
                              , ShelleyTransition
shelleyLedgerTransition :: forall proto era.
LedgerState (ShelleyBlock proto era) -> ShelleyTransition
shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition
                              } =
      (NewEpochState era, [Event (EraRule "TICK" era)])
-> LedgerResult
     (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
forall {l} {era} {a}.
(AuxLedgerEvent l ~ ShelleyLedgerEvent era) =>
(a, [Event (EraRule "TICK" era)]) -> LedgerResult l a
swizzle (NewEpochState era, [Event (EraRule "TICK" era)])
EventReturnType
  'EventPolicyReturn (EraRule "TICK" era) (NewEpochState era)
appTick LedgerResult
  (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
-> (NewEpochState era
    -> Ticked (LedgerState (ShelleyBlock proto era)))
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (Ticked (LedgerState (ShelleyBlock proto era)))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \NewEpochState era
l' ->
      TickedShelleyLedgerState {
          untickedShelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
untickedShelleyLedgerTip =
            WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
        , tickedShelleyLedgerTransition :: ShelleyTransition
tickedShelleyLedgerTransition =
            -- The voting resets each epoch
            if EpochInfo Identity -> WithOrigin SlotNo -> SlotNo -> Bool
isNewEpoch EpochInfo Identity
ei (ShelleyTip proto era -> SlotNo
forall proto era. ShelleyTip proto era -> SlotNo
shelleyTipSlotNo (ShelleyTip proto era -> SlotNo)
-> WithOrigin (ShelleyTip proto era) -> WithOrigin SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip) SlotNo
slotNo then
              ShelleyTransitionInfo { shelleyAfterVoting :: Word32
shelleyAfterVoting = Word32
0 }
            else
              ShelleyTransition
shelleyLedgerTransition
        , tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState = NewEpochState era
l'
        }
    where
      globals :: Globals
globals = ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals LedgerCfg (LedgerState (ShelleyBlock proto era))
ShelleyLedgerConfig era
cfg

      ei :: EpochInfo Identity
      ei :: EpochInfo Identity
ei = Globals -> EpochInfo Identity
SL.epochInfoPure Globals
globals

      swizzle :: (a, [Event (EraRule "TICK" era)]) -> LedgerResult l a
swizzle (a
l, [Event (EraRule "TICK" era)]
events) =
          LedgerResult {
              lrEvents :: [AuxLedgerEvent l]
lrEvents = (Event (EraRule "TICK" era) -> ShelleyLedgerEvent era)
-> [Event (EraRule "TICK" era)] -> [ShelleyLedgerEvent era]
forall a b. (a -> b) -> [a] -> [b]
map Event (EraRule "TICK" era) -> ShelleyLedgerEvent era
forall era. Event (EraRule "TICK" era) -> ShelleyLedgerEvent era
ShelleyLedgerEventTICK [Event (EraRule "TICK" era)]
events
            , lrResult :: a
lrResult = a
l
            }

      appTick :: EventReturnType
  'EventPolicyReturn (EraRule "TICK" era) (NewEpochState era)
appTick =
        ApplySTSOpts 'EventPolicyReturn
-> Globals
-> NewEpochState era
-> SlotNo
-> EventReturnType
     'EventPolicyReturn (EraRule "TICK" era) (NewEpochState era)
forall era (ep :: EventPolicy).
ApplyBlock era =>
ApplySTSOpts ep
-> Globals
-> NewEpochState era
-> SlotNo
-> EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
forall (ep :: EventPolicy).
ApplySTSOpts ep
-> Globals
-> NewEpochState era
-> SlotNo
-> EventReturnType ep (EraRule "TICK" era) (NewEpochState era)
SL.applyTickOpts
          STS.ApplySTSOpts {
              asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
STS.globalAssertionPolicy
            , asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
STS.ValidateAll
            , asoEvents :: SingEP 'EventPolicyReturn
asoEvents     = SingEP 'EventPolicyReturn
STS.EPReturn
            }
          Globals
globals
          NewEpochState era
shelleyLedgerState
          SlotNo
slotNo

-- | All events emitted by the Shelley ledger API
data ShelleyLedgerEvent era =
    -- | An event emitted when (re)applying a block
    ShelleyLedgerEventBBODY (STS.Event (Core.EraRule "BBODY" era))
    -- | An event emitted during the chain tick
  | ShelleyLedgerEventTICK  (STS.Event (Core.EraRule "TICK"  era))

instance ShelleyCompatible proto era
      => ApplyBlock (LedgerState (ShelleyBlock proto era)) (ShelleyBlock proto era) where
  -- Note: in the Shelley ledger, the @CHAIN@ rule is used to apply a whole
  -- block. In consensus, we split up the application of a block to the ledger
  -- into separate steps that are performed together by 'applyExtLedgerState':
  --
  -- + 'applyChainTickLedgerResult': executes the @TICK@ transition
  -- + 'validateHeader':
  --    - 'validateEnvelope': executes the @chainChecks@
  --    - 'updateChainDepState': executes the @PRTCL@ transition
  -- + 'applyBlockLedgerResult': executes the @BBODY@ transition
  --
  applyBlockLedgerResult :: HasCallStack =>
LedgerCfg (LedgerState (ShelleyBlock proto era))
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era))
-> Except
     (LedgerErr (LedgerState (ShelleyBlock proto era)))
     (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era)))
applyBlockLedgerResult =
      (Globals
 -> NewEpochState era
 -> Block (BHeaderView (EraCrypto era)) era
 -> ExceptT
      (ShelleyLedgerError era)
      Identity
      (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> LedgerCfg (LedgerState (ShelleyBlock proto era))
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era))
-> ExceptT
     (ShelleyLedgerError era)
     Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era)))
forall proto era (m :: * -> *).
(ShelleyCompatible proto era, Monad m) =>
(Globals
 -> NewEpochState era
 -> Block (BHeaderView (EraCrypto era)) era
 -> m (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> LedgerConfig (ShelleyBlock proto era)
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era))
-> m (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era)))
applyHelper (Except
  (BlockTransitionError era)
  (NewEpochState era, [Event (EraRule "BBODY" era)])
-> ExceptT
     (ShelleyLedgerError era)
     Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
forall {l} {era} {era} {a}.
(AuxLedgerEvent l ~ ShelleyLedgerEvent era) =>
Except
  (BlockTransitionError era) (a, [Event (EraRule "BBODY" era)])
-> ExceptT (ShelleyLedgerError era) Identity (LedgerResult l a)
swizzle (Except
   (BlockTransitionError era)
   (NewEpochState era, [Event (EraRule "BBODY" era)])
 -> ExceptT
      (ShelleyLedgerError era)
      Identity
      (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> (Globals
    -> NewEpochState era
    -> Block (BHeaderView (ProtoCrypto proto)) era
    -> Except
         (BlockTransitionError era)
         (NewEpochState era, [Event (EraRule "BBODY" era)]))
-> Globals
-> NewEpochState era
-> Block (BHeaderView (ProtoCrypto proto)) era
-> ExceptT
     (ShelleyLedgerError era)
     Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> Except
     (BlockTransitionError era)
     (NewEpochState era, [Event (EraRule "BBODY" era)])
Globals
-> NewEpochState era
-> Block (BHeaderView (ProtoCrypto proto)) era
-> Except
     (BlockTransitionError era)
     (NewEpochState era, [Event (EraRule "BBODY" era)])
appBlk)
    where
      swizzle :: Except
  (BlockTransitionError era) (a, [Event (EraRule "BBODY" era)])
-> ExceptT (ShelleyLedgerError era) Identity (LedgerResult l a)
swizzle Except
  (BlockTransitionError era) (a, [Event (EraRule "BBODY" era)])
m =
        (BlockTransitionError era -> ShelleyLedgerError era)
-> Except
     (BlockTransitionError era) (a, [Event (EraRule "BBODY" era)])
-> Except
     (ShelleyLedgerError era) (a, [Event (EraRule "BBODY" era)])
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept BlockTransitionError era -> ShelleyLedgerError era
forall era. BlockTransitionError era -> ShelleyLedgerError era
BBodyError Except
  (BlockTransitionError era) (a, [Event (EraRule "BBODY" era)])
m Except (ShelleyLedgerError era) (a, [Event (EraRule "BBODY" era)])
-> ((a, [Event (EraRule "BBODY" era)]) -> LedgerResult l a)
-> ExceptT (ShelleyLedgerError era) Identity (LedgerResult l a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(a
l, [Event (EraRule "BBODY" era)]
events) ->
          LedgerResult {
              lrEvents :: [AuxLedgerEvent l]
lrEvents = (Event (EraRule "BBODY" era) -> ShelleyLedgerEvent era)
-> [Event (EraRule "BBODY" era)] -> [ShelleyLedgerEvent era]
forall a b. (a -> b) -> [a] -> [b]
map Event (EraRule "BBODY" era) -> ShelleyLedgerEvent era
forall era. Event (EraRule "BBODY" era) -> ShelleyLedgerEvent era
ShelleyLedgerEventBBODY [Event (EraRule "BBODY" era)]
events
            , lrResult :: a
lrResult = a
l
            }

      -- Apply the BBODY transition using the ticked state
      appBlk :: Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> ExceptT
     (BlockTransitionError era)
     Identity
     (EventReturnType
        'EventPolicyReturn (EraRule "BBODY" era) (NewEpochState era))
appBlk =
        ApplySTSOpts 'EventPolicyReturn
-> Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> ExceptT
     (BlockTransitionError era)
     Identity
     (EventReturnType
        'EventPolicyReturn (EraRule "BBODY" era) (NewEpochState era))
forall era (ep :: EventPolicy) (m :: * -> *).
(ApplyBlock era, EventReturnTypeRep ep,
 MonadError (BlockTransitionError era) m) =>
ApplySTSOpts ep
-> Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
forall (ep :: EventPolicy) (m :: * -> *).
(EventReturnTypeRep ep, MonadError (BlockTransitionError era) m) =>
ApplySTSOpts ep
-> Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
SL.applyBlockOpts
          STS.ApplySTSOpts {
              asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
STS.globalAssertionPolicy
            , asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
STS.ValidateAll
            , asoEvents :: SingEP 'EventPolicyReturn
asoEvents     = SingEP 'EventPolicyReturn
STS.EPReturn
            }

  reapplyBlockLedgerResult :: HasCallStack =>
LedgerCfg (LedgerState (ShelleyBlock proto era))
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era))
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (LedgerState (ShelleyBlock proto era))
reapplyBlockLedgerResult =
      Identity
  (LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (LedgerState (ShelleyBlock proto era)))
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (LedgerState (ShelleyBlock proto era))
forall a. Identity a -> a
runIdentity (Identity
   (LedgerResult
      (LedgerState (ShelleyBlock proto era))
      (LedgerState (ShelleyBlock proto era)))
 -> LedgerResult
      (LedgerState (ShelleyBlock proto era))
      (LedgerState (ShelleyBlock proto era)))
-> (ShelleyLedgerConfig era
    -> ShelleyBlock proto era
    -> Ticked (LedgerState (ShelleyBlock proto era))
    -> Identity
         (LedgerResult
            (LedgerState (ShelleyBlock proto era))
            (LedgerState (ShelleyBlock proto era))))
-> ShelleyLedgerConfig era
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era))
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (LedgerState (ShelleyBlock proto era))
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: (Globals
 -> NewEpochState era
 -> Block (BHeaderView (EraCrypto era)) era
 -> Identity
      (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> LedgerCfg (LedgerState (ShelleyBlock proto era))
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era))
-> Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era)))
forall proto era (m :: * -> *).
(ShelleyCompatible proto era, Monad m) =>
(Globals
 -> NewEpochState era
 -> Block (BHeaderView (EraCrypto era)) era
 -> m (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> LedgerConfig (ShelleyBlock proto era)
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era))
-> m (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era)))
applyHelper (Except
  (BlockTransitionError era)
  (NewEpochState era, [Event (EraRule "BBODY" era)])
-> Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
swizzle (Except
   (BlockTransitionError era)
   (NewEpochState era, [Event (EraRule "BBODY" era)])
 -> Identity
      (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> (Globals
    -> NewEpochState era
    -> Block (BHeaderView (ProtoCrypto proto)) era
    -> Except
         (BlockTransitionError era)
         (NewEpochState era, [Event (EraRule "BBODY" era)]))
-> Globals
-> NewEpochState era
-> Block (BHeaderView (ProtoCrypto proto)) era
-> Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
forall y z x0 x1 x2.
(y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z
..: Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> Except
     (BlockTransitionError era)
     (NewEpochState era, [Event (EraRule "BBODY" era)])
Globals
-> NewEpochState era
-> Block (BHeaderView (ProtoCrypto proto)) era
-> Except
     (BlockTransitionError era)
     (NewEpochState era, [Event (EraRule "BBODY" era)])
reappBlk)
    where
      swizzle :: Except
  (BlockTransitionError era)
  (NewEpochState era, [Event (EraRule "BBODY" era)])
-> Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
swizzle Except
  (BlockTransitionError era)
  (NewEpochState era, [Event (EraRule "BBODY" era)])
m = case Except
  (BlockTransitionError era)
  (NewEpochState era, [Event (EraRule "BBODY" era)])
-> Either
     (BlockTransitionError era)
     (NewEpochState era, [Event (EraRule "BBODY" era)])
forall e a. Except e a -> Either e a
runExcept Except
  (BlockTransitionError era)
  (NewEpochState era, [Event (EraRule "BBODY" era)])
m of
        Left BlockTransitionError era
err          ->
          ShelleyReapplyException
-> Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
forall a e. Exception e => e -> a
Exception.throw (ShelleyReapplyException
 -> Identity
      (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> ShelleyReapplyException
-> Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
forall a b. (a -> b) -> a -> b
$! forall era.
Show (BlockTransitionError era) =>
BlockTransitionError era -> ShelleyReapplyException
ShelleyReapplyException @era BlockTransitionError era
err
        Right (NewEpochState era
l, [Event (EraRule "BBODY" era)]
events) ->
          LedgerResult
  (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
-> Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerResult {
              lrEvents :: [AuxLedgerEvent (LedgerState (ShelleyBlock proto era))]
lrEvents = (Event (EraRule "BBODY" era) -> ShelleyLedgerEvent era)
-> [Event (EraRule "BBODY" era)] -> [ShelleyLedgerEvent era]
forall a b. (a -> b) -> [a] -> [b]
map Event (EraRule "BBODY" era) -> ShelleyLedgerEvent era
forall era. Event (EraRule "BBODY" era) -> ShelleyLedgerEvent era
ShelleyLedgerEventBBODY [Event (EraRule "BBODY" era)]
events
            , lrResult :: NewEpochState era
lrResult = NewEpochState era
l
            }

      -- Reapply the BBODY transition using the ticked state
      reappBlk :: Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> ExceptT
     (BlockTransitionError era)
     Identity
     (EventReturnType
        'EventPolicyReturn (EraRule "BBODY" era) (NewEpochState era))
reappBlk =
        ApplySTSOpts 'EventPolicyReturn
-> Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> ExceptT
     (BlockTransitionError era)
     Identity
     (EventReturnType
        'EventPolicyReturn (EraRule "BBODY" era) (NewEpochState era))
forall era (ep :: EventPolicy) (m :: * -> *).
(ApplyBlock era, EventReturnTypeRep ep,
 MonadError (BlockTransitionError era) m) =>
ApplySTSOpts ep
-> Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
forall (ep :: EventPolicy) (m :: * -> *).
(EventReturnTypeRep ep, MonadError (BlockTransitionError era) m) =>
ApplySTSOpts ep
-> Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
SL.applyBlockOpts
          STS.ApplySTSOpts {
                  asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
STS.AssertionsOff
                , asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
STS.ValidateNone
                , asoEvents :: SingEP 'EventPolicyReturn
asoEvents     = SingEP 'EventPolicyReturn
STS.EPReturn
                }

data ShelleyReapplyException =
  forall era. Show (SL.BlockTransitionError era)
  => ShelleyReapplyException (SL.BlockTransitionError era)

instance Show ShelleyReapplyException where
  show :: ShelleyReapplyException -> String
show (ShelleyReapplyException BlockTransitionError era
err) = String
"(ShelleyReapplyException " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> BlockTransitionError era -> String
forall a. Show a => a -> String
show BlockTransitionError era
err String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

instance Exception.Exception ShelleyReapplyException where

applyHelper ::
     (ShelleyCompatible proto era, Monad m)
  => (   SL.Globals
      -> SL.NewEpochState era
      -> SL.Block (SL.BHeaderView (EraCrypto era)) era
      -> m (LedgerResult
              (LedgerState (ShelleyBlock proto era))
              (SL.NewEpochState era)
           )
     )
  -> LedgerConfig (ShelleyBlock proto era)
  -> ShelleyBlock proto era
  -> Ticked (LedgerState (ShelleyBlock proto era))
  -> m (LedgerResult
          (LedgerState (ShelleyBlock proto era))
          (LedgerState (ShelleyBlock proto era)))
applyHelper :: forall proto era (m :: * -> *).
(ShelleyCompatible proto era, Monad m) =>
(Globals
 -> NewEpochState era
 -> Block (BHeaderView (EraCrypto era)) era
 -> m (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> LedgerConfig (ShelleyBlock proto era)
-> ShelleyBlock proto era
-> Ticked (LedgerState (ShelleyBlock proto era))
-> m (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era)))
applyHelper Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> m (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
f LedgerConfig (ShelleyBlock proto era)
cfg ShelleyBlock proto era
blk TickedShelleyLedgerState{
                          ShelleyTransition
tickedShelleyLedgerTransition :: forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> ShelleyTransition
tickedShelleyLedgerTransition :: ShelleyTransition
tickedShelleyLedgerTransition
                        , NewEpochState era
tickedShelleyLedgerState :: forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState :: NewEpochState era
tickedShelleyLedgerState
                        } = do
    LedgerResult
  (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
ledgerResult <-
      Globals
-> NewEpochState era
-> Block (BHeaderView (EraCrypto era)) era
-> m (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
f
        Globals
globals
        NewEpochState era
tickedShelleyLedgerState
        ( let b :: Block (ShelleyProtocolHeader proto) era
b  = ShelleyBlock proto era -> Block (ShelleyProtocolHeader proto) era
forall proto era.
ShelleyBlock proto era -> Block (ShelleyProtocolHeader proto) era
shelleyBlockRaw ShelleyBlock proto era
blk
              h' :: BHeaderView (ProtoCrypto proto)
h' = ShelleyProtocolHeader proto -> BHeaderView (ProtoCrypto proto)
forall proto.
ProtocolHeaderSupportsLedger proto =>
ShelleyProtocolHeader proto -> BHeaderView (ProtoCrypto proto)
mkHeaderView (Block (ShelleyProtocolHeader proto) era
-> ShelleyProtocolHeader proto
forall h era. Block h era -> h
SL.bheader Block (ShelleyProtocolHeader proto) era
b)
          -- Jared Corduan explains that the " Unsafe " here ultimately only
          -- means the value must not be serialized. We're only passing it to
          -- 'STS.applyBlockOpts', which does not serialize it. So this is a
          -- safe use.
          in BHeaderView (ProtoCrypto proto)
-> TxSeq era -> Block (BHeaderView (ProtoCrypto proto)) era
forall h era. h -> TxSeq era -> Block h era
SL.UnsafeUnserialisedBlock BHeaderView (ProtoCrypto proto)
h' (Block (ShelleyProtocolHeader proto) era -> TxSeq era
forall h era. Block h era -> TxSeq era
SL.bbody Block (ShelleyProtocolHeader proto) era
b)
        )

    LedgerResult
  (LedgerState (ShelleyBlock proto era))
  (LedgerState (ShelleyBlock proto era))
-> m (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerResult
   (LedgerState (ShelleyBlock proto era))
   (LedgerState (ShelleyBlock proto era))
 -> m (LedgerResult
         (LedgerState (ShelleyBlock proto era))
         (LedgerState (ShelleyBlock proto era))))
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (LedgerState (ShelleyBlock proto era))
-> m (LedgerResult
        (LedgerState (ShelleyBlock proto era))
        (LedgerState (ShelleyBlock proto era)))
forall a b. (a -> b) -> a -> b
$ LedgerResult
  (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
ledgerResult LedgerResult
  (LedgerState (ShelleyBlock proto era)) (NewEpochState era)
-> (NewEpochState era -> LedgerState (ShelleyBlock proto era))
-> LedgerResult
     (LedgerState (ShelleyBlock proto era))
     (LedgerState (ShelleyBlock proto era))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \NewEpochState era
newNewEpochState -> ShelleyLedgerState {
        shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip = ShelleyTip proto era -> WithOrigin (ShelleyTip proto era)
forall t. t -> WithOrigin t
NotOrigin ShelleyTip {
            shelleyTipBlockNo :: BlockNo
shelleyTipBlockNo = ShelleyBlock proto era -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo   ShelleyBlock proto era
blk
          , shelleyTipSlotNo :: SlotNo
shelleyTipSlotNo  = ShelleyBlock proto era -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot ShelleyBlock proto era
blk
          , shelleyTipHash :: HeaderHash (ShelleyBlock proto era)
shelleyTipHash    = ShelleyBlock proto era -> HeaderHash (ShelleyBlock proto era)
forall b. HasHeader b => b -> HeaderHash b
blockHash ShelleyBlock proto era
blk
          }
      , shelleyLedgerState :: NewEpochState era
shelleyLedgerState =
          NewEpochState era
newNewEpochState
      , shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition = ShelleyTransitionInfo {
            shelleyAfterVoting :: Word32
shelleyAfterVoting =
              -- We count the number of blocks that have been applied after the
              -- voting deadline has passed.
              (if ShelleyBlock proto era -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot ShelleyBlock proto era
blk SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
votingDeadline then Word32 -> Word32
forall a. Enum a => a -> a
succ else Word32 -> Word32
forall a. a -> a
id) (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$
                ShelleyTransition -> Word32
shelleyAfterVoting ShelleyTransition
tickedShelleyLedgerTransition
          }
      }
  where
    globals :: Globals
globals = ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals LedgerConfig (ShelleyBlock proto era)
ShelleyLedgerConfig era
cfg
    swindow :: Word64
swindow = Globals -> Word64
SL.stabilityWindow Globals
globals

    ei :: EpochInfo Identity
    ei :: EpochInfo Identity
ei = Globals -> EpochInfo Identity
SL.epochInfoPure Globals
globals

    -- The start of the next epoch is within the safe zone, always.
    startOfNextEpoch :: SlotNo
    startOfNextEpoch :: SlotNo
startOfNextEpoch = Identity SlotNo -> SlotNo
forall a. Identity a -> a
runIdentity (Identity SlotNo -> SlotNo) -> Identity SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ do
        EpochNo
blockEpoch <- EpochInfo Identity -> SlotNo -> Identity EpochNo
forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m EpochNo
epochInfoEpoch EpochInfo Identity
ei (ShelleyBlock proto era -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot ShelleyBlock proto era
blk)
        let nextEpoch :: EpochNo
nextEpoch = EpochNo -> EpochNo
forall a. Enum a => a -> a
succ EpochNo
blockEpoch
        EpochInfo Identity -> EpochNo -> Identity SlotNo
forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> EpochNo -> m SlotNo
epochInfoFirst EpochInfo Identity
ei EpochNo
nextEpoch

    -- The block must come in strictly before the voting deadline
    -- See Fig 13, "Protocol Parameter Update Inference Rules", of the
    -- Shelley specification.
    votingDeadline :: SlotNo
    votingDeadline :: SlotNo
votingDeadline = Word64 -> SlotNo -> SlotNo
subSlots (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
swindow) SlotNo
startOfNextEpoch

instance HasHardForkHistory (ShelleyBlock proto era) where
  type HardForkIndices (ShelleyBlock proto era) = '[ShelleyBlock proto era]
  hardForkSummary :: LedgerConfig (ShelleyBlock proto era)
-> LedgerState (ShelleyBlock proto era)
-> Summary (HardForkIndices (ShelleyBlock proto era))
hardForkSummary = (LedgerConfig (ShelleyBlock proto era) -> EraParams)
-> LedgerConfig (ShelleyBlock proto era)
-> LedgerState (ShelleyBlock proto era)
-> Summary '[ShelleyBlock proto era]
forall blk.
(LedgerConfig blk -> EraParams)
-> LedgerConfig blk -> LedgerState blk -> Summary '[blk]
neverForksHardForkSummary ((LedgerConfig (ShelleyBlock proto era) -> EraParams)
 -> LedgerConfig (ShelleyBlock proto era)
 -> LedgerState (ShelleyBlock proto era)
 -> Summary '[ShelleyBlock proto era])
-> (LedgerConfig (ShelleyBlock proto era) -> EraParams)
-> LedgerConfig (ShelleyBlock proto era)
-> LedgerState (ShelleyBlock proto era)
-> Summary '[ShelleyBlock proto era]
forall a b. (a -> b) -> a -> b
$
      ShelleyGenesis (EraCrypto era) -> EraParams
forall c. ShelleyGenesis c -> EraParams
shelleyEraParamsNeverHardForks (ShelleyGenesis (EraCrypto era) -> EraParams)
-> (ShelleyLedgerConfig era -> ShelleyGenesis (EraCrypto era))
-> ShelleyLedgerConfig era
-> EraParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerConfig era -> ShelleyGenesis (EraCrypto era)
forall era.
ShelleyLedgerConfig era -> ShelleyGenesis (EraCrypto era)
shelleyLedgerGenesis

instance ShelleyCompatible proto era
      => CommonProtocolParams (ShelleyBlock proto era) where
  maxHeaderSize :: LedgerState (ShelleyBlock proto era) -> Word32
maxHeaderSize = Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word32)
-> (LedgerState (ShelleyBlock proto era) -> Word16)
-> LedgerState (ShelleyBlock proto era)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Word16 (PParams era) Word16 -> PParams era -> Word16
forall a s. Getting a s a -> s -> a
view Getting Word16 (PParams era) Word16
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
ppMaxBHSizeL (PParams era -> Word16)
-> (LedgerState (ShelleyBlock proto era) -> PParams era)
-> LedgerState (ShelleyBlock proto era)
-> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> PParams era
forall era. EraGov era => NewEpochState era -> PParams era
getPParams (NewEpochState era -> PParams era)
-> (LedgerState (ShelleyBlock proto era) -> NewEpochState era)
-> LedgerState (ShelleyBlock proto era)
-> PParams era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
shelleyLedgerState
  maxTxSize :: LedgerState (ShelleyBlock proto era) -> Word32
maxTxSize     = Getting Word32 (PParams era) Word32 -> PParams era -> Word32
forall a s. Getting a s a -> s -> a
view Getting Word32 (PParams era) Word32
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams era) Word32
ppMaxTxSizeL (PParams era -> Word32)
-> (LedgerState (ShelleyBlock proto era) -> PParams era)
-> LedgerState (ShelleyBlock proto era)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> PParams era
forall era. EraGov era => NewEpochState era -> PParams era
getPParams (NewEpochState era -> PParams era)
-> (LedgerState (ShelleyBlock proto era) -> NewEpochState era)
-> LedgerState (ShelleyBlock proto era)
-> PParams era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (ShelleyBlock proto era) -> NewEpochState era
forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
shelleyLedgerState

{-------------------------------------------------------------------------------
  ValidateEnvelope
-------------------------------------------------------------------------------}

instance ShelleyCompatible proto era => BasicEnvelopeValidation (ShelleyBlock proto era) where
  -- defaults all OK

instance ShelleyCompatible proto era => ValidateEnvelope (ShelleyBlock proto era) where
  type OtherHeaderEnvelopeError (ShelleyBlock proto era) =
    EnvelopeCheckError proto

  additionalEnvelopeChecks :: TopLevelConfig (ShelleyBlock proto era)
-> LedgerView (BlockProtocol (ShelleyBlock proto era))
-> Header (ShelleyBlock proto era)
-> Except (OtherHeaderEnvelopeError (ShelleyBlock proto era)) ()
additionalEnvelopeChecks TopLevelConfig (ShelleyBlock proto era)
cfg LedgerView (BlockProtocol (ShelleyBlock proto era))
lv Header (ShelleyBlock proto era)
hdr =
    ConsensusConfig proto
-> LedgerView proto
-> ShelleyProtocolHeader proto
-> Except (EnvelopeCheckError proto) ()
forall proto.
ProtocolHeaderSupportsEnvelope proto =>
ConsensusConfig proto
-> LedgerView proto
-> ShelleyProtocolHeader proto
-> Except (EnvelopeCheckError proto) ()
envelopeChecks (TopLevelConfig (ShelleyBlock proto era)
-> ConsensusConfig (BlockProtocol (ShelleyBlock proto era))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig (ShelleyBlock proto era)
cfg) LedgerView proto
LedgerView (BlockProtocol (ShelleyBlock proto era))
lv (Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
forall proto era.
Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
shelleyHeaderRaw Header (ShelleyBlock proto era)
hdr)

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

getPParams :: SL.EraGov era => SL.NewEpochState era -> Core.PParams era
getPParams :: forall era. EraGov era => NewEpochState era -> PParams era
getPParams = Getting (PParams era) (NewEpochState era) (PParams era)
-> NewEpochState era -> PParams era
forall a s. Getting a s a -> s -> a
view (Getting (PParams era) (NewEpochState era) (PParams era)
 -> NewEpochState era -> PParams era)
-> Getting (PParams era) (NewEpochState era) (PParams era)
-> NewEpochState era
-> PParams era
forall a b. (a -> b) -> a -> b
$ (GovState era -> Const (PParams era) (GovState era))
-> NewEpochState era -> Const (PParams era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
SL.newEpochStateGovStateL ((GovState era -> Const (PParams era) (GovState era))
 -> NewEpochState era -> Const (PParams era) (NewEpochState era))
-> ((PParams era -> Const (PParams era) (PParams era))
    -> GovState era -> Const (PParams era) (GovState era))
-> Getting (PParams era) (NewEpochState era) (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const (PParams era) (PParams era))
-> GovState era -> Const (PParams era) (GovState era)
forall era. EraGov era => Lens' (GovState era) (PParams era)
Lens' (GovState era) (PParams era)
SL.curPParamsGovStateL

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

-- | Current version
--
-- o 'serialisationFormatVersion0' used to include the 'LedgerViewHistory', but
--   since we had to break binary backwards compatibility of the 'TPraosState',
--   we dropped backwards compatibility with 'serialisationFormatVersion0' too.
-- o 'serialisationFormatVersion1' did not include a 'BlockNo' at the tip of
--   the ledger, which was introduced in version 2. Again, since we broke
--   compat anyway, we dropped support for version 1.
serialisationFormatVersion2 :: VersionNumber
serialisationFormatVersion2 :: VersionNumber
serialisationFormatVersion2 = VersionNumber
2

encodeShelleyAnnTip ::
     ShelleyCompatible proto era
  => AnnTip (ShelleyBlock proto era) -> Encoding
encodeShelleyAnnTip :: forall proto era.
ShelleyCompatible proto era =>
AnnTip (ShelleyBlock proto era) -> Encoding
encodeShelleyAnnTip = (HeaderHash (ShelleyBlock proto era) -> Encoding)
-> AnnTip (ShelleyBlock proto era) -> Encoding
forall blk.
(TipInfo blk ~ HeaderHash blk) =>
(HeaderHash blk -> Encoding) -> AnnTip blk -> Encoding
defaultEncodeAnnTip HeaderHash (ShelleyBlock proto era) -> Encoding
ShelleyHash (ProtoCrypto proto) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR

decodeShelleyAnnTip ::
     ShelleyCompatible proto era
  => Decoder s (AnnTip (ShelleyBlock proto era))
decodeShelleyAnnTip :: forall proto era s.
ShelleyCompatible proto era =>
Decoder s (AnnTip (ShelleyBlock proto era))
decodeShelleyAnnTip = (forall s. Decoder s (HeaderHash (ShelleyBlock proto era)))
-> forall s. Decoder s (AnnTip (ShelleyBlock proto era))
forall blk.
(TipInfo blk ~ HeaderHash blk) =>
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (AnnTip blk)
defaultDecodeAnnTip Decoder s (HeaderHash (ShelleyBlock proto era))
Decoder s (ShelleyHash (ProtoCrypto proto))
forall s. Decoder s (HeaderHash (ShelleyBlock proto era))
forall s. Decoder s (ShelleyHash (ProtoCrypto proto))
forall a s. FromCBOR a => Decoder s a
fromCBOR

encodeShelleyHeaderState ::
     ShelleyCompatible proto era
  => HeaderState (ShelleyBlock proto era)
  -> Encoding
encodeShelleyHeaderState :: forall proto era.
ShelleyCompatible proto era =>
HeaderState (ShelleyBlock proto era) -> Encoding
encodeShelleyHeaderState = (ChainDepState (BlockProtocol (ShelleyBlock proto era))
 -> Encoding)
-> (AnnTip (ShelleyBlock proto era) -> Encoding)
-> HeaderState (ShelleyBlock proto era)
-> Encoding
forall blk.
(ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding) -> HeaderState blk -> Encoding
encodeHeaderState
    ChainDepState proto -> Encoding
ChainDepState (BlockProtocol (ShelleyBlock proto era)) -> Encoding
forall a. Serialise a => a -> Encoding
encode
    AnnTip (ShelleyBlock proto era) -> Encoding
forall proto era.
ShelleyCompatible proto era =>
AnnTip (ShelleyBlock proto era) -> Encoding
encodeShelleyAnnTip

encodeShelleyTip :: ShelleyCompatible proto era => ShelleyTip proto era -> Encoding
encodeShelleyTip :: forall proto era.
ShelleyCompatible proto era =>
ShelleyTip proto era -> Encoding
encodeShelleyTip ShelleyTip {
                     SlotNo
shelleyTipSlotNo :: forall proto era. ShelleyTip proto era -> SlotNo
shelleyTipSlotNo :: SlotNo
shelleyTipSlotNo
                   , BlockNo
shelleyTipBlockNo :: forall proto era. ShelleyTip proto era -> BlockNo
shelleyTipBlockNo :: BlockNo
shelleyTipBlockNo
                   , HeaderHash (ShelleyBlock proto era)
shelleyTipHash :: forall proto era.
ShelleyTip proto era -> HeaderHash (ShelleyBlock proto era)
shelleyTipHash :: HeaderHash (ShelleyBlock proto era)
shelleyTipHash
                   } = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
CBOR.encodeListLen Word
3
    , SlotNo -> Encoding
forall a. Serialise a => a -> Encoding
encode SlotNo
shelleyTipSlotNo
    , BlockNo -> Encoding
forall a. Serialise a => a -> Encoding
encode BlockNo
shelleyTipBlockNo
    , ShelleyHash (ProtoCrypto proto) -> Encoding
forall a. Serialise a => a -> Encoding
encode HeaderHash (ShelleyBlock proto era)
ShelleyHash (ProtoCrypto proto)
shelleyTipHash
    ]

decodeShelleyTip :: ShelleyCompatible proto era => Decoder s (ShelleyTip proto era)
decodeShelleyTip :: forall proto era s.
ShelleyCompatible proto era =>
Decoder s (ShelleyTip proto era)
decodeShelleyTip = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"ShelleyTip" Int
3
    SlotNo
shelleyTipSlotNo  <- Decoder s SlotNo
forall s. Decoder s SlotNo
forall a s. Serialise a => Decoder s a
decode
    BlockNo
shelleyTipBlockNo <- Decoder s BlockNo
forall s. Decoder s BlockNo
forall a s. Serialise a => Decoder s a
decode
    ShelleyHash (ProtoCrypto proto)
shelleyTipHash    <- Decoder s (ShelleyHash (ProtoCrypto proto))
forall s. Decoder s (ShelleyHash (ProtoCrypto proto))
forall a s. Serialise a => Decoder s a
decode
    ShelleyTip proto era -> Decoder s (ShelleyTip proto era)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return ShelleyTip {
        SlotNo
shelleyTipSlotNo :: SlotNo
shelleyTipSlotNo :: SlotNo
shelleyTipSlotNo
      , BlockNo
shelleyTipBlockNo :: BlockNo
shelleyTipBlockNo :: BlockNo
shelleyTipBlockNo
      , HeaderHash (ShelleyBlock proto era)
ShelleyHash (ProtoCrypto proto)
shelleyTipHash :: HeaderHash (ShelleyBlock proto era)
shelleyTipHash :: ShelleyHash (ProtoCrypto proto)
shelleyTipHash
      }

encodeShelleyTransition :: ShelleyTransition -> Encoding
encodeShelleyTransition :: ShelleyTransition -> Encoding
encodeShelleyTransition ShelleyTransitionInfo{Word32
shelleyAfterVoting :: ShelleyTransition -> Word32
shelleyAfterVoting :: Word32
shelleyAfterVoting} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word32 -> Encoding
CBOR.encodeWord32 Word32
shelleyAfterVoting
    ]

decodeShelleyTransition :: Decoder s ShelleyTransition
decodeShelleyTransition :: forall s. Decoder s ShelleyTransition
decodeShelleyTransition = do
    Word32
shelleyAfterVoting <- Decoder s Word32
forall s. Decoder s Word32
CBOR.decodeWord32
    ShelleyTransition -> Decoder s ShelleyTransition
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return ShelleyTransitionInfo{Word32
shelleyAfterVoting :: Word32
shelleyAfterVoting :: Word32
shelleyAfterVoting}

encodeShelleyLedgerState ::
     ShelleyCompatible proto era
  => LedgerState (ShelleyBlock proto era)
  -> Encoding
encodeShelleyLedgerState :: forall proto era.
ShelleyCompatible proto era =>
LedgerState (ShelleyBlock proto era) -> Encoding
encodeShelleyLedgerState
    ShelleyLedgerState { WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: forall proto era.
LedgerState (ShelleyBlock proto era)
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
                       , NewEpochState era
shelleyLedgerState :: forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState
                       , ShelleyTransition
shelleyLedgerTransition :: forall proto era.
LedgerState (ShelleyBlock proto era) -> ShelleyTransition
shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition
                       } =
    VersionNumber -> Encoding -> Encoding
encodeVersion VersionNumber
serialisationFormatVersion2 (Encoding -> Encoding) -> Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$ [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
        Word -> Encoding
CBOR.encodeListLen Word
3
      , (ShelleyTip proto era -> Encoding)
-> WithOrigin (ShelleyTip proto era) -> Encoding
forall a. (a -> Encoding) -> WithOrigin a -> Encoding
encodeWithOrigin ShelleyTip proto era -> Encoding
forall proto era.
ShelleyCompatible proto era =>
ShelleyTip proto era -> Encoding
encodeShelleyTip WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
      , NewEpochState era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR NewEpochState era
shelleyLedgerState
      , ShelleyTransition -> Encoding
encodeShelleyTransition ShelleyTransition
shelleyLedgerTransition
      ]

decodeShelleyLedgerState ::
     forall era proto s. ShelleyCompatible proto era
  => Decoder s (LedgerState (ShelleyBlock proto era))
decodeShelleyLedgerState :: forall era proto s.
ShelleyCompatible proto era =>
Decoder s (LedgerState (ShelleyBlock proto era))
decodeShelleyLedgerState = [(VersionNumber,
  VersionDecoder (LedgerState (ShelleyBlock proto era)))]
-> forall s. Decoder s (LedgerState (ShelleyBlock proto era))
forall a.
[(VersionNumber, VersionDecoder a)] -> forall s. Decoder s a
decodeVersion [
      (VersionNumber
serialisationFormatVersion2, (forall s. Decoder s (LedgerState (ShelleyBlock proto era)))
-> VersionDecoder (LedgerState (ShelleyBlock proto era))
forall a. (forall s. Decoder s a) -> VersionDecoder a
Decode Decoder s (LedgerState (ShelleyBlock proto era))
forall s. Decoder s (LedgerState (ShelleyBlock proto era))
decodeShelleyLedgerState2)
    ]
  where
    decodeShelleyLedgerState2 :: Decoder s' (LedgerState (ShelleyBlock proto era))
    decodeShelleyLedgerState2 :: forall s. Decoder s (LedgerState (ShelleyBlock proto era))
decodeShelleyLedgerState2 = do
      Text -> Int -> Decoder s' ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"LedgerState ShelleyBlock" Int
3
      WithOrigin (ShelleyTip proto era)
shelleyLedgerTip        <- Decoder s' (ShelleyTip proto era)
-> Decoder s' (WithOrigin (ShelleyTip proto era))
forall s a. Decoder s a -> Decoder s (WithOrigin a)
decodeWithOrigin Decoder s' (ShelleyTip proto era)
forall proto era s.
ShelleyCompatible proto era =>
Decoder s (ShelleyTip proto era)
decodeShelleyTip
      NewEpochState era
shelleyLedgerState      <- Decoder s' (NewEpochState era)
forall s. Decoder s (NewEpochState era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      ShelleyTransition
shelleyLedgerTransition <- Decoder s' ShelleyTransition
forall s. Decoder s ShelleyTransition
decodeShelleyTransition
      LedgerState (ShelleyBlock proto era)
-> Decoder s' (LedgerState (ShelleyBlock proto era))
forall a. a -> Decoder s' a
forall (m :: * -> *) a. Monad m => a -> m a
return ShelleyLedgerState {
          WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip
        , NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState
        , ShelleyTransition
shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition
        }