{-# LANGUAGE TypeApplications #-}

-- | Tests of how the ChainDB and the LeiosDB interact: which endorser blocks the
-- ChainDB has the LeiosDB keep, once the blocks that announce and certify them
-- are immutable, and when ChainSel may select a block certifying one.
module Test.Consensus.Leios.ChainDB (tests) where

import Cardano.Crypto.Hash (Hash (UnsafeHash))
import Cardano.Crypto.Leios (VerificationError (..))
import Control.Monad (forM_, void)
import Control.Monad.Class.MonadSTM (atomically)
import Control.Monad.Class.MonadTimer.SI (threadDelay)
import Control.Monad.IOSim (IOSim, runSimOrThrow)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as SBS
import Ouroboros.Consensus.Block
  ( Point
  , Proxy (..)
  , WithOrigin (..)
  , blockHash
  , blockPoint
  , blockSlot
  )
import Ouroboros.Consensus.Ledger.Extended (ExtValidationError (..))
import Ouroboros.Consensus.Leios.Cert (LeiosCertRejection (..))
import Ouroboros.Consensus.Leios.Types
import Ouroboros.Consensus.NodeKernel (NodeKernel (..))
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import Ouroboros.Consensus.Storage.LeiosDB (newLeiosDBInMemory)
import Ouroboros.Consensus.Storage.LeiosDB.API
  ( LeiosDbReader (..)
  , LeiosDbWriter (..)
  , Promise (..)
  , withReader
  , withWriter
  )
import Ouroboros.Consensus.Util.STM (forgetFingerprint)
import Test.Consensus.Leios.Committee (certOf)
import Test.Consensus.Leios.NodeUnderTest
import Test.Consensus.Leios.TestBlock
import Test.Tasty
import Test.Tasty.HUnit
import Test.Util.ChainDB (emptyNodeDBs)

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"ChainDB and LeiosDB"
    [ TestName -> Assertion -> TestTree
testCase TestName
"ChainSel rejects a block whose certificate a minority made" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (forall s. IOSim s (Maybe (ExtValidationError LeiosTestBlock)))
-> Maybe (ExtValidationError LeiosTestBlock)
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
          ((NodeUnderTest (IOSim s) -> IOSim s ())
-> LeiosTestBlock
-> IOSim s (Maybe (ExtValidationError LeiosTestBlock))
forall s.
(NodeUnderTest (IOSim s) -> IOSim s ())
-> LeiosTestBlock
-> IOSim s (Maybe (ExtValidationError LeiosTestBlock))
whyInvalid (\NodeUnderTest (IOSim s)
nut -> NodeUnderTest (IOSim s) -> [LeiosTestBlock] -> IOSim s ()
forall (m :: * -> *).
IOLike m =>
NodeUnderTest m -> [LeiosTestBlock] -> m ()
addBlocks NodeUnderTest (IOSim s)
nut [LeiosTestBlock
announcingA, LeiosTestBlock
minorityCertifyingA]) LeiosTestBlock
minorityCertifyingA)
          Maybe (ExtValidationError LeiosTestBlock)
-> Maybe (ExtValidationError LeiosTestBlock) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= ExtValidationError LeiosTestBlock
-> Maybe (ExtValidationError LeiosTestBlock)
forall a. a -> Maybe a
Just (LeiosCertRejection -> ExtValidationError LeiosTestBlock
forall blk. LeiosCertRejection -> ExtValidationError blk
ExtValidationErrorLeiosCert (VerificationError -> LeiosCertRejection
LeiosCertInvalid (Ratio Integer -> VerificationError
InsufficientWeight (Ratio Integer
1 Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Fractional a => a -> a -> a
/ Ratio Integer
4))))
    , TestName -> Assertion -> TestTree
testCase TestName
"ChainSel does not verify a certificate again for a claim it established" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (forall s. IOSim s (Maybe (ExtValidationError LeiosTestBlock)))
-> Maybe (ExtValidationError LeiosTestBlock)
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((NodeUnderTest (IOSim s) -> IOSim s ())
-> LeiosTestBlock
-> IOSim s (Maybe (ExtValidationError LeiosTestBlock))
forall s.
(NodeUnderTest (IOSim s) -> IOSim s ())
-> LeiosTestBlock
-> IOSim s (Maybe (ExtValidationError LeiosTestBlock))
whyInvalid NodeUnderTest (IOSim s) -> IOSim s ()
forall s. NodeUnderTest (IOSim s) -> IOSim s ()
addSibling LeiosTestBlock
minoritySibling) Maybe (ExtValidationError LeiosTestBlock)
-> Maybe (ExtValidationError LeiosTestBlock) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe (ExtValidationError LeiosTestBlock)
forall a. Maybe a
Nothing
    , TestName -> Assertion -> TestTree
testCase TestName
"a restart forgets a certifying block off the selection, until it arrives again" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (forall s. IOSim s (Bool, Bool, Bool)) -> (Bool, Bool, Bool)
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (WhatOfA -> IOSim s (Bool, Bool, Bool)
forall s. WhatOfA -> IOSim s (Bool, Bool, Bool)
heldAcrossRestart WhatOfA
BodyOfA) (Bool, Bool, Bool) -> (Bool, Bool, Bool) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (Bool
True, Bool
False, Bool
True)
    , TestName -> Assertion -> TestTree
testCase TestName
"a restart keeps a certifying block on the selection" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (forall s. IOSim s (Bool, Bool, Bool)) -> (Bool, Bool, Bool)
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (WhatOfA -> IOSim s (Bool, Bool, Bool)
forall s. WhatOfA -> IOSim s (Bool, Bool, Bool)
heldAcrossRestart WhatOfA
ClosureOfA) (Bool, Bool, Bool) -> (Bool, Bool, Bool) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (Bool
True, Bool
True, Bool
True)
    , TestName -> Assertion -> TestTree
testCase TestName
"the GC keeps an endorser block an immutable block certifies" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        ([(TxHash, Word32)], [(TxHash, Word32)]) -> [(TxHash, Word32)]
forall a b. (a, b) -> a
fst ((forall s. IOSim s ([(TxHash, Word32)], [(TxHash, Word32)]))
-> ([(TxHash, Word32)], [(TxHash, Word32)])
forall a. (forall s. IOSim s a) -> a
runSimOrThrow IOSim s ([(TxHash, Word32)], [(TxHash, Word32)])
forall s. IOSim s ([(TxHash, Word32)], [(TxHash, Word32)])
bodiesAfterGc) [(TxHash, Word32)] -> [(TxHash, Word32)] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= EndorserBlock -> [(TxHash, Word32)]
endorserBlockReferences EndorserBlock
ebA
    , TestName -> Assertion -> TestTree
testCase TestName
"the GC evicts an endorser block no block certifies" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        ([(TxHash, Word32)], [(TxHash, Word32)]) -> [(TxHash, Word32)]
forall a b. (a, b) -> b
snd ((forall s. IOSim s ([(TxHash, Word32)], [(TxHash, Word32)]))
-> ([(TxHash, Word32)], [(TxHash, Word32)])
forall a. (forall s. IOSim s a) -> a
runSimOrThrow IOSim s ([(TxHash, Word32)], [(TxHash, Word32)])
forall s. IOSim s ([(TxHash, Word32)], [(TxHash, Word32)])
bodiesAfterGc) [(TxHash, Word32)] -> [(TxHash, Word32)] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= []
    , TestName -> Assertion -> TestTree
testCase TestName
"ChainSel parks a certifying block until the closure arrives" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (forall s. IOSim s (Point LeiosTestBlock, Point LeiosTestBlock))
-> (Point LeiosTestBlock, Point LeiosTestBlock)
forall a. (forall s. IOSim s a) -> a
runSimOrThrow IOSim s (Point LeiosTestBlock, Point LeiosTestBlock)
forall s. IOSim s (Point LeiosTestBlock, Point LeiosTestBlock)
tipsAroundClosure
          (Point LeiosTestBlock, Point LeiosTestBlock)
-> (Point LeiosTestBlock, Point LeiosTestBlock) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (LeiosTestBlock -> Point LeiosTestBlock
forall block. HasHeader block => block -> Point block
blockPoint LeiosTestBlock
announcingA, LeiosTestBlock -> Point LeiosTestBlock
forall block. HasHeader block => block -> Point block
blockPoint LeiosTestBlock
certifyingA)
    , TestName -> Assertion -> TestTree
testCase TestName
"ChainSel selects a certifying block whose closure the LeiosDB held at start" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (forall s. IOSim s (Point LeiosTestBlock)) -> Point LeiosTestBlock
forall a. (forall s. IOSim s a) -> a
runSimOrThrow IOSim s (Point LeiosTestBlock)
forall s. IOSim s (Point LeiosTestBlock)
tipWithClosureBeforeStart Point LeiosTestBlock -> Point LeiosTestBlock -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosTestBlock -> Point LeiosTestBlock
forall block. HasHeader block => block -> Point block
blockPoint LeiosTestBlock
certifyingA
    ]

-- | The node holds endorser blocks A and B, with their transactions. The
-- chain's first block announces A, its second certifies A, and its third
-- announces B, which nothing certifies. Once the immutable tip has passed both
-- announcements and the GC has run, these are the bodies of A and B that the
-- LeiosDB still holds.
bodiesAfterGc :: IOSim s ([(TxHash, BytesSize)], [(TxHash, BytesSize)])
bodiesAfterGc :: forall s. IOSim s ([(TxHash, Word32)], [(TxHash, Word32)])
bodiesAfterGc = (NodeUnderTest (IOSim s)
 -> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)]))
-> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)])
forall s a. (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNode ((NodeUnderTest (IOSim s)
  -> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)]))
 -> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)]))
-> (NodeUnderTest (IOSim s)
    -> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)]))
-> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)])
forall a b. (a -> b) -> a -> b
$ \NodeUnderTest (IOSim s)
nut -> do
  let leiosDb :: LeiosDbHandle (IOSim s)
leiosDb = NodeKernel (IOSim s) PeerAddr (ConnectionId ()) LeiosTestBlock
-> LeiosDbHandle (IOSim s)
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> LeiosDbHandle m
getLeiosDB (NodeUnderTest (IOSim s)
-> NodeKernel (IOSim s) PeerAddr (ConnectionId ()) LeiosTestBlock
forall (m :: * -> *).
NodeUnderTest m
-> NodeKernel m PeerAddr (ConnectionId ()) LeiosTestBlock
nutKernel NodeUnderTest (IOSim s)
nut)
  LeiosDbHandle (IOSim s)
-> (LeiosDbWriter (IOSim s) -> IOSim s ()) -> IOSim s ()
forall (m :: * -> *) a.
MonadThrow m =>
LeiosDbHandle m -> (LeiosDbWriter m -> m a) -> m a
withWriter LeiosDbHandle (IOSim s)
leiosDb ((LeiosDbWriter (IOSim s) -> IOSim s ()) -> IOSim s ())
-> (LeiosDbWriter (IOSim s) -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \LeiosDbWriter (IOSim s)
writer ->
    [(LeiosPoint, EndorserBlock)]
-> ((LeiosPoint, EndorserBlock) -> IOSim s ()) -> IOSim s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(LeiosPoint
pointA, EndorserBlock
ebA), (LeiosPoint
pointB, EndorserBlock
ebB)] (((LeiosPoint, EndorserBlock) -> IOSim s ()) -> IOSim s ())
-> ((LeiosPoint, EndorserBlock) -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \(LeiosPoint
point, EndorserBlock
eb) -> do
      Promise (IOSim s) () -> IOSim s ()
forall (m :: * -> *) a. Promise m a -> m a
await (Promise (IOSim s) () -> IOSim s ())
-> IOSim s (Promise (IOSim s) ()) -> IOSim s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter (IOSim s)
-> HasCallStack =>
   LeiosPoint -> Word32 -> IOSim s (Promise (IOSim s) ())
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack => LeiosPoint -> Word32 -> m (Promise m ())
writeEbPoint LeiosDbWriter (IOSim s)
writer LeiosPoint
point (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
eb)
      IOSim s CompletedEbs -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s CompletedEbs -> IOSim s ())
