{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TupleSections #-}

-- | The node's peers, as run by the Leios node-vs-environment tests.
--
-- A peer connects to the node as the node's diffusion layer would have it: over
-- an in-memory bearer, the two run the handshake and then a mux each. The
-- node's end runs its whole negotiated bundle, starting every initiator as for
-- a hot peer and every responder as the bundle says. The peer's end answers
-- each of the node's initiators:
--
-- - KeepAlive and PeerSharing with the servers a node runs;
-- - ChainSync by finding the intersection at genesis and then never sending a
--   header;
-- - BlockFetch and TxSubmission by never saying anything, which is all the node
--   sees of a peer with nothing to offer;
-- - LeiosNotify with whatever the test gives it.
module Test.Consensus.Leios.Environment
  ( EnvPeer (..)
  , LeiosNotifyCodec
  , NodeVsEnvConnection (..)
  , envLeiosNotifyCodec
  , withNodeVsEnvConnection
  ) where

import Cardano.Network.NodeToNode
  ( chainSyncMiniProtocolNum
  , keepAliveMiniProtocolNum
  , nodeToNodeHandshakeCodec
  , nodeToNodeVersionDataCodec
  , peerSharingMiniProtocolNum
  )
import Cardano.Network.NodeToNode.Version (NodeToNodeVersion, NodeToNodeVersionData)
import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..))
import Codec.CBOR.Read (DeserialiseFailure)
import qualified Control.Concurrent.Class.MonadSTM.Strict as Strict
import Control.Monad.IOSim (IOSim)
import Control.Tracer (nullTracer)
import Data.ByteString.Lazy (ByteString)
import Data.Foldable (for_)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Traversable (for)
import qualified Network.Mux as Mx
import Network.Mux.Bearer.Queues (QueueChannel (..), queueChannelAsBearer)
import Network.TypedProtocol.Codec (Codec)
import Numeric.Natural (Natural)
import Ouroboros.Consensus.Block (Header, Point, pattern BlockPoint, pattern GenesisPoint)
import Ouroboros.Consensus.Config (configCodec)
import Ouroboros.Consensus.Leios.Types (LeiosPoint, LeiosVote)
import Ouroboros.Consensus.MiniProtocol.LeiosNotify.Type (LeiosNotify)
import Ouroboros.Consensus.Network.LeiosNotify (leiosNotifyMiniProtocolNum)
import qualified Ouroboros.Consensus.Network.NodeToNode as NTN
import Ouroboros.Consensus.Node.ExitPolicy (NodeToNodeInitiatorResult)
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.Block (Tip (..))
import Ouroboros.Network.Channel (Channel)
import Ouroboros.Network.ConnectionId (ConnectionId (..))
import Ouroboros.Network.Context
  ( ExpandedInitiatorContext (..)
  , ResponderContext (..)
  )
import Ouroboros.Network.ControlMessage (ControlMessage (..))
import Ouroboros.Network.Driver.Simple (runPeer)
import Ouroboros.Network.KeepAlive (keepAliveServer)
import Ouroboros.Network.Mux
  ( MiniProtocol (..)
  , MiniProtocolCb (..)
  , OuroborosApplication (..)
  , RunMiniProtocol (..)
  , fromOuroborosBundle
  , mkMiniProtocolInfos
  )
import Ouroboros.Network.PeerSelection.Governor.Types (makePublicPeerSelectionStateVar)
import Ouroboros.Network.PeerSelection.LedgerPeers.Type (IsBigLedgerPeer (..))
import Ouroboros.Network.PeerSharing
  ( PeerSharingAPI
  , newPeerSharingAPI
  , peerSharingServer
  , ps_POLICY_PEER_SHARE_MAX_PEERS
  , ps_POLICY_PEER_SHARE_STICKY_TIME
  )
import Ouroboros.Network.Protocol.ChainSync.Server
  ( ChainSyncServer (..)
  , ServerStIdle (..)
  , ServerStIntersect (..)
  , chainSyncServerPeer
  )
import Ouroboros.Network.Protocol.Handshake
  ( HandshakeArguments (..)
  , HandshakeResult (..)
  , Versions
  , acceptableVersion
  , combineVersions
  , queryVersion
  , runHandshakeClient
  , runHandshakeServer
  , simpleSingletonVersions
  , timeLimitsHandshake
  )
import Ouroboros.Network.Protocol.KeepAlive.Server (keepAliveServerPeer)
import Ouroboros.Network.Protocol.PeerSharing.Server (peerSharingServerPeer)
import System.Random (StdGen)
import Test.Consensus.Leios.NodeUnderTest

type LeiosNotifyCodec s =
  Codec (LeiosNotify LeiosPoint (Header Blk) LeiosVote) DeserialiseFailure (IOSim s) ByteString

-- | What a peer runs for LeiosNotify.
data EnvPeer m = EnvPeer
  { forall (m :: * -> *). EnvPeer m -> Channel m ByteString -> m ()
epLeiosNotifyServer :: Channel m ByteString -> m ()
  -- ^ Answers the node's client.
  , forall (m :: * -> *).
EnvPeer m -> Maybe (Channel m ByteString -> m ())
epLeiosNotifyClient :: Maybe (Channel m ByteString -> m ())
  -- ^ Talks to the node's server, if the test has the peer do so.
  }

