WIP2

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

@@ -174,7 +174,7 @@ instance IsLedger (LedgerState ByronBlock) where
   type AuxLedgerEvent (LedgerState ByronBlock) =
     VoidLedgerEvent (LedgerState ByronBlock)
 
-  type STSOptions (LedgerState ByronBlock) = ()
+  type STSOptions (LedgerState ByronBlock) = CC.ValidationMode
 
   applyChainTickLedgerResult _ cfg slotNo ByronLedgerState{..} = pureLedgerResult $
       TickedByronLedgerState {
@@ -184,20 +184,25 @@ instance IsLedger (LedgerState ByronBlock) where
             byronLedgerTransition
         }
 
+  fastSTSOpts _ = CC.fromBlockValidationMode CC.NoBlockValidation
+  accurateSTSOpts _ = CC.fromBlockValidationMode CC.BlockValidation
+  enableSTSEvents _ = id
+
+deriving instance Generic CC.ValidationMode
+instance NoThunks 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
+  applyBlockLedgerResult sts = fmap pureLedgerResult ..: applyByronBlock sts
 
-  reapplyBlockLedgerResult _ =
-          (pureLedgerResult . validationErrorImpossible)
-      ..: applyByronBlock validationMode
-    where
-      validationMode = CC.fromBlockValidationMode CC.NoBlockValidation
+  reapplyResult _ = validationErrorImpossible
 
 data instance BlockQuery ByronBlock :: Type -> Type where
   GetUpdateInterfaceState :: BlockQuery ByronBlock UPI.State

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

@@ -25,6 +25,7 @@ module Ouroboros.Consensus.Byron.Node (
   , protocolInfoByron
   ) where
 
+import qualified Cardano.Chain.ValidationMode as Validation
 import qualified Cardano.Chain.Delegation as Delegation
 import qualified Cardano.Chain.Genesis as Genesis
 import           Cardano.Chain.ProtocolConstants (kEpochSlots)
@@ -178,13 +179,16 @@ data ProtocolParamsByron = ProtocolParamsByron {
     }
 
 protocolInfoByron :: ProtocolParamsByron
+                  -> Validation.ValidationMode
                   -> ProtocolInfo ByronBlock
 protocolInfoByron ProtocolParamsByron {
                       byronGenesis                = genesisConfig
                     , byronPbftSignatureThreshold = mSigThresh
                     , byronProtocolVersion        = pVer
                     , byronSoftwareVersion        = sVer
-                    } =
+                    }
+                  sts
+  =
     ProtocolInfo {
         pInfoConfig = TopLevelConfig {
             topLevelConfigProtocol = PBftConfig {
@@ -195,7 +199,7 @@ protocolInfoByron ProtocolParamsByron {
           , topLevelConfigCodec       = mkByronCodecConfig compactedGenesisConfig
           , topLevelConfigStorage     = ByronStorageConfig blockConfig
           , topLevelConfigCheckpoints = emptyCheckpointsMap
-          , topLevelConfigSTS         = ()
+          , 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

@@ -532,7 +532,7 @@ protocolInfoCardano paramsCardano
           , topLevelConfigBlock    = blockConfigByron
           }
       , pInfoInitLedger = initExtLedgerStateByron
-      } = protocolInfoByron byronProtocolParams
+      } = protocolInfoByron byronProtocolParams undefined
 
     partialConsensusConfigByron :: PartialConsensusConfig (BlockProtocol ByronBlock)
     partialConsensusConfigByron = consensusConfigByron

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

@@ -45,7 +45,8 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger (
   , encodeShelleyAnnTip
   , encodeShelleyHeaderState
   , encodeShelleyLedgerState
-  , someEpSing
+--  , someEpSing
+  , SomeSTSOpts (..)
   ) where
 
 import qualified Cardano.Ledger.BaseTypes as SL (epochInfoPure)
@@ -275,28 +276,43 @@ untickedShelleyLedgerTipPoint ::
   -> Point (ShelleyBlock proto era)
 untickedShelleyLedgerTipPoint = shelleyTipToPoint . untickedShelleyLedgerTip
 
-data SomeEPSing where
-  SomeEPSing :: STS.EventReturnTypeRep ep => STS.SingEP ep -> SomeEPSing
+data SomeSTSOpts where
+  SomeSTSOpts :: (NoThunks (STS.SingEP ep), STS.EventReturnTypeRep ep) => STS.ApplySTSOpts ep -> SomeSTSOpts
 
-someEpSing doEvents = if doEvents then SomeEPSing STS.EPReturn else SomeEPSing STS.EPDiscard
+instance NoThunks (STS.SingEP STS.EventPolicyReturn) where
+  wNoThunks _ STS.EPReturn = pure Nothing
+  showTypeOf _ = "SingEP EventPolicyReturn"
 
-instance NoThunks SomeEPSing where
-  wNoThunks = undefined
-  showTypeOf = undefined
+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
 
-  type STSOptions (LedgerState (ShelleyBlock proto era)) = SomeEPSing
+  type STSOptions (LedgerState (ShelleyBlock proto era)) = SomeSTSOpts
 
-  applyChainTickLedgerResult (SomeEPSing ep) cfg slotNo ShelleyLedgerState{
+  applyChainTickLedgerResult (SomeSTSOpts opts@(STS.ApplySTSOpts _ _ ep)) cfg slotNo ShelleyLedgerState{
                                 shelleyLedgerTip
                               , shelleyLedgerState
                               , shelleyLedgerTransition
                               } =
-      swizzle ep (appTick ep) <&> \l' ->
+      swizzle ep (appTick opts) <&> \l' ->
       TickedShelleyLedgerState {
           untickedShelleyLedgerTip =
             shelleyLedgerTip
@@ -330,19 +346,29 @@ instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era))
             }
 
       appTick ::
