{-# LANGUAGE TemplateHaskell #-}

-- | This module provides functionality for handling events.
module Navi.Event
  ( -- * Event type
    Event (..),
    AnyEvent (..),
    runEvent,

    -- * Results
    EventSuccess (..),
    EventError (..),

    -- * Caching previous events/errors
    RepeatEvent (..),
    ErrorNote (..),
    blockRepeat,
    blockErr,
    updatePrevTrigger,
  )
where

import Data.Set qualified as Set
import Navi.Effects (MonadSystemInfo (query))
import Navi.Event.Types
  ( AnyEvent (..),
    ErrorNote (..),
    Event (..),
    EventError (..),
    EventSuccess (..),
    RepeatEvent (..),
  )
import Navi.Prelude

-- | Runs an event, i.e.,
--
-- 1. Queries the system via 'MonadSystemInfo'.
-- 2. Returns the parsed result.
runEvent ::
  ( HasCallStack,
    MonadLoggerNS m env k,
    MonadSystemInfo m,
    Show result
  ) =>
  Event result trigger ->
  m (EventSuccess result trigger)
runEvent :: forall (m :: Type -> Type) env k result trigger.
(HasCallStack, MonadLoggerNS m env k, MonadSystemInfo m,
 Show result) =>
Event result trigger -> m (EventSuccess result trigger)
runEvent Event result trigger
event = Text
-> m (EventSuccess result trigger)
-> m (EventSuccess result trigger)
forall (m :: Type -> Type) env a k.
(Is k A_Setter, LabelOptic' "namespace" k env Namespace,
 MonadReader env m) =>
Text -> m a -> m a
addNamespace Text
"runEvent" (m (EventSuccess result trigger)
 -> m (EventSuccess result trigger))
-> m (EventSuccess result trigger)
-> m (EventSuccess result trigger)
forall a b. (a -> b) -> a -> b
$ do
  (result
result, Maybe PollInterval
pollInterval) <- ServiceType result -> m (result, Maybe PollInterval)
forall result.
HasCallStack =>
ServiceType result -> m (result, Maybe PollInterval)
forall (m :: Type -> Type) result.
(MonadSystemInfo m, HasCallStack) =>
ServiceType result -> m (result, Maybe PollInterval)
query (ServiceType result -> m (result, Maybe PollInterval))
-> ServiceType result -> m (result, Maybe PollInterval)
forall a b. (a -> b) -> a -> b
$ Event result trigger
event Event result trigger
-> Optic' A_Lens NoIx (Event result trigger) (ServiceType result)
-> ServiceType result
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (Event result trigger) (ServiceType result)
#serviceType
  $(logInfo) (Text
"Shell returned: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> result -> Text
forall a. Show a => a -> Text
showt result
result)
  pure
    $ MkEventSuccess
      { Maybe PollInterval
pollInterval :: Maybe PollInterval
pollInterval :: Maybe PollInterval
pollInterval,
        result
result :: result
result :: result
result,
        repeatEvent :: RepeatEvent trigger
repeatEvent = Event result trigger
event Event result trigger
-> Optic' A_Lens NoIx (Event result trigger) (RepeatEvent trigger)
-> RepeatEvent trigger
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (Event result trigger) (RepeatEvent trigger)
#repeatEvent,
        raiseAlert :: result -> Maybe (trigger, NaviNote)
raiseAlert = Event result trigger
event Event result trigger
-> Optic'
     A_Lens
     NoIx
     (Event result trigger)
     (result -> Maybe (trigger, NaviNote))
-> result
-> Maybe (trigger, NaviNote)
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic'
  A_Lens
  NoIx
  (Event result trigger)
  (result -> Maybe (trigger, NaviNote))
#raiseAlert
      }
{-# INLINEABLE runEvent #-}

-- | Determines if we should block the event. The semantics are:
--
-- 1. 'AllowRepeats': never block (returns 'False').
-- 2. 'NoRepeats': block only if the parameter @a@ equals the previous @a@
--    stored in our @ref@.
blockRepeat ::
  ( Ord a,
    MonadLoggerNS m env k,
    MonadIORef m,
    Show a
  ) =>
  RepeatEvent a ->
  a ->
  m Bool
blockRepeat :: forall a (m :: Type -> Type) env k.
(Ord a, MonadLoggerNS m env k, MonadIORef m, Show a) =>
RepeatEvent a -> a -> m Bool
blockRepeat RepeatEvent a
repeatEvent a
newVal = Text -> m Bool -> m Bool
forall (m :: Type -> Type) env a k.
(Is k A_Setter, LabelOptic' "namespace" k env Namespace,
 MonadReader env m) =>
Text -> m a -> m a
addNamespace Text
"blockRepeat" (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
  case RepeatEvent a
repeatEvent of
    -- Repeat events are allowed, so do not block.
    RepeatEvent a
AllowRepeats -> Bool -> m Bool
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
False
    -- Repeat events are not allowed, must check.
    SomeRepeats Set a
allowed IORef (Maybe a)
prevRef -> Set a -> IORef (Maybe a) -> m Bool
checkRepeat Set a
allowed IORef (Maybe a)
prevRef
    NoRepeats IORef (Maybe a)
prevRef -> Set a -> IORef (Maybe a) -> m Bool
checkRepeat Set a
forall a. Set a
Set.empty IORef (Maybe a)
prevRef
  where
    checkRepeat :: Set a -> IORef (Maybe a) -> m Bool
checkRepeat Set a
allowed IORef (Maybe a)
prevRef = do
      Maybe a
prevVal <- IORef (Maybe a) -> m (Maybe a)
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef IORef (Maybe a)
prevRef
      $(logDebug) (Text
"Previous value: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe a -> Text
forall a. Show a => a -> Text
showt Maybe a
prevVal)
      $(logDebug) (Text
"New value: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
newVal)
      if Maybe a
prevVal Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Maybe a
forall a. a -> Maybe a
Just a
newVal
        then -- Already sent this alert, check if repeats are allowed.
          if a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
newVal Set a
allowed
            then do
              -- Repeats are allowed for this value.
              $(logDebug) Text
"Repeats are allowed for this value."
              pure Bool
False
            else
              -- Repeats are not allowed for this value, block.
              Bool -> m Bool
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
True
        else -- New alert, do not block.
          do
            IORef (Maybe a) -> Maybe a -> m ()
forall a. HasCallStack => IORef a -> a -> m ()
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> a -> m ()
writeIORef IORef (Maybe a)
prevRef (Maybe a -> m ()) -> Maybe a -> m ()
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
newVal
            pure Bool
False
{-# INLINEABLE blockRepeat #-}

-- | Determines if we should block the error event. The semantics are:
--
-- 1. 'NoErrNote': always block (returns 'True').
-- 2. 'AllowErrNote' 'AllowRepeats': never block (returns 'False').
-- 3. 'AllowErrNote' 'NoRepeats': block only if we have sent a notifcation
--    for this error before.
blockErr ::
  ( MonadLoggerNS m env k,
    MonadIORef m
  ) =>
  ErrorNote ->
  m Bool
blockErr :: forall (m :: Type -> Type) env k.
(MonadLoggerNS m env k, MonadIORef m) =>
ErrorNote -> m Bool
blockErr ErrorNote
errorEvent = Text -> m Bool -> m Bool
forall (m :: Type -> Type) env a k.
(Is k A_Setter, LabelOptic' "namespace" k env Namespace,
 MonadReader env m) =>
Text -> m a -> m a
addNamespace Text
"blockErr" (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
  case ErrorNote
errorEvent of
    -- Error events are off, block.
    ErrorNote
NoErrNote -> do
      $(logDebug) Text
"Error notes are off"
      pure Bool
True
    -- Error events are on and repeats allowed, do not block.
    AllowErrNote RepeatEvent ()
AllowRepeats -> do
      $(logDebug) Text
"Error notes are on and repeats allowed"
      pure Bool
False
    -- Error events are on but repeats not allowed, must check.
    AllowErrNote (SomeRepeats Set ()
_ IORef (Maybe ())
ref) -> IORef (Maybe ()) -> m Bool
forall {m :: Type -> Type}.
(MonadIORef m, MonadLogger m) =>
IORef (Maybe ()) -> m Bool
checkRepeat IORef (Maybe ())
ref
    AllowErrNote (NoRepeats IORef (Maybe ())
ref) -> IORef (Maybe ()) -> m Bool
forall {m :: Type -> Type}.
(MonadIORef m, MonadLogger m) =>
IORef (Maybe ()) -> m Bool
checkRepeat IORef (Maybe ())
ref
  where
    checkRepeat :: IORef (Maybe ()) -> m Bool
checkRepeat IORef (Maybe ())
ref = do
      Maybe ()
prevErr <- IORef (Maybe ()) -> m (Maybe ())
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef IORef (Maybe ())
ref
      case Maybe ()
prevErr of
        -- Already sent this error, block
        Just () -> do
          $(logDebug) Text
"Already sent error"
          pure Bool
True
        -- Error not send, do not block
        Maybe ()
Nothing -> do
          $(logDebug) Text
"Send error"
          IORef (Maybe ()) -> Maybe () -> m ()
forall a. HasCallStack => IORef a -> a -> m ()
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> a -> m ()
writeIORef IORef (Maybe ())
ref (Maybe () -> m ()) -> Maybe () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> Maybe ()
forall a. a -> Maybe a
Just ()
          pure Bool
False
{-# INLINEABLE blockErr #-}

-- | If the reference is 'NoRepeats' or 'SomeRepeats' then we overwrite the
-- previous reference with the new parameter. Otherwise we do nothing.
updatePrevTrigger :: (Eq a, MonadIORef m) => RepeatEvent a -> Maybe a -> m ()
updatePrevTrigger :: forall a (m :: Type -> Type).
(Eq a, MonadIORef m) =>
RepeatEvent a -> Maybe a -> m ()
updatePrevTrigger RepeatEvent a
repeatEvent Maybe a
newVal =
  -- Only overwrite value if it's new
  case RepeatEvent a
repeatEvent of
    NoRepeats IORef (Maybe a)
ref -> do
      Maybe a
val <- IORef (Maybe a) -> m (Maybe a)
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef IORef (Maybe a)
ref
      Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe a
val Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe a
newVal) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe a) -> Maybe a -> m ()
forall a. HasCallStack => IORef a -> a -> m ()
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> a -> m ()
writeIORef IORef (Maybe a)
ref Maybe a
newVal
    SomeRepeats Set a
_ IORef (Maybe a)
ref -> do
      Maybe a
val <- IORef (Maybe a) -> m (Maybe a)
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef IORef (Maybe a)
ref
      Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Maybe a
val Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe a
newVal) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe a) -> Maybe a -> m ()
forall a. HasCallStack => IORef a -> a -> m ()
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> a -> m ()
writeIORef IORef (Maybe a)
ref Maybe a
newVal
    RepeatEvent a
AllowRepeats -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
{-# INLINEABLE updatePrevTrigger #-}