-- | A connection from the node to a peer, once the handshake has settled on a
-- version.
data NodeVsEnvConnection m = NodeVsEnvConnection
  { forall (m :: * -> *). NodeVsEnvConnection m -> m ()
connTerminate :: m ()
  -- ^ Tell the node's initiators to wind down, as when the node demotes the
  -- peer.
  , forall (m :: * -> *).
NodeVsEnvConnection m
-> Map
     MiniProtocolNum
     (STM m (Either SomeException NodeToNodeInitiatorResult))
connNodeInitiators ::
      Map Mx.MiniProtocolNum (STM m (Either SomeException NodeToNodeInitiatorResult))
  -- ^ The result of each of the node's initiators.
  , forall (m :: * -> *).
NodeVsEnvConnection m
-> Map MiniProtocolNum (STM m (Either SomeException ()))
connNodeResponders :: Map Mx.MiniProtocolNum (STM m (Either SomeException ()))
  -- ^ The result of each of the node's responders.
  , forall (m :: * -> *).
NodeVsEnvConnection m -> Maybe (STM m (Either SomeException ()))
connPeerLeiosNotifyClient :: Maybe (STM m (Either SomeException ()))
  -- ^ The result of the peer's LeiosNotify client, if it runs one.
  }

-- | Connect the node to the peer at the given address, run the body, then shut
-- both ends down.
withNodeVsEnvConnection ::
  NodeUnderTest (IOSim s) ->
  PeerAddr ->
  EnvPeer (IOSim s) ->
  (NodeVsEnvConnection (IOSim s) -> IOSim s a) ->
  IOSim s a
withNodeVsEnvConnection :: forall s a.
NodeUnderTest (IOSim s)
-> PeerAddr
-> EnvPeer (IOSim s)
-> (NodeVsEnvConnection (IOSim s) -> IOSim s a)
-> IOSim s a
withNodeVsEnvConnection NodeUnderTest (IOSim s)
nut PeerAddr
addr EnvPeer (IOSim s)
envPeer NodeVsEnvConnection (IOSim s) -> IOSim s a
body = do
  nodeToPeer <- Natural -> IOSim s (StrictTBQueue (IOSim s) ByteString)
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> m (StrictTBQueue m a)
Strict.newTBQueueIO Natural
bearerQueueCapacity
  peerToNode <- Strict.newTBQueueIO bearerQueueCapacity
  let nodeBearer = SDUSize -> QueueChannel (IOSim s) -> Bearer (IOSim s)
forall (m :: * -> *).
(MonadSTM m, MonadMonotonicTime m, MonadThrow m) =>
SDUSize -> QueueChannel m -> Bearer m
queueChannelAsBearer SDUSize
sduSize QueueChannel{readQueue :: StrictTBQueue (IOSim s) ByteString
readQueue = StrictTBQueue (IOSim s) ByteString
peerToNode, writeQueue :: StrictTBQueue (IOSim s) ByteString
writeQueue = StrictTBQueue (IOSim s) ByteString
nodeToPeer}
      peerBearer = SDUSize -> QueueChannel (IOSim s) -> Bearer (IOSim s)
