{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

module Cardano.Chairman (chairmanTest) where


import           Cardano.Api.Protocol.Types
import           Cardano.Node.Types (SocketPath (..))
import           Cardano.Prelude hiding (ByteString, STM, atomically, catch, option, show, throwIO)
import           Control.Monad.Class.MonadAsync
import           Control.Monad.Class.MonadST
import           Control.Monad.Class.MonadSTM.Strict
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Class.MonadTimer
import           Control.Tracer
import           Data.ByteString.Lazy (ByteString)
import           Data.Coerce (coerce)
import           Ouroboros.Consensus.Block (CodecConfig, GetHeader (..), Header)
import           Ouroboros.Consensus.Config.SecurityParam
import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx)
import           Ouroboros.Consensus.Network.NodeToClient
import           Ouroboros.Consensus.Node.NetworkProtocolVersion (HasNetworkProtocolVersion (..),
                     supportedNodeToClientVersions)
import           Ouroboros.Consensus.Node.ProtocolInfo (pClientInfoCodecConfig)
import           Ouroboros.Consensus.Node.Run
import           Ouroboros.Network.AnchoredFragment (Anchor, AnchoredFragment)
import           Ouroboros.Network.Block (BlockNo, HasHeader, Point, Tip)
import           Ouroboros.Network.Magic (NetworkMagic)
import           Ouroboros.Network.Mux
import           Ouroboros.Network.NodeToClient
import           Ouroboros.Network.Point (WithOrigin (..), fromWithOrigin)
import           Ouroboros.Network.Protocol.ChainSync.Client
import           Ouroboros.Network.Protocol.ChainSync.Type
import           Ouroboros.Network.Protocol.LocalTxSubmission.Type
import           Prelude (String, error, show)

import qualified Data.Map.Strict as Map
import qualified Ouroboros.Network.AnchoredFragment as AF
import qualified Ouroboros.Network.Block as Block

-- | The chairman checks for consensus and progress.
--
-- The chairman test is an integration test. It monitors a set of nodes and
-- checks that all the nodes agree on the chain, within a margin. It also
-- checks that enough blocks have been made.
--
-- Specifically in this case consensus is defined as follows: for all pairs
-- of chains, the intersection of each pair is within K blocks of each tip.
-- Progress is defined simply as each chain being at least of a certain length.
--
-- The consensus condition is checked incrementally as well as at the end, so
-- that failures can be detected as early as possible. The progress condition
-- is only checked at the end.
chairmanTest
  :: Tracer IO String
  -> SomeNodeClientProtocol
  -> NetworkMagic
  -> SecurityParam
  -> DiffTime
  -> BlockNo
  -> [SocketPath]
  -> IO ()
chairmanTest :: Tracer IO String
-> SomeNodeClientProtocol
-> NetworkMagic
-> SecurityParam
-> DiffTime
-> BlockNo
-> [SocketPath]
-> IO ()
chairmanTest Tracer IO String
tracer SomeNodeClientProtocol
protocol NetworkMagic
nw SecurityParam
securityParam DiffTime
runningTime BlockNo
progressThreshold [SocketPath]
socketPaths = do
  Tracer IO String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer (String
"Will observe nodes for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DiffTime -> String
forall a. Show a => a -> String
show DiffTime
runningTime)
  Tracer IO String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer (String
"Will require chain growth of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BlockNo -> String
forall a. Show a => a -> String
show BlockNo
progressThreshold)

  SomeNodeClientProtocol (ProtocolClientInfoArgs blk
ptcl :: ProtocolClientInfoArgs blk) <- SomeNodeClientProtocol -> IO SomeNodeClientProtocol
forall (m :: * -> *) a. Monad m => a -> m a
return SomeNodeClientProtocol
protocol

  -- Run the chairman and get the final snapshot of the chain from each node.
  ChainsSnapshot blk
chainsSnapshot <- Tracer IO String
-> CodecConfig blk
-> NetworkMagic
-> SecurityParam
-> DiffTime
-> [SocketPath]
-> IO (ChainsSnapshot blk)
forall blk.
RunNode blk =>
Tracer IO String
-> CodecConfig blk
-> NetworkMagic
-> SecurityParam
-> DiffTime
-> [SocketPath]
-> IO (ChainsSnapshot blk)
runChairman
    Tracer IO String
tracer
    (ProtocolClientInfo blk -> CodecConfig blk
forall b. ProtocolClientInfo b -> CodecConfig b
pClientInfoCodecConfig (ProtocolClientInfoArgs blk -> ProtocolClientInfo blk
forall blk.
ProtocolClient blk =>
ProtocolClientInfoArgs blk -> ProtocolClientInfo blk
protocolClientInfo ProtocolClientInfoArgs blk
ptcl))
    NetworkMagic
nw
    SecurityParam
securityParam
    DiffTime
runningTime
    [SocketPath]
socketPaths

  Tracer IO String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer String
"================== chairman results =================="

  -- Test if we achieved consensus
  ConsensusSuccess blk
consensusSuccess <- (ConsensusFailure blk -> IO (ConsensusSuccess blk))
-> (ConsensusSuccess blk -> IO (ConsensusSuccess blk))
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
-> IO (ConsensusSuccess blk)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ConsensusFailure blk -> IO (ConsensusSuccess blk)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ConsensusSuccess blk -> IO (ConsensusSuccess blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ConsensusFailure blk) (ConsensusSuccess blk)
 -> IO (ConsensusSuccess blk))
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
-> IO (ConsensusSuccess blk)
forall a b. (a -> b) -> a -> b
$
                        SecurityParam
-> ChainsSnapshot blk
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
forall blk.
HasHeader (Header blk) =>
SecurityParam
-> ChainsSnapshot blk
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
consensusCondition SecurityParam
securityParam ChainsSnapshot blk
chainsSnapshot

  Tracer IO String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer (ConsensusSuccess blk -> String
forall a. Show a => a -> String
show ConsensusSuccess blk
consensusSuccess)

  -- Test if we made adequate progress
  ProgressSuccess
progressSuccess <- (ProgressFailure blk -> IO ProgressSuccess)
-> (ProgressSuccess -> IO ProgressSuccess)
-> Either (ProgressFailure blk) ProgressSuccess
-> IO ProgressSuccess
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProgressFailure blk -> IO ProgressSuccess
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ProgressSuccess -> IO ProgressSuccess
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ProgressFailure blk) ProgressSuccess
 -> IO ProgressSuccess)
-> Either (ProgressFailure blk) ProgressSuccess
-> IO ProgressSuccess
forall a b. (a -> b) -> a -> b
$
                        BlockNo
-> ConsensusSuccess blk
-> Either (ProgressFailure blk) ProgressSuccess
forall blk.
BlockNo
-> ConsensusSuccess blk
-> Either (ProgressFailure blk) ProgressSuccess
progressCondition BlockNo
progressThreshold ConsensusSuccess blk
consensusSuccess

  Tracer IO String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer (ProgressSuccess -> String
forall a. Show a => a -> String
show ProgressSuccess
progressSuccess)
  Tracer IO String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer String
"================== chairman results =================="

type ChainsSnapshot blk = Map PeerId (AnchoredFragment (Header blk))

type PeerId = SocketPath

data ConsensusSuccess blk = ConsensusSuccess
    -- Minimum of the maximum intersection points
    (Anchor (Header blk))
    -- Chain tip for each chain
    [(PeerId, Tip (Header blk))]
  deriving Int -> ConsensusSuccess blk -> String -> String
