-- | Repeat suppression for a failure a looping action keeps hitting.
module Arbiter.Core.FailureGate
  ( FailureGate
  , newFailureGate
  , holdFailure
  , clearFailure
  , defaultFailureRepeatInterval
  ) where

import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.IORef (IORef, atomicModifyIORef', newIORef)
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Time (NominalDiffTime)
import GHC.Clock (getMonotonicTime)

-- | The last failure a repeating action reported and its time. Empty while healthy.
newtype FailureGate = FailureGate (IORef (Maybe (Text, Double)))

-- | A gate for one repeating action, starting healthy.
newFailureGate :: (MonadIO m) => m FailureGate
newFailureGate :: forall (m :: * -> *). MonadIO m => m FailureGate
newFailureGate = IORef (Maybe (Text, Double)) -> FailureGate
FailureGate (IORef (Maybe (Text, Double)) -> FailureGate)
-> m (IORef (Maybe (Text, Double))) -> m FailureGate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IORef (Maybe (Text, Double)))
-> m (IORef (Maybe (Text, Double)))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe (Text, Double) -> IO (IORef (Maybe (Text, Double)))
forall a. a -> IO (IORef a)
newIORef Maybe (Text, Double)
forall a. Maybe a
Nothing)

-- | Gap between repeats of a standing failure.
defaultFailureRepeatInterval :: NominalDiffTime
defaultFailureRepeatInterval :: NominalDiffTime
defaultFailureRepeatInterval = NominalDiffTime
60

-- | Take @failure@ as the one the gate holds. True when it is worth reporting.
holdFailure :: (MonadIO m) => FailureGate -> NominalDiffTime -> Text -> m Bool
holdFailure :: forall (m :: * -> *).
MonadIO m =>
FailureGate -> NominalDiffTime -> Text -> m Bool
holdFailure (FailureGate IORef (Maybe (Text, Double))
ref) NominalDiffTime
repeatAfter Text
failure = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
  now <- IO Double
getMonotonicTime
  atomicModifyIORef' ref $ \Maybe (Text, Double)
held ->
    let worth :: Bool
worth = Bool -> ((Text, Double) -> Bool) -> Maybe (Text, Double) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\(Text
heldFailure, Double
heldAt) -> Text
heldFailure Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
failure Bool -> Bool -> Bool
|| Double
now Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
heldAt Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
repeatAfter) Maybe (Text, Double)
held
     in (if Bool
worth then (Text, Double) -> Maybe (Text, Double)
forall a. a -> Maybe a
Just (Text
failure, Double
now) else Maybe (Text, Double)
held, Bool
worth)

-- | Drop whatever the gate holds. True when it held a failure.
clearFailure :: (MonadIO m) => FailureGate -> m Bool
clearFailure :: forall (m :: * -> *). MonadIO m => FailureGate -> m Bool
clearFailure (FailureGate IORef (Maybe (Text, Double))
ref) =
  IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (Text, Double))
-> (Maybe (Text, Double) -> (Maybe (Text, Double), Bool))
-> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Maybe (Text, Double))
ref (\Maybe (Text, Double)
held -> (Maybe (Text, Double)
forall a. Maybe a
Nothing, Maybe (Text, Double) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Text, Double)
held))