Expose ValidationPolicy interface

ouroboros-consensus-cardano/changelog.d/20250214_122220_jasataco_sts.md

@@ -0,0 +1,24 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+
+### Breaking
+
+- Adapt to the change in block application and ticking interface in
+  Byron and Shelley. Block application and ticking now can choose
+  validation policy and enable or disable ledger events.

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

@@ -59,6 +59,7 @@ import qualified Codec.CBOR.Encoding as CBOR
 import           Codec.Serialise (decode, encode)
 import           Control.Monad (replicateM)
 import           Control.Monad.Except (Except, runExcept, throwError)
+import qualified Control.State.Transition.Extended as STS
 import           Data.ByteString (ByteString)
 import           Data.Kind (Type)
 import           Data.Map.Strict (Map)
@@ -174,7 +175,7 @@ instance IsLedger (LedgerState ByronBlock) where
   type AuxLedgerEvent (LedgerState ByronBlock) =
     VoidLedgerEvent (LedgerState ByronBlock)
 
-  applyChainTickLedgerResult cfg slotNo ByronLedgerState{..} = pureLedgerResult $
+  applyChainTickLedgerResult _ cfg slotNo ByronLedgerState{..} = pureLedgerResult $
       TickedByronLedgerState {
           tickedByronLedgerState =
             CC.applyChainTick cfg (toByronSlotNo slotNo) byronLedgerState
@@ -187,15 +188,10 @@ instance IsLedger (LedgerState ByronBlock) where
 -------------------------------------------------------------------------------}
 
 instance ApplyBlock (LedgerState ByronBlock) ByronBlock where
-  applyBlockLedgerResult = fmap pureLedgerResult ..: applyByronBlock validationMode
-    where
-      validationMode = CC.fromBlockValidationMode CC.BlockValidation
-
-  reapplyBlockLedgerResult =
-          (pureLedgerResult . validationErrorImpossible)
-      ..: applyByronBlock validationMode
-    where
-      validationMode = CC.fromBlockValidationMode CC.NoBlockValidation
+  applyBlockLedgerResultWithValidation doValidation opts =
+    fmap pureLedgerResult ..: applyByronBlock doValidation opts
+  applyBlockLedgerResult = defaultApplyBlockLedgerResult
+  reapplyBlockLedgerResult = defaultReapplyBlockLedgerResult validationErrorImpossible
 
 data instance BlockQuery ByronBlock :: Type -> Type where
   GetUpdateInterfaceState :: BlockQuery ByronBlock UPI.State
@@ -309,12 +305,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
@@ -323,22 +315,30 @@ validationErrorImpossible = cantBeError . runExcept
   the right arguments, and maintain the snapshots.
 -------------------------------------------------------------------------------}
 
-applyByronBlock :: CC.ValidationMode
+applyByronBlock :: STS.ValidationPolicy
+                -> ComputeLedgerEvents
                 -> LedgerConfig ByronBlock
                 -> ByronBlock
                 -> TickedLedgerState ByronBlock
                 -> Except (LedgerError ByronBlock) (LedgerState ByronBlock)
-applyByronBlock validationMode
+applyByronBlock doValidation
+                _doEvents
                 cfg
                 blk@(ByronBlock raw _ (ByronHash blkHash))
                 ls =
     case raw of
-      CC.ABOBBlock    raw' -> applyABlock validationMode cfg raw' blkHash blkNo ls
-      CC.ABOBBoundary raw' -> applyABoundaryBlock        cfg raw'         blkNo ls
+      CC.ABOBBlock    raw' -> applyABlock byronOpts cfg raw' blkHash blkNo ls
+      CC.ABOBBoundary raw' -> applyABoundaryBlock   cfg raw'         blkNo ls
   where
     blkNo :: BlockNo
     blkNo = blockNo blk
 
+    byronOpts =
+      CC.fromBlockValidationMode $ case doValidation of
+        STS.ValidateAll        -> CC.BlockValidation
+        STS.ValidateNone       -> CC.NoBlockValidation
+        STS.ValidateSuchThat _ -> CC.BlockValidation
+
 applyABlock :: CC.ValidationMode
             -> Gen.Config
             -> CC.ABlock ByteString

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

@@ -10,8 +10,10 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -22,7 +24,6 @@
 module Ouroboros.Consensus.Shelley.Ledger.Ledger (
     LedgerState (..)
   , ShelleyBasedEra
-  , ShelleyLedgerError (..)
   , ShelleyTip (..)
   , ShelleyTransition (..)
   , Ticked (..)
@@ -62,7 +63,7 @@ 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           Control.Arrow (left, second)
 import qualified Control.Exception as Exception
 import           Control.Monad.Except
 import qualified Control.State.Transition.Extended as STS
@@ -90,24 +91,13 @@ 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, ProtoCrypto, envelopeChecks,
+                     mkHeaderView)
 import           Ouroboros.Consensus.Util ((..:))
 import           Ouroboros.Consensus.Util.CBOR (decodeWithOrigin,
                      encodeWithOrigin)
 import           Ouroboros.Consensus.Util.Versioned
 
