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

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

module Cardano.Chairman (chairmanTest) where

import           Control.Concurrent.Class.MonadSTM.Strict
import           Control.Monad (void)
import           Control.Monad.Class.MonadAsync
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Class.MonadTimer
import           Control.Tracer
import           Data.Coerce (coerce)
import qualified Data.List as List
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Ord (comparing)
import           Data.Proxy (Proxy (..))
import           Data.Word (Word64)

import           Ouroboros.Consensus.Block.Abstract
import           Ouroboros.Consensus.Config.SecurityParam

import           Ouroboros.Network.AnchoredFragment (Anchor, AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import qualified Ouroboros.Network.Block as Block
import           Ouroboros.Network.Protocol.ChainSync.Client

import           Cardano.Api
import           Cardano.Api.Byron
import           Cardano.Api.Shelley

-- | 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
  -> NetworkId
  -> DiffTime
  -> BlockNo
  -> [SocketPath]
  -> AnyConsensusModeParams
  -> SecurityParam
  -> IO ()
chairmanTest :: Tracer IO String
-> NetworkId
-> DiffTime
-> BlockNo
-> [SocketPath]
-> AnyConsensusModeParams
-> SecurityParam
-> IO ()
chairmanTest Tracer IO String
tracer NetworkId
nw DiffTime
runningTime BlockNo
progressThreshold [SocketPath]
socketPaths
             (AnyConsensusModeParams ConsensusModeParams mode
cModeParams) SecurityParam
secParam = do
  forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer (String
"Will observe nodes for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DiffTime
runningTime)
  forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO String
tracer (String
"Will require chain growth of " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show BlockNo
progressThreshold)

  -- Run the chairman and get the final snapshot of the chain from each node.
  Map
  SocketPath
  (AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (Header (ConsensusBlockForMode mode)))
     (Header (ConsensusBlockForMode mode)))
chainsSnapshot <-
    forall mode a.
ConsensusMode mode
-> (GetHeader (ConsensusBlockForMode mode) => a) -> a
obtainGetHeader (forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams) forall a b. (a -> b) -> a -> b
$
     forall mode blk.
(ConsensusBlockForMode mode ~ blk,
 GetHeader (ConsensusBlockForMode mode)) =>
Tracer IO String
-> NetworkId
-> DiffTime
-> [SocketPath]
-> ConsensusModeParams mode
-> SecurityParam
-> IO
     (Map
        SocketPath
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
runChairman
      Tracer IO String
tracer
      NetworkId
nw
      DiffTime
runningTime
      [SocketPath]
socketPaths
      ConsensusModeParams mode
cModeParams
      SecurityParam
secParam

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

  -- Test if we achieved consensus
  ConsensusSuccess
consensusSuccess <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                        forall mode blk a.
(ConsensusBlockForMode mode ~ blk) =>
ConsensusMode mode
-> ((HasHeader (Header blk),
     ConvertRawHash (ConsensusBlockForMode mode)) =>
    a)
-> a
obtainHasHeader (forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams) forall a b. (a -> b) -> a -> b
$
                        forall mode blk.
(ConsensusBlockForMode mode ~ blk, HasHeader (Header blk),
 ConvertRawHash blk) =>
ConsensusMode mode
-> Map SocketPath (AnchoredFragment (Header blk))
-> SecurityParam
-> Either ConsensusFailure ConsensusSuccess
consensusCondition (forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams) Map
  SocketPath
  (AnchoredSeq
     (WithOrigin SlotNo)
     (Anchor (Header (ConsensusBlockForMode mode)))
     (Header (ConsensusBlockForMode mode)))
chainsSnapshot SecurityParam
secParam

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

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

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

type PeerId = SocketPath

instance Exception ConsensusFailure where
  displayException :: ConsensusFailure -> String
displayException (ConsensusFailure (SocketPath
peerid1, ChainTip
tip1)
                                     (SocketPath
peerid2, ChainTip
tip2)
                                     ChainPoint
intersection
                                     (SecurityParam Word64
securityParam)) =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"consensus failure:\n"
      , String
"node at ", forall a. Show a => a -> String
show SocketPath
peerid1, String
" has chain tip ", forall a. Show a => a -> String
show ChainTip
tip1, String
"\n"
      , String
"node at ", forall a. Show a => a -> String
show SocketPath
peerid2, String
" has chain tip ", forall a. Show a => a -> String
show ChainTip
tip2, String
"\n"
      , String
"but their chain intersection is at ", forall a. Show a => a -> String
show ChainPoint
intersection, String
"\n"
      , String
"which is further back than the security param K ", 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
  :: ConsensusBlockForMode mode ~ blk
  => HasHeader (Header blk)
  => ConvertRawHash blk
  => ConsensusMode mode
  -> Map PeerId (AnchoredFragment (Header blk))
  -> SecurityParam
  -> Either ConsensusFailure ConsensusSuccess
consensusCondition :: forall mode blk.
(ConsensusBlockForMode mode ~ blk, HasHeader (Header blk),
 ConvertRawHash blk) =>
ConsensusMode mode
-> Map SocketPath (AnchoredFragment (Header blk))
-> SecurityParam
-> Either ConsensusFailure ConsensusSuccess
consensusCondition ConsensusMode mode
cMode Map SocketPath (AnchoredFragment (Header blk))
chains SecurityParam
securityParam =
    -- 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), 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) <- forall k a. Map k a -> [(k, a)]