-> IOSim s CompletedEbs -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs
forall (m :: * -> *) a. Promise m a -> m a
await (Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs)
-> IOSim s (Promise (IOSim s) CompletedEbs) -> IOSim s CompletedEbs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter (IOSim s)
-> HasCallStack =>
   LeiosPoint
   -> EndorserBlock -> IOSim s (Promise (IOSim s) CompletedEbs)
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack =>
   LeiosPoint -> EndorserBlock -> m (Promise m CompletedEbs)
writeEbBody LeiosDbWriter (IOSim s)
writer LeiosPoint
point EndorserBlock
eb
      IOSim s CompletedEbs -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s CompletedEbs -> IOSim s ())
-> IOSim s CompletedEbs -> IOSim s ()
forall a b. (a -> b) -> a -> b
$
        Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs
forall (m :: * -> *) a. Promise m a -> m a
await
          (Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs)
-> IOSim s (Promise (IOSim s) CompletedEbs) -> IOSim s CompletedEbs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter (IOSim s)
-> HasCallStack =>
   LeiosPoint
   -> [(Int, ByteString)] -> IOSim s (Promise (IOSim s) CompletedEbs)
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack =>
   LeiosPoint -> [(Int, ByteString)] -> m (Promise m CompletedEbs)
writeTxs
            LeiosDbWriter (IOSim s)
writer
            LeiosPoint
point
            [ (Int
offset, Int -> Word8 -> ByteString
BS.replicate (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size) Word8
0)
            | (Int
offset, (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)
            ]
  -- Let the slots of the chain's blocks pass, so none is from the future.
  DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
20
  NodeUnderTest (IOSim s) -> [LeiosTestBlock] -> IOSim s ()
forall (m :: * -> *).
IOLike m =>
NodeUnderTest m -> [LeiosTestBlock] -> m ()
addBlocks NodeUnderTest (IOSim s)
nut [LeiosTestBlock]
chain
  -- Long enough for the copy to the ImmutableDB and for the delayed GC.
  DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
100
  LeiosDbHandle (IOSim s)
-> (LeiosDbReader (IOSim s)
    -> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)]))
-> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)])
forall (m :: * -> *) a.
MonadThrow m =>
LeiosDbHandle m -> (LeiosDbReader m -> m a) -> m a
withReader LeiosDbHandle (IOSim s)
leiosDb ((LeiosDbReader (IOSim s)
  -> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)]))
 -> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)]))
-> (LeiosDbReader (IOSim s)
    -> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)]))
-> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)])
forall a b. (a -> b) -> a -> b
$ \LeiosDbReader (IOSim s)
reader ->
    (,)
      ([(TxHash, Word32)]
 -> [(TxHash, Word32)] -> ([(TxHash, Word32)], [(TxHash, Word32)]))