[ConsensusSuccess blk] -> String -> String
ConsensusSuccess blk -> String
(Int -> ConsensusSuccess blk -> String -> String)
-> (ConsensusSuccess blk -> String)
-> ([ConsensusSuccess blk] -> String -> String)
-> Show (ConsensusSuccess blk)
forall blk.
HasHeader blk =>
Int -> ConsensusSuccess blk -> String -> String
forall blk.
HasHeader blk =>
[ConsensusSuccess blk] -> String -> String
forall blk. HasHeader blk => ConsensusSuccess blk -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ConsensusSuccess blk] -> String -> String
$cshowList :: forall blk.
HasHeader blk =>
[ConsensusSuccess blk] -> String -> String
show :: ConsensusSuccess blk -> String
$cshow :: forall blk. HasHeader blk => ConsensusSuccess blk -> String
showsPrec :: Int -> ConsensusSuccess blk -> String -> String
$cshowsPrec :: forall blk.
HasHeader blk =>
Int -> ConsensusSuccess blk -> String -> String
Show

data ConsensusFailure blk = ConsensusFailure
    -- Tip of two peer's chains that do not intersect within K blocks
    (PeerId, Tip (Header blk))
    (PeerId, Tip (Header blk))
    -- The intersection point of two chains
    (Anchor (Header blk))
    SecurityParam
  deriving Int -> ConsensusFailure blk -> String -> String
[ConsensusFailure blk] -> String -> String
ConsensusFailure blk -> String
(Int -> ConsensusFailure blk -> String -> String)
-> (ConsensusFailure blk -> String)
-> ([ConsensusFailure blk] -> String -> String)
-> Show (ConsensusFailure blk)
forall blk.
HasHeader blk =>
Int -> ConsensusFailure blk -> String -> String
forall blk.
HasHeader blk =>
[ConsensusFailure blk] -> String -> String
forall blk. HasHeader blk => ConsensusFailure blk -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ConsensusFailure blk] -> String -> String
$cshowList :: forall blk.
HasHeader blk =>
[ConsensusFailure blk] -> String -> String
show :: ConsensusFailure blk -> String
$cshow :: forall blk. HasHeader blk => ConsensusFailure blk -> String
showsPrec :: Int -> ConsensusFailure blk -> String -> String
$cshowsPrec :: forall blk.
HasHeader blk =>
Int -> ConsensusFailure blk -> String -> String
Show

instance HasHeader blk => Exception (ConsensusFailure blk) where
  displayException :: ConsensusFailure blk -> String
displayException (ConsensusFailure (SocketPath
peerid1, Tip (Header blk)
tip1)
                                     (SocketPath
peerid2, Tip (Header blk)
tip2)
                                     Anchor (Header blk)
intersection
                                     (SecurityParam Word64
securityParam)) =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"consensus failure:\n"
      , String
"node at ", SocketPath -> String
forall a. Show a => a -> String
show SocketPath
peerid1, String
" has chain tip ", Tip (Header blk) -> String
forall a. Show a => a -> String
show Tip (Header blk)
tip1, String
"\n"
      , String
"node at ", SocketPath -> String
forall a. Show a => a -> String
show SocketPath
peerid2, String
" has chain tip ", Tip (Header blk) -> String
forall a. Show a => a -> String
show Tip (Header blk)
tip2, String
"\n"
      , String
"but their chain intersection is at ", Anchor (Header blk) -> String
forall a. Show a => a -> String
show Anchor (Header blk)
intersection, String
"\n"
      , String
"which is further back than the security param K ", Word64 -> String
forall a. Show a => a -> String
show Word64
securityParam
      ]

-- | For this test we define consensus as follows: for all pairs of chains,
-- the intersection of each pair is within K blocks of each tip.
consensusCondition
  :: HasHeader (Header blk)
  => SecurityParam
  -> ChainsSnapshot blk
  -> Either (ConsensusFailure blk) (ConsensusSuccess blk)
consensusCondition :: SecurityParam
-> ChainsSnapshot blk
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
consensusCondition (SecurityParam Word64
securityParam) ChainsSnapshot blk
chains =
    -- The (forkTooLong . chainForkPoints) predicate is not transitive.
    -- As a consequence, we need to check it between all the pairs of chains:
    let forks :: [((SocketPath, SocketPath),
  (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk)))]
forks =
          [ ((SocketPath
peerid1, SocketPath
peerid2), AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk))
forall blk.
HasHeader (Header blk) =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk))
chainForkPoints AnchoredFragment (Header blk)
chain1 AnchoredFragment (Header blk)
chain2)
          | (SocketPath
peerid1, AnchoredFragment (Header blk)
chain1) <- ChainsSnapshot blk -> [(SocketPath, AnchoredFragment (Header blk))]
forall k a. Map k a -> [(k, a)]
Map.toList ChainsSnapshot blk
chains
          , (SocketPath
peerid2, AnchoredFragment (Header blk)
chain2) <- ChainsSnapshot blk -> [(SocketPath, AnchoredFragment (Header blk))]
forall k a. Map k a -> [(k, a)]
Map.toList ChainsSnapshot blk
chains
          ]
     in case (((SocketPath, SocketPath),
  (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk)))
 -> Bool)
-> [((SocketPath, SocketPath),
     (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk)))]
-> Maybe
     ((SocketPath, SocketPath),
      (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk)))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Anchor (Header blk), Anchor (Header blk), Anchor (Header blk))
-> Bool
forall blk.
(Anchor (Header blk), Anchor (Header blk), Anchor (Header blk))
-> Bool
forkTooLong ((Anchor (Header blk), Anchor (Header blk), Anchor (Header blk))
 -> Bool)
-> (((SocketPath, SocketPath),
     (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk)))
    -> (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk)))
-> ((SocketPath, SocketPath),
    (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk)))
-> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((SocketPath, SocketPath),
 (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk)))
-> (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk))
forall a b. (a, b) -> b
snd) [((SocketPath, SocketPath),
  (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk)))]
forks of
          Just ((SocketPath
peerid1, SocketPath
peerid2), (Anchor (Header blk)
intersection, Anchor (Header blk)
tip1, Anchor (Header blk)
tip2)) ->
            ConsensusFailure blk
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
forall a b. a -> Either a b
Left (ConsensusFailure blk
 -> Either (ConsensusFailure blk) (ConsensusSuccess blk))
-> ConsensusFailure blk
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
forall a b. (a -> b) -> a -> b
$
              (SocketPath, Tip (Header blk))
