WIP: expose STSOpts interface

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs

@@ -174,28 +174,37 @@ instance IsLedger (LedgerState ByronBlock) where
   type AuxLedgerEvent (LedgerState ByronBlock) =
     VoidLedgerEvent (LedgerState ByronBlock)
 
-  applyChainTickLedgerResult cfg slotNo ByronLedgerState{..} = pureLedgerResult $
+  type STSOptions (LedgerState ByronBlock) = CC.ValidationMode
+
+  applyChainTickLedgerResultWithSTSOpts _ cfg slotNo ByronLedgerState{..} = pureLedgerResult $
       TickedByronLedgerState {
           tickedByronLedgerState =
             CC.applyChainTick cfg (toByronSlotNo slotNo) byronLedgerState
         , untickedByronLedgerTransition =
             byronLedgerTransition
         }
 
+  fastSTSOpts _ = CC.fromBlockValidationMode CC.NoBlockValidation
+  accurateSTSOpts _ = CC.fromBlockValidationMode CC.BlockValidation
+  enableSTSEvents _ = id
+
+deriving instance Generic CC.ValidationMode
+instance NoThunks CC.ValidationMode
+deriving instance Eq CC.ValidationMode
+deriving instance Generic CC.BlockValidationMode
+instance NoThunks CC.BlockValidationMode
+deriving instance Generic CC.TxValidationMode
+instance NoThunks CC.TxValidationMode
+
 {-------------------------------------------------------------------------------
   Supporting the various consensus interfaces
 -------------------------------------------------------------------------------}
 
 instance ApplyBlock (LedgerState ByronBlock) ByronBlock where
-  applyBlockLedgerResult = fmap pureLedgerResult ..: applyByronBlock validationMode
-    where
-      validationMode = CC.fromBlockValidationMode CC.BlockValidation
+  applyBlockLedgerResultWithSTSOpts sts = fmap pureLedgerResult ..: applyByronBlock sts
 
-  reapplyBlockLedgerResult =
-          (pureLedgerResult . validationErrorImpossible)
-      ..: applyByronBlock validationMode
-    where
-      validationMode = CC.fromBlockValidationMode CC.NoBlockValidation
+instance ThrowLedgerReapplyError (LedgerState ByronBlock) where
+  reapplyResult = validationErrorImpossible
 
 data instance BlockQuery ByronBlock :: Type -> Type where
   GetUpdateInterfaceState :: BlockQuery ByronBlock UPI.State
@@ -309,12 +318,8 @@ instance HasHardForkHistory ByronBlock where
 -- the event it is given a 'BlockValidationMode' of 'BlockValidation', it still
 -- /looks/ like it can fail (since its type doesn't change based on the
 -- 'ValidationMode') and we must still treat it as such.
