{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module contains various tests for the leaky bucket. Some, prefixed by
-- “play”, are simple, manual tests; two concern (non-)propagation of exceptions
-- between the bucket thread and the action's thread; the last one compares a
-- run of the actual bucket implementation against a model.
module Test.Ouroboros.Consensus.Util.LeakyBucket.Tests (tests) where

import Control.Monad (foldM, void)
import Control.Monad.Class.MonadTimer (MonadTimer)
import Control.Monad.IOSim (IOSim, runSimOrThrow)
import Data.Either (isLeft, isRight)
import Data.Functor ((<&>))
import Data.List (intersperse)
import Data.Ord (clamp)
import Data.Ratio ((%))
import Data.Time.Clock (DiffTime, picosecondsToDiffTime)
import Ouroboros.Consensus.Util.IOLike
  ( Exception (displayException)
  , MonadAsync
  , MonadCatch (try)
  , MonadDelay
  , MonadFork
  , MonadMask
  , MonadSTM
  , MonadThrow (throwIO)
  , NoThunks
  , SomeException
  , Time (Time)
  , addTime
  , fromException
  , threadDelay
  )
import Ouroboros.Consensus.Util.LeakyBucket
import Test.QuickCheck
  ( Arbitrary (arbitrary)
  , Gen
  , Property
  , classify
  , counterexample
  , forAllShrinkBlind
  , frequency
  , ioProperty
  , liftArbitrary2
  , listOf1
  , scale
  , shrinkList
  , suchThat
  )
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (property, testProperty)
import Test.Util.TestEnv (adjustQuickCheckTests)

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Ouroboros.Consensus.Util.LeakyBucket"
    [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"play a bit" Property
prop_playABit
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"play too long" Property
prop_playTooLong
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"play too long harmless" Property
prop_playTooLongHarmless
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"play with pause" Property
prop_playWithPause
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"play with pause too long" Property
prop_playWithPauseTooLong
    , TestName -> (Capacity -> Rate -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"wait almost too long" (Bool -> Capacity -> Rate -> Property
prop_noRefill Bool
False)
    , TestName -> (Capacity -> Rate -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"wait just too long" (Bool -> Capacity -> Rate -> Property
prop_noRefill Bool
True)
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"propagates exceptions" Property
prop_propagateExceptions
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"propagates exceptions (IO)" Property
prop_propagateExceptionsIO
    , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"catch exception" Property
prop_catchException
    , (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"random" Property
prop_random
    ]

--------------------------------------------------------------------------------
-- Dummy configuration
--------------------------------------------------------------------------------

newtype Capacity = Capacity {Capacity -> Rational
unCapacity :: Rational}
  deriving Int -> Capacity -> ShowS
[Capacity] -> ShowS
Capacity -> TestName
(Int -> Capacity -> ShowS)
-> (Capacity -> TestName) -> ([Capacity] -> ShowS) -> Show Capacity
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Capacity -> ShowS
showsPrec :: Int -> Capacity -> ShowS
$cshow :: Capacity -> TestName
show :: Capacity -> TestName
$cshowList :: [Capacity] -> ShowS
showList :: [Capacity] -> ShowS
Show

instance Arbitrary Capacity where
  arbitrary :: Gen Capacity
arbitrary = Rational -> Capacity
Capacity (Rational -> Capacity) -> Gen Rational -> Gen Capacity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Rational
forall a. Arbitrary a => Gen a
arbitrary Gen Rational -> (Rational -> Bool) -> Gen Rational
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
0)

newtype Rate = Rate {Rate -> Rational
unRate :: Rational}
  deriving Int -> Rate -> ShowS
[Rate] -> ShowS
Rate -> TestName
(Int -> Rate -> ShowS)
-> (Rate -> TestName) -> ([Rate] -> ShowS) -> Show Rate
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Rate -> ShowS
showsPrec :: Int -> Rate -> ShowS
$cshow :: Rate -> TestName
show :: Rate -> TestName
$cshowList :: [Rate] -> ShowS
showList :: [Rate] -> ShowS
Show

instance Arbitrary Rate where
  arbitrary :: Gen Rate
arbitrary = Rational -> Rate
Rate (Rational -> Rate) -> Gen Rational -> Gen Rate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Rational
forall a. Arbitrary a => Gen a
arbitrary Gen Rational -> (Rational -> Bool) -> Gen Rational
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
0)

newtype FillOnOverflow = FillOnOverflow {FillOnOverflow -> Bool
unFillOnOverflow :: Bool}
  deriving Int -> FillOnOverflow -> ShowS
[FillOnOverflow] -> ShowS
FillOnOverflow -> TestName
(Int -> FillOnOverflow -> ShowS)
-> (FillOnOverflow -> TestName)
-> ([FillOnOverflow] -> ShowS)
-> Show FillOnOverflow
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FillOnOverflow -> ShowS
showsPrec :: Int -> FillOnOverflow -> ShowS
$cshow :: FillOnOverflow -> TestName
show :: FillOnOverflow -> TestName
$cshowList :: [FillOnOverflow] -> ShowS
showList :: [FillOnOverflow] -> ShowS
Show

instance Arbitrary FillOnOverflow where
  arbitrary :: Gen FillOnOverflow
arbitrary = Bool -> FillOnOverflow
FillOnOverflow (Bool -> FillOnOverflow) -> Gen Bool -> Gen FillOnOverflow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary

-- | Whether to throw on empty bucket.
newtype ThrowOnEmpty = ThrowOnEmpty {ThrowOnEmpty -> Bool
unThrowOnEmpty :: Bool}
  deriving (ThrowOnEmpty -> ThrowOnEmpty -> Bool
(ThrowOnEmpty -> ThrowOnEmpty -> Bool)
-> (ThrowOnEmpty -> ThrowOnEmpty -> Bool) -> Eq ThrowOnEmpty
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThrowOnEmpty -> ThrowOnEmpty -> Bool
== :: ThrowOnEmpty -> ThrowOnEmpty -> Bool
$c/= :: ThrowOnEmpty -> ThrowOnEmpty -> Bool
/= :: ThrowOnEmpty -> ThrowOnEmpty -> Bool
Eq, Int -> ThrowOnEmpty -> ShowS
[ThrowOnEmpty] -> ShowS
ThrowOnEmpty -> TestName
(Int -> ThrowOnEmpty -> ShowS)
-> (ThrowOnEmpty -> TestName)
-> ([ThrowOnEmpty] -> ShowS)
-> Show ThrowOnEmpty
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThrowOnEmpty -> ShowS
showsPrec :: Int -> ThrowOnEmpty -> ShowS
$cshow :: ThrowOnEmpty -> TestName
show :: ThrowOnEmpty -> TestName
$cshowList :: [ThrowOnEmpty] -> ShowS
showList :: [ThrowOnEmpty] -> ShowS
Show)

instance Arbitrary ThrowOnEmpty where
  arbitrary :: Gen ThrowOnEmpty
arbitrary = Bool -> ThrowOnEmpty
ThrowOnEmpty (Bool -> ThrowOnEmpty) -> Gen Bool -> Gen ThrowOnEmpty
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary

data TestConfig = TestConfig
  { TestConfig -> Rational
testCapacity :: Rational
  , TestConfig -> Rational
testRate :: Rational
  , TestConfig -> Bool
testThrowOnEmpty :: Bool
  }
  deriving (TestConfig -> TestConfig -> Bool
(TestConfig -> TestConfig -> Bool)
-> (TestConfig -> TestConfig -> Bool) -> Eq TestConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestConfig -> TestConfig -> Bool
== :: TestConfig -> TestConfig -> Bool
$c/= :: TestConfig -> TestConfig -> Bool
/= :: TestConfig -> TestConfig -> Bool
Eq, Int -> TestConfig -> ShowS
[TestConfig] -> ShowS
TestConfig -> TestName
(Int -> TestConfig -> ShowS)
-> (TestConfig -> TestName)
-> ([TestConfig] -> ShowS)
-> Show TestConfig
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestConfig -> ShowS
showsPrec :: Int -> TestConfig -> ShowS
$cshow :: TestConfig -> TestName
show :: TestConfig -> TestName
$cshowList :: [TestConfig] -> ShowS
showList :: [TestConfig] -> ShowS
Show)

data TestState = TestState
  { TestState -> Rational
testLevel :: Rational
  , TestState -> Time
testTime :: Time
  , TestState -> Bool
testPaused :: Bool
  }
  deriving (TestState -> TestState -> Bool
(TestState -> TestState -> Bool)
-> (TestState -> TestState -> Bool) -> Eq TestState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestState -> TestState -> Bool
== :: TestState -> TestState -> Bool
$c/= :: TestState -> TestState -> Bool
/= :: TestState -> TestState -> Bool
Eq, Int -> TestState -> ShowS
[TestState] -> ShowS
TestState -> TestName
(Int -> TestState -> ShowS)
-> (TestState -> TestName)
-> ([TestState] -> ShowS)
-> Show TestState
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestState -> ShowS
showsPrec :: Int -> TestState -> ShowS
$cshow :: TestState -> TestName
show :: TestState -> TestName
$cshowList :: [TestState] -> ShowS
showList :: [TestState] -> ShowS
Show)

instance Arbitrary TestConfig where
  arbitrary :: Gen TestConfig
arbitrary =
    Rational -> Rational -> Bool -> TestConfig
TestConfig
      (Rational -> Rational -> Bool -> TestConfig)
-> Gen Rational -> Gen (Rational -> Bool -> TestConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Capacity -> Rational
unCapacity (Capacity -> Rational) -> Gen Capacity -> Gen Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Capacity
forall a. Arbitrary a => Gen a
arbitrary)
      Gen (Rational -> Bool -> TestConfig)
-> Gen Rational -> Gen (Bool -> TestConfig)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Rate -> Rational
unRate (Rate -> Rational) -> Gen Rate -> Gen Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Rate
forall a. Arbitrary a => Gen a
arbitrary)
      Gen (Bool -> TestConfig) -> Gen Bool -> Gen TestConfig
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ThrowOnEmpty -> Bool
unThrowOnEmpty (ThrowOnEmpty -> Bool) -> Gen ThrowOnEmpty -> Gen Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ThrowOnEmpty
forall a. Arbitrary a => Gen a
arbitrary)

