{-# LANGUAGE NamedFieldPuns #-}
module Test.Consensus.Cardano.SupportsSanityCheck (tests) where

import           Cardano.Ledger.BaseTypes (nonZero, nonZeroOr, unNonZero)
import           Ouroboros.Consensus.Cardano (CardanoHardForkTriggers)
import           Ouroboros.Consensus.Cardano.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HardFork.Combinator.Basics
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
import           Test.Consensus.Cardano.ProtocolInfo
import qualified Test.QuickCheck as QC
import qualified Test.QuickCheck.Gen as Gen
import           Test.Tasty
import           Test.Tasty.QuickCheck
import qualified Test.ThreadNet.Infra.Shelley as Shelley
import           Test.Util.SanityCheck

tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"SupportsSanityCheck"
  [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"cardano block top level config passes a sanity check" Property
prop_cardanoBlockSanityChecks
  , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"intentionally-misconfigured top level config fails a sanity check" Property
prop_intentionallyBrokenConfigDoesNotSanityCheck
  ]

prop_cardanoBlockSanityChecks :: QC.Property
prop_cardanoBlockSanityChecks :: Property
prop_cardanoBlockSanityChecks =
  Gen (ProtocolInfo (CardanoBlock StandardCrypto))
-> (ProtocolInfo (CardanoBlock StandardCrypto) -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (ProtocolInfo (CardanoBlock StandardCrypto))
genSimpleTestProtocolInfo (TopLevelConfig (CardanoBlock StandardCrypto) -> Property
forall blk.
BlockSupportsSanityCheck blk =>
TopLevelConfig blk -> Property
prop_sanityChecks (TopLevelConfig (CardanoBlock StandardCrypto) -> Property)
-> (ProtocolInfo (CardanoBlock StandardCrypto)
    -> TopLevelConfig (CardanoBlock StandardCrypto))
-> ProtocolInfo (CardanoBlock StandardCrypto)
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolInfo (CardanoBlock StandardCrypto)
-> TopLevelConfig (CardanoBlock StandardCrypto)
forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig)

prop_intentionallyBrokenConfigDoesNotSanityCheck :: QC.Property
prop_intentionallyBrokenConfigDoesNotSanityCheck :: Property
prop_intentionallyBrokenConfigDoesNotSanityCheck =
  Gen (ProtocolInfo (CardanoBlock StandardCrypto))
-> (ProtocolInfo (CardanoBlock StandardCrypto) -> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (ProtocolInfo (CardanoBlock StandardCrypto))
genSimpleTestProtocolInfo ((ProtocolInfo (CardanoBlock StandardCrypto) -> Property)
 -> Property)
-> (ProtocolInfo (CardanoBlock StandardCrypto) -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \ProtocolInfo (CardanoBlock StandardCrypto)
pinfo ->
    let saneTopLevelConfig :: TopLevelConfig (CardanoBlock StandardCrypto)
saneTopLevelConfig =
          ProtocolInfo (CardanoBlock StandardCrypto)
-> TopLevelConfig (CardanoBlock StandardCrypto)
forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig ProtocolInfo (CardanoBlock StandardCrypto)
pinfo
        brokenConfig :: TopLevelConfig (CardanoBlock StandardCrypto)
brokenConfig = TopLevelConfig (CardanoBlock StandardCrypto)
-> TopLevelConfig (CardanoBlock StandardCrypto)
breakTopLevelConfig TopLevelConfig (CardanoBlock StandardCrypto)
saneTopLevelConfig
    in Property -> Property
forall prop. Testable prop => prop -> Property
expectFailure (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ TopLevelConfig (CardanoBlock StandardCrypto) -> Property
forall blk.
BlockSupportsSanityCheck blk =>
TopLevelConfig blk -> Property
prop_sanityChecks TopLevelConfig (CardanoBlock StandardCrypto)
brokenConfig

breakTopLevelConfig :: TopLevelConfig (CardanoBlock StandardCrypto) -> TopLevelConfig (CardanoBlock StandardCrypto)
breakTopLevelConfig :: TopLevelConfig (CardanoBlock StandardCrypto)
-> TopLevelConfig (CardanoBlock StandardCrypto)
breakTopLevelConfig TopLevelConfig (CardanoBlock StandardCrypto)
tlc =
  let TopLevelConfig{ConsensusConfig (BlockProtocol (CardanoBlock StandardCrypto))
topLevelConfigProtocol :: ConsensusConfig (BlockProtocol (CardanoBlock StandardCrypto))
topLevelConfigProtocol :: forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
topLevelConfigProtocol} = TopLevelConfig (CardanoBlock StandardCrypto)
tlc
      HardForkConsensusConfig{SecurityParam
hardForkConsensusConfigK :: SecurityParam
hardForkConsensusConfigK :: forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> SecurityParam
hardForkConsensusConfigK} = ConsensusConfig
  (HardForkProtocol (ByronBlock : CardanoShelleyEras StandardCrypto))
topLevelConfigProtocol
      k :: Word64
k = NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64) -> NonZero Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ SecurityParam -> NonZero Word64
maxRollbacks SecurityParam
hardForkConsensusConfigK
  in TopLevelConfig (CardanoBlock StandardCrypto)
tlc
    { topLevelConfigProtocol = topLevelConfigProtocol
      { hardForkConsensusConfigK = SecurityParam $ nonZeroOr (succ k) $ error "Impossible! In breakTopLevelConfig, found zero, expected a positive number."
      }
    }

genSimpleTestProtocolInfo :: Gen (ProtocolInfo (CardanoBlock StandardCrypto))
genSimpleTestProtocolInfo :: Gen (ProtocolInfo (CardanoBlock StandardCrypto))
genSimpleTestProtocolInfo = do
  setup <- Gen SimpleTestProtocolInfoSetup
forall a. Arbitrary a => Gen a
arbitrary
  pure $
    mkSimpleTestProtocolInfo
      (decentralizationParam setup)
      (securityParam setup)
      (byronSlotLength setup)
      (shelleySlotLength setup)
      protocolVersionZero
      (hardForkTriggers setup)

data SimpleTestProtocolInfoSetup = SimpleTestProtocolInfoSetup
  { SimpleTestProtocolInfoSetup -> DecentralizationParam
decentralizationParam :: Shelley.DecentralizationParam
  , SimpleTestProtocolInfoSetup -> SecurityParam
securityParam         :: SecurityParam
  , SimpleTestProtocolInfoSetup -> ByronSlotLengthInSeconds
byronSlotLength       :: ByronSlotLengthInSeconds
  , SimpleTestProtocolInfoSetup -> ShelleySlotLengthInSeconds
shelleySlotLength     :: ShelleySlotLengthInSeconds
  , SimpleTestProtocolInfoSetup -> CardanoHardForkTriggers
hardForkTriggers      :: CardanoHardForkTriggers
  }

instance Arbitrary SimpleTestProtocolInfoSetup where
  arbitrary :: Gen SimpleTestProtocolInfoSetup
arbitrary = do
    DecentralizationParam
-> SecurityParam
-> ByronSlotLengthInSeconds
-> ShelleySlotLengthInSeconds
-> CardanoHardForkTriggers
-> SimpleTestProtocolInfoSetup
SimpleTestProtocolInfoSetup
      (DecentralizationParam
 -> SecurityParam
 -> ByronSlotLengthInSeconds
 -> ShelleySlotLengthInSeconds
 -> CardanoHardForkTriggers
 -> SimpleTestProtocolInfoSetup)
-> Gen DecentralizationParam
-> Gen
     (SecurityParam
      -> ByronSlotLengthInSeconds
      -> ShelleySlotLengthInSeconds
      -> CardanoHardForkTriggers
      -> SimpleTestProtocolInfoSetup)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen DecentralizationParam
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (SecurityParam
   -> ByronSlotLengthInSeconds
   -> ShelleySlotLengthInSeconds
   -> CardanoHardForkTriggers
   -> SimpleTestProtocolInfoSetup)
-> Gen SecurityParam
-> Gen
     (ByronSlotLengthInSeconds
      -> ShelleySlotLengthInSeconds
      -> CardanoHardForkTriggers
      -> SimpleTestProtocolInfoSetup)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SecurityParam
genSecurityParam
      Gen
  (ByronSlotLengthInSeconds
   -> ShelleySlotLengthInSeconds
   -> CardanoHardForkTriggers
   -> SimpleTestProtocolInfoSetup)
-> Gen ByronSlotLengthInSeconds
-> Gen
     (ShelleySlotLengthInSeconds
      -> CardanoHardForkTriggers -> SimpleTestProtocolInfoSetup)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ByronSlotLengthInSeconds
genByronSlotLength
      Gen
  (ShelleySlotLengthInSeconds
   -> CardanoHardForkTriggers -> SimpleTestProtocolInfoSetup)
-> Gen ShelleySlotLengthInSeconds
-> Gen (CardanoHardForkTriggers -> SimpleTestProtocolInfoSetup)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ShelleySlotLengthInSeconds
genShelleySlotLength
      Gen (CardanoHardForkTriggers -> SimpleTestProtocolInfoSetup)
-> Gen CardanoHardForkTriggers -> Gen SimpleTestProtocolInfoSetup
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen CardanoHardForkTriggers
genHardForkTriggers
    where
      genSecurityParam :: Gen SecurityParam
genSecurityParam =
        NonZero Word64 -> SecurityParam
SecurityParam (NonZero Word64 -> SecurityParam)
-> Gen (NonZero Word64) -> Gen SecurityParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
Gen.choose (Word64
8, Word64
12) Gen Word64
-> (Word64 -> Maybe (NonZero Word64)) -> Gen (NonZero Word64)
forall a b. Gen a -> (a -> Maybe b) -> Gen b
`suchThatMap` Word64 -> Maybe (NonZero Word64)
forall a. HasZero a => a -> Maybe (NonZero a)
nonZero
      genByronSlotLength :: Gen ByronSlotLengthInSeconds
genByronSlotLength =
        Word64 -> ByronSlotLengthInSeconds
ByronSlotLengthInSeconds (Word64 -> ByronSlotLengthInSeconds)
-> Gen Word64 -> Gen ByronSlotLengthInSeconds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
Gen.choose (Word64
1, Word64
4)
      genShelleySlotLength :: Gen ShelleySlotLengthInSeconds
genShelleySlotLength =
        Word64 -> ShelleySlotLengthInSeconds
ShelleySlotLengthInSeconds (Word64 -> ShelleySlotLengthInSeconds)
-> Gen Word64 -> Gen ShelleySlotLengthInSeconds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
Gen.choose (Word64
1, Word64
4)
      genHardForkTriggers :: Gen CardanoHardForkTriggers
genHardForkTriggers =
        Era -> CardanoHardForkTriggers
hardForkInto (Era -> CardanoHardForkTriggers)
-> Gen Era -> Gen CardanoHardForkTriggers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Era, Era) -> Gen Era
forall a. Enum a => (a, a) -> Gen a
Gen.chooseEnum (Era
Byron, Era
Conway)