-> IOSim s [(TxHash, Word32)]
-> IOSim
     s ([(TxHash, Word32)] -> ([(TxHash, Word32)], [(TxHash, Word32)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LeiosDbReader (IOSim s)
-> HasCallStack => EndorserBlockHash -> IOSim s [(TxHash, Word32)]
forall (m :: * -> *).
LeiosDbReader m
-> HasCallStack => EndorserBlockHash -> m [(TxHash, Word32)]
lookupEbBody LeiosDbReader (IOSim s)
reader (LeiosPoint -> EndorserBlockHash
pointEbHash LeiosPoint
pointA)
      IOSim
  s ([(TxHash, Word32)] -> ([(TxHash, Word32)], [(TxHash, Word32)]))
-> IOSim s [(TxHash, Word32)]
-> IOSim s ([(TxHash, Word32)], [(TxHash, Word32)])
forall a b. IOSim s (a -> b) -> IOSim s a -> IOSim s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LeiosDbReader (IOSim s)
-> HasCallStack => EndorserBlockHash -> IOSim s [(TxHash, Word32)]
forall (m :: * -> *).
LeiosDbReader m
-> HasCallStack => EndorserBlockHash -> m [(TxHash, Word32)]
lookupEbBody LeiosDbReader (IOSim s)
reader (LeiosPoint -> EndorserBlockHash
pointEbHash LeiosPoint
pointB)
 where
  -- k is 10, so with sixteen blocks the immutable tip is the sixth, past both
  -- announcements.
  chain :: [LeiosTestBlock]
chain = Int -> [LeiosTestBlock] -> [LeiosTestBlock]
forall a. Int -> [a] -> [a]
take Int
16 ([LeiosTestBlock] -> [LeiosTestBlock])
-> [LeiosTestBlock] -> [LeiosTestBlock]
forall a b. (a -> b) -> a -> b
$ LeiosTestBlock
announcingA LeiosTestBlock -> [LeiosTestBlock] -> [LeiosTestBlock]
forall a. a -> [a] -> [a]
: LeiosTestBlock
certifyingA LeiosTestBlock -> [LeiosTestBlock] -> [LeiosTestBlock]
forall a. a -> [a] -> [a]
: (LeiosTestBlock -> LeiosTestBlock)
-> LeiosTestBlock -> [LeiosTestBlock]
forall a. (a -> a) -> a -> [a]
iterate LeiosTestBlock -> LeiosTestBlock
successorLeiosBlock LeiosTestBlock
announcingB

-- | Add the blocks with the given action, then report why the ChainDB judges
-- the given block invalid, if it does.
whyInvalid ::
  (NodeUnderTest (IOSim s) -> IOSim s ()) ->
  LeiosTestBlock ->
  IOSim s (Maybe (ExtValidationError LeiosTestBlock))
whyInvalid :: forall s.
(NodeUnderTest (IOSim s) -> IOSim s ())
-> LeiosTestBlock
-> IOSim s (Maybe (ExtValidationError LeiosTestBlock))
whyInvalid NodeUnderTest (IOSim s) -> IOSim s ()
add LeiosTestBlock
blk = (NodeUnderTest (IOSim s)
 -> IOSim s (Maybe (ExtValidationError LeiosTestBlock)))
-> IOSim s (Maybe (ExtValidationError LeiosTestBlock))
forall s a. (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNode ((NodeUnderTest (IOSim s)
  -> IOSim s (Maybe (ExtValidationError LeiosTestBlock)))
 -> IOSim s (Maybe (ExtValidationError LeiosTestBlock)))
-> (NodeUnderTest (IOSim s)
    -> IOSim s (Maybe (ExtValidationError LeiosTestBlock)))
-> IOSim s (Maybe (ExtValidationError LeiosTestBlock))
forall a b. (a -> b) -> a -> b
$ \NodeUnderTest (IOSim s)
nut -> do
  -- Let the slots of the blocks pass, so none is from the future.
  DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
20
  NodeUnderTest (IOSim s) -> IOSim s ()
add NodeUnderTest (IOSim s)
nut
  DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
  isInvalid <- STM
  (IOSim s) (TestHash -> Maybe (ExtValidationError LeiosTestBlock))
-> IOSim s (TestHash -> Maybe (ExtValidationError LeiosTestBlock))
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   (IOSim s) (TestHash -> Maybe (ExtValidationError LeiosTestBlock))
 -> IOSim s (TestHash -> Maybe (ExtValidationError LeiosTestBlock)))
-> STM
     (IOSim s) (TestHash -> Maybe (ExtValidationError LeiosTestBlock))
-> IOSim s (TestHash -> Maybe (ExtValidationError LeiosTestBlock))
forall a b. (a -> b) -> a -> b
$ WithFingerprint
  (TestHash -> Maybe (ExtValidationError LeiosTestBlock))
-> TestHash -> Maybe (ExtValidationError LeiosTestBlock)
forall a. WithFingerprint a -> a
forgetFingerprint (WithFingerprint
   (TestHash -> Maybe (ExtValidationError LeiosTestBlock))
 -> TestHash -> Maybe (ExtValidationError LeiosTestBlock))
-> STM
     (IOSim s)
     (WithFingerprint
        (TestHash -> Maybe (ExtValidationError LeiosTestBlock)))
-> STM
     (IOSim s) (TestHash -> Maybe (ExtValidationError LeiosTestBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB (IOSim s) LeiosTestBlock
-> STM
     (IOSim s)
     (WithFingerprint
        (HeaderHash LeiosTestBlock
         -> Maybe (ExtValidationError LeiosTestBlock)))
forall (m :: * -> *) blk.
ChainDB m blk
-> STM
     m
     (WithFingerprint
        (HeaderHash blk -> Maybe (ExtValidationError blk)))
ChainDB.getIsInvalidBlock (NodeUnderTest (IOSim s) -> ChainDB (IOSim s) LeiosTestBlock
forall (m :: * -> *). NodeUnderTest m -> ChainDB m LeiosTestBlock
nutChainDB NodeUnderTest (IOSim s)
nut)
  pure $ isInvalid (blockHash blk)

-- | The node adds 'announcingA' and 'certifyingA', restarts, and then adds
-- 'certifyingA' again. Whether the ChainDB holds 'certifyingA' before the
-- restart, after it, and after the second add.
--
-- Without A's transactions, 'certifyingA' is parked and so not on the
-- selection.
heldAcrossRestart :: WhatOfA -> IOSim s (Bool, Bool, Bool)
heldAcrossRestart :: forall s. WhatOfA -> IOSim s (Bool, Bool, Bool)
heldAcrossRestart WhatOfA
whatOfA = do
  nodeDBs <- IOSim s (NodeDBs (StrictTMVar (IOSim s) MockFS))
forall (m :: * -> *).
MonadSTM m =>
m (NodeDBs (StrictTMVar m MockFS))
emptyNodeDBs
  leiosDb <- newLeiosDBInMemory
  withWriter leiosDb $ \LeiosDbWriter (IOSim s)
writer -> do
    Promise (IOSim s) () -> IOSim s ()
forall (m :: * -> *) a. Promise m a -> m a
await (Promise (IOSim s) () -> IOSim s ())
-> IOSim s (Promise (IOSim s) ()) -> IOSim s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter (IOSim s)
-> HasCallStack =>
   LeiosPoint -> Word32 -> IOSim s (Promise (IOSim s) ())
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack => LeiosPoint -> Word32 -> m (Promise m ())
writeEbPoint LeiosDbWriter (IOSim s)
writer LeiosPoint
pointA (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
ebA)
    IOSim s CompletedEbs -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s CompletedEbs -> IOSim s ())
-> IOSim s CompletedEbs -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs
forall (m :: * -> *) a. Promise m a -> m a
await (Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs)
-> IOSim s (Promise (IOSim s) CompletedEbs) -> IOSim s CompletedEbs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter (IOSim s)
-> HasCallStack =>
   LeiosPoint
   -> EndorserBlock -> IOSim s (Promise (IOSim s) CompletedEbs)
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack =>
   LeiosPoint -> EndorserBlock -> m (Promise m CompletedEbs)
writeEbBody LeiosDbWriter (IOSim s)
writer LeiosPoint
pointA EndorserBlock
ebA
    case WhatOfA
whatOfA of
      WhatOfA
BodyOfA -> () -> IOSim s ()
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      WhatOfA
ClosureOfA ->
        IOSim s CompletedEbs -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s CompletedEbs -> IOSim s ())
-> IOSim s CompletedEbs -> IOSim s ()
forall a b. (a -> b) -> a -> b
$
          Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs
forall (m :: * -> *) a. Promise m a -> m a
await
            (Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs)
-> IOSim s (Promise (IOSim s) CompletedEbs) -> IOSim s CompletedEbs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter (IOSim s)
-> HasCallStack =>
   LeiosPoint
   -> [(Int, ByteString)] -> IOSim s (Promise (IOSim s) CompletedEbs)
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack =>
   LeiosPoint -> [(Int, ByteString)] -> m (Promise m CompletedEbs)
writeTxs
              LeiosDbWriter (IOSim s)
writer
              LeiosPoint
pointA
              [ (Int
offset, Int -> Word8 -> ByteString
BS.replicate (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size) Word8
0)
              | (Int
offset, (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
ebA)
              ]
  beforeRestart <- withNodeOverDBs nodeDBs leiosDb $ \NodeUnderTest (IOSim s)
nut -> do
    -- Let the slots of the chain's blocks pass, so none is from the future.
    DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
20
    NodeUnderTest (IOSim s) -> [LeiosTestBlock] -> IOSim s ()
forall (m :: * -> *).
IOLike m =>
NodeUnderTest m -> [LeiosTestBlock] -> m ()
addBlocks NodeUnderTest (IOSim s)
nut [LeiosTestBlock
announcingA, LeiosTestBlock
certifyingA]
    DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
    NodeUnderTest (IOSim s) -> IOSim s Bool
forall {m :: * -> *}. MonadSTM m => NodeUnderTest m -> m Bool
holds NodeUnderTest (IOSim s)
nut
  withNodeOverDBs nodeDBs leiosDb $ \NodeUnderTest (IOSim s)
nut -> do
    afterRestart <- NodeUnderTest (IOSim s) -> IOSim s Bool
forall {m :: * -> *}. MonadSTM m => NodeUnderTest m -> m Bool
holds NodeUnderTest (IOSim s)
nut
    addBlocksAfter nut (NotOrigin (blockSlot announcingA)) [certifyingA]
    threadDelay 1
    afterAddingAgain <- holds nut
    pure (beforeRestart, afterRestart, afterAddingAgain)
 where
  holds :: NodeUnderTest m -> m Bool
holds NodeUnderTest m
nut = STM m Bool -> m Bool
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ ((Point LeiosTestBlock -> Bool) -> Point LeiosTestBlock -> Bool
forall a b. (a -> b) -> a -> b
$ LeiosTestBlock -> Point LeiosTestBlock
forall block. HasHeader block => block -> Point block
blockPoint LeiosTestBlock
certifyingA) ((Point LeiosTestBlock -> Bool) -> Bool)
-> STM m (Point LeiosTestBlock -> Bool) -> STM m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m LeiosTestBlock -> STM m (Point LeiosTestBlock -> Bool)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (Point blk -> Bool)
ChainDB.getIsFetched (NodeUnderTest m -> ChainDB m LeiosTestBlock
forall (m :: * -> *). NodeUnderTest m -> ChainDB m LeiosTestBlock
nutChainDB NodeUnderTest m
nut)

-- | What the LeiosDB holds of A
data WhatOfA
  = -- | Its body, but not its transactions
    BodyOfA
  | -- | Its body and its transactions
    ClosureOfA

-- | 'certifyingA', except a minority made its certificate.
minorityCertifyingA :: LeiosTestBlock
minorityCertifyingA :: LeiosTestBlock
minorityCertifyingA =
  LeiosCert -> LeiosTestBlock -> LeiosTestBlock
setLeiosCert (RankingBlockHash -> [Word16] -> LeiosCert
certOf (LeiosTestBlock -> RankingBlockHash
rbHashOf LeiosTestBlock
announcingA) [Word16
0]) (LeiosTestBlock -> LeiosTestBlock
successorLeiosBlock LeiosTestBlock
announcingA)

-- | A sibling of 'certifyingA', making the same claim, with a certificate a
-- minority made.
minoritySibling :: LeiosTestBlock
minoritySibling :: LeiosTestBlock
minoritySibling =
  LeiosCert -> LeiosTestBlock -> LeiosTestBlock
setLeiosCert (RankingBlockHash -> [Word16] -> LeiosCert
certOf (LeiosTestBlock -> RankingBlockHash
rbHashOf LeiosTestBlock
announcingA) [Word16
0]) (LeiosTestBlock -> LeiosTestBlock
forkLeiosBlock LeiosTestBlock
certifyingA)

-- | Add 'certifyingA', which establishes its claim, and then 'minoritySibling'.
addSibling :: NodeUnderTest (IOSim s) -> IOSim s ()
addSibling :: forall s. NodeUnderTest (IOSim s) -> IOSim s ()
addSibling NodeUnderTest (IOSim s)
nut = do
  NodeUnderTest (IOSim s) -> [LeiosTestBlock] -> IOSim s ()
forall (m :: * -> *).
IOLike m =>
NodeUnderTest m -> [LeiosTestBlock] -> m ()
addBlocks NodeUnderTest (IOSim s)
nut [LeiosTestBlock
announcingA, LeiosTestBlock
certifyingA]
  NodeUnderTest (IOSim s)
-> WithOrigin SlotNo -> [LeiosTestBlock] -> IOSim s ()
forall (m :: * -> *).
IOLike m =>
NodeUnderTest m -> WithOrigin SlotNo -> [LeiosTestBlock] -> m ()
addBlocksAfter NodeUnderTest (IOSim s)
nut (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin (LeiosTestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot LeiosTestBlock
announcingA)) [LeiosTestBlock
minoritySibling]

rbHashOf :: LeiosTestBlock -> RankingBlockHash
rbHashOf :: LeiosTestBlock -> RankingBlockHash
rbHashOf = Proxy LeiosTestBlock
-> HeaderHash LeiosTestBlock -> RankingBlockHash
forall blk.
ConvertRawHash blk =>
Proxy blk -> HeaderHash blk -> RankingBlockHash
toRankingBlockHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @LeiosTestBlock) (TestHash -> RankingBlockHash)
-> (LeiosTestBlock -> TestHash)
-> LeiosTestBlock
-> RankingBlockHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeiosTestBlock -> HeaderHash LeiosTestBlock
LeiosTestBlock -> TestHash
forall b. HasHeader b => b -> HeaderHash b
blockHash

pointA, pointB :: LeiosPoint
pointA :: LeiosPoint
pointA = SlotNo -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint (LeiosTestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot LeiosTestBlock
announcingA) (ShortByteString -> EndorserBlockHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
32 Word8
1))
pointB :: LeiosPoint
pointB = SlotNo -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint (LeiosTestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot LeiosTestBlock
announcingB) (ShortByteString -> EndorserBlockHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
32 Word8
2))

-- | The first block, which announces A; the second, which certifies A; and
-- the third, which announces B.
announcingA, certifyingA, announcingB :: LeiosTestBlock
announcingA :: LeiosTestBlock
announcingA = EndorserBlockHash -> Word32 -> LeiosTestBlock -> LeiosTestBlock
setAnnouncement (LeiosPoint -> EndorserBlockHash
pointEbHash LeiosPoint
pointA) (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
ebA) (Word64 -> LeiosTestBlock
firstLeiosBlock Word64
1)
certifyingA :: LeiosTestBlock
certifyingA =
  LeiosCert -> LeiosTestBlock -> LeiosTestBlock
setLeiosCert (RankingBlockHash -> [Word16] -> LeiosCert
certOf (LeiosTestBlock -> RankingBlockHash
rbHashOf LeiosTestBlock
announcingA) [Word16
0, Word16
1, Word16
2]) (LeiosTestBlock -> LeiosTestBlock
successorLeiosBlock LeiosTestBlock
announcingA)
announcingB :: LeiosTestBlock
announcingB =
  EndorserBlockHash -> Word32 -> LeiosTestBlock -> LeiosTestBlock
setAnnouncement (LeiosPoint -> EndorserBlockHash
pointEbHash LeiosPoint
pointB) (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
ebB) (LeiosTestBlock -> LeiosTestBlock
successorLeiosBlock LeiosTestBlock
certifyingA)

ebA, ebB :: EndorserBlock
ebA :: EndorserBlock
ebA = [(TxHash, Word32)] -> EndorserBlock
mkEndorserBlock [(ShortByteString -> TxHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
32 Word8
1), Word32
10)]
ebB :: EndorserBlock
ebB = [(TxHash, Word32)] -> EndorserBlock
mkEndorserBlock [(ShortByteString -> TxHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
32 Word8
2), Word32
10)]