data EmptyBucket = EmptyBucket
  deriving (EmptyBucket -> EmptyBucket -> Bool
(EmptyBucket -> EmptyBucket -> Bool)
-> (EmptyBucket -> EmptyBucket -> Bool) -> Eq EmptyBucket
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EmptyBucket -> EmptyBucket -> Bool
== :: EmptyBucket -> EmptyBucket -> Bool
$c/= :: EmptyBucket -> EmptyBucket -> Bool
/= :: EmptyBucket -> EmptyBucket -> Bool
Eq, Int -> EmptyBucket -> ShowS
[EmptyBucket] -> ShowS
EmptyBucket -> TestName
(Int -> EmptyBucket -> ShowS)
-> (EmptyBucket -> TestName)
-> ([EmptyBucket] -> ShowS)
-> Show EmptyBucket
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EmptyBucket -> ShowS
showsPrec :: Int -> EmptyBucket -> ShowS
$cshow :: EmptyBucket -> TestName
show :: EmptyBucket -> TestName
$cshowList :: [EmptyBucket] -> ShowS
showList :: [EmptyBucket] -> ShowS
Show)

instance Exception EmptyBucket

-- | Make an actual configuration from a test configuration.
mkConfig :: MonadThrow m => TestConfig -> Config m
mkConfig :: forall (m :: * -> *). MonadThrow m => TestConfig -> Config m
mkConfig TestConfig{Rational
testCapacity :: TestConfig -> Rational
testCapacity :: Rational
testCapacity, Rational
testRate :: TestConfig -> Rational
testRate :: Rational
testRate, Bool
testThrowOnEmpty :: TestConfig -> Bool
testThrowOnEmpty :: Bool
testThrowOnEmpty} =
  Config
    { capacity :: Rational
capacity = Rational
testCapacity
    , rate :: Rational
rate = Rational
testRate
    , fillOnOverflow :: Bool
fillOnOverflow = Bool
True
    , onEmpty :: m ()
onEmpty =
        if Bool
testThrowOnEmpty
          then (EmptyBucket -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO EmptyBucket
EmptyBucket)
          else (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    }

-- | Make a configuration that fills on overflow and throws 'EmptyBucket' on
-- empty bucket.
configThrow :: Capacity -> Rate -> TestConfig
configThrow :: Capacity -> Rate -> TestConfig
configThrow (Capacity Rational
testCapacity) (Rate Rational
testRate) =
  TestConfig{Rational
testCapacity :: Rational
testCapacity :: Rational
testCapacity, Rational
testRate :: Rational
testRate :: Rational
testRate, testThrowOnEmpty :: Bool
testThrowOnEmpty = Bool
True}

-- | A configuration with capacity and rate 1, that fills on overflow and throws
-- 'EmptyBucket' on empty bucket.
config11Throw :: TestConfig
config11Throw :: TestConfig
config11Throw = Capacity -> Rate -> TestConfig
configThrow (Rational -> Capacity
Capacity Rational
1) (Rational -> Rate
Rate Rational
1)

-- | Make a configuration that fills on overflow and does nothing on empty
-- bucket.
configPure :: Capacity -> Rate -> TestConfig
configPure :: Capacity -> Rate -> TestConfig
configPure (Capacity Rational
testCapacity) (Rate Rational
testRate) =
  TestConfig{Rational
testCapacity :: Rational
testCapacity :: Rational
testCapacity, Rational
testRate :: Rational
testRate :: Rational
testRate, testThrowOnEmpty :: Bool
testThrowOnEmpty = Bool
False}

-- | A configuration with capacity 1 and rate 1, that fills on overflow and does
-- nothing on empty bucket.
config11Pure :: TestConfig
config11Pure :: TestConfig
config11Pure = Capacity -> Rate -> TestConfig
configPure (Rational -> Capacity
Capacity Rational
1) (Rational -> Rate
Rate Rational
1)

stateToTestState :: State m -> TestState
stateToTestState :: forall (m :: * -> *). State m -> TestState
stateToTestState State{Rational
level :: Rational
level :: forall (m :: * -> *). State m -> Rational
level, Time
time :: Time
time :: forall (m :: * -> *). State m -> Time
time, Bool
paused :: Bool
paused :: forall (m :: * -> *). State m -> Bool
paused} =
  TestState{testLevel :: Rational
testLevel = Rational
level, testTime :: Time
testTime = Time
time, testPaused :: Bool
testPaused = Bool
paused}

-- | 'execAgainstBucket' except it takes a 'TestConfig'.
testExecAgainstBucket ::
  ( MonadDelay m
  , MonadAsync m
  , MonadFork m
  , MonadMask m
  , MonadTimer m
  , NoThunks (m ())
  ) =>
  TestConfig ->
  (Handlers m -> m a) ->
  m a
testExecAgainstBucket :: forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m a
testExecAgainstBucket TestConfig
testConfig Handlers m -> m a
action =
  Config m -> (Handlers m -> m a) -> m a
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
Config m -> (Handlers m -> m a) -> m a
execAgainstBucket (TestConfig -> Config m
forall (m :: * -> *). MonadThrow m => TestConfig -> Config m
mkConfig TestConfig
testConfig) Handlers m -> m a
action

-- | 'evalAgainstBucket' except it takes a 'TestConfig' and returns a 'TestState'.
testEvalAgainstBucket ::
  ( MonadDelay m
  , MonadAsync m
  , MonadFork m
  , MonadMask m
  , MonadTimer m
  , NoThunks (m ())
  ) =>
  TestConfig ->
  (Handlers m -> m a) ->
  m TestState
testEvalAgainstBucket :: forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
testConfig Handlers m -> m a
action =
  State m -> TestState
forall (m :: * -> *). State m -> TestState
stateToTestState (State m -> TestState) -> m (State m) -> m TestState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config m -> (Handlers m -> m a) -> m (State m)
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
Config m -> (Handlers m -> m a) -> m (State m)
evalAgainstBucket (TestConfig -> Config m
forall (m :: * -> *). MonadThrow m => TestConfig -> Config m
mkConfig TestConfig
testConfig) Handlers m -> m a
action

-- | Alias for 'runSimOrThrow' by analogy to 'ioProperty'.
ioSimProperty :: forall a. (forall s. IOSim s a) -> a
ioSimProperty :: forall a. (forall s. IOSim s a) -> a
ioSimProperty = (forall s. IOSim s a) -> a
forall a. (forall s. IOSim s a) -> a
runSimOrThrow

-- | QuickCheck helper to check that a code threw the given exception.
shouldThrow :: (MonadCatch m, Show a, Exception e, Eq e) => m a -> e -> m Property
shouldThrow :: forall (m :: * -> *) a e.
(MonadCatch m, Show a, Exception e, Eq e) =>
m a -> e -> m Property
shouldThrow m a
a e
e =
  m a -> m (Either SomeException a)
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m a
a m (Either SomeException a)
-> (Either SomeException a -> Property) -> m Property
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Left SomeException
exn
      | SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
exn Maybe e -> Maybe e -> Bool
forall a. Eq a => a -> a -> Bool
== e -> Maybe e
forall a. a -> Maybe a
Just e
e -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      | Bool
otherwise ->
          TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Expected exception " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> TestName
forall a. Show a => a -> TestName
show e
e TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
"; got exception " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> TestName
forall a. Show a => a -> TestName
show SomeException
exn) Bool
False
    Right a
