{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | This module contains 'SupportsProtocol' instances tying the ledger and
-- protocol together. Since these instances reference both ledger concerns and
-- protocol concerns, it is the one class where we cannot provide a generic
-- instance for 'ShelleyBlock'.
module Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () where

import qualified Cardano.Ledger.Core as LedgerCore
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Protocol.TPraos.API as SL
import Control.Monad.Except (MonadError (throwError))
import qualified Lens.Micro
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Forecast
import Ouroboros.Consensus.HardFork.History.Util
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsProtocol
  ( LedgerSupportsProtocol (..)
  )
import Ouroboros.Consensus.Protocol.Praos (Praos)
import qualified Ouroboros.Consensus.Protocol.Praos as Praos (PraosCrypto)
import qualified Ouroboros.Consensus.Protocol.Praos.Views as Praos
import Ouroboros.Consensus.Protocol.TPraos (TPraos)
import Ouroboros.Consensus.Shelley.Ledger.Block
import Ouroboros.Consensus.Shelley.Ledger.Ledger
import Ouroboros.Consensus.Shelley.Ledger.Protocol ()
import Ouroboros.Consensus.Shelley.Protocol.Abstract ()
import Ouroboros.Consensus.Shelley.Protocol.Praos ()
import Ouroboros.Consensus.Shelley.Protocol.TPraos ()

instance
  ( ShelleyCompatible (TPraos crypto) era
  , SL.ShelleyEraForecast era
  , SL.PraosCrypto crypto
  ) =>
  LedgerSupportsProtocol (ShelleyBlock (TPraos crypto) era)
  where
  protocolLedgerView :: forall (mk :: MapKind).
LedgerConfig (ShelleyBlock (TPraos crypto) era)
-> Ticked LedgerState (ShelleyBlock (TPraos crypto) era) mk
-> LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))
protocolLedgerView LedgerConfig (ShelleyBlock (TPraos crypto) era)
_cfg =
    Forecast Current era -> TPraosLedgerView
forall (t :: Timeline) era.
ShelleyEraForecast era =>
Forecast t era -> TPraosLedgerView
SL.forecastToTPraosLedgerView (Forecast Current era -> TPraosLedgerView)
-> (Ticked LedgerState (ShelleyBlock (TPraos crypto) era) mk
    -> Forecast Current era)
-> Ticked LedgerState (ShelleyBlock (TPraos crypto) era) mk
-> TPraosLedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> Forecast Current era
forall era.
EraForecast era =>
NewEpochState era -> Forecast Current era
SL.currentForecast (NewEpochState era -> Forecast Current era)
-> (Ticked LedgerState (ShelleyBlock (TPraos crypto) era) mk
    -> NewEpochState era)
-> Ticked LedgerState (ShelleyBlock (TPraos crypto) era) mk
-> Forecast Current era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked LedgerState (ShelleyBlock (TPraos crypto) era) mk
-> NewEpochState era
forall proto era (mk :: MapKind).
Ticked LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
tickedShelleyLedgerState

  -- Extra context available in
  -- https://github.com/IntersectMBO/ouroboros-consensus/blob/main/docs/website/contents/for-developers/HardWonWisdom.md#why-doesnt-ledger-code-ever-return-pasthorizonexception
  ledgerViewForecastAt :: forall (mk :: MapKind).
HasCallStack =>
LedgerConfig (ShelleyBlock (TPraos crypto) era)
-> LedgerState (ShelleyBlock (TPraos crypto) era) mk
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
ledgerViewForecastAt LedgerConfig (ShelleyBlock (TPraos crypto) era)
cfg LedgerState (ShelleyBlock (TPraos crypto) era) mk
ledgerState = WithOrigin SlotNo
-> (SlotNo
    -> Except
         OutsideForecastRange
         (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))))
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
forall a.
WithOrigin SlotNo
-> (SlotNo -> Except OutsideForecastRange a) -> Forecast a
Forecast WithOrigin SlotNo
at ((SlotNo
  -> Except
       OutsideForecastRange
       (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))))
 -> Forecast
      (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))))
