{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}

-- | Tests for the "Ouroboros.Consensus.Storage.LeiosDB" interface.
--
-- These tests verify the semantics of the LeiosDbHandle operations for both
-- InMemory and SQLite implementations. Each test case uses a fresh database
-- to ensure isolation and serve as an (too optimistic) performance baseline.
module Test.Ouroboros.Storage.LeiosDB (tests) where

import Cardano.Slotting.Slot (SlotNo (..))
import Control.Concurrent.Class.MonadSTM.Strict
  ( atomically
  , readTChan
  , tryReadTChan
  )
import Control.DeepSeq (force)
import Control.Exception (bracket)
import Control.Monad (forM, forM_, replicateM, void)
import Control.Monad.Class.MonadTime.SI (diffTime, getMonotonicTime)
import Control.Tracer (nullTracer)
import qualified Data.ByteString as BS
import Data.Function ((&))
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Data.Time.Clock (DiffTime)
import qualified Data.Vector.Strict as V
import qualified Database.SQLite3 as SQL
import Ouroboros.Consensus.Leios.Types
  ( BytesSize
  , EbHash (..)
  , LeiosEb (..)
  , LeiosPoint (..)
  , TxHash (..)
  , encodeLeiosEbSize
  , leiosEbTxs
  )
import Ouroboros.Consensus.Storage.LeiosDB
  ( CompletedEbs
  , LeiosDbHandle (..)
  , LeiosDbReader (..)
  , LeiosDbWriter (..)
  , LeiosEbNotification (..)
  , Promise (..)
  , deleteDanglingTxs
  , newLeiosDBInMemory
  , truncateLeiosDbAfterSlot
  , withLeiosDBSQLite
  , withReader
  , withWriter
  )
import System.Directory (doesFileExist, removeDirectoryRecursive)
import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory)
import Test.QuickCheck
  ( Gen
  , Property
  , chooseInt
  , conjoin
  , counterexample
  , forAll
  , forAllBlind
  , forAllShrinkShow
  , ioProperty
  , shrink
  , sublistOf
  , tabulate
  , vector
  , (===)
  )
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))
import Test.Tasty.QuickCheck (testProperty)

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup [Char]
"LeiosDB" ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$
    (DbImpl -> [TestTree]) -> [TestTree]
forEachImplementation DbImpl -> [TestTree]
mkTestGroups
      [TestTree] -> [TestTree] -> [TestTree]
forall a. Semigroup a => a -> a -> a
<> [ [Char] -> [TestTree] -> TestTree
testGroup
             [Char]
"truncateLeiosDbAfterSlot"
             [ [Char] -> Assertion -> TestTree
testCase [Char]
"drops the EBs announced after the slot, with their bodies" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 ([Char] -> [Char] -> LeiosDbHandle IO -> Assertion) -> Assertion
forall a. ([Char] -> [Char] -> LeiosDbHandle IO -> IO a) -> IO a
withFreshSQLiteFile [Char] -> [Char] -> LeiosDbHandle IO -> Assertion
test_truncateDropsEbsAfterSlot
             , [Char] -> Assertion -> TestTree
testCase [Char]
"runs on the immutable partition, which has no ebsMissingTxs" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 ([Char] -> [Char] -> Assertion) -> Assertion
forall a. ([Char] -> [Char] -> IO a) -> IO a
withTempLeiosDbPaths [Char] -> [Char] -> Assertion
test_truncateImmutablePartition
             ]
         , [Char] -> [TestTree] -> TestTree
testGroup
             [Char]
"deleteDanglingTxs"
             [ [Char] -> Assertion -> TestTree
testCase [Char]
"keeps the txs an EB references" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 ([Char] -> [Char] -> LeiosDbHandle IO -> Assertion) -> Assertion
forall a. ([Char] -> [Char] -> LeiosDbHandle IO -> IO a) -> IO a
withFreshSQLiteFile [Char] -> [Char] -> LeiosDbHandle IO -> Assertion
test_deleteDanglingTxs
             ]
         , [Char] -> [TestTree] -> TestTree
testGroup
             [Char]
"file initialisation (SQLite)"
             [ [Char] -> Assertion -> TestTree
testCase [Char]
"handle creation applies both schemas" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 ([Char] -> [Char] -> Assertion) -> Assertion
forall a. ([Char] -> [Char] -> IO a) -> IO a
withTempLeiosDbPaths [Char] -> [Char] -> Assertion
test_schemaAtHandleCreation
             , [Char] -> Assertion -> TestTree
testCase [Char]
"zero-byte files get a schema" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 ([Char] -> [Char] -> Assertion) -> Assertion
forall a. ([Char] -> [Char] -> IO a) -> IO a
withTempLeiosDbPaths [Char] -> [Char] -> Assertion
test_zeroByteFilesGetSchema
             , [Char] -> Assertion -> TestTree
testCase [Char]
"reopening keeps the data" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
                 ([Char] -> [Char] -> Assertion) -> Assertion
forall a. ([Char] -> [Char] -> IO a) -> IO a
withTempLeiosDbPaths [Char] -> [Char] -> Assertion
test_reopenKeepsData
             ]
         ]

-- | Database creation strategy for different implementations.
data DbImpl
  = InMemory
  | SQLite

-- | A reader and a writer onto the same database -- what every caller outside
-- these tests now holds, since reads and writes no longer share a connection.
data RW = RW
  { RW -> LeiosDbReader IO
rwReader :: LeiosDbReader IO
  , RW -> LeiosDbWriter IO
rwWriter :: LeiosDbWriter IO
  }