result -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Expected exception " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> TestName
forall a. Show a => a -> TestName
show e
e TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
"; got " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> TestName
forall a. Show a => a -> TestName
show a
result) Bool
False

-- | QuickCheck helper to check that a code evaluated to the given value.
shouldEvaluateTo :: (MonadCatch m, Eq a, Show a) => m a -> a -> m Property
shouldEvaluateTo :: forall (m :: * -> *) a.
(MonadCatch m, Eq a, Show a) =>
m a -> a -> m Property
shouldEvaluateTo m a
a a
v =
  m a -> m (Either SomeException a)
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m a
a m (Either SomeException a)
-> (Either SomeException a -> Property) -> m Property
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Right a
result
      | a
result a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      | Bool
otherwise -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Expected " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> TestName
forall a. Show a => a -> TestName
show a
v TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
"; got " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> TestName
forall a. Show a => a -> TestName
show a
result) Bool
False
    Left (SomeException
exn :: SomeException) -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Expected " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> TestName
forall a. Show a => a -> TestName
show a
v TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
"; got exception " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> TestName
forall e. Exception e => e -> TestName
displayException SomeException
exn) Bool
False

--------------------------------------------------------------------------------
-- Simple properties
--------------------------------------------------------------------------------

-- | One test case where we wait a bit, then fill, then wait some more. We then
-- should observe a state with a positive level.
prop_playABit :: Property
prop_playABit :: Property
prop_playABit =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
    TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket
      TestConfig