Map.toList Map SocketPath (AnchoredFragment (Header blk))
chains
          , (SocketPath
peerid2, AnchoredFragment (Header blk)
chain2) <- forall k a. Map k a -> [(k, a)]
Map.toList Map SocketPath (AnchoredFragment (Header blk))
chains
          ]
     in case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (forall blk.
(Anchor (Header blk), Anchor (Header blk), Anchor (Header blk))
-> Bool
forkTooLong forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)) ->do
            let apiTip1 :: ChainTip
apiTip1 = forall mode block.
(ConsensusBlockForMode mode ~ block) =>
ConsensusMode mode -> Tip block -> ChainTip
fromConsensusTip ConsensusMode mode
cMode forall a b. (a -> b) -> a -> b
$ forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b
AF.anchorToTip Anchor (Header blk)
tip1
                apiTip2 :: ChainTip
apiTip2 = forall mode block.
(ConsensusBlockForMode mode ~ block) =>
ConsensusMode mode -> Tip block -> ChainTip
fromConsensusTip ConsensusMode mode
cMode forall a b. (a -> b) -> a -> b
$ forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b
AF.anchorToTip Anchor (Header blk)
tip2
                intersectChainPt :: ChainPoint
intersectChainPt = forall blk. ConvertRawHash blk => Anchor (Header blk) -> ChainPoint
fromAnchor Anchor (Header blk)
intersection

            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
              (SocketPath, ChainTip)
-> (SocketPath, ChainTip)
-> ChainPoint
-> SecurityParam
-> ConsensusFailure
ConsensusFailure
                (SocketPath
peerid1, ChainTip
apiTip1)
                (SocketPath
peerid2, ChainTip
apiTip2)
                ChainPoint
intersectChainPt
                SecurityParam
securityParam
          Maybe
  ((SocketPath, SocketPath),
   (Anchor (Header blk), Anchor (Header blk), Anchor (Header blk)))
Nothing ->
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
              ChainPoint -> [(SocketPath, ChainTip)] -> ConsensusSuccess