-> (SlotNo
    -> Except
         OutsideForecastRange
         (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))))
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
forall a b. (a -> b) -> a -> b
$ \SlotNo
for ->
    if
      | SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
for WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== WithOrigin SlotNo
at ->
          TPraosLedgerView
-> ExceptT OutsideForecastRange Identity TPraosLedgerView
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TPraosLedgerView
 -> ExceptT OutsideForecastRange Identity TPraosLedgerView)
-> TPraosLedgerView
-> ExceptT OutsideForecastRange Identity TPraosLedgerView
forall a b. (a -> b) -> a -> b
$ Forecast Current era -> TPraosLedgerView
forall (t :: Timeline) era.
ShelleyEraForecast era =>
Forecast t era -> TPraosLedgerView
SL.forecastToTPraosLedgerView (NewEpochState era -> Forecast Current era
forall era.
EraForecast era =>
NewEpochState era -> Forecast Current era
SL.currentForecast NewEpochState era
shelleyLedgerState)
      | SlotNo
for SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
maxFor ->
          TPraosLedgerView
-> ExceptT OutsideForecastRange Identity TPraosLedgerView
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TPraosLedgerView
 -> ExceptT OutsideForecastRange Identity TPraosLedgerView)
-> TPraosLedgerView
-> ExceptT OutsideForecastRange Identity TPraosLedgerView
forall a b. (a -> b) -> a -> b
$ SlotNo -> TPraosLedgerView
futureLedgerView SlotNo
for
      | Bool
otherwise ->
          OutsideForecastRange
-> Except
     OutsideForecastRange
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
forall a.
OutsideForecastRange -> ExceptT OutsideForecastRange Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (OutsideForecastRange
 -> Except
      OutsideForecastRange
      (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))))
-> OutsideForecastRange
-> Except
     OutsideForecastRange
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
forall a b. (a -> b) -> a -> b
$
            OutsideForecastRange
              { outsideForecastAt :: WithOrigin SlotNo
outsideForecastAt = WithOrigin SlotNo
at
              , outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor = SlotNo
maxFor
              , outsideForecastFor :: SlotNo
outsideForecastFor = SlotNo
for
              }
   where
    ShelleyLedgerState{NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState :: forall proto era (mk :: MapKind).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState} = LedgerState (ShelleyBlock (TPraos crypto) era) mk
ledgerState
    globals :: Globals
globals = ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals LedgerConfig (ShelleyBlock (TPraos crypto) era)
ShelleyLedgerConfig era
cfg
    swindow :: Word64
swindow = Globals -> Word64
SL.stabilityWindow Globals
globals
    at :: WithOrigin SlotNo
at = LedgerState (ShelleyBlock (TPraos crypto) era) mk
-> WithOrigin SlotNo
forall blk (mk :: MapKind).
UpdateLedger blk =>
LedgerState blk mk -> WithOrigin SlotNo
ledgerTipSlot LedgerState (ShelleyBlock (TPraos crypto) era) mk
ledgerState

    futureLedgerView :: SlotNo -> SL.TPraosLedgerView
    futureLedgerView :: SlotNo -> TPraosLedgerView
futureLedgerView SlotNo
for =
      Forecast Future era -> TPraosLedgerView
forall (t :: Timeline) era.
ShelleyEraForecast era =>
Forecast t era -> TPraosLedgerView
SL.forecastToTPraosLedgerView (Forecast Future era -> TPraosLedgerView)
-> Forecast Future era -> TPraosLedgerView
forall a b. (a -> b) -> a -> b
$
        Globals -> SlotNo -> NewEpochState era -> Forecast Future era
forall era.
EraForecast era =>
Globals -> SlotNo -> NewEpochState era -> Forecast Future era
SL.futureForecast Globals
globals SlotNo
for NewEpochState era
shelleyLedgerState

    -- Exclusive upper bound
    maxFor :: SlotNo
    maxFor :: SlotNo