config11Throw
      ( \Handlers (IOSim s)
handlers -> do
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.5
          IOSim s FillResult -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s FillResult -> IOSim s ())
-> IOSim s FillResult -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ Handlers (IOSim s) -> Rational -> IOSim s FillResult
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Rational -> m FillResult
fill' Handlers (IOSim s)
handlers Rational
67
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.9
      )
      IOSim s TestState -> TestState -> IOSim s Property
forall (m :: * -> *) a.
(MonadCatch m, Eq a, Show a) =>
m a -> a -> m Property
`shouldEvaluateTo` TestState{testLevel :: Rational
testLevel = Integer
1 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
10, testTime :: Time
testTime = DiffTime -> Time
Time DiffTime
1.4, testPaused :: Bool
testPaused = Bool
False}

-- | One test case similar to 'prop_playABit' but we wait a bit too long and
-- should observe the triggering of the 'onEmpty' action.
prop_playTooLong :: Property
prop_playTooLong :: Property
prop_playTooLong =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
    TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket
      TestConfig
config11Throw
      ( \Handlers (IOSim s)
handlers -> do
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.5
          IOSim s FillResult -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s FillResult -> IOSim s ())
-> IOSim s FillResult -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ Handlers (IOSim s) -> Rational -> IOSim s FillResult
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Rational -> m FillResult
fill' Handlers (IOSim s)
handlers Rational
67
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1.1
      )
      IOSim s TestState -> EmptyBucket -> IOSim s Property
forall (m :: * -> *) a e.
(MonadCatch m, Show a, Exception e, Eq e) =>
m a -> e -> m Property
`shouldThrow` EmptyBucket
EmptyBucket

-- | One test case similar to 'prop_playTooLong' but 'onEmpty' does nothing and
-- therefore we should still observe a state at the end.
prop_playTooLongHarmless :: Property
prop_playTooLongHarmless :: Property
prop_playTooLongHarmless =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
    TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket
      TestConfig
config11Pure
      ( \Handlers (IOSim s)
handlers -> do
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.5
          IOSim s FillResult -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s FillResult -> IOSim s ())
-> IOSim s FillResult -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ Handlers (IOSim s) -> Rational -> IOSim s FillResult
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Rational -> m FillResult
fill' Handlers (IOSim s)
handlers Rational
67
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1.1
      )
      IOSim s TestState -> TestState -> IOSim s Property
forall (m :: * -> *) a.
(MonadCatch m, Eq a, Show a) =>
m a -> a -> m Property
`shouldEvaluateTo` TestState{testLevel :: Rational
testLevel = Rational
0, testTime :: Time
testTime = DiffTime -> Time
Time DiffTime
1.6, testPaused :: Bool
testPaused = Bool
False}

