{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE TypeApplications #-}

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

import Cardano.Ledger.BaseTypes (unNonZero)
import Cardano.Ledger.BaseTypes.NonZero (nonZero)
import Data.Time.Clock
  ( DiffTime
  , diffTimeToPicoseconds
  , picosecondsToDiffTime
  , secondsToDiffTime
  )
import Data.Word
import Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..))
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"SnapshotPolicy"
    [ TestName -> [TestTree] -> TestTree
testGroup
        TestName
"defaultSnapshotPolicy"
        [ TestName -> (TestSetup -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"onDiskNumSnapshots" TestSetup -> Property
prop_onDiskNumSnapshots
        , TestName -> (TestSetup -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"onDiskShouldTakeSnapshot" TestSetup -> Property
prop_onDiskShouldTakeSnapshot
        ]
    ]

{-------------------------------------------------------------------------------
  Test inputs
-------------------------------------------------------------------------------}

-- | This contains sufficient inputs for each property in this module.
data TestSetup = TestSetup
  { TestSetup -> Word64
tsBlocksSince :: Word64
  -- ^ argument to 'onDiskShouldTakeSnapshot'
  , TestSetup -> SecurityParam
tsK :: SecurityParam
  -- ^ argument to 'defaultSnapshotPolicy'
  , TestSetup -> SnapshotInterval
tsSnapshotInterval :: SnapshotInterval
  -- ^ argument to 'defaultSnapshotPolicy'
  , TestSetup -> Maybe DiffTime
tsTimeSince :: Maybe DiffTime
  -- ^ argument to 'onDiskShouldTakeSnapshot'
  }
  deriving Int -> TestSetup -> ShowS
[TestSetup] -> ShowS
TestSetup -> TestName
(Int -> TestSetup -> ShowS)
-> (TestSetup -> TestName)
-> ([TestSetup] -> ShowS)
-> Show TestSetup
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestSetup -> ShowS
showsPrec :: Int -> TestSetup -> ShowS
$cshow :: TestSetup -> TestName
show :: TestSetup -> TestName
$cshowList :: [TestSetup] -> ShowS
showList :: [TestSetup] -> ShowS
Show

-- | The represented default 'SnapshotPolicy'
toSnapshotPolicy :: TestSetup -> SnapshotPolicy
toSnapshotPolicy :: TestSetup -> SnapshotPolicy
toSnapshotPolicy TestSetup
ts = SecurityParam -> SnapshotPolicyArgs -> SnapshotPolicy
defaultSnapshotPolicy (TestSetup -> SecurityParam
tsK TestSetup
ts) SnapshotPolicyArgs
snapshotPolicyArgs
 where
  snapshotPolicyArgs :: SnapshotPolicyArgs
snapshotPolicyArgs =
    SnapshotInterval -> NumOfDiskSnapshots -> SnapshotPolicyArgs
SnapshotPolicyArgs (TestSetup -> SnapshotInterval
tsSnapshotInterval TestSetup
ts) NumOfDiskSnapshots
DefaultNumOfDiskSnapshots

-- | The result of the represented call to 'onDiskShouldTakeSnapshot'
shouldTakeSnapshot :: TestSetup -> Bool
shouldTakeSnapshot :: TestSetup -> Bool
shouldTakeSnapshot TestSetup
ts =
  SnapshotPolicy -> Maybe DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot
    (TestSetup -> SnapshotPolicy
toSnapshotPolicy TestSetup
ts)
    (TestSetup -> Maybe DiffTime
tsTimeSince TestSetup
ts)
    (TestSetup -> Word64
tsBlocksSince TestSetup
ts)

{-------------------------------------------------------------------------------
  Generator and shrinker
-------------------------------------------------------------------------------}

instance Arbitrary TestSetup where
  arbitrary :: Gen TestSetup
arbitrary = do
    k <-
      [(Int, Gen Word64)] -> Gen Word64
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
9, (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
3000))
        , (Int
1, (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
forall a. Bounded a => a
maxBound))
        ]
        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

    -- values within usual expectations
    let nominal =
          (,)
            -- 20 k is average number in a Shelley epoch
            (Word64 -> Maybe DiffTime -> (Word64, Maybe DiffTime))
-> Gen Word64 -> Gen (Maybe DiffTime -> (Word64, Maybe DiffTime))
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
0, Word64
20 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k)
            -- a week is a defensible upper bound on the user input
            Gen (Maybe DiffTime -> (Word64, Maybe DiffTime))
