{-# 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.Crypto.Hash (Hash (UnsafeHash), hashToStringAsHex)
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Concurrent (threadDelay)
import Control.Concurrent.Class.MonadSTM.Strict
  ( StrictTChan
  , atomically
  , readTChan
  , tryReadTChan
  )
import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar)
import Control.DeepSeq (force)
import Control.Exception (bracket, try)
import Control.Monad (forM, forM_, replicateM, void)
import Control.Monad.Class.MonadTime.SI (diffTime, getMonotonicTime)
import Control.Tracer (Tracer (..), emit, nullTracer)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as SBS
import Data.Function ((&))
import Data.List (nub, sortOn)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust)
import qualified Data.Text as T
import Data.Time.Clock (DiffTime)
import qualified Database.SQLite3 as SQL
import Ouroboros.Consensus.Leios.Types
  ( BytesSize
  , EndorserBlock
  , EndorserBlockHash
  , LeiosPoint (..)
  , TxHash
  , TxOffset
  , encodeEndorserBlockSize
  , endorserBlockReferences
  , mkEndorserBlock
  )
import Ouroboros.Consensus.Storage.LeiosDB
  ( CompletedEbs
  , LeiosDbHandle (..)
  , LeiosDbReader (..)
  , LeiosDbWriter (..)
  , LeiosEbNotification (..)
  , Promise (..)
  , TraceLeiosDb (..)
  , newLeiosDBInMemory
  , truncateLeiosDbAfterSlot
  , withLeiosDBSQLite
  , withReader
  , withWriter
  )
import Ouroboros.Consensus.Storage.LeiosDB.Exception (LeiosDbException)
import System.Directory (doesFileExist, removeDirectoryRecursive)
import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory)
import qualified System.Timeout as Timeout
import Test.QuickCheck
  ( Gen
  , Property
  , chooseInt
  , conjoin
  , counterexample
  , elements
  , forAll
  , forAllBlind
  , forAllShrinkShow
  , frequency
  , ioProperty
  , listOf
  , shrink
  , shrinkList
  , sublistOf
  , tabulate
  , vector
  , (===)
  )
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, 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] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"the two implementations agree on what a reader sees" Property
prop_implementationsAgree
         , -- InMemory only: on SQLite a failed write also stops the writer, which
           -- is linked to the thread that opened the database.
           [Char] -> Assertion -> TestTree
