97 lines
3.4 KiB
Haskell
97 lines
3.4 KiB
Haskell
module Nuthatch.Test.Recovery
|
|
( tests
|
|
) where
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Concurrent.MVar
|
|
( newEmptyMVar
|
|
, putMVar
|
|
, takeMVar
|
|
)
|
|
import Control.Exception
|
|
( AsyncException (ThreadKilled)
|
|
, SomeException
|
|
, finally
|
|
, throwIO
|
|
, try
|
|
)
|
|
import Control.Retry (simulatePolicy)
|
|
import Hedgehog (Gen, Property, forAll, property, (===))
|
|
import qualified Hedgehog.Gen as Gen
|
|
import qualified Hedgehog.Range as Range
|
|
import Nuthatch.Recovery
|
|
( recoveryClaimEligible
|
|
, recoveryRetryPolicy
|
|
, trySynchronous
|
|
, withLinkedWorker
|
|
)
|
|
import Nuthatch.Types (ExternalState (..), MutationState (..))
|
|
import qualified System.Timeout as Timeout
|
|
import Test.Tasty (TestTree, testGroup)
|
|
import Test.Tasty.HUnit (assertBool, assertFailure, testCase)
|
|
import Test.Tasty.Hedgehog (testProperty)
|
|
|
|
tests :: TestTree
|
|
tests = testGroup "recovery"
|
|
[ testProperty "worker lease and settlement independently gate recovery"
|
|
propRecoveryClaim
|
|
, testCase "asynchronous cancellation is not converted to failure" $ do
|
|
result <- try (trySynchronous (throwIO ThreadKilled))
|
|
:: IO (Either AsyncException (Either SomeException ()))
|
|
case result of
|
|
Left ThreadKilled -> pure ()
|
|
other -> assertFailure ("asynchronous exception was swallowed: " <> show other)
|
|
, testCase "linked worker failure interrupts the foreground" $ do
|
|
result <- Timeout.timeout 1000000 $
|
|
try (withLinkedWorker
|
|
(threadDelay 10000 >> fail "worker failed")
|
|
(threadDelay 5000000))
|
|
:: IO (Maybe (Either SomeException ()))
|
|
case result of
|
|
Just (Left _) -> pure ()
|
|
other -> assertFailure ("linked worker did not fail promptly: " <> show other)
|
|
, testCase "structured worker scope cancels and joins the worker" $ do
|
|
started <- newEmptyMVar
|
|
stopped <- newEmptyMVar
|
|
withLinkedWorker
|
|
(putMVar started () >>
|
|
(threadDelay 5000000 `finally` putMVar stopped ()))
|
|
(takeMVar started)
|
|
takeMVar stopped
|
|
, testCase "recovery retry policy has bounded exponential decisions" $ do
|
|
schedule <- simulatePolicy 8 recoveryRetryPolicy
|
|
let decisions = map snd schedule
|
|
retries = length [() | Just _ <- decisions]
|
|
assertBool "retry policy must retry" (retries > 0)
|
|
assertBool "retry policy must be bounded" (retries <= 5)
|
|
assertBool "retry policy must exhaust" (Nothing `elem` decisions)
|
|
]
|
|
|
|
propRecoveryClaim :: Property
|
|
propRecoveryClaim = property $ do
|
|
state <- forAll genMutationState
|
|
external <- forAll genExternalState
|
|
elapsed <- forAll (Gen.integral (Range.linear 0 10000))
|
|
grace <- forAll (Gen.integral (Range.linear 0 10000))
|
|
leaseExpired <- forAll Gen.bool
|
|
deadlineExpired <- forAll Gen.bool
|
|
recoveryClaimEligible
|
|
state
|
|
external
|
|
elapsed
|
|
grace
|
|
leaseExpired
|
|
deadlineExpired
|
|
=== ( state `elem` [Prepared, Applying]
|
|
&& case external of
|
|
ExtIdle -> elapsed > grace
|
|
ExtSettled -> elapsed > grace
|
|
ExtPending -> leaseExpired && deadlineExpired
|
|
)
|
|
|
|
genMutationState :: Gen MutationState
|
|
genMutationState =
|
|
Gen.element [Prepared, Applying, Succeeded, Failed, Rejected]
|
|
|
|
genExternalState :: Gen ExternalState
|
|
genExternalState = Gen.element [ExtIdle, ExtPending, ExtSettled]
|