-> Gen (Maybe DiffTime) -> Gen (Word64, Maybe DiffTime)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen DiffTime -> Gen (Maybe DiffTime)
forall a. Gen a -> Gen (Maybe a)
just95 (Integer -> Integer -> Gen DiffTime
chooseSeconds Integer
0 Integer
oneWeekInSeconds)

    -- values near known cutoffs
    let interesting =
          (,)
            (Word64 -> Maybe DiffTime -> (Word64, Maybe DiffTime))
-> Gen Word64 -> Gen (Maybe DiffTime -> (Word64, Maybe DiffTime))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Word64, Word64) -> Gen Word64) -> Word64 -> Word64 -> Gen Word64
forall a b c. ((a, b) -> c) -> a -> b -> c
curry
              (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose
              (Word64
minBlocksBeforeSnapshot Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
2)
              (Word64
minBlocksBeforeSnapshot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
2)
            Gen (Maybe DiffTime -> (Word64, Maybe DiffTime))
-> Gen (Maybe DiffTime) -> Gen (Word64, Maybe DiffTime)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just
                    (DiffTime -> Maybe DiffTime)
-> Gen DiffTime -> Gen (Maybe DiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen DiffTime
chooseSeconds
                      (Integer
minSecondsBeforeSnapshot Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2)
                      (Integer
minSecondsBeforeSnapshot Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2)
                )

    -- all other conceivable values
    let wild =
          (,)
            (Word64 -> Maybe DiffTime -> (Word64, Maybe DiffTime))
-> Gen Word64 -> Gen (Maybe DiffTime -> (Word64, Maybe DiffTime))
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
0, Word64
forall a. Bounded a => a
maxBound)
            Gen (Maybe DiffTime -> (Word64, Maybe DiffTime))
-> Gen (Maybe DiffTime) -> Gen (Word64, Maybe DiffTime)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen DiffTime -> Gen (Maybe DiffTime)
forall a. Gen a -> Gen (Maybe a)
just95 (Integer -> Integer -> Gen DiffTime
chooseSeconds Integer
0 Integer
oneCenturyInSeconds)

    (b, t) <-
      frequency
        [ (80, nominal)
        , (15, interesting)
        , (5, wild)
        ]

    -- this argument is provided from node via flag, we must anticipate values
    -- to be completely arbitrary. However we still want to keep the distribution
    -- of those values in such way that more probable values will be
    -- more frequently test
    tsSnapshotInterval <-
      frequency
        [ (45, pure DefaultSnapshotInterval)
        , (45, RequestedSnapshotInterval <$> chooseSeconds 0 oneWeekInSeconds)
        , (4, RequestedSnapshotInterval <$> chooseSeconds 0 (2 * oneWeekInSeconds))
        , (4, RequestedSnapshotInterval <$> chooseSeconds 0 (3 * oneWeekInSeconds))
        , (1, RequestedSnapshotInterval <$> chooseSeconds 0 (4 * oneWeekInSeconds))
        , (1, RequestedSnapshotInterval <$> chooseSeconds 0 oneCenturyInSeconds)
        ]

    pure
      TestSetup
        { tsBlocksSince = b
        , tsK = SecurityParam k
        , tsSnapshotInterval
        , tsTimeSince = t
        }
   where
    -- 100 years seems a reasonable upper bound for consideration
    oneCenturyInSeconds :: Integer
oneCenturyInSeconds = Integer
100 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
365 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
oneDayInSeconds
    -- one week seems a reasonable upper bound for relevance
    oneWeekInSeconds :: Integer
oneWeekInSeconds = Integer
7 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
oneDayInSeconds
    oneDayInSeconds :: Integer
oneDayInSeconds = Integer
24 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60

    just95 :: Gen a -> Gen (Maybe a)
    just95 :: forall a. Gen a -> Gen (Maybe a)
just95 Gen a
m = [(Int, Gen (Maybe a))] -> Gen (Maybe a)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
5, Maybe a -> Gen (Maybe a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing), (Int
95, a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Gen a -> Gen (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
m)]

    -- both bounds are inclusive and in seconds
    chooseSeconds :: Integer -> Integer -> Gen DiffTime
    chooseSeconds :: Integer -> Integer -> Gen DiffTime
