Investigation: failing faster when validating txs with missing inputs

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs

@@ -30,7 +30,7 @@ import qualified Cardano.Slotting.Slot as Slotting
 import qualified Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.FileWriting as F
 import qualified Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.SlotDataPoint as DP
 import           Cardano.Tools.DBAnalyser.CSV (computeAndWriteLine,
-                     writeHeaderLine)
+                     writeHeaderLine, writeLine)
 import           Cardano.Tools.DBAnalyser.HasAnalysis (HasAnalysis)
 import qualified Cardano.Tools.DBAnalyser.HasAnalysis as HasAnalysis
 import           Cardano.Tools.DBAnalyser.Types
@@ -45,6 +45,7 @@ import qualified Data.Map.Strict as Map
 import           Data.Singletons
 import           Data.Word (Word16, Word32, Word64)
 import qualified Debug.Trace as Debug
+import           GHC.Profiling
 import qualified GHC.Stats as GC
 import           NoThunks.Class (noThunks)
 import           Ouroboros.Consensus.Block
@@ -75,6 +76,7 @@ import qualified Ouroboros.Consensus.Util.IOLike as IOLike
 import           Ouroboros.Network.Protocol.LocalStateQuery.Type
 import           Ouroboros.Network.SizeInBytes
 import qualified System.IO as IO
+import qualified Text.Builder as Builder
 
 {-------------------------------------------------------------------------------
   Run the requested analysis
@@ -825,7 +827,10 @@ reproMempoolForge numBlks env = do
       )
       nullTracer
 
-    void $ processAll db registry GetBlock startFrom limit Nothing (process howManyBlocks mempool)
+    hdl <- IO.openFile "readd-txs.csv" IO.WriteMode
+    writeLine hdl "\t" ["txid", "dur", "mut", "gc"]
+    void $ processAll db registry GetBlock startFrom limit Nothing (process howManyBlocks hdl mempool)
+    IO.hFlush hdl
     pure Nothing
   where
     AnalysisEnv {
@@ -834,7 +839,6 @@ reproMempoolForge numBlks env = do
     , db
     , registry
     , limit
-    , tracer
     } = env
 
     lCfg :: LedgerConfig blk
@@ -855,14 +859,16 @@ reproMempoolForge numBlks env = do
 
     process
       :: ReproMempoolForgeHowManyBlks
+      -> IO.Handle
       -> Mempool.Mempool IO blk
       -> Maybe blk
       -> blk
       -> IO (Maybe blk)
-    process howManyBlocks mempool mbBlk blk' = (\() -> Just blk') <$> do
+    process howManyBlocks hdl mempool mbBlk blk' = (\() -> Just blk') <$> do
+      let txs = LedgerSupportsMempool.extractTxs blk'
       -- add this block's transactions to the mempool
       do
-        results <- Mempool.addTxs mempool $ LedgerSupportsMempool.extractTxs blk'
+        results <- Mempool.addTxs mempool txs
         let rejs =
               [ (LedgerSupportsMempool.txId tx, rej)
               | rej@(Mempool.MempoolTxRejected tx _) <- results
@@ -877,42 +883,33 @@ reproMempoolForge numBlks env = do
                    , "Consider trying again with `--repro-mempool-and-forge 1`."
                    ]
 
+      Foldable.for_ txs $ \tx -> do
+        let isInteresting = show (LedgerSupportsMempool.txId tx) `elem` intTxs
+              where
+                intTxs =
+                  [ "HardForkGenTxId {getHardForkGenTxId = S (S (S (S (S (S (Z (WrapGenTxId {unwrapGenTxId = txid: TxId {unTxId = SafeHash \"0dc72224c84ed853231c6a7790e9d4ac4e31dc13824779dedb59330e8b177804\"}})))))))}"
+                  , "HardForkGenTxId {getHardForkGenTxId = S (S (S (S (S (S (Z (WrapGenTxId {unwrapGenTxId = txid: TxId {unTxId = SafeHash \"681db1ffb477e9a52adafd8ce643eb01a6bceb5abc7ae4a503d76936c54feea0\"}})))))))}"
+                  ]
+        when isInteresting startProfTimer
+        (res, dur, mut, gc) <- timed $ Mempool.addTx mempool Mempool.AddTxForRemotePeer tx
+        when isInteresting stopProfTimer
+        case res of
+          Mempool.MempoolTxRejected {} -> pure ()
+          Mempool.MempoolTxAdded {}    -> fail "unexpected success"
+
+        writeLine hdl "\t"
+          [ Builder.string $ show $ LedgerSupportsMempool.txId tx
+          , Builder.decimal $ round @_ @Int $ dur * 1000000
+          , Builder.decimal $ mut
+          , Builder.decimal gc
+          ]
+
       let scrutinee = case howManyBlocks of
             ReproMempoolForgeOneBlk  -> Just blk'
             ReproMempoolForgeTwoBlks -> mbBlk
       case scrutinee of
         Nothing  -> pure ()
         Just blk -> do
