{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Consensus.Protocol.Praos.SelectView (tests) where

import qualified Cardano.Crypto.Hash as Crypto
import qualified Cardano.Crypto.Util as Crypto
import           Cardano.Crypto.VRF (OutputVRF, mkTestOutputVRF)
import qualified Cardano.Ledger.Keys as SL
import           Cardano.Protocol.Crypto (Crypto (..), StandardCrypto)
import           Codec.Serialise (encode)
import           Control.Monad
import           Data.Containers.ListUtils (nubOrdOn)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Protocol.Praos.Common
import           Test.Cardano.Ledger.Binary.Arbitrary ()
import           Test.Ouroboros.Consensus.Protocol
import           Test.QuickCheck.Gen (Gen (..))
import           Test.QuickCheck.Random (mkQCGen)
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.Util.TestEnv

tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"PraosChainSelectView"
    [   (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
50)
      -- Use a small max size by default in order to have a decent chance to
      -- trigger the actual tiebreaker cases.
      (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10)
      (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ Proxy (PraosChainSelectView StandardCrypto) -> TestTree
forall a.
(ChainOrder a, Typeable a, Arbitrary a, Show a,
 Arbitrary (ChainOrderConfig a), Show (ChainOrderConfig a)) =>
Proxy a -> TestTree
tests_chainOrder (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(PraosChainSelectView StandardCrypto))
    ]

instance Crypto c => Arbitrary (PraosChainSelectView c) where
  arbitrary :: Gen (PraosChainSelectView c)
arbitrary = do
      size           <- Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Gen Int -> Gen Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
getSize
      csvChainLength <- BlockNo <$> choose (1, size)
      csvSlotNo      <- SlotNo  <$> choose (1, size)
      csvIssuer      <- elements knownIssuers
      csvIssueNo     <- choose (1, 10)
      pure PraosChainSelectView {
          csvChainLength
        , csvSlotNo
        , csvIssuer
        , csvIssueNo
        , csvTieBreakVRF = mkVRFFor csvIssuer csvSlotNo
        }
   where
     -- We want to draw from the same small set of issuer identities in order to
     -- have a chance to explore cases where the issuers of two 'SelectView's
     -- are identical.
     knownIssuers :: [SL.VKey SL.BlockIssuer]
     knownIssuers :: [VKey 'BlockIssuer]
knownIssuers =
           (VKey 'BlockIssuer -> KeyHash 'BlockIssuer)
-> [VKey 'BlockIssuer] -> [VKey 'BlockIssuer]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn VKey 'BlockIssuer -> KeyHash 'BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
SL.hashKey
         ([VKey 'BlockIssuer] -> [VKey 'BlockIssuer])
-> [VKey 'BlockIssuer] -> [VKey 'BlockIssuer]
forall a b. (a -> b) -> a -> b
$ Gen [VKey 'BlockIssuer] -> QCGen -> Int -> [VKey 'BlockIssuer]
forall a. Gen a -> QCGen -> Int -> a
unGen (Int -> Gen (VKey 'BlockIssuer) -> Gen [VKey 'BlockIssuer]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numIssuers (VerKeyDSIGN DSIGN -> VKey 'BlockIssuer
forall (kd :: KeyRole). VerKeyDSIGN DSIGN -> VKey kd
SL.VKey (VerKeyDSIGN DSIGN -> VKey 'BlockIssuer)
-> Gen (VerKeyDSIGN DSIGN) -> Gen (VKey 'BlockIssuer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (VerKeyDSIGN DSIGN)
forall a. Arbitrary a => Gen a
arbitrary)) QCGen
randomSeed Int
100
       where
         randomSeed :: QCGen
randomSeed = Int -> QCGen
mkQCGen Int
4 -- chosen by fair dice roll
         numIssuers :: Int
numIssuers = Int
10

     -- The header VRF is a deterministic function of the issuer VRF key, the
     -- slot and the epoch nonce. Additionally, for any particular chain, the
     -- slot determines the epoch nonce.
     mkVRFFor :: SL.VKey SL.BlockIssuer -> SlotNo -> OutputVRF (VRF c)
     mkVRFFor :: VKey 'BlockIssuer -> SlotNo -> OutputVRF (VRF c)
mkVRFFor VKey 'BlockIssuer
issuer SlotNo
slot =
           Natural -> OutputVRF (VRF c)
forall v. VRFAlgorithm v => Natural -> OutputVRF v
mkTestOutputVRF
         (Natural -> OutputVRF (VRF c)) -> Natural -> OutputVRF (VRF c)
forall a b. (a -> b) -> a -> b
$ ByteString -> Natural
Crypto.bytesToNatural
         (ByteString -> Natural) -> ByteString -> Natural
forall a b. (a -> b) -> a -> b
$ Hash ADDRHASH SlotNo -> ByteString
forall h a. Hash h a -> ByteString
Crypto.hashToBytes
         (Hash ADDRHASH SlotNo -> ByteString)
-> Hash ADDRHASH SlotNo -> ByteString
forall a b. (a -> b) -> a -> b
$ Hash ADDRHASH SlotNo
-> Hash ADDRHASH SlotNo -> Hash ADDRHASH SlotNo
forall h a. Hash h a -> Hash h a -> Hash h a
Crypto.xor (Hash ADDRHASH (VerKeyDSIGN DSIGN) -> Hash ADDRHASH SlotNo
forall h a b. Hash h a -> Hash h b
Crypto.castHash Hash ADDRHASH (VerKeyDSIGN DSIGN)
issuerHash)
         (Hash ADDRHASH SlotNo -> Hash ADDRHASH SlotNo)
-> Hash ADDRHASH SlotNo -> Hash ADDRHASH SlotNo
forall a b. (a -> b) -> a -> b
$ (SlotNo -> Encoding) -> SlotNo -> Hash ADDRHASH SlotNo
forall h a. HashAlgorithm h => (a -> Encoding) -> a -> Hash h a
Crypto.hashWithSerialiser SlotNo -> Encoding
forall a. Serialise a => a -> Encoding
encode SlotNo
slot
       where
         SL.KeyHash Hash ADDRHASH (VerKeyDSIGN DSIGN)
issuerHash = VKey 'BlockIssuer -> KeyHash 'BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
SL.hashKey VKey 'BlockIssuer
issuer

-- | 'ChainOrderConfig' 'PraosChainSelectView'
instance Arbitrary VRFTiebreakerFlavor where
  arbitrary :: Gen VRFTiebreakerFlavor
arbitrary = [Gen VRFTiebreakerFlavor] -> Gen VRFTiebreakerFlavor
forall a. HasCallStack => [Gen a] -> Gen a
oneof
      [ VRFTiebreakerFlavor -> Gen VRFTiebreakerFlavor
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VRFTiebreakerFlavor
UnrestrictedVRFTiebreaker
      , do
          size <- Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
1 (Word64 -> Word64) -> (Int -> Word64) -> Int -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Gen Int -> Gen Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
getSize
          RestrictedVRFTiebreaker . SlotNo <$> choose (1, size)
      ]

  shrink :: VRFTiebreakerFlavor -> [VRFTiebreakerFlavor]
shrink = \case
      VRFTiebreakerFlavor
UnrestrictedVRFTiebreaker       -> []
      RestrictedVRFTiebreaker SlotNo
maxDist ->
          VRFTiebreakerFlavor
UnrestrictedVRFTiebreaker
        VRFTiebreakerFlavor
-> [VRFTiebreakerFlavor] -> [VRFTiebreakerFlavor]
forall a. a -> [a] -> [a]
: (SlotNo -> VRFTiebreakerFlavor
RestrictedVRFTiebreaker (SlotNo -> VRFTiebreakerFlavor)
-> [SlotNo] -> [VRFTiebreakerFlavor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo -> [SlotNo]
forall a. Arbitrary a => a -> [a]
shrink SlotNo
maxDist)