-           STS.SingEP ep
+           STS.ApplySTSOpts ep
         -> STS.EventReturnType ep (Core.EraRule "TICK" era) (SL.NewEpochState era)
       appTick ep' =
         SL.applyTickOpts
-          STS.ApplySTSOpts {
-              asoAssertions = STS.globalAssertionPolicy
-            , asoValidation = STS.ValidateAll
-            , asoEvents     = ep'
-            }
+          ep'
           globals
           shelleyLedgerState
           slotNo
 
+  fastSTSOpts _ = SomeSTSOpts $ STS.ApplySTSOpts {
+              asoAssertions = STS.AssertionsOff
+            , asoValidation = STS.ValidateNone
+            , asoEvents     = STS.EPDiscard
+            }
+
+  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
@@ -362,13 +388,17 @@ instance ShelleyCompatible proto era
   --    - 'updateChainDepState': executes the @PRTCL@ transition
   -- + 'applyBlockLedgerResult': executes the @BBODY@ transition
   --
-  applyBlockLedgerResult (SomeEPSing ep) cfg =
-      applyHelper (swizzle ep ..: (appBlk ep)) cfg
+  applyBlockLedgerResult (SomeSTSOpts opts@(STS.ApplySTSOpts _ _ ep)) cfg =
+      applyHelper (swizzle ep ..: appBlk opts) cfg
     where
       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))
+        -> 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 {
@@ -386,58 +416,21 @@ instance ShelleyCompatible proto era
       -- Apply the BBODY transition using the ticked state
       appBlk ::
            STS.EventReturnTypeRep ep
-        => STS.SingEP 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 ep' =
+        -> 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     = ep'
-            }
 
-  reapplyBlockLedgerResult (SomeEPSing ep) cfg =
-      runIdentity .: applyHelper (swizzle ep ..: reappBlk ep) cfg
-    where
-      swizzle STS.EPDiscard m = case runExcept m of
-        Left err          ->
-          Exception.throw $! ShelleyReapplyException @era err
-        Right l ->
-          pure LedgerResult {
-              lrEvents = []
-            , lrResult = l
-            }
-      swizzle STS.EPReturn 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 ::
-           STS.EventReturnTypeRep ep
-        => STS.SingEP 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))
-      reappBlk ep' =
-        SL.applyBlockOpts
-          STS.ApplySTSOpts {
-                  asoAssertions = STS.AssertionsOff
-                , asoValidation = STS.ValidateNone
-                , asoEvents     = ep'
-                }
+  reapplyResult _ = either (\err -> Exception.throw $! ShelleyReapplyException @era err) id . runExcept
 
 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,7 +179,7 @@ protocolInfoShelley ::
   => SL.ShelleyGenesis c
   -> ProtocolParamsShelleyBased c
   -> SL.ProtVer
-  -> Bool
+  -> SomeSTSOpts
   -> ( ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c) )
      , m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))]
      )
@@ -205,7 +205,7 @@ protocolInfoTPraosShelleyBased ::
   -> L.TransitionConfig era
   -> SL.ProtVer
      -- ^ see 'shelleyProtVer', mutatis mutandi
-  -> Bool
+  -> SomeSTSOpts
   -> ( ProtocolInfo (ShelleyBlock (TPraos c) era)
      , m [BlockForging m (ShelleyBlock (TPraos c) era)]
      )
