{-# LANGUAGE OverloadedStrings #-}

module SupervisorSpec (spec) where

import Control.Concurrent (newEmptyMVar, putMVar, readMVar, threadDelay)
import Control.Concurrent.Async (async, cancel, poll, waitCatch)
import Control.Exception (fromException)
import Control.Exception.Annotated (AnnotatedException (..), throw)
import Control.Monad (forever)
import Data.IORef (atomicModifyIORef', newIORef, readIORef)
import Data.Maybe (isJust, isNothing)
import HomeAssistant.Runtime.Supervisor
import Test.Hspec

tinyBackoff :: Backoff
tinyBackoff = Backoff 0.001 0.002 0.001

spec :: Spec
spec = describe "supervised" $ do
  it "restarts a crashing action until it stays up" $ do
    counter <- newIORef (0 :: Int)
    up <- newEmptyMVar
    let action = do
          n <- atomicModifyIORef' counter (\c -> (c + 1, c + 1))
          if n < 3
            then ioError (userError "boom")
            else do putMVar up (); forever (threadDelay 1000000)
    sup <- async (supervised "test" tinyBackoff action)
    readMVar up
    threadDelay 50000
    status <- poll sup
    isNothing status `shouldBe` True
    readIORef counter `shouldReturn` 3
    cancel sup

  it "rethrows Fatal instead of restarting" $ do
    counter <- newIORef (0 :: Int)
    let action = do
          _ <- atomicModifyIORef' counter (\c -> (c + 1, c + 1))
          throw (Fatal "auth_invalid")
    sup <- async (supervised "test" tinyBackoff action)
    res <- waitCatch sup
    case res of
      Left se -> case fromException se :: Maybe (AnnotatedException Fatal) of
        Just _  -> pure ()
        Nothing -> expectationFailure "expected Fatal to propagate"
      Right _ -> expectationFailure "supervised returned"
    threadDelay 50000
    readIORef counter `shouldReturn` 1

  it "does not restart on async exceptions" $ do
    counter <- newIORef (0 :: Int)
    let action = do
          _ <- atomicModifyIORef' counter (\c -> (c + 1, c + 1))
          forever (threadDelay 1000000)
    sup <- async (supervised "test" tinyBackoff action)
    threadDelay 100000
    cancel sup
    threadDelay 100000
    readIORef counter `shouldReturn` 1
    status <- poll sup
    isJust status `shouldBe` True

  describe "nextAttempt" $ do
    it "resets after a quiet period" $
      nextAttempt tinyBackoff 0.001 5 `shouldBe` 1
    it "increments otherwise" $
      nextAttempt tinyBackoff 0.0005 5 `shouldBe` 6

  describe "backoffDelay" $ do
    it "starts at base" $ backoffDelay tinyBackoff 1 `shouldBe` 0.001
    it "doubles" $ backoffDelay tinyBackoff 2 `shouldBe` 0.002
    it "clamps at cap" $ backoffDelay tinyBackoff 3 `shouldBe` 0.002