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

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
      SecurityParam Word64
k = SecurityParam
hardForkConsensusConfigK
  in TopLevelConfig (CardanoBlock StandardCrypto)
tlc
    { topLevelConfigProtocol = topLevelConfigProtocol
      { hardForkConsensusConfigK = SecurityParam (succ k)
      }
    }

genSimpleTestProtocolInfo :: Gen (ProtocolInfo (CardanoBlock StandardCrypto))
genSimpleTestProtocolInfo :: Gen (ProtocolInfo (CardanoBlock StandardCrypto))
genSimpleTestProtocolInfo = do
  SimpleTestProtocolInfoSetup
setup <- Gen SimpleTestProtocolInfoSetup
forall a. Arbitrary a => Gen a
arbitrary
  ProtocolInfo (CardanoBlock StandardCrypto)
-> Gen (ProtocolInfo (CardanoBlock StandardCrypto))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProtocolInfo (CardanoBlock StandardCrypto)
 -> Gen (ProtocolInfo (CardanoBlock StandardCrypto)))
-> ProtocolInfo (CardanoBlock StandardCrypto)
-> Gen (ProtocolInfo (CardanoBlock StandardCrypto))
forall a b. (a -> b) -> a -> b
$
    DecentralizationParam
-> SecurityParam
-> ByronSlotLengthInSeconds
-> ShelleySlotLengthInSeconds
-> ProtVer
-> CardanoHardForkTriggers
-> ProtocolInfo (CardanoBlock StandardCrypto)
forall c.
(CardanoHardForkConstraints c, c ~ StandardCrypto) =>
DecentralizationParam
-> SecurityParam
-> ByronSlotLengthInSeconds
-> ShelleySlotLengthInSeconds
-> ProtVer
-> CardanoHardForkTriggers
-> 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 =
        Word64 -> SecurityParam
SecurityParam (Word64 -> SecurityParam) -> Gen 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)
      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)