-> (SocketPath, Tip (Header blk))
-> Anchor (Header blk)
-> SecurityParam
-> ConsensusFailure blk
forall blk.
(SocketPath, Tip (Header blk))
-> (SocketPath, Tip (Header blk))
-> Anchor (Header blk)
-> SecurityParam
-> ConsensusFailure blk
ConsensusFailure
                (SocketPath
peerid1, Anchor (Header blk) -> Tip (Header blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b
AF.anchorToTip Anchor (Header blk)
tip1)
                (SocketPath
peerid2, Anchor (Header blk) -> Tip (Header blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b
AF.anchorToTip Anchor (Header blk)
tip2)
                Anchor (Header blk)
intersection
                (Word64 -> SecurityParam
SecurityParam Word64
securityParam)
          Maybe
  ((SocketPath, SocketPath),
   (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk)))
Nothing ->
            ConsensusSuccess blk
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
forall a b. b -> Either a b
Right (ConsensusSuccess blk
 -> Either (ConsensusFailure blk) (ConsensusSuccess blk))
-> ConsensusSuccess blk
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
forall a b. (a -> b) -> a -> b
$
              Anchor (Header blk)
-> [(SocketPath, Tip (Header blk))] -> ConsensusSuccess blk
forall blk.
Anchor (Header blk)
-> [(SocketPath, Tip (Header blk))] -> ConsensusSuccess blk
ConsensusSuccess
                -- the minimum intersection point:
                ((Anchor (Header blk) -> Anchor (Header blk) -> Ordering)
-> [Anchor (Header blk)] -> Anchor (Header blk)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((Anchor (Header blk) -> WithOrigin BlockNo)
-> Anchor (Header blk) -> Anchor (Header blk) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Anchor (Header blk) -> WithOrigin BlockNo
forall block. Anchor block -> WithOrigin BlockNo
AF.anchorToBlockNo)
                           [ Anchor (Header blk)
intersection | ((SocketPath, SocketPath)
_,(Anchor (Header blk)
intersection,Anchor (Header blk)
_,Anchor (Header blk)
_)) <- [((SocketPath, SocketPath),
  (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk)))]
forks ])
                -- all the chain tips:
                [ (SocketPath
peerid, Anchor (Header blk) -> Tip (Header blk)
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b
AF.anchorToTip (AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
AF.headAnchor AnchoredFragment (Header blk)
chain))
                | (SocketPath
peerid, AnchoredFragment (Header blk)
chain) <- ChainsSnapshot blk -> [(SocketPath, AnchoredFragment (Header blk))]
forall k a. Map k a -> [(k, a)]
Map.toList ChainsSnapshot blk
chains ]
  where
    chainForkPoints
      :: HasHeader (Header blk)
      => AnchoredFragment (Header blk)
      -> AnchoredFragment (Header blk)
      -> ( Anchor (Header blk) -- intersection
         , Anchor (Header blk) -- tip of c1
         , Anchor (Header blk) -- tip of c2
         )
    chainForkPoints :: AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk))
chainForkPoints AnchoredFragment (Header blk)
chain1 AnchoredFragment (Header blk)
chain2 =
      case AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Maybe
     (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
      AnchoredFragment (Header blk), AnchoredFragment (Header blk))
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2
-> Maybe
     (AnchoredFragment block1, AnchoredFragment block2,
      AnchoredFragment block1, AnchoredFragment block2)
AF.intersect AnchoredFragment (Header blk)
chain1 AnchoredFragment (Header blk)
chain2 of
        -- chains are anochored at the genesis, so their intersection is never
        -- empty
        Maybe
  (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
   AnchoredFragment (Header blk), AnchoredFragment (Header blk))
Nothing -> String
-> (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk))
forall a. HasCallStack => String -> a
error String
"chainChains: invariant violation"

        Just (AnchoredFragment (Header blk)
_, AnchoredFragment (Header blk)
_, AnchoredFragment (Header blk)
extension1, AnchoredFragment (Header blk)
extension2) ->
          ( AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
AF.anchor     AnchoredFragment (Header blk)
extension1
          , AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
AF.headAnchor AnchoredFragment (Header blk)
extension1
          , AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
AF.headAnchor AnchoredFragment (Header blk)
extension2
          )

    forkTooLong
      :: ( Anchor (Header blk) -- intersection
         , Anchor (Header blk) -- tip of chain1
         , Anchor (Header blk) -- tip of chain2
         )
      -> Bool
    forkTooLong :: (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk))
-> Bool
forkTooLong (Anchor (Header blk)
intersection, Anchor (Header blk)
tip1, Anchor (Header blk)
tip2) =
        -- If only one of len1, len2 is longer than the securityParam then it is
        -- still OK. That node can still recover by receiving a valid rollback
        -- instruction, but if both are longer, then we have a failure.
        Anchor (Header blk) -> Word64
forall blk. Anchor (Header blk) -> Word64
forkLen Anchor (Header blk)
tip1 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
securityParam Bool -> Bool -> Bool
&&
        Anchor (Header blk) -> Word64
forall blk. Anchor (Header blk) -> Word64
forkLen Anchor (Header blk)
tip2 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
securityParam
      where
        forkLen :: Anchor (Header blk) -> Word64
        forkLen :: Anchor (Header blk) -> Word64
forkLen Anchor (Header blk)
tip =
          BlockNo -> Word64
Block.unBlockNo (BlockNo -> Word64) -> BlockNo -> Word64
forall a b. (a -> b) -> a -> b
$
            BlockNo -> WithOrigin BlockNo -> BlockNo
forall t. t -> WithOrigin t -> t
fromWithOrigin BlockNo
0 (Anchor (Header blk) -> WithOrigin BlockNo
forall block. Anchor block -> WithOrigin BlockNo
AF.anchorToBlockNo Anchor (Header blk)
tip)
          BlockNo -> BlockNo -> BlockNo
forall a. Num a => a -> a -> a
- BlockNo -> WithOrigin BlockNo -> BlockNo
forall t. t -> WithOrigin t -> t
fromWithOrigin BlockNo
0 (Anchor (Header blk) -> WithOrigin BlockNo
forall block. Anchor block -> WithOrigin BlockNo
AF.anchorToBlockNo Anchor (Header blk)
intersection)

newtype ProgressSuccess = ProgressSuccess BlockNo
  deriving Int -> ProgressSuccess -> String -> String
[ProgressSuccess] -> String -> String
ProgressSuccess -> String
(Int -> ProgressSuccess -> String -> String)
-> (ProgressSuccess -> String)
-> ([ProgressSuccess] -> String -> String)
-> Show ProgressSuccess
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ProgressSuccess] -> String -> String
$cshowList :: [ProgressSuccess] -> String -> String
show :: ProgressSuccess -> String
$cshow :: ProgressSuccess -> String
showsPrec :: Int -> ProgressSuccess -> String -> String
$cshowsPrec :: Int -> ProgressSuccess -> String -> String
Show

data ProgressFailure blk =
     ProgressFailure
       BlockNo -- minimum expected
       PeerId
       (Tip (Header blk))
  deriving Int -> ProgressFailure blk -> String -> String
[ProgressFailure blk] -> String -> String
ProgressFailure blk -> String
(Int -> ProgressFailure blk -> String -> String)
-> (ProgressFailure blk -> String)
-> ([ProgressFailure blk] -> String -> String)
-> Show (ProgressFailure blk)
forall blk.
HasHeader blk =>
Int -> ProgressFailure blk -> String -> String
forall blk.
HasHeader blk =>
[ProgressFailure blk] -> String -> String
forall blk. HasHeader blk => ProgressFailure blk -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ProgressFailure blk] -> String -> String
$cshowList :: forall blk.
HasHeader blk =>
[ProgressFailure blk] -> String -> String
show :: ProgressFailure blk -> String
$cshow :: forall blk. HasHeader blk => ProgressFailure blk -> String
showsPrec :: Int -> ProgressFailure blk -> String -> String
$cshowsPrec :: forall blk.
HasHeader blk =>
Int -> ProgressFailure blk -> String -> String
Show

instance HasHeader blk => Exception (ProgressFailure blk) where
  displayException :: ProgressFailure blk -> String
displayException (ProgressFailure BlockNo
minBlockNo SocketPath
peerid Tip (Header blk)
tip) =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"progress failure:\n"
      , String
"the node at ", SocketPath -> String
forall a. Show a => a -> String
show SocketPath
peerid, String
" has chain tip ", Tip (Header blk) -> String
forall a. Show a => a -> String
show Tip (Header blk)
tip, String
"\n"
      , String