-- | The chain announces A and then certifies it, while the LeiosDB holds A's
-- body but not its transactions. The tip of the selected chain before they
-- arrive, and after.
tipsAroundClosure :: IOSim s (Point LeiosTestBlock, Point LeiosTestBlock)
tipsAroundClosure :: forall s. IOSim s (Point LeiosTestBlock, Point LeiosTestBlock)
tipsAroundClosure = (NodeUnderTest (IOSim s)
 -> IOSim s (Point LeiosTestBlock, Point LeiosTestBlock))
-> IOSim s (Point LeiosTestBlock, Point LeiosTestBlock)
forall s a. (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNode ((NodeUnderTest (IOSim s)
  -> IOSim s (Point LeiosTestBlock, Point LeiosTestBlock))
 -> IOSim s (Point LeiosTestBlock, Point LeiosTestBlock))
-> (NodeUnderTest (IOSim s)
    -> IOSim s (Point LeiosTestBlock, Point LeiosTestBlock))
-> IOSim s (Point LeiosTestBlock, Point LeiosTestBlock)
forall a b. (a -> b) -> a -> b
$ \NodeUnderTest (IOSim s)
nut -> do
  let leiosDb :: LeiosDbHandle (IOSim s)
leiosDb = NodeKernel (IOSim s) PeerAddr (ConnectionId ()) LeiosTestBlock
-> LeiosDbHandle (IOSim s)
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> LeiosDbHandle m
getLeiosDB (NodeUnderTest (IOSim s)
-> NodeKernel (IOSim s) PeerAddr (ConnectionId ()) LeiosTestBlock
forall (m :: * -> *).
NodeUnderTest m
-> NodeKernel m PeerAddr (ConnectionId ()) LeiosTestBlock
nutKernel NodeUnderTest (IOSim s)
nut)
      chainDB :: ChainDB (IOSim s) LeiosTestBlock
chainDB = NodeUnderTest (IOSim s) -> ChainDB (IOSim s) LeiosTestBlock
forall (m :: * -> *). NodeUnderTest m -> ChainDB m LeiosTestBlock
nutChainDB NodeUnderTest (IOSim s)
nut
  LeiosDbHandle (IOSim s)
-> (LeiosDbWriter (IOSim s) -> IOSim s ()) -> IOSim s ()
forall (m :: * -> *) a.
MonadThrow m =>
LeiosDbHandle m -> (LeiosDbWriter m -> m a) -> m a
withWriter LeiosDbHandle (IOSim s)
leiosDb ((LeiosDbWriter (IOSim s) -> IOSim s ()) -> IOSim s ())
-> (LeiosDbWriter (IOSim s) -> IOSim s ()) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \LeiosDbWriter (IOSim s)
writer -> do
    Promise (IOSim s) () -> IOSim s ()
forall (m :: * -> *) a. Promise m a -> m a
await (Promise (IOSim s) () -> IOSim s ())
-> IOSim s (Promise (IOSim s) ()) -> IOSim s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter (IOSim s)
-> HasCallStack =>
   LeiosPoint -> Word32 -> IOSim s (Promise (IOSim s) ())
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack => LeiosPoint -> Word32 -> m (Promise m ())
writeEbPoint LeiosDbWriter (IOSim s)
writer LeiosPoint
pointA (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
ebA)
    IOSim s CompletedEbs -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s CompletedEbs -> IOSim s ())
