{-# 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
        bno   <- Gen BlockNo
forall a. Arbitrary a => Gen a
arbitrary
        isEBB <- toIsEBB <$> arbitrary
        pure $ PBftSelectView bno 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
      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
      issuerHashes  <- nubOrd <$> replicateM numIssuers arbitrary
      hotIdentities <- concat <$> for issuerHashes \KeyHash 'BlockIssuer
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.
        numIssueNos <- [Int] -> Gen Int
forall a. HasCallStack => [a] -> Gen a
elements [Int
1, Int
2]
        issueNos    <- take numIssueNos . iterate succ <$> arbitrary
        pure $ HotIdentity issuerHash <$> issueNos
      concat <$> for bnos \BlockNo
bno -> do
        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
        pure $ ShelleyTentativeHeaderView bno <$> hotIds
    where
      -- Upper bound on the number of issuer identities
      numIssuers :: Int
numIssuers = Int
5