{-# 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 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           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           Data.Coerce (coerce)
import           Data.Functor ((<&>))
import           Data.Functor.Identity
import qualified Data.Text as Text
import           Data.Word
import           GHC.Generics (Generic)
import           GHC.Records
import           NoThunks.Class (NoThunks (..))

import           Cardano.Binary (FromCBOR (..), ToCBOR (..), enforceSize)
import           Cardano.Slotting.EpochInfo

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.Util ((..:))
import           Ouroboros.Consensus.Util.CBOR (decodeWithOrigin,
                     encodeWithOrigin)
import           Ouroboros.Consensus.Util.Versioned

import qualified Cardano.Ledger.BHeaderView as SL (BHeaderView)
import qualified Cardano.Ledger.BaseTypes as SL (epochInfoPure)
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Era as Core
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Control.State.Transition.Extended as STS

import           Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch)
import           Ouroboros.Consensus.Protocol.TPraos (MaxMajorProtVer (..),
                     Ticked (TickedPraosLedgerView))
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)

{-------------------------------------------------------------------------------
  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
$cto :: forall era x.
Rep (ShelleyLedgerError era) x -> ShelleyLedgerError era
$cfrom :: forall era x.
ShelleyLedgerError era -> Rep (ShelleyLedgerError era) x
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 {
      ShelleyLedgerConfig era -> CompactGenesis era
shelleyLedgerCompactGenesis     :: !(CompactGenesis era)
      -- | Derived from 'shelleyLedgerGenesis' but we store a cached version
      -- because it used very often.
    , ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals            :: !SL.Globals
    , 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
$cto :: forall era x.
Rep (ShelleyLedgerConfig era) x -> ShelleyLedgerConfig era
$cfrom :: forall era x.
ShelleyLedgerConfig era -> Rep (ShelleyLedgerConfig era) x
Generic, Context -> ShelleyLedgerConfig era -> IO (Maybe ThunkInfo)
Proxy (ShelleyLedgerConfig era) -> String
(Context -> ShelleyLedgerConfig era -> IO (Maybe ThunkInfo))
-> (Context -> ShelleyLedgerConfig era -> IO (Maybe ThunkInfo))
-> (Proxy (ShelleyLedgerConfig era) -> String)
-> NoThunks (ShelleyLedgerConfig era)
forall era.
ShelleyBasedEra era =>
Context -> ShelleyLedgerConfig era -> IO (Maybe ThunkInfo)
forall era.
ShelleyBasedEra era =>
Proxy (ShelleyLedgerConfig era) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (ShelleyLedgerConfig era) -> String
$cshowTypeOf :: forall era.
ShelleyBasedEra era =>
Proxy (ShelleyLedgerConfig era) -> String
wNoThunks :: Context -> ShelleyLedgerConfig era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era.
ShelleyBasedEra era =>
Context -> ShelleyLedgerConfig era -> IO (Maybe ThunkInfo)
noThunks :: Context -> ShelleyLedgerConfig era -> IO (Maybe ThunkInfo)
$cnoThunks :: forall era.
ShelleyBasedEra era =>
Context -> ShelleyLedgerConfig era -> IO (Maybe ThunkInfo)
NoThunks)

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

shelleyEraParams ::
     SL.ShelleyGenesis era
  -> HardFork.EraParams
shelleyEraParams :: ShelleyGenesis era -> EraParams
shelleyEraParams ShelleyGenesis era
genesis = EraParams :: EpochSize -> SlotLength -> SafeZone -> EraParams
HardFork.EraParams {
      eraEpochSize :: EpochSize
eraEpochSize  = ShelleyGenesis era -> EpochSize
forall era. ShelleyGenesis era -> EpochSize
SL.sgEpochLength ShelleyGenesis era
genesis
    , eraSlotLength :: SlotLength
eraSlotLength = 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
    , eraSafeZone :: SafeZone
eraSafeZone   = Word64 -> SafeZone
HardFork.StandardSafeZone Word64
stabilityWindow
    }
  where
    stabilityWindow :: Word64
stabilityWindow =
        Word64 -> ActiveSlotCoeff -> Word64
SL.computeStabilityWindow
          (ShelleyGenesis era -> Word64
forall era. ShelleyGenesis era -> Word64
SL.sgSecurityParam ShelleyGenesis era
genesis)
          (ShelleyGenesis era -> ActiveSlotCoeff
forall era. ShelleyGenesis era -> ActiveSlotCoeff
SL.sgActiveSlotCoeff ShelleyGenesis era
genesis)

-- | Separate variant of 'shelleyEraParams' to be used for a Shelley-only chain.
shelleyEraParamsNeverHardForks :: SL.ShelleyGenesis era -> HardFork.EraParams
shelleyEraParamsNeverHardForks :: ShelleyGenesis era -> EraParams
shelleyEraParamsNeverHardForks ShelleyGenesis era
genesis = EraParams :: EpochSize -> SlotLength -> SafeZone -> EraParams
HardFork.EraParams {
      eraEpochSize :: EpochSize
eraEpochSize  = ShelleyGenesis era -> EpochSize
forall era. ShelleyGenesis era -> EpochSize
SL.sgEpochLength ShelleyGenesis era
genesis
    , eraSlotLength :: SlotLength
eraSlotLength = 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
    , eraSafeZone :: SafeZone
eraSafeZone   = SafeZone
HardFork.UnsafeIndefiniteSafeZone
    }

mkShelleyLedgerConfig
  :: SL.ShelleyGenesis era
  -> Core.TranslationContext era
  -> EpochInfo (Except HardFork.PastHorizonException)
  -> MaxMajorProtVer
  -> ShelleyLedgerConfig era
mkShelleyLedgerConfig :: ShelleyGenesis era
-> TranslationContext era
-> EpochInfo (Except PastHorizonException)
-> MaxMajorProtVer
-> ShelleyLedgerConfig era
mkShelleyLedgerConfig ShelleyGenesis era
genesis TranslationContext era
transCtxt EpochInfo (Except PastHorizonException)
epochInfo MaxMajorProtVer
mmpv =
    ShelleyLedgerConfig :: forall era.
CompactGenesis era
-> Globals -> TranslationContext era -> ShelleyLedgerConfig era
ShelleyLedgerConfig {
        shelleyLedgerCompactGenesis :: CompactGenesis era
shelleyLedgerCompactGenesis     = ShelleyGenesis era -> CompactGenesis era
forall era. ShelleyGenesis era -> CompactGenesis era
compactGenesis ShelleyGenesis era
genesis
      , shelleyLedgerGlobals :: Globals
shelleyLedgerGlobals            =
          ShelleyGenesis era -> EpochInfo (Either Text) -> Natural -> Globals
forall era.
ShelleyGenesis era -> EpochInfo (Either Text) -> Natural -> Globals
SL.mkShelleyGlobals
            ShelleyGenesis 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 (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)
            Natural
maxMajorPV
      , shelleyLedgerTranslationContext :: TranslationContext era
shelleyLedgerTranslationContext = TranslationContext era
transCtxt
      }
  where
    MaxMajorProtVer Natural
maxMajorPV = MaxMajorProtVer
mmpv

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

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

data ShelleyTip proto era = ShelleyTip {
      ShelleyTip proto era -> SlotNo
shelleyTipSlotNo  :: !SlotNo
    , ShelleyTip proto era -> BlockNo
shelleyTipBlockNo :: !BlockNo
    , 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
/= :: 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
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
showList :: [ShelleyTip proto era] -> ShowS
$cshowList :: forall proto era. [ShelleyTip proto era] -> ShowS
show :: ShelleyTip proto era -> String
$cshow :: forall proto era. ShelleyTip proto era -> String
showsPrec :: Int -> ShelleyTip proto era -> ShowS
$cshowsPrec :: forall proto era. Int -> 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
$cto :: forall proto era x.
Rep (ShelleyTip proto era) x -> ShelleyTip proto era
$cfrom :: forall proto era x.
ShelleyTip proto era -> Rep (ShelleyTip proto era) x
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
showTypeOf :: Proxy (ShelleyTip proto era) -> String
$cshowTypeOf :: forall proto era. Proxy (ShelleyTip proto era) -> String
wNoThunks :: Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall proto era.
Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
noThunks :: Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
$cnoThunks :: forall proto era.
Context -> ShelleyTip proto era -> IO (Maybe ThunkInfo)
NoThunks)

shelleyTipToPoint :: WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
shelleyTipToPoint :: WithOrigin (ShelleyTip proto era) -> Point (ShelleyBlock proto era)
shelleyTipToPoint WithOrigin (ShelleyTip proto era)
Origin          = Point (ShelleyBlock proto era)
forall block. Point block
GenesisPoint
shelleyTipToPoint (NotOrigin ShelleyTip proto era
tip) = SlotNo
-> HeaderHash (ShelleyBlock proto era)
-> Point (ShelleyBlock proto era)
forall block. 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 :: ShelleyTip proto era -> ShelleyTip proto' era'
castShelleyTip (ShelleyTip SlotNo
sn BlockNo
bn HeaderHash (ShelleyBlock proto era)
hh) = ShelleyTip :: forall proto era.
SlotNo
-> BlockNo
-> HeaderHash (ShelleyBlock proto era)
-> ShelleyTip proto era
ShelleyTip {
      shelleyTipSlotNo :: SlotNo
shelleyTipSlotNo  = SlotNo
sn
    , shelleyTipBlockNo :: BlockNo
shelleyTipBlockNo = BlockNo
bn
    , shelleyTipHash :: HeaderHash (ShelleyBlock proto' era')
shelleyTipHash    = ShelleyHash (ProtoCrypto proto')
-> ShelleyHash (ProtoCrypto proto')
coerce HeaderHash (ShelleyBlock proto era)
ShelleyHash (ProtoCrypto proto')
hh
    }

data instance LedgerState (ShelleyBlock proto era) = ShelleyLedgerState {
      LedgerState (ShelleyBlock proto era)
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip        :: !(WithOrigin (ShelleyTip proto era))
    , LedgerState (ShelleyBlock proto era) -> NewEpochState era
shelleyLedgerState      :: !(SL.NewEpochState 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
$cto :: forall proto era x.
Rep (LedgerState (ShelleyBlock proto era)) x
-> LedgerState (ShelleyBlock proto era)
$cfrom :: forall proto era x.
LedgerState (ShelleyBlock proto era)
-> Rep (LedgerState (ShelleyBlock proto era)) x
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 which
      --    proposals we accepted in the voting period, if any, and notify the
      --    HFC is one of them indicates a transition.
      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
/= :: ShelleyTransition -> ShelleyTransition -> Bool
$c/= :: ShelleyTransition -> ShelleyTransition -> Bool
== :: ShelleyTransition -> ShelleyTransition -> Bool
$c== :: 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
showList :: [ShelleyTransition] -> ShowS
$cshowList :: [ShelleyTransition] -> ShowS
show :: ShelleyTransition -> String
$cshow :: ShelleyTransition -> String
showsPrec :: Int -> ShelleyTransition -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep ShelleyTransition x -> ShelleyTransition
$cfrom :: forall x. ShelleyTransition -> Rep ShelleyTransition x
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
showTypeOf :: Proxy ShelleyTransition -> String
$cshowTypeOf :: Proxy ShelleyTransition -> String
wNoThunks :: Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
noThunks :: Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> ShelleyTransition -> IO (Maybe ThunkInfo)
NoThunks)

shelleyLedgerTipPoint :: LedgerState (ShelleyBlock proto era) -> Point (ShelleyBlock proto era)
shelleyLedgerTipPoint :: 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 b b'.
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 b b'.
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 {
      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.
    , Ticked (LedgerState (ShelleyBlock proto era)) -> ShelleyTransition
tickedShelleyLedgerTransition :: !ShelleyTransition
    , 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
$cto :: forall proto era x.
Rep (Ticked (LedgerState (ShelleyBlock proto era))) x
-> Ticked (LedgerState (ShelleyBlock proto era))
$cfrom :: forall proto era x.
Ticked (LedgerState (ShelleyBlock proto era))
-> Rep (Ticked (LedgerState (ShelleyBlock proto era))) x
Generic)

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

untickedShelleyLedgerTipPoint ::
     Ticked (LedgerState (ShelleyBlock proto era))
  -> Point (ShelleyBlock proto era)
untickedShelleyLedgerTipPoint :: 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{
                                shelleyLedgerTip
                              , shelleyLedgerState
                              , 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 :: forall proto era.
WithOrigin (ShelleyTip proto era)
-> ShelleyTransition
-> NewEpochState era
-> Ticked (LedgerState (ShelleyBlock proto era))
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 :: Word32 -> ShelleyTransition
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 :: forall l a. [AuxLedgerEvent l] -> a -> LedgerResult l a
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)
SL.applyTickOpts
          ApplySTSOpts :: forall (ep :: EventPolicy).
AssertionPolicy -> ValidationPolicy -> SingEP ep -> ApplySTSOpts ep
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 :: 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 (ExceptT
  (BlockTransitionError era)
  Identity
  (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 (ExceptT
   (BlockTransitionError era)
   Identity
   (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
    -> ExceptT
         (BlockTransitionError era)
         Identity
         (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
-> ExceptT
     (BlockTransitionError era)
     Identity
     (NewEpochState era, [Event (EraRule "BBODY" era)])
Globals
-> NewEpochState era
-> Block (BHeaderView (ProtoCrypto proto)) era
-> ExceptT
     (BlockTransitionError era)
     Identity
     (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 :: forall l a. [AuxLedgerEvent l] -> a -> LedgerResult l a
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 (Crypto era)) era
-> m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
SL.applyBlockOpts
          ApplySTSOpts :: forall (ep :: EventPolicy).
AssertionPolicy -> ValidationPolicy -> SingEP ep -> ApplySTSOpts ep
STS.ApplySTSOpts {
              asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
STS.globalAssertionPolicy
            , asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
STS.ValidateAll
            , asoEvents :: SingEP 'EventPolicyReturn
asoEvents     = SingEP 'EventPolicyReturn
STS.EPReturn
            }

  reapplyBlockLedgerResult :: 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 (ExceptT
  (BlockTransitionError era)
  Identity
  (NewEpochState era, [Event (EraRule "BBODY" era)])
-> Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
swizzle (ExceptT
   (BlockTransitionError era)
   Identity
   (NewEpochState era, [Event (EraRule "BBODY" era)])
 -> Identity
      (LedgerResult
         (LedgerState (ShelleyBlock proto era)) (NewEpochState era)))
-> (Globals
    -> NewEpochState era
    -> Block (BHeaderView (ProtoCrypto proto)) era
    -> ExceptT
         (BlockTransitionError era)
         Identity
         (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
-> ExceptT
     (BlockTransitionError era)
     Identity
     (NewEpochState era, [Event (EraRule "BBODY" era)])
Globals
-> NewEpochState era
-> Block (BHeaderView (ProtoCrypto proto)) era
-> ExceptT
     (BlockTransitionError era)
     Identity
     (NewEpochState era, [Event (EraRule "BBODY" era)])
reappBlk)
    where
      swizzle :: ExceptT
  (BlockTransitionError era)
  Identity
  (NewEpochState era, [Event (EraRule "BBODY" era)])
-> Identity
     (LedgerResult
        (LedgerState (ShelleyBlock proto era)) (NewEpochState era))
swizzle ExceptT
  (BlockTransitionError era)
  Identity
  (NewEpochState era, [Event (EraRule "BBODY" era)])
m = case ExceptT
  (BlockTransitionError era)
  Identity
  (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 ExceptT
  (BlockTransitionError era)
  Identity
  (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
$! BlockTransitionError era -> ShelleyReapplyException
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 (f :: * -> *) a. Applicative f => a -> f a
pure LedgerResult :: forall l a. [AuxLedgerEvent l] -> a -> LedgerResult l a
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 (Crypto era)) era
-> m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era))
SL.applyBlockOpts
          ApplySTSOpts :: forall (ep :: EventPolicy).
AssertionPolicy -> ValidationPolicy -> SingEP ep -> ApplySTSOpts ep
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 :: (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{
                          tickedShelleyLedgerTransition
                        , 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 (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 :: forall proto era.
WithOrigin (ShelleyTip proto era)
-> NewEpochState era
-> ShelleyTransition
-> LedgerState (ShelleyBlock proto era)
ShelleyLedgerState {
        shelleyLedgerTip :: WithOrigin (ShelleyTip proto era)
shelleyLedgerTip = ShelleyTip proto era -> WithOrigin (ShelleyTip proto era)
forall t. t -> WithOrigin t
NotOrigin ShelleyTip :: forall proto era.
SlotNo
-> BlockNo
-> HeaderHash (ShelleyBlock proto era)
-> ShelleyTip proto era
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 :: Word32 -> ShelleyTransition
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 era -> EraParams
forall era. ShelleyGenesis era -> EraParams
shelleyEraParamsNeverHardForks (ShelleyGenesis era -> EraParams)
-> (ShelleyLedgerConfig era -> ShelleyGenesis era)
-> ShelleyLedgerConfig era
-> EraParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerConfig era -> ShelleyGenesis era
forall era. ShelleyLedgerConfig era -> ShelleyGenesis era
shelleyLedgerGenesis

instance ShelleyCompatible proto era
      => CommonProtocolParams (ShelleyBlock proto era) where
  maxHeaderSize :: LedgerState (ShelleyBlock proto era) -> Word32
maxHeaderSize = Natural -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Word32)
-> (LedgerState (ShelleyBlock proto era) -> Natural)
-> LedgerState (ShelleyBlock proto era)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "_maxBHSize" r a => r -> a
getField @"_maxBHSize" (PParams era -> Natural)
-> (LedgerState (ShelleyBlock proto era) -> PParams era)
-> LedgerState (ShelleyBlock proto era)
-> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> PParams era
forall 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     = Natural -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Word32)
-> (LedgerState (ShelleyBlock proto era) -> Natural)
-> LedgerState (ShelleyBlock proto era)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "_maxTxSize" r a => r -> a
getField @"_maxTxSize" (PParams era -> Natural)
-> (LedgerState (ShelleyBlock proto era) -> PParams era)
-> LedgerState (ShelleyBlock proto era)
-> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> PParams era
forall 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)
-> Ticked (LedgerView (BlockProtocol (ShelleyBlock proto era)))
-> Header (ShelleyBlock proto era)
-> Except (OtherHeaderEnvelopeError (ShelleyBlock proto era)) ()
additionalEnvelopeChecks TopLevelConfig (ShelleyBlock proto era)
cfg Ticked (LedgerView (BlockProtocol (ShelleyBlock proto era)))
tlv Header (ShelleyBlock proto era)
hdr =
    ConsensusConfig proto
-> Ticked (LedgerView proto)
-> ShelleyProtocolHeader proto
-> Except (EnvelopeCheckError proto) ()
forall proto.
ProtocolHeaderSupportsEnvelope proto =>
ConsensusConfig proto
-> Ticked (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) Ticked (LedgerView proto)
Ticked (LedgerView (BlockProtocol (ShelleyBlock proto era)))
tlv (Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
forall proto era.
Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
shelleyHeaderRaw Header (ShelleyBlock proto era)
hdr)

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

getPParams :: SL.NewEpochState era -> Core.PParams era
getPParams :: NewEpochState era -> PParams era
getPParams = EpochState era -> PParams era
forall era. EpochState era -> PParams era
SL.esPp (EpochState era -> PParams era)
-> (NewEpochState era -> EpochState era)
-> NewEpochState era
-> PParams era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
SL.nesEs

{-------------------------------------------------------------------------------
  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 :: 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
forall a. ToCBOR a => a -> Encoding
toCBOR

decodeShelleyAnnTip ::
     ShelleyCompatible proto era
  => Decoder s (AnnTip (ShelleyBlock proto era))
decodeShelleyAnnTip :: 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 forall s. Decoder s (HeaderHash (ShelleyBlock proto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR

encodeShelleyHeaderState ::
     ShelleyCompatible proto era
  => HeaderState (ShelleyBlock proto era)
  -> Encoding
encodeShelleyHeaderState :: 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 (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 :: ShelleyTip proto era -> Encoding
encodeShelleyTip ShelleyTip {
                     SlotNo
shelleyTipSlotNo :: SlotNo
shelleyTipSlotNo :: forall proto era. ShelleyTip proto era -> SlotNo
shelleyTipSlotNo
                   , BlockNo
shelleyTipBlockNo :: BlockNo
shelleyTipBlockNo :: forall proto era. ShelleyTip proto era -> BlockNo
shelleyTipBlockNo
                   , HeaderHash (ShelleyBlock proto era)
shelleyTipHash :: HeaderHash (ShelleyBlock proto era)
shelleyTipHash :: forall proto era.
ShelleyTip proto era -> 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 :: 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 a s. Serialise a => Decoder s a
decode
    BlockNo
shelleyTipBlockNo <- Decoder s BlockNo
forall a s. Serialise a => Decoder s a
decode
    ShelleyHash (ProtoCrypto proto)
shelleyTipHash    <- Decoder s (ShelleyHash (ProtoCrypto proto))
forall a s. Serialise a => Decoder s a
decode
    ShelleyTip proto era -> Decoder s (ShelleyTip proto era)
forall (m :: * -> *) a. Monad m => a -> m a
return ShelleyTip :: forall proto era.
SlotNo
-> BlockNo
-> HeaderHash (ShelleyBlock proto era)
-> ShelleyTip proto era
ShelleyTip {
        SlotNo
shelleyTipSlotNo :: SlotNo
shelleyTipSlotNo :: SlotNo
shelleyTipSlotNo
      , BlockNo
shelleyTipBlockNo :: BlockNo
shelleyTipBlockNo :: BlockNo
shelleyTipBlockNo
      , HeaderHash (ShelleyBlock proto era)
ShelleyHash (ProtoCrypto proto)
shelleyTipHash :: ShelleyHash (ProtoCrypto proto)
shelleyTipHash :: HeaderHash (ShelleyBlock proto era)
shelleyTipHash
      }

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

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

encodeShelleyLedgerState ::
     ShelleyCompatible proto era
  => LedgerState (ShelleyBlock proto era)
  -> Encoding
encodeShelleyLedgerState :: LedgerState (ShelleyBlock proto era) -> Encoding
encodeShelleyLedgerState
    ShelleyLedgerState { shelleyLedgerTip
                       , shelleyLedgerState
                       , 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 :: 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 forall s. Decoder s (LedgerState (ShelleyBlock proto era))
decodeShelleyLedgerState2)
    ]
  where
    decodeShelleyLedgerState2 :: Decoder s' (LedgerState (ShelleyBlock proto era))
    decodeShelleyLedgerState2 :: 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 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 (m :: * -> *) a. Monad m => a -> m a
return ShelleyLedgerState :: forall proto era.
WithOrigin (ShelleyTip proto era)
-> NewEpochState era
-> ShelleyTransition
-> LedgerState (ShelleyBlock proto era)
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
        }