module Test.Ouroboros.Storage.LedgerDB.SnapshotPolicySanityCheck (tests) where

import Cardano.Ledger.BaseTypes (unsafeNonZero)
import Data.Time.Clock (DiffTime, secondsToDiffTime)
import Data.Word (Word64)
import Ouroboros.Consensus.Block.SupportsSanityCheck
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import Ouroboros.Consensus.Util.Args (OverrideOrDefault (..))
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck (testProperty)

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"SnapshotPolicySanityCheck"
    [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"SnapshotNumZero fires iff spaNum overridden to 0" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
        Property
prop_num_zero_iff
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty
        TestName
"SnapshotDelayRangeInverted fires iff minimumDelay > maximumDelay (given minimumDelay >= 0)"
        (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ Property
prop_delay_range_inverted_iff
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"SnapshotDelayRangeNegativeMinimum fires iff minimumDelay < 0" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
        Property
prop_delay_range_negative_minimum_iff
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"SnapshotRateLimitDisabled fires iff sfaRateLimit overridden to <= 0" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
        Property
prop_rate_limit_disabled_iff
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty
        TestName
"SnapshotRateLimitSuspiciouslyLarge fires iff sfaRateLimit overridden to > 86400s (given > 0)"
        (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ Property
prop_rate_limit_large_iff
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"SnapshotIntervalNotDivisorOfEpoch fires iff 432000 mod interval /= 0" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
        Property
prop_mithril_divisibility_iff
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"no frequency issues emitted under DisableSnapshots" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
        Property
prop_disable_snapshots_no_frequency_issues
    ]

-------------------------------------------------------------------------------
-- Properties
-------------------------------------------------------------------------------

-- | 'SnapshotNumZero' fires if and only if 'spaNum' is overridden to 0.
-- Uses 'DisableSnapshots' so that no other checks interfere.
prop_num_zero_iff :: Property
prop_num_zero_iff :: Property
prop_num_zero_iff =
  Gen Word -> (Word -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen Word
forall a. Arbitrary a => Gen a
arbitrary :: Gen Word) ((Word -> Property) -> Property) -> (Word -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Word
n ->
    let issues :: [SanityCheckIssue]
issues =
          SnapshotPolicyArgs -> [SanityCheckIssue]
sanityCheckSnapshotPolicyArgs
            SnapshotPolicyArgs{spaFrequency :: SnapshotFrequency
spaFrequency = SnapshotFrequency
DisableSnapshots, spaNum :: OverrideOrDefault NumOfDiskSnapshots
spaNum = NumOfDiskSnapshots -> OverrideOrDefault NumOfDiskSnapshots
forall a. a -> OverrideOrDefault a
Override (Word -> NumOfDiskSnapshots
NumOfDiskSnapshots Word
n)}
     in (SanityCheckIssue
SnapshotNumZero SanityCheckIssue -> [SanityCheckIssue] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SanityCheckIssue]
issues) Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (Word
n Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0)

-- | 'SnapshotDelayRangeInverted' fires if and only if @minimumDelay > maximumDelay@,
-- when @minimumDelay >= 0@ (avoiding the 'SnapshotDelayRangeNegativeMinimum' case).
prop_delay_range_inverted_iff :: Property
prop_delay_range_inverted_iff :: Property
prop_delay_range_inverted_iff =
  Gen DiffTime -> (DiffTime -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen DiffTime
genNonNegativeDiffTime ((DiffTime -> Property) -> Property)
-> (DiffTime -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \DiffTime
mn ->
    Gen DiffTime -> (DiffTime -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen DiffTime
genDiffTime ((DiffTime -> Property) -> Property)
-> (DiffTime -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \DiffTime
mx ->
      let issues :: [SanityCheckIssue]
issues = SnapshotPolicyArgs -> [SanityCheckIssue]
sanityCheckSnapshotPolicyArgs (SnapshotDelayRange -> SnapshotPolicyArgs
withDelayRange (DiffTime -> DiffTime -> SnapshotDelayRange
SnapshotDelayRange DiffTime
mn DiffTime
mx))
          fired :: Bool
fired = (SanityCheckIssue -> Bool) -> [SanityCheckIssue] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SanityCheckIssue -> Bool
isInverted [SanityCheckIssue]
issues
       in Bool
fired Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (DiffTime
mn DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
mx)
 where
  isInverted :: SanityCheckIssue -> Bool
isInverted (SnapshotDelayRangeInverted DiffTime
_ DiffTime
_) = Bool
True
  isInverted SanityCheckIssue
_ = Bool
False

-- | 'SnapshotDelayRangeNegativeMinimum' fires if and only if @minimumDelay < 0@.
prop_delay_range_negative_minimum_iff :: Property
prop_delay_range_negative_minimum_iff :: Property
prop_delay_range_negative_minimum_iff =
  Gen DiffTime -> (DiffTime -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen DiffTime
genDiffTime ((DiffTime -> Property) -> Property)
-> (DiffTime -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \DiffTime
mn ->
    let issues :: [SanityCheckIssue]
issues = SnapshotPolicyArgs -> [SanityCheckIssue]
sanityCheckSnapshotPolicyArgs (SnapshotDelayRange -> SnapshotPolicyArgs
withDelayRange (DiffTime -> DiffTime -> SnapshotDelayRange
SnapshotDelayRange DiffTime
mn DiffTime
0))
        fired :: Bool
fired = (SanityCheckIssue -> Bool) -> [SanityCheckIssue] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SanityCheckIssue -> Bool
isNegativeMin [SanityCheckIssue]
issues
     in Bool
fired Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (DiffTime
mn DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< DiffTime
0)
 where
  isNegativeMin :: SanityCheckIssue -> Bool
isNegativeMin (SnapshotDelayRangeNegativeMinimum DiffTime
_) = Bool
True
  isNegativeMin SanityCheckIssue
_ = Bool
False

-- | 'SnapshotRateLimitDisabled' fires if and only if 'sfaRateLimit' is overridden
-- to a non-positive value.
prop_rate_limit_disabled_iff :: Property
prop_rate_limit_disabled_iff :: Property
prop_rate_limit_disabled_iff =
  Gen DiffTime -> (DiffTime -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen DiffTime
genDiffTime ((DiffTime -> Property) -> Property)
-> (DiffTime -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \DiffTime
rl ->
    let issues :: [SanityCheckIssue]
issues = SnapshotPolicyArgs -> [SanityCheckIssue]
sanityCheckSnapshotPolicyArgs (DiffTime -> SnapshotPolicyArgs
withRateLimit DiffTime
rl)
     in (SanityCheckIssue
SnapshotRateLimitDisabled SanityCheckIssue -> [SanityCheckIssue] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SanityCheckIssue]
issues) Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (DiffTime
rl DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= DiffTime
0)

-- | 'SnapshotRateLimitSuspiciouslyLarge' fires if and only if 'sfaRateLimit' is
-- overridden to a value greater than 86400s. We restrict to positive rate limits
-- to avoid the 'SnapshotRateLimitDisabled' check interfering.
prop_rate_limit_large_iff :: Property
prop_rate_limit_large_iff :: Property
prop_rate_limit_large_iff =
  Gen DiffTime -> (DiffTime -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen DiffTime
genPositiveDiffTime ((DiffTime -> Property) -> Property)
-> (DiffTime -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \DiffTime
rl ->
    let issues :: [SanityCheckIssue]
issues = SnapshotPolicyArgs -> [SanityCheckIssue]
sanityCheckSnapshotPolicyArgs (DiffTime -> SnapshotPolicyArgs
withRateLimit DiffTime
rl)
        fired :: Bool
fired = (SanityCheckIssue -> Bool) -> [SanityCheckIssue] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SanityCheckIssue -> Bool
isLarge [SanityCheckIssue]
issues
     in Bool
fired Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (DiffTime
rl DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
86400)
 where
  isLarge :: SanityCheckIssue -> Bool
isLarge (SnapshotRateLimitSuspiciouslyLarge DiffTime
_) = Bool
True
  isLarge SanityCheckIssue
_ = Bool
False

-- | 'SnapshotIntervalNotDivisorOfEpoch' fires if and only if
-- @'mithrilEpochSize' \`mod\` interval /= 0@.
prop_mithril_divisibility_iff :: Property
prop_mithril_divisibility_iff :: Property
prop_mithril_divisibility_iff =
  Gen Word64 -> (Word64 -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Word64
genNonZeroWord64 ((Word64 -> Property) -> Property)
-> (Word64 -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Word64
n ->
    let issues :: [SanityCheckIssue]
issues = SnapshotPolicyArgs -> [SanityCheckIssue]
sanityCheckSnapshotPolicyArgs (Word64 -> SnapshotPolicyArgs
withInterval Word64
n)
        fired :: Bool
fired = (SanityCheckIssue -> Bool) -> [SanityCheckIssue] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SanityCheckIssue -> Bool
isMithrilIssue [SanityCheckIssue]
issues
     in Bool
fired Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (Word64
mithrilEpochSize Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
n Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0)
 where
  isMithrilIssue :: SanityCheckIssue -> Bool
isMithrilIssue (SnapshotIntervalNotDivisorOfEpoch Word64
_) = Bool
True
  isMithrilIssue SanityCheckIssue
_ = Bool
False

-- | With 'DisableSnapshots', no frequency-related issues are ever emitted,
-- regardless of what 'spaNum' is set to.
prop_disable_snapshots_no_frequency_issues :: Property
prop_disable_snapshots_no_frequency_issues :: Property
prop_disable_snapshots_no_frequency_issues =
  Gen Word -> (Word -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen Word
forall a. Arbitrary a => Gen a
arbitrary :: Gen Word) ((Word -> Property) -> Property) -> (Word -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Word
n ->
    let issues :: [SanityCheckIssue]
issues =
          SnapshotPolicyArgs -> [SanityCheckIssue]
sanityCheckSnapshotPolicyArgs
            SnapshotPolicyArgs{spaFrequency :: SnapshotFrequency
spaFrequency = SnapshotFrequency
DisableSnapshots, spaNum :: OverrideOrDefault NumOfDiskSnapshots
spaNum = NumOfDiskSnapshots -> OverrideOrDefault NumOfDiskSnapshots
forall a. a -> OverrideOrDefault a
Override (Word -> NumOfDiskSnapshots
NumOfDiskSnapshots Word
n)}
     in (SanityCheckIssue -> Bool)
-> [SanityCheckIssue] -> [SanityCheckIssue]
forall a. (a -> Bool) -> [a] -> [a]
filter SanityCheckIssue -> Bool
isFrequencyIssue [SanityCheckIssue]
issues [SanityCheckIssue] -> [SanityCheckIssue] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== []
 where
  -- SnapshotNumZero is the only non-frequency issue that can appear here;
  -- everything else would require a SnapshotFrequency.
  isFrequencyIssue :: SanityCheckIssue -> Bool
isFrequencyIssue SanityCheckIssue
SnapshotNumZero = Bool
False
  isFrequencyIssue InconsistentSecurityParam{} = Bool
False
  isFrequencyIssue SanityCheckIssue
_ = Bool
True

-------------------------------------------------------------------------------
-- Generators
-------------------------------------------------------------------------------

-- | Generate an arbitrary 'DiffTime' (integer seconds, possibly negative).
genDiffTime :: Gen DiffTime
genDiffTime :: Gen DiffTime
genDiffTime = Integer -> DiffTime
secondsToDiffTime (Integer -> DiffTime) -> Gen Integer -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. Arbitrary a => Gen a
arbitrary

-- | Generate a non-negative 'DiffTime'.
genNonNegativeDiffTime :: Gen DiffTime
genNonNegativeDiffTime :: Gen DiffTime
genNonNegativeDiffTime = Integer -> DiffTime
secondsToDiffTime (Integer -> DiffTime)
-> (Integer -> Integer) -> Integer -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
forall a. Num a => a -> a
abs (Integer -> DiffTime) -> Gen Integer -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. Arbitrary a => Gen a
arbitrary

-- | Generate a strictly positive 'DiffTime'.
genPositiveDiffTime :: Gen DiffTime
genPositiveDiffTime :: Gen DiffTime
genPositiveDiffTime = Integer -> DiffTime
secondsToDiffTime (Integer -> DiffTime)
-> (Positive Integer -> Integer) -> Positive Integer -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive Integer -> Integer
forall a. Positive a -> a
getPositive (Positive Integer -> DiffTime)
-> Gen (Positive Integer) -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive Integer)
forall a. Arbitrary a => Gen a
arbitrary

-- | Generate a non-zero 'Word64'.
genNonZeroWord64 :: Gen Word64
genNonZeroWord64 :: Gen Word64
genNonZeroWord64 = Positive Word64 -> Word64
forall a. Positive a -> a
getPositive (Positive Word64 -> Word64) -> Gen (Positive Word64) -> Gen Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive Word64)
forall a. Arbitrary a => Gen a
arbitrary

-------------------------------------------------------------------------------
-- Helpers
-------------------------------------------------------------------------------

-- | Build a 'SnapshotPolicyArgs' with a specific 'SnapshotDelayRange' override.
withDelayRange :: SnapshotDelayRange -> SnapshotPolicyArgs
withDelayRange :: SnapshotDelayRange -> SnapshotPolicyArgs
withDelayRange SnapshotDelayRange
sdr =
  SnapshotPolicyArgs
    { spaFrequency :: SnapshotFrequency
spaFrequency =
        SnapshotFrequencyArgs -> SnapshotFrequency
SnapshotFrequency
          SnapshotFrequencyArgs
            { sfaInterval :: OverrideOrDefault (NonZero Word64)
sfaInterval = OverrideOrDefault (NonZero Word64)
forall a. OverrideOrDefault a
UseDefault
            , sfaOffset :: OverrideOrDefault SlotNo
sfaOffset = OverrideOrDefault SlotNo
forall a. OverrideOrDefault a
UseDefault
            , sfaRateLimit :: OverrideOrDefault DiffTime
sfaRateLimit = OverrideOrDefault DiffTime
forall a. OverrideOrDefault a
UseDefault
            , sfaDelaySnapshotRange :: OverrideOrDefault SnapshotDelayRange
sfaDelaySnapshotRange = SnapshotDelayRange -> OverrideOrDefault SnapshotDelayRange
forall a. a -> OverrideOrDefault a
Override SnapshotDelayRange
sdr
            }
    , spaNum :: OverrideOrDefault NumOfDiskSnapshots
spaNum = OverrideOrDefault NumOfDiskSnapshots
forall a. OverrideOrDefault a
UseDefault
    }

-- | Build a 'SnapshotPolicyArgs' with a specific 'sfaRateLimit' override.
withRateLimit :: DiffTime -> SnapshotPolicyArgs
withRateLimit :: DiffTime -> SnapshotPolicyArgs
withRateLimit DiffTime
rl =
  SnapshotPolicyArgs
    { spaFrequency :: SnapshotFrequency
spaFrequency =
        SnapshotFrequencyArgs -> SnapshotFrequency
SnapshotFrequency
          SnapshotFrequencyArgs
            { sfaInterval :: OverrideOrDefault (NonZero Word64)
sfaInterval = OverrideOrDefault (NonZero Word64)
forall a. OverrideOrDefault a
UseDefault
            , sfaOffset :: OverrideOrDefault SlotNo
sfaOffset = OverrideOrDefault SlotNo
forall a. OverrideOrDefault a
UseDefault
            , sfaRateLimit :: OverrideOrDefault DiffTime
sfaRateLimit = DiffTime -> OverrideOrDefault DiffTime
forall a. a -> OverrideOrDefault a
Override DiffTime
rl
            , sfaDelaySnapshotRange :: OverrideOrDefault SnapshotDelayRange
sfaDelaySnapshotRange = OverrideOrDefault SnapshotDelayRange
forall a. OverrideOrDefault a
UseDefault
            }
    , spaNum :: OverrideOrDefault NumOfDiskSnapshots
spaNum = OverrideOrDefault NumOfDiskSnapshots
forall a. OverrideOrDefault a
UseDefault
    }

-- | Build a 'SnapshotPolicyArgs' with a specific 'sfaInterval' override.
withInterval :: Word64 -> SnapshotPolicyArgs
withInterval :: Word64 -> SnapshotPolicyArgs
withInterval Word64
n =
  SnapshotPolicyArgs
    { spaFrequency :: SnapshotFrequency
spaFrequency =
        SnapshotFrequencyArgs -> SnapshotFrequency
SnapshotFrequency
          SnapshotFrequencyArgs
            { sfaInterval :: OverrideOrDefault (NonZero Word64)
sfaInterval = NonZero Word64 -> OverrideOrDefault (NonZero Word64)
forall a. a -> OverrideOrDefault a
Override (Word64 -> NonZero Word64
forall a. a -> NonZero a
unsafeNonZero Word64
n)
            , sfaOffset :: OverrideOrDefault SlotNo
sfaOffset = OverrideOrDefault SlotNo
forall a. OverrideOrDefault a
UseDefault
            , sfaRateLimit :: OverrideOrDefault DiffTime
sfaRateLimit = OverrideOrDefault DiffTime
forall a. OverrideOrDefault a
UseDefault
            , sfaDelaySnapshotRange :: OverrideOrDefault SnapshotDelayRange
sfaDelaySnapshotRange = OverrideOrDefault SnapshotDelayRange
forall a. OverrideOrDefault a
UseDefault
            }
    , spaNum :: OverrideOrDefault NumOfDiskSnapshots
spaNum = OverrideOrDefault NumOfDiskSnapshots
forall a. OverrideOrDefault a
UseDefault
    }