-validationErrorImpossible :: forall err a. Except err a -> a
-validationErrorImpossible = cantBeError . runExcept
-  where
-    cantBeError :: Either err a -> a
-    cantBeError (Left  _) = error "validationErrorImpossible: unexpected error"
-    cantBeError (Right a) = a
+validationErrorImpossible :: forall err a. err -> a
+validationErrorImpossible _ = error "validationErrorImpossible: unexpected error"
 
 {-------------------------------------------------------------------------------
   Applying a block

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs

@@ -175,6 +175,7 @@ data ProtocolParamsByron = ProtocolParamsByron {
     , byronProtocolVersion        :: Update.ProtocolVersion
     , byronSoftwareVersion        :: Update.SoftwareVersion
     , byronLeaderCredentials      :: Maybe ByronLeaderCredentials
+    , byronSTSOptions             :: STSOptions (LedgerState ByronBlock)
     }
 
 protocolInfoByron :: ProtocolParamsByron
@@ -184,6 +185,7 @@ protocolInfoByron ProtocolParamsByron {
                     , byronPbftSignatureThreshold = mSigThresh
                     , byronProtocolVersion        = pVer
                     , byronSoftwareVersion        = sVer
+                    , byronSTSOptions             = sts
                     } =
     ProtocolInfo {
         pInfoConfig = TopLevelConfig {
@@ -195,6 +197,7 @@ protocolInfoByron ProtocolParamsByron {
           , topLevelConfigCodec       = mkByronCodecConfig compactedGenesisConfig
           , topLevelConfigStorage     = ByronStorageConfig blockConfig
           , topLevelConfigCheckpoints = emptyCheckpointsMap
+          , topLevelConfigSTS         = sts
           }
       , pInfoInitLedger = ExtLedgerState {
             -- Important: don't pass the compacted genesis config to

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs

@@ -74,6 +74,7 @@ import qualified Data.SOP.OptNP as OptNP
 import           Data.SOP.Strict
 import           Data.Word (Word16, Word64)
 import           Lens.Micro ((^.))
+import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Byron.Ledger (ByronBlock)
 import qualified Ouroboros.Consensus.Byron.Ledger as Byron
@@ -451,6 +452,7 @@ data CardanoProtocolParams c = CardanoProtocolParams {
     -- /intra-era hard fork/ (ie conditionals in the ledger rules).
     --
   , cardanoProtocolVersion        :: ProtVer
+  , cardanoSTS                    :: PerEraSTSOptions (CardanoShelleyEras c)
   }
 
 -- | Create a 'ProtocolInfo' for 'CardanoBlock'
@@ -466,7 +468,7 @@ data CardanoProtocolParams c = CardanoProtocolParams {
 -- for mainnet (check against @'SL.gNetworkId' == 'SL.Mainnet'@).
 protocolInfoCardano ::
      forall c m. (IOLike m, CardanoHardForkConstraints c)
-  => CardanoProtocolParams c
+  => 1CardanoProtocolParams c
   -> ( ProtocolInfo      (CardanoBlock c)
      , m [BlockForging m (CardanoBlock c)]
      )
@@ -497,6 +499,7 @@ protocolInfoCardano paramsCardano
       , cardanoLedgerTransitionConfig
       , cardanoCheckpoints
       , cardanoProtocolVersion
+      , cardanoSTS = sts
       } = paramsCardano
 
     genesisShelley = cardanoLedgerTransitionConfig ^. L.tcShelleyGenesisL
@@ -772,6 +775,9 @@ protocolInfoCardano paramsCardano
             (Shelley.ShelleyStorageConfig tpraosSlotsPerKESPeriod k)
             (Shelley.ShelleyStorageConfig tpraosSlotsPerKESPeriod k)
       , topLevelConfigCheckpoints = cardanoCheckpoints
+      , topLevelConfigSTS = PerEraSTSOptions $
+              WrapSTSOptions (byronSTSOptions byronProtocolParams)
+           :* getPerEraSTSOptions sts
       }
 
     -- When the initial ledger state is not in the Byron era, register various

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs

@@ -45,6 +45,8 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger (
   , encodeShelleyAnnTip
   , encodeShelleyHeaderState
   , encodeShelleyLedgerState
+  -- * STS
+  , SomeSTSOpts (..)
   ) where
 
 import qualified Cardano.Ledger.BaseTypes as SL (epochInfoPure)
@@ -90,7 +92,7 @@ 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)
+                     (EnvelopeCheckError, envelopeChecks, mkHeaderView, ProtoCrypto)
 import           Ouroboros.Consensus.Util ((..:))
 import           Ouroboros.Consensus.Util.CBOR (decodeWithOrigin,
                      encodeWithOrigin)
@@ -274,17 +276,49 @@ untickedShelleyLedgerTipPoint ::
   -> Point (ShelleyBlock proto era)
 untickedShelleyLedgerTipPoint = shelleyTipToPoint . untickedShelleyLedgerTip
 
+data SomeSTSOpts where
+  SomeSTSOpts :: (NoThunks (STS.SingEP ep), STS.EventReturnTypeRep ep) => STS.SingEP ep -> SomeSTSOpts
+
+instance Show SomeSTSOpts where
+  show _ = "SomeSTS"
+
+instance Eq SomeSTSOpts where
+  _ == _ = True
+
+instance NoThunks (STS.SingEP STS.EventPolicyReturn) where
+  wNoThunks _ STS.EPReturn = pure Nothing
+  showTypeOf _ = "SingEP EventPolicyReturn"
+
+instance NoThunks (STS.SingEP STS.EventPolicyDiscard) where
+  wNoThunks _ STS.EPDiscard = pure Nothing
+  showTypeOf _ = "SingEP EventPolicyDiscard"
+
+deriving instance Generic (STS.ApplySTSOpts ep)
+deriving instance NoThunks (STS.SingEP ep) => NoThunks (STS.ApplySTSOpts ep)
+
+deriving instance Generic STS.AssertionPolicy
+deriving instance Generic STS.ValidationPolicy
+
+deriving instance NoThunks STS.AssertionPolicy
+deriving instance NoThunks STS.ValidationPolicy
+
+instance NoThunks SomeSTSOpts where
+  wNoThunks ctxt (SomeSTSOpts ep) = wNoThunks ctxt ep
+  showTypeOf _ = "SomeSTSOpts"
+
 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 cfg slotNo ShelleyLedgerState{
+  type STSOptions (LedgerState (ShelleyBlock proto era)) = SomeSTSOpts
+
+  applyChainTickLedgerResultWithSTSOpts (SomeSTSOpts ep) cfg slotNo ShelleyLedgerState{
                                 shelleyLedgerTip
                               , shelleyLedgerState
                               , shelleyLedgerTransition
                               } =
-      swizzle appTick <&> \l' ->
+      swizzle ep (appTick ep) <&> \l' ->
       TickedShelleyLedgerState {
           untickedShelleyLedgerTip =
             shelleyLedgerTip
@@ -302,23 +336,45 @@ instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era))
       ei :: EpochInfo Identity
       ei = SL.epochInfoPure globals
 
-      swizzle (l, events) =
+      swizzle ::
+           STS.SingEP ep
+        -> STS.EventReturnType ep (Core.EraRule "TICK" era) (SL.NewEpochState era)
+        -> LedgerResult (LedgerState (ShelleyBlock proto era)) (SL.NewEpochState era)
+      swizzle STS.EPDiscard l =
+          LedgerResult {
+              lrEvents = []
+            , lrResult = l
+            }
+      swizzle STS.EPReturn (l, events) =
           LedgerResult {
               lrEvents = map ShelleyLedgerEventTICK events
             , lrResult = l
             }
 
-      appTick =
+      appTick ::
+           STS.SingEP ep
+        -> STS.EventReturnType ep (Core.EraRule "TICK" era) (SL.NewEpochState era)
+      appTick ep' =
         SL.applyTickOpts
           STS.ApplySTSOpts {
-              asoAssertions = STS.globalAssertionPolicy
-            , asoValidation = STS.ValidateAll
-            , asoEvents     = STS.EPReturn
+              asoAssertions = STS.AssertionsOff
+            , asoValidation = STS.ValidateNone
+            , asoEvents     = ep'
             }
           globals
           shelleyLedgerState
           slotNo
 
+  fastSTSOpts _ = SomeSTSOpts $ undefined
+
+  accurateSTSOpts _ = SomeSTSOpts $ STS.ApplySTSOpts {
+              asoAssertions = STS.globalAssertionPolicy
+            , asoValidation = STS.ValidateAll
+            , asoEvents     = STS.EPDiscard
+            }
+
+  enableSTSEvents _ (SomeSTSOpts opts) = SomeSTSOpts $ opts { STS.asoEvents = STS.EPReturn }
+
 -- | All events emitted by the Shelley ledger API
 data ShelleyLedgerEvent era =
     -- | An event emitted when (re)applying a block
@@ -338,49 +394,51 @@ instance ShelleyCompatible proto era
   --    - 'updateChainDepState': executes the @PRTCL@ transition
   -- + 'applyBlockLedgerResult': executes the @BBODY@ transition
   --
-  applyBlockLedgerResult =
-      applyHelper (swizzle ..: appBlk)
+  applyBlockLedgerResultWithSTSOpts (SomeSTSOpts opts@(STS.ApplySTSOpts _ _ ep)) cfg =
+      applyHelper (swizzle ep ..: appBlk opts) cfg
     where
-      swizzle m =
+      swizzle ::
+           STS.SingEP ep
+        -> Except
+             (SL.BlockTransitionError era)
+             (STS.EventReturnType ep (Core.EraRule "BBODY" era) (SL.NewEpochState era))
+        -> Except
+             (ShelleyLedgerError era)
+             (LedgerResult (LedgerState (ShelleyBlock proto era)) (SL.NewEpochState era))
+      swizzle STS.EPDiscard m =
+        withExcept BBodyError m <&> \l ->
+          LedgerResult {
+              lrEvents = []
+            , lrResult = l
+            }
+      swizzle STS.EPReturn m =
         withExcept BBodyError m <&> \(l, events) ->
           LedgerResult {
               lrEvents = map ShelleyLedgerEventBBODY events
             , lrResult = l
             }
 
+
       -- Apply the BBODY transition using the ticked state
+      appBlk ::
+           STS.EventReturnTypeRep ep
+        => STS.ApplySTSOpts ep
+        -> SL.Globals
+        -> SL.NewEpochState era
+        -> SL.Block (SL.BHeaderView (ProtoCrypto proto)) era
+        -> Except
+             (SL.BlockTransitionError era)
+             (STS.EventReturnType ep (Core.EraRule "BBODY" era) (SL.NewEpochState era))
       appBlk =
         SL.applyBlockOpts
-          STS.ApplySTSOpts {
-              asoAssertions = STS.globalAssertionPolicy
-            , asoValidation = STS.ValidateAll
-            , asoEvents     = STS.EPReturn
-            }
 
-  reapplyBlockLedgerResult =
-      runIdentity ..: applyHelper (swizzle ..: reappBlk)
-    where
-      swizzle m = case runExcept m of
-        Left err          ->
-          Exception.throw $! ShelleyReapplyException @era err
-        Right (l, events) ->
-          pure LedgerResult {
-              lrEvents = map ShelleyLedgerEventBBODY events
-            , lrResult = l
-            }
-
-      -- Reapply the BBODY transition using the ticked state
-      reappBlk =
-        SL.applyBlockOpts
-          STS.ApplySTSOpts {
-                  asoAssertions = STS.AssertionsOff
-                , asoValidation = STS.ValidateNone
-                , asoEvents     = STS.EPReturn
-                }
+instance ShelleyCompatible proto era
+      => ThrowLedgerReapplyError (LedgerState (ShelleyBlock proto era)) where
+  reapplyResult err = Exception.throw $! ShelleyReapplyException @era err
 
 data ShelleyReapplyException =
-  forall era. Show (SL.BlockTransitionError era)
-  => ShelleyReapplyException (SL.BlockTransitionError era)
+  forall era. Show (ShelleyLedgerError era)
+  => ShelleyReapplyException (ShelleyLedgerError era)
 
 instance Show ShelleyReapplyException where
   show (ShelleyReapplyException err) = "(ShelleyReapplyException " <> show err <> ")"

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs

@@ -179,16 +179,19 @@ protocolInfoShelley ::
   => SL.ShelleyGenesis c
   -> ProtocolParamsShelleyBased c
   -> SL.ProtVer
+  -> SomeSTSOpts
   -> ( ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c) )
      , m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))]
      )
 protocolInfoShelley shelleyGenesis
                     protocolParamsShelleyBased
