{-# LANGUAGE DataKinds                #-}
{-# LANGUAGE DerivingStrategies       #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE FlexibleInstances        #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE MultiParamTypeClasses    #-}
{-# LANGUAGE MultiWayIf               #-}
{-# LANGUAGE NamedFieldPuns           #-}
{-# LANGUAGE OverloadedStrings        #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE TypeApplications         #-}
{-# LANGUAGE TypeFamilies             #-}
{-# LANGUAGE UndecidableInstances     #-}
{-# 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.Shelley.API as SL
import qualified Cardano.Protocol.TPraos.API as SL
import           Control.Monad.Except (MonadError (throwError))
import           Data.Coerce (coerce)
import           GHC.Records (getField)
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
import qualified Ouroboros.Consensus.Protocol.Praos.Views as Praos
import           Ouroboros.Consensus.Protocol.TPraos (TPraos)
import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos
import           Ouroboros.Consensus.Protocol.Translate (TranslateProto,
                     translateTickedLedgerView)
import           Ouroboros.Consensus.Shelley.Eras (EraCrypto)
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, crypto ~ EraCrypto era) =>
  LedgerSupportsProtocol (ShelleyBlock (TPraos crypto) era)
  where
  protocolLedgerView :: LedgerConfig (ShelleyBlock (TPraos crypto) era)
-> Ticked (LedgerState (ShelleyBlock (TPraos crypto) era))
-> Ticked
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
protocolLedgerView LedgerConfig (ShelleyBlock (TPraos crypto) era)
_cfg =
    LedgerView crypto -> Ticked (LedgerView crypto)
forall c. LedgerView c -> Ticked (LedgerView c)
TPraos.TickedPraosLedgerView
      (LedgerView crypto -> Ticked (LedgerView crypto))
-> (Ticked (LedgerState (ShelleyBlock (TPraos crypto) era))
    -> LedgerView crypto)
-> Ticked (LedgerState (ShelleyBlock (TPraos crypto) era))
-> Ticked (LedgerView crypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> LedgerView crypto
forall era.
GetLedgerView era =>
NewEpochState era -> LedgerView (Crypto era)
SL.currentLedgerView
      (NewEpochState era -> LedgerView crypto)
-> (Ticked (LedgerState (ShelleyBlock (TPraos crypto) era))
    -> NewEpochState era)
-> Ticked (LedgerState (ShelleyBlock (TPraos crypto) era))
-> LedgerView crypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (ShelleyBlock (TPraos crypto) era))
-> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState

  ledgerViewForecastAt :: LedgerConfig (ShelleyBlock (TPraos crypto) era)
-> LedgerState (ShelleyBlock (TPraos crypto) era)
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
ledgerViewForecastAt LedgerConfig (ShelleyBlock (TPraos crypto) era)
cfg LedgerState (ShelleyBlock (TPraos crypto) era)
ledgerState = WithOrigin SlotNo
-> (SlotNo
    -> Except OutsideForecastRange (Ticked (LedgerView crypto)))
-> Forecast (LedgerView crypto)
forall a.
WithOrigin SlotNo
-> (SlotNo -> Except OutsideForecastRange (Ticked a)) -> Forecast a
Forecast WithOrigin SlotNo
at ((SlotNo
  -> Except OutsideForecastRange (Ticked (LedgerView crypto)))
 -> Forecast (LedgerView crypto))
-> (SlotNo
    -> Except OutsideForecastRange (Ticked (LedgerView crypto)))
-> Forecast (LedgerView crypto)
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 ->
          Ticked (LedgerView crypto)
-> Except OutsideForecastRange (Ticked (LedgerView crypto))
forall (m :: * -> *) a. Monad m => a -> m a
return (Ticked (LedgerView crypto)
 -> Except OutsideForecastRange (Ticked (LedgerView crypto)))
-> Ticked (LedgerView crypto)
-> Except OutsideForecastRange (Ticked (LedgerView crypto))
forall a b. (a -> b) -> a -> b
$ LedgerView crypto -> Ticked (LedgerView crypto)
forall c. LedgerView c -> Ticked (LedgerView c)
TPraos.TickedPraosLedgerView (LedgerView crypto -> Ticked (LedgerView crypto))
-> LedgerView crypto -> Ticked (LedgerView crypto)
forall a b. (a -> b) -> a -> b
$ NewEpochState era -> LedgerView (EraCrypto era)
forall era.
GetLedgerView era =>
NewEpochState era -> LedgerView (Crypto era)
SL.currentLedgerView NewEpochState era
shelleyLedgerState
        | SlotNo
for SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
maxFor ->
          Ticked (LedgerView crypto)
-> Except OutsideForecastRange (Ticked (LedgerView crypto))
forall (m :: * -> *) a. Monad m => a -> m a
return (Ticked (LedgerView crypto)
 -> Except OutsideForecastRange (Ticked (LedgerView crypto)))
-> Ticked (LedgerView crypto)
-> Except OutsideForecastRange (Ticked (LedgerView crypto))
forall a b. (a -> b) -> a -> b
$ SlotNo -> Ticked (LedgerView (EraCrypto era))
futureLedgerView SlotNo
for
        | Bool
otherwise ->
          OutsideForecastRange
-> Except OutsideForecastRange (Ticked (LedgerView crypto))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (OutsideForecastRange
 -> Except OutsideForecastRange (Ticked (LedgerView crypto)))
-> OutsideForecastRange
-> Except OutsideForecastRange (Ticked (LedgerView crypto))
forall a b. (a -> b) -> a -> b
$
            OutsideForecastRange :: WithOrigin SlotNo -> SlotNo -> SlotNo -> OutsideForecastRange
OutsideForecastRange
              { outsideForecastAt :: WithOrigin SlotNo
outsideForecastAt = WithOrigin SlotNo
at,
                outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor = SlotNo
maxFor,
                outsideForecastFor :: SlotNo
outsideForecastFor = SlotNo
for
              }
    where
      ShelleyLedgerState {shelleyLedgerState} = LedgerState (ShelleyBlock (TPraos crypto) era)
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) -> WithOrigin SlotNo
forall blk.
UpdateLedger blk =>
LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot LedgerState (ShelleyBlock (TPraos crypto) era)
ledgerState

      futureLedgerView :: SlotNo -> Ticked (SL.LedgerView (EraCrypto era))
      futureLedgerView :: SlotNo -> Ticked (LedgerView (EraCrypto era))
futureLedgerView =
        (FutureLedgerViewError era -> Ticked (LedgerView crypto))
-> (LedgerView crypto -> Ticked (LedgerView crypto))
-> Either (FutureLedgerViewError era) (LedgerView crypto)
-> Ticked (LedgerView crypto)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (\FutureLedgerViewError era
e -> [Char] -> Ticked (LedgerView crypto)
forall a. HasCallStack => [Char] -> a
error ([Char]
"futureLedgerView failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> FutureLedgerViewError era -> [Char]
forall a. Show a => a -> [Char]
show FutureLedgerViewError era
e))
          LedgerView crypto -> Ticked (LedgerView crypto)
forall c. LedgerView c -> Ticked (LedgerView c)
TPraos.TickedPraosLedgerView
          (Either (FutureLedgerViewError era) (LedgerView crypto)
 -> Ticked (LedgerView crypto))
-> (SlotNo
    -> Either (FutureLedgerViewError era) (LedgerView crypto))
-> SlotNo
-> Ticked (LedgerView crypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Globals
-> NewEpochState era
-> SlotNo
-> Either (FutureLedgerViewError era) (LedgerView (EraCrypto era))
forall era (m :: * -> *).
(GetLedgerView era, MonadError (FutureLedgerViewError era) m) =>
Globals
-> NewEpochState era -> SlotNo -> m (LedgerView (Crypto era))
SL.futureLedgerView Globals
globals 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,
    ShelleyCompatible (TPraos crypto) era,
    crypto ~ EraCrypto era,
    TranslateProto (TPraos crypto) (Praos crypto)
  ) =>
  LedgerSupportsProtocol (ShelleyBlock (Praos crypto) era)
  where
  protocolLedgerView :: LedgerConfig (ShelleyBlock (Praos crypto) era)
-> Ticked (LedgerState (ShelleyBlock (Praos crypto) era))
-> Ticked
     (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era)))
protocolLedgerView LedgerConfig (ShelleyBlock (Praos crypto) era)
_cfg Ticked (LedgerState (ShelleyBlock (Praos crypto) era))
st =
    let SL.NewEpochState {PoolDistr (EraCrypto era)
nesPd :: forall era. NewEpochState era -> PoolDistr (Crypto era)
nesPd :: PoolDistr (EraCrypto era)
nesPd, EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
nesEs :: EpochState era
nesEs} = Ticked (LedgerState (ShelleyBlock (Praos crypto) era))
-> NewEpochState era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
tickedShelleyLedgerState Ticked (LedgerState (ShelleyBlock (Praos crypto) era))
st
     in LedgerView crypto -> Ticked (LedgerView crypto)
forall c. LedgerView c -> Ticked (LedgerView c)
Praos.TickedPraosLedgerView (LedgerView crypto -> Ticked (LedgerView crypto))
-> LedgerView crypto -> Ticked (LedgerView crypto)
forall a b. (a -> b) -> a -> b
$
          LedgerView :: forall crypto.
PoolDistr crypto
-> Natural -> Natural -> ProtVer -> LedgerView crypto
Praos.LedgerView
            { lvPoolDistr :: PoolDistr crypto
Praos.lvPoolDistr = PoolDistr crypto
PoolDistr (EraCrypto era)
nesPd,
              lvMaxBodySize :: Natural
Praos.lvMaxBodySize = forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "_maxBBSize" r a => r -> a
getField @"_maxBBSize" (PParams era -> Natural)
-> (EpochState era -> PParams era) -> EpochState era -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> PParams era
forall era. EpochState era -> PParams era
SL.esPp (EpochState era -> Natural) -> EpochState era -> Natural
forall a b. (a -> b) -> a -> b
$ EpochState era
nesEs,
              lvMaxHeaderSize :: Natural
Praos.lvMaxHeaderSize = 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)
-> (EpochState era -> PParams era) -> EpochState era -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> PParams era
forall era. EpochState era -> PParams era
SL.esPp (EpochState era -> Natural) -> EpochState era -> Natural
forall a b. (a -> b) -> a -> b
$ EpochState era
nesEs,
              lvProtocolVersion :: ProtVer
Praos.lvProtocolVersion = forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "_protocolVersion" r a => r -> a
getField @"_protocolVersion" (PParams era -> ProtVer)
-> (EpochState era -> PParams era) -> EpochState era -> ProtVer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> PParams era
forall era. EpochState era -> PParams era
SL.esPp (EpochState era -> ProtVer) -> EpochState era -> ProtVer
forall a b. (a -> b) -> a -> b
$ EpochState era
nesEs
            }

  -- | Currently the Shelley+ ledger is hard-coded to produce a TPraos ledger
  -- view. Since we can convert them, we piggy-back on this to get a Praos
  -- ledger view. Ultimately, we will want to liberalise the ledger code
  -- slightly.
  ledgerViewForecastAt :: LedgerConfig (ShelleyBlock (Praos crypto) era)
-> LedgerState (ShelleyBlock (Praos crypto) era)
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era)))
ledgerViewForecastAt LedgerConfig (ShelleyBlock (Praos crypto) era)
cfg LedgerState (ShelleyBlock (Praos crypto) era)
st =
    (Ticked (LedgerView crypto) -> Ticked (LedgerView crypto))