chooseSeconds Integer
lo Integer
hi = do
      -- pick a second
      s <- (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
lo, Integer
hi)
      -- jitter within it
      let nines = Integer
10 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
12 :: Int) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
      offset <- choose (negate nines, nines)
      pure $ picosecondsToDiffTime $ max lo $ min hi $ s + offset

  shrink :: TestSetup -> [TestSetup]
shrink (TestSetup Word64
x1 SecurityParam
x2 SnapshotInterval
x3 Maybe DiffTime
x4) =
    [[TestSetup]] -> [TestSetup]
forall a. Monoid a => [a] -> a
mconcat
      [ (\Word64
y -> Word64
-> SecurityParam -> SnapshotInterval -> Maybe DiffTime -> TestSetup
TestSetup Word64
y SecurityParam
x2 SnapshotInterval
x3 Maybe DiffTime
x4) (Word64 -> TestSetup) -> [Word64] -> [TestSetup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink @Word64 Word64
x1
      , (\SecurityParam
y -> Word64
-> SecurityParam -> SnapshotInterval -> Maybe DiffTime -> TestSetup
TestSetup Word64
x1 SecurityParam
y SnapshotInterval
x3 Maybe DiffTime
x4) (SecurityParam -> TestSetup) -> [SecurityParam] -> [TestSetup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SecurityParam -> [SecurityParam]
shrinkSecurityParam SecurityParam
x2
      , (\SnapshotInterval
y -> Word64
-> SecurityParam -> SnapshotInterval -> Maybe DiffTime -> TestSetup
TestSetup Word64
x1 SecurityParam
x2 SnapshotInterval
y Maybe DiffTime
x4) (SnapshotInterval -> TestSetup)
-> [SnapshotInterval] -> [TestSetup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SnapshotInterval -> [SnapshotInterval]
shrinkSnapshotInterval SnapshotInterval
x3
      , (\Maybe DiffTime
y -> Word64
-> SecurityParam -> SnapshotInterval -> Maybe DiffTime -> TestSetup
TestSetup Word64
x1 SecurityParam
x2 SnapshotInterval
x3 Maybe DiffTime
y) (Maybe DiffTime -> TestSetup) -> [Maybe DiffTime] -> [TestSetup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DiffTime -> [DiffTime]) -> Maybe DiffTime -> [Maybe DiffTime]
forall {t} {a}. (t -> [a]) -> Maybe t -> [Maybe a]
shrinkTSL DiffTime -> [DiffTime]
shrinkDiffTime Maybe DiffTime
x4
      ]
   where
    shrinkSecurityParam :: SecurityParam -> [SecurityParam]
shrinkSecurityParam =
      (NonZero Word64 -> SecurityParam)
-> [NonZero Word64] -> [SecurityParam]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonZero Word64 -> SecurityParam
SecurityParam ([NonZero Word64] -> [SecurityParam])
-> (SecurityParam -> [NonZero Word64])
-> SecurityParam
-> [SecurityParam]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonZero Word64 -> [NonZero Word64]
forall a. Arbitrary a => a -> [a]
shrink {-@(Word64)-} (NonZero Word64 -> [NonZero Word64])
-> (SecurityParam -> NonZero Word64)
-> SecurityParam
-> [NonZero Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam -> NonZero Word64
maxRollbacks

    shrinkDiffTime :: DiffTime -> [DiffTime]
shrinkDiffTime =
      (Integer -> DiffTime) -> [Integer] -> [DiffTime]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> DiffTime
picosecondsToDiffTime
        ([Integer] -> [DiffTime])
-> (DiffTime -> [Integer]) -> DiffTime -> [DiffTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Arbitrary a => a -> [a]
shrink @Integer
        (Integer -> [Integer])
-> (DiffTime -> Integer) -> DiffTime -> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Integer
diffTimeToPicoseconds

    shrinkTSL :: (t -> [a]) -> Maybe t -> [Maybe a]
shrinkTSL t -> [a]
shnk = \case
      Maybe t
Nothing -> []
      Just t
d -> Maybe a
forall a. Maybe a
Nothing Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: (a -> Maybe a) -> [a] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (t -> [a]
shnk t
d)

    shrinkSnapshotInterval :: SnapshotInterval -> [SnapshotInterval]
shrinkSnapshotInterval = \case
      SnapshotInterval
DisableSnapshots -> []
      SnapshotInterval
DefaultSnapshotInterval -> []
      RequestedSnapshotInterval DiffTime
d ->
        SnapshotInterval
DefaultSnapshotInterval
          SnapshotInterval -> [SnapshotInterval] -> [SnapshotInterval]
forall a. a -> [a] -> [a]
: (DiffTime -> SnapshotInterval
RequestedSnapshotInterval (DiffTime -> SnapshotInterval) -> [DiffTime] -> [SnapshotInterval]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DiffTime -> [DiffTime]
shrinkDiffTime DiffTime
d)

{-------------------------------------------------------------------------------
  Properties
-------------------------------------------------------------------------------}

-- | Check 'onDiskNumSnapshots' of 'defaultSnapshotPolicy'
prop_onDiskNumSnapshots :: TestSetup -> Property
prop_onDiskNumSnapshots :: TestSetup -> Property
prop_onDiskNumSnapshots TestSetup
ts =
  -- 'TestSetup' has more information than we need for this property
  TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"should always be 2" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    SnapshotPolicy -> Word
onDiskNumSnapshots (TestSetup -> SnapshotPolicy
toSnapshotPolicy TestSetup
ts) Word -> Word -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Word
2

minBlocksBeforeSnapshot :: Word64
minBlocksBeforeSnapshot :: Word64
minBlocksBeforeSnapshot = Word64
50_000

minSecondsBeforeSnapshot :: Integer
minSecondsBeforeSnapshot :: Integer
minSecondsBeforeSnapshot = Integer
6 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60

-- | Check 'onDiskShouldTakeSnapshot' of 'defaultSnapshotPolicy'
prop_onDiskShouldTakeSnapshot :: TestSetup -> Property
prop_onDiskShouldTakeSnapshot :: TestSetup -> Property
prop_onDiskShouldTakeSnapshot TestSetup
ts =
  TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"decided to take snapshot? " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> TestName
forall a. Show a => a -> TestName
show (TestSetup -> Bool
shouldTakeSnapshot TestSetup
ts)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    case Maybe DiffTime
t of
      Maybe DiffTime
Nothing ->
        TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"haven't taken a snapshot yet" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"should take snapshot if it processed at least k blocks" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            TestSetup -> Bool
shouldTakeSnapshot TestSetup
ts Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (Word64
blocksSinceLast Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k)
      Just DiffTime
timeSinceLast ->
        TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"have previously taken a snapshot" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          NamedValue Bool -> [NamedValue Bool] -> Property
isDisjunctionOf
            (TestSetup -> Bool
shouldTakeSnapshot TestSetup
ts Bool -> TestName -> NamedValue Bool
forall a. a -> TestName -> NamedValue a
`named` TestName
"the decision")
            [ DiffTime -> NamedValue Bool
systemChecksHowMuchTimeHasPassed DiffTime
timeSinceLast
            , DiffTime -> NamedValue Bool
systemChecksHowManyBlocksWereProcessed DiffTime
timeSinceLast
            ]
 where
  TestSetup
    { tsBlocksSince :: TestSetup -> Word64
tsBlocksSince = Word64
blocksSinceLast
    , tsK :: TestSetup -> SecurityParam
tsK = SecurityParam NonZero Word64
k
    , tsSnapshotInterval :: TestSetup -> SnapshotInterval
tsSnapshotInterval = SnapshotInterval
snapshotInterval
    , tsTimeSince :: TestSetup -> Maybe DiffTime
tsTimeSince = Maybe DiffTime
t
    } = TestSetup
ts

  kTimes2 :: DiffTime
  kTimes2 :: DiffTime
kTimes2 = Integer -> DiffTime
secondsToDiffTime (Integer -> DiffTime) -> Integer -> DiffTime
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
2

  systemChecksHowMuchTimeHasPassed :: DiffTime -> NamedValue Bool
  systemChecksHowMuchTimeHasPassed :: DiffTime -> NamedValue Bool
systemChecksHowMuchTimeHasPassed DiffTime
timeSinceLast =
    case SnapshotInterval
snapshotInterval of
      SnapshotInterval
DefaultSnapshotInterval ->
        (DiffTime
timeSinceLast DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
kTimes2)
          Bool -> TestName -> NamedValue Bool
forall a. a -> TestName -> NamedValue a
`named` TestName
"time since last is greater then 2 * k seconds if snapshot interval is set to default"
      RequestedSnapshotInterval DiffTime
interval ->
        (DiffTime
timeSinceLast DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
interval)
          Bool -> TestName -> NamedValue Bool
forall a. a -> TestName -> NamedValue a
`named` TestName
"time since last is greater then explicitly requested interval"
      SnapshotInterval
DisableSnapshots -> TestName -> NamedValue Bool
forall a. HasCallStack => TestName -> a
error TestName
"Will never call this test with this value"

  systemChecksHowManyBlocksWereProcessed :: DiffTime -> NamedValue Bool
  systemChecksHowManyBlocksWereProcessed :: DiffTime -> NamedValue Bool
systemChecksHowManyBlocksWereProcessed DiffTime
timeSinceLast =
    Bool
disjunct Bool -> TestName -> NamedValue Bool
forall a. a -> TestName -> NamedValue a
`named` TestName
msg
   where
    msg :: TestName
msg =
      [TestName] -> TestName
unwords
        [ TestName
"we have processed"
        , Word64 -> TestName
forall a. Show a => a -> TestName
show Word64
minBlocksBeforeSnapshot
        , TestName
"blocks and it's been more than"
        , Integer -> TestName
forall a. Show a => a -> TestName
show Integer
minSecondsBeforeSnapshot
        , TestName
"seconds since last snapshot was taken"
        ]

    disjunct :: Bool
disjunct =
      Word64
blocksSinceLast Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
minBlocksBeforeSnapshot
        Bool -> Bool -> Bool
&& DiffTime
timeSinceLast DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer -> DiffTime
secondsToDiffTime Integer
minSecondsBeforeSnapshot

{-------------------------------------------------------------------------------
  Auxiliary   -- TODO relocate this somewhere more general
-------------------------------------------------------------------------------}

-- | A value with an associated user-friendly string
data NamedValue a = NamedValue String a

forgetName :: NamedValue a -> a
forgetName :: forall a. NamedValue a -> a
forgetName (NamedValue TestName
_s a
a) = a
a

infix 0 `named`

named :: a -> String -> NamedValue a
named :: forall a. a -> TestName -> NamedValue a
named = (TestName -> a -> NamedValue a) -> a -> TestName -> NamedValue a
forall a b c. (a -> b -> c) -> b -> a -> c
flip TestName -> a -> NamedValue a
forall a. TestName -> a -> NamedValue a
NamedValue

-- | Use this instead of @x '===' 'or' ys@ to get a 'counterexample' message
-- that explains which of the disjuncts were mismatched
isDisjunctionOf :: NamedValue Bool -> [NamedValue Bool] -> Property
isDisjunctionOf :: NamedValue Bool -> [NamedValue Bool] -> Property
isDisjunctionOf (NamedValue TestName
s Bool
b) [NamedValue Bool]
ds =
  TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
msg (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool
b Bool -> Bool -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (NamedValue Bool -> Bool) -> [NamedValue Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedValue Bool -> Bool
forall a. NamedValue a -> a
forgetName [NamedValue Bool]
ds
 where
  msg :: TestName
msg =
    [TestName] -> TestName
unlines ([TestName] -> TestName) -> [TestName] -> TestName
forall a b. (a -> b) -> a -> b
$
      ( Bool -> TestName
forall a. Show a => a -> TestName
show Bool
b
          TestName -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestName
" for "
          TestName -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestName
s
          TestName -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestName
", but the "
          TestName -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> TestName
forall a. Show a => a -> TestName
show ([NamedValue Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NamedValue Bool]
ds)
          TestName -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestName
" disjuncts were: "
      )
        TestName -> [TestName] -> [TestName]
forall a. a -> [a] -> [a]
: [ TestName
"  "
              TestName -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestName
"disjunct "
              TestName -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> TestName
forall a. Show a => a -> TestName
show (Int
i :: Int)
              TestName -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestName
": "
              TestName -> ShowS
forall a. Semigroup a => a -> a -> a
<> Bool -> TestName
forall a. Show a => a -> TestName
show Bool
b'
              TestName -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestName
" for "
              TestName -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestName
s'
          | (Int
i, NamedValue TestName
s' Bool
b') <- [Int] -> [NamedValue Bool] -> [(Int, NamedValue Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [NamedValue Bool]
ds
          ]