testCase [Char]
"InMemory: writing a body for an unwritten point fails, as on SQLite" (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
InMemory LeiosDbHandle IO -> Assertion
test_ebBodyWithoutPointFails
         , -- InMemory only: the SQLite implementation sweeps in the background.
           [Char] -> [TestTree] -> TestTree
testGroup
             [Char]
"InMemory: garbage collection"
             [ [Char] -> Assertion -> TestTree
testCase [Char]
"evicts an EB all of whose points are older, with its txs" (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
InMemory LeiosDbHandle IO -> Assertion
test_gcEvictsOldEb
             , [Char] -> Assertion -> TestTree
testCase [Char]
"keeps an EB with a point at the slot" (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
InMemory LeiosDbHandle IO -> Assertion
test_gcKeepsEbWithPointAtSlot
             , [Char] -> Assertion -> TestTree
testCase [Char]
"keeps a pinned EB" (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
InMemory LeiosDbHandle IO -> Assertion
test_gcKeepsPinnedEb
             , [Char] -> Assertion -> TestTree
testCase [Char]
"promoting an EB whose closure is incomplete fails" (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
InMemory LeiosDbHandle IO -> Assertion
test_promoteIncompleteFails
             ]
         , [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" (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]
"close"
             [ [Char] -> Assertion -> TestTree
testCase [Char]
"returns while an EB stays pinned" Assertion
test_closeWithPinnedEb
             ]
         , [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 -> EndorserBlock -> IO CompletedEbs
rwInsertEbBody :: RW -> LeiosPoint -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
rw LeiosPoint
point EndorserBlock
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 -> EndorserBlock -> IO (Promise IO [LeiosPoint])
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack =>
   LeiosPoint -> EndorserBlock -> m (Promise m [LeiosPoint])
writeEbBody (RW -> LeiosDbWriter IO
rwWriter RW
rw) LeiosPoint
point EndorserBlock
eb

rwInsertTxs :: RW -> LeiosPoint -> [(TxOffset, BS.ByteString)] -> IO CompletedEbs
rwInsertTxs :: RW -> LeiosPoint -> [(Int, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
rw LeiosPoint
point [(Int, 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 =>
   LeiosPoint -> [(Int, ByteString)] -> IO (Promise IO [LeiosPoint])
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack =>
   LeiosPoint -> [(Int, ByteString)] -> m (Promise m [LeiosPoint])
writeTxs (RW -> LeiosDbWriter IO
rwWriter RW
rw) LeiosPoint
point [(Int, ByteString)]
txs

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

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

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

rwBatchRetrieveTxs ::
  RW -> EndorserBlockHash -> [Int] -> IO [(Int, TxHash, Maybe BS.ByteString)]
rwBatchRetrieveTxs :: RW
-> EndorserBlockHash
-> [Int]
-> IO [(Int, TxHash, Maybe ByteString)]
rwBatchRetrieveTxs = LeiosDbReader IO
-> HasCallStack =>
   EndorserBlockHash -> [Int] -> IO [(Int, TxHash, Maybe ByteString)]
LeiosDbReader IO
-> EndorserBlockHash
-> [Int]
-> IO [(Int, TxHash, Maybe ByteString)]
forall (m :: * -> *).
LeiosDbReader m
-> HasCallStack =>
   EndorserBlockHash -> [Int] -> m [(Int, TxHash, Maybe ByteString)]
batchRetrieveTxs (LeiosDbReader IO
 -> EndorserBlockHash
 -> [Int]
 -> IO [(Int, TxHash, Maybe ByteString)])
-> (RW -> LeiosDbReader IO)
-> RW
-> EndorserBlockHash
-> [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] -> Assertion -> TestTree
testCase [Char]
"out of bounds, duplicate and wrong-sized writes are dropped" (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_malformedTxWritesDropped
      ]
  , [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 EndorserBlockHash (32 random bytes).
-- With 256 bits of randomness, collisions are practically impossible.
genEbHash :: Gen EndorserBlockHash
genEbHash :: Gen EndorserBlockHash
genEbHash = ShortByteString -> EndorserBlockHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (ShortByteString -> EndorserBlockHash)
-> ([Word8] -> ShortByteString) -> [Word8] -> EndorserBlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ShortByteString
SBS.pack ([Word8] -> EndorserBlockHash)
-> Gen [Word8] -> Gen EndorserBlockHash
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 = ShortByteString -> TxHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (ShortByteString -> TxHash)
-> ([Word8] -> ShortByteString) -> [Word8] -> TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ShortByteString
SBS.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 -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint (SlotNo -> EndorserBlockHash -> LeiosPoint)
-> Gen SlotNo -> Gen (EndorserBlockHash -> LeiosPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SlotNo
genSlotNo Gen (EndorserBlockHash -> LeiosPoint)
-> Gen EndorserBlockHash -> 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 EndorserBlockHash
genEbHash

-- | Generate a EndorserBlock with the given number of transactions.
genEb :: Int -> Gen EndorserBlock
genEb :: Int -> Gen EndorserBlock
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 $ mkEndorserBlock txs

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

-- | Bytes for the tx at the given offset of the EB: of its declared size, as
-- a write must be to be accepted, and distinct per offset.
txBytesFor :: EndorserBlock -> TxOffset -> BS.ByteString
txBytesFor :: EndorserBlock -> Int -> ByteString
txBytesFor EndorserBlock
eb Int
off = Int -> Word8 -> ByteString
BS.replicate (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off)
 where
  (TxHash
_, Word32
size) = EndorserBlock -> [(TxHash, Word32)]
endorserBlockReferences EndorserBlock
eb [(TxHash, Word32)] -> Int -> (TxHash, Word32)
forall a. HasCallStack => [a] -> Int -> a
!! Int
off

-- | Every tx of the EB, with 'txBytesFor'.
allTxsFor :: EndorserBlock -> [(TxOffset, BS.ByteString)]
allTxsFor :: EndorserBlock -> [(Int, ByteString)]
allTxsFor EndorserBlock
eb = [(Int
off, EndorserBlock -> Int -> ByteString
txBytesFor EndorserBlock
eb Int
off) | Int
off <- [Int
0 .. [(TxHash, Word32)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (EndorserBlock -> [(TxHash, Word32)]
endorserBlockReferences EndorserBlock
eb) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]

-- * Test fixtures for unit tests

-- | Create a simple test EndorserBlockHash from a seed byte.
mkTestEbHash :: Word -> EndorserBlockHash
mkTestEbHash :: Word -> EndorserBlockHash
mkTestEbHash Word
seed = ShortByteString -> EndorserBlockHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (ShortByteString -> EndorserBlockHash)
-> ShortByteString -> EndorserBlockHash
forall a b. (a -> b) -> a -> b
$ [Word8] -> ShortByteString
SBS.pack ([Word8] -> ShortByteString) -> [Word8] -> ShortByteString
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 = ShortByteString -> TxHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (ShortByteString -> TxHash) -> ShortByteString -> TxHash
forall a b. (a -> b) -> a -> b
$ [Word8] -> ShortByteString
SBS.pack ([Word8] -> ShortByteString) -> [Word8] -> ShortByteString
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 -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint SlotNo
slot (Word -> EndorserBlockHash
mkTestEbHash Word
seed)

-- | Create a test EndorserBlock with the given number of transactions.
mkTestEb :: Int -> EndorserBlock
mkTestEb :: Int -> EndorserBlock
mkTestEb Int
numTxs =
  [(TxHash, Word32)] -> EndorserBlock
mkEndorserBlock ([(TxHash, Word32)] -> EndorserBlock)
-> [(TxHash, Word32)] -> EndorserBlock
forall a b. (a -> b) -> a -> b
$
    [ (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 -> EndorserBlockHash
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, EndorserBlock)
-> ((LeiosPoint, EndorserBlock) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int -> Gen (LeiosPoint, EndorserBlock)
genPointAndEb Int
numTxs) (((LeiosPoint, EndorserBlock) -> Property) -> Property)
-> ((LeiosPoint, EndorserBlock) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, EndorserBlock
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 = EndorserBlock -> [(TxHash, Word32)]
endorserBlockReferences EndorserBlock
eb
        RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
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 EndorserBlockHash
-> (EndorserBlockHash -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen EndorserBlockHash
genEbHash ((EndorserBlockHash -> Property) -> Property)
-> (EndorserBlockHash -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \EndorserBlockHash
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 -> EndorserBlockHash -> IO [(TxHash, Word32)]
rwLookupEbBody RW
con EndorserBlockHash
missingHash
      pure $
        result === []
          & tabulate "lookupEbBody (missing)" [timeBucket lookupTime]

-- * Property tests for transactions

-- | Property: inserting tx bytes and retrieving them returns the correct data.
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, EndorserBlock)
-> ((LeiosPoint, EndorserBlock) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (LeiosPoint, EndorserBlock)
genPointAndEb Int
numTxs) (((LeiosPoint, EndorserBlock) -> Property) -> Property)
-> ((LeiosPoint, EndorserBlock) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, EndorserBlock
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 (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
eb
          -- Forced, so that the tabulated insert time excludes building the
          -- bytes.
          let !txsToInsert :: [(Int, ByteString)]
txsToInsert =
                [(Int, ByteString)] -> [(Int, ByteString)]
forall a. NFData a => a -> a
force [(Int
off, EndorserBlock -> Int -> ByteString
txBytesFor EndorserBlock
eb Int
off) | Int
off <- [Int]
offsetsToInsert]
          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 -> LeiosPoint -> [(Int, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
con LeiosPoint
point [(Int, 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 (EndorserBlock -> Int -> ByteString
txBytesFor EndorserBlock
eb Int
off)
                  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 EndorserBlockHash
-> (EndorserBlockHash -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen EndorserBlockHash
genEbHash ((EndorserBlockHash -> Property) -> Property)
-> (EndorserBlockHash -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \EndorserBlockHash
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
-> EndorserBlockHash
-> [Int]
-> IO [(Int, TxHash, Maybe ByteString)]
rwBatchRetrieveTxs RW
con EndorserBlockHash
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 -> EndorserBlock
mkTestEb Int
3
  withRW db $ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
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 -> EndorserBlock
mkTestEb Int
5
  withRW db $ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
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 -> EndorserBlock
mkTestEb Int
10
      expectedSize = EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
eb
  withRW db $ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
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 -> EndorserBlockHash
pointEbHash LeiosPoint
notifPoint EndorserBlockHash -> EndorserBlockHash -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosPoint -> EndorserBlockHash
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 :: EndorserBlock
eb1 = Int -> EndorserBlock
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 (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point1 EndorserBlock
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 -> EndorserBlock
mkTestEb Int
3
  withRW db $ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point2 (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point2 EndorserBlock
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 -> EndorserBlock
mkTestEb Int
i | Int
i <- [Int
1 .. Int
5]]
  -- Insert all (point then body for each)
  withRW db $ \RW
con ->
    [(LeiosPoint, EndorserBlock)]
-> ((LeiosPoint, EndorserBlock) -> Assertion) -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([LeiosPoint] -> [EndorserBlock] -> [(LeiosPoint, EndorserBlock)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LeiosPoint]
points [EndorserBlock]
ebs) (((LeiosPoint, EndorserBlock) -> Assertion) -> Assertion)
-> ((LeiosPoint, EndorserBlock) -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, EndorserBlock
eb) -> do
      RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
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 -> EndorserBlock
mkTestEb Int
3 -- 3 transactions
  withRW db $ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
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
    _ <- rwInsertTxs con point (take 2 (allTxsFor eb))
    -- 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 -> EndorserBlock
mkTestEb Int
3 -- 3 transactions
  withRW db $ \RW
con -> do
    -- Insert the EB (point then body)
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
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
    _ <- rwInsertTxs con point (allTxsFor eb)
    -- 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: in this test specifically, it's for another EB
-- whose closure they complete.
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 -> EndorserBlock
mkTestEb Int
2
      otherPoint = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
2) Word
2
      otherEb = Int -> EndorserBlock
mkTestEb Int
3
  withRW db $ \RW
con -> do
    -- Insert and complete the EB
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
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"
    _ <- rwInsertTxs con point (allTxsFor eb)
    -- 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"
    -- Complete an unrelated EB
    rwInsertEbPoint con otherPoint (encodeEndorserBlockSize otherEb)
    void $ rwInsertEbBody con otherPoint otherEb
    completed <- rwInsertTxs con otherPoint (allTxsFor otherEb)
    completed @?= [otherPoint]
    -- Only the unrelated EB is notified, not the already-completed one again
    notifs <- drainChan chan
    [p | AcquiredEbTxs p <- notifs] @?= [otherPoint]

-- | 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 -> EndorserBlock
mkTestEb Int
2
  withRW db $ \RW
con -> do
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
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.
    _ <- rwInsertTxs con point (allTxsFor eb)
    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.
    completed <- rwInsertTxs con point (take 1 (allTxsFor eb))
    completed @?= []
    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"

-- | 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 -> EndorserBlock
mkTestEb Int
2 -- same content at both points (deterministic from numTxs)
      drainNotifications = StrictTChan IO LeiosEbNotification -> IO [LeiosEbNotification]
drainChan StrictTChan IO LeiosEbNotification
chan
  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 (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
eb)
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point2 (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point1 EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point2 EndorserBlock
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, naming only one of its points. The
    -- tx bytes belong to the EB, not to a point, so the closure completes for
    -- both points.
    completed <- rwInsertTxs con point1 (allTxsFor eb)
    -- The write returns both points ...
    completed `setEquals` [point1, point2]
    -- ... and notifies each completion, once.
    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]

-- | A body can only be written for a point already written, by 'writeEbPoint'
-- on the announcement path.
test_ebBodyWithoutPointFails :: LeiosDbHandle IO -> IO ()
test_ebBodyWithoutPointFails :: LeiosDbHandle IO -> Assertion
test_ebBodyWithoutPointFails 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
  result <- IO [LeiosPoint] -> IO (Either LeiosDbException [LeiosPoint])
forall a. IO a -> IO (Either LeiosDbException a)
tryDb (IO [LeiosPoint] -> IO (Either LeiosDbException [LeiosPoint]))
-> IO [LeiosPoint] -> IO (Either LeiosDbException [LeiosPoint])
forall a b. (a -> b) -> a -> b
$ RW -> LeiosPoint -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con (SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
1) Word
1) (Int -> EndorserBlock
mkTestEb Int
2)
  case result of
    Left LeiosDbException
_ -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Right [LeiosPoint]
_ -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"writeEbBody succeeded for a point that was never written"
 where
  tryDb :: IO a -> IO (Either LeiosDbException a)
  tryDb :: forall a. IO a -> IO (Either LeiosDbException a)
tryDb = IO a -> IO (Either LeiosDbException a)
forall e a. Exception e => IO a -> IO (Either e a)
try

-- | A tx write only fills a tx the body declares, once, at its declared size.
-- Anything else changes nothing and completes nothing.
--
-- Neither the LeiosDB nor this test requires the bytes to hash to the body's
-- tx hash: the LeiosDB assumes that its caller checked that.
test_malformedTxWritesDropped :: LeiosDbHandle IO -> IO ()
test_malformedTxWritesDropped :: LeiosDbHandle IO -> Assertion
test_malformedTxWritesDropped LeiosDbHandle IO
db = do
  let point :: LeiosPoint
point = SlotNo -> Word -> LeiosPoint
mkTestPoint (Word64 -> SlotNo
SlotNo Word64
1) Word
1
      eb :: EndorserBlock
eb = Int -> EndorserBlock
mkTestEb Int
2
      offsets :: [Int]
offsets = [Int
0, Int
1]
  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
point (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
eb
    -- An offset the body does not declare, and wrong-sized bytes.
    dropped <-
      RW -> LeiosPoint -> [(Int, ByteString)] -> IO [LeiosPoint]
rwInsertTxs
        RW
con
        LeiosPoint
point
        [ (Int
2, EndorserBlock -> Int -> ByteString
txBytesFor EndorserBlock
eb Int
0)
        , (Int
0, ByteString -> Word8 -> ByteString
BS.snoc (EndorserBlock -> Int -> ByteString
txBytesFor EndorserBlock
eb Int
0) Word8
0)
        , (Int
1, Int -> ByteString -> ByteString
BS.take Int
1 (EndorserBlock -> Int -> ByteString
txBytesFor EndorserBlock
eb Int
1))
        ]
    dropped @?= []
    retrieved <- rwBatchRetrieveTxs con (pointEbHash point) offsets
    [bytes | (_, _, bytes) <- retrieved] @?= [Nothing, Nothing]
    -- A duplicate delivery keeps the first bytes and does not count twice.
    first <- rwInsertTxs con point [(0, txBytesFor eb 0)]
    first @?= []
    duplicate <- rwInsertTxs con point [(0, BS.map (+ 1) (txBytesFor eb 0))]
    duplicate @?= []
    retrieved' <- rwBatchRetrieveTxs con (pointEbHash point) [0]
    [bytes | (_, _, bytes) <- retrieved'] @?= [Just (txBytesFor eb 0)]
    completed <- rwInsertTxs con point [(1, txBytesFor eb 1)]
    completed @?= [point]

-- | Every notification queued on the channel, in order.
drainChan :: StrictTChan IO LeiosEbNotification -> IO [LeiosEbNotification]
drainChan :: StrictTChan IO LeiosEbNotification -> IO [LeiosEbNotification]
drainChan StrictTChan IO LeiosEbNotification
chan = [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)

-- * Garbage collection

-- | Write the EB at these points, with its body and all its transactions.
writeWholeEb :: RW -> [LeiosPoint] -> EndorserBlock -> IO ()
writeWholeEb :: RW -> [LeiosPoint] -> EndorserBlock -> Assertion
writeWholeEb RW
con [LeiosPoint]
points EndorserBlock
eb = do
  [LeiosPoint] -> (LeiosPoint -> Assertion) -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [LeiosPoint]
points ((LeiosPoint -> Assertion) -> Assertion)
-> (LeiosPoint -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \LeiosPoint
point -> RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
eb)
  [LeiosPoint] -> (LeiosPoint -> Assertion) -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [LeiosPoint]
points ((LeiosPoint -> Assertion) -> Assertion)
-> (LeiosPoint -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \LeiosPoint
point -> 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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
eb
  [LeiosPoint] -> (LeiosPoint -> Assertion) -> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int -> [LeiosPoint] -> [LeiosPoint]
forall a. Int -> [a] -> [a]
take Int
1 [LeiosPoint]
points) ((LeiosPoint -> Assertion) -> Assertion)
-> (LeiosPoint -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \LeiosPoint
point -> 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 -> [(Int, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
con LeiosPoint
point (EndorserBlock -> [(Int, ByteString)]
allTxsFor EndorserBlock
eb)

-- | Whether the reader sees the EB's whole closure.
holdsClosure :: RW -> EndorserBlockHash -> IO Bool
holdsClosure :: RW -> EndorserBlockHash -> IO Bool
holdsClosure RW
con EndorserBlockHash
ebHash = Maybe [(TxHash, ByteString)] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [(TxHash, ByteString)] -> Bool)
-> IO (Maybe [(TxHash, ByteString)]) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RW -> EndorserBlockHash -> IO (Maybe [(TxHash, ByteString)])
rwLookupEbClosure RW
con EndorserBlockHash
ebHash

test_gcEvictsOldEb :: LeiosDbHandle IO -> IO ()
test_gcEvictsOldEb :: LeiosDbHandle IO -> Assertion
test_gcEvictsOldEb 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
  -- The old EB references transactions 0, 1 and 2, and the other only 0 and 1.
  RW -> [LeiosPoint] -> EndorserBlock -> Assertion
writeWholeEb RW
con [SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
5 Word
1] (Int -> EndorserBlock
mkTestEb Int
3)
  RW -> [LeiosPoint] -> EndorserBlock -> Assertion
writeWholeEb RW
con [SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
10 Word
2] (Int -> EndorserBlock
mkTestEb Int
2)
  LeiosDbHandle IO -> HasCallStack => SlotNo -> Assertion
forall (m :: * -> *).
LeiosDbHandle m -> HasCallStack => SlotNo -> m ()
garbageCollect LeiosDbHandle IO
db SlotNo
6
  RW -> EndorserBlockHash -> IO [(TxHash, Word32)]
rwLookupEbBody RW
con (Word -> EndorserBlockHash
mkTestEbHash Word
1) IO [(TxHash, Word32)]
-> ([(TxHash, Word32)] -> 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
>>= ([(TxHash, Word32)] -> [(TxHash, Word32)] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [])
  RW -> EndorserBlockHash -> IO Bool
holdsClosure RW
con (Word -> EndorserBlockHash
mkTestEbHash Word
1) 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
>>= (Bool -> Bool -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
False)
  RW -> IO [(SlotNo, EndorserBlockHash)]
rwScanEbPoints RW
con IO [(SlotNo, EndorserBlockHash)]
-> ([(SlotNo, EndorserBlockHash)] -> 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
>>= ([(SlotNo, EndorserBlockHash)]
-> [(SlotNo, EndorserBlockHash)] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [(SlotNo
10, Word -> EndorserBlockHash
mkTestEbHash Word
2)])
  RW -> EndorserBlockHash -> IO Bool
holdsClosure RW
con (Word -> EndorserBlockHash
mkTestEbHash Word
2) 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
>>= (Bool -> Bool -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
True)
  -- The old EB's transactions went with it, so a new EB referencing them
  -- lacks them.
  RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con (SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
20 Word
3) (EndorserBlock -> Word32
encodeEndorserBlockSize (Int -> EndorserBlock
mkTestEb Int
3))
  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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con (SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
20 Word
3) (Int -> EndorserBlock
mkTestEb Int
3)
  RW -> EndorserBlockHash -> IO Bool
holdsClosure RW
con (Word -> EndorserBlockHash
mkTestEbHash Word
3) 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
>>= (Bool -> Bool -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
False)

test_gcKeepsEbWithPointAtSlot :: LeiosDbHandle IO -> IO ()
test_gcKeepsEbWithPointAtSlot :: LeiosDbHandle IO -> Assertion
test_gcKeepsEbWithPointAtSlot 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
  RW -> [LeiosPoint] -> EndorserBlock -> Assertion
writeWholeEb RW
con [SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
5 Word
1, SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
6 Word
1] (Int -> EndorserBlock
mkTestEb Int
2)
  LeiosDbHandle IO -> HasCallStack => SlotNo -> Assertion
forall (m :: * -> *).
LeiosDbHandle m -> HasCallStack => SlotNo -> m ()
garbageCollect LeiosDbHandle IO
db SlotNo
6
  RW -> EndorserBlockHash -> IO Bool
holdsClosure RW
con (Word -> EndorserBlockHash
mkTestEbHash Word
1) 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
>>= (Bool -> Bool -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
True)

test_gcKeepsPinnedEb :: LeiosDbHandle IO -> IO ()
test_gcKeepsPinnedEb :: LeiosDbHandle IO -> Assertion
test_gcKeepsPinnedEb 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
  RW -> [LeiosPoint] -> EndorserBlock -> Assertion
writeWholeEb RW
con [SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
5 Word
1] (Int -> EndorserBlock
mkTestEb Int
2)
  LeiosDbHandle IO -> HasCallStack => [LeiosPoint] -> Assertion
forall (m :: * -> *).
LeiosDbHandle m -> HasCallStack => [LeiosPoint] -> m ()
leiosDbPromoteToImmutable LeiosDbHandle IO
db [SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
5 Word
1]
  LeiosDbHandle IO -> HasCallStack => SlotNo -> Assertion
forall (m :: * -> *).
LeiosDbHandle m -> HasCallStack => SlotNo -> m ()
garbageCollect LeiosDbHandle IO
db SlotNo
6
  RW -> EndorserBlockHash -> IO Bool
holdsClosure RW
con (Word -> EndorserBlockHash
mkTestEbHash Word
1) 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
>>= (Bool -> Bool -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
True)

test_promoteIncompleteFails :: LeiosDbHandle IO -> IO ()
test_promoteIncompleteFails :: LeiosDbHandle IO -> Assertion
test_promoteIncompleteFails 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
  RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con (SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
5 Word
1) (EndorserBlock -> Word32
encodeEndorserBlockSize (Int -> EndorserBlock
mkTestEb Int
2))
  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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con (SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
5 Word
1) (Int -> EndorserBlock
mkTestEb Int
2)
  result <- Assertion -> IO (Either LeiosDbException ())
forall a. IO a -> IO (Either LeiosDbException a)
tryDb (Assertion -> IO (Either LeiosDbException ()))
-> Assertion -> IO (Either LeiosDbException ())
forall a b. (a -> b) -> a -> b
$ LeiosDbHandle IO -> HasCallStack => [LeiosPoint] -> Assertion
forall (m :: * -> *).
LeiosDbHandle m -> HasCallStack => [LeiosPoint] -> m ()
leiosDbPromoteToImmutable LeiosDbHandle IO
db [SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
5 Word
1]
  case result of
    Left LeiosDbException
_ -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Right () -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"promoting an EB whose closure is incomplete succeeded"
 where
  tryDb :: IO a -> IO (Either LeiosDbException a)
  tryDb :: forall a. IO a -> IO (Either LeiosDbException a)
tryDb = IO a -> IO (Either LeiosDbException a)
forall e a. Exception e => IO a -> IO (Either e a)
try

-- * 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, EndorserBlock)
-> ((LeiosPoint, EndorserBlock) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (LeiosPoint, EndorserBlock)
genPointAndEb Int
numTxs) (((LeiosPoint, EndorserBlock) -> Property) -> Property)
-> ((LeiosPoint, EndorserBlock) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, EndorserBlock
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 (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
eb
        _ <- RW -> LeiosPoint -> [(Int, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
con LeiosPoint
point (EndorserBlock -> [(Int, ByteString)]
allTxsFor EndorserBlock
eb)
        (result, queryTime) <- timed $ rwLookupEbClosure con (pointEbHash point)
        let expected =
              [ (TxHash
txHash, EndorserBlock -> Int -> ByteString
txBytesFor EndorserBlock
eb Int
off)
              | (Int
off, (TxHash
txHash, Word32
_size)) <- [Int] -> [(TxHash, Word32)] -> [(Int, (TxHash, Word32))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (EndorserBlock -> [(TxHash, Word32)]
endorserBlockReferences EndorserBlock
eb)
              ]
        pure $
          result === Just expected
            & 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, EndorserBlock)
-> ((LeiosPoint, EndorserBlock) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (LeiosPoint, EndorserBlock)
genPointAndEb Int
numTxs) (((LeiosPoint, EndorserBlock) -> Property) -> Property)
-> ((LeiosPoint, EndorserBlock) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, EndorserBlock
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 (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
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 -> EndorserBlockHash -> IO (Maybe [(TxHash, ByteString)])
rwLookupEbClosure RW
con (LeiosPoint -> EndorserBlockHash
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, EndorserBlock)
-> ((LeiosPoint, EndorserBlock) -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind (Int -> Gen (LeiosPoint, EndorserBlock)
genPointAndEb Int
numTxs) (((LeiosPoint, EndorserBlock) -> Property) -> Property)
-> ((LeiosPoint, EndorserBlock) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, EndorserBlock
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 (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con LeiosPoint
point EndorserBlock
eb
        -- Insert only the first half of txs, leaving at least one missing
        let txsToInsert :: [(Int, ByteString)]
txsToInsert = Int -> [(Int, ByteString)] -> [(Int, ByteString)]
forall a. Int -> [a] -> [a]
take (Int
numTxs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (EndorserBlock -> [(Int, ByteString)]
allTxsFor EndorserBlock
eb)
        _ <- RW -> LeiosPoint -> [(Int, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
con LeiosPoint
point [(Int, 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 -> EndorserBlockHash -> IO (Maybe [(TxHash, ByteString)])
rwLookupEbClosure RW
con (LeiosPoint -> EndorserBlockHash
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 :: EndorserBlock
eb = Int -> EndorserBlock
mkTestEb Int
2
      keptHash :: EndorserBlockHash
keptHash = Word -> EndorserBlockHash
mkTestEbHash Word
1
      droppedHash :: EndorserBlockHash
droppedHash = Word -> EndorserBlockHash
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 -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint SlotNo
5 EndorserBlockHash
keptHash) (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con (SlotNo -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint SlotNo
5 EndorserBlockHash
keptHash) EndorserBlock
eb
    -- The kept EB is announced again at a slot the truncation drops.
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con (SlotNo -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint SlotNo
15 EndorserBlockHash
keptHash) (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
eb)
    RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
con (SlotNo -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint SlotNo
15 EndorserBlockHash
droppedHash) (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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 -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
con (SlotNo -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint SlotNo
15 EndorserBlockHash
droppedHash) EndorserBlock
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 -> [(Int, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
con (SlotNo -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint SlotNo
5 EndorserBlockHash
keptHash) (EndorserBlock -> [(Int, ByteString)]
allTxsFor EndorserBlock
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 -> [(Int, ByteString)] -> IO [LeiosPoint]
rwInsertTxs RW
con (SlotNo -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint SlotNo
15 EndorserBlockHash
droppedHash) (EndorserBlock -> [(Int, ByteString)]
allTxsFor EndorserBlock
eb)

  HasCallStack => [Char] -> SlotNo -> Assertion
[Char] -> SlotNo -> Assertion
truncateLeiosDbAfterSlot [Char]
volDbPath SlotNo
10
  [Char] -> EndorserBlockHash -> IO Int
ebTxBytesRows [Char]
volDbPath EndorserBlockHash
droppedHash IO Int -> (Int -> 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
>>= (Int -> Int -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Int
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
    points <- RW -> IO [(SlotNo, EndorserBlockHash)]
rwScanEbPoints RW
con
    points @?= [(5, keptHash)]
    keptBody <- rwLookupEbBody con keptHash
    keptBody @?= endorserBlockReferences eb
    droppedBody <- rwLookupEbBody con droppedHash
    droppedBody @?= []
    keptClosure <- rwLookupEbClosure con keptHash
    fmap (map snd) keptClosure @?= Just (map snd (allTxsFor eb))

-- | The immutable schema lacks the volatile-only columns and indexes; 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

-- * 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]
"ebTxBytes"] (([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_
      [ "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 :: EndorserBlock
eb = Int -> EndorserBlock
mkTestEb Int
2
      ebHash :: EndorserBlockHash
ebHash = Word -> EndorserBlockHash
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 -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint SlotNo
5 EndorserBlockHash
ebHash) (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
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, EndorserBlockHash)]
rwScanEbPoints RW
con
      points @?= [(5, ebHash)]

-- | Open a database file on a connection of its own.
withSqlFile :: FilePath -> (SQL.Database -> IO a) -> IO a
withSqlFile :: forall a. [Char] -> (Database -> IO a) -> IO a
withSqlFile [Char]
path Database -> IO a
k =
  IO Database
-> (Database -> Assertion) -> (Database -> IO a) -> IO a
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 a) -> IO a) -> (Database -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Database
sql -> do
    Database -> Text -> Assertion
SQL.exec Database
sql ([Char] -> Text
T.pack [Char]
"pragma busy_timeout = 1000;")
    Database -> IO a
k Database
sql

-- | An EB hash as an SQL blob literal.
sqlBlob :: EndorserBlockHash -> String
sqlBlob :: EndorserBlockHash -> [Char]
sqlBlob EndorserBlockHash
ebHash = [Char]
"x'" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> EndorserBlockHash -> [Char]
forall h a. Hash h a -> [Char]
hashToStringAsHex EndorserBlockHash
ebHash [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"'"

-- | How many 'ebTxBytes' rows the file holds for the EB.
ebTxBytesRows :: FilePath -> EndorserBlockHash -> IO Int
ebTxBytesRows :: [Char] -> EndorserBlockHash -> IO Int
ebTxBytesRows [Char]
path EndorserBlockHash
ebHash =
  [Char] -> (Database -> IO Int) -> IO Int
forall a. [Char] -> (Database -> IO a) -> IO a
withSqlFile [Char]
path ((Database -> IO Int) -> IO Int) -> (Database -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Database
sql ->
    Database -> Text -> (Statement -> IO Int) -> IO Int
forall a. Database -> Text -> (Statement -> IO a) -> IO a
SQL.withStatement
      Database
sql
      ([Char] -> Text
T.pack ([Char]
"SELECT COUNT(*) FROM ebTxBytes WHERE ebHashBytes = " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> EndorserBlockHash -> [Char]
sqlBlob EndorserBlockHash
ebHash))
      ((Statement -> IO Int) -> IO Int)
-> (Statement -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Statement
stmt ->
        Statement -> IO StepResult
SQL.step Statement
stmt IO StepResult -> IO Int -> IO Int
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> IO Int64 -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Statement -> ColumnIndex -> IO Int64
SQL.columnInt64 Statement
stmt ColumnIndex
0

-- | A pinned EB whose tx closure never arrives cannot be copied, so the
-- copier keeps retrying it for as long as the database is open. 'close' must
-- still return.
test_closeWithPinnedEb :: Assertion
test_closeWithPinnedEb :: Assertion
test_closeWithPinnedEb =
  ([Char] -> [Char] -> Assertion) -> Assertion
forall a. ([Char] -> [Char] -> IO a) -> IO a
withTempLeiosDbPaths (([Char] -> [Char] -> Assertion) -> Assertion)
-> ([Char] -> [Char] -> Assertion) -> Assertion
forall a b. (a -> b) -> a -> b
$ \[Char]
volDbPath [Char]
immDbPath -> do
    copyFailed <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    let
      -- The copier traces one of these per pass that cannot retire the pin.
      -- Waiting for the first one leaves the copier on the retry path, which
      -- is the case a stop check on the idle wait alone does not reach.
      tracer = TracerA IO TraceLeiosDb () -> Tracer IO TraceLeiosDb
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
Tracer (TracerA IO TraceLeiosDb () -> Tracer IO TraceLeiosDb)
-> ((TraceLeiosDb -> Assertion) -> TracerA IO TraceLeiosDb ())
-> (TraceLeiosDb -> Assertion)
-> Tracer IO TraceLeiosDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TraceLeiosDb -> Assertion) -> TracerA IO TraceLeiosDb ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
emit ((TraceLeiosDb -> Assertion) -> Tracer IO TraceLeiosDb)
-> (TraceLeiosDb -> Assertion) -> Tracer IO TraceLeiosDb
forall a b. (a -> b) -> a -> b
$ \case
        TraceLeiosDbCopyError{} -> IO Bool -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> Assertion) -> IO Bool -> Assertion
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
copyFailed ()
        TraceLeiosDb
_ -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      point = SlotNo -> Word -> LeiosPoint
mkTestPoint SlotNo
5 Word
1
    closed <-
      Timeout.timeout closeTimeoutMicros $
        withLeiosDBSQLite tracer volDbPath immDbPath $ \LeiosDbHandle IO
db -> do
          -- The body never lands, so the closure stays incomplete and every
          -- attempt to copy this EB fails.
          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 LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize (Int -> EndorserBlock
mkTestEb Int
2))
          LeiosDbHandle IO -> HasCallStack => [LeiosPoint] -> Assertion
forall (m :: * -> *).
LeiosDbHandle m -> HasCallStack => [LeiosPoint] -> m ()
leiosDbPromoteToImmutable LeiosDbHandle IO
db [LeiosPoint
point]
          MVar () -> Assertion
forall a. MVar a -> IO a
takeMVar MVar ()
copyFailed
    case closed of
      Maybe ()
Nothing -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"close did not return while an EB stayed pinned"
      Just () -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  closeTimeoutMicros :: Int
closeTimeoutMicros = Int
30_000_000

-- * The two implementations agree

-- | An operation on the database: a write, or what the ChainDB has it do as
-- blocks become immutable.
data Op
  = OpPoint LeiosPoint
  | OpBody LeiosPoint
  | OpTxs LeiosPoint [TxOffset]
  | OpPromote EndorserBlockHash
  | OpGc SlotNo
  deriving Int -> Op -> [Char] -> [Char]
[Op] -> [Char] -> [Char]
Op -> [Char]
(Int -> Op -> [Char] -> [Char])
-> (Op -> [Char]) -> ([Op] -> [Char] -> [Char]) -> Show Op
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Op -> [Char] -> [Char]
showsPrec :: Int -> Op -> [Char] -> [Char]
$cshow :: Op -> [Char]
show :: Op -> [Char]
$cshowList :: [Op] -> [Char] -> [Char]
showList :: [Op] -> [Char] -> [Char]
Show

-- | What each endorser block's body is, by its hash, with the index in the
-- pool of each transaction it references: the same hash always names the same
-- body, as it would on the wire.
type Bodies = Map.Map EndorserBlockHash (EndorserBlock, [Int])

-- | Property: running the same operations against both implementations, a
-- reader sees the same in each, and each write completes the same endorser
-- blocks.
--
-- The node runs on SQLite and its tests run on the in-memory implementation, so
-- those tests say something about the node only as far as the two agree.
--
-- The SQLite implementation copies pinned endorser blocks and sweeps what the
-- garbage collection marked in the background, so how far it has got at any
-- moment depends on its load. The in-memory implementation does both at once.
-- So the SQLite implementation's background work catches up after each
-- operation, before the next.
prop_implementationsAgree :: Property
prop_implementationsAgree :: Property
prop_implementationsAgree =
  Gen Bodies -> (Bodies -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Bodies
genBodies ((Bodies -> Property) -> Property)
-> (Bodies -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Bodies
bodies ->
    Gen [Op]
-> ([Op] -> [[Op]])
-> ([Op] -> [Char])
-> ([Op] -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> [Char]) -> (a -> prop) -> Property
forAllShrinkShow (Bodies -> Gen [Op]
genOps Bodies
bodies) ((Op -> [Op]) -> [Op] -> [[Op]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([Op] -> Op -> [Op]
forall a b. a -> b -> a
const [])) [Op] -> [Char]
forall a. Show a => a -> [Char]
show (([Op] -> Property) -> Property) -> ([Op] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[Op]
ops ->
      IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
        ((nPinned, nEvicted), inMemory) <-
          DbImpl
-> (LeiosDbHandle IO
    -> IO
         ((Int, Int),
          ([[LeiosPoint]],
           [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
             [(Int, TxHash, Maybe ByteString)])])))
-> IO
     ((Int, Int),
      ([[LeiosPoint]],
       [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
         [(Int, TxHash, Maybe ByteString)])]))
forall a. DbImpl -> (LeiosDbHandle IO -> IO a) -> IO a
withFreshDb DbImpl
InMemory ((LeiosDbHandle IO
  -> IO
       ((Int, Int),
        ([[LeiosPoint]],
         [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
           [(Int, TxHash, Maybe ByteString)])])))
 -> IO
      ((Int, Int),
       ([[LeiosPoint]],
        [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
          [(Int, TxHash, Maybe ByteString)])])))
-> (LeiosDbHandle IO
    -> IO
         ((Int, Int),
          ([[LeiosPoint]],
           [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
             [(Int, TxHash, Maybe ByteString)])])))
-> IO
     ((Int, Int),
      ([[LeiosPoint]],
       [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
         [(Int, TxHash, Maybe ByteString)])]))
forall a b. (a -> b) -> a -> b
$ \LeiosDbHandle IO
db -> LeiosDbHandle IO
-> Assertion
-> Bodies
-> [Op]
-> IO
     ((Int, Int),
      ([[LeiosPoint]],
       [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
         [(Int, TxHash, Maybe ByteString)])]))
observe LeiosDbHandle IO
db (() -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Bodies
bodies [Op]
ops
        (_, sqlite) <-
          withFreshSQLiteFile $ \[Char]
volDbPath [Char]
_immDbPath LeiosDbHandle IO
db ->
            [Char]
-> (Assertion
    -> IO
         ((Int, Int),
          ([[LeiosPoint]],
           [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
             [(Int, TxHash, Maybe ByteString)])])))
-> IO
     ((Int, Int),
      ([[LeiosPoint]],
       [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
         [(Int, TxHash, Maybe ByteString)])]))
forall a. [Char] -> (Assertion -> IO a) -> IO a
withSettle [Char]
volDbPath ((Assertion
  -> IO
       ((Int, Int),
        ([[LeiosPoint]],
         [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
           [(Int, TxHash, Maybe ByteString)])])))
 -> IO
      ((Int, Int),
       ([[LeiosPoint]],
        [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
          [(Int, TxHash, Maybe ByteString)])])))
-> (Assertion
    -> IO
         ((Int, Int),
          ([[LeiosPoint]],
           [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
             [(Int, TxHash, Maybe ByteString)])])))
-> IO
     ((Int, Int),
      ([[LeiosPoint]],
       [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
         [(Int, TxHash, Maybe ByteString)])]))
forall a b. (a -> b) -> a -> b
$ \Assertion
settle -> LeiosDbHandle IO
-> Assertion
-> Bodies
-> [Op]
-> IO
     ((Int, Int),
      ([[LeiosPoint]],
       [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
         [(Int, TxHash, Maybe ByteString)])]))
observe LeiosDbHandle IO
db Assertion
settle Bodies
bodies [Op]
ops
        pure $
          tabulate "endorser blocks pinned" [bucket nPinned] $
            tabulate "endorser blocks evicted" [bucket nEvicted] $
              inMemory === sqlite
 where
  bucket :: a -> [Char]
bucket a
n = if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
3 then [Char]
"3+" else a -> [Char]
forall a. Show a => a -> [Char]
show a
n

-- | Three endorser blocks over a pool of eight transactions. Sometimes a
-- reference misstates its transaction's size.
genBodies :: Gen Bodies
genBodies :: Gen Bodies
genBodies =
  ([(EndorserBlockHash, (EndorserBlock, [Int]))] -> Bodies)
-> Gen [(EndorserBlockHash, (EndorserBlock, [Int]))] -> Gen Bodies
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(EndorserBlockHash, (EndorserBlock, [Int]))] -> Bodies
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Gen [(EndorserBlockHash, (EndorserBlock, [Int]))] -> Gen Bodies)
-> Gen [(EndorserBlockHash, (EndorserBlock, [Int]))] -> Gen Bodies
forall a b. (a -> b) -> a -> b
$
    [Word]
-> (Word -> Gen (EndorserBlockHash, (EndorserBlock, [Int])))
-> Gen [(EndorserBlockHash, (EndorserBlock, [Int]))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Word
1 .. Word
3] ((Word -> Gen (EndorserBlockHash, (EndorserBlock, [Int])))
 -> Gen [(EndorserBlockHash, (EndorserBlock, [Int]))])
-> (Word -> Gen (EndorserBlockHash, (EndorserBlock, [Int])))
-> Gen [(EndorserBlockHash, (EndorserBlock, [Int]))]
forall a b. (a -> b) -> a -> b
$ \Word
seed -> do
      indices <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int
4) Gen Int -> (Int -> Gen [Int]) -> Gen [Int]
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
n -> Int -> Gen Int -> Gen [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n ((Int, Int) -> Gen Int
chooseInt (Int
1, Int
8))
      refs <- forM indices $ \Int
i -> do
        let size :: Word32
size = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length (Int -> ByteString
poolTxBytes Int
i))
        misstate <- [(Int, Gen Bool)] -> Gen Bool
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
9, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False), (Int
1, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)]
        pure (mkTestTxHash (fromIntegral i), if misstate then size + 1 else size)
      pure (mkTestEbHash seed, (mkEndorserBlock refs, indices))

-- | Writes, with tx offsets up to one past the largest body, so that some are
-- not in the body they are written for.
genOps :: Bodies -> Gen [Op]
genOps :: Bodies -> Gen [Op]
genOps Bodies
bodies = Gen Op -> Gen [Op]
forall a. Gen a -> Gen [a]
listOf Gen Op
genOp
 where
  genSlot :: Gen SlotNo
genSlot = 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
1, Int
4)
  genPointOf :: Gen LeiosPoint
genPointOf = SlotNo -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint (SlotNo -> EndorserBlockHash -> LeiosPoint)
-> Gen SlotNo -> Gen (EndorserBlockHash -> LeiosPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SlotNo
genSlot Gen (EndorserBlockHash -> LeiosPoint)
-> Gen EndorserBlockHash -> 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
<*> [EndorserBlockHash] -> Gen EndorserBlockHash
forall a. HasCallStack => [a] -> Gen a
elements (Bodies -> [EndorserBlockHash]
forall k a. Map k a -> [k]
Map.keys Bodies
bodies)
  genOp :: Gen Op
genOp =
    [(Int, Gen Op)] -> Gen Op
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
2, LeiosPoint -> Op
OpPoint (LeiosPoint -> Op) -> Gen LeiosPoint -> Gen Op
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen LeiosPoint
genPointOf)
      , (Int
2, LeiosPoint -> Op
OpBody (LeiosPoint -> Op) -> Gen LeiosPoint -> Gen Op
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen LeiosPoint
genPointOf)
      , (Int
3, LeiosPoint -> [Int] -> Op
OpTxs (LeiosPoint -> [Int] -> Op) -> Gen LeiosPoint -> Gen ([Int] -> Op)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen LeiosPoint
genPointOf Gen ([Int] -> Op) -> Gen [Int] -> Gen Op
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 [Int]
forall a. [a] -> Gen [a]
sublistOf [Int
0 .. Int
4])
      , (Int
3, EndorserBlockHash -> Op
OpPromote (EndorserBlockHash -> Op) -> Gen EndorserBlockHash -> Gen Op
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [EndorserBlockHash] -> Gen EndorserBlockHash
forall a. HasCallStack => [a] -> Gen a
elements (Bodies -> [EndorserBlockHash]
forall k a. Map k a -> [k]
Map.keys Bodies
bodies))
      , (Int
1, SlotNo -> Op
OpGc (SlotNo -> Op) -> (SlotNo -> SlotNo) -> SlotNo -> Op
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1) (SlotNo -> Op) -> Gen SlotNo -> Gen Op
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SlotNo
genSlot)
      ]

-- | A transaction's bytes, by its index in the pool.
poolTxBytes :: Int -> BS.ByteString
poolTxBytes :: Int -> ByteString
poolTxBytes Int
i = Int -> Word8 -> ByteString
BS.replicate (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

-- | Run the operations, then read back everything a reader can see of each
-- endorser block. Also how many endorser blocks the operations pinned and
-- evicted.
--
-- The operations run only as far as they meet the node's own preconditions: a
-- body is written once per point, for a point the database holds; and an
-- endorser block is promoted only with a complete closure, as the node pins
-- only what an immutable block certifies, and its ChainSel adopts a block
-- certifying an endorser block only once it holds that endorser block's
-- closure. So this tracks which points and
-- bodies the garbage collection evicts: those of every endorser block all of
-- whose points are older than its slot, pinned or not, since a pinned one has
-- a complete closure, so has been copied.
--
-- An endorser block is also promoted at most once: the node pins only what the
-- immutable chain certifies, and a chain cannot certify the same endorser
-- block twice, since it cannot be valid twice.
--
-- @settle@ runs after each operation.
observe ::
  LeiosDbHandle IO ->
  IO () ->
  Bodies ->
  [Op] ->
  IO
    ( (Int, Int)
    , ( [CompletedEbs]
      , [ ( [(TxHash, BytesSize)]
          , Maybe [(TxHash, BS.ByteString)]
          , [(Int, TxHash, Maybe BS.ByteString)]
          )
        ]
      )
    )
observe :: LeiosDbHandle IO
-> Assertion
-> Bodies
-> [Op]
-> IO
     ((Int, Int),
      ([[LeiosPoint]],
       [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
         [(Int, TxHash, Maybe ByteString)])]))
observe LeiosDbHandle IO
db Assertion
settle Bodies
bodies [Op]
ops = LeiosDbHandle IO
-> (RW
    -> IO
         ((Int, Int),
          ([[LeiosPoint]],
           [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
             [(Int, TxHash, Maybe ByteString)])])))
-> IO
     ((Int, Int),
      ([[LeiosPoint]],
       [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
         [(Int, TxHash, Maybe ByteString)])]))
forall a. LeiosDbHandle IO -> (RW -> IO a) -> IO a
withRW LeiosDbHandle IO
db ((RW
  -> IO
       ((Int, Int),
        ([[LeiosPoint]],
         [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
           [(Int, TxHash, Maybe ByteString)])])))
 -> IO
      ((Int, Int),
       ([[LeiosPoint]],
        [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
          [(Int, TxHash, Maybe ByteString)])])))
-> (RW
    -> IO
         ((Int, Int),
          ([[LeiosPoint]],
           [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
             [(Int, TxHash, Maybe ByteString)])])))
-> IO
     ((Int, Int),
      ([[LeiosPoint]],
       [([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
         [(Int, TxHash, Maybe ByteString)])]))
forall a b. (a -> b) -> a -> b
$ \RW
rw -> do
  (counts, completed) <- RW
-> [LeiosPoint]
-> [LeiosPoint]
-> [EndorserBlockHash]
-> Int
-> [Op]
-> IO ((Int, Int), [[LeiosPoint]])
go RW
rw [] [] [] Int
0 [Op]
ops
  seen <- forM (Map.toList bodies) $ \(EndorserBlockHash
ebHash, (EndorserBlock
eb, [Int]
_)) ->
    (,,)
      ([(TxHash, Word32)]
 -> Maybe [(TxHash, ByteString)]
 -> [(Int, TxHash, Maybe ByteString)]
 -> ([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
     [(Int, TxHash, Maybe ByteString)]))
-> IO [(TxHash, Word32)]
-> IO
     (Maybe [(TxHash, ByteString)]
      -> [(Int, TxHash, Maybe ByteString)]
      -> ([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
          [(Int, TxHash, Maybe ByteString)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RW -> EndorserBlockHash -> IO [(TxHash, Word32)]
rwLookupEbBody RW
rw EndorserBlockHash
ebHash
      IO
  (Maybe [(TxHash, ByteString)]
   -> [(Int, TxHash, Maybe ByteString)]
   -> ([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
       [(Int, TxHash, Maybe ByteString)]))
-> IO (Maybe [(TxHash, ByteString)])
-> IO
     ([(Int, TxHash, Maybe ByteString)]
      -> ([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
          [(Int, TxHash, Maybe ByteString)]))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RW -> EndorserBlockHash -> IO (Maybe [(TxHash, ByteString)])
rwLookupEbClosure RW
rw EndorserBlockHash
ebHash
      IO
  ([(Int, TxHash, Maybe ByteString)]
   -> ([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
       [(Int, TxHash, Maybe ByteString)]))
-> IO [(Int, TxHash, Maybe ByteString)]
-> IO
     ([(TxHash, Word32)], Maybe [(TxHash, ByteString)],
      [(Int, TxHash, Maybe ByteString)])
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RW
-> EndorserBlockHash
-> [Int]
-> IO [(Int, TxHash, Maybe ByteString)]
rwBatchRetrieveTxs RW
rw EndorserBlockHash
ebHash [Int
0 .. [(TxHash, Word32)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (EndorserBlock -> [(TxHash, Word32)]
endorserBlockReferences EndorserBlock
eb)]
  pure (counts, (completed, seen))
 where
  go :: RW
-> [LeiosPoint]
-> [LeiosPoint]
-> [EndorserBlockHash]
-> Int
-> [Op]
-> IO ((Int, Int), [[LeiosPoint]])
go RW
_rw [LeiosPoint]
_points [LeiosPoint]
_bodied [EndorserBlockHash]
pinned Int
nEvicted [] = ((Int, Int), [[LeiosPoint]]) -> IO ((Int, Int), [[LeiosPoint]])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([EndorserBlockHash] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EndorserBlockHash]
pinned, Int
nEvicted), [])
  go RW
rw [LeiosPoint]
points [LeiosPoint]
bodied [EndorserBlockHash]
pinned Int
nEvicted (Op
op : [Op]
rest) = case Op
op of
    OpPoint LeiosPoint
point -> do
      RW -> LeiosPoint -> Word32 -> Assertion
rwInsertEbPoint RW
rw LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize ((EndorserBlock, [Int]) -> EndorserBlock
forall a b. (a, b) -> a
fst (Bodies
bodies Bodies -> EndorserBlockHash -> (EndorserBlock, [Int])
forall k a. Ord k => Map k a -> k -> a
Map.! LeiosPoint -> EndorserBlockHash
pointEbHash LeiosPoint
point)))
      Assertion
settle
      RW
-> [LeiosPoint]
-> [LeiosPoint]
-> [EndorserBlockHash]
-> Int
-> [Op]
-> IO ((Int, Int), [[LeiosPoint]])
go RW
rw (LeiosPoint
point LeiosPoint -> [LeiosPoint] -> [LeiosPoint]
forall a. a -> [a] -> [a]
: [LeiosPoint]
points) [LeiosPoint]
bodied [EndorserBlockHash]
pinned Int
nEvicted [Op]
rest
    OpBody LeiosPoint
point
      | LeiosPoint
point LeiosPoint -> [LeiosPoint] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [LeiosPoint]
points Bool -> Bool -> Bool
&& LeiosPoint
point LeiosPoint -> [LeiosPoint] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [LeiosPoint]
bodied -> do
          done <- RW -> LeiosPoint -> EndorserBlock -> IO [LeiosPoint]
rwInsertEbBody RW
rw LeiosPoint
point ((EndorserBlock, [Int]) -> EndorserBlock
forall a b. (a, b) -> a
fst (Bodies
bodies Bodies -> EndorserBlockHash -> (EndorserBlock, [Int])
forall k a. Ord k => Map k a -> k -> a
Map.! LeiosPoint -> EndorserBlockHash
pointEbHash LeiosPoint
point))
          settle
          fmap (sortOn show done :) <$> go rw points (point : bodied) pinned nEvicted rest
      | Bool
otherwise -> RW
-> [LeiosPoint]
-> [LeiosPoint]
-> [EndorserBlockHash]
-> Int
-> [Op]
-> IO ((Int, Int), [[LeiosPoint]])
go RW
rw [LeiosPoint]
points [LeiosPoint]
bodied [EndorserBlockHash]
pinned Int
nEvicted [Op]
rest
    OpTxs LeiosPoint
point [Int]
offsets -> do
      let indices :: [Int]
indices = (EndorserBlock, [Int]) -> [Int]
forall a b. (a, b) -> b
snd (Bodies
bodies Bodies -> EndorserBlockHash -> (EndorserBlock, [Int])
forall k a. Ord k => Map k a -> k -> a
Map.! LeiosPoint -> EndorserBlockHash
pointEbHash LeiosPoint
point)
      done <-
        RW -> LeiosPoint -> [(Int, ByteString)] -> IO [LeiosPoint]
rwInsertTxs
          RW
rw
          LeiosPoint
point
          [ (Int
offset, Int -> ByteString
poolTxBytes (if Int
offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
indices then [Int]
indices [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
offset else Int
1))
          | Int
offset <- [Int]
offsets
          ]
      settle
      fmap (sortOn show done :) <$> go rw points bodied pinned nEvicted rest
    OpPromote EndorserBlockHash
ebHash -> case [LeiosPoint
p | LeiosPoint
p <- [LeiosPoint]
points, LeiosPoint -> EndorserBlockHash
pointEbHash LeiosPoint
p EndorserBlockHash -> EndorserBlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== EndorserBlockHash
ebHash, EndorserBlockHash
ebHash EndorserBlockHash -> [EndorserBlockHash] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [EndorserBlockHash]
pinned] of
      LeiosPoint
point : [LeiosPoint]
_ -> do
        complete <- Maybe [(TxHash, ByteString)] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [(TxHash, ByteString)] -> Bool)
-> IO (Maybe [(TxHash, ByteString)]) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RW -> EndorserBlockHash -> IO (Maybe [(TxHash, ByteString)])
rwLookupEbClosure RW
rw EndorserBlockHash
ebHash
        if complete
          then do
            leiosDbPromoteToImmutable db [point]
            settle
            go rw points bodied (nub (ebHash : pinned)) nEvicted rest
          else go rw points bodied pinned nEvicted rest
      [] -> RW
-> [LeiosPoint]
-> [LeiosPoint]
-> [EndorserBlockHash]
-> Int
-> [Op]
-> IO ((Int, Int), [[LeiosPoint]])
go RW
rw [LeiosPoint]
points [LeiosPoint]
bodied [EndorserBlockHash]
pinned Int
nEvicted [Op]
rest
    OpGc SlotNo
slot -> do
      LeiosDbHandle IO -> HasCallStack => SlotNo -> Assertion
forall (m :: * -> *).
LeiosDbHandle m -> HasCallStack => SlotNo -> m ()
garbageCollect LeiosDbHandle IO
db SlotNo
slot
      Assertion
settle
      let newest :: EndorserBlockHash -> SlotNo
newest EndorserBlockHash
ebHash = [SlotNo] -> SlotNo
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [LeiosPoint -> SlotNo
pointSlotNo LeiosPoint
p | LeiosPoint
p <- [LeiosPoint]
points, LeiosPoint -> EndorserBlockHash
pointEbHash LeiosPoint
p EndorserBlockHash -> EndorserBlockHash -> Bool
forall a. Eq a => a -> a -> Bool
== EndorserBlockHash
ebHash]
          evicted :: [EndorserBlockHash]
evicted =
            [EndorserBlockHash] -> [EndorserBlockHash]
forall a. Eq a => [a] -> [a]
nub [EndorserBlockHash
ebHash | LeiosPoint
p <- [LeiosPoint]
points, let ebHash :: EndorserBlockHash
ebHash = LeiosPoint -> EndorserBlockHash
pointEbHash LeiosPoint
p, EndorserBlockHash -> SlotNo
newest EndorserBlockHash
ebHash SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
slot]
          kept :: LeiosPoint -> Bool
kept LeiosPoint
p = LeiosPoint -> EndorserBlockHash
pointEbHash LeiosPoint
p EndorserBlockHash -> [EndorserBlockHash] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [EndorserBlockHash]
evicted
      RW
-> [LeiosPoint]
-> [LeiosPoint]
-> [EndorserBlockHash]
-> Int
-> [Op]
-> IO ((Int, Int), [[LeiosPoint]])
go RW
rw ((LeiosPoint -> Bool) -> [LeiosPoint] -> [LeiosPoint]
forall a. (a -> Bool) -> [a] -> [a]
filter LeiosPoint -> Bool
kept [LeiosPoint]
points) ((LeiosPoint -> Bool) -> [LeiosPoint] -> [LeiosPoint]
forall a. (a -> Bool) -> [a] -> [a]
filter LeiosPoint -> Bool
kept [LeiosPoint]
bodied) [EndorserBlockHash]
pinned (Int
nEvicted Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [EndorserBlockHash] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EndorserBlockHash]
evicted) [Op]
rest

-- | Hand the action a wait for the SQLite implementation's background work to
-- catch up: for its sweep to have evicted every row the garbage collection
-- marked, and the transactions that left orphaned, and for its copier to have
-- copied every pinned endorser block.
withSettle :: FilePath -> (IO () -> IO a) -> IO a
withSettle :: forall a. [Char] -> (Assertion -> IO a) -> IO a
withSettle [Char]
volDbPath Assertion -> IO a
action =
  IO Database
-> (Database -> Assertion) -> (Database -> IO a) -> IO a
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]
volDbPath)) Database -> Assertion
SQL.close ((Database -> IO a) -> IO a) -> (Database -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Database
conn -> do
    Database -> Text -> Assertion
SQL.exec Database
conn ([Char] -> Text
T.pack [Char]
"pragma busy_timeout = 1000;")
    IO Statement
-> (Statement -> Assertion) -> (Statement -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Database -> Text -> IO Statement
SQL.prepare Database
conn Text
sqlBackgroundWork) Statement -> Assertion
SQL.finalize ((Statement -> IO a) -> IO a) -> (Statement -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Statement
stmt -> do
      let backlog :: IO Int64
backlog = do
            _ <- Statement -> IO StepResult
SQL.step Statement
stmt
            n <- SQL.columnInt64 stmt 0
            SQL.reset stmt
            pure n
          poll :: Assertion
poll =
            IO Int64
backlog IO Int64 -> (Int64 -> 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
>>= \case
              Int64
0 -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Int64
_ -> Int -> Assertion
threadDelay Int
1_000 Assertion -> Assertion -> Assertion
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Assertion
poll
          settle :: Assertion
settle =
            Int -> Assertion -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
Timeout.timeout Int
settleTimeoutMicros Assertion
poll IO (Maybe ()) -> (Maybe () -> 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
>>= \case
              Just () -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              Maybe ()
Nothing -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure [Char]
"the SQLite implementation's background work did not catch up"
      Assertion -> IO a
action Assertion
settle
 where
  settleTimeoutMicros :: Int
settleTimeoutMicros = Int
10_000_000

-- | How many rows the SQLite implementation's background work has yet to deal
-- with: those pinned (status 1) or marked for the sweep (status 3).
sqlBackgroundWork :: T.Text
sqlBackgroundWork :: Text
sqlBackgroundWork =
  [Char] -> Text
T.pack [Char]
"SELECT COUNT(*) FROM ebs WHERE status IN (1, 3)"