{-# 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           Cardano.Ledger.Crypto (Crypto (..), StandardCrypto)
import qualified Cardano.Ledger.Keys as SL
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 hiding (elements)
import           Test.Util.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
      Word64
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
      BlockNo
csvChainLength <- Word64 -> BlockNo
BlockNo (Word64 -> BlockNo) -> Gen Word64 -> Gen BlockNo
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
size)
      SlotNo
csvSlotNo      <- 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
1, Word64
size)
      VKey 'BlockIssuer c
csvIssuer      <- [VKey 'BlockIssuer c] -> Gen (VKey 'BlockIssuer c)
forall a. HasCallStack => [a] -> Gen a
elements [VKey 'BlockIssuer c]
knownIssuers
      Word64
csvIssueNo     <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
10)
      PraosChainSelectView c -> Gen (PraosChainSelectView c)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PraosChainSelectView {
          BlockNo
csvChainLength :: BlockNo
csvChainLength :: BlockNo
csvChainLength
        , SlotNo
csvSlotNo :: SlotNo
csvSlotNo :: SlotNo
csvSlotNo
        , VKey 'BlockIssuer c
csvIssuer :: VKey 'BlockIssuer c
csvIssuer :: VKey 'BlockIssuer c
csvIssuer
        , Word64
csvIssueNo :: Word64
csvIssueNo :: Word64
csvIssueNo
        , csvTieBreakVRF :: OutputVRF (VRF c)
csvTieBreakVRF = VKey 'BlockIssuer c -> SlotNo -> OutputVRF (VRF c)
mkVRFFor VKey 'BlockIssuer c
csvIssuer SlotNo
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 c]
     knownIssuers :: [VKey 'BlockIssuer c]
knownIssuers =
           (VKey 'BlockIssuer c -> KeyHash 'BlockIssuer c)
-> [VKey 'BlockIssuer c] -> [VKey 'BlockIssuer c]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn VKey 'BlockIssuer c -> KeyHash 'BlockIssuer c
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey
         ([VKey 'BlockIssuer c] -> [VKey 'BlockIssuer c])
-> [VKey 'BlockIssuer c] -> [VKey 'BlockIssuer c]
forall a b. (a -> b) -> a -> b
$ Gen [VKey 'BlockIssuer c] -> QCGen -> Int -> [VKey 'BlockIssuer c]
forall a. Gen a -> QCGen -> Int -> a
unGen (Int -> Gen (VKey 'BlockIssuer c) -> Gen [VKey 'BlockIssuer c]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numIssuers (VerKeyDSIGN (DSIGN c) -> VKey 'BlockIssuer c
forall (kd :: KeyRole) c. VerKeyDSIGN (DSIGN c) -> VKey kd c
SL.VKey (VerKeyDSIGN (DSIGN c) -> VKey 'BlockIssuer c)
-> Gen (VerKeyDSIGN (DSIGN c)) -> Gen (VKey 'BlockIssuer c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (VerKeyDSIGN (DSIGN c))
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 c -> SlotNo -> OutputVRF (VRF c)
     mkVRFFor :: VKey 'BlockIssuer c -> SlotNo -> OutputVRF (VRF c)
mkVRFFor VKey 'BlockIssuer c
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 c) SlotNo -> ByteString
forall h a. Hash h a -> ByteString
Crypto.hashToBytes
         (Hash (ADDRHASH c) SlotNo -> ByteString)
-> Hash (ADDRHASH c) SlotNo -> ByteString
forall a b. (a -> b) -> a -> b
$ Hash (ADDRHASH c) SlotNo
-> Hash (ADDRHASH c) SlotNo -> Hash (ADDRHASH c) SlotNo
forall h a. Hash h a -> Hash h a -> Hash h a
Crypto.xor (Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
-> Hash (ADDRHASH c) SlotNo
forall h a b. Hash h a -> Hash h b
Crypto.castHash Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
issuerHash)
         (Hash (ADDRHASH c) SlotNo -> Hash (ADDRHASH c) SlotNo)
-> Hash (ADDRHASH c) SlotNo -> Hash (ADDRHASH c) SlotNo
forall a b. (a -> b) -> a -> b
$ (SlotNo -> Encoding) -> SlotNo -> Hash (ADDRHASH c) 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 c) (VerKeyDSIGN (DSIGN c))
issuerHash = VKey 'BlockIssuer c -> KeyHash 'BlockIssuer c
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey VKey 'BlockIssuer c
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
          Word64
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
          SlotNo -> VRFTiebreakerFlavor
RestrictedVRFTiebreaker (SlotNo -> VRFTiebreakerFlavor)
-> (Word64 -> SlotNo) -> Word64 -> VRFTiebreakerFlavor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
SlotNo (Word64 -> VRFTiebreakerFlavor)
-> Gen Word64 -> Gen VRFTiebreakerFlavor
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
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)