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

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

import           Data.Time.Clock (DiffTime, diffTimeToPicoseconds,
                     picosecondsToDiffTime, secondsToDiffTime)
import           Data.Word
import           Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..))
import           Ouroboros.Consensus.Storage.LedgerDB (DiskPolicy (..),
                     NumOfDiskSnapshots (..), SnapshotInterval (..),
                     TimeSinceLast (..), mkDiskPolicy)
import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
                     (DiskPolicyArgs (DiskPolicyArgs))
import           Test.QuickCheck
import           Test.Tasty
import           Test.Tasty.QuickCheck

tests :: TestTree
tests :: TestTree
tests =
    TestName -> [TestTree] -> TestTree
testGroup TestName
"DiskPolicy" [
        TestName -> [TestTree] -> TestTree
testGroup TestName
"defaultDiskPolicy" [
            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 {
    -- | argument to 'onDiskShouldTakeSnapshot'
    TestSetup -> Word64
tsBlocksSince      :: Word64
    -- | argument to 'defaultDiskPolicy'
  , TestSetup -> SecurityParam
tsK                :: SecurityParam
    -- | argument to 'defaultDiskPolicy'
  , TestSetup -> SnapshotInterval
tsSnapshotInterval :: SnapshotInterval
    -- | argument to 'onDiskShouldTakeSnapshot'
  , TestSetup -> TimeSinceLast DiffTime
tsTimeSince        :: TimeSinceLast DiffTime
  }
  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 'DiskPolicy'
toDiskPolicy :: TestSetup -> DiskPolicy
toDiskPolicy :: TestSetup -> DiskPolicy
toDiskPolicy TestSetup
ts = SecurityParam -> DiskPolicyArgs -> DiskPolicy
mkDiskPolicy (TestSetup -> SecurityParam
tsK TestSetup
ts) DiskPolicyArgs
diskPolicyArgs
  where
    diskPolicyArgs :: DiskPolicyArgs
diskPolicyArgs =
      SnapshotInterval -> NumOfDiskSnapshots -> DiskPolicyArgs
DiskPolicyArgs (TestSetup -> SnapshotInterval
tsSnapshotInterval TestSetup
ts) NumOfDiskSnapshots
DefaultNumOfDiskSnapshots

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

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

instance Arbitrary TestSetup where
  arbitrary :: Gen TestSetup
arbitrary = do
      Word64
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))
        ]

      -- values within usual expectations
      let nominal :: Gen (Word64, Maybe DiffTime)
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
* 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 :: Gen (Word64, Maybe DiffTime)
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 :: Gen (Word64, Maybe DiffTime)
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)

      (Word64
b, Maybe DiffTime
t) <- [(Int, Gen (Word64, Maybe DiffTime))]
-> Gen (Word64, Maybe DiffTime)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [
          (Int
80, Gen (Word64, Maybe DiffTime)
nominal)
        , (Int
15, Gen (Word64, Maybe DiffTime)
interesting)
        , (Int
5,  Gen (Word64, Maybe DiffTime)
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
      SnapshotInterval
tsSnapshotInterval <- [(Int, Gen SnapshotInterval)] -> Gen SnapshotInterval
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [
          (Int
45, SnapshotInterval -> Gen SnapshotInterval
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotInterval
DefaultSnapshotInterval)
        , (Int
45, DiffTime -> SnapshotInterval
RequestedSnapshotInterval (DiffTime -> SnapshotInterval)
-> Gen DiffTime -> Gen SnapshotInterval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen DiffTime
chooseSeconds Integer
0      Integer
oneWeekInSeconds)
        , ( Int
4, DiffTime -> SnapshotInterval
RequestedSnapshotInterval (DiffTime -> SnapshotInterval)
-> Gen DiffTime -> Gen SnapshotInterval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen DiffTime
chooseSeconds Integer
0 (Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
oneWeekInSeconds))
        , ( Int
4, DiffTime -> SnapshotInterval
RequestedSnapshotInterval (DiffTime -> SnapshotInterval)
-> Gen DiffTime -> Gen SnapshotInterval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen DiffTime
chooseSeconds Integer
0 (Integer
3 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
oneWeekInSeconds))
        , ( Int
1, DiffTime -> SnapshotInterval
RequestedSnapshotInterval (DiffTime -> SnapshotInterval)
-> Gen DiffTime -> Gen SnapshotInterval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen DiffTime
chooseSeconds Integer
0 (Integer
4 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
oneWeekInSeconds))
        , ( Int
1, DiffTime -> SnapshotInterval
RequestedSnapshotInterval (DiffTime -> SnapshotInterval)
-> Gen DiffTime -> Gen SnapshotInterval
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen DiffTime
chooseSeconds Integer
0 Integer
oneCenturyInSeconds)
        ]

      TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestSetup {
          tsBlocksSince :: Word64
tsBlocksSince = Word64
b
        , tsK :: SecurityParam
tsK           = Word64 -> SecurityParam
SecurityParam Word64
k
        , SnapshotInterval
tsSnapshotInterval :: SnapshotInterval
tsSnapshotInterval :: SnapshotInterval
tsSnapshotInterval
        , tsTimeSince :: TimeSinceLast DiffTime
tsTimeSince   = TimeSinceLast DiffTime
-> (DiffTime -> TimeSinceLast DiffTime)
-> Maybe DiffTime
-> TimeSinceLast DiffTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TimeSinceLast DiffTime
forall time. TimeSinceLast time
NoSnapshotTakenYet DiffTime -> TimeSinceLast DiffTime
forall time. time -> TimeSinceLast time
TimeSinceLast Maybe DiffTime
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
          Integer
s <- (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
lo, Integer
hi)
          -- jitter within it
          let nines :: Integer
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
          Integer
offset <- (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer -> Integer
forall a. Num a => a -> a
negate Integer
nines, Integer
nines)
          DiffTime -> Gen DiffTime
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime -> Gen DiffTime) -> DiffTime -> Gen DiffTime
forall a b. (a -> b) -> a -> b
$ Integer -> DiffTime
picosecondsToDiffTime (Integer -> DiffTime) -> Integer -> DiffTime
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
lo (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min Integer
hi (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
offset

  shrink :: TestSetup -> [TestSetup]
shrink (TestSetup Word64
x1 SecurityParam
x2 SnapshotInterval
x3 TimeSinceLast DiffTime
x4) = [[TestSetup]] -> [TestSetup]
forall a. Monoid a => [a] -> a
mconcat [
        (\Word64
y -> Word64
-> SecurityParam
-> SnapshotInterval
-> TimeSinceLast DiffTime
-> TestSetup
TestSetup Word64
y SecurityParam
x2 SnapshotInterval
x3 TimeSinceLast 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
-> TimeSinceLast DiffTime
-> TestSetup
TestSetup Word64
x1 SecurityParam
y SnapshotInterval
x3 TimeSinceLast 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
-> TimeSinceLast DiffTime
-> TestSetup
TestSetup Word64
x1 SecurityParam
x2 SnapshotInterval
y TimeSinceLast DiffTime
x4) (SnapshotInterval -> TestSetup)
-> [SnapshotInterval] -> [TestSetup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SnapshotInterval -> [SnapshotInterval]
shrinkSnapshotInterval SnapshotInterval
x3
      , (\TimeSinceLast DiffTime
y -> Word64
-> SecurityParam
-> SnapshotInterval
-> TimeSinceLast DiffTime
-> TestSetup
TestSetup Word64
x1 SecurityParam
x2 SnapshotInterval
x3 TimeSinceLast DiffTime
y) (TimeSinceLast DiffTime -> TestSetup)
-> [TimeSinceLast DiffTime] -> [TestSetup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DiffTime -> [DiffTime])
-> TimeSinceLast DiffTime -> [TimeSinceLast DiffTime]
forall {t} {time}.
(t -> [time]) -> TimeSinceLast t -> [TimeSinceLast time]
shrinkTSL DiffTime -> [DiffTime]
shrinkDiffTime TimeSinceLast DiffTime
x4
      ]
    where
      shrinkSecurityParam :: SecurityParam -> [SecurityParam]
shrinkSecurityParam =
          (Word64 -> SecurityParam) -> [Word64] -> [SecurityParam]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> SecurityParam
SecurityParam ([Word64] -> [SecurityParam])
-> (SecurityParam -> [Word64]) -> SecurityParam -> [SecurityParam]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Arbitrary a => a -> [a]
shrink @Word64 (Word64 -> [Word64])
-> (SecurityParam -> Word64) -> SecurityParam -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam -> 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 -> [time]) -> TimeSinceLast t -> [TimeSinceLast time]
shrinkTSL t -> [time]
shnk = \case
        TimeSinceLast t
NoSnapshotTakenYet -> []
        TimeSinceLast    t
d -> TimeSinceLast time
forall time. TimeSinceLast time
NoSnapshotTakenYet TimeSinceLast time -> [TimeSinceLast time] -> [TimeSinceLast time]
forall a. a -> [a] -> [a]
: (time -> TimeSinceLast time) -> [time] -> [TimeSinceLast time]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap time -> TimeSinceLast time
forall time. time -> TimeSinceLast time
TimeSinceLast (t -> [time]
shnk t
d)

      shrinkSnapshotInterval :: SnapshotInterval -> [SnapshotInterval]
shrinkSnapshotInterval = \case
        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 'defaultDiskPolicy'
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
$ DiskPolicy -> Word
onDiskNumSnapshots (TestSetup -> DiskPolicy
toDiskPolicy 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 'defaultDiskPolicy'
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 TimeSinceLast DiffTime
t of
      TimeSinceLast DiffTime
NoSnapshotTakenYet ->
            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
>= Word64
k)
      TimeSinceLast    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 Word64
k
      , tsSnapshotInterval :: TestSetup -> SnapshotInterval
tsSnapshotInterval = SnapshotInterval
snapshotInterval
      , tsTimeSince :: TestSetup -> TimeSinceLast DiffTime
tsTimeSince        = TimeSinceLast 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
$ 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"

    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
          ]