{-# 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.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 Any) -> 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 Any
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 Any) -> 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 Any
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

-- NOTE: Needed for GHC 8
clamp :: Ord a => (a, a) -> a -> a
clamp :: forall a. Ord a => (a, a) -> a -> a
clamp (a
low, a
high) a
x = a -> a -> a
forall a. Ord a => a -> a -> a
min a
high (a -> a -> a
forall a. Ord a => a -> a -> a
max a
low a
x)