-          LedgerDB.withPrivateTipForker ledgerDB $ \forker -> do
-            st <- IOLike.atomically $ LedgerDB.forkerGetLedgerState forker
-
-            -- time the suspected slow parts of the forge thread that created
-            -- this block
-            --
-            -- Primary caveat: that thread's mempool may have had more transactions in it.
-            let slot = blockSlot blk
-            (ticked, durTick, mutTick, gcTick) <- timed $ IOLike.evaluate $
-                applyChainTick lCfg slot (ledgerState st)
-            ((), durSnap, mutSnap, gcSnap) <- timed $ do
-                snap <- Mempool.getSnapshotFor mempool slot ticked $
-                  fmap castLedgerTables . LedgerDB.forkerReadTables forker . castLedgerTables
-
-                pure $ length (Mempool.snapshotTxs snap) `seq` Mempool.snapshotStateHash snap `seq` ()
-
-            let sizes = HasAnalysis.blockTxSizes blk
-            traceWith tracer $
-              BlockMempoolAndForgeRepro
-                (blockNo blk)
-                slot
-                (length sizes)
-                (sum sizes)
-                durTick
-                mutTick
-                gcTick
-                durSnap
-                mutSnap
-                gcSnap
-
           -- advance the ledger state to include this block
           --
           -- TODO We could inline/reuse parts of the IsLedger ExtLedgerState

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs

@@ -35,6 +35,7 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as LedgerDB.V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as LedgerDB.V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as LedgerDB.V2
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as LedgerDB.V2
 import           Ouroboros.Consensus.Util.Args
 import           Ouroboros.Consensus.Util.IOLike
@@ -68,8 +69,17 @@ openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs=LedgerDB.Led
       emptyStream
       genesisPoint
   pure (ledgerDB, intLedgerDB)
-openLedgerDB LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs=LedgerDB.LedgerDbFlavorArgsV2{}} =
-  error "not defined for v2, use v1 instead for now!"
+openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs=LedgerDB.LedgerDbFlavorArgsV2 args} = do
+  (ledgerDB, _, intLedgerDB) <-
+    LedgerDB.openDBInternal
+      lgrDbArgs
+      (LedgerDB.V2.mkInitDb
+        lgrDbArgs
+        args
+        (\_ -> error "no replay"))
+      emptyStream
+      genesisPoint
+  pure (ledgerDB, intLedgerDB)
 
 emptyStream :: Applicative m => ImmutableDB.StreamAPI m blk a
 emptyStream = ImmutableDB.StreamAPI $ \_ k -> k $ Right $ pure ImmutableDB.NoMoreItems

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs

@@ -38,8 +38,8 @@ import           Control.Monad.Trans.Except (runExcept)
 import           Control.Tracer
 import qualified Data.Foldable as Foldable
 import qualified Data.List.NonEmpty as NE
-import           Data.Set (Set)
-import qualified Data.Set as Set
+import           Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
 import           Data.Typeable
 import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Block
@@ -80,7 +80,7 @@ data InternalState blk = IS {
       -- 'MempoolSnapshot' (see 'snapshotHasTx').
       --
       -- This should always be in-sync with the transactions in 'isTxs'.
-    , isTxIds        :: !(Set (GenTxId blk))
+    , isTxIds        :: !(Map (GenTxId blk) (Validated (GenTx blk)))
 
       -- | The cached ledger state after applying the transactions in the
       -- Mempool against the chain's ledger state. New transactions will be
@@ -150,7 +150,7 @@ initInternalState ::
   -> InternalState blk
 initInternalState capacityOverride lastTicketNo cfg slot st = IS {
       isTxs          = TxSeq.Empty
-    , isTxIds        = Set.empty
+    , isTxIds        = Map.empty
     , isLedgerState  = st
     , isTip          = castPoint $ getTip st
     , isSlotNo       = slot
@@ -279,17 +279,25 @@ validateNewTransaction
      , InternalState blk
      )
 validateNewTransaction cfg wti tx txsz st is =
-    case runExcept (applyTx cfg wti isSlotNo tx st) of
+    case runExcept res of
       Left err         -> ( Left err, is )
       Right (st', vtx) ->
         ( Right vtx
         , is { isTxs          = isTxs :> TxTicket vtx nextTicketNo txsz
-             , isTxIds        = Set.insert (txId tx) isTxIds
+             , isTxIds        = Map.insert (txId tx) vtx isTxIds
              , isLedgerState  = prependDiffs isLedgerState st'
              , isLastTicketNo = nextTicketNo
              }
         )
   where
+    res = case Map.lookup (txId tx) isTxIds of
+      Nothing  -> applyTx cfg wti isSlotNo tx st
+      Just vtx -> do
+        _ <- reapplyTx cfg isSlotNo vtx st
+        -- that must have failed, since every tx must consume at least one
+        -- input and this one is necessarily a double-spend
+        pure $ error "unreachable"
+
     IS {
         isTxs
       , isTxIds
@@ -333,7 +341,7 @@ revalidateTxsFor capacityOverride cfg slot st values lastTicketNo txTickets =
   in RevalidateTxsResult
       (IS {
          isTxs          = TxSeq.fromList $ map unwrap val
-       , isTxIds        = Set.fromList $ map (txId . txForgetValidated . fst) val
+       , isTxIds        = Map.fromList $ map (\(vtx, _) -> (txId $ txForgetValidated vtx, vtx)) val
        , isLedgerState  = trackingToDiffs st'
        , isTip          = castPoint $ getTip st
        , isSlotNo       = slot
@@ -394,7 +402,7 @@ snapshotFromIS is = MempoolSnapshot {
   implSnapshotHasTx :: InternalState blk
                     -> GenTxId blk
                     -> Bool
-  implSnapshotHasTx IS{isTxIds} = flip Set.member isTxIds
+  implSnapshotHasTx IS{isTxIds} = flip Map.member isTxIds
 
   implSnapshotGetMempoolSize :: InternalState blk
                              -> MempoolSize