ConsensusSuccess
                -- the minimum intersection point:
                (forall blk. ConvertRawHash blk => Anchor (Header blk) -> ChainPoint
fromAnchor
                   forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.minimumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing 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, forall mode block.
(ConsensusBlockForMode mode ~ block) =>
ConsensusMode mode -> Tip block -> ChainTip
fromConsensusTip ConsensusMode mode
cMode forall a b. (a -> b) -> a -> b
$ forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Tip b
AF.anchorToTip (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) <- forall k a. Map k a -> [(k, a)]
Map.toList Map SocketPath (AnchoredFragment (Header 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 :: 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 =
      case 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 anchored at the genesis, so their intersection is never
        -- empty
        Maybe
  (AnchoredFragment (Header blk), AnchoredFragment (Header blk),
   AnchoredFragment (Header blk), AnchoredFragment (Header blk))
Nothing -> 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) ->
          ( forall v a b. AnchoredSeq v a b -> a
AF.anchor     AnchoredFragment (Header blk)
extension1
          , forall v a b. Anchorable v a b => AnchoredSeq v a b -> a
AF.headAnchor AnchoredFragment (Header blk)
extension1
          , 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 :: forall blk.
(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.
        forall blk. Anchor (Header blk) -> Word64
forkLen Anchor (Header blk)
tip1 forall a. Ord a => a -> a -> Bool
>  SecurityParam -> Word64
maxRollbacks SecurityParam
securityParam Bool -> Bool -> Bool
&&
        forall blk. Anchor (Header blk) -> Word64
forkLen Anchor (Header blk)
tip2 forall a. Ord a => a -> a -> Bool
>  SecurityParam -> Word64
maxRollbacks SecurityParam
securityParam
      where
        forkLen :: Anchor (Header blk) -> Word64
        forkLen :: forall blk. Anchor (Header blk) -> Word64
forkLen Anchor (Header blk)
tip =
          BlockNo -> Word64
Block.unBlockNo forall a b. (a -> b) -> a -> b
$
            forall t. t -> WithOrigin t -> t
fromWithOrigin BlockNo
0 (forall block. Anchor block -> WithOrigin BlockNo
AF.anchorToBlockNo Anchor (Header blk)
tip)
          forall a. Num a => a -> a -> a
- forall t. t -> WithOrigin t -> t
fromWithOrigin BlockNo
0 (forall block. Anchor block -> WithOrigin BlockNo
AF.anchorToBlockNo Anchor (Header blk)
intersection)


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


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

fromAnchor :: forall blk. ConvertRawHash blk => Anchor (Header blk) -> ChainPoint
fromAnchor :: forall blk. ConvertRawHash blk => Anchor (Header blk) -> ChainPoint
fromAnchor Anchor (Header blk)
AF.AnchorGenesis = ChainPoint
ChainPointAtGenesis
fromAnchor (AF.Anchor SlotNo
slot HeaderHash (Header blk)
headerhash BlockNo
_blockNo) =
  let sbs :: ShortByteString
sbs = forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> ShortByteString
toShortRawHash (forall {k} (t :: k). Proxy t
Proxy @blk) HeaderHash (Header blk)
headerhash
  in SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint SlotNo
slot forall a b. (a -> b) -> a -> b
$ ShortByteString -> Hash BlockHeader
HeaderHash ShortByteString
sbs

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

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


instance Exception ProgressFailure where
  displayException :: ProgressFailure -> String
displayException (ProgressFailure BlockNo
minBlockNo SocketPath
peerid ChainTip
tip) =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"progress failure:\n"
      , String
"the node at ", forall a. Show a => a -> String
show SocketPath
peerid, String
" has chain tip ", forall a. Show a => a -> String
show ChainTip
tip, String
"\n"
      , String
"while the minimum expected block number is ", 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
                  -> Either ProgressFailure ProgressSuccess
progressCondition :: BlockNo
-> ConsensusSuccess -> Either ProgressFailure ProgressSuccess
progressCondition BlockNo
minBlockNo (ConsensusSuccess ChainPoint
_ [(SocketPath, ChainTip)]
tips) = do
   case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\(SocketPath
_, ChainTip
ct) -> ChainTip -> BlockNo
getBlockNo ChainTip
ct forall a. Ord a => a -> a -> Bool
< BlockNo
minBlockNo) [(SocketPath, ChainTip)]
tips of
    Just (SocketPath
peerid, ChainTip
tip) -> forall a b. a -> Either a b
Left (BlockNo -> SocketPath -> ChainTip -> ProgressFailure
ProgressFailure BlockNo
minBlockNo SocketPath
peerid ChainTip
tip)
    Maybe (SocketPath, ChainTip)
Nothing -> forall a b. b -> Either a b
Right (BlockNo -> ProgressSuccess
ProgressSuccess BlockNo
minBlockNo)
 where
   getBlockNo :: ChainTip -> BlockNo
   getBlockNo :: ChainTip -> BlockNo
getBlockNo (ChainTip SlotNo
_ Hash BlockHeader
_ BlockNo
bNum) = BlockNo
bNum
   getBlockNo ChainTip
ChainTipAtGenesis = BlockNo
0

runChairman
  :: forall mode blk. ConsensusBlockForMode mode ~ blk
  => GetHeader (ConsensusBlockForMode mode)
  => Tracer IO String
  -> NetworkId
  -- ^ Security parameter, if a fork is deeper than it 'runChairman'
  -- will throw an exception.
  -> DiffTime
  -- ^ Run for this much time.
  -> [SocketPath]
  -- ^ Local socket directory
  -> ConsensusModeParams mode
  -> SecurityParam
  -> IO (Map SocketPath
             (AF.AnchoredSeq
                (WithOrigin SlotNo)
                (Anchor (Header blk))
                (Header blk)))
runChairman :: forall mode blk.
(ConsensusBlockForMode mode ~ blk,
 GetHeader (ConsensusBlockForMode mode)) =>
Tracer IO String
-> NetworkId
-> DiffTime
-> [SocketPath]
-> ConsensusModeParams mode
-> SecurityParam
-> IO
     (Map
        SocketPath
        (AnchoredSeq
           (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
runChairman Tracer IO String
tracer NetworkId
networkId DiffTime
runningTime [SocketPath]
socketPaths ConsensusModeParams mode
cModeParams SecurityParam
secParam = do
    let initialChains :: Map SocketPath (AF.AnchoredSeq (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
        initialChains :: Map
  SocketPath
  (AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
initialChains = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (SocketPath
socketPath, forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty forall block. Anchor block
AF.AnchorGenesis)
          | SocketPath
socketPath <- [SocketPath]
socketPaths]

    StrictTVar
  IO
  (Map
     SocketPath
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
chainsVar <- forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO Map
  SocketPath
  (AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk))
initialChains

    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
runningTime forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) (m :: * -> *) a b.
(Foldable f, MonadAsync m) =>
f a -> (a -> m b) -> m ()
forConcurrently_ [SocketPath]
socketPaths forall a b. (a -> b) -> a -> b
$ \SocketPath
sockPath ->
          let localConnInfo :: LocalNodeConnectInfo mode
localConnInfo = LocalNodeConnectInfo
                          { localConsensusModeParams :: ConsensusModeParams mode
localConsensusModeParams = ConsensusModeParams mode
cModeParams
                          , localNodeNetworkId :: NetworkId
localNodeNetworkId = NetworkId
networkId
                          , localNodeSocketPath :: String
localNodeSocketPath = SocketPath -> String
unSocketPath SocketPath
sockPath
                          }
              chairmanChainSyncClient :: LocalChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO
chairmanChainSyncClient = forall block point tip (m :: * -> *).
ChainSyncClient block point tip m ()
-> LocalChainSyncClient block point tip m
LocalChainSyncClient forall a b. (a -> b) -> a -> b
$ forall mode.
GetHeader (ConsensusBlockForMode mode) =>
Tracer IO ConsensusSuccess
-> SocketPath
-> ChainVar mode
-> ConsensusModeParams mode
-> SecurityParam
-> ChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO ()
chainSyncClient (forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer IO String
tracer) SocketPath
sockPath StrictTVar
  IO
  (Map
     SocketPath
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
chainsVar ConsensusModeParams mode
cModeParams SecurityParam
secParam
              protocolsInMode :: LocalNodeClientProtocols
  (BlockInMode mode)
  ChainPoint
  ChainTip
  SlotNo
  (TxInMode mode)
  (TxIdInMode mode)
  (TxValidationErrorInMode mode)
  (QueryInMode mode)
  IO
protocolsInMode = LocalNodeClientProtocols
                { localChainSyncClient :: LocalChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO
localChainSyncClient = LocalChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO
chairmanChainSyncClient
                , localTxSubmissionClient :: Maybe
  (LocalTxSubmissionClient
     (TxInMode mode) (TxValidationErrorInMode mode) IO ())
localTxSubmissionClient = forall a. Maybe a
Nothing
                , localStateQueryClient :: Maybe
  (LocalStateQueryClient
     (BlockInMode mode) ChainPoint (QueryInMode mode) IO ())
localStateQueryClient = forall a. Maybe a
Nothing
                , localTxMonitoringClient :: Maybe
  (LocalTxMonitorClient
     (TxIdInMode mode) (TxInMode mode) SlotNo IO ())
localTxMonitoringClient = forall a. Maybe a
Nothing
                }
          in forall mode.
LocalNodeConnectInfo mode
-> LocalNodeClientProtocolsInMode mode -> IO ()
connectToLocalNode LocalNodeConnectInfo mode
localConnInfo LocalNodeClientProtocols
  (BlockInMode mode)
  ChainPoint
  ChainTip
  SlotNo
  (TxInMode mode)
  (TxIdInMode mode)
  (TxValidationErrorInMode mode)
  (QueryInMode mode)
  IO
protocolsInMode

    forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar
  IO
  (Map
     SocketPath
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header blk)) (Header blk)))
chainsVar

-- 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 :: forall blk (m :: * -> *).
(MonadSTM m, GetHeader blk) =>
SocketPath -> ChainsVar m blk -> blk -> STM m ()
addBlock SocketPath
sockPath ChainsVar m blk
chainsVar blk
blk =
    forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar ChainsVar m blk
chainsVar (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall block.
HasHeader block =>
block -> AnchoredFragment block -> AnchoredFragment block
AF.addBlock (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 mode blk. ConsensusBlockForMode mode ~ blk
  => HasHeader (Header blk)
  => SocketPath
  -> StrictTVar IO (Map SocketPath (AnchoredFragment (Header (ConsensusBlockForMode mode))))
  -> ConsensusMode mode
  -> ChainPoint
  -> STM IO ()
rollback :: forall mode blk.
(ConsensusBlockForMode mode ~ blk, HasHeader (Header blk)) =>
SocketPath
-> StrictTVar
     IO
     (Map
        SocketPath
        (AnchoredFragment (Header (ConsensusBlockForMode mode))))
-> ConsensusMode mode
-> ChainPoint
-> STM IO ()
rollback SocketPath
sockPath StrictTVar
  IO
  (Map
     SocketPath
     (AnchoredFragment (Header (ConsensusBlockForMode mode))))
chainsVar ConsensusMode mode
cMode ChainPoint
p =
  forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar
  IO
  (Map
     SocketPath
     (AnchoredFragment (Header (ConsensusBlockForMode mode))))
chainsVar (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust AnchoredFragment (Header (ConsensusBlockForMode mode))
-> AnchoredFragment (Header (ConsensusBlockForMode mode))
fn SocketPath
sockPath)
  where
    p' :: Point (Header (ConsensusBlockForMode mode))
    p' :: Point (Header (ConsensusBlockForMode mode))
p' = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall mode.
ConsensusMode mode
-> ChainPoint -> Point (ConsensusBlockForMode mode)
toConsensusPointInMode ConsensusMode mode
cMode ChainPoint
p

    fn :: AnchoredFragment (Header (ConsensusBlockForMode mode))
       -> AnchoredFragment (Header (ConsensusBlockForMode mode))
    fn :: AnchoredFragment (Header (ConsensusBlockForMode mode))
-> AnchoredFragment (Header (ConsensusBlockForMode mode))
fn AnchoredFragment (Header (ConsensusBlockForMode mode))
cf = case forall block.
HasHeader block =>
Point block
-> AnchoredFragment block -> Maybe (AnchoredFragment block)
AF.rollback Point (Header (ConsensusBlockForMode mode))
p' AnchoredFragment (Header (ConsensusBlockForMode mode))
cf of
      Maybe (AnchoredFragment (Header blk))
Nothing  -> 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' = ConsensusSuccess

type ChainVar mode = StrictTVar IO (Map SocketPath (AnchoredFragment (Header (ConsensusBlockForMode mode))))

-- | 'chainSyncClient which build chain fragment; on every roll forward it will
-- check if there is consensus on immutable chain.
chainSyncClient
  :: forall mode. GetHeader (ConsensusBlockForMode mode)
  => Tracer IO ChairmanTrace'
  -> SocketPath
  -> ChainVar mode
  -> ConsensusModeParams mode
  -> SecurityParam
  -> ChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO ()
chainSyncClient :: forall mode.
GetHeader (ConsensusBlockForMode mode) =>
Tracer IO ConsensusSuccess
-> SocketPath
-> ChainVar mode
-> ConsensusModeParams mode
-> SecurityParam
-> ChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO ()
chainSyncClient Tracer IO ConsensusSuccess
tracer SocketPath
sockPath ChainVar mode
chainsVar ConsensusModeParams mode
cModeP SecurityParam
secParam = forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure 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.
  forall point header tip (m :: * -> *) a.
[point]
-> ClientStIntersect header point tip m a
-> ClientStIdle header point tip m a
SendMsgFindIntersect
    [forall mode.
ConsensusMode mode
-> Point (ConsensusBlockForMode mode) -> ChainPoint
fromConsensusPointInMode (forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeP) forall block. Point block
Block.genesisPoint]
    ClientStIntersect
    { recvMsgIntersectFound :: ChainPoint
-> ChainTip
-> ChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO ()
recvMsgIntersectFound    = \ChainPoint
_ ChainTip
_ -> forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle (BlockInMode mode) ChainPoint ChainTip IO ()
clientStIdle
    , recvMsgIntersectNotFound :: ChainTip
-> ChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO ()
recvMsgIntersectNotFound = \  ChainTip
_ -> forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle (BlockInMode mode) ChainPoint ChainTip IO ()
clientStIdle
    }
  where
    clientStIdle :: ClientStIdle (BlockInMode mode) ChainPoint ChainTip IO ()
    clientStIdle :: ClientStIdle (BlockInMode mode) ChainPoint ChainTip IO ()
clientStIdle = 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 (BlockInMode mode) ChainPoint ChainTip IO ()
clientStNext (forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStNext (BlockInMode mode) ChainPoint ChainTip IO ()
clientStNext)

    clientStNext :: ClientStNext (BlockInMode mode) ChainPoint ChainTip IO ()
    clientStNext :: ClientStNext (BlockInMode mode) ChainPoint ChainTip IO ()
clientStNext = ClientStNext
      { recvMsgRollForward :: BlockInMode mode
-> ChainTip
-> ChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO ()
recvMsgRollForward = \BlockInMode mode
blk ChainTip
_tip -> forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient forall a b. (a -> b) -> a -> b
$ do
          -- add block & check if there is consensus on immutable chain
          -- trace the decision or error
          ConsensusSuccess
res <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
            forall blk (m :: * -> *).
(MonadSTM m, GetHeader blk) =>
SocketPath -> ChainsVar m blk -> blk -> STM m ()
addBlock SocketPath
sockPath ChainVar mode
chainsVar forall a b. (a -> b) -> a -> b
$ forall mode block.
(ConsensusBlockForMode mode ~ block,
 LedgerSupportsProtocol
   (ShelleyBlock
      (TPraos StandardCrypto) (ShelleyEra StandardCrypto))) =>
BlockInMode mode -> block
toConsensusBlock BlockInMode mode
blk
            forall mode blk a.
(ConsensusBlockForMode mode ~ blk) =>
ConsensusMode mode
-> ((HasHeader (Header blk),
     ConvertRawHash (ConsensusBlockForMode mode)) =>
    a)
-> a
obtainHasHeader (forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeP) forall a b. (a -> b) -> a -> b
$ forall mode.
(HasHeader (Header (ConsensusBlockForMode mode)),
 ConvertRawHash (ConsensusBlockForMode mode)) =>
ConsensusMode mode
-> ChainVar mode -> SecurityParam -> STM IO ConsensusSuccess
checkConsensus (forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeP) ChainVar mode
chainsVar SecurityParam
secParam
          forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO ConsensusSuccess
tracer ConsensusSuccess
res
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle (BlockInMode mode) ChainPoint ChainTip IO ()
clientStIdle
      , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> ChainSyncClient (BlockInMode mode) ChainPoint ChainTip IO ()
recvMsgRollBackward = \ChainPoint
point ChainTip
_tip -> forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient forall a b. (a -> b) -> a -> b
$ do
          -- rollback & check
          ConsensusSuccess
res <- forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
            forall mode blk.
(ConsensusBlockForMode mode ~ blk, HasHeader (Header blk)) =>
SocketPath
-> StrictTVar
     IO
     (Map
        SocketPath
        (AnchoredFragment (Header (ConsensusBlockForMode mode))))
-> ConsensusMode mode
-> ChainPoint
-> STM IO ()
rollback SocketPath
sockPath ChainVar mode
chainsVar (forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeP) ChainPoint
point
            forall mode blk a.
(ConsensusBlockForMode mode ~ blk) =>
ConsensusMode mode
-> ((HasHeader (Header blk),
     ConvertRawHash (ConsensusBlockForMode mode)) =>
    a)
-> a
obtainHasHeader (forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeP) forall a b. (a -> b) -> a -> b
$ forall mode.
(HasHeader (Header (ConsensusBlockForMode mode)),
 ConvertRawHash (ConsensusBlockForMode mode)) =>
ConsensusMode mode
-> ChainVar mode -> SecurityParam -> STM IO ConsensusSuccess
checkConsensus (forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeP) ChainVar mode
chainsVar SecurityParam
secParam
          forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO ConsensusSuccess
tracer ConsensusSuccess
res
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientStIdle (BlockInMode mode) ChainPoint ChainTip IO ()
clientStIdle
      }

-- Helpers

obtainHasHeader
  :: ConsensusBlockForMode mode ~ blk
  => ConsensusMode mode
  -> ((HasHeader (Header blk), ConvertRawHash (ConsensusBlockForMode mode)) => a)
  -> a
obtainHasHeader :: forall mode blk a.
(ConsensusBlockForMode mode ~ blk) =>
ConsensusMode mode
-> ((HasHeader (Header blk),
     ConvertRawHash (ConsensusBlockForMode mode)) =>
    a)
-> a
obtainHasHeader ConsensusMode mode
ByronMode (HasHeader (Header blk),
 ConvertRawHash (ConsensusBlockForMode mode)) =>
a
f = (HasHeader (Header blk),
 ConvertRawHash (ConsensusBlockForMode mode)) =>
a
f
obtainHasHeader ConsensusMode mode
ShelleyMode (HasHeader (Header blk),
 ConvertRawHash (ConsensusBlockForMode mode)) =>
a
f = (HasHeader (Header blk),
 ConvertRawHash (ConsensusBlockForMode mode)) =>
a
f
obtainHasHeader ConsensusMode mode
CardanoMode (HasHeader (Header blk),
 ConvertRawHash (ConsensusBlockForMode mode)) =>
a
f = (HasHeader (Header blk),
 ConvertRawHash (ConsensusBlockForMode mode)) =>
a
f

obtainGetHeader
  :: ConsensusMode mode
  -> ( (GetHeader (ConsensusBlockForMode mode)
       ) => a)
  -> a
obtainGetHeader :: forall mode a.
ConsensusMode mode
-> (GetHeader (ConsensusBlockForMode mode) => a) -> a
obtainGetHeader ConsensusMode mode
ByronMode GetHeader (ConsensusBlockForMode mode) => a
f = GetHeader (ConsensusBlockForMode mode) => a
f
obtainGetHeader ConsensusMode mode
ShelleyMode GetHeader (ConsensusBlockForMode mode) => a
f = GetHeader (ConsensusBlockForMode mode) => a
f
obtainGetHeader ConsensusMode mode
CardanoMode GetHeader (ConsensusBlockForMode mode) => a
f = GetHeader (ConsensusBlockForMode mode) => a
f

-- | Check that all nodes agree with each other, within the security parameter.
checkConsensus
  :: HasHeader (Header (ConsensusBlockForMode mode))
  => ConvertRawHash (ConsensusBlockForMode mode)
  => ConsensusMode mode
  -> ChainVar mode
  -> SecurityParam
  -> STM IO ConsensusSuccess
checkConsensus :: forall mode.
(HasHeader (Header (ConsensusBlockForMode mode)),
 ConvertRawHash (ConsensusBlockForMode mode)) =>
ConsensusMode mode
-> ChainVar mode -> SecurityParam -> STM IO ConsensusSuccess
checkConsensus ConsensusMode mode
cMode ChainVar mode
chainsVar SecurityParam
secParam = do
  Map
  SocketPath (AnchoredFragment (Header (ConsensusBlockForMode mode)))
chainsSnapshot <- forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar ChainVar mode
chainsVar
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall mode blk.
(ConsensusBlockForMode mode ~ blk, HasHeader (Header blk),
 ConvertRawHash blk) =>
ConsensusMode mode
-> Map SocketPath (AnchoredFragment (Header blk))
-> SecurityParam
-> Either ConsensusFailure ConsensusSuccess
consensusCondition ConsensusMode mode
cMode  Map
  SocketPath (AnchoredFragment (Header (ConsensusBlockForMode mode)))
chainsSnapshot SecurityParam
secParam