-> Forecast (LedgerView crypto) -> Forecast (LedgerView crypto)
forall a b. (Ticked a -> Ticked b) -> Forecast a -> Forecast b
mapForecast (TranslateProto (TPraos crypto) (Praos crypto) =>
Ticked (LedgerView (TPraos crypto))
-> Ticked (LedgerView (Praos crypto))
forall protoFrom protoTo.
TranslateProto protoFrom protoTo =>
Ticked (LedgerView protoFrom) -> Ticked (LedgerView protoTo)
translateTickedLedgerView @(TPraos crypto) @(Praos crypto)) (Forecast (LedgerView crypto) -> Forecast (LedgerView crypto))
-> Forecast (LedgerView crypto) -> Forecast (LedgerView crypto)
forall a b. (a -> b) -> a -> b
$
      LedgerConfig (ShelleyBlock (TPraos crypto) era)
-> LedgerState (ShelleyBlock (TPraos crypto) era)
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
forall blk.
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk))
ledgerViewForecastAt @(ShelleyBlock (TPraos crypto) era) LedgerConfig (ShelleyBlock (Praos crypto) era)
LedgerConfig (ShelleyBlock (TPraos crypto) era)
cfg LedgerState (ShelleyBlock (TPraos crypto) era)
st'
    where
      st' :: LedgerState (ShelleyBlock (TPraos crypto) era)
      st' :: LedgerState (ShelleyBlock (TPraos crypto) era)