"while the mininum expected block number is ", BlockNo -> String
forall a. Show a => a -> String
show BlockNo
minBlockNo
      ]

-- | Progress is defined as each chain being at least of a certain length.
--
progressCondition :: BlockNo
                  -> ConsensusSuccess blk
                  -> Either (ProgressFailure blk) ProgressSuccess
progressCondition :: BlockNo
-> ConsensusSuccess blk
-> Either (ProgressFailure blk) ProgressSuccess
progressCondition BlockNo
minBlockNo (ConsensusSuccess Anchor (Header blk)
_ [(SocketPath, Tip (Header blk))]
tips) =
  case ((SocketPath, Tip (Header blk)) -> Bool)
-> [(SocketPath, Tip (Header blk))]
-> Maybe (SocketPath, Tip (Header blk))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(SocketPath
_, Tip (Header blk)
tip) -> Tip (Header blk) -> WithOrigin BlockNo
forall b. Tip b -> WithOrigin BlockNo
Block.getTipBlockNo Tip (Header blk)
tip WithOrigin BlockNo -> WithOrigin BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
< BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At BlockNo
minBlockNo) [(SocketPath, Tip (Header blk))]
tips of
    Just (SocketPath
peerid, Tip (Header blk)
tip) -> ProgressFailure blk -> Either (ProgressFailure blk) ProgressSuccess
forall a b. a -> Either a b
Left (BlockNo -> SocketPath -> Tip (Header blk) -> ProgressFailure blk
forall blk.
BlockNo -> SocketPath -> Tip (Header blk) -> ProgressFailure blk
ProgressFailure BlockNo
minBlockNo SocketPath
peerid Tip (Header blk)
tip)
    Maybe (SocketPath, Tip (Header blk))
Nothing            -> ProgressSuccess -> Either (ProgressFailure blk) ProgressSuccess
forall a b. b -> Either a b
Right (BlockNo -> ProgressSuccess
ProgressSuccess BlockNo
minBlockNo)


runChairman
  :: RunNode blk
  => Tracer IO String
  -> CodecConfig blk
  -> NetworkMagic
  -> SecurityParam
  -- ^ Security parameter, if a fork is deeper than it 'runChairman'
  -- will throw an exception.
  -> DiffTime
  -- ^ Run for this much time.
  -> [SocketPath]
  -- ^ Local socket directory
  -> IO (ChainsSnapshot blk)
runChairman :: Tracer IO String
-> CodecConfig blk
-> NetworkMagic
-> SecurityParam
-> DiffTime
-> [SocketPath]
-> IO (ChainsSnapshot blk)
runChairman Tracer IO String
tracer CodecConfig blk
cfg NetworkMagic
networkMagic SecurityParam
securityParam DiffTime
runningTime [SocketPath]
socketPaths = do
    let initialChains :: ChainsSnapshot blk
initialChains = [(SocketPath,
  AnchoredSeq
    (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))]
-> ChainsSnapshot blk
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (SocketPath
socketPath, Anchor (Header blk)
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header blk)
forall block. Anchor block
AF.AnchorGenesis)
          | SocketPath
socketPath <- [SocketPath]
socketPaths]
    StrictTVar IO (ChainsSnapshot blk)
