{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Consensus.Cardano.DiffusionPipelining (tests) where

import           Control.Monad (replicateM)
import           Data.Containers.ListUtils (nubOrd)
import           Data.List (sort)
import           Data.Proxy
import           Data.SOP.BasicFunctors
import           Data.SOP.Constraint
import           Data.SOP.Strict
import           Data.Traversable (for)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Byron.Ledger (ByronBlock)
import           Ouroboros.Consensus.Cardano (CardanoBlock)
import           Ouroboros.Consensus.HardFork.Combinator
import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import           Ouroboros.Consensus.Protocol.PBFT
import           Ouroboros.Consensus.Shelley.Eras
import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock,
                     ShelleyCompatible)
import           Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
import           Ouroboros.Consensus.Shelley.Node.DiffusionPipelining
import           Ouroboros.Consensus.TypeFamilyWrappers
import           Test.Cardano.Ledger.Binary.Arbitrary ()
import           Test.Cardano.Ledger.Core.Arbitrary ()
import           Test.Ouroboros.Consensus.DiffusionPipelining
import           Test.Tasty
import           Test.Tasty.QuickCheck

tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"Cardano diffusion pipelining"
    [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"subsequence consistency" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
        Property
prop_cardanoDiffusionPipeliningSubsequenceConsistency
    ]

prop_cardanoDiffusionPipeliningSubsequenceConsistency :: Property
prop_cardanoDiffusionPipeliningSubsequenceConsistency :: Property
prop_cardanoDiffusionPipeliningSubsequenceConsistency =
    Gen
  [OneEraTentativeHeaderView
     (ByronBlock : CardanoShelleyEras StandardCrypto)]
-> ([OneEraTentativeHeaderView
       (ByronBlock : CardanoShelleyEras StandardCrypto)]
    -> [[OneEraTentativeHeaderView
           (ByronBlock : CardanoShelleyEras StandardCrypto)]])
