{-# 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