-> IOSim s CompletedEbs -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs
forall (m :: * -> *) a. Promise m a -> m a
await (Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs)
-> IOSim s (Promise (IOSim s) CompletedEbs) -> IOSim s CompletedEbs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter (IOSim s)
-> HasCallStack =>
   LeiosPoint
   -> EndorserBlock -> IOSim s (Promise (IOSim s) CompletedEbs)
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack =>
   LeiosPoint -> EndorserBlock -> m (Promise m CompletedEbs)
writeEbBody LeiosDbWriter (IOSim s)
writer LeiosPoint
pointA EndorserBlock
ebA
  -- Let the slots of the chain's blocks pass, so none is from the future.
  DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
20
  NodeUnderTest (IOSim s) -> [LeiosTestBlock] -> IOSim s ()
forall (m :: * -> *).
IOLike m =>
NodeUnderTest m -> [LeiosTestBlock] -> m ()
addBlocks NodeUnderTest (IOSim s)
nut [LeiosTestBlock
announcingA, LeiosTestBlock
certifyingA]
  DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
  tipBefore <- STM (IOSim s) (Point LeiosTestBlock)
-> IOSim s (Point LeiosTestBlock)
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (IOSim s) (Point LeiosTestBlock)
 -> IOSim s (Point LeiosTestBlock))
