Split host tests by component ownership

test/Nuthatch/Test/Recovery.hs

@@ -0,0 +1,97 @@
+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]