Cleanup and comments on mempool implementation

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

@@ -21,6 +21,9 @@ import           Data.Either (isRight)
 import           Data.List (foldl', isSuffixOf, nub, partition, sort)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import qualified Data.List.NonEmpty as NE
+import           Data.Map (Map)
+import qualified Data.Map as Map
 import           Data.Maybe (mapMaybe)
 import qualified Data.Set as Set
 import           Data.Word
@@ -61,37 +64,37 @@ import           Test.Util.QuickCheck (elements)
 tests :: TestTree
 tests = testGroup "Mempool"
   [ testGroup "TxSeq"
-      [ testProperty "lookupByTicketNo complete"           prop_TxSeq_lookupByTicketNo_complete
-      , testProperty "lookupByTicketNo sound"              prop_TxSeq_lookupByTicketNo_sound
-      , testProperty "splitAfterTxSize"                    prop_TxSeq_splitAfterTxSize
-      , testProperty "splitAfterTxSizeSpec"                prop_TxSeq_splitAfterTxSizeSpec
+      [ testProperty "lookupByTicketNo complete"                prop_TxSeq_lookupByTicketNo_complete
+      , testProperty "lookupByTicketNo sound"                   prop_TxSeq_lookupByTicketNo_sound
+      , testProperty "splitAfterTxSize"                         prop_TxSeq_splitAfterTxSize
+      , testProperty "splitAfterTxSizeSpec"                     prop_TxSeq_splitAfterTxSizeSpec
       ]
-  , testProperty "snapshotTxs == snapshotTxsAfter zeroIdx" prop_Mempool_snapshotTxs_snapshotTxsAfter
-  , testProperty "valid added txs == getTxs"               prop_Mempool_addTxs_getTxs
-  , testProperty "addTxs [..] == forM [..] addTxs"         prop_Mempool_semigroup_addTxs
-  , testProperty "result of addTxs"                        prop_Mempool_addTxs_result
-  , testProperty "Invalid transactions are never added"    prop_Mempool_InvalidTxsNeverAdded
-  , testProperty "result of getCapacity"                   prop_Mempool_getCapacity
-  , testProperty "Mempool capacity implementation"         prop_Mempool_Capacity
-  , testProperty "Added valid transactions are traced"     prop_Mempool_TraceValidTxs
-  , testProperty "Rejected invalid txs are traced"         prop_Mempool_TraceRejectedTxs
-  , testProperty "Removed invalid txs are traced"          prop_Mempool_TraceRemovedTxs
-  , testProperty "idx consistency"                         prop_Mempool_idx_consistency
-  , testProperty "removeTxs"                               prop_Mempool_removeTxs
-  , testProperty "removeTxs [..] == forM [..] removeTxs"   prop_Mempool_semigroup_removeTxs
+  , testProperty "snapshotTxs == snapshotTxsAfter zeroTicketNo" prop_Mempool_snapshotTxs_snapshotTxsAfter
+  , testProperty "valid added txs == getTxs"                    prop_Mempool_addTxs_getTxs
+  , testProperty "addTxs [..] == forM [..] addTxs"              prop_Mempool_semigroup_addTxs
+  , testProperty "result of addTxs"                             prop_Mempool_addTxs_result
+  , testProperty "Invalid transactions are never added"         prop_Mempool_InvalidTxsNeverAdded
+  , testProperty "result of getCapacity"                        prop_Mempool_getCapacity
+  , testProperty "Mempool capacity implementation"              prop_Mempool_Capacity
+  , testProperty "Added valid transactions are traced"          prop_Mempool_TraceValidTxs
+  , testProperty "Rejected invalid txs are traced"              prop_Mempool_TraceRejectedTxs
+  , testProperty "Removed invalid txs are traced"               prop_Mempool_TraceRemovedTxs
+  , testProperty "idx consistency"                              prop_Mempool_idx_consistency
+  , testProperty "removeTxs"                                    prop_Mempool_removeTxs
+  , testProperty "removeTxs [..] == forM [..] removeTxs"        prop_Mempool_semigroup_removeTxs
   ]
 
 {-------------------------------------------------------------------------------
   Mempool Implementation Properties
 -------------------------------------------------------------------------------}
 
--- | Test that @snapshotTxs == snapshotTxsAfter zeroIdx@.
+-- | Test that @snapshotTxs == snapshotTxsAfter zeroTicketNo@.
 prop_Mempool_snapshotTxs_snapshotTxsAfter :: TestSetup -> Property
 prop_Mempool_snapshotTxs_snapshotTxsAfter setup =
     withTestMempool setup $ \TestMempool { mempool } -> do
-      let Mempool { zeroIdx, getSnapshot } = mempool
+      let Mempool { getSnapshot } = mempool
       MempoolSnapshot { snapshotTxs, snapshotTxsAfter} <- atomically getSnapshot
-      return $ snapshotTxs === snapshotTxsAfter zeroIdx
+      return $ snapshotTxs === snapshotTxsAfter zeroTicketNo
 
 -- | Test that all valid transactions added to a 'Mempool' can be retrieved
 -- afterward.
@@ -162,7 +165,7 @@ prop_Mempool_removeTxs :: TestSetupWithTxInMempool -> Property
 prop_Mempool_removeTxs (TestSetupWithTxInMempool testSetup txToRemove) =
     withTestMempool testSetup $ \TestMempool { mempool } -> do
       let Mempool { removeTxs, getSnapshot } = mempool
-      removeTxs [txId txToRemove]
+      removeTxs $ NE.fromList [txId txToRemove]
       txsInMempoolAfter <- map fst . snapshotTxs <$> atomically getSnapshot
       return $ counterexample
         ("Transactions in the mempool after removing (" <>
@@ -174,11 +177,11 @@ prop_Mempool_removeTxs (TestSetupWithTxInMempool testSetup txToRemove) =
 prop_Mempool_semigroup_removeTxs :: TestSetupWithTxsInMempool -> Property
 prop_Mempool_semigroup_removeTxs (TestSetupWithTxsInMempool testSetup txsToRemove) =
   withTestMempool testSetup $ \TestMempool {mempool = mempool1} -> do
-  removeTxs mempool1 $ map txId txsToRemove
+  removeTxs mempool1 $ NE.map txId txsToRemove
   snapshot1 <- atomically (getSnapshot mempool1)
 
   return $ withTestMempool testSetup $ \TestMempool {mempool = mempool2} -> do
-    forM_ (map txId txsToRemove) (removeTxs mempool2 . (:[]))
+    forM_ (NE.map txId txsToRemove) (removeTxs mempool2 . (NE.:| []))
     snapshot2 <- atomically (getSnapshot mempool2)
 
     return $ counterexample
@@ -688,15 +691,15 @@ instance Arbitrary TestSetupWithTxInMempool where
     , tx' <- testInitialTxs testSetup'
     ]
 
-data TestSetupWithTxsInMempool = TestSetupWithTxsInMempool TestSetup [TestTx]
+data TestSetupWithTxsInMempool = TestSetupWithTxsInMempool TestSetup (NE.NonEmpty TestTx)
   deriving (Show)
 
 instance Arbitrary TestSetupWithTxsInMempool where
   arbitrary = do
     TestSetupWithTxs { testSetup } <-
       arbitrary `suchThat` (not . null . testInitialTxs . testSetup)
     txs <- sublistOf (testInitialTxs testSetup)
-    return $ TestSetupWithTxsInMempool testSetup txs
+    return $ TestSetupWithTxsInMempool testSetup $ NE.fromList txs
 
   -- TODO shrink
 
@@ -1128,16 +1131,17 @@ executeAction testMempool action = case action of
           False
 
     RemoveTxs txs -> do
-      removeTxs mempool (map txId txs)
+      let txs' = NE.fromList $ map txId txs
+      removeTxs mempool txs'
       tracedManuallyRemovedTxs <- expectTraceEvent $ \case
         TraceMempoolManuallyRemovedTxs txIds _ _ -> Just txIds
         _                                        -> Nothing
-      return $ if concat tracedManuallyRemovedTxs == map txId txs
+      return $ if concatMap NE.toList tracedManuallyRemovedTxs == map txId txs
         then property True
         else counterexample
           ("Expected a TraceMempoolManuallyRemovedTxs event for " <>
            condense txs <> " but got " <>
-           condense tracedManuallyRemovedTxs)
+           condense (map NE.toList tracedManuallyRemovedTxs))
           False
 
   where

ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs

@@ -1007,7 +1007,7 @@ runDB standalone@DB{..} cmd =
       -> ExtValidationError TestBlock
     annLedgerErr' = annLedgerErr
 
-    reader :: TypeOf_readDB m (ExtLedgerState TestBlock)
+    reader :: KeySetsReader m (ExtLedgerState TestBlock)
     reader rewoundTableKeySets = do
       backingStore <- readTVarIO dbBackingStore
       readKeySets backingStore rewoundTableKeySets

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

@@ -176,7 +176,8 @@ instance ( IsLedger (LedgerState  blk)
 
 instance (LedgerSupportsProtocol blk, TableStuff (LedgerState blk)) => TableStuff (ExtLedgerState blk) where
 
-  newtype LedgerTables (ExtLedgerState blk) mk = ExtLedgerStateTables (LedgerTables (LedgerState blk) mk)
+  newtype LedgerTables (ExtLedgerState blk) mk =
+    ExtLedgerStateTables { unExtLedgerStateTables :: LedgerTables (LedgerState blk) mk }
     deriving (Generic)
 
   projectLedgerTables (ExtLedgerState lstate _) =

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

@@ -31,6 +31,7 @@ module Ouroboros.Consensus.Mempool.API (
   , TxSizeInBytes
   ) where
 
+import qualified Data.List.NonEmpty as NE
 import           Data.Word (Word32)
 
 import           Ouroboros.Network.Protocol.TxSubmission2.Type (TxSizeInBytes)
@@ -149,10 +150,10 @@ data Mempool m blk idx = Mempool {
                           )
 
       -- | Manually remove the given transactions from the mempool.
-    , removeTxs      :: [GenTxId blk] -> m ()
+    , removeTxs      :: NE.NonEmpty (GenTxId blk) -> m ()
 
       -- | Sync the transactions in the mempool with the current ledger state
-      --  of the 'ChainDB'.
+      --  at the tip of the 'ChainDB'.
       --
       -- The transactions that exist within the mempool will be revalidated
       -- against the current ledger state. Transactions which are found to be
@@ -171,27 +172,31 @@ data Mempool m blk idx = Mempool {
       -- | Get a snapshot of the current mempool state. This allows for
       -- further pure queries on the snapshot.
       --
-      -- This doesn't look at the ledger state at all.
+      -- This doesn't look at the ledger state at all, i.e. it produces a
+      -- snapshot from the current InternalState of the mempool.
     , getSnapshot    :: STM m (MempoolSnapshot blk idx)
 
       -- | Get a snapshot of the mempool state that is valid with respect to
       -- the returned ledger state when it's ticked to the given slot.
       --
-      -- This returns the ledger state that was retrieved from the LedgerDB (for
-      -- ticking its ChainDepState to see if we have to forge), the ticked
-      -- ledger state that was used for mempool revalidation, and a snapshot of
-      -- the mempool. In particular given '(a, b, _)' as a result, 'b == tick
-      -- (ledgerState a)'.
+      -- This function returns the ledger state that was retrieved from the
+      -- LedgerDB (for ticking its ChainDepState to see if we have to forge),
+      -- the ticked ledger state that was used for mempool revalidation, and a
+      -- snapshot of the mempool. In particular given '(a, b, _)' as a result,
+      -- 'b == tick (ledgerState a)'.
       --
-      -- This does not update the state of the mempool.
+      -- This function returns 'Nothing' when the given point is not on
+      -- the current chain.
+      --
+      -- This does not update the internal state of the mempool.
     , getLedgerAndSnapshotFor ::
            Point blk
         -> SlotNo
         -> m (Maybe ( ExtLedgerState blk EmptyMK
                     , TickedLedgerState blk TrackingMK
                     , MempoolSnapshot blk idx
                     )
-             )
+             ) -- FIXME: don't we want to introduce a custom data type for this triple?
 
       -- | Get the mempool's capacity in bytes.
       --
@@ -209,10 +214,6 @@ data Mempool m blk idx = Mempool {
 
       -- | Return the post-serialisation size in bytes of a 'GenTx'.
     , getTxSize      :: GenTx blk -> TxSizeInBytes
-
-      -- | Represents the initial value at which the transaction ticket number
-      -- counter will start (i.e. the zeroth ticket number).
-    , zeroIdx        :: idx
     }
 
 {-------------------------------------------------------------------------------
@@ -353,7 +354,6 @@ data MempoolCapacityBytesOverride
     -- ^ Use the following 'MempoolCapacityBytes'.
   deriving (Eq, Show)
 
-
 -- | If no override is provided, calculate the default mempool capacity as 2x
 -- the current ledger's maximum transaction capacity of a block.
 computeMempoolCapacity
@@ -458,7 +458,7 @@ data TraceEventMempool blk
       MempoolSize
       -- ^ The current size of the Mempool.
   | TraceMempoolManuallyRemovedTxs
-      [GenTxId blk]
+      (NE.NonEmpty (GenTxId blk))
       -- ^ Transactions that have been manually removed from the Mempool.
       [Validated (GenTx blk)]
       -- ^ Previously valid transactions that are no longer valid because they