-> STM (IOSim s) (Point LeiosTestBlock)
-> IOSim s (Point LeiosTestBlock)
forall a b. (a -> b) -> a -> b
$ ChainDB (IOSim s) LeiosTestBlock
-> STM (IOSim s) (Point LeiosTestBlock)
forall (m :: * -> *) blk. ChainDB m blk -> STM m (Point blk)
ChainDB.getTipPoint ChainDB (IOSim s) LeiosTestBlock
chainDB
  withWriter leiosDb $ \LeiosDbWriter (IOSim s)
writer ->
    IOSim s CompletedEbs -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s CompletedEbs -> IOSim s ())
-> IOSim s CompletedEbs -> IOSim s ()
forall a b. (a -> b) -> a -> b
$
      Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs
forall (m :: * -> *) a. Promise m a -> m a
await
        (Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs)
-> IOSim s (Promise (IOSim s) CompletedEbs) -> IOSim s CompletedEbs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter (IOSim s)
-> HasCallStack =>
   LeiosPoint
   -> [(Int, ByteString)] -> IOSim s (Promise (IOSim s) CompletedEbs)
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack =>
   LeiosPoint -> [(Int, ByteString)] -> m (Promise m CompletedEbs)
writeTxs
          LeiosDbWriter (IOSim s)
