{-# 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
]
]
data TestSetup = TestSetup {
TestSetup -> Word64
tsBlocksSince :: Word64
, TestSetup -> SecurityParam
tsK :: SecurityParam
, TestSetup -> SnapshotInterval
tsSnapshotInterval :: SnapshotInterval
, 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)
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
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)
instance Arbitrary TestSetup where
arbitrary :: Gen TestSetup
arbitrary = do
Word64
k <- [(Int, Gen Word64)] -> Gen Word64
forall a. [(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))
]
let nominal :: Gen (Word64, Maybe DiffTime)
nominal =
(,)
(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)
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)
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)
)
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. [(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)
]
SnapshotInterval
tsSnapshotInterval <- [(Int, Gen SnapshotInterval)] -> Gen SnapshotInterval
forall a. [(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
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
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. [(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)]
chooseSeconds :: Integer -> Integer -> Gen DiffTime
chooseSeconds :: Integer -> Integer -> Gen DiffTime
chooseSeconds Integer
lo Integer
hi = do
Integer
s <- (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
lo, Integer
hi)
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)
prop_onDiskNumSnapshots :: TestSetup -> Property
prop_onDiskNumSnapshots :: TestSetup -> Property
prop_onDiskNumSnapshots TestSetup
ts =
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
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
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
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
]