consensus: add WhetherToIntevene to applyTx

We introduce this argument so that we can use slightly different rules when
validating transactions depending on their source. In particular, we can reject
an invalid script submitted by the local wallet, thereby preventing the local
wallet from being punished for it. This is not something we want to do for
transactions from peers. The new flag controls eg whether we intervene in this
way.

ouroboros-consensus-byron-test/test/Test/ThreadNet/DualByron.hs

@@ -276,6 +276,7 @@ instance TxGen DualByronBlock where
           tx <- genTx cfg st
           case runExcept $ applyTx
                              (configLedger cfg)
+                             DoNotIntervene
                              curSlotNo
                              tx
                              st of

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

@@ -130,7 +130,7 @@ instance LedgerSupportsMempool ByronBlock where
     where
       tx' = toMempoolPayload tx
 
-  applyTx cfg slot tx st =
+  applyTx cfg _wti slot tx st =
           (\st' -> (st', ValidatedByronTx tx))
       <$> applyByronGenTx validationMode cfg slot tx st
     where

ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs

@@ -41,7 +41,7 @@ newtype instance Validated (GenTx ByronSpecBlock) = ValidatedByronSpecGenTx {
 type instance ApplyTxErr ByronSpecBlock = ByronSpecGenTxErr
 
 instance LedgerSupportsMempool ByronSpecBlock where
-  applyTx cfg _slot tx (TickedByronSpecLedgerState tip st) =
+  applyTx cfg _wti _slot tx (TickedByronSpecLedgerState tip st) =
         fmap (\st' ->
                ( TickedByronSpecLedgerState tip st'
                , ValidatedByronSpecGenTx tx
@@ -52,7 +52,7 @@ instance LedgerSupportsMempool ByronSpecBlock where
   -- Byron spec doesn't have multiple validation modes
   reapplyTx cfg slot vtx st =
         fmap fst
-      $ applyTx cfg slot (forgetValidatedByronSpecGenTx vtx) st
+      $ applyTx cfg DoNotIntervene slot (forgetValidatedByronSpecGenTx vtx) st
 
   -- Dummy values, as these are not used in practice.
   maxTxCapacity = const maxBound

ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs

@@ -428,7 +428,7 @@ type instance ApplyTxErr (SimpleBlock c ext) = MockError (SimpleBlock c ext)
 
 instance MockProtocolSpecific c ext
       => LedgerSupportsMempool (SimpleBlock c ext) where
-  applyTx _cfg slot tx st = do
+  applyTx _cfg _wti slot tx st = do
       st' <- updateSimpleUTxO slot tx st
       return (st', ValidatedSimpleGenTx tx)
   reapplyTx _cfg slot vtx st =

ouroboros-consensus-shelley-test/src/Test/ThreadNet/TxGen/Shelley.hs

@@ -83,7 +83,7 @@ instance HashAlgorithm h => TxGen (ShelleyBlock (MockShelley h)) where
         mbTx <- genTx cfg curSlotNo st stgeGenEnv
         case mbTx of
           Nothing -> return (reverse acc)  -- cannot afford more transactions
-          Just tx -> case runExcept $ fst <$> applyTx lcfg curSlotNo tx st of
+          Just tx -> case runExcept $ fst <$> applyTx lcfg DoNotIntervene curSlotNo tx st of
               -- We don't mind generating invalid transactions
               Left  _   -> go (tx:acc) (n - 1) st
               Right st' -> go (tx:acc) (n - 1) st'

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Eras.hs

@@ -42,6 +42,7 @@ import           Cardano.Ledger.Allegra.Translation ()
 import           Cardano.Ledger.Alonzo (AlonzoEra)
 import qualified Cardano.Ledger.Alonzo.PParams as Alonzo
 import qualified Cardano.Ledger.Alonzo.Translation as Alonzo
+import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
 import           Cardano.Ledger.BaseTypes
 import qualified Cardano.Ledger.Core as Core
 import           Cardano.Ledger.Crypto (StandardCrypto)
@@ -137,18 +138,30 @@ class ( SL.ShelleyBasedEra era
   -- etc.
   shelleyBasedEraName :: proxy era -> Text
 
+  scriptsWereOK :: proxy era -> Core.TxInBlock era -> Bool
+
 instance SL.PraosCrypto c => ShelleyBasedEra (ShelleyEra c) where
   shelleyBasedEraName _ = "Shelley"
 
+  scriptsWereOK _ _ = True
+
 instance SL.PraosCrypto c => ShelleyBasedEra (AllegraEra c) where
   shelleyBasedEraName _ = "Allegra"
 
+  scriptsWereOK _ _ = True
+
 instance SL.PraosCrypto c => ShelleyBasedEra (MaryEra c) where
   shelleyBasedEraName _ = "Mary"
 
+  scriptsWereOK _ _ = True
+
 instance SL.PraosCrypto c => ShelleyBasedEra (AlonzoEra c) where
   shelleyBasedEraName _ = "Alonzo"
 
+  scriptsWereOK _ vtx = b
+    where
+      Alonzo.IsValidating b = Alonzo.isValidating vtx
+
 {-------------------------------------------------------------------------------
   TxInBlock wrapper
 -------------------------------------------------------------------------------}

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

@@ -29,7 +29,7 @@ module Ouroboros.Consensus.Shelley.Ledger.Mempool (
   , perTxOverhead
   ) where
 
-import           Control.Monad.Except (Except)
+import           Control.Monad.Except (Except, throwError)
 import           Control.Monad.Identity (Identity (..))
 import           Data.Foldable (toList)
 import           Data.Typeable (Typeable)
@@ -58,7 +58,7 @@ import qualified Cardano.Ledger.Era as SL (Crypto, TxInBlock, TxSeq, fromTxSeq)
 import qualified Shelley.Spec.Ledger.API as SL
 import qualified Shelley.Spec.Ledger.UTxO as SL (txid)
 
-import           Ouroboros.Consensus.Shelley.Eras (EraCrypto)
+import           Ouroboros.Consensus.Shelley.Eras (EraCrypto, scriptsWereOK)
 import           Ouroboros.Consensus.Shelley.Ledger.Block
 import           Ouroboros.Consensus.Shelley.Ledger.Ledger
                      (ShelleyLedgerConfig (shelleyLedgerGlobals),
@@ -206,21 +206,27 @@ instance Show (GenTxId (ShelleyBlock era)) where
 applyShelleyTx :: forall era.
      ShelleyBasedEra era
   => LedgerConfig (ShelleyBlock era)
+  -> WhetherToIntervene
   -> SlotNo
   -> GenTx (ShelleyBlock era)
   -> TickedLedgerState (ShelleyBlock era)
   -> Except (ApplyTxErr (ShelleyBlock era))
        ( TickedLedgerState (ShelleyBlock era)
        , Validated (GenTx (ShelleyBlock era))
        )
-applyShelleyTx cfg slot (ShelleyTx _ tx) st = do
+applyShelleyTx cfg wti slot (ShelleyTx _ tx) st = do
     (mempoolState', vtx) <-
        SL.applyTx
          (shelleyLedgerGlobals cfg)
          (SL.mkMempoolEnv   innerSt slot)
          (SL.mkMempoolState innerSt)
          tx
 
+    case wti of
+      Intervene | not (scriptsWereOK @era Proxy vtx) ->
+        throwError $ SL.ApplyTxError []   -- TODO what to put in this list?
+      _ -> pure ()
+
     let st' = set theLedgerLens mempoolState' st
 
     pure (st', mkShelleyValidatedTx vtx)

ouroboros-consensus-test/src/Test/ThreadNet/Network.hs

@@ -592,7 +592,7 @@ runThreadNetwork systemTime ThreadNetworkArgs
     forkCrucialTxs clock s0 registry unblockForge lcfg getLdgr mempool txs0 =
       void $ forkLinkedThread registry "crucialTxs" $ do
         let wouldBeValid slot st tx =
-                isRight $ Exc.runExcept $ applyTx lcfg slot tx st
+                isRight $ Exc.runExcept $ applyTx lcfg DoNotIntervene slot tx st
 
             checkSt slot snap =
                 any (wouldBeValid slot (snapshotLedgerState snap)) txs0

ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/A.hs

@@ -216,7 +216,7 @@ instance ApplyBlock (LedgerState BlockA) BlockA where
   applyLedgerBlock cfg blk =
         fmap setTip
       . repeatedlyM
-          (fmap fst .: applyTx cfg (blockSlot blk))
+          (fmap fst .: applyTx cfg DoNotIntervene (blockSlot blk))
           (blkA_body blk)
     where
       setTip :: TickedLedgerState BlockA -> LedgerState BlockA
@@ -313,12 +313,12 @@ newtype instance Validated (GenTx BlockA) = ValidatedGenTxA { forgetValidatedGen
 type instance ApplyTxErr BlockA = Void
 
 instance LedgerSupportsMempool BlockA where
-  applyTx _ sno tx@(TxA _ payload) (TickedLedgerStateA st) =
+  applyTx _ _wti sno tx@(TxA _ payload) (TickedLedgerStateA st) =
       case payload of
         InitiateAtoB -> do
           return (TickedLedgerStateA $ st { lgrA_transition = Just sno }, ValidatedGenTxA tx)
 
-  reapplyTx cfg slot = fmap fst .: (applyTx cfg slot . forgetValidatedGenTxA)
+  reapplyTx cfg slot = fmap fst .: (applyTx cfg DoNotIntervene slot . forgetValidatedGenTxA)
 
   maxTxCapacity _ = maxBound
   txInBlockSize _ = 0

ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/B.hs

@@ -257,7 +257,7 @@ data instance Validated (GenTx BlockB)
 type instance ApplyTxErr BlockB = Void
 
 instance LedgerSupportsMempool BlockB where
-  applyTx   = \_ _ tx -> case tx of {}
+  applyTx   = \_ _ _wti tx -> case tx of {}
   reapplyTx = \_ _ vtx -> case vtx of {}
 
   maxTxCapacity _ = maxBound

ouroboros-consensus-test/test-consensus/Test/Consensus/Mempool.hs

@@ -212,7 +212,7 @@ prop_Mempool_Capacity (MempoolCapTestSetup testSetupWithTxs) =
     capacity <- atomically (getCapacity mempool)
     curSize <- msNumBytes . snapshotMempoolSize <$>
       atomically (getSnapshot mempool)
-    res@(processed, unprocessed) <- tryAddTxs mempool (map fst txsToAdd)
+    res@(processed, unprocessed) <- tryAddTxs mempool DoNotIntervene (map fst txsToAdd)
     return $
       counterexample ("Initial size: " <> show curSize)    $
       classify (null processed)   "no transactions added"  $
@@ -826,7 +826,7 @@ withTestMempool setup@TestSetup {..} prop =
                            , snapshotSlotNo
                            } =
         case runExcept $ repeatedlyM
-               (fmap fst .: applyTx testLedgerConfig snapshotSlotNo)
+               (fmap fst .: applyTx testLedgerConfig DoNotIntervene snapshotSlotNo)
                txs
                (TickedSimpleLedgerState ledgerState) of
           Right _ -> property True

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

@@ -102,6 +102,7 @@ instance CanHardFork xs => LedgerSupportsMempool (HardForkBlock xs) where
       $ applyHelper
           ModeReapply
           cfg
+          DoNotIntervene
           slot
           (WrapValidatedGenTx vtx)
           tls
@@ -143,6 +144,7 @@ data ApplyResult xs blk = ApplyResult {
 applyHelper :: forall xs txIn. CanHardFork xs
   => ApplyHelperMode txIn
   -> LedgerConfig (HardForkBlock xs)
+  -> WhetherToIntervene
   -> SlotNo
   -> txIn (HardForkBlock xs)
   -> TickedLedgerState (HardForkBlock xs)
@@ -153,6 +155,7 @@ applyHelper :: forall xs txIn. CanHardFork xs
       )
 applyHelper mode
             HardForkLedgerConfig{..}
+            wti
             slot
             tx
             (TickedHardForkLedgerState transition hardForkState) =
@@ -235,7 +238,7 @@ applyHelper mode
         $ do
             let lcfg = unwrapLedgerConfig cfg
             (st', vtx) <- case mode of
-              ModeApply   -> applyTx lcfg slot tx' st
+              ModeApply   -> applyTx lcfg wti slot tx' st
               ModeReapply -> do
                   let vtx' = unwrapValidatedGenTx tx'
                   st' <- reapplyTx lcfg slot vtx' st

ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs

@@ -540,18 +540,21 @@ type instance ApplyTxErr (DualBlock m a) = DualGenTxErr m a
 
 instance Bridge m a => LedgerSupportsMempool (DualBlock m a) where
   applyTx DualLedgerConfig{..}
+          wti
           slot
           DualGenTx{..}
           TickedDualLedgerState{..} = do
       ((main', mainVtx), (aux', auxVtx)) <-
         agreeOnError DualGenTxErr (
             applyTx
               dualLedgerConfigMain
+              wti
               slot
               dualGenTxMain
               tickedDualLedgerStateMain
           , applyTx
               dualLedgerConfigAux
+              wti
               slot
               dualGenTxAux
               tickedDualLedgerStateAux

ouroboros-consensus/src/Ouroboros/Consensus/Ledger/SupportsMempool.hs

@@ -9,6 +9,7 @@ module Ouroboros.Consensus.Ledger.SupportsMempool (
   , LedgerSupportsMempool (..)
   , TxId
   , Validated
+  , WhetherToIntervene (..)
   ) where
 
 import           Control.Monad.Except
@@ -32,6 +33,28 @@ data family GenTx blk :: Type
 -- error type as when updating it with a block
 type family ApplyTxErr blk :: Type
 
+-- | A flag indicating whether the mempool should reject a valid-but-problematic
+-- transaction, in order to to protect its author from penalties etc
+--
+-- The primary example is that, as of the Alonzo ledger, a valid transaction can
+-- carry an invalid script. If a remote peer sends us such a transaction (over a
+-- Node-to-Node protocol), we include it in a block so that the ledger will
+-- penalize them them for the invalid script: they wasted our resources by
+-- forcing us to run the script to determine it's invalid. But if our local
+-- wallet -- which we trust by assumption -- sends us such a transaction (over a
+-- Node-to-Client protocol), we would be a good neighbor by rejecting that
+-- transaction: they must have made some sort of mistake, and we don't want the
+-- ledger to penalize them.
+data WhetherToIntervene
+  = DoNotIntervene
+    -- ^ We do not trust remote peers, so if a problematic-yet-valid transaction
+    -- arrives over NTN, we accept it; it will end up in a block and the ledger
+    -- will penalize them for it.
+  | Intervene
+    -- ^ We trust local clients, so if a problematic-yet-valid transaction
+    -- arrives over NTC, we reject it in order to avoid the ledger penalizing
+    -- them for it.
+
 class ( UpdateLedger blk
       , NoThunks (GenTx blk)
       , NoThunks (Validated (GenTx blk))
@@ -47,6 +70,7 @@ class ( UpdateLedger blk
 
   -- | Apply an unvalidated transaction
   applyTx :: LedgerConfig blk
+          -> WhetherToIntervene
           -> SlotNo -- ^ Slot number of the block containing the tx
           -> GenTx blk
           -> TickedLedgerState blk

ouroboros-consensus/src/Ouroboros/Consensus/Mempool/API.hs

@@ -22,6 +22,7 @@ module Ouroboros.Consensus.Mempool.API (
   , computeMempoolCapacity
     -- * Tracing support
   , TraceEventMempool (..)
+  , addLocalTxs
   , addTxs
     -- * Re-exports
   , TxSizeInBytes
@@ -64,11 +65,11 @@ import           Ouroboros.Consensus.Util.IOLike
 -- same result whether they process transactions one by one or all in one go, so
 -- this equality holds:
 --
--- > void (tryAddTxs txs) === forM_ txs (tryAddTxs . (:[]))
--- > void (trAddTxs [x,y]) === tryAddTxs x >> void (tryAddTxs y)
+-- > void (tryAddTxs wti txs) === forM_ txs (tryAddTxs wti . (:[]))
+-- > void (trAddTxs wti [x,y]) === tryAddTxs wti x >> void (tryAddTxs wti y)
 --
--- This shows that 'tryAddTxs' is an homomorphism from '++' and '>>', which
--- informally makes these operations "distributive".
+-- This shows that @'tryAddTxs' wti@ is an homomorphism from '++' and '>>',
+-- which informally makes these operations "distributive".
 data Mempool m blk idx = Mempool {
       -- | Add a bunch of transactions (oldest to newest)
       --
@@ -111,7 +112,7 @@ data Mempool m blk idx = Mempool {
       -- > let prj = \case
       -- >       MempoolTxAdded vtx        -> txForgetValidated vtx
       -- >       MempoolTxRejected tx _err -> tx
-      -- > (processed, toProcess) <- tryAddTxs txs
+      -- > (processed, toProcess) <- tryAddTxs wti txs
       -- > map prj processed ++ toProcess == txs
       --
       -- Note that previously valid transaction that are now invalid with
@@ -137,7 +138,8 @@ data Mempool m blk idx = Mempool {
       -- an index of transaction hashes that have been included on the
       -- blockchain.
       --
-      tryAddTxs      :: [GenTx blk]
+      tryAddTxs      :: WhetherToIntervene
+                     -> [GenTx blk]
                      -> m ( [MempoolAddTxResult blk]
                           , [GenTx blk]
                           )
@@ -229,14 +231,33 @@ isMempoolTxRejected _                   = False
 -- This function does not sync the Mempool contents with the ledger state in
 -- case the latter changes, it relies on the background thread to do that.
 --
--- See the necessary invariants on the Haddock for 'API.tryAddTxs'.
+-- See the necessary invariants on the Haddock for 'tryAddTxs'.
 addTxs
   :: forall m blk idx. MonadSTM m
   => Mempool m blk idx
   -> [GenTx blk]
   -> m [MempoolAddTxResult blk]
-addTxs mempool = \txs -> do
-    (processed, toAdd) <- tryAddTxs mempool txs
+addTxs mempool = addTxsHelper mempool DoNotIntervene
+
+-- | Variation on 'addTxs' that is more forgiving when possible
+--
+-- See 'Intervene'.
+addLocalTxs
+  :: forall m blk idx. MonadSTM m
+  => Mempool m blk idx
+  -> [GenTx blk]
+  -> m [MempoolAddTxResult blk]
+addLocalTxs mempool = addTxsHelper mempool Intervene
+
+-- | See 'addTxs'
+addTxsHelper
+  :: forall m blk idx. MonadSTM m
+  => Mempool m blk idx
+  -> WhetherToIntervene
+  -> [GenTx blk]
+  -> m [MempoolAddTxResult blk]
+addTxsHelper mempool wti = \txs -> do
+    (processed, toAdd) <- tryAddTxs mempool wti txs
     case toAdd of
       [] -> return processed
       _  -> go [processed] toAdd
@@ -259,7 +280,7 @@ addTxs mempool = \txs -> do
       -- It is possible that between the check above and the call below, other
       -- transactions are added, stealing our spot, but that's fine, we'll
       -- just recurse again without progress.
-      (added, toAdd) <- tryAddTxs mempool txs
+      (added, toAdd) <- tryAddTxs mempool wti txs
       go (added:acc) toAdd
 
 {-------------------------------------------------------------------------------