st' =
        ShelleyLedgerState :: forall proto era.
WithOrigin (ShelleyTip proto era)
-> NewEpochState era
-> ShelleyTransition
-> LedgerState (ShelleyBlock proto era)
ShelleyLedgerState
          { shelleyLedgerTip :: WithOrigin (ShelleyTip (TPraos crypto) era)
shelleyLedgerTip = ShelleyTip (Praos crypto) era -> ShelleyTip (TPraos crypto) era
forall proto proto era era.
(HASH (ProtoCrypto proto) ~ HASH (ProtoCrypto proto)) =>
ShelleyTip proto era -> ShelleyTip proto era
coerceTip (ShelleyTip (Praos crypto) era -> ShelleyTip (TPraos crypto) era)
-> WithOrigin (ShelleyTip (Praos crypto) era)
-> WithOrigin (ShelleyTip (TPraos crypto) era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerState (ShelleyBlock (Praos crypto) era)
-> WithOrigin (ShelleyTip (Praos crypto) era)
forall proto era.
LedgerState (ShelleyBlock proto era)
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip LedgerState (ShelleyBlock (Praos crypto) era)
st,
            shelleyLedgerState :: NewEpochState era
shelleyLedgerState = LedgerState (ShelleyBlock (Praos crypto) era) -> NewEpochState era
forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
shelleyLedgerState LedgerState (ShelleyBlock (Praos crypto) era)
st,
            shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition = LedgerState (ShelleyBlock (Praos crypto) era) -> ShelleyTransition
forall proto era.
LedgerState (ShelleyBlock proto era) -> ShelleyTransition
shelleyLedgerTransition LedgerState (ShelleyBlock (Praos crypto) era)
st
          }
      coerceTip :: ShelleyTip proto era -> ShelleyTip proto era
coerceTip (ShelleyTip SlotNo
slot BlockNo
block HeaderHash (ShelleyBlock proto era)
hash) = SlotNo
-> BlockNo
-> HeaderHash (ShelleyBlock proto era)
-> ShelleyTip proto era
forall proto era.
SlotNo
-> BlockNo
-> HeaderHash (ShelleyBlock proto era)
-> ShelleyTip proto era
ShelleyTip SlotNo
slot BlockNo
block (ShelleyHash (ProtoCrypto proto) -> ShelleyHash (ProtoCrypto proto)
coerce HeaderHash (ShelleyBlock proto era)
ShelleyHash (ProtoCrypto proto)
hash)