prop_playWithPause :: Property
prop_playWithPause :: Property
prop_playWithPause =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
    TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket
      TestConfig
config11Throw
      ( \Handlers (IOSim s)
handlers -> do
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.5
          Handlers (IOSim s) -> Bool -> IOSim s ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Bool -> m ()
setPaused' Handlers (IOSim s)
handlers Bool
True
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1.5
          Handlers (IOSim s) -> Bool -> IOSim s ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Bool -> m ()
setPaused' Handlers (IOSim s)
handlers Bool
False
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.4
      )
      IOSim s TestState -> TestState -> IOSim s Property
forall (m :: * -> *) a.
(MonadCatch m, Eq a, Show a) =>
m a -> a -> m Property
`shouldEvaluateTo` TestState{testLevel :: Rational
testLevel = Integer
1 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
10, testTime :: Time
testTime = DiffTime -> Time
Time DiffTime
2.4, testPaused :: Bool
testPaused = Bool
False}

prop_playWithPauseTooLong :: Property
prop_playWithPauseTooLong :: Property
prop_playWithPauseTooLong =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
    TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket
      TestConfig
config11Throw
      ( \Handlers (IOSim s)
handlers -> do
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.5
          Handlers (IOSim s) -> Bool -> IOSim s ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Bool -> m ()
setPaused' Handlers (IOSim s)
handlers Bool
True
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1.5
          Handlers (IOSim s) -> Bool -> IOSim s ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Bool -> m ()
setPaused' Handlers (IOSim s)
handlers Bool
False
          DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
0.6
      )
      IOSim s TestState -> EmptyBucket -> IOSim s Property
forall (m :: * -> *) a e.
(MonadCatch m, Show a, Exception e, Eq e) =>
m a -> e -> m Property
`shouldThrow` EmptyBucket
EmptyBucket

-- | A bunch of test cases where we wait exactly as much as the bucket runs
-- except for a given offset. If the offset is negative, we should get a
-- state. If the offset is positive, we should get an exception. NOTE: Do not
-- use an offset of @0@. NOTE: Considering the precision, we *need* IOSim for
-- this test.
prop_noRefill :: Bool -> Capacity -> Rate -> Property
prop_noRefill :: Bool -> Capacity -> Rate -> Property
prop_noRefill Bool
tooLong capacity :: Capacity
capacity@(Capacity Rational
c) rate :: Rate
rate@(Rate Rational
r) = do
  -- NOTE: The @-1@ is to ensure that we do not test the situation where the
  -- bucket empties at the *exact* same time (curtesy of IOSim) as the action.
  let ps :: Integer
ps =
        Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
c Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
r Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
picosecondsPerSecond)
          Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (if Bool
tooLong then Integer
1 else -Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
microsecondsPerSecond
      time :: DiffTime
time = Integer -> DiffTime
picosecondsToDiffTime Integer
ps
      level :: Rational
level = Rational
c Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- (Integer
ps Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
picosecondsPerSecond) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
r
  if Bool
tooLong
    then
      (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
        TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket (Capacity -> Rate -> TestConfig
configThrow Capacity
capacity Rate
rate) (\Handlers (IOSim s)
_ -> DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
time)
          IOSim s TestState -> EmptyBucket -> IOSim s Property
forall (m :: * -> *) a e.
(MonadCatch m, Show a, Exception e, Eq e) =>
m a -> e -> m Property
`shouldThrow` EmptyBucket
EmptyBucket
    else
      (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
        TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket (Capacity -> Rate -> TestConfig
configThrow Capacity
capacity Rate
rate) (\Handlers (IOSim s)
_ -> DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
time)
          IOSim s TestState -> TestState -> IOSim s Property
forall (m :: * -> *) a.
(MonadCatch m, Eq a, Show a) =>
m a -> a -> m Property
`shouldEvaluateTo` TestState{testLevel :: Rational
testLevel = Rational
level, testTime :: Time
testTime = DiffTime -> Time
Time DiffTime
time, testPaused :: Bool
testPaused = Bool
False}

--------------------------------------------------------------------------------
-- Exception propagation
--------------------------------------------------------------------------------

-- | A dummy exception that we will use to outrun the bucket.
data NoPlumberException = NoPlumberException
  deriving (NoPlumberException -> NoPlumberException -> Bool
(NoPlumberException -> NoPlumberException -> Bool)
-> (NoPlumberException -> NoPlumberException -> Bool)
-> Eq NoPlumberException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NoPlumberException -> NoPlumberException -> Bool
== :: NoPlumberException -> NoPlumberException -> Bool
$c/= :: NoPlumberException -> NoPlumberException -> Bool
/= :: NoPlumberException -> NoPlumberException -> Bool
Eq, Int -> NoPlumberException -> ShowS
[NoPlumberException] -> ShowS
NoPlumberException -> TestName
(Int -> NoPlumberException -> ShowS)
-> (NoPlumberException -> TestName)
-> ([NoPlumberException] -> ShowS)
-> Show NoPlumberException
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoPlumberException -> ShowS
showsPrec :: Int -> NoPlumberException -> ShowS
$cshow :: NoPlumberException -> TestName
show :: NoPlumberException -> TestName
$cshowList :: [NoPlumberException] -> ShowS
showList :: [NoPlumberException] -> ShowS
Show)

instance Exception NoPlumberException

-- | One test to check that throwing an exception in the action does propagate
-- outside of @*AgainstBucket@.
prop_propagateExceptions :: Property
prop_propagateExceptions :: Property
prop_propagateExceptions =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
    TestConfig
-> (Handlers (IOSim s) -> IOSim s (ZonkAny 0)) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
config11Throw (\Handlers (IOSim s)
_ -> NoPlumberException -> IOSim s (ZonkAny 0)
forall e a. Exception e => e -> IOSim s a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO NoPlumberException
NoPlumberException)
      IOSim s TestState -> NoPlumberException -> IOSim s Property
forall (m :: * -> *) a e.
(MonadCatch m, Show a, Exception e, Eq e) =>
m a -> e -> m Property
`shouldThrow` NoPlumberException
NoPlumberException

-- | Same as 'prop_propagateExceptions' except it runs in IO.
prop_propagateExceptionsIO :: Property
prop_propagateExceptionsIO :: Property
prop_propagateExceptionsIO =
  IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$
    TestConfig -> (Handlers IO -> IO (ZonkAny 1)) -> IO TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
config11Throw (\Handlers IO
_ -> NoPlumberException -> IO (ZonkAny 1)
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO NoPlumberException
NoPlumberException)
      IO TestState -> NoPlumberException -> IO Property
forall (m :: * -> *) a e.
(MonadCatch m, Show a, Exception e, Eq e) =>
m a -> e -> m Property
`shouldThrow` NoPlumberException
NoPlumberException

-- | One test to show that we can catch the 'EmptyBucket' exception from the
-- action itself, but that it is not wrapped in 'ExceptionInLinkedThread'.
prop_catchException :: Property
prop_catchException :: Property
prop_catchException =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
ioSimProperty ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
    TestConfig
-> (Handlers (IOSim s) -> IOSim s (Either EmptyBucket ()))
-> IOSim s (Either EmptyBucket ())
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m a
testExecAgainstBucket TestConfig
config11Throw (\Handlers (IOSim s)
_ -> IOSim s () -> IOSim s (Either EmptyBucket ())
forall e a. Exception e => IOSim s a -> IOSim s (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IOSim s () -> IOSim s (Either EmptyBucket ()))
-> IOSim s () -> IOSim s (Either EmptyBucket ())
forall a b. (a -> b) -> a -> b
$ DiffTime -> IOSim s ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1000)
      IOSim s (Either EmptyBucket ())
-> Either EmptyBucket () -> IOSim s Property
forall (m :: * -> *) a.
(MonadCatch m, Eq a, Show a) =>
m a -> a -> m Property
`shouldEvaluateTo` EmptyBucket -> Either EmptyBucket ()
forall a b. a -> Either a b
Left EmptyBucket
EmptyBucket

--------------------------------------------------------------------------------
-- Against a model
--------------------------------------------------------------------------------

-- | Abstract “actions” to be run. We can either wait by some time or refill the
-- bucket by some value.
data Action
  = Wait DiffTime
  | Fill Rational
  | SetPaused Bool
  | -- | Set the configuration, then wait the given time. Setting the
    -- configuration without waiting can lead to poorly defined situations.
    SetConfigWait TestConfig DiffTime
  deriving (Action -> Action -> Bool
(Action -> Action -> Bool)
-> (Action -> Action -> Bool) -> Eq Action
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Action -> Action -> Bool
== :: Action -> Action -> Bool
$c/= :: Action -> Action -> Bool
/= :: Action -> Action -> Bool
Eq, Int -> Action -> ShowS
[Action] -> ShowS
Action -> TestName
(Int -> Action -> ShowS)
-> (Action -> TestName) -> ([Action] -> ShowS) -> Show Action
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Action -> ShowS
showsPrec :: Int -> Action -> ShowS
$cshow :: Action -> TestName
show :: Action -> TestName
$cshowList :: [Action] -> ShowS
showList :: [Action] -> ShowS
Show)

-- | Random generation of 'Action's. The scales and frequencies are taken such
-- that we explore as many interesting cases as possible.
genAction :: Gen Action
genAction :: Gen Action
genAction =
  [(Int, Gen Action)] -> Gen Action
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, DiffTime -> Action
Wait (DiffTime -> Action) -> Gen DiffTime -> Gen Action
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen DiffTime
genDelay)
    , (Int
1, Rational -> Action
Fill (Rational -> Action) -> Gen Rational -> Gen Action
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int) -> Gen Rational -> Gen Rational
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000_000_000_000) (Gen Rational
forall a. Arbitrary a => Gen a
arbitrary Gen Rational -> (Rational -> Bool) -> Gen Rational
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
0)))
    , (Int
1, Bool -> Action
SetPaused (Bool -> Action) -> Gen Bool -> Gen Action
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
arbitrary)
    , (Int
1, TestConfig -> DiffTime -> Action
SetConfigWait (TestConfig -> DiffTime -> Action)
-> Gen TestConfig -> Gen (DiffTime -> Action)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TestConfig
forall a. Arbitrary a => Gen a
arbitrary Gen (DiffTime -> Action) -> Gen DiffTime -> Gen Action
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
genDelay)
    ]
 where
  genDelay :: Gen DiffTime
genDelay =
    Integer -> DiffTime
picosecondsToDiffTime (Integer -> DiffTime) -> Gen Integer -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int) -> Gen Integer -> Gen Integer
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
picosecondsPerSecond) (Gen Integer
forall a. Arbitrary a => Gen a
arbitrary Gen Integer -> (Integer -> Bool) -> Gen Integer
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0))

