{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Consensus.HardFork.Combinator (tests) where

import qualified Data.Map.Strict as Map
import           Data.SOP.Counting
import           Data.SOP.InPairs (RequiringBoth (..))
import qualified Data.SOP.InPairs as InPairs
import           Data.SOP.OptNP (OptNP (..))
import           Data.SOP.Strict
import qualified Data.SOP.Tails as Tails
import           Data.Word
import           GHC.Generics (Generic)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HardFork.Combinator
import           Ouroboros.Consensus.HardFork.Combinator.Condense ()
import           Ouroboros.Consensus.HardFork.Combinator.Serialisation
import           Ouroboros.Consensus.HardFork.Combinator.State.Types
import           Ouroboros.Consensus.HardFork.History (EraParams (..))
import qualified Ouroboros.Consensus.HardFork.History as History
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.NodeId
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Protocol.LeaderSchedule
                     (LeaderSchedule (..), leaderScheduleFor)
import           Ouroboros.Consensus.TypeFamilyWrappers
import           Ouroboros.Consensus.Util.Orphans ()
import qualified Ouroboros.Network.Mock.Chain as Mock
import           Quiet (Quiet (..))
import           Test.Consensus.HardFork.Combinator.A
import           Test.Consensus.HardFork.Combinator.B
import           Test.QuickCheck
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.ThreadNet.General
import           Test.ThreadNet.Network
import           Test.ThreadNet.TxGen
import           Test.ThreadNet.Util
import           Test.ThreadNet.Util.NodeJoinPlan
import           Test.ThreadNet.Util.NodeRestarts
import           Test.ThreadNet.Util.NodeToNodeVersion
import           Test.ThreadNet.Util.NodeTopology
import           Test.ThreadNet.Util.Seed
import           Test.Util.HardFork.Future
import           Test.Util.SanityCheck (prop_sanityChecks)
import           Test.Util.Slots (NumSlots (..))
import           Test.Util.Time (dawnOfTime)

tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"Consensus" [
      String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"simple convergence" ((TestSetup -> Property) -> TestTree)
-> (TestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$
        TestSetup -> Property
prop_simple_hfc_convergence
    ]

data AB a = AB {forall a. AB a -> a
getA, forall a. AB a -> a
getB :: a}
  deriving ((forall m. Monoid m => AB m -> m)
-> (forall m a. Monoid m => (a -> m) -> AB a -> m)
-> (forall m a. Monoid m => (a -> m) -> AB a -> m)
-> (forall a b. (a -> b -> b) -> b -> AB a -> b)
-> (forall a b. (a -> b -> b) -> b -> AB a -> b)
-> (forall b a. (b -> a -> b) -> b -> AB a -> b)
-> (forall b a. (b -> a -> b) -> b -> AB a -> b)
-> (forall a. (a -> a -> a) -> AB a -> a)
-> (forall a. (a -> a -> a) -> AB a -> a)
-> (forall a. AB a -> [a])
-> (forall a. AB a -> Bool)
-> (forall a. AB a -> Int)
-> (forall a. Eq a => a -> AB a -> Bool)
-> (forall a. Ord a => AB a -> a)
-> (forall a. Ord a => AB a -> a)
-> (forall a. Num a => AB a -> a)
-> (forall a. Num a => AB a -> a)
-> Foldable AB
forall a. Eq a => a -> AB a -> Bool
forall a. Num a => AB a -> a
forall a. Ord a => AB a -> a
forall m. Monoid m => AB m -> m
forall a. AB a -> Bool
forall a. AB a -> Int
forall a. AB a -> [a]
forall a. (a -> a -> a) -> AB a -> a
forall m a. Monoid m => (a -> m) -> AB a -> m
forall b a. (b -> a -> b) -> b -> AB a -> b
forall a b. (a -> b -> b) -> b -> AB a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => AB m -> m
fold :: forall m. Monoid m => AB m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> AB a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> AB a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> AB a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> AB a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> AB a -> b
foldr :: forall a b. (a -> b -> b) -> b -> AB a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> AB a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> AB a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> AB a -> b
foldl :: forall b a. (b -> a -> b) -> b -> AB a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> AB a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> AB a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> AB a -> a
foldr1 :: forall a. (a -> a -> a) -> AB a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> AB a -> a
foldl1 :: forall a. (a -> a -> a) -> AB a -> a
$ctoList :: forall a. AB a -> [a]
toList :: forall a. AB a -> [a]
$cnull :: forall a. AB a -> Bool
null :: forall a. AB a -> Bool
$clength :: forall a. AB a -> Int
length :: forall a. AB a -> Int
$celem :: forall a. Eq a => a -> AB a -> Bool
elem :: forall a. Eq a => a -> AB a -> Bool
$cmaximum :: forall a. Ord a => AB a -> a
maximum :: forall a. Ord a => AB a -> a
$cminimum :: forall a. Ord a => AB a -> a
minimum :: forall a. Ord a => AB a -> a
$csum :: forall a. Num a => AB a -> a
sum :: forall a. Num a => AB a -> a
$cproduct :: forall a. Num a => AB a -> a
product :: forall a. Num a => AB a -> a
Foldable, (forall a b. (a -> b) -> AB a -> AB b)
-> (forall a b. a -> AB b -> AB a) -> Functor AB
forall a b. a -> AB b -> AB a
forall a b. (a -> b) -> AB a -> AB b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> AB a -> AB b
fmap :: forall a b. (a -> b) -> AB a -> AB b
$c<$ :: forall a b. a -> AB b -> AB a
<$ :: forall a b. a -> AB b -> AB a
Functor, (forall x. AB a -> Rep (AB a) x)
-> (forall x. Rep (AB a) x -> AB a) -> Generic (AB a)
forall x. Rep (AB a) x -> AB a
forall x. AB a -> Rep (AB a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (AB a) x -> AB a
forall a x. AB a -> Rep (AB a) x
$cfrom :: forall a x. AB a -> Rep (AB a) x
from :: forall x. AB a -> Rep (AB a) x
$cto :: forall a x. Rep (AB a) x -> AB a
to :: forall x. Rep (AB a) x -> AB a
Generic, Functor AB
Foldable AB
(Functor AB, Foldable AB) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> AB a -> f (AB b))
-> (forall (f :: * -> *) a. Applicative f => AB (f a) -> f (AB a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> AB a -> m (AB b))
-> (forall (m :: * -> *) a. Monad m => AB (m a) -> m (AB a))
-> Traversable AB
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => AB (m a) -> m (AB a)
forall (f :: * -> *) a. Applicative f => AB (f a) -> f (AB a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> AB a -> m (AB b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AB a -> f (AB b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AB a -> f (AB b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AB a -> f (AB b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => AB (f a) -> f (AB a)
sequenceA :: forall (f :: * -> *) a. Applicative f => AB (f a) -> f (AB a)
$cmapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> AB a -> m (AB b)
mapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> AB a -> m (AB b)
$csequence :: forall (m :: * -> *) a. Monad m => AB (m a) -> m (AB a)
sequence :: forall (m :: * -> *) a. Monad m => AB (m a) -> m (AB a)
Traversable)
  deriving (Int -> AB a -> ShowS
[AB a] -> ShowS
AB a -> String
(Int -> AB a -> ShowS)
-> (AB a -> String) -> ([AB a] -> ShowS) -> Show (AB a)
forall a. Show a => Int -> AB a -> ShowS
forall a. Show a => [AB a] -> ShowS
forall a. Show a => AB a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> AB a -> ShowS
showsPrec :: Int -> AB a -> ShowS
$cshow :: forall a. Show a => AB a -> String
show :: AB a -> String
$cshowList :: forall a. Show a => [AB a] -> ShowS
showList :: [AB a] -> ShowS
Show) via (Quiet (AB a))

instance Applicative AB where
  pure :: forall a. a -> AB a
pure a
x = a -> a -> AB a
forall a. a -> a -> AB a
AB a
x a
x
  AB a -> b
af a -> b
bf <*> :: forall a b. AB (a -> b) -> AB a -> AB b
<*> AB a
a a
b = b -> b -> AB b
forall a. a -> a -> AB a
AB (a -> b
af a
a) (a -> b
bf a
b)

data TestSetup = TestSetup {
      TestSetup -> AB EpochSize
testSetupEpochSize  :: AB EpochSize
      -- ^ INVARIANT: @> 0@
    , TestSetup -> SecurityParam
testSetupK          :: SecurityParam
    , TestSetup -> Seed
testSetupSeed       :: Seed
    , TestSetup -> AB SlotLength
testSetupSlotLength :: AB SlotLength
    , TestSetup -> SlotNo
testSetupTxSlot     :: SlotNo
    }
  deriving (Int -> TestSetup -> ShowS
[TestSetup] -> ShowS
TestSetup -> String
(Int -> TestSetup -> ShowS)
-> (TestSetup -> String)
-> ([TestSetup] -> ShowS)
-> Show TestSetup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestSetup -> ShowS
showsPrec :: Int -> TestSetup -> ShowS
$cshow :: TestSetup -> String
show :: TestSetup -> String
$cshowList :: [TestSetup] -> ShowS
showList :: [TestSetup] -> ShowS
Show)

instance Arbitrary TestSetup where
  arbitrary :: Gen TestSetup
arbitrary = do
      AB EpochSize
testSetupEpochSize <- Gen EpochSize -> Gen (AB EpochSize)
forall (m :: * -> *) a. Monad m => m a -> m (AB a)
abM (Gen EpochSize -> Gen (AB EpochSize))
-> Gen EpochSize -> Gen (AB EpochSize)
forall a b. (a -> b) -> a -> b
$ Word64 -> EpochSize
EpochSize (Word64 -> EpochSize) -> Gen Word64 -> Gen EpochSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
10)
      SecurityParam
testSetupK         <- Word64 -> SecurityParam
SecurityParam   (Word64 -> SecurityParam) -> Gen Word64 -> Gen SecurityParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
2, Word64
10)
      -- TODO why does k=1 cause the nodes to only forge in the first epoch?
      SlotNo
testSetupTxSlot    <- Word64 -> SlotNo
SlotNo          (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
9)

      Seed
testSetupSeed       <- Gen Seed
forall a. Arbitrary a => Gen a
arbitrary
      AB SlotLength
testSetupSlotLength <- Gen SlotLength -> Gen (AB SlotLength)
forall (m :: * -> *) a. Monad m => m a -> m (AB a)
abM Gen SlotLength
forall a. Arbitrary a => Gen a
arbitrary
      TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return TestSetup{SlotNo
SecurityParam
Seed
AB EpochSize
AB SlotLength
testSetupEpochSize :: AB EpochSize
testSetupK :: SecurityParam
testSetupSeed :: Seed
testSetupSlotLength :: AB SlotLength
testSetupTxSlot :: SlotNo
testSetupEpochSize :: AB EpochSize
testSetupK :: SecurityParam
testSetupTxSlot :: SlotNo
testSetupSeed :: Seed
testSetupSlotLength :: AB SlotLength
..}
    where
      abM :: Monad m => m a -> m (AB a)
      abM :: forall (m :: * -> *) a. Monad m => m a -> m (AB a)
abM = AB (m a) -> m (AB a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => AB (m a) -> m (AB a)
sequence (AB (m a) -> m (AB a)) -> (m a -> AB (m a)) -> m a -> m (AB a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> AB (m a)
forall a. a -> AB a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | The number of epochs in the A era
testSetupEraSizeA :: TestSetup -> EraSize
testSetupEraSizeA :: TestSetup -> EraSize
testSetupEraSizeA TestSetup{SlotNo
SecurityParam
Seed
AB EpochSize
AB SlotLength
testSetupEpochSize :: TestSetup -> AB EpochSize
testSetupK :: TestSetup -> SecurityParam
testSetupSeed :: TestSetup -> Seed
testSetupSlotLength :: TestSetup -> AB SlotLength
testSetupTxSlot :: TestSetup -> SlotNo
testSetupEpochSize :: AB EpochSize
testSetupK :: SecurityParam
testSetupSeed :: Seed
testSetupSlotLength :: AB SlotLength
testSetupTxSlot :: SlotNo
..} =
    -- This function, as a specification, intentionally independently
    -- reimplements the interpretation of the 'InitiateAtoB' transaction by the
    -- A ledger.
    Word64 -> EraSize
EraSize (Word64 -> EraSize) -> Word64 -> EraSize
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
forall a. Enum a => a -> a
succ Word64
lastEpochA
  where
    lastEpochA :: Word64
lastEpochA = Word64
lastSlotA Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` EpochSize -> Word64
unEpochSize (AB EpochSize -> EpochSize
forall a. AB a -> a
getA AB EpochSize
testSetupEpochSize)
    lastSlotA :: Word64
lastSlotA  =
        SlotNo -> Word64
unSlotNo SlotNo
testSetupTxSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+
        SecurityParam -> Word64
stabilityWindowA SecurityParam
testSetupK Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+
        SecurityParam -> Word64
safeFromTipA SecurityParam
testSetupK

-- | Minimum number of slots needed to include exactly one epoch of the B era
testSetupNumSlots :: TestSetup -> NumSlots
testSetupNumSlots :: TestSetup -> NumSlots
testSetupNumSlots testSetup :: TestSetup
testSetup@TestSetup{SlotNo
SecurityParam
Seed
AB EpochSize
AB SlotLength
testSetupEpochSize :: TestSetup -> AB EpochSize
testSetupK :: TestSetup -> SecurityParam
testSetupSeed :: TestSetup -> Seed
testSetupSlotLength :: TestSetup -> AB SlotLength
testSetupTxSlot :: TestSetup -> SlotNo
testSetupEpochSize :: AB EpochSize
testSetupK :: SecurityParam
testSetupSeed :: Seed
testSetupSlotLength :: AB SlotLength
testSetupTxSlot :: SlotNo
..} =
    -- this test doesn't need more than one B epoch
    Word64 -> NumSlots
NumSlots (Word64 -> NumSlots) -> Word64 -> NumSlots
forall a b. (a -> b) -> a -> b
$ Word64
eraSizeA Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
epoSizeA Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
epoSizeB
  where
    EraSize Word64
eraSizeA     = TestSetup -> EraSize
testSetupEraSizeA TestSetup
testSetup
    AB Word64
epoSizeA Word64
epoSizeB = EpochSize -> Word64
unEpochSize (EpochSize -> Word64) -> AB EpochSize -> AB Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AB EpochSize
testSetupEpochSize

prop_simple_hfc_convergence :: TestSetup -> Property
prop_simple_hfc_convergence :: TestSetup -> Property
prop_simple_hfc_convergence testSetup :: TestSetup
testSetup@TestSetup{SlotNo
SecurityParam
Seed
AB EpochSize
AB SlotLength
testSetupEpochSize :: TestSetup -> AB EpochSize
testSetupK :: TestSetup -> SecurityParam
testSetupSeed :: TestSetup -> Seed
testSetupSlotLength :: TestSetup -> AB SlotLength
testSetupTxSlot :: TestSetup -> SlotNo
testSetupEpochSize :: AB EpochSize
testSetupK :: SecurityParam
testSetupSeed :: Seed
testSetupSlotLength :: AB SlotLength
testSetupTxSlot :: SlotNo
..} =
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (TestConfig -> String
forall a. Show a => a -> String
show TestConfig
testConfig) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"eraSizeA: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> EraSize -> String
forall a. Show a => a -> String
show EraSize
eraSizeA) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"epochs in era A" [String
labelEraSizeA] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    PropGeneralArgs TestBlock -> TestOutput TestBlock -> Property
forall blk.
(Condense blk, Condense (HeaderHash blk), Eq blk, RunNode blk) =>
PropGeneralArgs blk -> TestOutput blk -> Property
prop_general PropGeneralArgs TestBlock
args TestOutput TestBlock
testOutput Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
    TopLevelConfig TestBlock -> Property
forall blk.
BlockSupportsSanityCheck blk =>
TopLevelConfig blk -> Property
prop_sanityChecks (CoreNodeId -> TopLevelConfig TestBlock
topLevelConfig (Word64 -> CoreNodeId
CoreNodeId Word64
0))  Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
    Property
prop_allExpectedBlocks
  where
    k :: SecurityParam
    k :: SecurityParam
k = SecurityParam
testSetupK

    eraParamsA, eraParamsB :: EraParams
    AB EraParams
eraParamsA EraParams
eraParamsB =
        EpochSize -> SlotLength -> SafeZone -> GenesisWindow -> EraParams
EraParams
        (EpochSize -> SlotLength -> SafeZone -> GenesisWindow -> EraParams)
-> AB EpochSize
-> AB (SlotLength -> SafeZone -> GenesisWindow -> EraParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AB EpochSize
testSetupEpochSize
        AB (SlotLength -> SafeZone -> GenesisWindow -> EraParams)
-> AB SlotLength -> AB (SafeZone -> GenesisWindow -> EraParams)
forall a b. AB (a -> b) -> AB a -> AB b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AB SlotLength
testSetupSlotLength
        AB (SafeZone -> GenesisWindow -> EraParams)
-> AB SafeZone -> AB (GenesisWindow -> EraParams)
forall a b. AB (a -> b) -> AB a -> AB b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SafeZone -> SafeZone -> AB SafeZone
forall a. a -> a -> AB a
AB (Word64 -> SafeZone
History.StandardSafeZone (SecurityParam -> Word64
safeFromTipA SecurityParam
k))
               (SecurityParam -> SafeZone
safeZoneB SecurityParam
k)
        AB (GenesisWindow -> EraParams) -> AB GenesisWindow -> AB EraParams
forall a b. AB (a -> b) -> AB a -> AB b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenesisWindow -> AB GenesisWindow
forall a. a -> AB a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> GenesisWindow
GenesisWindow ((SecurityParam -> Word64
maxRollbacks SecurityParam
k) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
2))

    shape :: History.Shape '[BlockA, BlockB]
    shape :: Shape '[BlockA, BlockB]
shape = Exactly '[BlockA, BlockB] EraParams -> Shape '[BlockA, BlockB]
forall (xs :: [*]). Exactly xs EraParams -> Shape xs
History.Shape (Exactly '[BlockA, BlockB] EraParams -> Shape '[BlockA, BlockB])
-> Exactly '[BlockA, BlockB] EraParams -> Shape '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$ EraParams -> EraParams -> Exactly '[BlockA, BlockB] EraParams
forall a x y. a -> a -> Exactly '[x, y] a
exactlyTwo EraParams
eraParamsA EraParams
eraParamsB

    leaderSchedule :: LeaderSchedule
    leaderSchedule :: LeaderSchedule
leaderSchedule = NumCoreNodes -> NumSlots -> LeaderSchedule
roundRobinLeaderSchedule NumCoreNodes
numCoreNodes NumSlots
numSlots
      where
        TestConfig{NumCoreNodes
NumSlots
NodeTopology
Seed
numCoreNodes :: NumCoreNodes
numSlots :: NumSlots
initSeed :: Seed
nodeTopology :: NodeTopology
initSeed :: TestConfig -> Seed
nodeTopology :: TestConfig -> NodeTopology
numCoreNodes :: TestConfig -> NumCoreNodes
numSlots :: TestConfig -> NumSlots
..} = TestConfig
testConfig

    args :: PropGeneralArgs TestBlock
    args :: PropGeneralArgs TestBlock
args = PropGeneralArgs {
          pgaBlockProperty :: TestBlock -> Property
pgaBlockProperty       = Property -> TestBlock -> Property
forall a b. a -> b -> a
const (Property -> TestBlock -> Property)
-> Property -> TestBlock -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
        , pgaCountTxs :: TestBlock -> Word64
pgaCountTxs            = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> (TestBlock -> Int) -> TestBlock -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenTx TestBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([GenTx TestBlock] -> Int)
-> (TestBlock -> [GenTx TestBlock]) -> TestBlock -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> [GenTx TestBlock]
forall blk. HasTxs blk => blk -> [GenTx blk]
extractTxs
        , pgaExpectedCannotForge :: SlotNo -> NodeId -> WrapCannotForge TestBlock -> Bool
pgaExpectedCannotForge = SlotNo -> NodeId -> WrapCannotForge TestBlock -> Bool
forall blk. SlotNo -> NodeId -> WrapCannotForge blk -> Bool
noExpectedCannotForges
        , pgaFirstBlockNo :: BlockNo
pgaFirstBlockNo        = Word64 -> BlockNo
BlockNo Word64
0
        , pgaFixedMaxForkLength :: Maybe NumBlocks
pgaFixedMaxForkLength  = Maybe NumBlocks
forall a. Maybe a
Nothing
        , pgaFixedSchedule :: Maybe LeaderSchedule
pgaFixedSchedule       = LeaderSchedule -> Maybe LeaderSchedule
forall a. a -> Maybe a
Just LeaderSchedule
leaderSchedule
        , pgaSecurityParam :: SecurityParam
pgaSecurityParam       = SecurityParam
k
        , pgaTestConfig :: TestConfig
pgaTestConfig          = TestConfig
testConfig
        , pgaTestConfigB :: TestConfigB TestBlock
pgaTestConfigB         = TestConfigB TestBlock
testConfigB
        }

    testConfig :: TestConfig
    testConfig :: TestConfig
testConfig = TestConfig {
          numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
        , numSlots :: NumSlots
numSlots     = TestSetup -> NumSlots
testSetupNumSlots TestSetup
testSetup
        , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
        , initSeed :: Seed
initSeed     = Seed
testSetupSeed
        }
      where
        ncn :: NumCoreNodes
        ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
2

    eraSizeA :: EraSize
    eraSizeA :: EraSize
eraSizeA = TestSetup -> EraSize
testSetupEraSizeA TestSetup
testSetup

    testConfigB :: TestConfigB TestBlock
    testConfigB :: TestConfigB TestBlock
testConfigB = TestConfigB {
          forgeEbbEnv :: Maybe (ForgeEbbEnv TestBlock)
forgeEbbEnv = Maybe (ForgeEbbEnv TestBlock)
forall a. Maybe a
Nothing
        , future :: Future
future      =
            SlotLength -> EpochSize -> EraSize -> Future -> Future
EraCons  (EraParams -> SlotLength
eraSlotLength EraParams
eraParamsA)
                     (EraParams -> EpochSize
eraEpochSize  EraParams
eraParamsA)
                     EraSize
eraSizeA (Future -> Future) -> Future -> Future
forall a b. (a -> b) -> a -> b
$
            SlotLength -> EpochSize -> Future
EraFinal (EraParams -> SlotLength
eraSlotLength EraParams
eraParamsB)
                     (EraParams -> EpochSize
eraEpochSize  EraParams
eraParamsB)
        , messageDelay :: CalcMessageDelay TestBlock
messageDelay = CalcMessageDelay TestBlock
forall blk. CalcMessageDelay blk
noCalcMessageDelay
        , nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
numCoreNodes
        , nodeRestarts :: NodeRestarts
nodeRestarts = NodeRestarts
noRestarts
        , txGenExtra :: TxGenExtra TestBlock
txGenExtra   = ()
        , version :: (NodeToNodeVersion, BlockNodeToNodeVersion TestBlock)
version      = Proxy TestBlock
-> (NodeToNodeVersion, BlockNodeToNodeVersion TestBlock)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
newestVersion (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @TestBlock)
        }
      where
        TestConfig{NumCoreNodes
NumSlots
NodeTopology
Seed
initSeed :: TestConfig -> Seed
nodeTopology :: TestConfig -> NodeTopology
numCoreNodes :: TestConfig -> NumCoreNodes
numSlots :: TestConfig -> NumSlots
numCoreNodes :: NumCoreNodes
initSeed :: Seed
nodeTopology :: NodeTopology
numSlots :: NumSlots
..} = TestConfig
testConfig

    testConfigMB :: Monad m => TestConfigMB m TestBlock
    testConfigMB :: forall (m :: * -> *). Monad m => TestConfigMB m TestBlock
testConfigMB = TestConfigMB {
          nodeInfo :: CoreNodeId -> TestNodeInitialization m TestBlock
nodeInfo = \CoreNodeId
a -> ProtocolInfo TestBlock
-> m [BlockForging m TestBlock]
-> TestNodeInitialization m TestBlock
forall blk (m :: * -> *).
ProtocolInfo blk
-> m [BlockForging m blk] -> TestNodeInitialization m blk
plainTestNodeInitialization (CoreNodeId -> ProtocolInfo TestBlock
protocolInfo CoreNodeId
a)
                                                      ([BlockForging m TestBlock] -> m [BlockForging m TestBlock]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [BlockForging m TestBlock]
forall (m :: * -> *). Monad m => [BlockForging m TestBlock]
blockForging)
        , mkRekeyM :: Maybe (m (RekeyM m TestBlock))
mkRekeyM = Maybe (m (RekeyM m TestBlock))
forall a. Maybe a
Nothing
        }

    labelEraSizeA :: String
    labelEraSizeA :: String
labelEraSizeA =
        if Word64
sz Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
10 then String
">=10" else Word64 -> String
forall a. Show a => a -> String
show Word64
sz
      where
        EraSize Word64
sz = EraSize
eraSizeA

    protocolInfo :: CoreNodeId -> ProtocolInfo TestBlock
    protocolInfo :: CoreNodeId -> ProtocolInfo TestBlock
protocolInfo CoreNodeId
nid = ProtocolInfo {
          pInfoConfig :: TopLevelConfig TestBlock
pInfoConfig =
            CoreNodeId -> TopLevelConfig TestBlock
topLevelConfig CoreNodeId
nid
        , pInfoInitLedger :: ExtLedgerState TestBlock
pInfoInitLedger = ExtLedgerState {
              ledgerState :: LedgerState TestBlock
ledgerState = HardForkState LedgerState '[BlockA, BlockB]
-> LedgerState TestBlock
forall (xs :: [*]).
HardForkState LedgerState xs -> LedgerState (HardForkBlock xs)
HardForkLedgerState (HardForkState LedgerState '[BlockA, BlockB]
 -> LedgerState TestBlock)
-> HardForkState LedgerState '[BlockA, BlockB]
-> LedgerState TestBlock
forall a b. (a -> b) -> a -> b
$
                              LedgerState BlockA -> HardForkState LedgerState '[BlockA, BlockB]
forall (f :: * -> *) x (xs :: [*]). f x -> HardForkState f (x : xs)
initHardForkState
                                LedgerState BlockA
initLedgerState
            , headerState :: HeaderState TestBlock
headerState = ChainDepState (BlockProtocol TestBlock) -> HeaderState TestBlock
forall blk. ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState (ChainDepState (BlockProtocol TestBlock) -> HeaderState TestBlock)
-> ChainDepState (BlockProtocol TestBlock) -> HeaderState TestBlock
forall a b. (a -> b) -> a -> b
$
                              WrapChainDepState BlockA
-> HardForkState WrapChainDepState '[BlockA, BlockB]
forall (f :: * -> *) x (xs :: [*]). f x -> HardForkState f (x : xs)
initHardForkState
                                (ChainDepState (BlockProtocol BlockA) -> WrapChainDepState BlockA
forall blk.
ChainDepState (BlockProtocol blk) -> WrapChainDepState blk
WrapChainDepState ChainDepState (BlockProtocol BlockA)
ChainDepState ProtocolA
initChainDepState)
            }
        }

    blockForging :: Monad m => [BlockForging m TestBlock]
    blockForging :: forall (m :: * -> *). Monad m => [BlockForging m TestBlock]
blockForging =
      [   Text
-> NonEmptyOptNP (BlockForging m) '[BlockA, BlockB]
-> BlockForging m TestBlock
forall (m :: * -> *) (xs :: [*]).
(CanHardFork xs, Monad m) =>
Text
-> NonEmptyOptNP (BlockForging m) xs
-> BlockForging m (HardForkBlock xs)
hardForkBlockForging Text
"Test"
        (NonEmptyOptNP (BlockForging m) '[BlockA, BlockB]
 -> BlockForging m TestBlock)
-> NonEmptyOptNP (BlockForging m) '[BlockA, BlockB]
-> BlockForging m TestBlock
forall a b. (a -> b) -> a -> b
$ BlockForging m BlockA
-> OptNP 'False (BlockForging m) '[BlockB]
-> NonEmptyOptNP (BlockForging m) '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (empty1 :: Bool) (xs1 :: [k]).
f x -> OptNP empty1 f xs1 -> OptNP 'False f (x : xs1)
OptCons BlockForging m BlockA
forall (m :: * -> *). Monad m => BlockForging m BlockA
blockForgingA
        (OptNP 'False (BlockForging m) '[BlockB]
 -> NonEmptyOptNP (BlockForging m) '[BlockA, BlockB])
-> OptNP 'False (BlockForging m) '[BlockB]
-> NonEmptyOptNP (BlockForging m) '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$ BlockForging m BlockB
-> OptNP 'True (BlockForging m) '[]
-> OptNP 'False (BlockForging m) '[BlockB]
forall {k} (f :: k -> *) (x :: k) (empty1 :: Bool) (xs1 :: [k]).
f x -> OptNP empty1 f xs1 -> OptNP 'False f (x : xs1)
OptCons BlockForging m BlockB
forall (m :: * -> *). Monad m => BlockForging m BlockB
blockForgingB
        (OptNP 'True (BlockForging m) '[]
 -> OptNP 'False (BlockForging m) '[BlockB])
-> OptNP 'True (BlockForging m) '[]
-> OptNP 'False (BlockForging m) '[BlockB]
forall a b. (a -> b) -> a -> b
$ OptNP 'True (BlockForging m) '[]
forall {k} (f :: k -> *). OptNP 'True f '[]
OptNil
      ]

    initLedgerState :: LedgerState BlockA
    initLedgerState :: LedgerState BlockA
initLedgerState = LgrA {
          lgrA_tip :: Point BlockA
lgrA_tip        = Point BlockA
forall {k} (block :: k). Point block
GenesisPoint
        , lgrA_transition :: Maybe SlotNo
lgrA_transition = Maybe SlotNo
forall a. Maybe a
Nothing
        }

    initChainDepState :: ChainDepState ProtocolA
    initChainDepState :: ChainDepState ProtocolA
initChainDepState = ()

    topLevelConfig :: CoreNodeId -> TopLevelConfig TestBlock
    topLevelConfig :: CoreNodeId -> TopLevelConfig TestBlock
topLevelConfig CoreNodeId
nid = TopLevelConfig {
          topLevelConfigProtocol :: ConsensusConfig (BlockProtocol TestBlock)
topLevelConfigProtocol = HardForkConsensusConfig {
              hardForkConsensusConfigK :: SecurityParam
hardForkConsensusConfigK      = SecurityParam
k
            , hardForkConsensusConfigShape :: Shape '[BlockA, BlockB]
hardForkConsensusConfigShape  = Shape '[BlockA, BlockB]
shape
            , hardForkConsensusConfigPerEra :: PerEraConsensusConfig '[BlockA, BlockB]
hardForkConsensusConfigPerEra = NP WrapPartialConsensusConfig '[BlockA, BlockB]
-> PerEraConsensusConfig '[BlockA, BlockB]
forall (xs :: [*]).
NP WrapPartialConsensusConfig xs -> PerEraConsensusConfig xs
PerEraConsensusConfig (NP WrapPartialConsensusConfig '[BlockA, BlockB]
 -> PerEraConsensusConfig '[BlockA, BlockB])
-> NP WrapPartialConsensusConfig '[BlockA, BlockB]
-> PerEraConsensusConfig '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$
                   (PartialConsensusConfig (BlockProtocol BlockA)
-> WrapPartialConsensusConfig BlockA
forall blk.
PartialConsensusConfig (BlockProtocol blk)
-> WrapPartialConsensusConfig blk
WrapPartialConsensusConfig (PartialConsensusConfig (BlockProtocol BlockA)
 -> WrapPartialConsensusConfig BlockA)
-> PartialConsensusConfig (BlockProtocol BlockA)
-> WrapPartialConsensusConfig BlockA
forall a b. (a -> b) -> a -> b
$ CoreNodeId -> ConsensusConfig ProtocolA
consensusConfigA CoreNodeId
nid)
                WrapPartialConsensusConfig BlockA
-> NP WrapPartialConsensusConfig '[BlockB]
-> NP WrapPartialConsensusConfig '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* (PartialConsensusConfig (BlockProtocol BlockB)
-> WrapPartialConsensusConfig BlockB
forall blk.
PartialConsensusConfig (BlockProtocol blk)
-> WrapPartialConsensusConfig blk
WrapPartialConsensusConfig (PartialConsensusConfig (BlockProtocol BlockB)
 -> WrapPartialConsensusConfig BlockB)
-> PartialConsensusConfig (BlockProtocol BlockB)
-> WrapPartialConsensusConfig BlockB
forall a b. (a -> b) -> a -> b
$ CoreNodeId -> ConsensusConfig ProtocolB
consensusConfigB CoreNodeId
nid)
                WrapPartialConsensusConfig BlockB
-> NP WrapPartialConsensusConfig '[]
-> NP WrapPartialConsensusConfig '[BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP WrapPartialConsensusConfig '[]
forall {k} (f :: k -> *). NP f '[]
Nil
            }
        , topLevelConfigLedger :: LedgerConfig TestBlock
topLevelConfigLedger = HardForkLedgerConfig {
              hardForkLedgerConfigShape :: Shape '[BlockA, BlockB]
hardForkLedgerConfigShape  = Shape '[BlockA, BlockB]
shape
            , hardForkLedgerConfigPerEra :: PerEraLedgerConfig '[BlockA, BlockB]
hardForkLedgerConfigPerEra = NP WrapPartialLedgerConfig '[BlockA, BlockB]
-> PerEraLedgerConfig '[BlockA, BlockB]
forall (xs :: [*]).
NP WrapPartialLedgerConfig xs -> PerEraLedgerConfig xs
PerEraLedgerConfig (NP WrapPartialLedgerConfig '[BlockA, BlockB]
 -> PerEraLedgerConfig '[BlockA, BlockB])
-> NP WrapPartialLedgerConfig '[BlockA, BlockB]
-> PerEraLedgerConfig '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$
                   (PartialLedgerConfig BlockA -> WrapPartialLedgerConfig BlockA
forall blk. PartialLedgerConfig blk -> WrapPartialLedgerConfig blk
WrapPartialLedgerConfig (PartialLedgerConfig BlockA -> WrapPartialLedgerConfig BlockA)
-> PartialLedgerConfig BlockA -> WrapPartialLedgerConfig BlockA
forall a b. (a -> b) -> a -> b
$ CoreNodeId -> PartialLedgerConfig BlockA
ledgerConfigA CoreNodeId
nid)
                WrapPartialLedgerConfig BlockA
-> NP WrapPartialLedgerConfig '[BlockB]
-> NP WrapPartialLedgerConfig '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* (PartialLedgerConfig BlockB -> WrapPartialLedgerConfig BlockB
forall blk. PartialLedgerConfig blk -> WrapPartialLedgerConfig blk
WrapPartialLedgerConfig (PartialLedgerConfig BlockB -> WrapPartialLedgerConfig BlockB)
-> PartialLedgerConfig BlockB -> WrapPartialLedgerConfig BlockB
forall a b. (a -> b) -> a -> b
$ CoreNodeId -> LedgerConfig BlockB
ledgerConfigB CoreNodeId
nid)
                WrapPartialLedgerConfig BlockB
-> NP WrapPartialLedgerConfig '[]
-> NP WrapPartialLedgerConfig '[BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP WrapPartialLedgerConfig '[]
forall {k} (f :: k -> *). NP f '[]
Nil
            }
        , topLevelConfigBlock :: BlockConfig TestBlock
topLevelConfigBlock = HardForkBlockConfig {
              hardForkBlockConfigPerEra :: PerEraBlockConfig '[BlockA, BlockB]
hardForkBlockConfigPerEra = NP BlockConfig '[BlockA, BlockB]
-> PerEraBlockConfig '[BlockA, BlockB]
forall (xs :: [*]). NP BlockConfig xs -> PerEraBlockConfig xs
PerEraBlockConfig (NP BlockConfig '[BlockA, BlockB]
 -> PerEraBlockConfig '[BlockA, BlockB])
-> NP BlockConfig '[BlockA, BlockB]
-> PerEraBlockConfig '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$
                   CoreNodeId -> BlockConfig BlockA
blockConfigA CoreNodeId
nid
                BlockConfig BlockA
-> NP BlockConfig '[BlockB] -> NP BlockConfig '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* CoreNodeId -> BlockConfig BlockB
blockConfigB CoreNodeId
nid
                BlockConfig BlockB
-> NP BlockConfig '[] -> NP BlockConfig '[BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP BlockConfig '[]
forall {k} (f :: k -> *). NP f '[]
Nil
            }
        , topLevelConfigCodec :: CodecConfig TestBlock
topLevelConfigCodec = HardForkCodecConfig {
              hardForkCodecConfigPerEra :: PerEraCodecConfig '[BlockA, BlockB]
hardForkCodecConfigPerEra = NP CodecConfig '[BlockA, BlockB]
-> PerEraCodecConfig '[BlockA, BlockB]
forall (xs :: [*]). NP CodecConfig xs -> PerEraCodecConfig xs
PerEraCodecConfig (NP CodecConfig '[BlockA, BlockB]
 -> PerEraCodecConfig '[BlockA, BlockB])
-> NP CodecConfig '[BlockA, BlockB]
-> PerEraCodecConfig '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$
                   CodecConfig BlockA
CCfgA
                CodecConfig BlockA
-> NP CodecConfig '[BlockB] -> NP CodecConfig '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* CodecConfig BlockB
CCfgB
                CodecConfig BlockB
-> NP CodecConfig '[] -> NP CodecConfig '[BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP CodecConfig '[]
forall {k} (f :: k -> *). NP f '[]
Nil
            }
        , topLevelConfigStorage :: StorageConfig TestBlock
topLevelConfigStorage = HardForkStorageConfig {
              hardForkStorageConfigPerEra :: PerEraStorageConfig '[BlockA, BlockB]
hardForkStorageConfigPerEra = NP StorageConfig '[BlockA, BlockB]
-> PerEraStorageConfig '[BlockA, BlockB]
forall (xs :: [*]). NP StorageConfig xs -> PerEraStorageConfig xs
PerEraStorageConfig (NP StorageConfig '[BlockA, BlockB]
 -> PerEraStorageConfig '[BlockA, BlockB])
-> NP StorageConfig '[BlockA, BlockB]
-> PerEraStorageConfig '[BlockA, BlockB]
forall a b. (a -> b) -> a -> b
$
                   StorageConfig BlockA
SCfgA
                StorageConfig BlockA
-> NP StorageConfig '[BlockB] -> NP StorageConfig '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* StorageConfig BlockB
SCfgB
                StorageConfig BlockB
-> NP StorageConfig '[] -> NP StorageConfig '[BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP StorageConfig '[]
forall {k} (f :: k -> *). NP f '[]
Nil
            }
        , topLevelConfigCheckpoints :: CheckpointsMap TestBlock
topLevelConfigCheckpoints = CheckpointsMap TestBlock
forall blk. CheckpointsMap blk
emptyCheckpointsMap
        }

    consensusConfigA :: CoreNodeId -> ConsensusConfig ProtocolA
    consensusConfigA :: CoreNodeId -> ConsensusConfig ProtocolA
consensusConfigA CoreNodeId
nid = CfgA {
          cfgA_k :: SecurityParam
cfgA_k           = SecurityParam
k
        , cfgA_leadInSlots :: Set SlotNo
cfgA_leadInSlots = CoreNodeId -> LeaderSchedule -> Set SlotNo
leaderScheduleFor CoreNodeId
nid LeaderSchedule
leaderSchedule
        }

    consensusConfigB :: CoreNodeId -> ConsensusConfig ProtocolB
    consensusConfigB :: CoreNodeId -> ConsensusConfig ProtocolB
consensusConfigB CoreNodeId
nid = CfgB {
          cfgB_k :: SecurityParam
cfgB_k           = SecurityParam
k
        , cfgB_leadInSlots :: Set SlotNo
cfgB_leadInSlots = CoreNodeId -> LeaderSchedule -> Set SlotNo
leaderScheduleFor CoreNodeId
nid LeaderSchedule
leaderSchedule
        }

    ledgerConfigA :: CoreNodeId -> PartialLedgerConfig BlockA
    ledgerConfigA :: CoreNodeId -> PartialLedgerConfig BlockA
ledgerConfigA CoreNodeId
_nid = LCfgA {
          lcfgA_k :: SecurityParam
lcfgA_k           = SecurityParam
k
        , lcfgA_systemStart :: SystemStart
lcfgA_systemStart = UTCTime -> SystemStart
SystemStart UTCTime
dawnOfTime -- required for RunNode
        , lcfgA_forgeTxs :: Map SlotNo [GenTx BlockA]
lcfgA_forgeTxs    = [(SlotNo, [GenTx BlockA])] -> Map SlotNo [GenTx BlockA]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [
              (SlotNo
testSetupTxSlot, [TxId (GenTx BlockA) -> TxPayloadA -> GenTx BlockA
TxA (Int -> TxId (GenTx BlockA)
TxIdA Int
0) TxPayloadA
InitiateAtoB])
            ]
        }

    ledgerConfigB :: CoreNodeId -> LedgerConfig BlockB
    ledgerConfigB :: CoreNodeId -> LedgerConfig BlockB
ledgerConfigB CoreNodeId
_nid = ()

    blockConfigA :: CoreNodeId -> BlockConfig BlockA
    blockConfigA :: CoreNodeId -> BlockConfig BlockA
blockConfigA CoreNodeId
_ = BlockConfig BlockA
BCfgA

    blockConfigB :: CoreNodeId -> BlockConfig BlockB
    blockConfigB :: CoreNodeId -> BlockConfig BlockB
blockConfigB CoreNodeId
_ = BlockConfig BlockB
BCfgB

    testOutput :: TestOutput TestBlock
    testOutput :: TestOutput TestBlock
testOutput = TestConfig
-> TestConfigB TestBlock
-> (forall (m :: * -> *). IOLike m => TestConfigMB m TestBlock)
-> TestOutput TestBlock
forall blk.
(RunNode blk, TxGen blk, TracingConstraints blk, HasCallStack) =>
TestConfig
-> TestConfigB blk
-> (forall (m :: * -> *). IOLike m => TestConfigMB m blk)
-> TestOutput blk
runTestNetwork TestConfig
testConfig TestConfigB TestBlock
testConfigB TestConfigMB m TestBlock
forall (m :: * -> *). Monad m => TestConfigMB m TestBlock
forall (m :: * -> *). IOLike m => TestConfigMB m TestBlock
testConfigMB

    prop_allExpectedBlocks :: Property
    prop_allExpectedBlocks :: Property
prop_allExpectedBlocks =
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
            ( String
"some final chain does not have " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
              Word64 -> String
forall a. Show a => a -> String
show Word64
a String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" blocks from A and " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
              Word64 -> String
forall a. Show a => a -> String
show Word64
b String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" blocks from B"
            ) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([(NodeId, (Word64, Word64))] -> String
forall a. Show a => a -> String
show ([(NodeId, (Word64, Word64))] -> String)
-> [(NodeId, (Word64, Word64))] -> String
forall a b. (a -> b) -> a -> b
$ Map NodeId (Word64, Word64) -> [(NodeId, (Word64, Word64))]
forall k a. Map k a -> [(k, a)]
Map.toList Map NodeId (Word64, Word64)
counts) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ ((Word64, Word64) -> Bool) -> Map NodeId (Word64, Word64) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Word64, Word64) -> (Word64, Word64) -> Bool
forall a. Eq a => a -> a -> Bool
== (Word64
a, Word64
b)) Map NodeId (Word64, Word64)
counts
      where
        TestConfig{NumCoreNodes
NumSlots
NodeTopology
Seed
initSeed :: TestConfig -> Seed
nodeTopology :: TestConfig -> NodeTopology
numCoreNodes :: TestConfig -> NumCoreNodes
numSlots :: TestConfig -> NumSlots
initSeed :: Seed
nodeTopology :: NodeTopology
numCoreNodes :: NumCoreNodes
numSlots :: NumSlots
..} = TestConfig
testConfig
        NumSlots Word64
t     = NumSlots
numSlots

        -- we expect one epoch from B and the rest from A
        b :: Word64
b = EpochSize -> Word64
unEpochSize (AB EpochSize -> EpochSize
forall a. AB a -> a
getB AB EpochSize
testSetupEpochSize)
        a :: Word64
a = Word64
t Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
b

    -- counts of A blocks and of B blocks for each final chain
    counts :: Map.Map NodeId (Word64, Word64)
    counts :: Map NodeId (Word64, Word64)
counts =
        (\NodeOutput TestBlock
c -> ((TestBlock -> Bool) -> NodeOutput TestBlock -> Word64
forall a. (a -> Bool) -> NodeOutput a -> Word64
chainLen TestBlock -> Bool
isA NodeOutput TestBlock
c, (TestBlock -> Bool) -> NodeOutput TestBlock -> Word64
forall a. (a -> Bool) -> NodeOutput a -> Word64
chainLen TestBlock -> Bool
isB NodeOutput TestBlock
c)) (NodeOutput TestBlock -> (Word64, Word64))
-> Map NodeId (NodeOutput TestBlock) -> Map NodeId (Word64, Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map NodeId (NodeOutput TestBlock)
testOutputNodes
      where
        TestOutput{Map SlotNo (Map NodeId (WithOrigin BlockNo))
Map NodeId (NodeOutput TestBlock)
testOutputNodes :: Map NodeId (NodeOutput TestBlock)
testOutputTipBlockNos :: Map SlotNo (Map NodeId (WithOrigin BlockNo))
testOutputNodes :: forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
testOutputTipBlockNos :: forall blk.
TestOutput blk -> Map SlotNo (Map NodeId (WithOrigin BlockNo))
..} = TestOutput TestBlock
testOutput

        isA, isB :: TestBlock -> Bool
        isA :: TestBlock -> Bool
isA (HardForkBlock (OneEraBlock NS I '[BlockA, BlockB]
blk)) = NS I '[BlockA, BlockB] -> Int
forall {k} (f :: k -> *) (xs :: [k]). NS f xs -> Int
index_NS NS I '[BlockA, BlockB]
blk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        isB :: TestBlock -> Bool
isB (HardForkBlock (OneEraBlock NS I '[BlockA, BlockB]
blk)) = NS I '[BlockA, BlockB] -> Int
forall {k} (f :: k -> *) (xs :: [k]). NS f xs -> Int
index_NS NS I '[BlockA, BlockB]
blk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1

        chainLen :: (a -> Bool) -> NodeOutput a -> Word64
        chainLen :: forall a. (a -> Bool) -> NodeOutput a -> Word64
chainLen a -> Bool
p NodeOutput{[LedgerUpdate a]
[TracePipeliningEvent a]
Map SlotNo a
Map SlotNo [(RealPoint a, BlockNo)]
Map SlotNo [CannotForge a]
Map SlotNo (Set (RealPoint a, BlockNo))
Map (RealPoint a) [ExtValidationError a]
LedgerState a
Chain a
NodeDBs MockFS
nodeOutputAdds :: Map SlotNo (Set (RealPoint a, BlockNo))
nodeOutputCannotForges :: Map SlotNo [CannotForge a]
nodeOutputFinalChain :: Chain a
nodeOutputFinalLedger :: LedgerState a
nodeOutputForges :: Map SlotNo a
nodeOutputHeaderAdds :: Map SlotNo [(RealPoint a, BlockNo)]
nodeOutputInvalids :: Map (RealPoint a) [ExtValidationError a]
nodeOutputNodeDBs :: NodeDBs MockFS
nodeOutputSelects :: Map SlotNo [(RealPoint a, BlockNo)]
nodeOutputUpdates :: [LedgerUpdate a]
nodePipeliningEvents :: [TracePipeliningEvent a]
nodeOutputAdds :: forall blk.
NodeOutput blk -> Map SlotNo (Set (RealPoint blk, BlockNo))
nodeOutputCannotForges :: forall blk. NodeOutput blk -> Map SlotNo [CannotForge blk]
nodeOutputFinalChain :: forall blk. NodeOutput blk -> Chain blk
nodeOutputFinalLedger :: forall blk. NodeOutput blk -> LedgerState blk
nodeOutputForges :: forall blk. NodeOutput blk -> Map SlotNo blk
nodeOutputHeaderAdds :: forall blk. NodeOutput blk -> Map SlotNo [(RealPoint blk, BlockNo)]
nodeOutputInvalids :: forall blk.
NodeOutput blk -> Map (RealPoint blk) [ExtValidationError blk]
nodeOutputNodeDBs :: forall blk. NodeOutput blk -> NodeDBs MockFS
nodeOutputSelects :: forall blk. NodeOutput blk -> Map SlotNo [(RealPoint blk, BlockNo)]
nodeOutputUpdates :: forall blk. NodeOutput blk -> [LedgerUpdate blk]
nodePipeliningEvents :: forall blk. NodeOutput blk -> [TracePipeliningEvent blk]
..} =
              Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
            (Int -> Word64) -> ([a] -> Int) -> [a] -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
            ([a] -> Int) -> ([a] -> [a]) -> [a] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
p
            ([a] -> Word64) -> [a] -> Word64
forall a b. (a -> b) -> a -> b
$ Chain a -> [a]
forall block. Chain block -> [block]
Mock.chainToList Chain a
nodeOutputFinalChain

-- We ignore the mempool for these tests
instance TxGen TestBlock where
  testGenTxs :: CoreNodeId
-> NumCoreNodes
-> SlotNo
-> TopLevelConfig TestBlock
-> TxGenExtra TestBlock
-> LedgerState TestBlock
-> Gen [GenTx TestBlock]
testGenTxs CoreNodeId
_ NumCoreNodes
_ SlotNo
_ TopLevelConfig TestBlock
_ TxGenExtra TestBlock
_ LedgerState TestBlock
_ = [GenTx TestBlock] -> Gen [GenTx TestBlock]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return []

{-------------------------------------------------------------------------------
  Hard fork
-------------------------------------------------------------------------------}

type TestBlock = HardForkBlock '[BlockA, BlockB]

instance CanHardFork '[BlockA, BlockB] where
  type HardForkTxMeasure '[BlockA, BlockB] = IgnoringOverflow ByteSize32

  hardForkEraTranslation :: EraTranslation '[BlockA, BlockB]
hardForkEraTranslation = EraTranslation {
        translateLedgerState :: InPairs
  (RequiringBoth WrapLedgerConfig (Translate LedgerState))
  '[BlockA, BlockB]
translateLedgerState   = RequiringBoth
  WrapLedgerConfig (Translate LedgerState) BlockA BlockB
-> InPairs
     (RequiringBoth WrapLedgerConfig (Translate LedgerState)) '[BlockB]
-> InPairs
     (RequiringBoth WrapLedgerConfig (Translate LedgerState))
     '[BlockA, BlockB]
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (zs :: [k]).
f x y -> InPairs f (y : zs) -> InPairs f (x : y : zs)
PCons RequiringBoth
  WrapLedgerConfig (Translate LedgerState) BlockA BlockB
ledgerState_AtoB   InPairs
  (RequiringBoth WrapLedgerConfig (Translate LedgerState)) '[BlockB]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
PNil
      , translateChainDepState :: InPairs
  (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
  '[BlockA, BlockB]
translateChainDepState = RequiringBoth
  WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB
-> InPairs
     (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
     '[BlockB]
-> InPairs
     (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
     '[BlockA, BlockB]
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (zs :: [k]).
f x y -> InPairs f (y : zs) -> InPairs f (x : y : zs)
PCons RequiringBoth
  WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB
chainDepState_AtoB InPairs
  (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
  '[BlockB]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
PNil
      , crossEraForecast :: InPairs
  (RequiringBoth
     WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
  '[BlockA, BlockB]
crossEraForecast       = RequiringBoth
  WrapLedgerConfig
  (CrossEraForecaster LedgerState WrapLedgerView)
  BlockA
  BlockB
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
     '[BlockB]
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
     '[BlockA, BlockB]
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (zs :: [k]).
f x y -> InPairs f (y : zs) -> InPairs f (x : y : zs)
PCons RequiringBoth
  WrapLedgerConfig
  (CrossEraForecaster LedgerState WrapLedgerView)
  BlockA
  BlockB
forecast_AtoB      InPairs
  (RequiringBoth
     WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
  '[BlockB]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
PNil
      }
  hardForkChainSel :: Tails AcrossEraSelection '[BlockA, BlockB]
hardForkChainSel  = AcrossEraSelection BlockA BlockB
-> Tails AcrossEraSelection '[BlockA, BlockB]
forall {k} (f :: k -> k -> *) (x :: k) (y :: k).
f x y -> Tails f '[x, y]
Tails.mk2 AcrossEraSelection BlockA BlockB
forall a b. AcrossEraSelection a b
CompareBlockNo
  hardForkInjectTxs :: InPairs
  (RequiringBoth
     WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
  '[BlockA, BlockB]
hardForkInjectTxs = RequiringBoth
  WrapLedgerConfig
  (Product2 InjectTx InjectValidatedTx)
  BlockA
  BlockB
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
     '[BlockA, BlockB]
forall {k} (f :: k -> k -> *) (x :: k) (y :: k).
f x y -> InPairs f '[x, y]
InPairs.mk2 RequiringBoth
  WrapLedgerConfig
  (Product2 InjectTx InjectValidatedTx)
  BlockA
  BlockB
injectTx_AtoB

  hardForkInjTxMeasure :: NS WrapTxMeasure '[BlockA, BlockB]
-> HardForkTxMeasure '[BlockA, BlockB]
hardForkInjTxMeasure = \case
    (  Z (WrapTxMeasure TxMeasure x
x)) -> TxMeasure x
HardForkTxMeasure '[BlockA, BlockB]
x
    S (Z (WrapTxMeasure TxMeasure x
x)) -> TxMeasure x
HardForkTxMeasure '[BlockA, BlockB]
x

versionN2N :: BlockNodeToNodeVersion TestBlock
versionN2N :: BlockNodeToNodeVersion TestBlock
versionN2N =
    HardForkSpecificNodeToNodeVersion
-> NP WrapNodeToNodeVersion '[BlockA, BlockB]
-> HardForkNodeToNodeVersion '[BlockA, BlockB]
forall (xs :: [*]).
HardForkSpecificNodeToNodeVersion
-> NP WrapNodeToNodeVersion xs -> HardForkNodeToNodeVersion xs
HardForkNodeToNodeEnabled
      HardForkSpecificNodeToNodeVersion
forall a. Bounded a => a
maxBound
      (  BlockNodeToNodeVersion BlockA -> WrapNodeToNodeVersion BlockA
forall blk. BlockNodeToNodeVersion blk -> WrapNodeToNodeVersion blk
WrapNodeToNodeVersion ()
      WrapNodeToNodeVersion BlockA
-> NP WrapNodeToNodeVersion '[BlockB]
-> NP WrapNodeToNodeVersion '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* BlockNodeToNodeVersion BlockB -> WrapNodeToNodeVersion BlockB
forall blk. BlockNodeToNodeVersion blk -> WrapNodeToNodeVersion blk
WrapNodeToNodeVersion ()
      WrapNodeToNodeVersion BlockB
-> NP WrapNodeToNodeVersion '[]
-> NP WrapNodeToNodeVersion '[BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP WrapNodeToNodeVersion '[]
forall {k} (f :: k -> *). NP f '[]
Nil
      )

versionN2C :: BlockNodeToClientVersion TestBlock
versionN2C :: BlockNodeToClientVersion TestBlock
versionN2C =
    HardForkSpecificNodeToClientVersion
-> NP EraNodeToClientVersion '[BlockA, BlockB]
-> HardForkNodeToClientVersion '[BlockA, BlockB]
forall (xs :: [*]).
HardForkSpecificNodeToClientVersion
-> NP EraNodeToClientVersion xs -> HardForkNodeToClientVersion xs
HardForkNodeToClientEnabled
      HardForkSpecificNodeToClientVersion
forall a. Bounded a => a
maxBound
      (  BlockNodeToClientVersion BlockA -> EraNodeToClientVersion BlockA
forall blk.
BlockNodeToClientVersion blk -> EraNodeToClientVersion blk
EraNodeToClientEnabled ()
      EraNodeToClientVersion BlockA
-> NP EraNodeToClientVersion '[BlockB]
-> NP EraNodeToClientVersion '[BlockA, BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* BlockNodeToClientVersion BlockB -> EraNodeToClientVersion BlockB
forall blk.
BlockNodeToClientVersion blk -> EraNodeToClientVersion blk
EraNodeToClientEnabled ()
      EraNodeToClientVersion BlockB
-> NP EraNodeToClientVersion '[]
-> NP EraNodeToClientVersion '[BlockB]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP EraNodeToClientVersion '[]
forall {k} (f :: k -> *). NP f '[]
Nil
      )

instance SupportedNetworkProtocolVersion TestBlock where
  supportedNodeToNodeVersions :: Proxy TestBlock
-> Map NodeToNodeVersion (BlockNodeToNodeVersion TestBlock)
supportedNodeToNodeVersions   Proxy TestBlock
_ = NodeToNodeVersion
-> HardForkNodeToNodeVersion '[BlockA, BlockB]
-> Map
     NodeToNodeVersion (HardForkNodeToNodeVersion '[BlockA, BlockB])
forall k a. k -> a -> Map k a
Map.singleton NodeToNodeVersion
forall a. Bounded a => a
maxBound BlockNodeToNodeVersion TestBlock
HardForkNodeToNodeVersion '[BlockA, BlockB]
versionN2N
  supportedNodeToClientVersions :: Proxy TestBlock
-> Map NodeToClientVersion (BlockNodeToClientVersion TestBlock)
supportedNodeToClientVersions Proxy TestBlock
_ = NodeToClientVersion
-> HardForkNodeToClientVersion '[BlockA, BlockB]
-> Map
     NodeToClientVersion (HardForkNodeToClientVersion '[BlockA, BlockB])
forall k a. k -> a -> Map k a
Map.singleton NodeToClientVersion
forall a. Bounded a => a
maxBound BlockNodeToClientVersion TestBlock
HardForkNodeToClientVersion '[BlockA, BlockB]
versionN2C

  latestReleasedNodeVersion :: Proxy TestBlock
-> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
latestReleasedNodeVersion = Proxy TestBlock
-> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> (Maybe NodeToNodeVersion, Maybe NodeToClientVersion)
latestReleasedNodeVersionDefault

instance SerialiseHFC '[BlockA, BlockB]
  -- Use defaults

{-------------------------------------------------------------------------------
  Translation
-------------------------------------------------------------------------------}

ledgerState_AtoB ::
     RequiringBoth
       WrapLedgerConfig
       (Translate LedgerState)
       BlockA
       BlockB
ledgerState_AtoB :: RequiringBoth
  WrapLedgerConfig (Translate LedgerState) BlockA BlockB
ledgerState_AtoB = Translate LedgerState BlockA BlockB
-> RequiringBoth
     WrapLedgerConfig (Translate LedgerState) BlockA BlockB
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (h :: k -> *).
f x y -> RequiringBoth h f x y
InPairs.ignoringBoth (Translate LedgerState BlockA BlockB
 -> RequiringBoth
      WrapLedgerConfig (Translate LedgerState) BlockA BlockB)
-> Translate LedgerState BlockA BlockB
-> RequiringBoth
     WrapLedgerConfig (Translate LedgerState) BlockA BlockB
forall a b. (a -> b) -> a -> b
$ (EpochNo -> LedgerState BlockA -> LedgerState BlockB)
-> Translate LedgerState BlockA BlockB
forall (f :: * -> *) x y.
(EpochNo -> f x -> f y) -> Translate f x y
Translate ((EpochNo -> LedgerState BlockA -> LedgerState BlockB)
 -> Translate LedgerState BlockA BlockB)
-> (EpochNo -> LedgerState BlockA -> LedgerState BlockB)
-> Translate LedgerState BlockA BlockB
forall a b. (a -> b) -> a -> b
$ \EpochNo
_ LgrA{Maybe SlotNo
Point BlockA
lgrA_tip :: LedgerState BlockA -> Point BlockA
lgrA_transition :: LedgerState BlockA -> Maybe SlotNo
lgrA_tip :: Point BlockA
lgrA_transition :: Maybe SlotNo
..} -> LgrB {
      lgrB_tip :: Point BlockB
lgrB_tip = Point BlockA -> Point BlockB
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point BlockA
lgrA_tip
    }

chainDepState_AtoB ::
     RequiringBoth
       WrapConsensusConfig
       (Translate WrapChainDepState)
       BlockA
       BlockB
chainDepState_AtoB :: RequiringBoth
  WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB
chainDepState_AtoB = Translate WrapChainDepState BlockA BlockB
-> RequiringBoth
     WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (h :: k -> *).
f x y -> RequiringBoth h f x y
InPairs.ignoringBoth (Translate WrapChainDepState BlockA BlockB
 -> RequiringBoth
      WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB)
-> Translate WrapChainDepState BlockA BlockB
-> RequiringBoth
     WrapConsensusConfig (Translate WrapChainDepState) BlockA BlockB
forall a b. (a -> b) -> a -> b
$ (EpochNo -> WrapChainDepState BlockA -> WrapChainDepState BlockB)
-> Translate WrapChainDepState BlockA BlockB
forall (f :: * -> *) x y.
(EpochNo -> f x -> f y) -> Translate f x y
Translate ((EpochNo -> WrapChainDepState BlockA -> WrapChainDepState BlockB)
 -> Translate WrapChainDepState BlockA BlockB)
-> (EpochNo
    -> WrapChainDepState BlockA -> WrapChainDepState BlockB)
-> Translate WrapChainDepState BlockA BlockB
forall a b. (a -> b) -> a -> b
$ \EpochNo
_ WrapChainDepState BlockA
_ ->
    ChainDepState (BlockProtocol BlockB) -> WrapChainDepState BlockB
forall blk.
ChainDepState (BlockProtocol blk) -> WrapChainDepState blk
WrapChainDepState ()

forecast_AtoB ::
      RequiringBoth
        WrapLedgerConfig
        (CrossEraForecaster LedgerState WrapLedgerView)
        BlockA
        BlockB
forecast_AtoB :: RequiringBoth
  WrapLedgerConfig
  (CrossEraForecaster LedgerState WrapLedgerView)
  BlockA
  BlockB
forecast_AtoB = CrossEraForecaster LedgerState WrapLedgerView BlockA BlockB
-> RequiringBoth
     WrapLedgerConfig
     (CrossEraForecaster LedgerState WrapLedgerView)
     BlockA
     BlockB
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (h :: k -> *).
f x y -> RequiringBoth h f x y
InPairs.ignoringBoth (CrossEraForecaster LedgerState WrapLedgerView BlockA BlockB
 -> RequiringBoth
      WrapLedgerConfig
      (CrossEraForecaster LedgerState WrapLedgerView)
      BlockA
      BlockB)
-> CrossEraForecaster LedgerState WrapLedgerView BlockA BlockB
-> RequiringBoth
     WrapLedgerConfig
     (CrossEraForecaster LedgerState WrapLedgerView)
     BlockA
     BlockB
forall a b. (a -> b) -> a -> b
$ (Bound
 -> SlotNo
 -> LedgerState BlockA
 -> Except OutsideForecastRange (WrapLedgerView BlockB))
-> CrossEraForecaster LedgerState WrapLedgerView BlockA BlockB
forall (state :: * -> *) (view :: * -> *) x y.
(Bound
 -> SlotNo -> state x -> Except OutsideForecastRange (view y))
-> CrossEraForecaster state view x y
CrossEraForecaster ((Bound
  -> SlotNo
  -> LedgerState BlockA
  -> Except OutsideForecastRange (WrapLedgerView BlockB))
 -> CrossEraForecaster LedgerState WrapLedgerView BlockA BlockB)
-> (Bound
    -> SlotNo
    -> LedgerState BlockA
    -> Except OutsideForecastRange (WrapLedgerView BlockB))
-> CrossEraForecaster LedgerState WrapLedgerView BlockA BlockB
forall a b. (a -> b) -> a -> b
$ \Bound
_ SlotNo
_ LedgerState BlockA
_ -> WrapLedgerView BlockB
-> Except OutsideForecastRange (WrapLedgerView BlockB)
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (WrapLedgerView BlockB
 -> Except OutsideForecastRange (WrapLedgerView BlockB))
-> WrapLedgerView BlockB
-> Except OutsideForecastRange (WrapLedgerView BlockB)
forall a b. (a -> b) -> a -> b
$
    LedgerView (BlockProtocol BlockB) -> WrapLedgerView BlockB
forall blk. LedgerView (BlockProtocol blk) -> WrapLedgerView blk
WrapLedgerView ()

injectTx_AtoB ::
     RequiringBoth
       WrapLedgerConfig
       (Product2 InjectTx InjectValidatedTx)
       BlockA
       BlockB
injectTx_AtoB :: RequiringBoth
  WrapLedgerConfig
  (Product2 InjectTx InjectValidatedTx)
  BlockA
  BlockB
injectTx_AtoB =
    Product2 InjectTx InjectValidatedTx BlockA BlockB
-> RequiringBoth
     WrapLedgerConfig
     (Product2 InjectTx InjectValidatedTx)
     BlockA
     BlockB
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (h :: k -> *).
f x y -> RequiringBoth h f x y
InPairs.ignoringBoth (Product2 InjectTx InjectValidatedTx BlockA BlockB
 -> RequiringBoth
      WrapLedgerConfig
      (Product2 InjectTx InjectValidatedTx)
      BlockA
      BlockB)
-> Product2 InjectTx InjectValidatedTx BlockA BlockB
-> RequiringBoth
     WrapLedgerConfig
     (Product2 InjectTx InjectValidatedTx)
     BlockA
     BlockB
forall a b. (a -> b) -> a -> b
$ InjectTx BlockA BlockB
-> InjectValidatedTx BlockA BlockB
-> Product2 InjectTx InjectValidatedTx BlockA BlockB
forall (f :: * -> * -> *) (g :: * -> * -> *) x y.
f x y -> g x y -> Product2 f g x y
Pair2 InjectTx BlockA BlockB
forall blk blk'. InjectTx blk blk'
cannotInjectTx InjectValidatedTx BlockA BlockB
forall blk blk'. InjectValidatedTx blk blk'
cannotInjectValidatedTx