{-# options_haddock prune #-}

-- |Description: Monitor Implementations, Internal
module Polysemy.Conc.Monitor where

import qualified Polysemy.Time as Time
import Polysemy.Time (Minutes (Minutes), NanoSeconds, Seconds (Seconds), Time, TimeUnit, convert)
import Torsor (Torsor, difference, minus)

import Polysemy.Conc.Effect.Monitor (MonitorCheck (MonitorCheck))

-- |Config for 'monitorClockSkew'.
data ClockSkewConfig =
  ClockSkewConfig {
    ClockSkewConfig -> NanoSeconds
interval :: NanoSeconds,
    ClockSkewConfig -> NanoSeconds
tolerance :: NanoSeconds
  }
  deriving stock (ClockSkewConfig -> ClockSkewConfig -> Bool
(ClockSkewConfig -> ClockSkewConfig -> Bool)
-> (ClockSkewConfig -> ClockSkewConfig -> Bool)
-> Eq ClockSkewConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClockSkewConfig -> ClockSkewConfig -> Bool
$c/= :: ClockSkewConfig -> ClockSkewConfig -> Bool
== :: ClockSkewConfig -> ClockSkewConfig -> Bool
$c== :: ClockSkewConfig -> ClockSkewConfig -> Bool
Eq, Int -> ClockSkewConfig -> ShowS
[ClockSkewConfig] -> ShowS
ClockSkewConfig -> String
(Int -> ClockSkewConfig -> ShowS)
-> (ClockSkewConfig -> String)
-> ([ClockSkewConfig] -> ShowS)
-> Show ClockSkewConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClockSkewConfig] -> ShowS
$cshowList :: [ClockSkewConfig] -> ShowS
show :: ClockSkewConfig -> String
$cshow :: ClockSkewConfig -> String
showsPrec :: Int -> ClockSkewConfig -> ShowS
$cshowsPrec :: Int -> ClockSkewConfig -> ShowS
Show)

-- |Smart constructor for 'ClockSkewConfig' that takes arbitrary 'TimeUnit's.
clockSkewConfig ::
  TimeUnit u1 =>
  TimeUnit u2 =>
  u1 ->
  u2 ->
  ClockSkewConfig
clockSkewConfig :: forall u1 u2.
(TimeUnit u1, TimeUnit u2) =>
u1 -> u2 -> ClockSkewConfig
clockSkewConfig u1
i u2
t =
  NanoSeconds -> NanoSeconds -> ClockSkewConfig
ClockSkewConfig (u1 -> NanoSeconds
forall a b. (TimeUnit a, TimeUnit b) => a -> b
convert u1
i) (u2 -> NanoSeconds
forall a b. (TimeUnit a, TimeUnit b) => a -> b
convert u2
t)

instance Default ClockSkewConfig where
  def :: ClockSkewConfig
def =
    Minutes -> Seconds -> ClockSkewConfig
forall u1 u2.
(TimeUnit u1, TimeUnit u2) =>
u1 -> u2 -> ClockSkewConfig
clockSkewConfig (Int64 -> Minutes
Minutes Int64
1) (Int64 -> Seconds
Seconds Int64
5)

-- |Check for 'Polysemy.Conc.Effect.Monitor' that checks every @interval@ whether the difference between the current
-- time and the time at the last check is larger than @interval@ + @tolerance@.
-- Can be used to detect that the operating system suspended and resumed.
monitorClockSkew ::
  ∀ t d diff r .
  Torsor t diff =>
  TimeUnit diff =>
  Members [AtomicState (Maybe t), Time t d, Embed IO] r =>
  ClockSkewConfig ->
  MonitorCheck r
monitorClockSkew :: forall t d diff (r :: EffectRow).
(Torsor t diff, TimeUnit diff,
 Members '[AtomicState (Maybe t), Time t d, Embed IO] r) =>
ClockSkewConfig -> MonitorCheck r
monitorClockSkew (ClockSkewConfig NanoSeconds
interval NanoSeconds
tolerance) =
  NanoSeconds -> (MVar () -> Sem r ()) -> MonitorCheck r
forall (r :: EffectRow).
NanoSeconds -> (MVar () -> Sem r ()) -> MonitorCheck r
MonitorCheck NanoSeconds
interval \ MVar ()
signal -> do
    Sem r (Maybe t)
forall s (r :: EffectRow). Member (AtomicState s) r => Sem r s
atomicGet Sem r (Maybe t) -> (Maybe t -> Sem r ()) -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just t
prev -> do
        t
now <- forall t d (r :: EffectRow). Member (Time t d) r => Sem r t
Time.now @t @d
        Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NanoSeconds -> NanoSeconds -> NanoSeconds
forall v. Additive v => v -> v -> v
minus (diff -> NanoSeconds
forall a b. (TimeUnit a, TimeUnit b) => a -> b
convert (t -> t -> diff
forall p v. Torsor p v => p -> p -> v
difference t
now t
prev)) NanoSeconds
tolerance NanoSeconds -> NanoSeconds -> Bool
forall a. Ord a => a -> a -> Bool
> NanoSeconds
interval) (Sem r Bool -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed @IO (MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
signal ())))
        Maybe t -> Sem r ()
forall s (r :: EffectRow).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut (t -> Maybe t
forall a. a -> Maybe a
Just t
now)
      Maybe t
Nothing -> do
        t
now <- forall t d (r :: EffectRow). Member (Time t d) r => Sem r t
Time.now @t @d
        Maybe t -> Sem r ()
forall s (r :: EffectRow).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut (t -> Maybe t
forall a. a -> Maybe a
Just t
now)