@@ -215,7 +215,7 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased {
                            }
                          transitionCfg
                          protVer
-                         doEvents
+                         sts
   =
     assertWithMsg (validateGenesis genesis) $
     ( ProtocolInfo {
@@ -241,7 +241,7 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased {
       , topLevelConfigCodec       = ShelleyCodecConfig
       , topLevelConfigStorage     = storageConfig
       , topLevelConfigCheckpoints = emptyCheckpointsMap
-      , topLevelConfigSTS         = someEpSing doEvents
+      , topLevelConfigSTS         = sts
       }
 
     consensusConfig :: ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs

@@ -158,6 +158,21 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where
       extended :: HardForkState LedgerState xs
       extended = State.extendToSlot cfg slot st
 
+  fastSTSOpts _ = PerEraSTSOptions (hcpure proxySingle f)
+    where
+      f :: forall blk. IsLedger (LedgerState blk) => WrapSTSOptions blk
+      f = WrapSTSOptions $ fastSTSOpts (Proxy @(LedgerState blk))
+
+  accurateSTSOpts _ = PerEraSTSOptions (hcpure proxySingle f)
+    where
+      f :: forall blk. IsLedger (LedgerState blk) => WrapSTSOptions blk
+      f = WrapSTSOptions $ accurateSTSOpts (Proxy @(LedgerState blk))
+
+  enableSTSEvents _ = PerEraSTSOptions . hcmap proxySingle f . getPerEraSTSOptions
+    where
+      f :: forall blk. IsLedger (LedgerState blk) => WrapSTSOptions blk -> WrapSTSOptions blk
+      f = WrapSTSOptions . enableSTSEvents (Proxy @(LedgerState blk)) . unwrapSTSOptions
+
 tickOne :: SingleEraBlock blk
         => EpochInfo (Except PastHorizonException)
         -> SlotNo
@@ -199,24 +214,10 @@ instance CanHardFork xs
                transition
                st
 
-  reapplyBlockLedgerResult sts cfg
-                      (HardForkBlock (OneEraBlock block))
-                      (TickedHardForkLedgerState transition st) =
-      case State.match block st of
-        Left _mismatch ->
-          -- We already applied this block to this ledger state,
-          -- so it can't be from the wrong era
-          error "reapplyBlockLedgerResult: can't be from other era"
-        Right matched ->
-            fmap HardForkLedgerState
-          $ sequenceHardForkState
-          $ hcizipWith proxySingle reapply (hzipWith (\s c -> Pair s c) (getPerEraSTSOptions sts) cfgs) matched
-    where
-      cfgs = distribLedgerConfig ei cfg
-      ei   = State.epochInfoPrecomputedTransitionInfo
-               (hardForkLedgerConfigShape cfg)
-               transition
-               st
+  reapplyResult _ _ =
+    -- We already applied this block to this ledger state,
+    -- so it can't be from the wrong era
+    error "reapplyBlockLedgerResult: can't be from other era"
 
 apply :: SingleEraBlock blk
       => Index xs                                           blk
@@ -232,18 +233,6 @@ apply index (Pair (WrapSTSOptions sts) (WrapLedgerConfig cfg)) (Pair (I block) (
     $ fmap (Comp . embedLedgerResult (injectLedgerEvent index))
     $ applyBlockLedgerResult sts cfg block st
 
-reapply :: SingleEraBlock blk
-        => Index xs                                           blk
-        -> Product WrapSTSOptions WrapLedgerConfig            blk
-        -> Product I (Ticked :.: LedgerState)                 blk
-        -> (    LedgerResult (LedgerState (HardForkBlock xs))
-            :.: LedgerState
-           )                                                  blk
-reapply index (Pair (WrapSTSOptions sts) (WrapLedgerConfig cfg)) (Pair (I block) (Comp st)) =
-      Comp
-    $ embedLedgerResult (injectLedgerEvent index)
-    $ reapplyBlockLedgerResult sts cfg block st
-
 {-------------------------------------------------------------------------------
   UpdateLedger
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs

@@ -255,7 +255,7 @@ fromChain cfg initState chain =
     anchorSnapshot NE.:| snapshots =
           fmap (mkHeaderStateWithTime (configLedger cfg))
         . NE.scanl
-            (flip (tickThenReapply (topLevelConfigSTS cfg) (ExtLedgerCfg cfg)))
+            (flip (tickThenReapply (ExtLedgerCfg cfg)))
             initState
         . Chain.toOldestFirst
         $ chain