Make object recovery settlement-safe

test/Spec.hs

@@ -1,7 +1,20 @@
 module Main (main) where
 
-import           Control.Exception (try)
+import           Control.Concurrent (threadDelay)
+import           Control.Concurrent.MVar
+  ( newEmptyMVar
+  , putMVar
+  , takeMVar
+  )
+import           Control.Exception
+  ( AsyncException (ThreadKilled)
+  , SomeException
+  , finally
+  , throwIO
+  , try
+  )
 import           Control.Monad.IO.Class (liftIO)
+import           Control.Retry (simulatePolicy)
 import           Control.Lens ((&), (?~))
 import           Crypto.JOSE (runJOSE)
 import           Crypto.JOSE.Compact (encodeCompact)
@@ -92,6 +105,12 @@ import           Nuthatch.Protocol
   , terminalExpiryEligible
   , terminalExpired
   )
+import           Nuthatch.Recovery
+  ( recoveryClaimEligible
+  , recoveryRetryPolicy
+  , trySynchronous
+  , withLinkedWorker
+  )
 import           Nuthatch.Types
 import           Nuthatch.Session (mintSession)
 import           Nuthatch.Streaming
@@ -109,6 +128,7 @@ import           Servant.Types.SourceT
   , fromStepT
   , source
   )
+import qualified System.Timeout as Timeout
 import           Test.Tasty (TestTree, defaultMain, testGroup)
 import           Test.Tasty.HUnit ((@?=), assertBool, assertFailure, testCase)
 import           Test.Tasty.Hedgehog (testProperty)
@@ -121,6 +141,7 @@ tests = testGroup "nuthatch-unit"
   [ pathTests
   , identityTests
   , protocolTests
+  , recoveryTests
   , streamingTests
   , oidcTests
   , apiTests
@@ -238,6 +259,42 @@ protocolTests = testGroup "mutation protocol decisions"
   , testProperty "only stale active records are recovery eligible" propRecoveryTiming
   ]
 
+recoveryTests :: TestTree
+recoveryTests = 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)
+  ]
+
 oidcTests :: TestTree
 oidcTests = testGroup "OIDC validation"
   [ testCase "accepts an exact RS256 ID token" testValidIdToken
@@ -874,6 +931,7 @@ testConfig = Config
   , cfgSearchMaxKeys = 100
   , cfgRecoveryGraceSec = 30
   , cfgIdempotencyWindowSec = 3600
+  , cfgObjectRequestTimeoutSec = 300
   }
 
 newtype ValidPath = ValidPath { getValidPath :: Text }
@@ -1029,6 +1087,28 @@ propRecoveryTiming = property $ do
   recoveryEligible state elapsed grace
     === (state `elem` [Prepared, Applying] && elapsed > grace)
 
+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
+        )
+
 genObservation :: Gen ObjectObservation
 genObservation = Gen.choice
   [ pure ObjectAbsent