{-# options_haddock prune #-}
-- |Description: Monitor Implementations, Internal
module Polysemy.Conc.Monitor where

import Data.Default (Default (def))
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 (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 :: 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 :: 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 (r :: EffectRow). MemberWithError (Time t d) r => Sem r t
forall t d (r :: EffectRow).
MemberWithError (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 (IO Bool -> Sem r Bool
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed @IO (MVar () -> () -> IO Bool
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m 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 (r :: EffectRow). MemberWithError (Time t d) r => Sem r t
forall t d (r :: EffectRow).
MemberWithError (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)