Merge #2788

2788: Inject transactions from past eras when forging a block r=mrBliss a=mrBliss

When the mempool verifies transactions, it injects transactions from past eras
into the current era. However, block production was not doing this.

Debugging this was made more difficult because the trace message that we were
outputting after creating a block (`TraceAdoptedBlock`) recorded the
transactions from the mempool, not the transactions that were actually included
in the block.

This means that injection now happens 3 times: once when we add transactions
into the mempool, once when we revalidate the mempool when we produce a block,
and then a third time when we actually construct the block. Streamlining this
however we can do at a later stage.

Co-authored-by: Thomas Winant <thomas@well-typed.com>

ouroboros-consensus-test/test-consensus/Test/Consensus/BlockchainTime/Simple.hs

@@ -184,9 +184,9 @@ model = \need (Schedule ss) ->
         = go n ss' (offset, nextSlot)
         | nextSlot >  prevSlot
         = (nextSlot :) <$> go (n - 1) ss' (offset, nextSlot)
-        -- If time moved back, but less than 2s, we don't throw an exception
-        | prevOffset - offset < 2
-        = go n ss' (prevOffset, prevSlot)
+        -- If time moved back, but not more than 2s, we don't throw an exception
+        | prevOffset - offset <= 2
+        = go n ss' (offset, prevSlot)
         -- If time moved back too much, we should see an exception
         | otherwise
         = throwError (prevSlot, nextSlot)

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

@@ -24,17 +24,21 @@ import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.TypeFamilyWrappers
+import           Ouroboros.Consensus.Util ((.:))
 import           Ouroboros.Consensus.Util.OptNP (OptNP (..), ViewOptNP (..))
 import qualified Ouroboros.Consensus.Util.OptNP as OptNP
 import           Ouroboros.Consensus.Util.SOP
 
 import           Ouroboros.Consensus.HardFork.Combinator.Abstract
 import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
 import           Ouroboros.Consensus.HardFork.Combinator.Basics
+import           Ouroboros.Consensus.HardFork.Combinator.InjectTxs
 import           Ouroboros.Consensus.HardFork.Combinator.Ledger (Ticked (..))
 import           Ouroboros.Consensus.HardFork.Combinator.Mempool
 import           Ouroboros.Consensus.HardFork.Combinator.Protocol
 import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
+import           Ouroboros.Consensus.HardFork.Combinator.Util.InPairs (InPairs)
+import qualified Ouroboros.Consensus.HardFork.Combinator.Util.InPairs as InPairs
 import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Match as Match
 
 -- | If we cannot forge, it's because the current era could not forge
@@ -298,45 +302,69 @@ hardForkForgeBlock blockForging
                    isLeader =
         fmap (HardForkBlock . OneEraBlock)
       $ hsequence
-      $ hizipWith4
+      $ hizipWith3
           forgeBlockOne
-          (distribTopLevelConfig ei cfg)
+          cfgs
           (OptNP.toNP blockForging)
-          -- Although we get a list with transactions that each could be from a
-          -- different era, we know they have been validated against the
-          -- 'LedgerState', which means they __must__ be from the same era.
-          (partition_NS (map (getOneEraGenTx . getHardForkGenTx) txs))
-          -- We know both NSs must be from the same era, because they were all
-          -- produced from the same 'BlockForging'. Unfortunately, we can't
-          -- enforce it statically.
-          (Match.mustMatchNS
-            "IsLeader"
-            (getOneEraIsLeader isLeader)
-            (State.tip ledgerState))
+      $ injectTxs (map (getOneEraGenTx . getHardForkGenTx) txs)
+      -- We know both NSs must be from the same era, because they were all
+      -- produced from the same 'BlockForging'. Unfortunately, we can't enforce
+      -- it statically.
+      $ Match.mustMatchNS
+          "IsLeader"
+          (getOneEraIsLeader isLeader)
+          (State.tip ledgerState)
   where
-    ei = State.epochInfoPrecomputedTransitionInfo
-           (hardForkLedgerConfigShape (configLedger cfg))
-           transition
-           ledgerState
+    cfgs = distribTopLevelConfig ei cfg
+    ei   = State.epochInfoPrecomputedTransitionInfo
+             (hardForkLedgerConfigShape (configLedger cfg))
+             transition
+             ledgerState
 
     missingBlockForgingImpossible :: EraIndex xs -> String
     missingBlockForgingImpossible eraIndex =
         "impossible: current era lacks block forging but we have an IsLeader proof "
         <> show eraIndex
 
+    injectTxs ::
+         [NS GenTx xs]
+      -> NS f xs
+      -> NS (Product f ([] :.: GenTx)) xs
+    injectTxs = noMismatches .: flip (matchTxsNS injTxs)
+      where
+        injTxs :: InPairs InjectTx xs
+        injTxs =
+            InPairs.requiringBoth
+              (hmap (WrapLedgerConfig . configLedger) cfgs)
+              hardForkInjectTxs
+
+        -- | We know the transactions must be valid w.r.t. the given ledger
+        -- state, the Mempool maintains that invariant. That means they are
+        -- either from the same era, or can be injected into that era.
+        noMismatches ::
+             ([Match.Mismatch GenTx f xs], NS (Product f ([] :.: GenTx)) xs)
+           -> NS (Product f ([] :.: GenTx)) xs
+        noMismatches ([], xs)   = xs
+        noMismatches (_errs, _) = error "unexpected unmatchable transactions"
+
     -- | Unwraps all the layers needed for SOP and call 'forgeBlock'.
     forgeBlockOne ::
          Index xs blk
       -> TopLevelConfig blk
       -> (Maybe :.: BlockForging m) blk