-- | How to run the 'Action's in a monad.
applyActions :: (MonadDelay m, MonadThrow m, MonadSTM m) => Handlers m -> [Action] -> m ()
applyActions :: forall (m :: * -> *).
(MonadDelay m, MonadThrow m, MonadSTM m) =>
Handlers m -> [Action] -> m ()
applyActions Handlers m
handlers = (Action -> m ()) -> [Action] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Action -> m ()) -> [Action] -> m ())
-> (Action -> m ()) -> [Action] -> m ()
forall a b. (a -> b) -> a -> b
$ \case
  Wait DiffTime
t -> DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
t
  Fill Rational
t -> m FillResult -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m FillResult -> m ()) -> m FillResult -> m ()
forall a b. (a -> b) -> a -> b
$ Handlers m -> Rational -> m FillResult
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Rational -> m FillResult
fill' Handlers m
handlers Rational
t
  SetPaused Bool
p -> Handlers m -> Bool -> m ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m -> Bool -> m ()
setPaused' Handlers m
handlers Bool
p
  SetConfigWait TestConfig
cfg DiffTime
t -> do
    Handlers m
-> ((Rational, Config m) -> (Rational, Config m)) -> m ()
forall (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m) =>
Handlers m
-> ((Rational, Config m) -> (Rational, Config m)) -> m ()
updateConfig' Handlers m
handlers (((Rational, Config m) -> (Rational, Config m)) -> m ())
-> ((Rational, Config m) -> (Rational, Config m)) -> m ()
forall a b. (a -> b) -> a -> b
$ (\(Rational
l, Config m
_) -> (Rational
l, TestConfig -> Config m
forall (m :: * -> *). MonadThrow m => TestConfig -> Config m
mkConfig TestConfig
cfg))
    DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
t

-- | A model of what we expect the 'Action's to lead to, either an 'EmptyBucket'
-- exception (if the bucket won the race) or a 'State' (otherwise).
modelActions :: TestConfig -> [Action] -> Either EmptyBucket TestState
modelActions :: TestConfig -> [Action] -> Either EmptyBucket TestState
modelActions TestConfig
testConfig =
  ((TestConfig, TestState) -> TestState
forall a b. (a, b) -> b
snd ((TestConfig, TestState) -> TestState)
-> Either EmptyBucket (TestConfig, TestState)
-> Either EmptyBucket TestState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
    (Either EmptyBucket (TestConfig, TestState)
 -> Either EmptyBucket TestState)
-> ([Action] -> Either EmptyBucket (TestConfig, TestState))
-> [Action]
-> Either EmptyBucket TestState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TestConfig, TestState)
 -> Action -> Either EmptyBucket (TestConfig, TestState))
-> (TestConfig, TestState)
-> [Action]
-> Either EmptyBucket (TestConfig, TestState)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
      (TestConfig, TestState)
-> Action -> Either EmptyBucket (TestConfig, TestState)
go
      (TestConfig
testConfig, TestState{testLevel :: Rational
testLevel = TestConfig -> Rational
testCapacity TestConfig
testConfig, testTime :: Time
testTime = DiffTime -> Time
Time DiffTime
0, testPaused :: Bool
testPaused = Bool
False})
 where
  go :: (TestConfig, TestState) -> Action -> Either EmptyBucket (TestConfig, TestState)
  go :: (TestConfig, TestState)
-> Action -> Either EmptyBucket (TestConfig, TestState)
go
    ( config :: TestConfig
config@TestConfig{Rational
testCapacity :: TestConfig -> Rational
testCapacity :: Rational
testCapacity, Rational
testRate :: TestConfig -> Rational
testRate :: Rational
testRate, Bool
testThrowOnEmpty :: TestConfig -> Bool
testThrowOnEmpty :: Bool
testThrowOnEmpty}
      , state :: TestState
state@TestState{Time
testTime :: TestState -> Time
testTime :: Time
testTime, Rational
testLevel :: TestState -> Rational
testLevel :: Rational
testLevel, Bool
testPaused :: TestState -> Bool
testPaused :: Bool
testPaused}
      ) = \case
      Fill Rational
t ->
        (TestConfig, TestState)
-> Either EmptyBucket (TestConfig, TestState)
forall a b. b -> Either a b
Right (TestConfig
config, TestState
state{testLevel = clamp (0, testCapacity) (testLevel + t)})
      Wait DiffTime
t ->
        let newTime :: Time
newTime = DiffTime -> Time -> Time
addTime DiffTime
t Time
testTime
            newLevel :: Rational
newLevel =
              if Bool
testPaused
                then Rational
testLevel
                else (Rational, Rational) -> Rational -> Rational
forall a. Ord a => (a, a) -> a -> a
clamp (Rational
0, Rational
testCapacity) (Rational
testLevel Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- DiffTime -> Rational
diffTimeToSecondsRational DiffTime
t Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
testRate)
         in if Rational
newLevel Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
0 Bool -> Bool -> Bool
&& Bool
testThrowOnEmpty
              then EmptyBucket -> Either EmptyBucket (TestConfig, TestState)
forall a b. a -> Either a b
Left EmptyBucket
EmptyBucket
              else (TestConfig, TestState)
-> Either EmptyBucket (TestConfig, TestState)
forall a b. b -> Either a b
Right (TestConfig
config, TestState
state{testTime = newTime, testLevel = newLevel})
      SetPaused Bool
newPaused ->
        (TestConfig, TestState)
-> Either EmptyBucket (TestConfig, TestState)
forall a b. b -> Either a b
Right (TestConfig
config, TestState
state{testPaused = newPaused})
      SetConfigWait newConfig :: TestConfig