forall (m :: * -> *).
(MonadSTM m, MonadMonotonicTime m, MonadThrow m) =>
SDUSize -> QueueChannel m -> Bearer m
queueChannelAsBearer SDUSize
sduSize QueueChannel{readQueue :: StrictTBQueue (IOSim s) ByteString
readQueue = StrictTBQueue (IOSim s) ByteString
nodeToPeer, writeQueue :: StrictTBQueue (IOSim s) ByteString
writeQueue = StrictTBQueue (IOSim s) ByteString
peerToNode}
      nodeConnId = ConnectionId{localAddress :: PeerAddr
localAddress = PeerAddr
nodeAddr, remoteAddress :: PeerAddr
remoteAddress = PeerAddr
addr}
      peerConnId = ConnectionId{localAddress :: PeerAddr
localAddress = PeerAddr
addr, remoteAddress :: PeerAddr
remoteAddress = PeerAddr
nodeAddr}
  (bundle, version) <-
    concurrently
      (runHandshakeClient nodeBearer nodeConnId handshakeArguments (nutVersions nut))
      (runHandshakeServer peerBearer peerConnId handshakeArguments peerVersions)
      >>= \case
        (Right (HandshakeNegotiationResult TemperatureBundle
  [MiniProtocol
     'InitiatorResponderMode
     (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
     (ResponderContext PeerAddr)
     ByteString
     (IOSim s)
     NodeToNodeInitiatorResult
     ()]
bundle NodeToNodeVersion
version NodeToNodeVersionData
_), Right HandshakeNegotiationResult{}) ->
          (TemperatureBundle
   [MiniProtocol
      'InitiatorResponderMode
      (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
      (ResponderContext PeerAddr)
      ByteString
      (IOSim s)
      NodeToNodeInitiatorResult
      ()],
 NodeToNodeVersion)
-> IOSim
     s
     (TemperatureBundle
        [MiniProtocol
           'InitiatorResponderMode
           (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
           (ResponderContext PeerAddr)
           ByteString
           (IOSim s)
           NodeToNodeInitiatorResult
           ()],
      NodeToNodeVersion)
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TemperatureBundle
  [MiniProtocol
     'InitiatorResponderMode
     (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
     (ResponderContext PeerAddr)
     ByteString
     (IOSim s)
     NodeToNodeInitiatorResult
     ()]
bundle, NodeToNodeVersion
version)
        (Either
   (HandshakeException NodeToNodeVersion)
   (HandshakeResult
      (TemperatureBundle
         [MiniProtocol
            'InitiatorResponderMode
            (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
            (ResponderContext PeerAddr)
            ByteString
            (IOSim s)
            NodeToNodeInitiatorResult
            ()])
      NodeToNodeVersion
      NodeToNodeVersionData),
 Either
   (HandshakeException NodeToNodeVersion)
   (HandshakeResult () NodeToNodeVersion NodeToNodeVersionData))
_ -> IOError
-> IOSim
     s
     (TemperatureBundle
        [MiniProtocol
           'InitiatorResponderMode
           (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
           (ResponderContext PeerAddr)
           ByteString
           (IOSim s)
           NodeToNodeInitiatorResult
           ()],
      NodeToNodeVersion)
forall e a. Exception e => e -> IOSim s a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOError
 -> IOSim
      s
      (TemperatureBundle
         [MiniProtocol
            'InitiatorResponderMode
            (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
            (ResponderContext PeerAddr)
            ByteString
            (IOSim s)
            NodeToNodeInitiatorResult
            ()],
       NodeToNodeVersion))
-> IOError
-> IOSim
     s
     (TemperatureBundle
        [MiniProtocol
           'InitiatorResponderMode
           (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
           (ResponderContext PeerAddr)
           ByteString
           (IOSim s)
           NodeToNodeInitiatorResult
           ()],
      NodeToNodeVersion)
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"the node and the peer did not agree on a version"
  controlMessage <- Strict.newTVarIO Continue
  peerSharingAPI <- do
    publicPeerSelectionStateVar <- makePublicPeerSelectionStateVar
    newPeerSharingAPI
      publicPeerSelectionStateVar
      (seedEnvPeerSharing (nutSeeds nut))
      ps_POLICY_PEER_SHARE_STICKY_TIME
      ps_POLICY_PEER_SHARE_MAX_PEERS
  let protocols = OuroborosApplication
  'InitiatorResponderMode
  (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
  (ResponderContext PeerAddr)
  ByteString
  (IOSim s)
  NodeToNodeInitiatorResult
  ()
-> [MiniProtocol
      'InitiatorResponderMode
      (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
      (ResponderContext PeerAddr)
      ByteString
      (IOSim s)
      NodeToNodeInitiatorResult
      ()]
forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
OuroborosApplication mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocol mode initiatorCtx responderCtx bytes m a b]
getOuroborosApplication (TemperatureBundle
  [MiniProtocol
     'InitiatorResponderMode
     (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
     (ResponderContext PeerAddr)
     ByteString
     (IOSim s)
     NodeToNodeInitiatorResult
     ()]
-> OuroborosApplication
     'InitiatorResponderMode
     (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
     (ResponderContext PeerAddr)
     ByteString
     (IOSim s)
     NodeToNodeInitiatorResult
     ()
forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
OuroborosBundle mode initiatorCtx responderCtx bytes m a b
-> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
fromOuroborosBundle TemperatureBundle
  [MiniProtocol
     'InitiatorResponderMode
     (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
     (ResponderContext PeerAddr)
     ByteString
     (IOSim s)
     NodeToNodeInitiatorResult
     ()]
bundle)
      infos = ForkPolicyCb
-> TemperatureBundle
     [MiniProtocol
        'InitiatorResponderMode
        (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
        (ResponderContext PeerAddr)
        ByteString
        (IOSim s)
        NodeToNodeInitiatorResult
        ()]
-> [MiniProtocolInfo 'InitiatorResponderMode]
forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
ForkPolicyCb
-> OuroborosBundle mode initiatorCtx responderCtx bytes m a b
-> [MiniProtocolInfo mode]
mkMiniProtocolInfos (\MiniProtocolNum
_ MiniProtocolDir
_ -> Maybe Int
forall a. Maybe a
Nothing) TemperatureBundle
  [MiniProtocol
     'InitiatorResponderMode
     (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
     (ResponderContext PeerAddr)
     ByteString
     (IOSim s)
     NodeToNodeInitiatorResult
     ()]
bundle
      codecs = NodeUnderTest (IOSim s) -> NodeToNodeVersion -> NodeCodecs s
forall s.
NodeUnderTest (IOSim s) -> NodeToNodeVersion -> NodeCodecs s
envCodecs NodeUnderTest (IOSim s)
nut NodeToNodeVersion
version
  nodeMux <- Mx.new Mx.nullTracers infos
  peerMux <- Mx.new Mx.nullTracers infos
  withAsync (Mx.run nodeMux nodeBearer) $ \Async (IOSim s) ()
_ ->
    IOSim s () -> (Async (IOSim s) () -> IOSim s a) -> IOSim s a
forall a b.
IOSim s a -> (Async (IOSim s) a -> IOSim s b) -> IOSim s b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync (Mux 'InitiatorResponderMode (IOSim s)
-> Bearer (IOSim s) -> IOSim s ()
forall (m :: * -> *) (mode :: Mode).
(MonadAsync m, MonadDelay m, MonadEvaluate m, MonadFork m,
 MonadLabelledSTM m, Alternative (STM m), MonadThrow (STM m),
 MonadTimer m, MonadMask m) =>
Mux mode m -> Bearer m -> m ()
Mx.run Mux 'InitiatorResponderMode (IOSim s)
peerMux Bearer (IOSim s)
peerBearer) ((Async (IOSim s) () -> IOSim s a) -> IOSim s a)
-> (Async (IOSim s) () -> IOSim s a) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ \Async (IOSim s) ()
_ -> do
      [MiniProtocol
   'InitiatorResponderMode
   (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
   (ResponderContext PeerAddr)
   ByteString
   (IOSim s)
   NodeToNodeInitiatorResult
   ()]
-> (MiniProtocol
      'InitiatorResponderMode
      (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
      (ResponderContext PeerAddr)
      ByteString
      (IOSim s)
      NodeToNodeInitiatorResult
      ()
    -> IOSim s (STM s (Either SomeException ())))
-> IOSim s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [MiniProtocol
   'InitiatorResponderMode
   (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
   (ResponderContext PeerAddr)
   ByteString
   (IOSim s)
   NodeToNodeInitiatorResult
   ()]
protocols ((MiniProtocol
    'InitiatorResponderMode
    (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
    (ResponderContext PeerAddr)
    ByteString
    (IOSim s)
    NodeToNodeInitiatorResult
    ()
  -> IOSim s (STM s (Either SomeException ())))
 -> IOSim s ())
-> (MiniProtocol
      'InitiatorResponderMode
      (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
      (ResponderContext PeerAddr)
      ByteString
      (IOSim s)
      NodeToNodeInitiatorResult
      ()
    -> IOSim s (STM s (Either SomeException ())))
-> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \MiniProtocol{MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
miniProtocolNum :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolNum
miniProtocolNum} ->
        Mux 'InitiatorResponderMode (IOSim s)
-> MiniProtocolNum
-> MiniProtocolDirection 'InitiatorResponderMode
-> StartOnDemandOrEagerly
-> (ByteChannel (IOSim s) -> IOSim s ((), Maybe ByteString))
-> IOSim s (STM (IOSim s) (Either SomeException ()))
forall (mode :: Mode) (m :: * -> *) a.
(Alternative (STM m), MonadSTM m, MonadThrow (STM m)) =>
Mux mode m
-> MiniProtocolNum
-> MiniProtocolDirection mode
-> StartOnDemandOrEagerly
-> (ByteChannel m -> m (a, Maybe ByteString))
-> m (STM m (Either SomeException a))
Mx.runMiniProtocol
          Mux 'InitiatorResponderMode (IOSim s)
peerMux
          MiniProtocolNum
miniProtocolNum
          MiniProtocolDirection 'InitiatorResponderMode
Mx.ResponderDirection
          StartOnDemandOrEagerly
Mx.StartOnDemand
          (NodeCodecs s
-> PeerSharingAPI PeerAddr StdGen (IOSim s)
-> EnvPeer (IOSim s)
-> MiniProtocolNum
-> ByteChannel (IOSim s)
-> IOSim s ((), Maybe ByteString)
forall s.
NodeCodecs s
-> PeerSharingAPI PeerAddr StdGen (IOSim s)
-> EnvPeer (IOSim s)
-> MiniProtocolNum
-> Channel (IOSim s) ByteString
-> IOSim s ((), Maybe ByteString)
peerResponder NodeCodecs s
codecs PeerSharingAPI PeerAddr StdGen (IOSim s)
peerSharingAPI EnvPeer (IOSim s)
envPeer MiniProtocolNum
miniProtocolNum)
      connPeerLeiosNotifyClient <-
        Maybe (ByteChannel (IOSim s) -> IOSim s ())
-> ((ByteChannel (IOSim s) -> IOSim s ())
    -> IOSim s (STM s (Either SomeException ())))
-> IOSim s (Maybe (STM s (Either SomeException ())))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (EnvPeer (IOSim s) -> Maybe (ByteChannel (IOSim s) -> IOSim s ())
forall (m :: * -> *).
EnvPeer m -> Maybe (Channel m ByteString -> m ())
epLeiosNotifyClient EnvPeer (IOSim s)
envPeer) (((ByteChannel (IOSim s) -> IOSim s ())
  -> IOSim s (STM s (Either SomeException ())))
 -> IOSim s (Maybe (STM s (Either SomeException ()))))
-> ((ByteChannel (IOSim s) -> IOSim s ())
    -> IOSim s (STM s (Either SomeException ())))
-> IOSim s (Maybe (STM s (Either SomeException ())))
forall a b. (a -> b) -> a -> b
$ \ByteChannel (IOSim s) -> IOSim s ()
client ->
          Mux 'InitiatorResponderMode (IOSim s)
-> MiniProtocolNum
-> MiniProtocolDirection 'InitiatorResponderMode
-> StartOnDemandOrEagerly
-> (ByteChannel (IOSim s) -> IOSim s ((), Maybe ByteString))
-> IOSim s (STM (IOSim s) (Either SomeException ()))
forall (mode :: Mode) (m :: * -> *) a.
(Alternative (STM m), MonadSTM m, MonadThrow (STM m)) =>
Mux mode m
-> MiniProtocolNum
-> MiniProtocolDirection mode
-> StartOnDemandOrEagerly
-> (ByteChannel m -> m (a, Maybe ByteString))
-> m (STM m (Either SomeException a))
Mx.runMiniProtocol
            Mux 'InitiatorResponderMode (IOSim s)
peerMux
            MiniProtocolNum
leiosNotifyMiniProtocolNum
            MiniProtocolDirection 'InitiatorResponderMode
Mx.InitiatorDirection
            StartOnDemandOrEagerly
Mx.StartEagerly
            ((() -> ((), Maybe ByteString))
-> IOSim s () -> IOSim s ((), Maybe ByteString)
forall a b. (a -> b) -> IOSim s a -> IOSim s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Maybe ByteString
forall a. Maybe a
Nothing) (IOSim s () -> IOSim s ((), Maybe ByteString))
-> (ByteChannel (IOSim s) -> IOSim s ())
-> ByteChannel (IOSim s)
-> IOSim s ((), Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteChannel (IOSim s) -> IOSim s ()
client)
      nodeProtocols <-
        for protocols $ \MiniProtocol{MiniProtocolNum
miniProtocolNum :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> MiniProtocolNum
miniProtocolNum :: MiniProtocolNum
miniProtocolNum, StartOnDemandOrEagerly
miniProtocolStart :: StartOnDemandOrEagerly
miniProtocolStart :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> StartOnDemandOrEagerly
miniProtocolStart, RunMiniProtocol
  'InitiatorResponderMode
  (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
  (ResponderContext PeerAddr)
  ByteString
  (IOSim s)
  NodeToNodeInitiatorResult
  ()
miniProtocolRun :: RunMiniProtocol
  'InitiatorResponderMode
  (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
  (ResponderContext PeerAddr)
  ByteString
  (IOSim s)
  NodeToNodeInitiatorResult
  ()
miniProtocolRun :: forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
MiniProtocol mode initiatorCtx responderCtx bytes m a b
-> RunMiniProtocol mode initiatorCtx responderCtx bytes m a b
miniProtocolRun} ->
          case RunMiniProtocol
  'InitiatorResponderMode
  (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
  (ResponderContext PeerAddr)
  ByteString
  (IOSim s)
  NodeToNodeInitiatorResult
  ()
miniProtocolRun of
            InitiatorAndResponderProtocol MiniProtocolCb
  (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
  ByteString
  (IOSim s)
  NodeToNodeInitiatorResult
initiator MiniProtocolCb (ResponderContext PeerAddr) ByteString (IOSim s) ()
responder -> do
              initiatorResult <-
                Mux 'InitiatorResponderMode (IOSim s)
-> MiniProtocolNum
-> MiniProtocolDirection 'InitiatorResponderMode
-> StartOnDemandOrEagerly
-> (ByteChannel (IOSim s)
    -> IOSim s (NodeToNodeInitiatorResult, Maybe ByteString))
-> IOSim
     s (STM (IOSim s) (Either SomeException NodeToNodeInitiatorResult))
forall (mode :: Mode) (m :: * -> *) a.
(Alternative (STM m), MonadSTM m, MonadThrow (STM m)) =>
Mux mode m
-> MiniProtocolNum
-> MiniProtocolDirection mode
-> StartOnDemandOrEagerly
-> (ByteChannel m -> m (a, Maybe ByteString))
-> m (STM m (Either SomeException a))
Mx.runMiniProtocol
                  Mux 'InitiatorResponderMode (IOSim s)
nodeMux
                  MiniProtocolNum
miniProtocolNum
                  MiniProtocolDirection 'InitiatorResponderMode
Mx.InitiatorDirection
                  StartOnDemandOrEagerly
Mx.StartEagerly
                  ( MiniProtocolCb
  (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
  ByteString
  (IOSim s)
  NodeToNodeInitiatorResult
-> ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s)
-> ByteChannel (IOSim s)
-> IOSim s (NodeToNodeInitiatorResult, Maybe ByteString)
forall ctx bytes (m :: * -> *) a.
MiniProtocolCb ctx bytes m a
-> ctx -> Channel m bytes -> m (a, Maybe bytes)
runMiniProtocolCb
                      MiniProtocolCb
  (ExpandedInitiatorContext PeerAddr PeerTrustable (IOSim s))
  ByteString
  (IOSim s)
  NodeToNodeInitiatorResult
initiator
                      ExpandedInitiatorContext
                        { eicConnectionId :: ConnectionId PeerAddr
eicConnectionId = ConnectionId PeerAddr
nodeConnId
                        , eicControlMessage :: ControlMessageSTM (IOSim s)
eicControlMessage = StrictTVar (IOSim s) ControlMessage -> ControlMessageSTM (IOSim s)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
Strict.readTVar StrictTVar (IOSim s) ControlMessage
controlMessage
                        , eicIsBigLedgerPeer :: IsBigLedgerPeer
eicIsBigLedgerPeer = IsBigLedgerPeer
IsBigLedgerPeer
                        , eicExtraFlags :: PeerTrustable
eicExtraFlags = PeerTrustable
IsNotTrustable
                        }
                  )
              responderResult <-
                Mx.runMiniProtocol
                  nodeMux
                  miniProtocolNum
                  Mx.ResponderDirection
                  miniProtocolStart
                  (runMiniProtocolCb responder ResponderContext{rcConnectionId = nodeConnId})
              pure ((miniProtocolNum, initiatorResult), (miniProtocolNum, responderResult))
      result <-
        body
          NodeVsEnvConnection
            { connTerminate = atomically $ Strict.writeTVar controlMessage Terminate
            , connNodeInitiators = Map.fromList (map fst nodeProtocols)
            , connNodeResponders = Map.fromList (map snd nodeProtocols)
            , connPeerLeiosNotifyClient
            }
      Mx.stop nodeMux
      Mx.stop peerMux
      pure result

-- | The node's own address.
nodeAddr :: PeerAddr
nodeAddr :: PeerAddr
nodeAddr = Int -> PeerAddr
PeerAddr Int
0

-- | How many SDUs each direction of the bearer holds. When it is full, the
-- sending mux waits, as it would on a full socket buffer, so any size works.
bearerQueueCapacity :: Natural
bearerQueueCapacity :: Natural
bearerQueueCapacity = Natural
10

-- | The SDU size of the socket bearer a node uses.
sduSize :: Mx.SDUSize
sduSize :: SDUSize
sduSize = Word16 -> SDUSize
Mx.SDUSize Word16
12288

-- | What a node uses for the handshake, without its tracers.
handshakeArguments ::
  HandshakeArguments (ConnectionId PeerAddr) NodeToNodeVersion NodeToNodeVersionData (IOSim s)
handshakeArguments :: forall s.
HandshakeArguments
  (ConnectionId PeerAddr)
  NodeToNodeVersion
  NodeToNodeVersionData
  (IOSim s)
handshakeArguments =
  HandshakeArguments
    { haHandshakeTracer :: Tracer
  (IOSim s)
  (WithBearer
     (ConnectionId PeerAddr)
     (TraceSendRecv (Handshake NodeToNodeVersion Term)))
haHandshakeTracer = Tracer
  (IOSim s)
  (WithBearer
     (ConnectionId PeerAddr)
     (TraceSendRecv (Handshake NodeToNodeVersion Term)))
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer
    , haBearerTracer :: Tracer (IOSim s) (WithBearer (ConnectionId PeerAddr) BearerTrace)
haBearerTracer = Tracer (IOSim s) (WithBearer (ConnectionId PeerAddr) BearerTrace)
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer
    , haHandshakeCodec :: Codec
  (Handshake NodeToNodeVersion Term)
  DeserialiseFailure
  (IOSim s)
  ByteString
haHandshakeCodec = Codec
  (Handshake NodeToNodeVersion Term)
  DeserialiseFailure
  (IOSim s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (Handshake NodeToNodeVersion Term) DeserialiseFailure m ByteString
nodeToNodeHandshakeCodec
    , haVersionDataCodec :: VersionDataCodec NodeToNodeVersion NodeToNodeVersionData
haVersionDataCodec = VersionDataCodec NodeToNodeVersion NodeToNodeVersionData
nodeToNodeVersionDataCodec
    , haAcceptVersion :: NodeToNodeVersionData
-> NodeToNodeVersionData -> Accept NodeToNodeVersionData
haAcceptVersion = NodeToNodeVersionData
-> NodeToNodeVersionData -> Accept NodeToNodeVersionData
forall versionData.
Acceptable versionData =>
versionData -> versionData -> Accept versionData
acceptableVersion
    , haQueryVersion :: NodeToNodeVersionData -> Bool
haQueryVersion = NodeToNodeVersionData -> Bool
forall versionData. Queryable versionData => versionData -> Bool
queryVersion
    , haTimeLimits :: ProtocolTimeLimits (Handshake NodeToNodeVersion Term)
haTimeLimits = ProtocolTimeLimits (Handshake NodeToNodeVersion Term)
forall {k} (vNumber :: k).
ProtocolTimeLimits (Handshake vNumber Term)
timeLimitsHandshake
    }

-- | The peer offers every version, with the version data the node itself
-- offers.
peerVersions :: Versions NodeToNodeVersion NodeToNodeVersionData ()
peerVersions :: Versions NodeToNodeVersion NodeToNodeVersionData ()
peerVersions =
  [Versions NodeToNodeVersion NodeToNodeVersionData ()]
-> Versions NodeToNodeVersion NodeToNodeVersionData ()
forall vNum (f :: * -> *) extra r.
(Ord vNum, Foldable f, HasCallStack) =>
f (Versions vNum extra r) -> Versions vNum extra r
combineVersions
    [ NodeToNodeVersion
-> NodeToNodeVersionData
-> (NodeToNodeVersionData -> ())
-> Versions NodeToNodeVersion NodeToNodeVersionData ()
forall vNum vData r.
vNum -> vData -> (vData -> r) -> Versions vNum vData r
simpleSingletonVersions NodeToNodeVersion
version (NodeToNodeVersion -> NodeToNodeVersionData
nodeVersionData NodeToNodeVersion
version) (() -> NodeToNodeVersionData -> ()
forall a b. a -> b -> a
const ())
    | NodeToNodeVersion
version <- [NodeToNodeVersion
forall a. Bounded a => a
minBound .. NodeToNodeVersion
forall a. Bounded a => a
maxBound]
    ]

-- | The peer's answer to the node's initiator with the given number.
peerResponder ::
  NodeCodecs s ->
  PeerSharingAPI PeerAddr StdGen (IOSim s) ->
  EnvPeer (IOSim s) ->
  Mx.MiniProtocolNum ->
  Channel (IOSim s) ByteString ->
  IOSim s ((), Maybe ByteString)
peerResponder :: forall s.
NodeCodecs s
-> PeerSharingAPI PeerAddr StdGen (IOSim s)
-> EnvPeer (IOSim s)
-> MiniProtocolNum
-> Channel (IOSim s) ByteString
-> IOSim s ((), Maybe ByteString)
peerResponder NodeCodecs s
codecs PeerSharingAPI PeerAddr StdGen (IOSim s)
peerSharingAPI EnvPeer (IOSim s)
envPeer MiniProtocolNum
num Channel (IOSim s) ByteString
chan
  | MiniProtocolNum
num MiniProtocolNum -> MiniProtocolNum -> Bool
forall a. Eq a => a -> a -> Bool
== MiniProtocolNum
chainSyncMiniProtocolNum =
      Tracer
  (IOSim s)
  (TraceSendRecv (ChainSync (Header Blk) (Point Blk) (Tip Blk)))
-> Codec
     (ChainSync (Header Blk) (Point Blk) (Tip Blk))
     DeserialiseFailure
     (IOSim s)
     ByteString
-> Channel (IOSim s) ByteString
-> Peer
     (ChainSync (Header Blk) (Point Blk) (Tip Blk))
     'AsServer
     'NonPipelined
     'StIdle
     (IOSim s)
     ()
-> IOSim s ((), Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadEvaluate m, MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 NFData a, NFData failure, Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer Tracer
  (IOSim s)
  (TraceSendRecv (ChainSync (Header Blk) (Point Blk) (Tip Blk)))
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer (NodeCodecs s
-> Codec
     (ChainSync (Header Blk) (Point Blk) (Tip Blk))
     DeserialiseFailure
     (IOSim s)
     ByteString
forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bPCD bPVD bKA
       bPS bLN.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bPCD bPVD bKA bPS bLN
-> Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS
NTN.cChainSyncCodec NodeCodecs s
codecs) Channel (IOSim s) ByteString
chan (ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
-> Peer
     (ChainSync (Header Blk) (Point Blk) (Tip Blk))
     'AsServer
     'NonPipelined
     'StIdle
     (IOSim s)
     ()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Server (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncServerPeer ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
forall s.
ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
quietChainSyncServer)
  | MiniProtocolNum
num MiniProtocolNum -> MiniProtocolNum -> Bool
forall a. Eq a => a -> a -> Bool
== MiniProtocolNum
keepAliveMiniProtocolNum =
      Tracer (IOSim s) (TraceSendRecv KeepAlive)
-> Codec KeepAlive DeserialiseFailure (IOSim s) ByteString
-> Channel (IOSim s) ByteString
-> Peer KeepAlive 'AsServer 'NonPipelined 'StClient (IOSim s) ()
-> IOSim s ((), Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadEvaluate m, MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 NFData a, NFData failure, Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer Tracer (IOSim s) (TraceSendRecv KeepAlive)
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer (NodeCodecs s
-> Codec KeepAlive DeserialiseFailure (IOSim s) ByteString
forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bPCD bPVD bKA
       bPS bLN.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bPCD bPVD bKA bPS bLN
-> Codec KeepAlive e m bKA
NTN.cKeepAliveCodec NodeCodecs s
codecs) Channel (IOSim s) ByteString
chan (KeepAliveServer (IOSim s) ()
-> Peer KeepAlive 'AsServer 'NonPipelined 'StClient (IOSim s) ()
forall (m :: * -> *) a.
Functor m =>
KeepAliveServer m a -> Server KeepAlive 'NonPipelined 'StClient m a
keepAliveServerPeer KeepAliveServer (IOSim s) ()
forall (m :: * -> *). Applicative m => KeepAliveServer m ()
keepAliveServer)
  | MiniProtocolNum
num MiniProtocolNum -> MiniProtocolNum -> Bool
forall a. Eq a => a -> a -> Bool
== MiniProtocolNum
peerSharingMiniProtocolNum =
      Tracer (IOSim s) (TraceSendRecv (PeerSharing PeerAddr))
-> Codec
     (PeerSharing PeerAddr) DeserialiseFailure (IOSim s) ByteString
-> Channel (IOSim s) ByteString
-> Peer
     (PeerSharing PeerAddr) 'AsServer 'NonPipelined 'StIdle (IOSim s) ()
-> IOSim s ((), Maybe ByteString)
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadEvaluate m, MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 NFData a, NFData failure, Show failure) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer
        Tracer (IOSim s) (TraceSendRecv (PeerSharing PeerAddr))
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer
        (NodeCodecs s
-> Codec
     (PeerSharing PeerAddr) DeserialiseFailure (IOSim s) ByteString
forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bPCD bPVD bKA
       bPS bLN.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bPCD bPVD bKA bPS bLN
-> Codec (PeerSharing addr) e m bPS
NTN.cPeerSharingCodec NodeCodecs s
codecs)
        Channel (IOSim s) ByteString
chan
        (PeerSharingServer PeerAddr (IOSim s)
-> Peer
     (PeerSharing PeerAddr) 'AsServer 'NonPipelined 'StIdle (IOSim s) ()
forall (m :: * -> *) peerAddress.
Monad m =>
PeerSharingServer peerAddress m
-> Server (PeerSharing peerAddress) 'NonPipelined 'StIdle m ()
peerSharingServerPeer (PeerSharingAPI PeerAddr StdGen (IOSim s)
-> PeerSharingServer PeerAddr (IOSim s)
forall (m :: * -> *) peer s.
(MonadSTM m, MonadMonotonicTime m, Hashable peer, RandomGen s) =>
PeerSharingAPI peer s m -> PeerSharingServer peer m
peerSharingServer PeerSharingAPI PeerAddr StdGen (IOSim s)
peerSharingAPI))
  | MiniProtocolNum
num MiniProtocolNum -> MiniProtocolNum -> Bool
forall a. Eq a => a -> a -> Bool
== MiniProtocolNum
leiosNotifyMiniProtocolNum =
      (,Maybe ByteString
forall a. Maybe a
Nothing) (() -> ((), Maybe ByteString))
-> IOSim s () -> IOSim s ((), Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnvPeer (IOSim s) -> Channel (IOSim s) ByteString -> IOSim s ()
forall (m :: * -> *). EnvPeer m -> Channel m ByteString -> m ()
epLeiosNotifyServer EnvPeer (IOSim s)
envPeer Channel (IOSim s) ByteString
chan
  | Bool
otherwise =
      STM (IOSim s) ((), Maybe ByteString)
-> IOSim s ((), Maybe ByteString)
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) ((), Maybe ByteString)
forall a. STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry

-- | A ChainSync server whose chain is empty and never grows.
--
-- The node gives a peer that is not trustable a random 135 to 269 seconds to
-- send its next header, and then disconnects, so a test that keeps a
-- connection open longer than 135 seconds loses it. That is probably not what
-- such a test intends, so it should serve a chain that grows instead.
quietChainSyncServer :: ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
quietChainSyncServer :: forall s.
ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
quietChainSyncServer = IOSim
  s (ServerStIdle (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
-> ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
forall header point tip (m :: * -> *) a.
m (ServerStIdle header point tip m a)
-> ChainSyncServer header point tip m a
ChainSyncServer (IOSim
   s (ServerStIdle (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
 -> ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
-> IOSim
     s (ServerStIdle (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
-> ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
forall a b. (a -> b) -> a -> b
$ ServerStIdle (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
-> IOSim
     s (ServerStIdle (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerStIdle (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
forall {s}.
ServerStIdle (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
idle
 where
  idle :: ServerStIdle (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
idle =
    ServerStIdle
      { recvMsgRequestNext :: IOSim
  s
  (Either
     (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
     (IOSim
        s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())))
recvMsgRequestNext = Either
  (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
  (IOSim
     s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()))
-> IOSim
     s
     (Either
        (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
        (IOSim
           s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())))
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
   (IOSim
      s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()))
 -> IOSim
      s
      (Either
         (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
         (IOSim
            s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()))))
-> Either
     (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
     (IOSim
        s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()))
-> IOSim
     s
     (Either
        (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
        (IOSim
           s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())))
forall a b. (a -> b) -> a -> b
$ IOSim
  s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
-> Either
     (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
     (IOSim
        s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()))
forall a b. b -> Either a b
Right (IOSim
   s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
 -> Either
      (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
      (IOSim
         s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())))
-> IOSim
     s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
-> Either
     (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
     (IOSim
        s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()))
forall a b. (a -> b) -> a -> b
$ STM
  (IOSim s)
  (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
-> IOSim
     s (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (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)
  (ServerStNext (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
forall a. STM (IOSim s) a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
      , recvMsgFindIntersect :: [Point Blk]
-> IOSim
     s
     (ServerStIntersect (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
recvMsgFindIntersect = \[Point Blk]
points ->
          ServerStIntersect (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
-> IOSim
     s
     (ServerStIntersect (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerStIntersect (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
 -> IOSim
      s
      (ServerStIntersect
         (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()))
-> ServerStIntersect
     (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
-> IOSim
     s
     (ServerStIntersect (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ())
forall a b. (a -> b) -> a -> b
$
            if (Point Blk -> Bool) -> [Point Blk] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Point Blk -> Bool
forall {block}. Point block -> Bool
isGenesis [Point Blk]
points
              then Point Blk
-> Tip Blk
-> ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
-> ServerStIntersect
     (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
forall point tip header (m :: * -> *) a.
point
-> tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectFound Point Blk
forall {k} (block :: k). Point block
GenesisPoint Tip Blk
forall {k} (b :: k). Tip b
TipGenesis ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
forall s.
ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
quietChainSyncServer
              else Tip Blk
-> ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
-> ServerStIntersect
     (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
forall tip header point (m :: * -> *) a.
tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectNotFound Tip Blk
forall {k} (b :: k). Tip b
TipGenesis ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
forall s.
ChainSyncServer (Header Blk) (Point Blk) (Tip Blk) (IOSim s) ()
quietChainSyncServer
      , recvMsgDoneClient :: IOSim s ()
recvMsgDoneClient = () -> IOSim s ()
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      }
  isGenesis :: Point block -> Bool
isGenesis = \case
    Point block
GenesisPoint -> Bool
True
    BlockPoint{} -> Bool
False

-- | The codecs the peer speaks, which are the node's.
-- | The node's codecs, at every mini-protocol's bytes.
type NodeCodecs s =
  NTN.Codecs
    Blk
    PeerAddr
    DeserialiseFailure
    (IOSim s)
    ByteString
    ByteString
    ByteString
    ByteString
    ByteString
    ByteString
    ByteString
    ByteString
    ByteString
    ByteString

envCodecs :: NodeUnderTest (IOSim s) -> NodeToNodeVersion -> NodeCodecs s
envCodecs :: forall s.
NodeUnderTest (IOSim s) -> NodeToNodeVersion -> NodeCodecs s
envCodecs NodeUnderTest (IOSim s)
nut =
  CodecConfig Blk
-> BlockNodeToNodeVersion Blk
-> (NodeToNodeVersion -> PeerAddr -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s PeerAddr)
-> NodeToNodeVersion
-> Codecs
     Blk
     PeerAddr
     DeserialiseFailure
     (IOSim s)
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
forall (m :: * -> *) blk addr.
(IOLike m, SerialiseNodeToNodeConstraints blk) =>
CodecConfig blk
-> BlockNodeToNodeVersion blk
-> (NodeToNodeVersion -> addr -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s addr)
-> NodeToNodeVersion
-> Codecs
     blk
     addr
     DeserialiseFailure
     m
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
NTN.defaultCodecs
    (TopLevelConfig Blk -> CodecConfig Blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec (NodeUnderTest (IOSim s) -> TopLevelConfig Blk
forall (m :: * -> *). NodeUnderTest m -> TopLevelConfig Blk
nutTopLevelConfig NodeUnderTest (IOSim s)
nut))
    ()
    ((PeerAddr -> Encoding) -> NodeToNodeVersion -> PeerAddr -> Encoding
forall a b. a -> b -> a
const PeerAddr -> Encoding
encodePeerAddr)
    (Decoder s PeerAddr -> NodeToNodeVersion -> Decoder s PeerAddr
forall a b. a -> b -> a
const Decoder s PeerAddr
forall s. Decoder s PeerAddr
decodePeerAddr)

envLeiosNotifyCodec :: NodeUnderTest (IOSim s) -> LeiosNotifyCodec s
envLeiosNotifyCodec :: forall s. NodeUnderTest (IOSim s) -> LeiosNotifyCodec s
envLeiosNotifyCodec NodeUnderTest (IOSim s)
nut = Codecs
  Blk
  PeerAddr
  DeserialiseFailure
  (IOSim s)
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
  ByteString
-> Codec
     (LeiosNotify LeiosPoint (Header Blk) LeiosVote)
     DeserialiseFailure
     (IOSim s)
     ByteString
forall blk addr e (m :: * -> *) bCS bSCS bBF bSBF bTX bPCD bPVD bKA
       bPS bLN.
Codecs blk addr e m bCS bSCS bBF bSBF bTX bPCD bPVD bKA bPS bLN
-> Codec (LeiosNotify LeiosPoint (Header blk) LeiosVote) e m bLN
NTN.cLeiosNotifyCodec (NodeUnderTest (IOSim s)
-> NodeToNodeVersion
-> Codecs
     Blk
     PeerAddr
     DeserialiseFailure
     (IOSim s)
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
     ByteString
forall s.
NodeUnderTest (IOSim s) -> NodeToNodeVersion -> NodeCodecs s
envCodecs NodeUnderTest (IOSim s)
nut NodeToNodeVersion
forall a. Bounded a => a
maxBound)