-{-------------------------------------------------------------------------------
-  Ledger errors
--------------------------------------------------------------------------------}
-
-newtype ShelleyLedgerError era = BBodyError (SL.BlockTransitionError era)
-  deriving (Generic)
-
-deriving instance ShelleyBasedEra era => Eq   (ShelleyLedgerError era)
-deriving instance ShelleyBasedEra era => Show (ShelleyLedgerError era)
-
-instance ShelleyBasedEra era => NoThunks (ShelleyLedgerError era)
-
 {-------------------------------------------------------------------------------
   Config
 -------------------------------------------------------------------------------}
@@ -275,16 +265,16 @@ untickedShelleyLedgerTipPoint ::
 untickedShelleyLedgerTipPoint = shelleyTipToPoint . untickedShelleyLedgerTip
 
 instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era)) where
-  type LedgerErr (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerError era
+  type LedgerErr (LedgerState (ShelleyBlock proto era)) = SL.BlockTransitionError era
 
   type AuxLedgerEvent (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerEvent era
 
-  applyChainTickLedgerResult cfg slotNo ShelleyLedgerState{
+  applyChainTickLedgerResult evs cfg slotNo ShelleyLedgerState{
                                 shelleyLedgerTip
                               , shelleyLedgerState
                               , shelleyLedgerTransition
                               } =
-      swizzle appTick <&> \l' ->
+     appTick globals shelleyLedgerState slotNo <&> \l' ->
       TickedShelleyLedgerState {
           untickedShelleyLedgerTip =
             shelleyLedgerTip
@@ -302,22 +292,14 @@ instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era))
       ei :: EpochInfo Identity
       ei = SL.epochInfoPure globals
 
-      swizzle (l, events) =
-          LedgerResult {
-              lrEvents = map ShelleyLedgerEventTICK events
-            , lrResult = l
-            }
-
       appTick =
-        SL.applyTickOpts
-          STS.ApplySTSOpts {
-              asoAssertions = STS.globalAssertionPolicy
-            , asoValidation = STS.ValidateAll
-            , asoEvents     = STS.EPReturn
-            }
-          globals
-          shelleyLedgerState
-          slotNo
+        uncurry (flip LedgerResult) ..: case evs of
+          ComputeLedgerEvents ->
+            second (map ShelleyLedgerEventTICK) ..:
+              applyTick STS.EPReturn
+          OmitLedgerEvents ->
+            (,[]) ..: applyTickNoEvents
+
 
 -- | All events emitted by the Shelley ledger API
 data ShelleyLedgerEvent era =
@@ -326,6 +308,54 @@ data ShelleyLedgerEvent era =
     -- | An event emitted during the chain tick
   | ShelleyLedgerEventTICK  (STS.Event (Core.EraRule "TICK"  era))
 
+--------------------------------------------------------------------------------
+--  ↓↓↓ REMOVE ↓↓↓
+--
+-- This code comes from https://github.com/IntersectMBO/cardano-ledger/pull/4889
+-- and must be removed before merging!!
+--------------------------------------------------------------------------------
+
+applyTickNoEvents ::
+  SL.Globals ->
+  SL.NewEpochState era ->
+  SlotNo ->
+  SL.NewEpochState era
+applyTickNoEvents = undefined
+
+applyTick ::
+  STS.SingEP ep ->
+  SL.Globals ->
+  SL.NewEpochState era ->
+  SlotNo ->
+  (SL.NewEpochState era, [STS.Event (Core.EraRule "TICK" era)])
+applyTick = undefined
+
+applyBlockEither ::
+  -- IMPORTANT: I had to add this proto parameter. It won't be needed because
+  -- the ledger removed the argument to BHeaderView, so whoever integrates this
+  -- must remove the Proxy from the calls below.
+  Proxy proto ->
+  STS.SingEP ep ->
+  STS.ValidationPolicy ->
+  SL.Globals ->
+  SL.NewEpochState era ->
+  SL.Block (SL.BHeaderView (ProtoCrypto proto)) era ->
+  Either (SL.BlockTransitionError era) (SL.NewEpochState era, [STS.Event (Core.EraRule "BBODY" era)])
+applyBlockEither = undefined
+
+applyBlockEitherNoEvents ::
+  Proxy proto ->
+  STS.ValidationPolicy ->
+  SL.Globals ->
+  SL.NewEpochState era ->
+  SL.Block (SL.BHeaderView (ProtoCrypto proto)) era ->
+  Either (SL.BlockTransitionError era) (SL.NewEpochState era)
+applyBlockEitherNoEvents = undefined
+
+--------------------------------------------------------------------------------
+-- ↑↑↑ REMOVE ↑↑↑
+--------------------------------------------------------------------------------
+
 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
@@ -338,45 +368,24 @@ instance ShelleyCompatible proto era
   --    - 'updateChainDepState': executes the @PRTCL@ transition
   -- + 'applyBlockLedgerResult': executes the @BBODY@ transition
   --
-  applyBlockLedgerResult =
-      applyHelper (swizzle ..: appBlk)
+  applyBlockLedgerResultWithValidation doValidate evs =
+      liftEither ..: applyHelper appBlk
     where
-      swizzle m =
-        withExcept BBodyError m <&> \(l, events) ->
-          LedgerResult {
-              lrEvents = map ShelleyLedgerEventBBODY events
-            , lrResult = l
-            }
-
       -- Apply the BBODY transition using the ticked state
       appBlk =
-        SL.applyBlockOpts
-          STS.ApplySTSOpts {
-              asoAssertions = STS.globalAssertionPolicy
-            , asoValidation = STS.ValidateAll
-            , asoEvents     = STS.EPReturn
-            }
+        fmap (uncurry (flip LedgerResult)) ..: case evs of
+          ComputeLedgerEvents ->
+              fmap (second (map ShelleyLedgerEventBBODY)) ..:
+                applyBlockEither (Proxy @proto) STS.EPReturn doValidate
+          OmitLedgerEvents ->
+              fmap (,[]) ..:
+                applyBlockEitherNoEvents (Proxy @proto) doValidate
+
+
+  applyBlockLedgerResult = defaultApplyBlockLedgerResult
 
   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
-                }
+    defaultReapplyBlockLedgerResult (\err -> Exception.throw $! ShelleyReapplyException @era err)
 
 data ShelleyReapplyException =
   forall era. Show (SL.BlockTransitionError era)
@@ -388,19 +397,23 @@ instance Show ShelleyReapplyException where
 instance Exception.Exception ShelleyReapplyException where
 
 applyHelper ::
-     (ShelleyCompatible proto era, Monad m)
+     ShelleyCompatible proto era
   => (   SL.Globals
       -> SL.NewEpochState era
       -> SL.Block (SL.BHeaderView (EraCrypto era)) era
-      -> m (LedgerResult
+      -> Either
+           (SL.BlockTransitionError era)
+           (LedgerResult
               (LedgerState (ShelleyBlock proto era))
               (SL.NewEpochState era)
            )
      )
   -> LedgerConfig (ShelleyBlock proto era)
   -> ShelleyBlock proto era
   -> Ticked (LedgerState (ShelleyBlock proto era))
-  -> m (LedgerResult
+  -> Either
+       (SL.BlockTransitionError era)
+       (LedgerResult
           (LedgerState (ShelleyBlock proto era))
           (LedgerState (ShelleyBlock proto era)))
 applyHelper f cfg blk TickedShelleyLedgerState{

ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs

@@ -122,7 +122,7 @@ exampleBlock =
       cfg
       (BlockNo 1)
       (SlotNo 1)
-      (applyChainTick ledgerConfig (SlotNo 1) ledgerStateAfterEBB)
+      (applyChainTick OmitLedgerEvents ledgerConfig (SlotNo 1) ledgerStateAfterEBB)
       [ValidatedByronTx exampleGenTx]
       (fakeMkIsLeader leaderCredentials)
   where
@@ -180,14 +180,14 @@ emptyLedgerState = ByronLedgerState {
 
 ledgerStateAfterEBB :: LedgerState ByronBlock
 ledgerStateAfterEBB =
-      reapplyLedgerBlock ledgerConfig exampleEBB
-    . applyChainTick ledgerConfig (SlotNo 0)
+      reapplyLedgerBlock OmitLedgerEvents ledgerConfig exampleEBB
+    . applyChainTick OmitLedgerEvents ledgerConfig (SlotNo 0)
     $ emptyLedgerState
 
 exampleLedgerState :: LedgerState ByronBlock
 exampleLedgerState =
-      reapplyLedgerBlock ledgerConfig exampleBlock
-    . applyChainTick ledgerConfig (SlotNo 1)
+      reapplyLedgerBlock OmitLedgerEvents ledgerConfig exampleBlock
+    . applyChainTick OmitLedgerEvents ledgerConfig (SlotNo 1)
     $ ledgerStateAfterEBB
 
 exampleHeaderState :: HeaderState ByronBlock