{-# options_haddock prune #-}
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))
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)
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)
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)