-      -> ([] :.: GenTx) blk
-      -> Product WrapIsLeader (Ticked :.: LedgerState) blk
+      -> Product
+           (Product
+              WrapIsLeader
+              (Ticked :.: LedgerState))
+           ([] :.: GenTx)
+           blk
       -> m blk
     forgeBlockOne index
                   cfg'
                   (Comp mBlockForging')
-                  (Comp txs')
-                  (Pair (WrapIsLeader isLeader') (Comp ledgerState')) =
+                  (Pair
+                    (Pair (WrapIsLeader isLeader') (Comp ledgerState'))
+                    (Comp txs')) =
         forgeBlock
           (fromMaybe
               (error (missingBlockForgingImpossible (eraIndexFromIndex index)))

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

@@ -1,12 +1,17 @@
-{-# LANGUAGE EmptyCase        #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs            #-}
-{-# LANGUAGE RecordWildCards  #-}
+{-# LANGUAGE EmptyCase           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators       #-}
 
 module Ouroboros.Consensus.HardFork.Combinator.InjectTxs (
     InjectTx(..)
   , cannotInjectTx
   , matchTx
+  , matchTxNS
+  , matchTxsNS
   ) where
 
 import           Data.Bifunctor
@@ -21,6 +26,7 @@ import           Ouroboros.Consensus.HardFork.Combinator.Util.Telescope
                      (Telescope (..))
 import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Telescope as Telescope
 import           Ouroboros.Consensus.Ledger.SupportsMempool
+import           Ouroboros.Consensus.Util (pairFst)
 
 {-------------------------------------------------------------------------------
   Match a transaction with a ledger
@@ -72,3 +78,48 @@ matchTx is tx =
           currentStart = currentStart
         , currentState = Pair tx' currentState
         }
+
+-- | Match transaction with an 'NS', attempting to inject where possible
+matchTxNS ::
+     InPairs InjectTx xs
+  -> NS GenTx xs
+  -> NS f xs
+  -> Either (Mismatch GenTx f xs)
+            (NS (Product GenTx f) xs)
+matchTxNS = go
+  where
+    go :: InPairs InjectTx xs
+       -> NS GenTx xs
+       -> NS f xs
+       -> Either (Mismatch GenTx f xs)
+                 (NS (Product GenTx f) xs)
+    go _            (Z x) (Z f) = Right $ Z (Pair x f)
+    go (PCons _ is) (S x) (S f) = bimap MS S $ go is x f
+    go _            (S x) (Z f) = Left $ MR x f
+    go (PCons i is) (Z x) (S f) =
+        case injectTxWith i x of
+          Nothing -> Left $ ML x f
+          Just x' -> bimap MS S $ go is (Z x') f
+
+-- | Match a list of transactions with an 'NS, attempting to inject where
+-- possible
+matchTxsNS ::
+     forall f xs. SListI xs
+  => InPairs InjectTx xs
+  -> NS f xs
+  -> [NS GenTx xs]
+  -> ([Mismatch GenTx f xs], NS (Product f ([] :.: GenTx)) xs)
+matchTxsNS is ns = go
+  where
+    go :: [NS GenTx xs]
+       -> ([Mismatch GenTx f xs], NS (Product f ([] :.: GenTx)) xs)
+    go []       = ([], hmap (`Pair` Comp []) ns)
+    go (tx:txs) =
+      let (mismatched, matched) = go txs
+      in case matchTxNS is tx matched of
+           Left  err      -> (hmap pairFst err : mismatched, matched)
+           Right matched' -> (mismatched, insert matched')
+
+    insert :: NS (Product GenTx (Product f ([] :.: GenTx))) xs
+           -> NS (Product f ([] :.: GenTx)) xs
+    insert = hmap $ \(Pair tx (Pair f (Comp txs))) -> Pair f (Comp (tx:txs))

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Util/Match.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE RankNTypes           #-}
 {-# LANGUAGE StandaloneDeriving   #-}
 {-# LANGUAGE TypeApplications     #-}
+{-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -90,6 +91,22 @@ matchTelescope = go
     go (Z hx) (TS _gx t) = Left $ ML hx (Telescope.tip t)
     go (S l)  (TZ fx)    = Left $ MR l fx
 
+{-------------------------------------------------------------------------------
+  SOP class instances for 'Mismatch'
+-------------------------------------------------------------------------------}
+
+type instance Prod    (Mismatch f)   = NP
+type instance SListIN (Mismatch f)   = SListI
+type instance AllN    (Mismatch f) c = All c
+
+instance HAp (Mismatch f) where
+  hap = go
+    where
+      go :: NP (g -.-> g') xs -> Mismatch f g xs -> Mismatch f g' xs
+      go (_ :* fs) (MS m)     = MS (go fs m)
+      go (_ :* fs) (ML fx gy) = ML fx (hap fs gy)
+      go (f :* _)  (MR fy gx) = MR fy (apFn f gx)
+
 {-------------------------------------------------------------------------------
   Utilities
 -------------------------------------------------------------------------------}

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

@@ -511,6 +511,13 @@ forkBlockForging maxTxCapacityOverride IS{..} blockForging =
           exitEarly
 
         -- We successfully produced /and/ adopted a block
+        --
+        -- NOTE: we are tracing the transactions we retrieved from the Mempool,
+        -- not the transactions actually /in the block/. They should always
+        -- match, if they don't, that would be a bug. Unfortunately, we can't
+        -- assert this here because the ability to extract transactions from a
+        -- block, i.e., the @HasTxs@ class, is not implementable by all blocks,
+        -- e.g., @DualBlock@.
         trace $ TraceAdoptedBlock currentSlot newBlock txs
 
     trace :: TraceForgeEvent blk -> WithEarlyExit m ()