newConfig@TestConfig{testCapacity :: TestConfig -> Rational
testCapacity = Rational
newTestCapacity} DiffTime
t ->
        (TestConfig, TestState)
-> Action -> Either EmptyBucket (TestConfig, TestState)
go (TestConfig
newConfig, TestState
state{testLevel = clamp (0, newTestCapacity) testLevel}) (DiffTime -> Action
Wait DiffTime
t)

-- | A bunch of test cases where we generate a list of 'Action's ,run them via
-- 'applyActions' and compare the result to that of 'modelActions'.
prop_random :: Property
prop_random :: Property
prop_random =
  Gen (TestConfig, [Action])
-> ((TestConfig, [Action]) -> [(TestConfig, [Action])])
-> ((TestConfig, [Action]) -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrinkBlind
    (Gen TestConfig -> Gen [Action] -> Gen (TestConfig, [Action])
forall a b. Gen a -> Gen b -> Gen (a, b)
forall (f :: * -> * -> *) a b.
Arbitrary2 f =>
Gen a -> Gen b -> Gen (f a b)
liftArbitrary2 Gen TestConfig
forall a. Arbitrary a => Gen a
arbitrary (Gen Action -> Gen [Action]
forall a. Gen a -> Gen [a]
listOf1 Gen Action
genAction))
    (([Action] -> [[Action]])
-> (TestConfig, [Action]) -> [(TestConfig, [Action])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (TestConfig, a) -> f (TestConfig, b)
traverse ((Action -> [Action]) -> [Action] -> [[Action]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([Action] -> Action -> [Action]
forall a b. a -> b -> a
const [])))
    (((TestConfig, [Action]) -> Property) -> Property)
-> ((TestConfig, [Action]) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(TestConfig
testConfig, [Action]
actions) ->
      let result :: Either EmptyBucket TestState
result =
            (forall s. IOSim s (Either EmptyBucket TestState))
-> Either EmptyBucket TestState
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
              ( IOSim s TestState -> IOSim s (Either EmptyBucket TestState)
forall e a. Exception e => IOSim s a -> IOSim s (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IOSim s TestState -> IOSim s (Either EmptyBucket TestState))
-> IOSim s TestState -> IOSim s (Either EmptyBucket TestState)
forall a b. (a -> b) -> a -> b
$
                  TestConfig
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall (m :: * -> *) a.
(MonadDelay m, MonadAsync m, MonadFork m, MonadMask m,
 MonadTimer m, NoThunks (m ())) =>
TestConfig -> (Handlers m -> m a) -> m TestState
testEvalAgainstBucket TestConfig
testConfig ((Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState)
-> (Handlers (IOSim s) -> IOSim s ()) -> IOSim s TestState
forall a b. (a -> b) -> a -> b
$
                    (Handlers (IOSim s) -> [Action] -> IOSim s ())
-> [Action] -> Handlers (IOSim s) -> IOSim s ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handlers (IOSim s) -> [Action] -> IOSim s ()
forall (m :: * -> *).
(MonadDelay m, MonadThrow m, MonadSTM m) =>
Handlers m -> [Action] -> m ()
applyActions [Action]
actions
              )
          modelResult :: Either EmptyBucket TestState
modelResult = TestConfig -> [Action] -> Either EmptyBucket TestState
modelActions TestConfig
testConfig [Action]
actions
          nbActions :: Int
nbActions = [Action] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action]
actions
       in Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Either EmptyBucket TestState -> Bool
forall a b. Either a b -> Bool
isLeft Either EmptyBucket TestState
modelResult) TestName
"bucket finished empty" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Either EmptyBucket TestState -> Bool
forall a b. Either a b -> Bool
isRight Either EmptyBucket TestState
modelResult) TestName
"bucket finished non-empty" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
              Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Int
nbActions Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
10) TestName
"<= 10 actions" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Int
10 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nbActions Bool -> Bool -> Bool
&& Int
nbActions Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
20) TestName
"11-20 actions" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                  Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Int
20 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nbActions Bool -> Bool -> Bool
&& Int
nbActions Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
50) TestName
"21-50 actions" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                    Bool -> TestName -> Property -> Property
forall prop. Testable prop => Bool -> TestName -> prop -> Property
classify (Int
50 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nbActions) TestName
"> 50 actions" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                      TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Config: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestConfig -> TestName
forall a. Show a => a -> TestName
show TestConfig
testConfig) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                        TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Actions:\n" TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ ([TestName] -> TestName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([TestName] -> TestName) -> [TestName] -> TestName
forall a b. (a -> b) -> a -> b
$ TestName -> [TestName] -> [TestName]
forall a. a -> [a] -> [a]
intersperse TestName
"\n" ([TestName] -> [TestName]) -> [TestName] -> [TestName]
forall a b. (a -> b) -> a -> b
$ (Action -> TestName) -> [Action] -> [TestName]
forall a b. (a -> b) -> [a] -> [b]
map ((TestName
" - " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Action -> TestName) -> Action -> TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action -> TestName
forall a. Show a => a -> TestName
show) [Action]
actions)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                          TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Result: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Either EmptyBucket TestState -> TestName
forall a. Show a => a -> TestName
show Either EmptyBucket TestState
result) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                            TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Model:  " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Either EmptyBucket TestState -> TestName
forall a. Show a => a -> TestName
show Either EmptyBucket TestState
modelResult) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
                              Either EmptyBucket TestState
result Either EmptyBucket TestState
-> Either EmptyBucket TestState -> Bool
forall a. Eq a => a -> a -> Bool
== Either EmptyBucket TestState
modelResult