-> ([OneEraTentativeHeaderView
       (ByronBlock : CardanoShelleyEras StandardCrypto)]
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink
      (Proxy (CardanoBlock StandardCrypto)
-> Gen [TentativeHeaderView (CardanoBlock StandardCrypto)]
forall blk.
GenTentativeHeaderViews blk =>
Proxy blk -> Gen [TentativeHeaderView blk]
genTentativeHeaderViews Proxy (CardanoBlock StandardCrypto)
p)
      [OneEraTentativeHeaderView
   (ByronBlock : CardanoShelleyEras StandardCrypto)]
-> [[OneEraTentativeHeaderView
       (ByronBlock : CardanoShelleyEras StandardCrypto)]]
forall {a}. [a] -> [[a]]
shrinkThvs
      (Proxy (CardanoBlock StandardCrypto)
-> [TentativeHeaderView (CardanoBlock StandardCrypto)] -> Property
forall blk.
BlockSupportsDiffusionPipelining blk =>
Proxy blk -> [TentativeHeaderView blk] -> Property
prop_diffusionPipeliningSubsequenceConsistency Proxy (CardanoBlock StandardCrypto)
p)
  where
    p :: Proxy (CardanoBlock StandardCrypto)
p = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(CardanoBlock StandardCrypto)

    shrinkThvs :: [a] -> [[a]]
shrinkThvs = (a -> [a]) -> [a] -> [[a]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([a] -> a -> [a]
forall a b. a -> b -> a
const [])

class GenTentativeHeaderViews blk where
  genTentativeHeaderViews :: Proxy blk -> Gen [TentativeHeaderView blk]

instance All GenTentativeHeaderViews xs => GenTentativeHeaderViews (HardForkBlock xs) where
  genTentativeHeaderViews :: Proxy (HardForkBlock xs)
-> Gen [TentativeHeaderView (HardForkBlock xs)]
genTentativeHeaderViews Proxy (HardForkBlock xs)
_ =
          (NS WrapTentativeHeaderView xs -> OneEraTentativeHeaderView xs)
-> [NS WrapTentativeHeaderView xs]
-> [OneEraTentativeHeaderView xs]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NS WrapTentativeHeaderView xs -> OneEraTentativeHeaderView xs
forall (xs :: [*]).
NS WrapTentativeHeaderView xs -> OneEraTentativeHeaderView xs
OneEraTentativeHeaderView
       ([NS WrapTentativeHeaderView xs] -> [OneEraTentativeHeaderView xs])
-> (NP ([] :.: WrapTentativeHeaderView) xs
    -> [NS WrapTentativeHeaderView xs])
-> NP ([] :.: WrapTentativeHeaderView) xs
-> [OneEraTentativeHeaderView xs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (NS ([] :.: WrapTentativeHeaderView) xs
 -> [NS WrapTentativeHeaderView xs])
-> [NS ([] :.: WrapTentativeHeaderView) xs]
-> [NS WrapTentativeHeaderView xs]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NS ([] :.: WrapTentativeHeaderView) xs
-> [NS WrapTentativeHeaderView xs]
forall (xs :: [*]) (f :: * -> *) (g :: * -> *).
(SListIN NS xs, Applicative f) =>
NS (f :.: g) xs -> f (NS g xs)
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *)
       (g :: k -> *).
(HSequence h, SListIN h xs, Applicative f) =>
h (f :.: g) xs -> f (h g xs)
hsequence'
       ([NS ([] :.: WrapTentativeHeaderView) xs]
 -> [NS WrapTentativeHeaderView xs])
-> (NP ([] :.: WrapTentativeHeaderView) xs
    -> [NS ([] :.: WrapTentativeHeaderView) xs])
-> NP ([] :.: WrapTentativeHeaderView) xs
-> [NS WrapTentativeHeaderView xs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  NP (K (NS ([] :.: WrapTentativeHeaderView) xs)) xs
-> [NS ([] :.: WrapTentativeHeaderView) xs]
NP (K (NS ([] :.: WrapTentativeHeaderView) xs)) xs
-> CollapseTo NP (NS ([] :.: WrapTentativeHeaderView) xs)
forall (xs :: [*]) a.
SListIN NP xs =>
NP (K a) xs -> CollapseTo NP a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NP (K (NS ([] :.: WrapTentativeHeaderView) xs)) xs
 -> [NS ([] :.: WrapTentativeHeaderView) xs])
-> (NP ([] :.: WrapTentativeHeaderView) xs
    -> NP (K (NS ([] :.: WrapTentativeHeaderView) xs)) xs)
-> NP ([] :.: WrapTentativeHeaderView) xs
-> [NS ([] :.: WrapTentativeHeaderView) xs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prod
  NP
  (([] :.: WrapTentativeHeaderView)
   -.-> K (NS ([] :.: WrapTentativeHeaderView) xs))
  xs
-> NP ([] :.: WrapTentativeHeaderView) xs
-> NP (K (NS ([] :.: WrapTentativeHeaderView) xs)) xs
forall k l (h :: (k -> *) -> l -> *) (f :: k -> *) (g :: k -> *)
       (xs :: l).
HAp h =>
Prod h (f -.-> g) xs -> h f xs -> h g xs
forall (f :: * -> *) (g :: * -> *) (xs :: [*]).
Prod NP (f -.-> g) xs -> NP f xs -> NP g xs
hap Prod
  NP
  (([] :.: WrapTentativeHeaderView)
   -.-> K (NS ([] :.: WrapTentativeHeaderView) xs))
  xs
NP
  (([] :.: WrapTentativeHeaderView)
   -.-> K (NS ([] :.: WrapTentativeHeaderView) xs))
  xs
forall {k} (xs :: [k]) (f :: k -> *).
SListI xs =>
NP (Injection f xs) xs
injections
      (NP ([] :.: WrapTentativeHeaderView) xs
 -> [OneEraTentativeHeaderView xs])
-> Gen (NP ([] :.: WrapTentativeHeaderView) xs)
-> Gen [OneEraTentativeHeaderView xs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (NP ([] :.: WrapTentativeHeaderView) xs)
gen
    where
      gen :: Gen (NP ([] :.: WrapTentativeHeaderView) xs)
      gen :: Gen (NP ([] :.: WrapTentativeHeaderView) xs)
gen = Proxy GenTentativeHeaderViews
-> (forall a.
    GenTentativeHeaderViews a =>
    Proxy a -> Gen ((:.:) [] WrapTentativeHeaderView a))
-> NP Proxy xs
-> Gen (NP ([] :.: WrapTentativeHeaderView) xs)
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (g :: * -> *) (proxy :: (k -> Constraint) -> *)
       (f :: k -> *) (f' :: k -> *).
(HSequence h, AllN h c xs, Applicative g) =>
proxy c
-> (forall (a :: k). c a => f a -> g (f' a))
-> h f xs
-> g (h f' xs)
forall (c :: * -> Constraint) (xs :: [*]) (g :: * -> *)
       (proxy :: (* -> Constraint) -> *) (f :: * -> *) (f' :: * -> *).
(AllN NP c xs, Applicative g) =>
proxy c
-> (forall a. c a => f a -> g (f' a)) -> NP f xs -> g (NP f' xs)
hctraverse' (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @GenTentativeHeaderViews)
        (\Proxy a
p -> [WrapTentativeHeaderView a] -> (:.:) [] WrapTentativeHeaderView a
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp ([WrapTentativeHeaderView a] -> (:.:) [] WrapTentativeHeaderView a)
-> ([TentativeHeaderView a] -> [WrapTentativeHeaderView a])
-> [TentativeHeaderView a]
-> (:.:) [] WrapTentativeHeaderView a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TentativeHeaderView a -> WrapTentativeHeaderView a)
-> [TentativeHeaderView a] -> [WrapTentativeHeaderView a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TentativeHeaderView a -> WrapTentativeHeaderView a
forall blk. TentativeHeaderView blk -> WrapTentativeHeaderView blk
WrapTentativeHeaderView ([TentativeHeaderView a] -> (:.:) [] WrapTentativeHeaderView a)
-> Gen [TentativeHeaderView a]
-> Gen ((:.:) [] WrapTentativeHeaderView a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> Gen [TentativeHeaderView a]
forall blk.
GenTentativeHeaderViews blk =>
Proxy blk -> Gen [TentativeHeaderView blk]
genTentativeHeaderViews Proxy a
p)
        ((forall t. Proxy t) -> NP Proxy xs
forall (xs :: [*]) (f :: * -> *).
SListIN NP xs =>
(forall a. f a) -> NP f xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *).
(HPure h, SListIN h xs) =>
(forall (a :: k). f a) -> h f xs
hpure Proxy a
forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy)

instance GenTentativeHeaderViews ByronBlock where
  genTentativeHeaderViews :: Proxy ByronBlock -> Gen [TentativeHeaderView ByronBlock]
genTentativeHeaderViews Proxy ByronBlock
_ =
      [PBftSelectView] -> [PBftSelectView]
forall a. Ord a => [a] -> [a]
nubOrd ([PBftSelectView] -> [PBftSelectView])
-> ([PBftSelectView] -> [PBftSelectView])
-> [PBftSelectView]
-> [PBftSelectView]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PBftSelectView] -> [PBftSelectView]
forall a. Ord a => [a] -> [a]
sort ([PBftSelectView] -> [PBftSelectView])
-> Gen [PBftSelectView] -> Gen [PBftSelectView]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen PBftSelectView -> Gen [PBftSelectView]
forall a. Gen a -> Gen [a]
listOf do
        BlockNo
bno   <- Gen BlockNo
forall a. Arbitrary a => Gen a
arbitrary
        IsEBB
isEBB <- Bool -> IsEBB
toIsEBB (Bool -> IsEBB) -> Gen Bool -> Gen IsEBB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
        PBftSelectView -> Gen PBftSelectView
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PBftSelectView -> Gen PBftSelectView)
-> PBftSelectView -> Gen PBftSelectView
forall a b. (a -> b) -> a -> b
$ BlockNo -> IsEBB -> PBftSelectView
PBftSelectView BlockNo
bno IsEBB
isEBB

instance ShelleyCompatible proto era => GenTentativeHeaderViews (ShelleyBlock proto era) where
  genTentativeHeaderViews :: Proxy (ShelleyBlock proto era)
-> Gen [TentativeHeaderView (ShelleyBlock proto era)]
genTentativeHeaderViews Proxy (ShelleyBlock proto era)
_ = do
      [BlockNo]
bnos          <- [BlockNo] -> [BlockNo]
forall a. Ord a => [a] -> [a]
nubOrd ([BlockNo] -> [BlockNo]) -> Gen [BlockNo] -> Gen [BlockNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [BlockNo]
forall a. (Ord a, Arbitrary a) => Gen [a]
orderedList
      [KeyHash 'BlockIssuer (ProtoCrypto proto)]
issuerHashes  <- [KeyHash 'BlockIssuer (ProtoCrypto proto)]
-> [KeyHash 'BlockIssuer (ProtoCrypto proto)]
forall a. Ord a => [a] -> [a]
nubOrd ([KeyHash 'BlockIssuer (ProtoCrypto proto)]
 -> [KeyHash 'BlockIssuer (ProtoCrypto proto)])
-> Gen [KeyHash 'BlockIssuer (ProtoCrypto proto)]
-> Gen [KeyHash 'BlockIssuer (ProtoCrypto proto)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Gen (KeyHash 'BlockIssuer (ProtoCrypto proto))
-> Gen [KeyHash 'BlockIssuer (ProtoCrypto proto)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numIssuers Gen (KeyHash 'BlockIssuer (ProtoCrypto proto))
forall a. Arbitrary a => Gen a
arbitrary
      [HotIdentity (ProtoCrypto proto)]
hotIdentities <- [[HotIdentity (ProtoCrypto proto)]]
-> [HotIdentity (ProtoCrypto proto)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[HotIdentity (ProtoCrypto proto)]]
 -> [HotIdentity (ProtoCrypto proto)])
-> Gen [[HotIdentity (ProtoCrypto proto)]]
-> Gen [HotIdentity (ProtoCrypto proto)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyHash 'BlockIssuer (ProtoCrypto proto)]
-> (KeyHash 'BlockIssuer (ProtoCrypto proto)
    -> Gen [HotIdentity (ProtoCrypto proto)])
-> Gen [[HotIdentity (ProtoCrypto proto)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [KeyHash 'BlockIssuer (ProtoCrypto proto)]
issuerHashes \KeyHash 'BlockIssuer (ProtoCrypto proto)
issuerHash -> do
        -- Due to the constraints placed by the OCERT rule on how the issue
        -- number can evolve, the number of issue numbers per block number and
        -- issuer (cold) identity is bounded. Note that we don't actually
        -- enforce those exact constraints here across different block numbers
        -- as their details are not relevant for this test.
        Int
numIssueNos <- [Int] -> Gen Int
forall a. HasCallStack => [a] -> Gen a
elements [Int
1, Int
2]
        [Word64]
issueNos    <- Int -> [Word64] -> [Word64]
forall a. Int -> [a] -> [a]
take Int
numIssueNos ([Word64] -> [Word64])
-> (Word64 -> [Word64]) -> Word64 -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Word64) -> Word64 -> [Word64]
forall a. (a -> a) -> a -> [a]
iterate Word64 -> Word64
forall a. Enum a => a -> a
succ (Word64 -> [Word64]) -> Gen Word64 -> Gen [Word64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
arbitrary
        [HotIdentity (ProtoCrypto proto)]
-> Gen [HotIdentity (ProtoCrypto proto)]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([HotIdentity (ProtoCrypto proto)]
 -> Gen [HotIdentity (ProtoCrypto proto)])
-> [HotIdentity (ProtoCrypto proto)]
-> Gen [HotIdentity (ProtoCrypto proto)]
forall a b. (a -> b) -> a -> b
$ KeyHash 'BlockIssuer (ProtoCrypto proto)
-> Word64 -> HotIdentity (ProtoCrypto proto)
forall c. KeyHash 'BlockIssuer c -> Word64 -> HotIdentity c
HotIdentity KeyHash 'BlockIssuer (ProtoCrypto proto)
issuerHash (Word64 -> HotIdentity (ProtoCrypto proto))
-> [Word64] -> [HotIdentity (ProtoCrypto proto)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word64]
issueNos
      [[ShelleyTentativeHeaderView proto]]
-> [ShelleyTentativeHeaderView proto]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ShelleyTentativeHeaderView proto]]
 -> [ShelleyTentativeHeaderView proto])
-> Gen [[ShelleyTentativeHeaderView proto]]
-> Gen [ShelleyTentativeHeaderView proto]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockNo]
-> (BlockNo -> Gen [ShelleyTentativeHeaderView proto])
-> Gen [[ShelleyTentativeHeaderView proto]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [BlockNo]
bnos \BlockNo
bno -> do
        [HotIdentity (ProtoCrypto proto)]
hotIds <- [HotIdentity (ProtoCrypto proto)]
-> Gen [HotIdentity (ProtoCrypto proto)]
forall a. [a] -> Gen [a]
shuffle ([HotIdentity (ProtoCrypto proto)]
 -> Gen [HotIdentity (ProtoCrypto proto)])
-> Gen [HotIdentity (ProtoCrypto proto)]
-> Gen [HotIdentity (ProtoCrypto proto)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [HotIdentity (ProtoCrypto proto)]
-> Gen [HotIdentity (ProtoCrypto proto)]
forall a. [a] -> Gen [a]
sublistOf [HotIdentity (ProtoCrypto proto)]
hotIdentities
        [ShelleyTentativeHeaderView proto]
-> Gen [ShelleyTentativeHeaderView proto]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ShelleyTentativeHeaderView proto]
 -> Gen [ShelleyTentativeHeaderView proto])
-> [ShelleyTentativeHeaderView proto]
-> Gen [ShelleyTentativeHeaderView proto]
forall a b. (a -> b) -> a -> b
$ BlockNo
-> HotIdentity (ProtoCrypto proto)
-> ShelleyTentativeHeaderView proto
forall proto.
BlockNo
-> HotIdentity (ProtoCrypto proto)
-> ShelleyTentativeHeaderView proto
ShelleyTentativeHeaderView BlockNo
bno (HotIdentity (ProtoCrypto proto)
 -> ShelleyTentativeHeaderView proto)
-> [HotIdentity (ProtoCrypto proto)]
-> [ShelleyTentativeHeaderView proto]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HotIdentity (ProtoCrypto proto)]
hotIds
    where
      -- Upper bound on the number of issuer identities
      numIssuers :: Int
numIssuers = Int
5