{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

-- | Tests of the node's LeiosFetch client and server, over real connections,
-- against peers run by the Leios node-vs-environment tests.
module Test.Consensus.Leios.LeiosFetch.Node (tests) where

import Cardano.Crypto.Hash (Hash (UnsafeHash))
import Cardano.Network.NodeToNode (defaultMiniProtocolParameters)
import Cardano.Network.NodeToNode.Version (NodeToNodeVersion (..))
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTimer.SI (timeout)
import Control.Monad.IOSim (IOSim, runSimOrThrow)
import Control.Tracer (nullTracer)
import Data.Bits ((.|.))
import qualified Data.Bits as Bits
import qualified Data.ByteString as BS
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Short as SBS
import qualified Data.Map.Strict as Map
import qualified Data.Vector.Strict as V
import Network.TypedProtocol.Codec (PeerRole (..))
import Network.TypedProtocol.Core (IsPipelined (..), ReflRelativeAgency (..))
import Network.TypedProtocol.Peer (Peer (..))
import Ouroboros.Consensus.Leios.Types
  ( EndorserBlock
  , LeiosPoint (..)
  , LeiosTx (..)
  , TxHash
  , encodeEndorserBlockSize
  , mkEndorserBlock
  )
import Ouroboros.Consensus.MiniProtocol.LeiosFetch.Server (ExnLeiosInvalidRequest (..))
import Ouroboros.Consensus.MiniProtocol.LeiosFetch.Type
import Ouroboros.Consensus.Network.LeiosFetch (leiosFetchMiniProtocolNum)
import qualified Ouroboros.Consensus.Network.NodeToNode as NTN
import Ouroboros.Consensus.NodeKernel (NodeKernel (..))
import Ouroboros.Consensus.Storage.LeiosDB.API
  ( LeiosDbWriter (..)
  , Promise (..)
  , withWriter
  )
import Ouroboros.Network.Channel (Channel)
import Ouroboros.Network.Driver.Simple (runAnnotatedPeer)
import Ouroboros.Network.Mux
  ( MiniProtocol (..)
  , TemperatureBundle (..)
  , WithProtocolTemperature (..)
  )
import Test.Consensus.Leios.Environment
import Test.Consensus.Leios.NodeUnderTest
import Test.Tasty
import Test.Tasty.HUnit

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"node vs environment"
    [ TestName -> Assertion -> TestTree
testCase TestName
"the node's server ends when the peer sends MsgDone" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (forall s. IOSim s ServerOutcome) -> IO ServerOutcome
forall a. (forall s. IOSim s a) -> IO a
runSimFinishing (EnvClient s -> IOSim s ServerOutcome
forall s. EnvClient s -> IOSim s ServerOutcome
nodeServerAgainst EnvClient s
forall s. EnvClient s
doneClient) IO ServerOutcome -> (ServerOutcome -> 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
>>= (ServerOutcome -> ServerOutcome -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= ServerOutcome
ServerEnded)
    , TestName -> Assertion -> TestTree
testCase TestName
"the node serves an endorser block it holds" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (forall s. IOSim s (Maybe Reply, ServerOutcome))
-> IO (Maybe Reply, ServerOutcome)
forall a. (forall s. IOSim s a) -> IO a
runSimFinishing ((StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s)
-> IOSim s (Maybe Reply, ServerOutcome)
forall s.
(StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s)
-> IOSim s (Maybe Reply, ServerOutcome)
nodeAnswers (LeiosPoint -> StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
forall s.
LeiosPoint -> StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
requestBlock LeiosPoint
heldPoint))
          IO (Maybe Reply, ServerOutcome)
-> ((Maybe Reply, ServerOutcome) -> 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
>>= ((Maybe Reply, ServerOutcome)
-> (Maybe Reply, ServerOutcome) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (Reply -> Maybe Reply
forall a. a -> Maybe a
Just (EndorserBlock -> Reply
ReplyBlock EndorserBlock
heldEb), ServerOutcome
ServerEnded))
    , TestName -> Assertion -> TestTree
testCase TestName
"the node serves the transactions it holds" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (forall s. IOSim s (Maybe Reply, ServerOutcome))
-> IO (Maybe Reply, ServerOutcome)
forall a. (forall s. IOSim s a) -> IO a
runSimFinishing ((StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s)
-> IOSim s (Maybe Reply, ServerOutcome)
forall s.
(StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s)
-> IOSim s (Maybe Reply, ServerOutcome)
nodeAnswers (LeiosPoint
-> TxBitmaps -> StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
forall s.
LeiosPoint
-> TxBitmaps -> StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
requestTxs LeiosPoint
heldPoint ([Int] -> TxBitmaps
bitmapsNaming [Int
0, Int
63, Int
64])))
          IO (Maybe Reply, ServerOutcome)
-> ((Maybe Reply, ServerOutcome) -> 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
>>= ((Maybe Reply, ServerOutcome)
-> (Maybe Reply, ServerOutcome) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (Reply -> Maybe Reply
forall a. a -> Maybe a
Just ([LeiosTx] -> Reply
ReplyTxs ((Int -> LeiosTx) -> [Int] -> [LeiosTx]
forall a b. (a -> b) -> [a] -> [b]
map Int -> LeiosTx
heldTx [Int
0, Int
63, Int
64])), ServerOutcome
ServerEnded))
    , TestName -> Assertion -> TestTree
testCase TestName
"the node disconnects a client that requests an endorser block it does not hold" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (forall s. IOSim s (Maybe Reply, ServerOutcome))
-> IO (Maybe Reply, ServerOutcome)
forall a. (forall s. IOSim s a) -> IO a
runSimFinishing ((StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s)
-> IOSim s (Maybe Reply, ServerOutcome)
forall s.
(StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s)
-> IOSim s (Maybe Reply, ServerOutcome)
nodeAnswers (LeiosPoint -> StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
forall s.
LeiosPoint -> StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
requestBlock LeiosPoint
unknownPoint))
          IO (Maybe Reply, ServerOutcome)
-> ((Maybe Reply, ServerOutcome) -> 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
>>= ((Maybe Reply, ServerOutcome)
-> (Maybe Reply, ServerOutcome) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (Maybe Reply
forall a. Maybe a
Nothing, TestName -> ServerOutcome
ServerFailed (ExnLeiosInvalidRequest -> TestName
forall a. Show a => a -> TestName
show (LeiosPoint -> ExnLeiosInvalidRequest
ExnLeiosUnknownBlockRequested LeiosPoint
unknownPoint))))
    , TestName -> Assertion -> TestTree
testCase TestName
"the node disconnects a client that requests transactions it does not hold" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        -- The first is held, the second is not, and the third is past the end
        -- of the endorser block.
        (forall s. IOSim s (Maybe Reply, ServerOutcome))
-> IO (Maybe Reply, ServerOutcome)
forall a. (forall s. IOSim s a) -> IO a
runSimFinishing ((StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s)
-> IOSim s (Maybe Reply, ServerOutcome)
forall s.
(StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s)
-> IOSim s (Maybe Reply, ServerOutcome)
nodeAnswers (LeiosPoint
-> TxBitmaps -> StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
forall s.
LeiosPoint
-> TxBitmaps -> StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
requestTxs LeiosPoint
heldPoint ([Int] -> TxBitmaps
bitmapsNaming [Int
0, Int
69, Int
100])))
          IO (Maybe Reply, ServerOutcome)
-> ((Maybe Reply, ServerOutcome) -> 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
>>= ((Maybe Reply, ServerOutcome)
-> (Maybe Reply, ServerOutcome) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (Maybe Reply
forall a. Maybe a
Nothing, TestName -> ServerOutcome
ServerFailed (ExnLeiosInvalidRequest -> TestName
forall a. Show a => a -> TestName
show (LeiosPoint -> [Int] -> ExnLeiosInvalidRequest
ExnLeiosUnknownTxsRequested LeiosPoint
heldPoint [Int
69, Int
100]))))
    , TestName -> Assertion -> TestTree
testCase TestName
"the node runs LeiosFetch from NodeToNodeV_16 on" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (forall s. IOSim s (Bool, Bool)) -> IO (Bool, Bool)
forall a. (forall s. IOSim s a) -> IO a
runSimFinishing (NodeToNodeVersion -> IOSim s (Bool, Bool)
forall s. NodeToNodeVersion -> IOSim s (Bool, Bool)
nodeRunsLeiosFetch NodeToNodeVersion
NodeToNodeV_16) IO (Bool, Bool) -> ((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) -> (Bool, Bool) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (Bool
True, Bool
True))
    , TestName -> Assertion -> TestTree
testCase TestName
"the node does not run LeiosFetch before NodeToNodeV_16" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        (forall s. IOSim s (Bool, Bool)) -> IO (Bool, Bool)
forall a. (forall s. IOSim s a) -> IO a
runSimFinishing (NodeToNodeVersion -> IOSim s (Bool, Bool)
forall s. NodeToNodeVersion -> IOSim s (Bool, Bool)
nodeRunsLeiosFetch NodeToNodeVersion
NodeToNodeV_15) IO (Bool, Bool) -> ((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) -> (Bool, Bool) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (Bool
False, Bool
False))
    ]

-- | Run the simulation, and fail the test if it has not finished after 100
-- simulated seconds.
runSimFinishing :: (forall s. IOSim s a) -> IO a
runSimFinishing :: forall a. (forall s. IOSim s a) -> IO a
runSimFinishing forall s. IOSim s a
sim = case (forall s. IOSim s (Maybe a)) -> Maybe a
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (DiffTime -> IOSim s a -> IOSim s (Maybe a)
forall a. DiffTime -> IOSim s a -> IOSim s (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
100 IOSim s a
forall s. IOSim s a
sim) of
  Maybe a
Nothing -> TestName -> IO a
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"the simulation did not finish within 100 seconds"
  Just a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

{-------------------------------------------------------------------------------
  The node's server
-------------------------------------------------------------------------------}

data ServerOutcome = ServerEnded | ServerFailed String
  deriving (ServerOutcome -> ServerOutcome -> Bool
(ServerOutcome -> ServerOutcome -> Bool)
-> (ServerOutcome -> ServerOutcome -> Bool) -> Eq ServerOutcome
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerOutcome -> ServerOutcome -> Bool
== :: ServerOutcome -> ServerOutcome -> Bool
$c/= :: ServerOutcome -> ServerOutcome -> Bool
/= :: ServerOutcome -> ServerOutcome -> Bool
Eq, Int -> ServerOutcome -> ShowS
[ServerOutcome] -> ShowS
ServerOutcome -> TestName
(Int -> ServerOutcome -> ShowS)
-> (ServerOutcome -> TestName)
-> ([ServerOutcome] -> ShowS)
-> Show ServerOutcome
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerOutcome -> ShowS
showsPrec :: Int -> ServerOutcome -> ShowS
$cshow :: ServerOutcome -> TestName
show :: ServerOutcome -> TestName
$cshowList :: [ServerOutcome] -> ShowS
showList :: [ServerOutcome] -> ShowS
Show)

type EnvClient s =
  Peer (LeiosFetch LeiosPoint EndorserBlock LeiosTx) AsClient NonPipelined StIdle (IOSim s) ()

-- | Run the node's server, with 'heldEb' in its LeiosDB, against a peer that
-- runs this client.
nodeServerAgainst :: EnvClient s -> IOSim s ServerOutcome
nodeServerAgainst :: forall s. EnvClient s -> IOSim s ServerOutcome
nodeServerAgainst EnvClient s
client = (NodeUnderTest (IOSim s) -> IOSim s ServerOutcome)
-> IOSim s ServerOutcome
forall s a. (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNode ((NodeUnderTest (IOSim s) -> IOSim s ServerOutcome)
 -> IOSim s ServerOutcome)
-> (NodeUnderTest (IOSim s) -> IOSim s ServerOutcome)
-> IOSim s ServerOutcome
forall a b. (a -> b) -> a -> b
$ \NodeUnderTest (IOSim s)
nut -> do
  NodeUnderTest (IOSim s) -> IOSim s ()
forall s. NodeUnderTest (IOSim s) -> IOSim s ()
holdHeldEb NodeUnderTest (IOSim s)
nut
  let envPeer :: EnvPeer (IOSim s)
envPeer =
        EnvPeer
          { epLeiosNotifyServer :: Channel (IOSim s) ByteString -> IOSim s ()
epLeiosNotifyServer = \Channel (IOSim s) ByteString
_chan -> STM (IOSim s) () -> IOSim s ()
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) ()
forall a. STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
          , epLeiosNotifyClient :: Maybe (Channel (IOSim s) ByteString -> IOSim s ())
epLeiosNotifyClient = Maybe (Channel (IOSim s) ByteString -> IOSim s ())
forall a. Maybe a
Nothing
          , epLeiosFetchServer :: Channel (IOSim s) ByteString -> IOSim s ()
epLeiosFetchServer = NodeUnderTest (IOSim s)
-> Channel (IOSim s) ByteString -> IOSim s ()
forall s.
NodeUnderTest (IOSim s)
-> Channel (IOSim s) ByteString -> IOSim s ()
refusingLeiosFetchServer NodeUnderTest (IOSim s)
nut
          , epLeiosFetchClient :: Maybe (Channel (IOSim s) ByteString -> IOSim s ())
epLeiosFetchClient = (Channel (IOSim s) ByteString -> IOSim s ())
-> Maybe (Channel (IOSim s) ByteString -> IOSim s ())
forall a. a -> Maybe a
Just ((Channel (IOSim s) ByteString -> IOSim s ())
 -> Maybe (Channel (IOSim s) ByteString -> IOSim s ()))
-> (Channel (IOSim s) ByteString -> IOSim s ())
-> Maybe (Channel (IOSim s) ByteString -> IOSim s ())
forall a b. (a -> b) -> a -> b
$ NodeUnderTest (IOSim s)
-> EnvClient s -> Channel (IOSim s) ByteString -> IOSim s ()
forall s.
NodeUnderTest (IOSim s)
-> EnvClient s -> Channel (IOSim s) ByteString -> IOSim s ()
runEnvClient NodeUnderTest (IOSim s)
nut EnvClient s
client
          }
  NodeUnderTest (IOSim s)
-> PeerAddr
-> EnvPeer (IOSim s)
-> (NodeVsEnvConnection (IOSim s) -> IOSim s ServerOutcome)
-> IOSim s ServerOutcome
forall s a.
NodeUnderTest (IOSim s)
-> PeerAddr
-> EnvPeer (IOSim s)
-> (NodeVsEnvConnection (IOSim s) -> IOSim s a)
-> IOSim s a
withNodeVsEnvConnection NodeUnderTest (IOSim s)
nut (Int -> PeerAddr
PeerAddr Int
1) EnvPeer (IOSim s)
envPeer ((NodeVsEnvConnection (IOSim s) -> IOSim s ServerOutcome)
 -> IOSim s ServerOutcome)
-> (NodeVsEnvConnection (IOSim s) -> IOSim s ServerOutcome)
-> IOSim s ServerOutcome
forall a b. (a -> b) -> a -> b
$ \NodeVsEnvConnection (IOSim s)
conn -> do
    server <- NodeVsEnvConnection (IOSim s)
-> IOSim s (STM (IOSim s) (Either SomeException ()))
forall s.
NodeVsEnvConnection (IOSim s)
-> IOSim s (STM (IOSim s) (Either SomeException ()))
nodeLeiosFetchServer NodeVsEnvConnection (IOSim s)
conn
    atomically server >>= \case
      Right () -> ServerOutcome -> IOSim s ServerOutcome
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerOutcome
ServerEnded
      Left SomeException
e -> ServerOutcome -> IOSim s ServerOutcome
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerOutcome -> IOSim s ServerOutcome)
-> ServerOutcome -> IOSim s ServerOutcome
forall a b. (a -> b) -> a -> b
$ TestName -> ServerOutcome
ServerFailed (SomeException -> TestName
forall a. Show a => a -> TestName
show SomeException
e)

runEnvClient :: NodeUnderTest (IOSim s) -> EnvClient s -> Channel (IOSim s) ByteString -> IOSim s ()
runEnvClient :: forall s.
NodeUnderTest (IOSim s)
-> EnvClient s -> Channel (IOSim s) ByteString -> IOSim s ()
runEnvClient NodeUnderTest (IOSim s)
nut EnvClient s
client Channel (IOSim s) ByteString
chan = ((), Maybe ByteString) -> ()
forall a b. (a, b) -> a
fst (((), Maybe ByteString) -> ())
-> IOSim s ((), Maybe ByteString) -> IOSim s ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer
  (IOSim s)
  (TraceSendRecv (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
-> AnnotatedCodec
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     DeserialiseFailure
     (IOSim s)
     ByteString
-> Channel (IOSim s) ByteString
-> EnvClient s
-> IOSim s ((), Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadEvaluate m, MonadThrow m, Monoid bytes, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 NFData a, NFData failure, Show failure) =>
Tracer m (TraceSendRecv ps)
-> AnnotatedCodec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runAnnotatedPeer Tracer
  (IOSim s)
  (TraceSendRecv (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer (NodeUnderTest (IOSim s)
-> AnnotatedCodec
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     DeserialiseFailure
     (IOSim s)
     ByteString
forall s. NodeUnderTest (IOSim s) -> LeiosFetchCodec s
envLeiosFetchCodec NodeUnderTest (IOSim s)
nut) Channel (IOSim s) ByteString
chan EnvClient s
client

doneClient :: EnvClient s
doneClient :: forall s. EnvClient s
doneClient = WeHaveAgencyProof 'AsClient 'StIdle
-> Message
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx) 'StIdle 'StDone
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     'StDone
     (IOSim s)
     ()
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     'StIdle
     (IOSim s)
     ()
forall ps (pr :: PeerRole) (pl :: IsPipelined ps) (st :: ps)
       (st' :: ps) (m :: * -> *) a.
(StateTokenI st, StateTokenI st', ActiveState st,
 Outstanding pl ~ 'Z, OutstandingSenders pl ~ 'Z) =>
WeHaveAgencyProof pr st
-> Message ps st st'
-> Peer ps pr pl st' m a
-> Peer ps pr pl st m a
Yield ReflRelativeAgency 'ClientAgency 'WeHaveAgency 'WeHaveAgency
WeHaveAgencyProof 'AsClient 'StIdle
forall (r :: RelativeAgency). ReflRelativeAgency 'ClientAgency r r
ReflClientAgency Message
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx) 'StIdle 'StDone
forall point eb tx.
Message (LeiosFetch point eb tx) 'StIdle 'StDone
MsgDone (Peer
   (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
   'AsClient
   'NonPipelined
   'StDone
   (IOSim s)
   ()
 -> Peer
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      'AsClient
      'NonPipelined
      'StIdle
      (IOSim s)
      ())
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     'StDone
     (IOSim s)
     ()
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     'StIdle
     (IOSim s)
     ()
forall a b. (a -> b) -> a -> b
$ NobodyHasAgencyProof 'AsClient 'StDone
-> ()
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     'StDone
     (IOSim s)
     ()
forall ps (pr :: PeerRole) (pl :: IsPipelined ps) (st :: ps)
       (m :: * -> *) a.
(StateTokenI st, StateAgency st ~ 'NobodyAgency,
 Outstanding pl ~ 'Z, OutstandingSenders pl ~ 'Z) =>
NobodyHasAgencyProof pr st -> a -> Peer ps pr pl st m a
Done ReflRelativeAgency 'NobodyAgency 'NobodyHasAgency 'NobodyHasAgency
NobodyHasAgencyProof 'AsClient 'StDone
forall (r :: RelativeAgency). ReflRelativeAgency 'NobodyAgency r r
ReflNobodyAgency ()

data Reply = ReplyBlock EndorserBlock | ReplyTxs [LeiosTx]
  deriving (Reply -> Reply -> Bool
(Reply -> Reply -> Bool) -> (Reply -> Reply -> Bool) -> Eq Reply
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Reply -> Reply -> Bool
== :: Reply -> Reply -> Bool
$c/= :: Reply -> Reply -> Bool
/= :: Reply -> Reply -> Bool
Eq, Int -> Reply -> ShowS
[Reply] -> ShowS
Reply -> TestName
(Int -> Reply -> ShowS)
-> (Reply -> TestName) -> ([Reply] -> ShowS) -> Show Reply
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Reply -> ShowS
showsPrec :: Int -> Reply -> ShowS
$cshow :: Reply -> TestName
show :: Reply -> TestName
$cshowList :: [Reply] -> ShowS
showList :: [Reply] -> ShowS
Show)

-- | The node's reply to the client's one request, if it replied, and how its
-- server ended.
nodeAnswers ::
  (StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s) -> IOSim s (Maybe Reply, ServerOutcome)
nodeAnswers :: forall s.
(StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s)
-> IOSim s (Maybe Reply, ServerOutcome)
nodeAnswers StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
client = do
  replyVar <- Maybe Reply -> IOSim s (StrictTVar (IOSim s) (Maybe Reply))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO Maybe Reply
forall a. Maybe a
Nothing
  outcome <- nodeServerAgainst (client replyVar)
  reply <- readTVarIO replyVar
  pure (reply, outcome)

-- | A client that requests an endorser block, keeps the reply, and sends
-- 'MsgDone'.
requestBlock :: LeiosPoint -> StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
requestBlock :: forall s.
LeiosPoint -> StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
requestBlock LeiosPoint
point StrictTVar (IOSim s) (Maybe Reply)
replyVar =
  WeHaveAgencyProof 'AsClient 'StIdle
-> Message
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'StIdle
     ('StBusy 'StBlock)
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     ('StBusy 'StBlock)
     (IOSim s)
     ()
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     'StIdle
     (IOSim s)
     ()
forall ps (pr :: PeerRole) (pl :: IsPipelined ps) (st :: ps)
       (st' :: ps) (m :: * -> *) a.
(StateTokenI st, StateTokenI st', ActiveState st,
 Outstanding pl ~ 'Z, OutstandingSenders pl ~ 'Z) =>
WeHaveAgencyProof pr st
-> Message ps st st'
-> Peer ps pr pl st' m a
-> Peer ps pr pl st m a
Yield ReflRelativeAgency 'ClientAgency 'WeHaveAgency 'WeHaveAgency
WeHaveAgencyProof 'AsClient 'StIdle
forall (r :: RelativeAgency). ReflRelativeAgency 'ClientAgency r r
ReflClientAgency (LeiosPoint
-> Message
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'StIdle
     ('StBusy 'StBlock)
forall point eb tx.
point
-> Message (LeiosFetch point eb tx) 'StIdle ('StBusy 'StBlock)
MsgLeiosBlockRequest LeiosPoint
point) (Peer
   (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
   'AsClient
   'NonPipelined
   ('StBusy 'StBlock)
   (IOSim s)
   ()
 -> Peer
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      'AsClient
      'NonPipelined
      'StIdle
      (IOSim s)
      ())
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     ('StBusy 'StBlock)
     (IOSim s)
     ()
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     'StIdle
     (IOSim s)
     ()
forall a b. (a -> b) -> a -> b
$
    TheyHaveAgencyProof 'AsClient ('StBusy 'StBlock)
-> (forall (st' :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
    Message
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      ('StBusy 'StBlock)
      st'
    -> Peer
         (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
         'AsClient
         'NonPipelined
         st'
         (IOSim s)
         ())
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     ('StBusy 'StBlock)
     (IOSim s)
     ()
forall ps (pr :: PeerRole) (pl :: IsPipelined ps) (st :: ps)
       (m :: * -> *) a.
(StateTokenI st, ActiveState st, Outstanding pl ~ 'Z,
 OutstandingSenders pl ~ 'Z) =>
TheyHaveAgencyProof pr st
-> (forall (st' :: ps). Message ps st st' -> Peer ps pr pl st' m a)
-> Peer ps pr pl st m a
Await ReflRelativeAgency 'ServerAgency 'TheyHaveAgency 'TheyHaveAgency
TheyHaveAgencyProof 'AsClient ('StBusy 'StBlock)
forall (r :: RelativeAgency). ReflRelativeAgency 'ServerAgency r r
ReflServerAgency ((forall (st' :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
  Message
    (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
    ('StBusy 'StBlock)
    st'
  -> Peer
       (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
       'AsClient
       'NonPipelined
       st'
       (IOSim s)
       ())
 -> Peer
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      'AsClient
      'NonPipelined
      ('StBusy 'StBlock)
      (IOSim s)
      ())
-> (forall (st' :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
    Message
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      ('StBusy 'StBlock)
      st'
    -> Peer
         (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
         'AsClient
         'NonPipelined
         st'
         (IOSim s)
         ())
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     ('StBusy 'StBlock)
     (IOSim s)
     ()
forall a b. (a -> b) -> a -> b
$ \case
      MsgLeiosBlock EndorserBlock
eb -> IOSim
  s
  (Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     st'
     (IOSim s)
     ())
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     st'
     (IOSim s)
     ()
forall ps (pr :: PeerRole) (pl :: IsPipelined ps) (st :: ps)
       (m :: * -> *) a.
m (Peer ps pr pl st m a) -> Peer ps pr pl st m a
Effect (IOSim
   s
   (Peer
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      'AsClient
      'NonPipelined
      st'
      (IOSim s)
      ())
 -> Peer
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      'AsClient
      'NonPipelined
      st'
      (IOSim s)
      ())
-> IOSim
     s
     (Peer
        (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
        'AsClient
        'NonPipelined
        st'
        (IOSim s)
        ())
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     st'
     (IOSim s)
     ()
forall a b. (a -> b) -> a -> b
$ Peer
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  'AsClient
  'NonPipelined
  st'
  (IOSim s)
  ()
Peer
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  'AsClient
  'NonPipelined
  'StIdle
  (IOSim s)
  ()
forall s. EnvClient s
doneClient Peer
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  'AsClient
  'NonPipelined
  st'
  (IOSim s)
  ()
-> IOSim s ()
-> IOSim
     s
     (Peer
        (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
        'AsClient
        'NonPipelined
        st'
        (IOSim s)
        ())
forall a b. a -> IOSim s b -> IOSim s a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ STM (IOSim s) () -> IOSim s ()
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar (IOSim s) (Maybe Reply)
-> Maybe Reply -> STM (IOSim s) ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar (IOSim s) (Maybe Reply)
replyVar (Reply -> Maybe Reply
forall a. a -> Maybe a
Just (EndorserBlock -> Reply
ReplyBlock EndorserBlock
eb)))

-- | A client that requests transactions, keeps the reply, and sends 'MsgDone'.
requestTxs :: LeiosPoint -> TxBitmaps -> StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
requestTxs :: forall s.
LeiosPoint
-> TxBitmaps -> StrictTVar (IOSim s) (Maybe Reply) -> EnvClient s
requestTxs LeiosPoint
point TxBitmaps
bitmaps StrictTVar (IOSim s) (Maybe Reply)
replyVar =
  WeHaveAgencyProof 'AsClient 'StIdle
-> Message
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'StIdle
     ('StBusy 'StBlockTxs)
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     ('StBusy 'StBlockTxs)
     (IOSim s)
     ()
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     'StIdle
     (IOSim s)
     ()
forall ps (pr :: PeerRole) (pl :: IsPipelined ps) (st :: ps)
       (st' :: ps) (m :: * -> *) a.
(StateTokenI st, StateTokenI st', ActiveState st,
 Outstanding pl ~ 'Z, OutstandingSenders pl ~ 'Z) =>
WeHaveAgencyProof pr st
-> Message ps st st'
-> Peer ps pr pl st' m a
-> Peer ps pr pl st m a
Yield ReflRelativeAgency 'ClientAgency 'WeHaveAgency 'WeHaveAgency
WeHaveAgencyProof 'AsClient 'StIdle
forall (r :: RelativeAgency). ReflRelativeAgency 'ClientAgency r r
ReflClientAgency (LeiosPoint
-> TxBitmaps
-> Message
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'StIdle
     ('StBusy 'StBlockTxs)
forall point eb tx.
point
-> TxBitmaps
-> Message (LeiosFetch point eb tx) 'StIdle ('StBusy 'StBlockTxs)
MsgLeiosBlockTxsRequest LeiosPoint
point TxBitmaps
bitmaps) (Peer
   (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
   'AsClient
   'NonPipelined
   ('StBusy 'StBlockTxs)
   (IOSim s)
   ()
 -> Peer
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      'AsClient
      'NonPipelined
      'StIdle
      (IOSim s)
      ())
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     ('StBusy 'StBlockTxs)
     (IOSim s)
     ()
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     'StIdle
     (IOSim s)
     ()
forall a b. (a -> b) -> a -> b
$
    TheyHaveAgencyProof 'AsClient ('StBusy 'StBlockTxs)
-> (forall (st' :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
    Message
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      ('StBusy 'StBlockTxs)
      st'
    -> Peer
         (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
         'AsClient
         'NonPipelined
         st'
         (IOSim s)
         ())
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     ('StBusy 'StBlockTxs)
     (IOSim s)
     ()
forall ps (pr :: PeerRole) (pl :: IsPipelined ps) (st :: ps)
       (m :: * -> *) a.
(StateTokenI st, ActiveState st, Outstanding pl ~ 'Z,
 OutstandingSenders pl ~ 'Z) =>
TheyHaveAgencyProof pr st
-> (forall (st' :: ps). Message ps st st' -> Peer ps pr pl st' m a)
-> Peer ps pr pl st m a
Await ReflRelativeAgency 'ServerAgency 'TheyHaveAgency 'TheyHaveAgency
TheyHaveAgencyProof 'AsClient ('StBusy 'StBlockTxs)
forall (r :: RelativeAgency). ReflRelativeAgency 'ServerAgency r r
ReflServerAgency ((forall (st' :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
  Message
    (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
    ('StBusy 'StBlockTxs)
    st'
  -> Peer
       (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
       'AsClient
       'NonPipelined
       st'
       (IOSim s)
       ())
 -> Peer
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      'AsClient
      'NonPipelined
      ('StBusy 'StBlockTxs)
      (IOSim s)
      ())
-> (forall (st' :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
    Message
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      ('StBusy 'StBlockTxs)
      st'
    -> Peer
         (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
         'AsClient
         'NonPipelined
         st'
         (IOSim s)
         ())
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     ('StBusy 'StBlockTxs)
     (IOSim s)
     ()
forall a b. (a -> b) -> a -> b
$ \case
      MsgLeiosBlockTxs Vector LeiosTx
txs ->
        IOSim
  s
  (Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     st'
     (IOSim s)
     ())
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     st'
     (IOSim s)
     ()
forall ps (pr :: PeerRole) (pl :: IsPipelined ps) (st :: ps)
       (m :: * -> *) a.
m (Peer ps pr pl st m a) -> Peer ps pr pl st m a
Effect (IOSim
   s
   (Peer
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      'AsClient
      'NonPipelined
      st'
      (IOSim s)
      ())
 -> Peer
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      'AsClient
      'NonPipelined
      st'
      (IOSim s)
      ())
-> IOSim
     s
     (Peer
        (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
        'AsClient
        'NonPipelined
        st'
        (IOSim s)
        ())
-> Peer
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'AsClient
     'NonPipelined
     st'
     (IOSim s)
     ()
forall a b. (a -> b) -> a -> b
$ Peer
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  'AsClient
  'NonPipelined
  st'
  (IOSim s)
  ()
Peer
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  'AsClient
  'NonPipelined
  'StIdle
  (IOSim s)
  ()
forall s. EnvClient s
doneClient Peer
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  'AsClient
  'NonPipelined
  st'
  (IOSim s)
  ()
-> IOSim s ()
-> IOSim
     s
     (Peer
        (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
        'AsClient
        'NonPipelined
        st'
        (IOSim s)
        ())
forall a b. a -> IOSim s b -> IOSim s a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ STM (IOSim s) () -> IOSim s ()
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar (IOSim s) (Maybe Reply)
-> Maybe Reply -> STM (IOSim s) ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar (IOSim s) (Maybe Reply)
replyVar (Reply -> Maybe Reply
forall a. a -> Maybe a
Just ([LeiosTx] -> Reply
ReplyTxs (Vector LeiosTx -> [LeiosTx]
forall a. Vector a -> [a]
V.toList Vector LeiosTx
txs))))

-- | The bitmaps that name these offsets.
bitmapsNaming :: [Int] -> TxBitmaps
bitmapsNaming :: [Int] -> TxBitmaps
bitmapsNaming [Int]
offsets =
  Map Word16 Word64 -> TxBitmaps
forall k a. Map k a -> [(k, a)]
Map.toList (Map Word16 Word64 -> TxBitmaps) -> Map Word16 Word64 -> TxBitmaps
forall a b. (a -> b) -> a -> b
$
    (Word64 -> Word64 -> Word64) -> TxBitmaps -> Map Word16 Word64
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
      Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
(.|.)
      [(Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
offset Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
64), Int -> Word64
forall a. Bits a => Int -> a
Bits.bit (Int
63 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
64)) | Int
offset <- [Int]
offsets]

{-------------------------------------------------------------------------------
  What the node's LeiosDB holds
-------------------------------------------------------------------------------}

-- | An endorser block of 70 transactions, so that a request for them takes two
-- bitmaps.
heldEb :: EndorserBlock
heldEb :: EndorserBlock
heldEb =
  [(TxHash, Word32)] -> EndorserBlock
mkEndorserBlock ([(TxHash, Word32)] -> EndorserBlock)
-> [(TxHash, Word32)] -> EndorserBlock
forall a b. (a -> b) -> a -> b
$
    [(Int -> TxHash
heldTxHash Int
i, Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length (Int -> ByteString
heldTxBytes Int
i))) | Int
i <- [Int
0 .. Int
69]]

heldPoint :: LeiosPoint
heldPoint :: LeiosPoint
heldPoint = SlotNo -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint SlotNo
1 (ShortByteString -> EndorserBlockHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
32 Word8
1))

unknownPoint :: LeiosPoint
unknownPoint :: LeiosPoint
unknownPoint = SlotNo -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint SlotNo
1 (ShortByteString -> EndorserBlockHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
32 Word8
2))

heldTxHash :: Int -> TxHash
heldTxHash :: Int -> TxHash
heldTxHash Int
i = ShortByteString -> TxHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
31 Word8
0 ShortByteString -> ShortByteString -> ShortByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ShortByteString
SBS.singleton (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))

heldTxBytes :: Int -> BS.ByteString
heldTxBytes :: Int -> ByteString
heldTxBytes 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)

heldTx :: Int -> LeiosTx
heldTx :: Int -> LeiosTx
heldTx = ByteString -> LeiosTx
MkLeiosTx (ByteString -> LeiosTx) -> (Int -> ByteString) -> Int -> LeiosTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString
heldTxBytes

-- | Write 'heldEb' and all its transactions but the last.
holdHeldEb :: NodeUnderTest (IOSim s) -> IOSim s ()
holdHeldEb :: forall s. NodeUnderTest (IOSim s) -> IOSim s ()
holdHeldEb 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 (NodeKernel (IOSim s) PeerAddr (ConnectionId ()) Blk
-> LeiosDbHandle (IOSim s)
forall (m :: * -> *) addrNTN addrNTC blk.
NodeKernel m addrNTN addrNTC blk -> LeiosDbHandle m
getLeiosDB (NodeUnderTest (IOSim s)
-> NodeKernel (IOSim s) PeerAddr (ConnectionId ()) Blk
forall (m :: * -> *).
NodeUnderTest m -> NodeKernel m PeerAddr (ConnectionId ()) Blk
nutKernel NodeUnderTest (IOSim s)
nut)) ((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
heldPoint (EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
heldEb)
  _ <- 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
heldPoint EndorserBlock
heldEb
  _ <- await =<< writeTxs writer heldPoint [(i, heldTxBytes i) | i <- [0 .. 68]]
  pure ()

{-------------------------------------------------------------------------------
  Registration
-------------------------------------------------------------------------------}

-- | Whether the node's initiator bundle, and its initiator-and-responder bundle,
-- include LeiosFetch among their hot mini-protocols for this version.
nodeRunsLeiosFetch :: NodeToNodeVersion -> IOSim s (Bool, Bool)
nodeRunsLeiosFetch :: forall s. NodeToNodeVersion -> IOSim s (Bool, Bool)
nodeRunsLeiosFetch NodeToNodeVersion
ntnVersion = (NodeUnderTest (IOSim s) -> IOSim s (Bool, Bool))
-> IOSim s (Bool, Bool)
forall s a. (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNode ((NodeUnderTest (IOSim s) -> IOSim s (Bool, Bool))
 -> IOSim s (Bool, Bool))
-> (NodeUnderTest (IOSim s) -> IOSim s (Bool, Bool))
-> IOSim s (Bool, Bool)
forall a b. (a -> b) -> a -> b
$ \NodeUnderTest (IOSim s)
nut ->
  (Bool, Bool) -> IOSim s (Bool, Bool)
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( TemperatureBundle
  [MiniProtocol
     'InitiatorMode
     (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
     (ResponderContext PeerAddr)
     ByteString
     (IOSim s)
     NodeToNodeInitiatorResult
     Void]
-> Bool
forall {mode :: Mode} {initiatorCtx} {responderCtx} {bytes}
       {m :: * -> *} {a} {b}.
TemperatureBundle
  [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> Bool
runsLeiosFetch (TemperatureBundle
   [MiniProtocol
      'InitiatorMode
      (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
      (ResponderContext PeerAddr)
      ByteString
      (IOSim s)
      NodeToNodeInitiatorResult
      Void]
 -> Bool)
-> TemperatureBundle
     [MiniProtocol
        'InitiatorMode
        (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
        (ResponderContext PeerAddr)
        ByteString
        (IOSim s)
        NodeToNodeInitiatorResult
        Void]
-> Bool
forall a b. (a -> b) -> a -> b
$
        Set CardanoFeatureFlag
-> MiniProtocolParameters
-> NodeToNodeVersion
-> NodeToNodeVersionData
-> Apps
     (IOSim s)
     PeerAddr
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
-> TemperatureBundle
     [MiniProtocol
        'InitiatorMode
        (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
        (ResponderContext PeerAddr)
        ByteString
        (IOSim s)
        NodeToNodeInitiatorResult
        Void]
forall (m :: * -> *) addr b a c.
Set CardanoFeatureFlag
-> MiniProtocolParameters
-> NodeToNodeVersion
-> NodeToNodeVersionData
-> Apps m addr b b b b b b b b b a c
-> OuroborosBundleWithExpandedCtx
     'InitiatorMode addr PeerTrustable b m a Void
NTN.initiator Set CardanoFeatureFlag
forall a. Monoid a => a
mempty MiniProtocolParameters
defaultMiniProtocolParameters NodeToNodeVersion
ntnVersion NodeToNodeVersionData
versionData (NodeUnderTest (IOSim s)
-> BlockNodeToNodeVersion Blk
-> Apps
     (IOSim s)
     PeerAddr
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
forall (m :: * -> *).
NodeUnderTest m -> BlockNodeToNodeVersion Blk -> NodeApps m
nutApps NodeUnderTest (IOSim s)
nut ())
    , TemperatureBundle
  [MiniProtocol
     'InitiatorResponderMode
     (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
     (ResponderContext PeerAddr)
     ByteString
     (IOSim s)
     NodeToNodeInitiatorResult
     ()]
-> Bool
forall {mode :: Mode} {initiatorCtx} {responderCtx} {bytes}
       {m :: * -> *} {a} {b}.
TemperatureBundle
  [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> Bool
runsLeiosFetch (TemperatureBundle
   [MiniProtocol
      'InitiatorResponderMode
      (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
      (ResponderContext PeerAddr)
      ByteString
      (IOSim s)
      NodeToNodeInitiatorResult
      ()]
 -> Bool)
-> TemperatureBundle
     [MiniProtocol
        'InitiatorResponderMode
        (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
        (ResponderContext PeerAddr)
        ByteString
        (IOSim s)
        NodeToNodeInitiatorResult
        ()]
-> Bool
forall a b. (a -> b) -> a -> b
$
        Set CardanoFeatureFlag
-> MiniProtocolParameters
-> NodeToNodeVersion
-> NodeToNodeVersionData
-> Apps
     (IOSim s)
     PeerAddr
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
-> TemperatureBundle
     [MiniProtocol
        'InitiatorResponderMode
        (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
        (ResponderContext PeerAddr)
        ByteString
        (IOSim s)
        NodeToNodeInitiatorResult
        ()]
forall (m :: * -> *) addr b a c.
Set CardanoFeatureFlag
-> MiniProtocolParameters
-> NodeToNodeVersion
-> NodeToNodeVersionData
-> Apps m addr b b b b b b b b b a c
-> OuroborosBundleWithExpandedCtx
     'InitiatorResponderMode addr PeerTrustable b m a c
NTN.initiatorAndResponder
          Set CardanoFeatureFlag
forall a. Monoid a => a
mempty
          MiniProtocolParameters
defaultMiniProtocolParameters
          NodeToNodeVersion
ntnVersion
          NodeToNodeVersionData
versionData
          (NodeUnderTest (IOSim s)
-> BlockNodeToNodeVersion Blk
-> Apps
     (IOSim s)
     PeerAddr
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     NodeToNodeInitiatorResult
     ()
forall (m :: * -> *).
NodeUnderTest m -> BlockNodeToNodeVersion Blk -> NodeApps m
nutApps NodeUnderTest (IOSim s)
nut ())
    )
 where
  versionData :: NodeToNodeVersionData
versionData = NodeToNodeVersion -> NodeToNodeVersionData
nodeVersionData NodeToNodeVersion
ntnVersion
  runsLeiosFetch :: TemperatureBundle
  [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> Bool
runsLeiosFetch TemperatureBundle
  [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
bundle = case TemperatureBundle
  [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> WithProtocolTemperature
     'Hot [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
forall a. TemperatureBundle a -> WithProtocolTemperature 'Hot a
withHot TemperatureBundle
  [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
bundle of
    WithHot [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
protocols -> MiniProtocolNum
leiosFetchMiniProtocolNum MiniProtocolNum -> [MiniProtocolNum] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (MiniProtocol mode initiatorCtx responderCtx bytes m a b
 -> MiniProtocolNum)
-> [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> [MiniProtocolNum]
forall a b. (a -> b) -> [a] -> [b]
map MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolNum
forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolNum
miniProtocolNum [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
protocols

{-------------------------------------------------------------------------------
  The node, connected to peers run by the test
-------------------------------------------------------------------------------}

-- | The node's LeiosFetch server on the connection.
nodeLeiosFetchServer ::
  NodeVsEnvConnection (IOSim s) -> IOSim s (STM (IOSim s) (Either SomeException ()))
nodeLeiosFetchServer :: forall s.
NodeVsEnvConnection (IOSim s)
-> IOSim s (STM (IOSim s) (Either SomeException ()))
nodeLeiosFetchServer NodeVsEnvConnection (IOSim s)
conn =
  IOSim s (STM (IOSim s) (Either SomeException ()))
-> (STM s (Either SomeException ())
    -> IOSim s (STM (IOSim s) (Either SomeException ())))
-> Maybe (STM s (Either SomeException ()))
-> IOSim s (STM (IOSim s) (Either SomeException ()))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IOError -> IOSim s (STM (IOSim s) (Either SomeException ()))
forall e a. Exception e => e -> IOSim s a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOError -> IOSim s (STM (IOSim s) (Either SomeException ())))
-> IOError -> IOSim s (STM (IOSim s) (Either SomeException ()))
forall a b. (a -> b) -> a -> b
$ TestName -> IOError
userError TestName
"the node does not run a LeiosFetch server") STM s (Either SomeException ())
-> IOSim s (STM (IOSim s) (Either SomeException ()))
STM s (Either SomeException ())
-> IOSim s (STM s (Either SomeException ()))
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (STM s (Either SomeException ()))
 -> IOSim s (STM (IOSim s) (Either SomeException ())))
-> Maybe (STM s (Either SomeException ()))
-> IOSim s (STM (IOSim s) (Either SomeException ()))
forall a b. (a -> b) -> a -> b
$
    MiniProtocolNum
-> Map MiniProtocolNum (STM s (Either SomeException ()))
-> Maybe (STM s (Either SomeException ()))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MiniProtocolNum
leiosFetchMiniProtocolNum (NodeVsEnvConnection (IOSim s)
-> Map MiniProtocolNum (STM (IOSim s) (Either SomeException ()))
forall (m :: * -> *).
NodeVsEnvConnection m
-> Map MiniProtocolNum (STM m (Either SomeException ()))
connNodeResponders NodeVsEnvConnection (IOSim s)
conn)