writer
          LeiosPoint
pointA
          [ (Int
offset, Int -> Word8 -> ByteString
BS.replicate (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size) Word8
0)
          | (Int
offset, (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
ebA)
          ]
  threadDelay 1
  tipAfter <- atomically $ ChainDB.getTipPoint chainDB
  pure (tipBefore, tipAfter)

-- | As 'tipsAroundClosure', except that the LeiosDB holds A's closure before
-- the node starts. The tip of the selected chain.
tipWithClosureBeforeStart :: IOSim s (Point LeiosTestBlock)
tipWithClosureBeforeStart :: forall s. IOSim s (Point LeiosTestBlock)
tipWithClosureBeforeStart = do
  leiosDb <- IOSim s (LeiosDbHandle (IOSim s))
forall (m :: * -> *). IOLike m => m (LeiosDbHandle m)
newLeiosDBInMemory
  withWriter leiosDb $ \LeiosDbWriter (IOSim s)
writer -> do
    Promise (IOSim s) () -> IOSim s ()
forall (m :: * -> *) a. Promise m a -> m a
await (Promise (IOSim s) () -> IOSim s ())
-> IOSim s (Promise (IOSim s) ()) -> IOSim s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter (IOSim s)
-> HasCallStack =>
   LeiosPoint -> Word32 -> IOSim s (Promise (IOSim s) ())
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack => LeiosPoint -> Word32 -> m (Promise m ())
writeEbPoint LeiosDbWriter (IOSim s)
writer LeiosPoint
pointA (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
ebA)
    IOSim s CompletedEbs -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s CompletedEbs -> IOSim s ())
-> IOSim s CompletedEbs -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs
forall (m :: * -> *) a. Promise m a -> m a
await (Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs)
-> IOSim s (Promise (IOSim s) CompletedEbs) -> IOSim s CompletedEbs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter (IOSim s)
-> HasCallStack =>
   LeiosPoint
   -> EndorserBlock -> IOSim s (Promise (IOSim s) CompletedEbs)
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack =>
   LeiosPoint -> EndorserBlock -> m (Promise m CompletedEbs)
writeEbBody LeiosDbWriter (IOSim s)
writer LeiosPoint
pointA EndorserBlock
ebA
    IOSim s CompletedEbs -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s CompletedEbs -> IOSim s ())
-> IOSim s CompletedEbs -> IOSim s ()
forall a b. (a -> b) -> a -> b
$
      Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs
forall (m :: * -> *) a. Promise m a -> m a
await
        (Promise (IOSim s) CompletedEbs -> IOSim s CompletedEbs)
-> IOSim s (Promise (IOSim s) CompletedEbs) -> IOSim s CompletedEbs
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LeiosDbWriter (IOSim s)
-> HasCallStack =>
   LeiosPoint
   -> [(Int, ByteString)] -> IOSim s (Promise (IOSim s) CompletedEbs)
forall (m :: * -> *).
LeiosDbWriter m
-> HasCallStack =>
   LeiosPoint -> [(Int, ByteString)] -> m (Promise m CompletedEbs)
writeTxs
          LeiosDbWriter (IOSim s)
writer
          LeiosPoint
pointA
          [ (Int
offset, Int -> Word8 -> ByteString
BS.replicate (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size) Word8
0)
          | (Int
offset, (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
ebA)
          ]
  withNodeOver leiosDb $ \NodeUnderTest (IOSim s)
nut -> do
    -- Let the slots of the chain's blocks pass, so none is from the future.
    DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
20
    NodeUnderTest (IOSim s) -> [LeiosTestBlock] -> IOSim s ()
forall (m :: * -> *).
IOLike m =>
NodeUnderTest m -> [LeiosTestBlock] -> m ()
addBlocks NodeUnderTest (IOSim s)
nut [LeiosTestBlock
announcingA, LeiosTestBlock
certifyingA]
    DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
    STM (IOSim s) (Point LeiosTestBlock)
-> IOSim s (Point LeiosTestBlock)
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (IOSim s) (Point LeiosTestBlock)
 -> IOSim s (Point LeiosTestBlock))
-> STM (IOSim s) (Point LeiosTestBlock)
-> IOSim s (Point LeiosTestBlock)
forall a b. (a -> b) -> a -> b
$ ChainDB (IOSim s) LeiosTestBlock
-> STM (IOSim s) (Point LeiosTestBlock)
forall (m :: * -> *) blk. ChainDB m blk -> STM m (Point blk)
ChainDB.getTipPoint (NodeUnderTest (IOSim s) -> ChainDB (IOSim s) LeiosTestBlock
forall (m :: * -> *). NodeUnderTest m -> ChainDB m LeiosTestBlock
nutChainDB NodeUnderTest (IOSim s)
nut)