-                    protVer =
+                    protVer
+                    doEvents =
     protocolInfoTPraosShelleyBased
       protocolParamsShelleyBased
       (L.mkShelleyTransitionConfig shelleyGenesis)
       protVer
+      doEvents
 
 protocolInfoTPraosShelleyBased ::
      forall m era c.
@@ -202,6 +205,7 @@ protocolInfoTPraosShelleyBased ::
   -> L.TransitionConfig era
   -> SL.ProtVer
      -- ^ see 'shelleyProtVer', mutatis mutandi
+  -> SomeSTSOpts
   -> ( ProtocolInfo (ShelleyBlock (TPraos c) era)
      , m [BlockForging m (ShelleyBlock (TPraos c) era)]
      )
@@ -210,7 +214,9 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased {
                            , shelleyBasedLeaderCredentials = credentialss
                            }
                          transitionCfg
-                         protVer =
+                         protVer
+                         sts
+  =
     assertWithMsg (validateGenesis genesis) $
     ( ProtocolInfo {
         pInfoConfig       = topLevelConfig
@@ -235,6 +241,7 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased {
       , topLevelConfigCodec       = ShelleyCodecConfig
       , topLevelConfigStorage     = storageConfig
       , topLevelConfigCheckpoints = emptyCheckpointsMap
+      , topLevelConfigSTS         = sts
       }
 
     consensusConfig :: ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))

ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -106,6 +107,7 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss =
               , dualStorageConfigAux  = ByronSpecStorageConfig
               }
           , topLevelConfigCheckpoints = emptyCheckpointsMap
+          , topLevelConfigSTS         = fastSTSOpts (Proxy @(LedgerState ByronBlock))
           }
       , pInfoInitLedger = ExtLedgerState {
              ledgerState = DualLedgerState {