chainsVar <- ChainsSnapshot blk -> IO (StrictTVar IO (ChainsSnapshot blk))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO ChainsSnapshot blk
initialChains

    IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> IO () -> IO (Maybe ())
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
runningTime (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$
      (IOManager -> IO ()) -> IO ()
WithIOManager
withIOManager ((IOManager -> IO ()) -> IO ()) -> (IOManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOManager
iomgr ->
        [SocketPath] -> (SocketPath -> IO ()) -> IO ()
forall (f :: * -> *) (m :: * -> *) a b.
(Foldable f, MonadAsync m) =>
f a -> (a -> m b) -> m ()
forConcurrently_ [SocketPath]
socketPaths ((SocketPath -> IO ()) -> IO ()) -> (SocketPath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SocketPath
sockPath ->
          Tracer IO String
-> IOManager
-> CodecConfig blk
-> NetworkMagic
-> SocketPath
-> StrictTVar IO (ChainsSnapshot blk)
-> SecurityParam
-> IO ()
forall blk.
RunNode blk =>
Tracer IO String
-> IOManager
-> CodecConfig blk
-> NetworkMagic
-> SocketPath
-> ChainsVar IO blk
-> SecurityParam
-> IO ()
createConnection
            Tracer IO String
tracer
            IOManager
iomgr
            CodecConfig blk
cfg
            NetworkMagic
networkMagic
            SocketPath
sockPath
            StrictTVar IO (ChainsSnapshot blk)
chainsVar
            SecurityParam
securityParam

    STM IO (ChainsSnapshot blk) -> IO (ChainsSnapshot blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar IO (ChainsSnapshot blk) -> STM IO (ChainsSnapshot blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar IO (ChainsSnapshot blk)
chainsVar)

-- catch 'MuxError'; it will be thrown if a node shuts down closing the
-- connection.
handleMuxError
  :: Tracer IO String
  -> ChainsVar IO blk
  -> SocketPath
  -> MuxError
  -> IO ()
handleMuxError :: Tracer IO String
-> ChainsVar IO blk -> SocketPath -> MuxError -> IO ()
handleMuxError Tracer IO String
tracer ChainsVar IO blk
chainsVar SocketPath
socketPath MuxError
err = do
  Tracer IO String -> String -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer (MuxError -> String
forall a. Show a => a -> String
show MuxError
err)
  STM IO () -> IO ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO () -> IO ()) -> STM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ChainsVar IO blk
-> (Map SocketPath (AnchoredFragment (Header blk))
    -> Map SocketPath (AnchoredFragment (Header blk)))
-> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar ChainsVar IO blk
chainsVar (SocketPath
-> Map SocketPath (AnchoredFragment (Header blk))
-> Map SocketPath (AnchoredFragment (Header blk))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete SocketPath
socketPath)

createConnection
  :: forall blk.
     RunNode blk
  => Tracer IO String
  -> IOManager
  -> CodecConfig blk
  -> NetworkMagic
  -> SocketPath
  -> ChainsVar IO blk
  -> SecurityParam
  -> IO ()
createConnection :: Tracer IO String
-> IOManager
-> CodecConfig blk
-> NetworkMagic
-> SocketPath
-> ChainsVar IO blk
-> SecurityParam
-> IO ()
createConnection
  Tracer IO String
tracer
  IOManager
iomgr
  CodecConfig blk
cfg
  NetworkMagic
networkMagic
  socketPath :: SocketPath
socketPath@(SocketPath String
path)
  ChainsVar IO blk
chainsVar
  SecurityParam
securityParam =
      LocalSnocket
-> NetworkConnectTracers LocalAddress NodeToClientVersion
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString IO () Void)
-> String
-> IO ()
forall a b.
LocalSnocket
-> NetworkConnectTracers LocalAddress NodeToClientVersion
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString IO a b)
-> String
-> IO ()
connectTo
        (IOManager -> String -> LocalSnocket
localSnocket IOManager
iomgr String
path)
        NetworkConnectTracers :: forall addr vNumber.
Tracer IO (WithMuxBearer (ConnectionId addr) MuxTrace)
-> Tracer
     IO
     (WithMuxBearer
        (ConnectionId addr) (TraceSendRecv (Handshake vNumber Term)))
-> NetworkConnectTracers addr vNumber
NetworkConnectTracers
          { nctMuxTracer :: Tracer IO (WithMuxBearer (ConnectionId LocalAddress) MuxTrace)
nctMuxTracer       = Tracer IO (WithMuxBearer (ConnectionId LocalAddress) MuxTrace)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
          , nctHandshakeTracer :: Tracer
  IO
  (WithMuxBearer
     (ConnectionId LocalAddress)
     (TraceSendRecv (Handshake NodeToClientVersion Term)))
nctHandshakeTracer = Tracer
  IO
  (WithMuxBearer
     (ConnectionId LocalAddress)
     (TraceSendRecv (Handshake NodeToClientVersion Term)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
          }
        (Tracer IO (ChairmanTrace blk)
-> Tracer IO (TraceSendRecv (ChainSync blk (Point blk) (Tip blk)))
-> Tracer
     IO (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
-> CodecConfig blk
-> NetworkMagic
-> SocketPath
-> ChainsVar IO blk
-> SecurityParam
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString IO () Void)
forall blk (m :: * -> *).
(RunNode blk, MonadAsync m, MonadST m, MonadTimer m,
 MonadThrow (STM m)) =>
Tracer m (ChairmanTrace blk)
-> Tracer m (TraceSendRecv (ChainSync blk (Point blk) (Tip blk)))
-> Tracer
     m (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
-> CodecConfig blk
-> NetworkMagic
-> SocketPath
-> ChainsVar m blk
-> SecurityParam
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString m () Void)
localInitiatorNetworkApplication
            (Tracer IO String -> Tracer IO (ChairmanTrace blk)
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer IO String
tracer)
            Tracer IO (TraceSendRecv (ChainSync blk (Point blk) (Tip blk)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
            Tracer
  IO (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
            CodecConfig blk
cfg
            NetworkMagic
networkMagic
            SocketPath
socketPath
            ChainsVar IO blk
chainsVar
            SecurityParam
securityParam)
        String
path
        IO () -> (MuxError -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` Tracer IO String
-> ChainsVar IO blk -> SocketPath -> MuxError -> IO ()
forall blk.
Tracer IO String
-> ChainsVar IO blk -> SocketPath -> MuxError -> IO ()
handleMuxError Tracer IO String
tracer ChainsVar IO blk
chainsVar SocketPath
socketPath

-- Shared State, and its API.

-- | Shared state between chain-sync clients.  Each chain-sync client will write to the
-- corresponding entry.
type ChainsVar m blk = StrictTVar m (Map SocketPath (AnchoredFragment (Header blk)))

-- | Add a single block to the chain.
addBlock
    :: forall blk m.
       ( MonadSTM m
       , GetHeader blk
       )
    => SocketPath
    -> ChainsVar m blk
    -> blk
    -> STM m ()
addBlock :: SocketPath -> ChainsVar m blk -> blk -> STM m ()
addBlock SocketPath
sockPath ChainsVar m blk
chainsVar blk
blk =
    ChainsVar m blk
-> (Map SocketPath (AnchoredFragment (Header blk))
    -> Map SocketPath (AnchoredFragment (Header blk)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar ChainsVar m blk
chainsVar ((AnchoredFragment (Header blk) -> AnchoredFragment (Header blk))
-> SocketPath
-> Map SocketPath (AnchoredFragment (Header blk))
-> Map SocketPath (AnchoredFragment (Header blk))
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (Header blk
-> AnchoredFragment (Header blk) -> AnchoredFragment (Header blk)
forall block.
HasHeader block =>
block -> AnchoredFragment block -> AnchoredFragment block
AF.addBlock (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk)) SocketPath
sockPath)

-- | Rollback a single block.  If the rollback point is not found, we simply
-- error.  It should never happen if the security parameter is set up correctly.
rollback
  :: forall blk m. (MonadSTM m, HasHeader (Header blk))
  => SocketPath
  -> ChainsVar m blk
  -> Point blk
  -> STM m ()
rollback :: SocketPath -> ChainsVar m blk -> Point blk -> STM m ()
rollback SocketPath
sockPath ChainsVar m blk
chainsVar Point blk
p = ChainsVar m blk
-> (Map SocketPath (AnchoredFragment (Header blk))
    -> Map SocketPath (AnchoredFragment (Header blk)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar ChainsVar m blk
chainsVar ((AnchoredFragment (Header blk) -> AnchoredFragment (Header blk))
-> SocketPath
-> Map SocketPath (AnchoredFragment (Header blk))
-> Map SocketPath (AnchoredFragment (Header blk))
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust AnchoredFragment (Header blk) -> AnchoredFragment (Header blk)
fn SocketPath
sockPath)
  where
    p' :: Point (Header blk)
    p' :: Point (Header blk)
p' = Point blk -> Point (Header blk)
coerce Point blk
p

    fn :: AnchoredFragment (Header blk) -> AnchoredFragment (Header blk)
    fn :: AnchoredFragment (Header blk) -> AnchoredFragment (Header blk)
fn AnchoredFragment (Header blk)
cf = case Point (Header blk)
-> AnchoredFragment (Header blk)
-> Maybe (AnchoredFragment (Header blk))
forall block.
HasHeader block =>
Point block
-> AnchoredFragment block -> Maybe (AnchoredFragment block)
AF.rollback Point (Header blk)
p' AnchoredFragment (Header blk)
cf of
      Maybe (AnchoredFragment (Header blk))
Nothing  -> String -> AnchoredFragment (Header blk)
forall a. HasCallStack => String -> a
error String
"rollback error: rollback beyond chain fragment"
      Just AnchoredFragment (Header blk)
cf' -> AnchoredFragment (Header blk)
cf'

-- Chain-Sync client
type ChairmanTrace blk = ConsensusSuccess blk

-- | 'ChainSyncClient' which build chain fragment; on every roll forward it will
-- check if there is consensus on immutable chain.
chainSyncClient
  :: forall blk m.
     ( MonadSTM   m
     , MonadThrow (STM m)
     , MonadAsync m
     , GetHeader blk
     , HasHeader blk
     )
  => Tracer m (ChairmanTrace blk)
  -> SocketPath
  -> ChainsVar m blk
  -> SecurityParam
  -> ChainSyncClient blk (Point blk) (Tip blk) m ()
chainSyncClient :: Tracer m (ChairmanTrace blk)
-> SocketPath
-> ChainsVar m blk
-> SecurityParam
-> ChainSyncClient blk (Point blk) (Tip blk) m ()
chainSyncClient Tracer m (ChairmanTrace blk)
tracer SocketPath
sockPath ChainsVar m blk
chainsVar SecurityParam
securityParam = m (ClientStIdle blk (Point blk) (Tip blk) m ())
-> ChainSyncClient blk (Point blk) (Tip blk) m ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle blk (Point blk) (Tip blk) m ())
 -> ChainSyncClient blk (Point blk) (Tip blk) m ())
-> m (ClientStIdle blk (Point blk) (Tip blk) m ())
-> ChainSyncClient blk (Point blk) (Tip blk) m ()
forall a b. (a -> b) -> a -> b
$ ClientStIdle blk (Point blk) (Tip blk) m ()
-> m (ClientStIdle blk (Point blk) (Tip blk) m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStIdle blk (Point blk) (Tip blk) m ()
 -> m (ClientStIdle blk (Point blk) (Tip blk) m ()))
-> ClientStIdle blk (Point blk) (Tip blk) m ()
-> m (ClientStIdle blk (Point blk) (Tip blk) m ())
forall a b. (a -> b) -> a -> b
$
  -- Notify the core node about the our latest points at which we are
  -- synchronised.  This client is not persistent and thus it just
  -- synchronises from the genesis block.  A real implementation should send
  -- a list of points up to a point which is k blocks deep.
  [Point blk]
-> ClientStIntersect blk (Point blk) (Tip blk) m ()
-> ClientStIdle blk (Point blk) (Tip blk) m ()
forall point header tip (m :: * -> *) a.
[point]
-> ClientStIntersect header point tip m a
-> ClientStIdle header point tip m a
SendMsgFindIntersect
    [Point blk
forall block. Point block
Block.genesisPoint]
    ClientStIntersect :: forall header point tip (m :: * -> *) a.
(point -> tip -> ChainSyncClient header point tip m a)
-> (tip -> ChainSyncClient header point tip m a)
-> ClientStIntersect header point tip m a
ClientStIntersect
    { recvMsgIntersectFound :: Point blk
-> Tip blk -> ChainSyncClient blk (Point blk) (Tip blk) m ()
recvMsgIntersectFound    = \Point blk
_ Tip blk
_ -> m (ClientStIdle blk (Point blk) (Tip blk) m ())
-> ChainSyncClient blk (Point blk) (Tip blk) m ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (ClientStIdle blk (Point blk) (Tip blk) m ()
-> m (ClientStIdle blk (Point blk) (Tip blk) m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle blk (Point blk) (Tip blk) m ()
clientStIdle)
    , recvMsgIntersectNotFound :: Tip blk -> ChainSyncClient blk (Point blk) (Tip blk) m ()
recvMsgIntersectNotFound = \  Tip blk
_ -> m (ClientStIdle blk (Point blk) (Tip blk) m ())
-> ChainSyncClient blk (Point blk) (Tip blk) m ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (ClientStIdle blk (Point blk) (Tip blk) m ()
-> m (ClientStIdle blk (Point blk) (Tip blk) m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle blk (Point blk) (Tip blk) m ()
clientStIdle)
    }
  where
    clientStIdle :: ClientStIdle blk (Point blk) (Tip blk) m ()
    clientStIdle :: ClientStIdle blk (Point blk) (Tip blk) m ()
clientStIdle = ClientStNext blk (Point blk) (Tip blk) m ()
-> m (ClientStNext blk (Point blk) (Tip blk) m ())
-> ClientStIdle blk (Point blk) (Tip blk) m ()
forall header point tip (m :: * -> *) a.
ClientStNext header point tip m a
-> m (ClientStNext header point tip m a)
-> ClientStIdle header point tip m a
SendMsgRequestNext ClientStNext blk (Point blk) (Tip blk) m ()
clientStNext (ClientStNext blk (Point blk) (Tip blk) m ()
-> m (ClientStNext blk (Point blk) (Tip blk) m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStNext blk (Point blk) (Tip blk) m ()
clientStNext)

    clientStNext :: ClientStNext blk (Point blk) (Tip blk) m ()
    clientStNext :: ClientStNext blk (Point blk) (Tip blk) m ()
clientStNext = ClientStNext :: forall header point tip (m :: * -> *) a.
(header -> tip -> ChainSyncClient header point tip m a)
-> (point -> tip -> ChainSyncClient header point tip m a)
-> ClientStNext header point tip m a
ClientStNext
      { recvMsgRollForward :: blk -> Tip blk -> ChainSyncClient blk (Point blk) (Tip blk) m ()
recvMsgRollForward = \blk
blk Tip blk
_tip -> m (ClientStIdle blk (Point blk) (Tip blk) m ())
-> ChainSyncClient blk (Point blk) (Tip blk) m ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle blk (Point blk) (Tip blk) m ())
 -> ChainSyncClient blk (Point blk) (Tip blk) m ())
-> m (ClientStIdle blk (Point blk) (Tip blk) m ())
-> ChainSyncClient blk (Point blk) (Tip blk) m ()
forall a b. (a -> b) -> a -> b
$ do
          -- add block & check if there is consensus on immutable chain
          -- trace the decision or error
          ChairmanTrace blk
res <- STM m (ChairmanTrace blk) -> m (ChairmanTrace blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ChairmanTrace blk) -> m (ChairmanTrace blk))
-> STM m (ChairmanTrace blk) -> m (ChairmanTrace blk)
forall a b. (a -> b) -> a -> b
$ do
            SocketPath -> ChainsVar m blk -> blk -> STM m ()
forall blk (m :: * -> *).
(MonadSTM m, GetHeader blk) =>
SocketPath -> ChainsVar m blk -> blk -> STM m ()
addBlock SocketPath
sockPath ChainsVar m blk
chainsVar blk
blk
            ChainsVar m blk -> SecurityParam -> STM m (ChairmanTrace blk)
forall blk (m :: * -> *).
(MonadSTM m, MonadThrow (STM m), HasHeader blk,
 HasHeader (Header blk)) =>
ChainsVar m blk -> SecurityParam -> STM m (ConsensusSuccess blk)
checkConsensus ChainsVar m blk
chainsVar SecurityParam
securityParam
          Tracer m (ChairmanTrace blk) -> ChairmanTrace blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChairmanTrace blk)
tracer ChairmanTrace blk
res
          ClientStIdle blk (Point blk) (Tip blk) m ()
-> m (ClientStIdle blk (Point blk) (Tip blk) m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle blk (Point blk) (Tip blk) m ()
clientStIdle
      , recvMsgRollBackward :: Point blk
-> Tip blk -> ChainSyncClient blk (Point blk) (Tip blk) m ()
recvMsgRollBackward = \Point blk
point Tip blk
_tip -> m (ClientStIdle blk (Point blk) (Tip blk) m ())
-> ChainSyncClient blk (Point blk) (Tip blk) m ()
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle blk (Point blk) (Tip blk) m ())
 -> ChainSyncClient blk (Point blk) (Tip blk) m ())
-> m (ClientStIdle blk (Point blk) (Tip blk) m ())
-> ChainSyncClient blk (Point blk) (Tip blk) m ()
forall a b. (a -> b) -> a -> b
$ do
          -- rollback & check
          ChairmanTrace blk
res <- STM m (ChairmanTrace blk) -> m (ChairmanTrace blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ChairmanTrace blk) -> m (ChairmanTrace blk))
-> STM m (ChairmanTrace blk) -> m (ChairmanTrace blk)
forall a b. (a -> b) -> a -> b
$ do
            SocketPath -> ChainsVar m blk -> Point blk -> STM m ()
forall blk (m :: * -> *).
(MonadSTM m, HasHeader (Header blk)) =>
SocketPath -> ChainsVar m blk -> Point blk -> STM m ()
rollback SocketPath
sockPath ChainsVar m blk
chainsVar Point blk
point
            ChainsVar m blk -> SecurityParam -> STM m (ChairmanTrace blk)
forall blk (m :: * -> *).
(MonadSTM m, MonadThrow (STM m), HasHeader blk,
 HasHeader (Header blk)) =>
ChainsVar m blk -> SecurityParam -> STM m (ConsensusSuccess blk)
checkConsensus ChainsVar m blk
chainsVar SecurityParam
securityParam
          Tracer m (ChairmanTrace blk) -> ChairmanTrace blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChairmanTrace blk)
tracer ChairmanTrace blk
res
          ClientStIdle blk (Point blk) (Tip blk) m ()
-> m (ClientStIdle blk (Point blk) (Tip blk) m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle blk (Point blk) (Tip blk) m ()
clientStIdle
      }

-- | Check that all nodes agree with each other, within the security parameter.
checkConsensus
  :: forall blk m.
      ( MonadSTM m
      , MonadThrow (STM m)
      , HasHeader blk
      , HasHeader (Header blk)
      )
  => ChainsVar m blk
  -> SecurityParam
  -> STM m (ConsensusSuccess blk)
checkConsensus :: ChainsVar m blk -> SecurityParam -> STM m (ConsensusSuccess blk)
checkConsensus ChainsVar m blk
chainsVar SecurityParam
securityParam = do
  ChainsSnapshot blk
chainsSnapshot <- ChainsVar m blk -> STM m (ChainsSnapshot blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar ChainsVar m blk
chainsVar
  (ConsensusFailure blk -> STM m (ConsensusSuccess blk))
-> (ConsensusSuccess blk -> STM m (ConsensusSuccess blk))
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
-> STM m (ConsensusSuccess blk)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ConsensusFailure blk -> STM m (ConsensusSuccess blk)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ConsensusSuccess blk -> STM m (ConsensusSuccess blk)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ConsensusFailure blk) (ConsensusSuccess blk)
 -> STM m (ConsensusSuccess blk))
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
-> STM m (ConsensusSuccess blk)
forall a b. (a -> b) -> a -> b
$ SecurityParam
-> ChainsSnapshot blk
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
forall blk.
HasHeader (Header blk) =>
SecurityParam
-> ChainsSnapshot blk
-> Either (ConsensusFailure blk) (ConsensusSuccess blk)
consensusCondition SecurityParam
securityParam ChainsSnapshot blk
chainsSnapshot

-- | Client Application
localInitiatorNetworkApplication
  :: forall blk m.
     ( RunNode blk
     , MonadAsync m
     , MonadST    m
     , MonadTimer m
     , MonadThrow (STM m)
     )
  => Tracer m (ChairmanTrace blk)
  -> Tracer m (TraceSendRecv (ChainSync blk (Point blk) (Tip blk)))
  -- ^ tracer which logs all chain-sync messages send and received by the client
  -- (see 'Ouroboros.Network.Protocol.ChainSync.Type' in 'ouroboros-network'
  -- package)
  -> Tracer m (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
  -- ^ tracer which logs all local tx submission protocol messages send and
  -- received by the client (see 'Ouroboros.Network.Protocol.LocalTxSubmission.Type'
  -- in 'ouroboros-network' package).
  -> CodecConfig blk
  -> NetworkMagic
  -> SocketPath
  -> ChainsVar m blk
  -> SecurityParam
  -> Versions
        NodeToClientVersion
        NodeToClientVersionData
        (OuroborosApplication InitiatorMode LocalAddress ByteString m () Void)
localInitiatorNetworkApplication :: Tracer m (ChairmanTrace blk)
-> Tracer m (TraceSendRecv (ChainSync blk (Point blk) (Tip blk)))
-> Tracer
     m (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
-> CodecConfig blk
-> NetworkMagic
-> SocketPath
-> ChainsVar m blk
-> SecurityParam
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString m () Void)
localInitiatorNetworkApplication
    Tracer m (ChairmanTrace blk)
chairmanTracer Tracer m (TraceSendRecv (ChainSync blk (Point blk) (Tip blk)))
chainSyncTracer
    Tracer
  m (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
localTxSubmissionTracer
    CodecConfig blk
cfg NetworkMagic
networkMagic
    SocketPath
sockPath ChainsVar m blk
chainsVar SecurityParam
securityParam =
  ((NodeToClientVersion, BlockNodeToClientVersion blk)
 -> Versions
      NodeToClientVersion
      NodeToClientVersionData
      (OuroborosApplication
         'InitiatorMode LocalAddress ByteString m () Void))
-> [(NodeToClientVersion, BlockNodeToClientVersion blk)]
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString m () Void)
forall vNum (f :: * -> *) x extra r.
(Ord vNum, Foldable f, HasCallStack) =>
(x -> Versions vNum extra r) -> f x -> Versions vNum extra r
foldMapVersions
    (\(NodeToClientVersion
version, BlockNodeToClientVersion blk
blockVersion) ->
      NodeToClientVersion
-> NodeToClientVersionData
-> (ConnectionId LocalAddress
    -> STM m ControlMessage
    -> NodeToClientProtocols 'InitiatorMode ByteString m () Void)
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication
        'InitiatorMode LocalAddress ByteString m () Void)
forall (m :: * -> *) (appType :: MuxMode) bytes a b.
NodeToClientVersion
-> NodeToClientVersionData
-> (ConnectionId LocalAddress
    -> STM m ControlMessage
    -> NodeToClientProtocols appType bytes m a b)
-> Versions
     NodeToClientVersion
     NodeToClientVersionData
     (OuroborosApplication appType LocalAddress bytes m a b)
versionedNodeToClientProtocols
        NodeToClientVersion
version
        NodeToClientVersionData
versionData
        (\ConnectionId LocalAddress
_ STM m ControlMessage
_ -> BlockNodeToClientVersion blk
-> NodeToClientVersion
-> NodeToClientProtocols 'InitiatorMode ByteString m () Void
protocols BlockNodeToClientVersion blk
blockVersion NodeToClientVersion
version))
    (Map NodeToClientVersion (BlockNodeToClientVersion blk)
-> [(NodeToClientVersion, BlockNodeToClientVersion blk)]
forall k a. Map k a -> [(k, a)]
Map.toList (Proxy blk -> Map NodeToClientVersion (BlockNodeToClientVersion blk)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Map NodeToClientVersion (BlockNodeToClientVersion blk)
supportedNodeToClientVersions Proxy blk
proxy))
  where
    proxy :: Proxy blk
    proxy :: Proxy blk
proxy = Proxy blk
forall k (t :: k). Proxy t
Proxy

    versionData :: NodeToClientVersionData
versionData = NetworkMagic -> NodeToClientVersionData
NodeToClientVersionData NetworkMagic
networkMagic

    protocols
      :: BlockNodeToClientVersion blk
      -> NodeToClientVersion
      -> NodeToClientProtocols InitiatorMode ByteString m () Void
    protocols :: BlockNodeToClientVersion blk
-> NodeToClientVersion
-> NodeToClientProtocols 'InitiatorMode ByteString m () Void
protocols BlockNodeToClientVersion blk
byronClientVersion NodeToClientVersion
version =
      NodeToClientProtocols :: forall (appType :: MuxMode) bytes (m :: * -> *) a b.
RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> RunMiniProtocol appType bytes m a b
-> NodeToClientProtocols appType bytes m a b
NodeToClientProtocols
      { localChainSyncProtocol :: RunMiniProtocol 'InitiatorMode ByteString m () Void
localChainSyncProtocol =
          MuxPeer ByteString m ()
-> RunMiniProtocol 'InitiatorMode ByteString m () Void
forall bytes (m :: * -> *) a.
MuxPeer bytes m a -> RunMiniProtocol 'InitiatorMode bytes m a Void
InitiatorProtocolOnly (MuxPeer ByteString m ()
 -> RunMiniProtocol 'InitiatorMode ByteString m () Void)
-> MuxPeer ByteString m ()
-> RunMiniProtocol 'InitiatorMode ByteString m () Void
forall a b. (a -> b) -> a -> b
$
            Tracer m (TraceSendRecv (ChainSync blk (Point blk) (Tip blk)))
-> Codec
     (ChainSync blk (Point blk) (Tip blk))
     DeserialiseFailure
     m
     ByteString
-> Peer
     (ChainSync blk (Point blk) (Tip blk)) 'AsClient 'StIdle m ()
-> MuxPeer ByteString m ()
forall (pr :: PeerRole) ps (st :: ps) failure bytes (m :: * -> *)
       a.
(Show failure, forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr st m a
-> MuxPeer bytes m a
MuxPeer
              Tracer m (TraceSendRecv (ChainSync blk (Point blk) (Tip blk)))
chainSyncTracer
              Codec
  (ChainSync blk (Point blk) (Tip blk))
  DeserialiseFailure
  m
  ByteString
cChainSyncCodec
              (ChainSyncClient blk (Point blk) (Tip blk) m ()
-> Peer
     (ChainSync blk (Point blk) (Tip blk)) 'AsClient 'StIdle m ()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncClient header point tip m a
-> Peer (ChainSync header point tip) 'AsClient 'StIdle m a
chainSyncClientPeer (ChainSyncClient blk (Point blk) (Tip blk) m ()
 -> Peer
      (ChainSync blk (Point blk) (Tip blk)) 'AsClient 'StIdle m ())
-> ChainSyncClient blk (Point blk) (Tip blk) m ()
-> Peer
     (ChainSync blk (Point blk) (Tip blk)) 'AsClient 'StIdle m ()
forall a b. (a -> b) -> a -> b
$
                  Tracer m (ChairmanTrace blk)
-> SocketPath
-> ChainsVar m blk
-> SecurityParam
-> ChainSyncClient blk (Point blk) (Tip blk) m ()
forall blk (m :: * -> *).
(MonadSTM m, MonadThrow (STM m), MonadAsync m, GetHeader blk,
 HasHeader blk) =>
Tracer m (ChairmanTrace blk)
-> SocketPath
-> ChainsVar m blk
-> SecurityParam
-> ChainSyncClient blk (Point blk) (Tip blk) m ()
chainSyncClient Tracer m (ChairmanTrace blk)
chairmanTracer SocketPath
sockPath ChainsVar m blk
chainsVar SecurityParam
securityParam)

      , localTxSubmissionProtocol :: RunMiniProtocol 'InitiatorMode ByteString m () Void
localTxSubmissionProtocol =
          MuxPeer ByteString m ()
-> RunMiniProtocol 'InitiatorMode ByteString m () Void
forall bytes (m :: * -> *) a.
MuxPeer bytes m a -> RunMiniProtocol 'InitiatorMode bytes m a Void
InitiatorProtocolOnly (MuxPeer ByteString m ()
 -> RunMiniProtocol 'InitiatorMode ByteString m () Void)
-> MuxPeer ByteString m ()
-> RunMiniProtocol 'InitiatorMode ByteString m () Void
forall a b. (a -> b) -> a -> b
$
            Tracer
  m (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
-> Codec
     (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
     DeserialiseFailure
     m
     ByteString
-> Peer
     (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
     'AsClient
     'StIdle
     m
     ()
-> MuxPeer ByteString m ()
forall (pr :: PeerRole) ps (st :: ps) failure bytes (m :: * -> *)
       a.
(Show failure, forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr st m a
-> MuxPeer bytes m a
MuxPeer
              Tracer
  m (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
localTxSubmissionTracer
              Codec
  (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
  DeserialiseFailure
  m
  ByteString
cTxSubmissionCodec
              Peer
  (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
  'AsClient
  'StIdle
  m
  ()
forall tx reject (m :: * -> *) a.
MonadTimer m =>
Peer (LocalTxSubmission tx reject) 'AsClient 'StIdle m a
localTxSubmissionPeerNull
      , localStateQueryProtocol :: RunMiniProtocol 'InitiatorMode ByteString m () Void
localStateQueryProtocol =
          MuxPeer ByteString m ()
-> RunMiniProtocol 'InitiatorMode ByteString m () Void
forall bytes (m :: * -> *) a.
MuxPeer bytes m a -> RunMiniProtocol 'InitiatorMode bytes m a Void
InitiatorProtocolOnly (MuxPeer ByteString m ()
 -> RunMiniProtocol 'InitiatorMode ByteString m () Void)
-> MuxPeer ByteString m ()
-> RunMiniProtocol 'InitiatorMode ByteString m () Void
forall a b. (a -> b) -> a -> b
$
            Tracer
  m (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)))
-> Codec
     (LocalStateQuery blk (Point blk) (Query blk))
     DeserialiseFailure
     m
     ByteString
-> Peer
     (LocalStateQuery blk (Point blk) (Query blk))
     'AsClient
     'StIdle
     m
     ()
-> MuxPeer ByteString m ()
forall (pr :: PeerRole) ps (st :: ps) failure bytes (m :: * -> *)
       a.
(Show failure, forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr st m a
-> MuxPeer bytes m a
MuxPeer
              Tracer
  m (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
              Codec
  (LocalStateQuery blk (Point blk) (Query blk))
  DeserialiseFailure
  m
  ByteString
cStateQueryCodec
              Peer
  (LocalStateQuery blk (Point blk) (Query blk))
  'AsClient
  'StIdle
  m
  ()
forall block point (query :: * -> *) (m :: * -> *) a.
MonadTimer m =>
Peer (LocalStateQuery block point query) 'AsClient 'StIdle m a
localStateQueryPeerNull
      }
      where
        Codecs
            { Codec
  (ChainSync blk (Point blk) (Tip blk))
  DeserialiseFailure
  m
  ByteString
cChainSyncCodec :: forall blk serialisedBlk e (m :: * -> *) bCS bTX bSQ.
Codecs' blk serialisedBlk e m bCS bTX bSQ
-> Codec (ChainSync serialisedBlk (Point blk) (Tip blk)) e m bCS
cChainSyncCodec :: Codec
  (ChainSync blk (Point blk) (Tip blk))
  DeserialiseFailure
  m
  ByteString
cChainSyncCodec
            , Codec
  (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
  DeserialiseFailure
  m
  ByteString
cTxSubmissionCodec :: forall blk serialisedBlk e (m :: * -> *) bCS bTX bSQ.
Codecs' blk serialisedBlk e m bCS bTX bSQ
-> Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX
cTxSubmissionCodec :: Codec
  (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
  DeserialiseFailure
  m
  ByteString
cTxSubmissionCodec
            , Codec
  (LocalStateQuery blk (Point blk) (Query blk))
  DeserialiseFailure
  m
  ByteString
cStateQueryCodec :: forall blk serialisedBlk e (m :: * -> *) bCS bTX bSQ.
Codecs' blk serialisedBlk e m bCS bTX bSQ
-> Codec (LocalStateQuery blk (Point blk) (Query blk)) e m bSQ
cStateQueryCodec :: Codec
  (LocalStateQuery blk (Point blk) (Query blk))
  DeserialiseFailure
  m
  ByteString
cStateQueryCodec
            } =
          CodecConfig blk
-> BlockNodeToClientVersion blk
-> NodeToClientVersion
-> Codecs'
     blk blk DeserialiseFailure m ByteString ByteString ByteString
forall (m :: * -> *) blk.
(MonadST m, SerialiseNodeToClientConstraints blk,
 ShowQuery (BlockQuery blk)) =>
CodecConfig blk
-> BlockNodeToClientVersion blk
-> NodeToClientVersion
-> ClientCodecs blk m
clientCodecs CodecConfig blk
cfg BlockNodeToClientVersion blk
byronClientVersion NodeToClientVersion
version