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]