maxFor = Word64 -> SlotNo -> SlotNo
addSlots Word64
swindow (SlotNo -> SlotNo) -> SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ WithOrigin SlotNo -> SlotNo
forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin WithOrigin SlotNo
at

instance
  ( ShelleyCompatible (Praos crypto) era
  , SL.EraForecast era
  , Praos.PraosCrypto crypto
  ) =>
  LedgerSupportsProtocol (ShelleyBlock (Praos crypto) era)
  where
  protocolLedgerView :: forall (mk :: MapKind).
LedgerConfig (ShelleyBlock (Praos crypto) era)
-> Ticked LedgerState (ShelleyBlock (Praos crypto) era) mk
-> LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era))
protocolLedgerView LedgerConfig (ShelleyBlock (Praos crypto) era)
_cfg Ticked LedgerState (ShelleyBlock (Praos crypto) era) mk
st =
    let nes :: NewEpochState era
nes = Ticked LedgerState (ShelleyBlock (Praos crypto) era) mk
-> NewEpochState era
forall proto era (mk :: MapKind).
Ticked LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
tickedShelleyLedgerState Ticked LedgerState (ShelleyBlock (Praos crypto) era) mk
st

        SL.NewEpochState{PoolDistr
nesPd :: PoolDistr
nesPd :: forall era. NewEpochState era -> PoolDistr
nesPd} = NewEpochState era
nes

        pparam :: forall a. Lens.Micro.Lens' (LedgerCore.PParams era) a -> a
        pparam :: forall a. Lens' (PParams era) a -> a
pparam Lens' (PParams era) a
lens = NewEpochState era -> PParams era
forall era. EraGov era => NewEpochState era -> PParams era
getPParams NewEpochState era
nes PParams era -> Getting a (PParams era) a -> a
forall s a. s -> Getting a s a -> a
Lens.Micro.^. Getting a (PParams era) a
Lens' (PParams era) a
lens
     in Praos.PraosLedgerView
          { plvPoolDistr :: PoolDistr
Praos.plvPoolDistr = PoolDistr
nesPd
          , plvMaxBodySize :: Word32
Praos.plvMaxBodySize = Lens' (PParams era) Word32 -> Word32
forall a. Lens' (PParams era) a -> a
pparam (Word32 -> f Word32) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams era) Word32
LedgerCore.ppMaxBBSizeL
          , plvMaxHeaderSize :: Word16
Praos.plvMaxHeaderSize = Lens' (PParams era) Word16 -> Word16
forall a. Lens' (PParams era) a -> a
pparam (Word16 -> f Word16) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
LedgerCore.ppMaxBHSizeL
          , plvProtocolVersion :: ProtVer
Praos.plvProtocolVersion = Lens' (PParams era) ProtVer -> ProtVer
forall a. Lens' (PParams era) a -> a
pparam (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
LedgerCore.ppProtocolVersionL
          }

  ledgerViewForecastAt :: forall (mk :: MapKind).
HasCallStack =>
LedgerConfig (ShelleyBlock (Praos crypto) era)
-> LedgerState (ShelleyBlock (Praos crypto) era) mk
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era)))
ledgerViewForecastAt LedgerConfig (ShelleyBlock (Praos crypto) era)
cfg LedgerState (ShelleyBlock (Praos crypto) era) mk
ledgerState = WithOrigin SlotNo
-> (SlotNo
    -> Except
         OutsideForecastRange
         (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era))))
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era)))
forall a.
WithOrigin SlotNo
-> (SlotNo -> Except OutsideForecastRange a) -> Forecast a
Forecast WithOrigin SlotNo
at ((SlotNo
  -> Except
       OutsideForecastRange
       (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era))))
 -> Forecast
      (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era))))
-> (SlotNo
    -> Except
         OutsideForecastRange
         (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era))))
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era)))
forall a b. (a -> b) -> a -> b
$ \SlotNo
for ->
    if
      | SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
for WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== WithOrigin SlotNo
at ->
          PraosLedgerView
-> ExceptT OutsideForecastRange Identity PraosLedgerView
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (PraosLedgerView
 -> ExceptT OutsideForecastRange Identity PraosLedgerView)
-> PraosLedgerView
-> ExceptT OutsideForecastRange Identity PraosLedgerView
forall a b. (a -> b) -> a -> b
$
            Forecast Current era -> PraosLedgerView
forall (t :: Timeline) era.
EraForecast era =>
Forecast t era -> PraosLedgerView
Praos.forecastToPraosLedgerView (NewEpochState era -> Forecast Current era
forall era.
EraForecast era =>
NewEpochState era -> Forecast Current era
SL.currentForecast NewEpochState era
shelleyLedgerState)
      | SlotNo
for SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
maxFor ->
          PraosLedgerView
-> ExceptT OutsideForecastRange Identity PraosLedgerView
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (PraosLedgerView
 -> ExceptT OutsideForecastRange Identity PraosLedgerView)
-> PraosLedgerView
-> ExceptT OutsideForecastRange Identity PraosLedgerView
forall a b. (a -> b) -> a -> b
$ SlotNo -> PraosLedgerView
futureLedgerView SlotNo
for
      | Bool
otherwise ->
          OutsideForecastRange
-> Except
     OutsideForecastRange
     (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era)))
forall a.
OutsideForecastRange -> ExceptT OutsideForecastRange Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (OutsideForecastRange
 -> Except
      OutsideForecastRange
      (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era))))
-> OutsideForecastRange
-> Except
     OutsideForecastRange
     (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era)))
forall a b. (a -> b) -> a -> b
$
            OutsideForecastRange
              { outsideForecastAt :: WithOrigin SlotNo
outsideForecastAt = WithOrigin SlotNo
at
              , outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor = SlotNo
maxFor
              , outsideForecastFor :: SlotNo
outsideForecastFor = SlotNo
for
              }
   where
    ShelleyLedgerState{NewEpochState era
shelleyLedgerState :: forall proto era (mk :: MapKind).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState} = LedgerState (ShelleyBlock (Praos crypto) era) mk
ledgerState
    globals :: Globals
globals = ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals LedgerConfig (ShelleyBlock (Praos crypto) era)
ShelleyLedgerConfig era
cfg
    swindow :: Word64
swindow = Globals -> Word64
SL.stabilityWindow Globals
globals
    at :: WithOrigin SlotNo
at = LedgerState (ShelleyBlock (Praos crypto) era) mk
-> WithOrigin SlotNo
forall blk (mk :: MapKind).
UpdateLedger blk =>
LedgerState blk mk -> WithOrigin SlotNo
ledgerTipSlot LedgerState (ShelleyBlock (Praos crypto) era) mk
ledgerState

    futureLedgerView :: SlotNo -> Praos.PraosLedgerView
    futureLedgerView :: SlotNo -> PraosLedgerView
futureLedgerView SlotNo
for =
      Forecast Future era -> PraosLedgerView
forall (t :: Timeline) era.
EraForecast era =>
Forecast t era -> PraosLedgerView
Praos.forecastToPraosLedgerView (Forecast Future era -> PraosLedgerView)
-> Forecast Future era -> PraosLedgerView
forall a b. (a -> b) -> a -> b
$
        Globals -> SlotNo -> NewEpochState era -> Forecast Future era
forall era.
EraForecast era =>
Globals -> SlotNo -> NewEpochState era -> Forecast Future era
SL.futureForecast Globals
globals SlotNo
for NewEpochState era
shelleyLedgerState

    -- Exclusive upper bound
    maxFor :: SlotNo
    maxFor :: SlotNo
maxFor = Word64 -> SlotNo -> SlotNo
addSlots Word64
swindow (SlotNo -> SlotNo) -> SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ WithOrigin SlotNo -> SlotNo
forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin WithOrigin SlotNo
at