withRW :: LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW :: forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db RW -> IO a
k = LeiosDbHandle IO -> (LeiosDbReader IO -> IO a) -> IO a
forall (m :: * -> *) a.
MonadThrow m =>
LeiosDbHandle m -> (LeiosDbReader m -> m a) -> m a
withReader LeiosDbHandle IO
db ((LeiosDbReader IO -> IO a) -> IO a)
-> (LeiosDbReader IO -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \LeiosDbReader IO
r -> LeiosDbHandle IO -> (LeiosDbWriter IO -> IO a) -> IO a
forall (m :: * -> *) a.
MonadThrow m =>
LeiosDbHandle m -> (LeiosDbWriter m -> m a) -> m a
withWriter LeiosDbHandle IO
db ((LeiosDbWriter IO -> IO a) -> IO a)
-> (LeiosDbWriter IO -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \LeiosDbWriter IO
w -> RW -> IO a
k (LeiosDbReader IO -> LeiosDbWriter IO -> RW
RW LeiosDbReader IO
r LeiosDbWriter IO
w)

-- Writes are awaited, so a read that follows one sees it.
rwInsertEbPoint :: RW -> LeiosPoint -> BytesSize -> IO ()
rwInsertEbPoint :: RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
rw LeiosPoint
point Word32
sz = Assertion -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$ Promise IO () -> Assertion
forall (m :: * -> *) a. Promise m a -> m a
await (Promise IO () -> Assertion) -> IO (Promise IO ()) -> Assertion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter IO
-> HasCallStack => LeiosPoint -> Word32 -> IO (Promise IO ())
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack => LeiosPoint -> Word32 -> m (Promise m ())
writeEbPoint (RW -> LeiosDbWriter IO
rwWriter RW
rw) LeiosPoint
point Word32
sz

rwInsertEbBody :: RW -> LeiosPoint -> LeiosEb -> IO CompletedEbs
rwInsertEbBody :: RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
rw LeiosPoint
point LeiosEb
eb = Promise IO [LeiosPoint] -> IO [LeiosPoint]
forall (m :: * -> *) a. Promise m a -> m a
await (Promise IO [LeiosPoint] -> IO [LeiosPoint])
-> IO (Promise IO [LeiosPoint]) -> IO [LeiosPoint]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter IO
-> HasCallStack =>
   LeiosPoint -> LeiosEb -> IO (Promise IO [LeiosPoint])
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack =>
   LeiosPoint -> LeiosEb -> m (Promise m [LeiosPoint])
writeEbBody (RW -> LeiosDbWriter IO
rwWriter RW
rw) LeiosPoint
point LeiosEb
eb

rwInsertTxs :: RW -> [(TxHash, BS.ByteString)] -> IO CompletedEbs
rwInsertTxs :: RW -> [(TxHash, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
rw [(TxHash, ByteString)]
txs = Promise IO [LeiosPoint] -> IO [LeiosPoint]
forall (m :: * -> *) a. Promise m a -> m a
await (Promise IO [LeiosPoint] -> IO [LeiosPoint])
-> IO (Promise IO [LeiosPoint]) -> IO [LeiosPoint]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter IO
-> HasCallStack =>
   [(TxHash, ByteString)] -> IO (Promise IO [LeiosPoint])
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack =>
   [(TxHash, ByteString)] -> m (Promise m [LeiosPoint])
writeTxs (RW -> LeiosDbWriter IO
rwWriter RW
rw) [(TxHash, ByteString)]
txs

rwScanEbPoints :: RW -> IO [(SlotNo, EbHash)]
rwScanEbPoints :: RW -> IO [(SlotNo, EbHash)]
rwScanEbPoints = LeiosDbReader IO -> IO [(SlotNo, EbHash)]
LeiosDbReader IO -> HasCallStack => IO [(SlotNo, EbHash)]
forall (m :: * -> *).
LeiosDbReader m -> HasCallStack => m [(SlotNo, EbHash)]
testScanEbPoints (LeiosDbReader IO -> IO [(SlotNo, EbHash)])
-> (RW -> LeiosDbReader IO) -> RW -> IO [(SlotNo, EbHash)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RW -> LeiosDbReader IO
rwReader

rwLookupEbBody :: RW -> EbHash -> IO [(TxHash, BytesSize)]
rwLookupEbBody :: RW -> EbHash -> IO [(TxHash, Word32)]
rwLookupEbBody = LeiosDbReader IO -> HasCallStack => EbHash -> IO [(TxHash, Word32)]
LeiosDbReader IO -> EbHash -> IO [(TxHash, Word32)]
forall (m :: * -> *).
LeiosDbReader m -> HasCallStack => EbHash -> m [(TxHash, Word32)]
lookupEbBody (LeiosDbReader IO -> EbHash -> IO [(TxHash, Word32)])
-> (RW -> LeiosDbReader IO)
-> RW
-> EbHash
-> IO [(TxHash, Word32)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RW -> LeiosDbReader IO
rwReader

rwLookupEbClosure :: RW -> EbHash -> IO (Maybe [(TxHash, BS.ByteString)])
rwLookupEbClosure :: RW -> EbHash -> IO (Maybe [(TxHash, ByteString)])
rwLookupEbClosure = LeiosDbReader IO
-> HasCallStack => EbHash -> IO (Maybe [(TxHash, ByteString)])
LeiosDbReader IO -> EbHash -> IO (Maybe [(TxHash, ByteString)])
forall (m :: * -> *).
LeiosDbReader m
-> HasCallStack => EbHash -> m (Maybe [(TxHash, ByteString)])
lookupEbClosure (LeiosDbReader IO -> EbHash -> IO (Maybe [(TxHash, ByteString)]))
-> (RW -> LeiosDbReader IO)
-> RW
-> EbHash
-> IO (Maybe [(TxHash, ByteString)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RW -> LeiosDbReader IO
rwReader

rwBatchRetrieveTxs :: RW -> EbHash -> [Int] -> IO [(Int, TxHash, Maybe BS.ByteString)]
rwBatchRetrieveTxs :: RW -> EbHash -> [Int] -> IO [(Int, TxHash, Maybe ByteString)]
rwBatchRetrieveTxs = LeiosDbReader IO
-> HasCallStack =>
   EbHash -> [Int] -> IO [(Int, TxHash, Maybe ByteString)]
LeiosDbReader IO
-> EbHash -> [Int] -> IO [(Int, TxHash, Maybe ByteString)]
forall (m :: * -> *).
LeiosDbReader m
-> HasCallStack =>
   EbHash -> [Int] -> m [(Int, TxHash, Maybe ByteString)]
batchRetrieveTxs (LeiosDbReader IO
 -> EbHash -> [Int] -> IO [(Int, TxHash, Maybe ByteString)])
-> (RW -> LeiosDbReader IO)
-> RW
-> EbHash
-> [Int]
-> IO [(Int, TxHash, Maybe ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RW -> LeiosDbReader IO
rwReader

-- | Create a fresh database and run an action with it.
-- Ensures proper cleanup for SQLite databases.
withFreshDb :: DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb :: forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
InMemory LeiosDbHandle IO -> IO a
action =
  IO (LeiosDbHandle IO)
forall (m :: * -> *). IOLike m => m (LeiosDbHandle m)
newLeiosDBInMemory IO (LeiosDbHandle IO) -> (LeiosDbHandle IO -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LeiosDbHandle IO -> IO a
action
withFreshDb DbImpl
SQLite LeiosDbHandle IO -> IO a
action = (LeiosDbHandle IO -> IO a) -> IO a
forall a. (LeiosDbHandle IO -> IO a) -> IO a
withFreshSQLiteDb LeiosDbHandle IO -> IO a
action

withFreshSQLiteDb :: (LeiosDbHandle IO -> IO a) -> IO a
withFreshSQLiteDb :: forall a. (LeiosDbHandle IO -> IO a) -> IO a
withFreshSQLiteDb LeiosDbHandle IO -> IO a
action = ([Char] -> [Char] -> LeiosDbHandle IO -> IO a) -> IO a
forall a. ([Char] -> [Char] -> LeiosDbHandle IO -> IO a) -> IO a
withFreshSQLiteFile (\[Char]
_vol [Char]
_imm -> LeiosDbHandle IO -> IO a
action)

-- | Create a fresh SQLite database and hand its paths to the action, which
-- 'truncateLeiosDbAfterSlot' needs. The database is torn down -- writes
-- flushed, threads stopped, connections closed -- before the directory is
-- removed; a still-open connection makes the removal flaky (a hard failure
-- on Windows, where deleting an open WAL is a sharing violation).
withFreshSQLiteFile :: (FilePath -> FilePath -> LeiosDbHandle IO -> IO a) -> IO a
withFreshSQLiteFile :: forall a. ([Char] -> [Char] -> LeiosDbHandle IO -> IO a) -> IO a
withFreshSQLiteFile [Char] -> [Char] -> LeiosDbHandle IO -> IO a
action =
  ([Char] -> [Char] -> IO a) -> IO a
forall a. ([Char] -> [Char] -> IO a) -> IO a
withTempLeiosDbPaths (([Char] -> [Char] -> IO a) -> IO a)
-> ([Char] -> [Char] -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \[Char]
volDbPath [Char]
immDbPath ->
    Tracer IO TraceLeiosDb
-> [Char] -> [Char] -> (LeiosDbHandle IO -> IO a) -> IO a
forall a.
Tracer IO TraceLeiosDb
-> [Char] -> [Char] -> (LeiosDbHandle IO -> IO a) -> IO a
withLeiosDBSQLite Tracer IO TraceLeiosDb
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer [Char]
volDbPath [Char]
immDbPath ((LeiosDbHandle IO -> IO a) -> IO a)
-> (LeiosDbHandle IO -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
      [Char] -> [Char] -> LeiosDbHandle IO -> IO a
action [Char]
volDbPath [Char]
immDbPath

-- | Paths for both partition files in a fresh temporary directory, which is
-- removed afterwards. Nothing is created at the paths.
withTempLeiosDbPaths :: (FilePath -> FilePath -> IO a) -> IO a
withTempLeiosDbPaths :: forall a. ([Char] -> [Char] -> IO a) -> IO a
withTempLeiosDbPaths [Char] -> [Char] -> IO a
action = do
  sysTmp <- IO [Char]
getCanonicalTemporaryDirectory
  bracket
    (createTempDirectory sysTmp "leios-test")
    removeDirectoryRecursive
    (\[Char]
tmpDir -> [Char] -> [Char] -> IO a
action ([Char]
tmpDir [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/test.vol.db") ([Char]
tmpDir [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/test.imm.db"))

-- | Run tests for each database implementation.
forEachImplementation :: (DbImpl -> [TestTree]) -> [TestTree]
forEachImplementation :: (DbImpl -> [TestTree]) -> [TestTree]
forEachImplementation DbImpl -> [TestTree]
mkTests =
  [ [Char] -> [TestTree] -> TestTree
testGroup [Char]
"InMemory" (DbImpl -> [TestTree]
mkTests DbImpl
InMemory)
  , [Char] -> [TestTree] -> TestTree
testGroup [Char]
"SQLite" (DbImpl -> [TestTree]
mkTests DbImpl
SQLite)
  ]

-- | Create the test groups for a given database implementation.
mkTestGroups :: DbImpl -> [TestTree]
mkTestGroups :: DbImpl -> [TestTree]
mkTestGroups DbImpl
impl =
  [ [Char] -> [TestTree] -> TestTree
testGroup
      [Char]
"points"
      [ [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"insert then scan" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> Property
prop_pointsInsertThenScan DbImpl
impl
      , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"multiple inserts accumulate" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> Property
prop_pointsAccumulate DbImpl
impl
      ]
  , [Char] -> [TestTree] -> TestTree
testGroup
      [Char]
"ebs"
      [ [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"insert then lookup" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> Property
prop_ebsInsertThenLookup DbImpl
impl
      , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"lookup missing returns empty" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> Property
prop_ebsLookupMissing DbImpl
impl
      ]
  , [Char] -> [TestTree] -> TestTree
testGroup
      [Char]
"transactions"
      [ [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"insert then retrieve" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> Property
prop_txsInsertThenRetrieve DbImpl
impl
      , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"retrieve missing returns empty" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> Property
prop_txsRetrieveMissing DbImpl
impl
      ]
  , [Char] -> [TestTree] -> TestTree
testGroup
      [Char]
"notifications"
      [ [Char] -> Assertion -> TestTree
testCase [Char]
"single subscriber" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl LeiosDbHandle IO -> Assertion
test_singleSubscriber
      , [Char] -> Assertion -> TestTree
testCase [Char]
"multiple subscribers" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl LeiosDbHandle IO -> Assertion
test_multipleSubscribers
      , [Char] -> Assertion -> TestTree
testCase [Char]
"correct data" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl LeiosDbHandle IO -> Assertion
test_correctData
      , [Char] -> Assertion -> TestTree
testCase [Char]
"late subscriber" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl LeiosDbHandle IO -> Assertion
test_lateSubscriber
      , [Char] -> Assertion -> TestTree
testCase [Char]
"multiple notifications" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl LeiosDbHandle IO -> Assertion
test_multipleNotifications
      , [Char] -> Assertion -> TestTree
testCase [Char]
"no offerBlockTxs before last update" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl LeiosDbHandle IO -> Assertion
test_noOfferBlockTxsBeforeComplete
      , [Char] -> Assertion -> TestTree
testCase [Char]
"offerBlockTxs on last update" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl LeiosDbHandle IO -> Assertion
test_offerBlockTxs
      , [Char] -> Assertion -> TestTree
testCase [Char]
"no re-notification of completed EBs" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl LeiosDbHandle IO -> Assertion
test_noReNotifyCompletedEbs
      , [Char] -> Assertion -> TestTree
testCase [Char]
"no re-notification when re-inserting an EB's own tx" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
          DbImpl -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl LeiosDbHandle IO -> Assertion
test_noReNotifyOnRelatedTxReinsert
      , [Char] -> Assertion -> TestTree
testCase [Char]
"same EB hash at multiple slots notifies each completion" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
          DbImpl -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl LeiosDbHandle IO -> Assertion
test_multipleSlotsSameHash
      ]
  , [Char] -> [TestTree] -> TestTree
testGroup
      [Char]
"lookupEbClosure"
      [ [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"complete EB returns Just with tx data" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> Property
prop_completedEbComplete DbImpl
impl
      , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"no txs returns Nothing" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> Property
prop_completedEbMissingTxs DbImpl
impl
      , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"partial txs returns Nothing" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> Property
prop_completedEbPartialTxs DbImpl
impl
      , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"no body returns Nothing" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ DbImpl -> Property
prop_completedEbNoBody DbImpl
impl
      ]
  ]

-- * QuickCheck generators

-- | Generate a random EbHash (32 random bytes).
-- With 256 bits of randomness, collisions are practically impossible.
genEbHash :: Gen EbHash
genEbHash :: Gen EbHash
genEbHash = ByteString -> EbHash
MkEbHash (ByteString -> EbHash)
-> ([Word8] -> ByteString) -> [Word8] -> EbHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack ([Word8] -> EbHash) -> Gen [Word8] -> Gen EbHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [Word8]
forall a. Arbitrary a => Int -> Gen [a]
vector Int
32

-- | Generate a random TxHash (32 random bytes).
genTxHash :: Gen TxHash
genTxHash :: Gen TxHash
genTxHash = ByteString -> TxHash
MkTxHash (ByteString -> TxHash)
-> ([Word8] -> ByteString) -> [Word8] -> TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack ([Word8] -> TxHash) -> Gen [Word8] -> Gen TxHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [Word8]
forall a. Arbitrary a => Int -> Gen [a]
vector Int
32

-- | Generate a random SlotNo.
genSlotNo :: Gen SlotNo
genSlotNo :: Gen SlotNo
genSlotNo = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> (Int -> Word64) -> Int -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> SlotNo) -> Gen Int -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
chooseInt (Int
0, Int
forall a. Bounded a => a
maxBound)

-- | Generate a random LeiosPoint.
genPoint :: Gen LeiosPoint
genPoint :: Gen LeiosPoint
genPoint = SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint (SlotNo -> EbHash -> LeiosPoint)
-> Gen SlotNo -> Gen (EbHash -> LeiosPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SlotNo
genSlotNo Gen (EbHash -> LeiosPoint) -> Gen EbHash -> Gen LeiosPoint
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen EbHash
genEbHash

-- | Generate a LeiosEb with the given number of transactions.
genEb :: Int -> Gen LeiosEb
genEb :: Int -> Gen LeiosEb
genEb Int
numTxs = do
  txs <- Int -> Gen (TxHash, Word32) -> Gen [(TxHash, Word32)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numTxs (Gen (TxHash, Word32) -> Gen [(TxHash, Word32)])
-> Gen (TxHash, Word32) -> Gen [(TxHash, Word32)]
forall a b. (a -> b) -> a -> b
$ do
    txHash <- Gen TxHash
genTxHash
    size <- chooseInt (50, 500)
    pure (txHash, fromIntegral size)
  pure $ MkLeiosEb $ V.fromList txs

-- | Generate a LeiosPoint and LeiosEb together with the given number of transactions.
genPointAndEb :: Int -> Gen (LeiosPoint, LeiosEb)
genPointAndEb :: Int -> Gen (LeiosPoint, LeiosEb)
genPointAndEb Int
numTxs = (,) (LeiosPoint -> LeiosEb -> (LeiosPoint, LeiosEb))
-> Gen LeiosPoint -> Gen (LeiosEb -> (LeiosPoint, LeiosEb))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen LeiosPoint
genPoint Gen (LeiosEb -> (LeiosPoint, LeiosEb))
-> Gen LeiosEb -> Gen (LeiosPoint, LeiosEb)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Gen LeiosEb
genEb Int
numTxs

-- | Generate random max sized tx (16k).
genTxBytes :: Gen BS.ByteString
genTxBytes :: Gen ByteString
genTxBytes = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> Gen [Word8] -> Gen ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [Word8]
forall a. Arbitrary a => Int -> Gen [a]
vector Int
16_384

-- | Max sized tx (16k) with all zeros.
maxTxBytesZero :: BS.ByteString
maxTxBytesZero :: ByteString
maxTxBytesZero = Int -> Word8 -> ByteString
BS.replicate Int
16_384 Word8
0

-- * Test fixtures for unit tests

-- | Create a simple test EbHash from a seed byte.
mkTestEbHash :: Word -> EbHash
mkTestEbHash :: Word -> EbHash
mkTestEbHash Word
seed = ByteString -> EbHash
MkEbHash (ByteString -> EbHash) -> ByteString -> EbHash
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
32 (Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
seed)

-- | Create a simple test TxHash from a seed byte.
mkTestTxHash :: Word -> TxHash
mkTestTxHash :: Word -> TxHash
mkTestTxHash Word
seed = ByteString -> TxHash
MkTxHash (ByteString -> TxHash) -> ByteString -> TxHash
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
32 (Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
seed)

-- | Create a test LeiosPoint.
mkTestPoint :: SlotNo -> Word -> LeiosPoint
mkTestPoint :: SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
slot Word
seed = SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint SlotNo
slot (Word -> EbHash
mkTestEbHash Word
seed)

-- | Create a test LeiosEb with the given number of transactions.
mkTestEb :: Int -> LeiosEb
mkTestEb :: Int -> LeiosEb
mkTestEb Int
numTxs =
  Vector (TxHash, Word32) -> LeiosEb
MkLeiosEb (Vector (TxHash, Word32) -> LeiosEb)
-> Vector (TxHash, Word32) -> LeiosEb
forall a b. (a -> b) -> a -> b
$
    [(TxHash, Word32)] -> Vector (TxHash, Word32)
forall a. [a] -> Vector a
V.fromList
      [ (Word -> TxHash
mkTestTxHash (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i), Word32
100 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
      | Int
i <- [Int
0 .. Int
numTxs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      ]

-- * Timing helpers

-- | Measure the time of an IO action and return the result with 'DiffTime'.
timed :: IO a -> IO (a, DiffTime)
timed :: forall a. IO a -> IO (a, DiffTime)
timed IO a
action = do
  start <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
  result <- action
  end <- getMonotonicTime
  pure (result, diffTime end start)

-- | Convert 'DiffTime' to a bucket label.
timeBucket :: DiffTime -> String
timeBucket :: DiffTime -> [Char]
timeBucket DiffTime
d
  | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< Integer -> DiffTime
micro Integer
1 = [Char]
"<1μs"
  | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< Integer -> DiffTime
micro Integer
10 = [Char]
"1μs-10μs"
  | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< Integer -> DiffTime
micro Integer
100 = [Char]
"10μs-100μs"
  | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< Integer -> DiffTime
milli Integer
1 = [Char]
"100μs-1ms"
  | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< Integer -> DiffTime
milli Integer
2 = [Char]
"1-2ms"
  | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< Integer -> DiffTime
milli Integer
3 = [Char]
"2-3ms"
  | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< Integer -> DiffTime
milli Integer
4 = [Char]
"3-4ms"
  | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< Integer -> DiffTime
milli Integer
5 = [Char]
"4-5ms"
  | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< Integer -> DiffTime
milli Integer
10 = [Char]
"5-10ms"
  | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< Integer -> DiffTime
milli Integer
50 = [Char]
"10-50ms"
  | Bool
otherwise = [Char]
">50ms"
 where

milli :: Integer -> DiffTime
milli :: Integer -> DiffTime
milli Integer
x = Integer -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x DiffTime -> DiffTime -> DiffTime
forall a. Fractional a => a -> a -> a
/ DiffTime
1000

micro :: Integer -> DiffTime
micro :: Integer -> DiffTime
micro Integer
x = Integer -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x DiffTime -> DiffTime -> DiffTime
forall a. Fractional a => a -> a -> a
/ DiffTime
1_000_000

magnitudeBucket :: (Num a, Ord a) => a -> String
magnitudeBucket :: forall a. (Num a, Ord a) => a -> [Char]
magnitudeBucket a
size
  | a
size a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
1 = [Char]
"0-1"
  | a
size a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
10 = [Char]
"1-10"
  | a
size a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
100 = [Char]
"10-100"
  | a
size a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
1_000 = [Char]
"100-1_000"
  | a
size a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
10_000 = [Char]
"1_000-10_000"
  | a
size a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
100_000 = [Char]
"10_000-100_000"
  | Bool
otherwise = [Char]
">100_000"

-- * Property tests for points

-- | Property: inserting a point and then scanning should return it.
prop_pointsInsertThenScan :: DbImpl -> Property
prop_pointsInsertThenScan :: DbImpl -> Property
prop_pointsInsertThenScan DbImpl
impl =
  Gen LeiosPoint -> (LeiosPoint -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen LeiosPoint
genPoint ((LeiosPoint -> Property) -> Property)
-> (LeiosPoint -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \LeiosPoint
point ->
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl ((LeiosDbHandle IO -> IO Property) -> IO Property)
-> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db -> LeiosDbHandle IO -> (RW -> IO Property) -> IO Property
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> IO Property) -> IO Property)
-> (RW -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
      (_, insertTime) <- Assertion -> IO ((), DiffTime)
forall a. IO a -> IO (a, DiffTime)
timed (Assertion -> IO ((), DiffTime)) -> Assertion -> IO ((), DiffTime)
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point Word32
1000
      (points, scanTime) <- timed $ rwScanEbPoints con
      pure $
        (pointSlotNo point, pointEbHash point) `elem` points
          & tabulate "insertEbPoint" [timeBucket insertTime]
          & tabulate "scanEbPoints" [timeBucket scanTime]

-- | Property: multiple inserted points all appear in scan results.
prop_pointsAccumulate :: DbImpl -> Property
prop_pointsAccumulate :: DbImpl -> Property
prop_pointsAccumulate DbImpl
impl =
  Gen Int
-> (Int -> [Int])
-> (Int -> [Char])
-> (Int -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> [Char]) -> (a -> prop) -> Property
forAllShrinkShow ((Int, Int) -> Gen Int
chooseInt (Int
1, Int
10)) Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int -> [Char]
forall a. Show a => a -> [Char]
show ((Int -> Property) -> Property) -> (Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
count ->
    Gen [LeiosPoint] -> ([LeiosPoint] -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen LeiosPoint -> Gen [LeiosPoint]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
count Gen LeiosPoint
genPoint) (([LeiosPoint] -> Property) -> Property)
-> ([LeiosPoint] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[LeiosPoint]
points ->
      IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl ((LeiosDbHandle IO -> IO Property) -> IO Property)
-> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db -> LeiosDbHandle IO -> (RW -> IO Property) -> IO Property
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> IO Property) -> IO Property)
-> (RW -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
        insertTimes <- [LeiosPoint] -> (LeiosPoint -> IO DiffTime) -> IO [DiffTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LeiosPoint]
points ((LeiosPoint -> IO DiffTime) -> IO [DiffTime])
-> (LeiosPoint -> IO DiffTime) -> IO [DiffTime]
forall a b. (a -> b) -> a -> b
$ \LeiosPoint
p ->
          ((), DiffTime) -> DiffTime
forall a b. (a, b) -> b
snd (((), DiffTime) -> DiffTime) -> IO ((), DiffTime) -> IO DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Assertion -> IO ((), DiffTime)
forall a. IO a -> IO (a, DiffTime)
timed (RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
p Word32
1000)
        (scanned, scanTime) <- timed $ rwScanEbPoints con
        let expected = [(LeiosPoint -> SlotNo
pointSlotNo LeiosPoint
p, LeiosPoint -> EbHash
pointEbHash LeiosPoint
p) | LeiosPoint
p <- [LeiosPoint]
points]
        pure $
          all (`elem` scanned) expected
            & tabulate "insertEbPoint" [timeBucket $ maximum insertTimes]
            & tabulate "scanEbPoints" [timeBucket scanTime]

-- * Property tests for EBs

-- | Property: inserting an EB body and looking it up returns the correct txs.
prop_ebsInsertThenLookup :: DbImpl -> Property
prop_ebsInsertThenLookup :: DbImpl -> Property
prop_ebsInsertThenLookup DbImpl
impl =
  Gen Int
-> (Int -> [Int])
-> (Int -> [Char])
-> (Int -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> [Char]) -> (a -> prop) -> Property
forAllShrinkShow ((Int, Int) -> Gen Int
chooseInt (Int
1, Int
50)) ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1) ([Int] -> [Int]) -> (Int -> [Int]) -> Int -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink) Int -> [Char]
forall a. Show a => a -> [Char]
show ((Int -> Property) -> Property) -> (Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
numTxs ->
    Gen (LeiosPoint, LeiosEb)
-> ((LeiosPoint, LeiosEb) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (LeiosPoint, LeiosEb)
genPointAndEb Int
numTxs) (((LeiosPoint, LeiosEb) -> Property) -> Property)
-> ((LeiosPoint, LeiosEb) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, LeiosEb
eb) ->
      IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl ((LeiosDbHandle IO -> IO Property) -> IO Property)
-> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db -> LeiosDbHandle IO -> (RW -> IO Property) -> IO Property
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> IO Property) -> IO Property)
-> (RW -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
        let expectedTxs :: [(TxHash, Word32)]
expectedTxs = Vector (TxHash, Word32) -> [(TxHash, Word32)]
forall a. Vector a -> [a]
V.toList (LeiosEb -> Vector (TxHash, Word32)
leiosEbTxs LeiosEb
eb)
        RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
        (_, insertTime) <- IO [LeiosPoint] -> IO ([LeiosPoint], DiffTime)
forall a. IO a -> IO (a, DiffTime)
timed (IO [LeiosPoint] -> IO ([LeiosPoint], DiffTime))
-> IO [LeiosPoint] -> IO ([LeiosPoint], DiffTime)
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
        (result, lookupTime) <- timed $ rwLookupEbBody con (pointEbHash point)
        pure $
          result == expectedTxs
            & counterexample ("Expected: " ++ show expectedTxs ++ "\nGot: " ++ show result)
            & tabulate "insertEbBody" [timeBucket insertTime]
            & tabulate "lookupEbBody" [timeBucket lookupTime]

-- | Property: looking up a non-existent EB returns empty list.
prop_ebsLookupMissing :: DbImpl -> Property
prop_ebsLookupMissing :: DbImpl -> Property
prop_ebsLookupMissing DbImpl
impl =
  Gen EbHash -> (EbHash -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen EbHash
genEbHash ((EbHash -> Property) -> Property)
-> (EbHash -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \EbHash
missingHash ->
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl ((LeiosDbHandle IO -> IO Property) -> IO Property)
-> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db -> LeiosDbHandle IO -> (RW -> IO Property) -> IO Property
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> IO Property) -> IO Property)
-> (RW -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
      (result, lookupTime) <- IO [(TxHash, Word32)] -> IO ([(TxHash, Word32)], DiffTime)
forall a. IO a -> IO (a, DiffTime)
timed (IO [(TxHash, Word32)] -> IO ([(TxHash, Word32)], DiffTime))
-> IO [(TxHash, Word32)] -> IO ([(TxHash, Word32)], DiffTime)
forall a b. (a -> b) -> a -> b
$ RW -> EbHash -> IO [(TxHash, Word32)]
rwLookupEbBody RW
con EbHash
missingHash
      pure $
        result === []
          & tabulate "lookupEbBody (missing)" [timeBucket lookupTime]

-- * Property tests for transactions

-- | Property: inserting tx bytes and retrieving them returns the correct data.
-- With the normalized schema, txs are inserted into a global `txs` table by TxHash,
-- and retrieval JOINs with that table.
prop_txsInsertThenRetrieve :: DbImpl -> Property
prop_txsInsertThenRetrieve :: DbImpl -> Property
prop_txsInsertThenRetrieve DbImpl
impl =
  Gen Int
-> (Int -> [Int])
-> (Int -> [Char])
-> (Int -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> [Char]) -> (a -> prop) -> Property
forAllShrinkShow ((Int, Int) -> Gen Int
chooseInt (Int
1, Int
50)) ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1) ([Int] -> [Int]) -> (Int -> [Int]) -> Int -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink) Int -> [Char]
forall a. Show a => a -> [Char]
show ((Int -> Property) -> Property) -> (Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
numTxs ->
    Gen (LeiosPoint, LeiosEb)
-> ((LeiosPoint, LeiosEb) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (LeiosPoint, LeiosEb)
genPointAndEb Int
numTxs) (((LeiosPoint, LeiosEb) -> Property) -> Property)
-> ((LeiosPoint, LeiosEb) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, LeiosEb
eb) ->
      Gen [Int] -> ([Int] -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind ([Int] -> Gen [Int]
forall a. [a] -> Gen [a]
sublistOf [Int
0 .. Int
numTxs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]) (([Int] -> Property) -> Property)
-> ([Int] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[Int]
offsetsToInsert ->
        IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl ((LeiosDbHandle IO -> IO Property) -> IO Property)
-> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db -> LeiosDbHandle IO -> (RW -> IO Property) -> IO Property
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> IO Property) -> IO Property)
-> (RW -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
          -- Insert the EB first (point then body)
          RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
          IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
          -- Get the txHashes from the EB for the offsets we want to insert
          let ebTxList :: [(TxHash, Word32)]
ebTxList = Vector (TxHash, Word32) -> [(TxHash, Word32)]
forall a. Vector a -> [a]
V.toList (LeiosEb -> Vector (TxHash, Word32)
leiosEbTxs LeiosEb
eb)
              !txsToInsert :: [(TxHash, ByteString)]
txsToInsert =
                [(TxHash, ByteString)] -> [(TxHash, ByteString)]
forall a. NFData a => a -> a
force ([(TxHash, ByteString)] -> [(TxHash, ByteString)])
-> [(TxHash, ByteString)] -> [(TxHash, ByteString)]
forall a b. (a -> b) -> a -> b
$
                  [ (TxHash
txHash, ByteString
txBytes)
                  | Int
off <- [Int]
offsetsToInsert
                  , let (TxHash
txHash, Word32
_size) = [(TxHash, Word32)]
ebTxList [(TxHash, Word32)] -> Int -> (TxHash, Word32)
forall a. HasCallStack => [a] -> Int -> a
!! Int
off
                  , let txBytes :: ByteString
txBytes = [Word8] -> ByteString
BS.pack [Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off, Word8
1, Word8
2, Word8
3] -- deterministic test bytes
                  ]
          -- Insert txs into global txs table
          insertTime <- ([LeiosPoint], DiffTime) -> DiffTime
forall a b. (a, b) -> b
snd (([LeiosPoint], DiffTime) -> DiffTime)
-> IO ([LeiosPoint], DiffTime) -> IO DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [LeiosPoint] -> IO ([LeiosPoint], DiffTime)
forall a. IO a -> IO (a, DiffTime)
timed (RW -> [(TxHash, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
con [(TxHash, ByteString)]
txsToInsert)
          -- Retrieve all offsets
          let allOffsets = [Int
0 .. Int
numTxs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
          (results, retrieveTime) <- timed $ rwBatchRetrieveTxs con (pointEbHash point) allOffsets
          -- Check that inserted txs have bytes, others don't
          let checkResult (Int
off, b
_txHash, Maybe ByteString
mBytes) =
                if Int
off Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
offsetsToInsert
                  then Maybe ByteString
mBytes Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ([Word8] -> ByteString
BS.pack [Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off, Word8
1, Word8
2, Word8
3])
                  else Maybe ByteString
mBytes Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ByteString
forall a. Maybe a
Nothing
          pure $
            conjoin
              [ all checkResult results
                  & counterexample "Unexpected bytes"
                  & counterexample ("Inserted offsets: " ++ show offsetsToInsert)
                  & counterexample ("Results: " ++ show results)
              , length results === numTxs
                  & counterexample "Length mismatch"
                  & counterexample ("Results: " ++ show (length results))
              ]
              & counterexample ("Total txs: " <> show numTxs)
              & counterexample ("Inserted txs: " <> show (length txsToInsert))
              & tabulate "insertTxs" [timeBucket insertTime]
              & tabulate "batchRetrieveTxs" [timeBucket retrieveTime]
              & tabulate "txs inserted" [magnitudeBucket $ length txsToInsert]

-- | Property: retrieving from non-existent EB returns empty list.
prop_txsRetrieveMissing :: DbImpl -> Property
prop_txsRetrieveMissing :: DbImpl -> Property
prop_txsRetrieveMissing DbImpl
impl =
  Gen EbHash -> (EbHash -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen EbHash
genEbHash ((EbHash -> Property) -> Property)
-> (EbHash -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \EbHash
missingHash ->
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl ((LeiosDbHandle IO -> IO Property) -> IO Property)
-> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db -> LeiosDbHandle IO -> (RW -> IO Property) -> IO Property
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> IO Property) -> IO Property)
-> (RW -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
      (result, retrieveTime) <- IO [(Int, TxHash, Maybe ByteString)]
-> IO ([(Int, TxHash, Maybe ByteString)], DiffTime)
forall a. IO a -> IO (a, DiffTime)
timed (IO [(Int, TxHash, Maybe ByteString)]
 -> IO ([(Int, TxHash, Maybe ByteString)], DiffTime))
-> IO [(Int, TxHash, Maybe ByteString)]
-> IO ([(Int, TxHash, Maybe ByteString)], DiffTime)
forall a b. (a -> b) -> a -> b
$ RW -> EbHash -> [Int] -> IO [(Int, TxHash, Maybe ByteString)]
rwBatchRetrieveTxs RW
con EbHash
missingHash [Int
0, Int
1, Int
2]
      pure $
        result === []
          & tabulate "batchRetrieveTxs (missing)" [timeBucket retrieveTime]

-- * Notification tests

-- | Test that a single subscriber receives a notification when rwInsertEbBody is called.
test_singleSubscriber :: LeiosDbHandle IO -> IO ()
test_singleSubscriber :: LeiosDbHandle IO -> Assertion
test_singleSubscriber LeiosDbHandle IO
db = do
  chan <- LeiosDbHandle IO
-> HasCallStack => IO (StrictTChan IO LeiosEbNotification)
forall (m :: * -> *).
LeiosDbHandle m
-> HasCallStack => m (StrictTChan m LeiosEbNotification)
subscribeEbNotifications LeiosDbHandle IO
db
  let point = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
1) Word
1
      eb = Int -> LeiosEb
mkTestEb Int
3
  withRW db $ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
  notification <- atomically $ readTChan chan
  case notification of
    AcquiredEb LeiosPoint
notifPoint Word32
_ ->
      LeiosPoint
notifPoint LeiosPoint -> LeiosPoint -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosPoint
point
    AcquiredEbTxs LeiosPoint
_ ->
      [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"expected AcquiredEb, got AcquiredEbTxs"

-- | Test that multiple subscribers each receive the notification.
test_multipleSubscribers :: LeiosDbHandle IO -> IO ()
test_multipleSubscribers :: LeiosDbHandle IO -> Assertion
test_multipleSubscribers LeiosDbHandle IO
db = do
  chan1 <- LeiosDbHandle IO
-> HasCallStack => IO (StrictTChan IO LeiosEbNotification)
forall (m :: * -> *).
LeiosDbHandle m
-> HasCallStack => m (StrictTChan m LeiosEbNotification)
subscribeEbNotifications LeiosDbHandle IO
db
  chan2 <- subscribeEbNotifications db
  chan3 <- subscribeEbNotifications db
  let point = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
1) Word
1
      eb = Int -> LeiosEb
mkTestEb Int
5
  withRW db $ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
  -- All subscribers should receive the notification
  notif1 <- atomically $ readTChan chan1
  notif2 <- atomically $ readTChan chan2
  notif3 <- atomically $ readTChan chan3
  assertOfferBlock point notif1
  assertOfferBlock point notif2
  assertOfferBlock point notif3

-- | Test that the notification contains the correct AcquiredEb data.
test_correctData :: LeiosDbHandle IO -> IO ()
test_correctData :: LeiosDbHandle IO -> Assertion
test_correctData LeiosDbHandle IO
db = do
  chan <- LeiosDbHandle IO
-> HasCallStack => IO (StrictTChan IO LeiosEbNotification)
forall (m :: * -> *).
LeiosDbHandle m
-> HasCallStack => m (StrictTChan m LeiosEbNotification)
subscribeEbNotifications LeiosDbHandle IO
db
  let point = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
1) Word
1
      eb = Int -> LeiosEb
mkTestEb Int
10
      expectedSize = LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb
  withRW db $ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
  notification <- atomically $ readTChan chan
  case notification of
    AcquiredEb LeiosPoint
notifPoint Word32
notifSize -> do
      LeiosPoint -> SlotNo
pointSlotNo LeiosPoint
notifPoint SlotNo -> SlotNo -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosPoint -> SlotNo
pointSlotNo LeiosPoint
point
      LeiosPoint -> EbHash
pointEbHash LeiosPoint
notifPoint EbHash -> EbHash -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosPoint -> EbHash
pointEbHash LeiosPoint
point
      Word32
notifSize Word32 -> Word32 -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Word32
expectedSize
    AcquiredEbTxs LeiosPoint
_ ->
      [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"expected AcquiredEb, got AcquiredEbTxs"

-- | Test that a subscriber who subscribes after an insertion does not receive
-- the past notification.
test_lateSubscriber :: LeiosDbHandle IO -> IO ()
test_lateSubscriber :: LeiosDbHandle IO -> Assertion
test_lateSubscriber LeiosDbHandle IO
db = do
  -- Insert before subscribing
  let point1 :: LeiosPoint
point1 = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
1) Word
1
      eb1 :: LeiosEb
eb1 = Int -> LeiosEb
mkTestEb Int
2
  LeiosDbHandle IO -> (RW -> Assertion) -> Assertion
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> Assertion) -> Assertion) -> (RW -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point1 (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb1)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point1 LeiosEb
eb1
  -- Now subscribe
  chan <- LeiosDbHandle IO
-> HasCallStack => IO (StrictTChan IO LeiosEbNotification)
forall (m :: * -> *).
LeiosDbHandle m
-> HasCallStack => m (StrictTChan m LeiosEbNotification)
subscribeEbNotifications LeiosDbHandle IO
db
  -- The channel should be empty (no past notifications)
  maybeNotif <- atomically $ tryReadTChan chan
  case maybeNotif of
    Maybe LeiosEbNotification
Nothing -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Expected: no notification
    Just LeiosEbNotification
_ -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"late subscriber should not receive past notifications"
  -- But new insertions should be received
  let point2 = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
2) Word
2
      eb2 = Int -> LeiosEb
mkTestEb Int
3
  withRW db $ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point2 (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb2)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point2 LeiosEb
eb2
  notification <- atomically $ readTChan chan
  assertOfferBlock point2 notification

-- | Test that multiple insertions yield multiple notifications in order.
test_multipleNotifications :: LeiosDbHandle IO -> IO ()
test_multipleNotifications :: LeiosDbHandle IO -> Assertion
test_multipleNotifications LeiosDbHandle IO
db = do
  chan <- LeiosDbHandle IO
-> HasCallStack => IO (StrictTChan IO LeiosEbNotification)
forall (m :: * -> *).
LeiosDbHandle m
-> HasCallStack => m (StrictTChan m LeiosEbNotification)
subscribeEbNotifications LeiosDbHandle IO
db
  let points =
        [ SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
i) (Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i)
        | Word64
i <- [Word64
1 .. Word64
5]
        ]
      ebs = [Int -> LeiosEb
mkTestEb Int
i | Int
i <- [Int
1 .. Int
5]]
  -- Insert all (point then body for each)
  withRW db $ \RW
con ->
    [(LeiosPoint, LeiosEb)]
-> ((LeiosPoint, LeiosEb) -> Assertion) -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([LeiosPoint] -> [LeiosEb] -> [(LeiosPoint, LeiosEb)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LeiosPoint]
points [LeiosEb]
ebs) (((LeiosPoint, LeiosEb) -> Assertion) -> Assertion)
-> ((LeiosPoint, LeiosEb) -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, LeiosEb
eb) -> do
      RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
      IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
  -- Read all notifications and verify order
  notifications <- replicateM 5 (atomically $ readTChan chan)
  mapM_
    (uncurry assertOfferBlock)
    (zip points notifications)

-- | Test that no AcquiredEbTxs notification is produced when only some
-- transactions have been inserted via rwInsertTxs.
test_noOfferBlockTxsBeforeComplete :: LeiosDbHandle IO -> IO ()
test_noOfferBlockTxsBeforeComplete :: LeiosDbHandle IO -> Assertion
test_noOfferBlockTxsBeforeComplete LeiosDbHandle IO
db = do
  chan <- LeiosDbHandle IO
-> HasCallStack => IO (StrictTChan IO LeiosEbNotification)
forall (m :: * -> *).
LeiosDbHandle m
-> HasCallStack => m (StrictTChan m LeiosEbNotification)
subscribeEbNotifications LeiosDbHandle IO
db
  let point = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
1) Word
1
      eb = Int -> LeiosEb
mkTestEb Int
3 -- 3 transactions
      ebTxList = Vector (TxHash, Word32) -> [(TxHash, Word32)]
forall a. Vector a -> [a]
V.toList (LeiosEb -> Vector (TxHash, Word32)
leiosEbTxs LeiosEb
eb)
  withRW db $ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
    -- Consume the LeiosOfferBlock notification
    _ <- STM IO LeiosEbNotification -> IO LeiosEbNotification
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO LeiosEbNotification -> IO LeiosEbNotification)
-> STM IO LeiosEbNotification -> IO LeiosEbNotification
forall a b. (a -> b) -> a -> b
$ StrictTChan IO LeiosEbNotification -> STM IO LeiosEbNotification
forall (m :: * -> *) a. MonadSTM m => StrictTChan m a -> STM m a
readTChan StrictTChan IO LeiosEbNotification
chan
    -- Insert only 2 of 3 txs (by txHash)
    let txsToInsert =
          [ (TxHash
txHash, [Word8] -> ByteString
BS.pack [Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i, Word8
1, Word8
2, Word8
3])
          | (Int
i, (TxHash
txHash, Word32
_size)) <- [Int] -> [(TxHash, Word32)] -> [(Int, (TxHash, Word32))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int, Int
1] [(TxHash, Word32)]
ebTxList
          ]
    _ <- rwInsertTxs con txsToInsert
    -- No LeiosOfferBlockTxs notification should be available
    maybeNotif <- atomically $ tryReadTChan chan
    case maybeNotif of
      Maybe LeiosEbNotification
Nothing -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just LeiosEbNotification
_ -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"should not notify before all txs are inserted"

-- | Test that a AcquiredEbTxs notification is produced when all
-- transactions are inserted via rwInsertTxs.
test_offerBlockTxs :: LeiosDbHandle IO -> IO ()
test_offerBlockTxs :: LeiosDbHandle IO -> Assertion
test_offerBlockTxs LeiosDbHandle IO
db = do
  chan <- LeiosDbHandle IO
-> HasCallStack => IO (StrictTChan IO LeiosEbNotification)
forall (m :: * -> *).
LeiosDbHandle m
-> HasCallStack => m (StrictTChan m LeiosEbNotification)
subscribeEbNotifications LeiosDbHandle IO
db
  let point = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
1) Word
1
      eb = Int -> LeiosEb
mkTestEb Int
3 -- 3 transactions
      ebTxList = Vector (TxHash, Word32) -> [(TxHash, Word32)]
forall a. Vector a -> [a]
V.toList (LeiosEb -> Vector (TxHash, Word32)
leiosEbTxs LeiosEb
eb)
  withRW db $ \RW
con -> do
    -- Insert the EB (point then body)
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
    -- Consume the LeiosOfferBlock notification
    _ <- STM IO LeiosEbNotification -> IO LeiosEbNotification
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO LeiosEbNotification -> IO LeiosEbNotification)
-> STM IO LeiosEbNotification -> IO LeiosEbNotification
forall a b. (a -> b) -> a -> b
$ StrictTChan IO LeiosEbNotification -> STM IO LeiosEbNotification
forall (m :: * -> *) a. MonadSTM m => StrictTChan m a -> STM m a
readTChan StrictTChan IO LeiosEbNotification
chan
    -- Insert all txs (by txHash)
    let txsToInsert =
          [ (TxHash
txHash, [Word8] -> ByteString
BS.pack [Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i, Word8
1, Word8
2, Word8
3])
          | (Int
i, (TxHash
txHash, Word32
_size)) <- [Int] -> [(TxHash, Word32)] -> [(Int, (TxHash, Word32))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [(TxHash, Word32)]
ebTxList
          ]
    _ <- rwInsertTxs con txsToInsert
    -- FIXME: blocks forever if impl not working
    notification <- atomically $ readTChan chan
    assertOfferBlockTxs point notification

-- | Test that completed EBs are not re-notified when subsequent unrelated
-- transactions are inserted.
test_noReNotifyCompletedEbs :: LeiosDbHandle IO -> IO ()
test_noReNotifyCompletedEbs :: LeiosDbHandle IO -> Assertion
test_noReNotifyCompletedEbs LeiosDbHandle IO
db = do
  chan <- LeiosDbHandle IO
-> HasCallStack => IO (StrictTChan IO LeiosEbNotification)
forall (m :: * -> *).
LeiosDbHandle m
-> HasCallStack => m (StrictTChan m LeiosEbNotification)
subscribeEbNotifications LeiosDbHandle IO
db
  let point = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
1) Word
1
      eb = Int -> LeiosEb
mkTestEb Int
2
      ebTxList = Vector (TxHash, Word32) -> [(TxHash, Word32)]
forall a. Vector a -> [a]
V.toList (LeiosEb -> Vector (TxHash, Word32)
leiosEbTxs LeiosEb
eb)
  withRW db $ \RW
con -> do
    -- Insert and complete the EB
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
    -- Consume the AcquiredEb notification
    acquiredEb <- STM IO (Maybe LeiosEbNotification)
-> IO (Maybe LeiosEbNotification)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (Maybe LeiosEbNotification)
 -> IO (Maybe LeiosEbNotification))
-> STM IO (Maybe LeiosEbNotification)
-> IO (Maybe LeiosEbNotification)
forall a b. (a -> b) -> a -> b
$ StrictTChan IO LeiosEbNotification
-> STM IO (Maybe LeiosEbNotification)
forall (m :: * -> *) a.
MonadSTM m =>
StrictTChan m a -> STM m (Maybe a)
tryReadTChan StrictTChan IO LeiosEbNotification
chan
    case acquiredEb of
      Just (AcquiredEb{}) -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Maybe LeiosEbNotification
_ -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"expected AcquiredEb notification"
    let txsToInsert = [(TxHash
txHash, ByteString
maxTxBytesZero) | (TxHash
txHash, Word32
_) <- [(TxHash, Word32)]
ebTxList]
    _ <- rwInsertTxs con txsToInsert
    -- Consume the AcquiredEbTxs notification
    acquiredTxs <- atomically $ tryReadTChan chan
    case acquiredTxs of
      Just (AcquiredEbTxs LeiosPoint
p) -> LeiosPoint
p LeiosPoint -> LeiosPoint -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosPoint
point
      Maybe LeiosEbNotification
_ -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"expected AcquiredEbTxs notification"
    -- Insert an unrelated tx
    _ <- rwInsertTxs con [(mkTestTxHash 99, maxTxBytesZero)]
    -- No re-notification should occur for the already-completed EB
    maybeNotif <- atomically $ tryReadTChan chan
    case maybeNotif of
      Maybe LeiosEbNotification
Nothing -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just LeiosEbNotification
_ -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"completed EB should not be re-notified"

-- | Re-inserting a tx that is _referenced_ by an already-completed EB
-- must not re-fire 'AcquiredEbTxs'. This is the practical case where
-- the previous 'no re-notification' check (which only used an unrelated
-- tx) lets a bug through: the completion predicate
-- @any (\\e -> eteTxHash e \`elem\` insertedTxHashes)@ matches again on
-- any subsequent batch containing an EB-referenced tx, since the
-- 'all txs present' clause remains true once the EB is complete.
-- The voting layer treats the duplicate 'AcquiredEbTxs' as a fatal
-- 'AlreadyKnown' from 'addVote'.
test_noReNotifyOnRelatedTxReinsert :: LeiosDbHandle IO -> IO ()
test_noReNotifyOnRelatedTxReinsert :: LeiosDbHandle IO -> Assertion
test_noReNotifyOnRelatedTxReinsert LeiosDbHandle IO
db = do
  chan <- LeiosDbHandle IO
-> HasCallStack => IO (StrictTChan IO LeiosEbNotification)
forall (m :: * -> *).
LeiosDbHandle m
-> HasCallStack => m (StrictTChan m LeiosEbNotification)
subscribeEbNotifications LeiosDbHandle IO
db
  let point = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
1) Word
1
      eb = Int -> LeiosEb
mkTestEb Int
2
      ebTxList = Vector (TxHash, Word32) -> [(TxHash, Word32)]
forall a. Vector a -> [a]
V.toList (LeiosEb -> Vector (TxHash, Word32)
leiosEbTxs LeiosEb
eb)
  withRW db $ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
    acquiredEb <- STM IO (Maybe LeiosEbNotification)
-> IO (Maybe LeiosEbNotification)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (Maybe LeiosEbNotification)
 -> IO (Maybe LeiosEbNotification))
-> STM IO (Maybe LeiosEbNotification)
-> IO (Maybe LeiosEbNotification)
forall a b. (a -> b) -> a -> b
$ StrictTChan IO LeiosEbNotification
-> STM IO (Maybe LeiosEbNotification)
forall (m :: * -> *) a.
MonadSTM m =>
StrictTChan m a -> STM m (Maybe a)
tryReadTChan StrictTChan IO LeiosEbNotification
chan
    case acquiredEb of
      Just (AcquiredEb{}) -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Maybe LeiosEbNotification
_ -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"expected AcquiredEb notification"
    -- Insert all EB-referenced txs → EB completes, one AcquiredEbTxs.
    let txsToInsert = [(TxHash
txHash, ByteString
maxTxBytesZero) | (TxHash
txHash, Word32
_) <- [(TxHash, Word32)]
ebTxList]
    _ <- rwInsertTxs con txsToInsert
    acquiredTxs <- atomically $ tryReadTChan chan
    case acquiredTxs of
      Just (AcquiredEbTxs LeiosPoint
p) -> LeiosPoint
p LeiosPoint -> LeiosPoint -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosPoint
point
      Maybe LeiosEbNotification
_ -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"expected AcquiredEbTxs notification"
    -- Re-insert one of the EB's own txs (a no-op at the tx storage
    -- level — it's already present). The completed EB must NOT be
    -- re-notified.
    case ebTxList of
      ((TxHash
txHash, Word32
_) : [(TxHash, Word32)]
_) -> do
        _ <- RW -> [(TxHash, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
con [(TxHash
txHash, ByteString
maxTxBytesZero)]
        maybeNotif <- atomically $ tryReadTChan chan
        case maybeNotif of
          Maybe LeiosEbNotification
Nothing -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just LeiosEbNotification
_ ->
            [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure
              [Char]
"completed EB should not be re-notified on re-insert of its own tx"
      [] -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"test EB has no txs"

-- | The same EB content can be forged at multiple slots; the DB must
-- track each 'LeiosPoint' independently and emit one 'AcquiredEbTxs'
-- per (slot, hash) when the closure completes, regardless of how many
-- slots reference the same hash. Conflating the slots loses a
-- notification.
test_multipleSlotsSameHash :: LeiosDbHandle IO -> IO ()
test_multipleSlotsSameHash :: LeiosDbHandle IO -> Assertion
test_multipleSlotsSameHash LeiosDbHandle IO
db = do
  chan <- LeiosDbHandle IO
-> HasCallStack => IO (StrictTChan IO LeiosEbNotification)
forall (m :: * -> *).
LeiosDbHandle m
-> HasCallStack => m (StrictTChan m LeiosEbNotification)
subscribeEbNotifications LeiosDbHandle IO
db
  let hashSeed = Word
1
      point1 = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
1) Word
hashSeed
      point2 = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
2) Word
hashSeed
      eb = Int -> LeiosEb
mkTestEb Int
2 -- same content at both points (deterministic from numTxs)
      ebTxList = Vector (TxHash, Word32) -> [(TxHash, Word32)]
forall a. Vector a -> [a]
V.toList (LeiosEb -> Vector (TxHash, Word32)
leiosEbTxs LeiosEb
eb)
      drainNotifications = [LeiosEbNotification] -> IO [LeiosEbNotification]
go []
       where
        go :: [LeiosEbNotification] -> IO [LeiosEbNotification]
go [LeiosEbNotification]
acc =
          STM IO (Maybe LeiosEbNotification)
-> IO (Maybe LeiosEbNotification)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTChan IO LeiosEbNotification
-> STM IO (Maybe LeiosEbNotification)
forall (m :: * -> *) a.
MonadSTM m =>
StrictTChan m a -> STM m (Maybe a)
tryReadTChan StrictTChan IO LeiosEbNotification
chan) IO (Maybe LeiosEbNotification)
-> (Maybe LeiosEbNotification -> IO [LeiosEbNotification])
-> IO [LeiosEbNotification]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe LeiosEbNotification
Nothing -> [LeiosEbNotification] -> IO [LeiosEbNotification]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LeiosEbNotification] -> [LeiosEbNotification]
forall a. [a] -> [a]
reverse [LeiosEbNotification]
acc)
            Just LeiosEbNotification
n -> [LeiosEbNotification] -> IO [LeiosEbNotification]
go (LeiosEbNotification
n LeiosEbNotification
-> [LeiosEbNotification] -> [LeiosEbNotification]
forall a. a -> [a] -> [a]
: [LeiosEbNotification]
acc)
  withRW db $ \RW
con -> do
    -- Announce the same EB at two slots and insert the body twice.
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point1 (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point2 (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point1 LeiosEb
eb
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point2 LeiosEb
eb
    -- Drain the two AcquiredEb notifications (order matches insertion).
    acquiredEbs <- IO [LeiosEbNotification]
drainNotifications
    let acquiredEbPoints =
          [LeiosPoint
p | AcquiredEb LeiosPoint
p Word32
_ <- [LeiosEbNotification]
acquiredEbs]
    acquiredEbPoints `setEquals` [point1, point2]
    -- Insert every tx the EB references — closure completes for both rows.
    _ <-
      rwInsertTxs
        con
        [(txHash, maxTxBytesZero) | (txHash, _) <- ebTxList]
    -- Both rows must notify completion, once each.
    completionNotifs <- drainNotifications
    let completionPoints =
          [LeiosPoint
p | AcquiredEbTxs LeiosPoint
p <- [LeiosEbNotification]
completionNotifs]
    completionPoints `setEquals` [point1, point2]
    length completionNotifs @?= 2
 where
  setEquals :: [k] -> [k] -> Assertion
setEquals [k]
xs [k]
ys = [(k, ())] -> Map k ()
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(k
p, ()) | k
p <- [k]
xs] Map k () -> Map k () -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [(k, ())] -> Map k ()
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(k
p, ()) | k
p <- [k]
ys]

-- * Test utilities

-- | Assert that a notification is AcquiredEb with the expected point.
assertOfferBlock :: LeiosPoint -> LeiosEbNotification -> IO ()
assertOfferBlock :: LeiosPoint -> LeiosEbNotification -> Assertion
assertOfferBlock LeiosPoint
expectedPoint = \case
  AcquiredEb LeiosPoint
actualPoint Word32
_ ->
    LeiosPoint
actualPoint LeiosPoint -> LeiosPoint -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosPoint
expectedPoint
  AcquiredEbTxs LeiosPoint
_ ->
    [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"expected AcquiredEb, got AcquiredEbTxs"

-- | Assert that a notification is AcquiredEbTxs with the expected point.
assertOfferBlockTxs :: LeiosPoint -> LeiosEbNotification -> IO ()
assertOfferBlockTxs :: LeiosPoint -> LeiosEbNotification -> Assertion
assertOfferBlockTxs LeiosPoint
expectedPoint = \case
  AcquiredEbTxs LeiosPoint
actualPoint ->
    LeiosPoint
actualPoint LeiosPoint -> LeiosPoint -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosPoint
expectedPoint
  AcquiredEb LeiosPoint
_ Word32
_ ->
    [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"expected AcquiredEbTxs, got AcquiredEb"

-- * Property tests for lookupEbClosure

-- | Property: complete EB (all txs inserted) returns Just with correct tx data.
prop_completedEbComplete :: DbImpl -> Property
prop_completedEbComplete :: DbImpl -> Property
prop_completedEbComplete DbImpl
impl =
  Gen Int
-> (Int -> [Int])
-> (Int -> [Char])
-> (Int -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> [Char]) -> (a -> prop) -> Property
forAllShrinkShow ((Int, Int) -> Gen Int
chooseInt (Int
1, Int
20)) Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int -> [Char]
forall a. Show a => a -> [Char]
show ((Int -> Property) -> Property) -> (Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
numTxs ->
    Gen (LeiosPoint, LeiosEb)
-> ((LeiosPoint, LeiosEb) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (LeiosPoint, LeiosEb)
genPointAndEb Int
numTxs) (((LeiosPoint, LeiosEb) -> Property) -> Property)
-> ((LeiosPoint, LeiosEb) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, LeiosEb
eb) ->
      Gen ByteString -> (ByteString -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen ByteString
genTxBytes ((ByteString -> Property) -> Property)
-> (ByteString -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ByteString
txBytes ->
        IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl ((LeiosDbHandle IO -> IO Property) -> IO Property)
-> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db -> LeiosDbHandle IO -> (RW -> IO Property) -> IO Property
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> IO Property) -> IO Property)
-> (RW -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
          RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
          IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
          let ebTxList :: [(TxHash, Word32)]
ebTxList = Vector (TxHash, Word32) -> [(TxHash, Word32)]
forall a. Vector a -> [a]
V.toList (LeiosEb -> Vector (TxHash, Word32)
leiosEbTxs LeiosEb
eb)
              txsToInsert :: [(TxHash, ByteString)]
txsToInsert = [(TxHash
txHash, ByteString
txBytes) | (TxHash
txHash, Word32
_size) <- [(TxHash, Word32)]
ebTxList]
          _ <- RW -> [(TxHash, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
con [(TxHash, ByteString)]
txsToInsert
          (result, queryTime) <- timed $ rwLookupEbClosure con (pointEbHash point)
          let expectedHashes = ((TxHash, ByteString) -> TxHash)
-> [(TxHash, ByteString)] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map (TxHash, ByteString) -> TxHash
forall a b. (a, b) -> a
fst [(TxHash, ByteString)]
txsToInsert
              check = case Maybe [(TxHash, ByteString)]
result of
                Maybe [(TxHash, ByteString)]
Nothing ->
                  Bool
False Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"Expected Just, got Nothing"
                Just [(TxHash, ByteString)]
txData ->
                  [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
                    [ [(TxHash, ByteString)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxHash, ByteString)]
txData Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int
numTxs
                        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"Wrong number of txs"
                    , (TxHash -> Bool) -> [TxHash] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TxHash -> [TxHash] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((TxHash, ByteString) -> TxHash)
-> [(TxHash, ByteString)] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map (TxHash, ByteString) -> TxHash
forall a b. (a, b) -> a
fst [(TxHash, ByteString)]
txData) [TxHash]
expectedHashes
                        Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"Missing expected tx hashes"
                    , (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
txBytes) (((TxHash, ByteString) -> ByteString)
-> [(TxHash, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (TxHash, ByteString) -> ByteString
forall a b. (a, b) -> b
snd [(TxHash, ByteString)]
txData)
                        Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"Wrong tx bytes"
                    ]
          pure $
            check
              & tabulate "lookupEbClosure (complete)" [timeBucket queryTime]
              & tabulate "numTxs" [magnitudeBucket numTxs]

-- | Property: EB with body but no txs returns Nothing.
prop_completedEbMissingTxs :: DbImpl -> Property
prop_completedEbMissingTxs :: DbImpl -> Property
prop_completedEbMissingTxs DbImpl
impl =
  Gen Int
-> (Int -> [Int])
-> (Int -> [Char])
-> (Int -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> [Char]) -> (a -> prop) -> Property
forAllShrinkShow ((Int, Int) -> Gen Int
chooseInt (Int
1, Int
20)) Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int -> [Char]
forall a. Show a => a -> [Char]
show ((Int -> Property) -> Property) -> (Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
numTxs ->
    Gen (LeiosPoint, LeiosEb)
-> ((LeiosPoint, LeiosEb) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (LeiosPoint, LeiosEb)
genPointAndEb Int
numTxs) (((LeiosPoint, LeiosEb) -> Property) -> Property)
-> ((LeiosPoint, LeiosEb) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, LeiosEb
eb) ->
      IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl ((LeiosDbHandle IO -> IO Property) -> IO Property)
-> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db -> LeiosDbHandle IO -> (RW -> IO Property) -> IO Property
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> IO Property) -> IO Property)
-> (RW -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
        RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
        IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
        (result, queryTime) <- IO (Maybe [(TxHash, ByteString)])
-> IO (Maybe [(TxHash, ByteString)], DiffTime)
forall a. IO a -> IO (a, DiffTime)
timed (IO (Maybe [(TxHash, ByteString)])
 -> IO (Maybe [(TxHash, ByteString)], DiffTime))
-> IO (Maybe [(TxHash, ByteString)])
-> IO (Maybe [(TxHash, ByteString)], DiffTime)
forall a b. (a -> b) -> a -> b
$ RW -> EbHash -> IO (Maybe [(TxHash, ByteString)])
rwLookupEbClosure RW
con (LeiosPoint -> EbHash
pointEbHash LeiosPoint
point)
        pure $
          result === Nothing
            & counterexample "Expected Nothing when no txs are present"
            & tabulate "lookupEbClosure (no txs)" [timeBucket queryTime]
            & tabulate "numTxs" [magnitudeBucket numTxs]

-- | Property: EB with partial txs (at least one missing) returns Nothing.
prop_completedEbPartialTxs :: DbImpl -> Property
prop_completedEbPartialTxs :: DbImpl -> Property
prop_completedEbPartialTxs DbImpl
impl =
  Gen Int
-> (Int -> [Int])
-> (Int -> [Char])
-> (Int -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> [Char]) -> (a -> prop) -> Property
forAllShrinkShow ((Int, Int) -> Gen Int
chooseInt (Int
2, Int
20)) Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int -> [Char]
forall a. Show a => a -> [Char]
show ((Int -> Property) -> Property) -> (Int -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
numTxs ->
    Gen (LeiosPoint, LeiosEb)
-> ((LeiosPoint, LeiosEb) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (LeiosPoint, LeiosEb)
genPointAndEb Int
numTxs) (((LeiosPoint, LeiosEb) -> Property) -> Property)
-> ((LeiosPoint, LeiosEb) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, LeiosEb
eb) ->
      Gen ByteString -> (ByteString -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen ByteString
genTxBytes ((ByteString -> Property) -> Property)
-> (ByteString -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ByteString
txBytes ->
        IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl ((LeiosDbHandle IO -> IO Property) -> IO Property)
-> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db -> LeiosDbHandle IO -> (RW -> IO Property) -> IO Property
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> IO Property) -> IO Property)
-> (RW -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
          RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
          IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point LeiosEb
eb
          -- Insert only the first half of txs, leaving at least one missing
          let ebTxList :: [(TxHash, Word32)]
ebTxList = Vector (TxHash, Word32) -> [(TxHash, Word32)]
forall a. Vector a -> [a]
V.toList (LeiosEb -> Vector (TxHash, Word32)
leiosEbTxs LeiosEb
eb)
              partialTxs :: [(TxHash, Word32)]
partialTxs = Int -> [(TxHash, Word32)] -> [(TxHash, Word32)]
forall a. Int -> [a] -> [a]
take (Int
numTxs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [(TxHash, Word32)]
ebTxList
              txsToInsert :: [(TxHash, ByteString)]
txsToInsert = [(TxHash
txHash, ByteString
txBytes) | (TxHash
txHash, Word32
_size) <- [(TxHash, Word32)]
partialTxs]
          _ <- RW -> [(TxHash, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
con [(TxHash, ByteString)]
txsToInsert
          (result, queryTime) <- timed $ rwLookupEbClosure con (pointEbHash point)
          pure $
            result === Nothing
              & counterexample
                ( "Expected Nothing with "
                    ++ show (length txsToInsert)
                    ++ "/"
                    ++ show numTxs
                    ++ " txs present"
                )
              & tabulate "lookupEbClosure (partial txs)" [timeBucket queryTime]
              & tabulate "numTxs" [magnitudeBucket numTxs]

-- | Property: EB with only a point announced (no body) returns Nothing.
prop_completedEbNoBody :: DbImpl -> Property
prop_completedEbNoBody :: DbImpl -> Property
prop_completedEbNoBody DbImpl
impl =
  Gen LeiosPoint -> (LeiosPoint -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen LeiosPoint
genPoint ((LeiosPoint -> Property) -> Property)
-> (LeiosPoint -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \LeiosPoint
point ->
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ DbImpl -> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
impl ((LeiosDbHandle IO -> IO Property) -> IO Property)
-> (LeiosDbHandle IO -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db -> LeiosDbHandle IO -> (RW -> IO Property) -> IO Property
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> IO Property) -> IO Property)
-> (RW -> IO Property) -> IO Property
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
      RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point Word32
1000
      (result, queryTime) <- IO (Maybe [(TxHash, ByteString)])
-> IO (Maybe [(TxHash, ByteString)], DiffTime)
forall a. IO a -> IO (a, DiffTime)
timed (IO (Maybe [(TxHash, ByteString)])
 -> IO (Maybe [(TxHash, ByteString)], DiffTime))
-> IO (Maybe [(TxHash, ByteString)])
-> IO (Maybe [(TxHash, ByteString)], DiffTime)
forall a b. (a -> b) -> a -> b
$ RW -> EbHash -> IO (Maybe [(TxHash, ByteString)])
rwLookupEbClosure RW
con (LeiosPoint -> EbHash
pointEbHash LeiosPoint
point)
      pure $
        result === Nothing
          & counterexample "Expected Nothing for EB with no body inserted"
          & tabulate "lookupEbClosure (no body)" [timeBucket queryTime]

-- * truncateLeiosDbAfterSlot

test_truncateDropsEbsAfterSlot :: FilePath -> FilePath -> LeiosDbHandle IO -> IO ()
test_truncateDropsEbsAfterSlot :: [Char] -> [Char] -> LeiosDbHandle IO -> Assertion
test_truncateDropsEbsAfterSlot [Char]
volDbPath [Char]
_immDbPath LeiosDbHandle IO
db = do
  let eb :: LeiosEb
eb = Int -> LeiosEb
mkTestEb Int
2
      keptHash :: EbHash
keptHash = Word -> EbHash
mkTestEbHash Word
1
      droppedHash :: EbHash
droppedHash = Word -> EbHash
mkTestEbHash Word
2
  LeiosDbHandle IO -> (RW -> Assertion) -> Assertion
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> Assertion) -> Assertion) -> (RW -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con (SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint SlotNo
5 EbHash
keptHash) (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con (SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint SlotNo
5 EbHash
keptHash) LeiosEb
eb
    -- The kept EB is announced again at a slot the truncation drops.
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con (SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint SlotNo
15 EbHash
keptHash) (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con (SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint SlotNo
15 EbHash
droppedHash) (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con (SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint SlotNo
15 EbHash
droppedHash) LeiosEb
eb

  HasCallStack => [Char] -> SlotNo -> Assertion
[Char] -> SlotNo -> Assertion
truncateLeiosDbAfterSlot [Char]
volDbPath SlotNo
10

  LeiosDbHandle IO -> (RW -> Assertion) -> Assertion
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> Assertion) -> Assertion) -> (RW -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
    points <- RW -> IO [(SlotNo, EbHash)]
rwScanEbPoints RW
con
    points @?= [(5, keptHash)]
    keptBody <- rwLookupEbBody con keptHash
    keptBody @?= V.toList (leiosEbTxs eb)
    droppedBody <- rwLookupEbBody con droppedHash
    droppedBody @?= []

-- | The immutable schema lacks the volatile-only tables; the tooling that
-- DBTruncater runs on both files must still work on it.
test_truncateImmutablePartition :: FilePath -> FilePath -> IO ()
test_truncateImmutablePartition :: [Char] -> [Char] -> Assertion
test_truncateImmutablePartition [Char]
volDbPath [Char]
immDbPath = do
  Tracer IO TraceLeiosDb
-> [Char] -> [Char] -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a.
Tracer IO TraceLeiosDb
-> [Char] -> [Char] -> (LeiosDbHandle IO -> IO a) -> IO a
withLeiosDBSQLite Tracer IO TraceLeiosDb
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer [Char]
volDbPath [Char]
immDbPath ((LeiosDbHandle IO -> Assertion) -> Assertion)
-> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
_db -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  HasCallStack => [Char] -> SlotNo -> Assertion
[Char] -> SlotNo -> Assertion
truncateLeiosDbAfterSlot [Char]
immDbPath SlotNo
10
  HasCallStack => [Char] -> Assertion
[Char] -> Assertion
deleteDanglingTxs [Char]
immDbPath

-- * File initialisation

-- | Names of the tables and indexes in a database file.
schemaObjects :: FilePath -> IO [String]
schemaObjects :: [Char] -> IO [[Char]]
schemaObjects [Char]
path =
  IO Database
-> (Database -> Assertion)
-> (Database -> IO [[Char]])
-> IO [[Char]]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Text -> IO Database
SQL.open ([Char] -> Text
T.pack [Char]
path)) Database -> Assertion
SQL.close ((Database -> IO [[Char]]) -> IO [[Char]])
-> (Database -> IO [[Char]]) -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ \Database
db -> do
    Database -> Text -> Assertion
SQL.exec Database
db ([Char] -> Text
T.pack [Char]
"pragma busy_timeout = 1000;")
    IO Statement
-> (Statement -> Assertion)
-> (Statement -> IO [[Char]])
-> IO [[Char]]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      (Database -> Text -> IO Statement
SQL.prepare Database
db ([Char] -> Text
T.pack [Char]
"SELECT name FROM sqlite_master WHERE type IN ('table', 'index')"))
      Statement -> Assertion
SQL.finalize
      ((Statement -> IO [[Char]]) -> IO [[Char]])
-> (Statement -> IO [[Char]]) -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ \Statement
stmt ->
        let loop :: [[Char]] -> IO [[Char]]
loop [[Char]]
acc =
              Statement -> IO StepResult
SQL.step Statement
stmt IO StepResult -> (StepResult -> IO [[Char]]) -> IO [[Char]]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                StepResult
SQL.Row -> Statement -> ColumnIndex -> IO Text
SQL.columnText Statement
stmt ColumnIndex
0 IO Text -> (Text -> IO [[Char]]) -> IO [[Char]]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
name -> [[Char]] -> IO [[Char]]
loop (Text -> [Char]
T.unpack Text
name [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
acc)
                StepResult
SQL.Done -> [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]]
acc
         in [[Char]] -> IO [[Char]]
loop []

test_schemaAtHandleCreation :: FilePath -> FilePath -> IO ()
test_schemaAtHandleCreation :: [Char] -> [Char] -> Assertion
test_schemaAtHandleCreation [Char]
volDbPath [Char]
immDbPath =
  -- No reader or writer is opened: the schema must not depend on one.
  Tracer IO TraceLeiosDb
-> [Char] -> [Char] -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a.
Tracer IO TraceLeiosDb
-> [Char] -> [Char] -> (LeiosDbHandle IO -> IO a) -> IO a
withLeiosDBSQLite Tracer IO TraceLeiosDb
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer [Char]
volDbPath [Char]
immDbPath ((LeiosDbHandle IO -> Assertion) -> Assertion)
-> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
_db -> do
    [[Char]] -> ([Char] -> Assertion) -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]
volDbPath, [Char]
immDbPath] (([Char] -> Assertion) -> Assertion)
-> ([Char] -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \[Char]
path ->
      [Char] -> IO Bool
doesFileExist [Char]
path IO Bool -> (Bool -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => [Char] -> Bool -> Assertion
[Char] -> Bool -> Assertion
assertBool ([Char]
path [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" exists")
    vol <- [Char] -> IO [[Char]]
schemaObjects [Char]
volDbPath
    imm <- schemaObjects immDbPath
    forM_ [(vol, "vol"), (imm, "imm")] $ \([[Char]]
objs, [Char]
file) ->
      [[Char]] -> ([Char] -> Assertion) -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]
"ebs", [Char]
"idx_ebs_ebHashBytes", [Char]
"ebTxs", [Char]
"txs"] (([Char] -> Assertion) -> Assertion)
-> ([Char] -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \[Char]
name ->
        HasCallStack => [Char] -> Bool -> Assertion
[Char] -> Bool -> Assertion
assertBool ([Char]
file [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" has " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
name) ([Char]
name [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
objs)
    forM_
      [ "ebsMissingTxs"
      , "idx_ebsMissingTxs_ebHashBytes"
      , "idx_ebTxs_txHashBytes"
      , "gcTxCandidates"
      , "idx_ebs_sweepable"
      , "idx_ebs_markedForGc"
      , "idx_ebs_pinned"
      ]
      $ \[Char]
name -> do
        HasCallStack => [Char] -> Bool -> Assertion
[Char] -> Bool -> Assertion
assertBool ([Char]
"vol has " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
name) ([Char]
name [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
vol)
        HasCallStack => [Char] -> Bool -> Assertion
[Char] -> Bool -> Assertion
assertBool ([Char]
"imm lacks " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
name) ([Char]
name [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]]
imm)

-- | A file that exists without a schema, as a crash between creating the file
-- and applying the schema leaves it.
test_zeroByteFilesGetSchema :: FilePath -> FilePath -> IO ()
test_zeroByteFilesGetSchema :: [Char] -> [Char] -> Assertion
test_zeroByteFilesGetSchema [Char]
volDbPath [Char]
immDbPath = do
  [Char] -> [Char] -> Assertion
writeFile [Char]
volDbPath [Char]
""
  [Char] -> [Char] -> Assertion
writeFile [Char]
immDbPath [Char]
""
  Tracer IO TraceLeiosDb
-> [Char] -> [Char] -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a.
Tracer IO TraceLeiosDb
-> [Char] -> [Char] -> (LeiosDbHandle IO -> IO a) -> IO a
withLeiosDBSQLite Tracer IO TraceLeiosDb
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer [Char]
volDbPath [Char]
immDbPath ((LeiosDbHandle IO -> Assertion) -> Assertion)
-> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db ->
    LeiosDbHandle IO -> (LeiosDbReader IO -> Assertion) -> Assertion
forall (m :: * -> *) a.
MonadThrow m =>
LeiosDbHandle m -> (LeiosDbReader m -> m a) -> m a
withReader LeiosDbHandle IO
db ((LeiosDbReader IO -> Assertion) -> Assertion)
-> (LeiosDbReader IO -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \LeiosDbReader IO
reader -> do
      points <- LeiosDbReader IO -> HasCallStack => SlotNo -> IO [LeiosPoint]
forall (m :: * -> *).
LeiosDbReader m -> HasCallStack => SlotNo -> m [LeiosPoint]
scanCompleteEbClosuresNotOlderThanSlot LeiosDbReader IO
reader SlotNo
0
      points @?= []

test_reopenKeepsData :: FilePath -> FilePath -> IO ()
test_reopenKeepsData :: [Char] -> [Char] -> Assertion
test_reopenKeepsData [Char]
volDbPath [Char]
immDbPath = do
  let eb :: LeiosEb
eb = Int -> LeiosEb
mkTestEb Int
2
      ebHash :: EbHash
ebHash = Word -> EbHash
mkTestEbHash Word
1
  Tracer IO TraceLeiosDb
-> [Char] -> [Char] -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a.
Tracer IO TraceLeiosDb
-> [Char] -> [Char] -> (LeiosDbHandle IO -> IO a) -> IO a
withLeiosDBSQLite Tracer IO TraceLeiosDb
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer [Char]
volDbPath [Char]
immDbPath ((LeiosDbHandle IO -> Assertion) -> Assertion)
-> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db ->
    LeiosDbHandle IO -> (RW -> Assertion) -> Assertion
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> Assertion) -> Assertion) -> (RW -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \RW
con -> RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con (SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint SlotNo
5 EbHash
ebHash) (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
  Tracer IO TraceLeiosDb
-> [Char] -> [Char] -> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a.
Tracer IO TraceLeiosDb
-> [Char] -> [Char] -> (LeiosDbHandle IO -> IO a) -> IO a
withLeiosDBSQLite Tracer IO TraceLeiosDb
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer [Char]
volDbPath [Char]
immDbPath ((LeiosDbHandle IO -> Assertion) -> Assertion)
-> (LeiosDbHandle IO -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db ->
    LeiosDbHandle IO -> (RW -> Assertion) -> Assertion
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> Assertion) -> Assertion) -> (RW -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
      points <- RW -> IO [(SlotNo, EbHash)]
rwScanEbPoints RW
con
      points @?= [(5, ebHash)]

-- * deleteDanglingTxs

test_deleteDanglingTxs :: FilePath -> FilePath -> LeiosDbHandle IO -> IO ()
test_deleteDanglingTxs :: [Char] -> [Char] -> LeiosDbHandle IO -> Assertion
test_deleteDanglingTxs [Char]
volDbPath [Char]
_immDbPath LeiosDbHandle IO
db = do
  let eb :: LeiosEb
eb = Int -> LeiosEb
mkTestEb Int
2
      ebHash :: EbHash
ebHash = Word -> EbHash
mkTestEbHash Word
1
      danglingTx :: TxHash
danglingTx = Word -> TxHash
mkTestTxHash Word
9
      txBytes :: ByteString
txBytes = Int -> Word8 -> ByteString
BS.replicate Int
10 Word8
0
  LeiosDbHandle IO -> (RW -> Assertion) -> Assertion
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> Assertion) -> Assertion) -> (RW -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con (SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint SlotNo
5 EbHash
ebHash) (LeiosEb -> Word32
encodeLeiosEbSize LeiosEb
eb)
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> LeiosEb -> IO [LeiosPoint]
rwInsertEbBody RW
con (SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint SlotNo
5 EbHash
ebHash) LeiosEb
eb
    IO [LeiosPoint] -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [LeiosPoint] -> Assertion) -> IO [LeiosPoint] -> Assertion
forall a b. (a -> b) -> a -> b
$
      RW -> [(TxHash, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
con ([(TxHash, ByteString)] -> IO [LeiosPoint])
-> [(TxHash, ByteString)] -> IO [LeiosPoint]
forall a b. (a -> b) -> a -> b
$
        (TxHash
danglingTx, ByteString
txBytes) (TxHash, ByteString)
-> [(TxHash, ByteString)] -> [(TxHash, ByteString)]
forall a. a -> [a] -> [a]
: [(TxHash
txHash, ByteString
txBytes) | (TxHash
txHash, Word32
_) <- Vector (TxHash, Word32) -> [(TxHash, Word32)]
forall a. Vector a -> [a]
V.toList (LeiosEb -> Vector (TxHash, Word32)
leiosEbTxs LeiosEb
eb)]

  HasCallStack => [Char] -> Assertion
[Char] -> Assertion
deleteDanglingTxs [Char]
volDbPath

  LeiosDbHandle IO -> (RW -> Assertion) -> Assertion
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW -> Assertion) -> Assertion) -> (RW -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \RW
con -> do
    closure <- RW -> EbHash -> IO (Maybe [(TxHash, ByteString)])
rwLookupEbClosure RW
con EbHash
ebHash
    fmap (map fst) closure @?= Just (map fst (V.toList (leiosEbTxs eb)))
    -- A closure resolves only when the db holds every tx the body names. So
    -- this probe resolves only if the delete missed the dangling tx.
    let probeEb = Vector (TxHash, Word32) -> LeiosEb
MkLeiosEb ([(TxHash, Word32)] -> Vector (TxHash, Word32)
forall a. [a] -> Vector a
V.fromList [(TxHash
danglingTx, Word32
10)])
        probePoint = SlotNo -> EbHash -> LeiosPoint
MkLeiosPoint SlotNo
6 (Word -> EbHash
mkTestEbHash Word
2)
    rwInsertEbPoint con probePoint (encodeLeiosEbSize probeEb)
    void $ rwInsertEbBody con probePoint probeEb
    probeClosure <- rwLookupEbClosure con (pointEbHash probePoint)
    probeClosure @?= Nothing