{-# 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 SimpleTestProtocolInfoSetup
-> (SimpleTestProtocolInfoSetup -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen SimpleTestProtocolInfoSetup
forall a. Arbitrary a => Gen a
arbitrary ((SimpleTestProtocolInfoSetup -> Property) -> Property)
-> (SimpleTestProtocolInfoSetup -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \SimpleTestProtocolInfoSetup
setup ->
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
QC.ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
      pinfo <- SimpleTestProtocolInfoSetup
-> IO (ProtocolInfo (CardanoBlock StandardCrypto))
mkSimpleTestProtocolInfoFromSetup SimpleTestProtocolInfoSetup
setup
      pure $ prop_sanityChecks (pInfoConfig pinfo)

prop_intentionallyBrokenConfigDoesNotSanityCheck :: QC.Property
prop_intentionallyBrokenConfigDoesNotSanityCheck :: Property
prop_intentionallyBrokenConfigDoesNotSanityCheck =
  Gen SimpleTestProtocolInfoSetup
-> (SimpleTestProtocolInfoSetup -> Property) -> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen SimpleTestProtocolInfoSetup
forall a. Arbitrary a => Gen a
arbitrary ((SimpleTestProtocolInfoSetup -> Property) -> Property)
-> (SimpleTestProtocolInfoSetup -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \SimpleTestProtocolInfoSetup
setup ->
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
QC.ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
      pinfo <- SimpleTestProtocolInfoSetup
-> IO (ProtocolInfo (CardanoBlock StandardCrypto))
mkSimpleTestProtocolInfoFromSetup SimpleTestProtocolInfoSetup
setup
      let saneTopLevelConfig = ProtocolInfo (CardanoBlock StandardCrypto)
-> TopLevelConfig (CardanoBlock StandardCrypto)
forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig ProtocolInfo (CardanoBlock StandardCrypto)
pinfo
          brokenConfig = TopLevelConfig (CardanoBlock StandardCrypto)
-> TopLevelConfig (CardanoBlock StandardCrypto)
breakTopLevelConfig TopLevelConfig (CardanoBlock StandardCrypto)
saneTopLevelConfig
      pure $ expectFailure $ prop_sanityChecks 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."
              }
        }

mkSimpleTestProtocolInfoFromSetup ::
  SimpleTestProtocolInfoSetup ->
  IO (ProtocolInfo (CardanoBlock StandardCrypto))
mkSimpleTestProtocolInfoFromSetup :: SimpleTestProtocolInfoSetup
-> IO (ProtocolInfo (CardanoBlock StandardCrypto))
mkSimpleTestProtocolInfoFromSetup SimpleTestProtocolInfoSetup
setup =
  DecentralizationParam
-> SecurityParam
-> ByronSlotLengthInSeconds
-> ShelleySlotLengthInSeconds
-> ProtVer
-> CardanoHardForkTriggers
-> IO (ProtocolInfo (CardanoBlock StandardCrypto))
forall c.
(CardanoHardForkConstraints c, AgentCrypto c) =>
DecentralizationParam
-> SecurityParam
-> ByronSlotLengthInSeconds
-> ShelleySlotLengthInSeconds
-> ProtVer
-> CardanoHardForkTriggers
-> IO (ProtocolInfo (CardanoBlock c))
mkSimpleTestProtocolInfo
    (SimpleTestProtocolInfoSetup -> DecentralizationParam
decentralizationParam SimpleTestProtocolInfoSetup
setup)
    (SimpleTestProtocolInfoSetup -> SecurityParam
securityParam SimpleTestProtocolInfoSetup
setup)
    (SimpleTestProtocolInfoSetup -> ByronSlotLengthInSeconds
byronSlotLength SimpleTestProtocolInfoSetup
setup)
    (SimpleTestProtocolInfoSetup -> ShelleySlotLengthInSeconds
shelleySlotLength SimpleTestProtocolInfoSetup
setup)
    ProtVer
protocolVersionZero
    (SimpleTestProtocolInfoSetup -> CardanoHardForkTriggers
hardForkTriggers SimpleTestProtocolInfoSetup
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)