{-# LANGUAGE TemplateHaskell #-}

-- | This module provides the core application type and logic.
module Navi
  ( -- * Entry point
    runNavi,

    -- * Application Types
    NaviT (..),
    runNaviT,
  )
where

import DBus.Client (ClientError (clientErrorFatal))
import DBus.Notify (UrgencyLevel (Critical, Normal))
import Effects.Concurrent.Async qualified as Async
import Effects.Concurrent.STM (flushTBQueueA)
import Effects.Concurrent.Thread (MonadThread (labelThread, myThreadId), sleep)
import Effects.Logger.Namespace (logStrToBs)
import Effects.System.Terminal (MonadTerminal (putBinary))
import Navi.Data.NaviLog (LogEnv)
import Navi.Data.NaviNote
  ( NaviNote
      ( MkNaviNote,
        body,
        summary,
        timeout,
        urgency
      ),
    Timeout (Seconds),
  )
import Navi.Data.PollInterval (PollInterval)
import Navi.Effects.MonadNotify (MonadNotify (sendNote))
import Navi.Effects.MonadSystemInfo (MonadSystemInfo)
import Navi.Env.Core
  ( HasEvents (getEvents),
    HasLogEnv (getLogEnv),
    HasNoteQueue (getNoteQueue),
    sendNoteQueue,
  )
import Navi.Event qualified as Event
import Navi.Event.Types
  ( AnyEvent (MkAnyEvent),
    EventError,
    EventSuccess,
  )
import Navi.NaviT (NaviT (..), runNaviT)
import Navi.Prelude
import Navi.Utils qualified as U

-- | Entry point for the application.
runNavi ::
  forall env m k.
  ( HasCallStack,
    HasEvents env,
    HasLogEnv env,
    HasNoteQueue env,
    MonadAsync m,
    MonadHandleWriter m,
    MonadIORef m,
    MonadLoggerNS m env k,
    MonadMask m,
    MonadNotify m,
    MonadSTM m,
    MonadSystemInfo m,
    MonadTerminal m,
    MonadThread m
  ) =>
  m Void
runNavi :: forall env (m :: Type -> Type) k.
(HasCallStack, HasEvents env, HasLogEnv env, HasNoteQueue env,
 MonadAsync m, MonadHandleWriter m, MonadIORef m,
 MonadLoggerNS m env k, MonadMask m, MonadNotify m, MonadSTM m,
 MonadSystemInfo m, MonadTerminal m, MonadThread m) =>
m Void
runNavi = do
  let welcome :: NaviNote
welcome =
        MkNaviNote
          { summary :: Text
summary = Text
"Navi",
            body :: Maybe Text
body = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Navi is up :-)",
            urgency :: Maybe UrgencyLevel
urgency = UrgencyLevel -> Maybe UrgencyLevel
forall a. a -> Maybe a
Just UrgencyLevel
Normal,
            timeout :: Maybe Timeout
timeout = Timeout -> Maybe Timeout
forall a. a -> Maybe a
Just (Timeout -> Maybe Timeout) -> Timeout -> Maybe Timeout
forall a b. (a -> b) -> a -> b
$ Word16 -> Timeout
Seconds Word16
10
          }
  NaviNote -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasNoteQueue env, MonadReader env m, MonadSTM m) =>
NaviNote -> m ()
sendNoteQueue NaviNote
welcome
  NonEmpty AnyEvent
events <- (env -> NonEmpty AnyEvent) -> m (NonEmpty AnyEvent)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> NonEmpty AnyEvent
forall env. HasEvents env => env -> NonEmpty AnyEvent
getEvents
  NonEmpty AnyEvent -> m Void
forall (t :: Type -> Type).
(HasCallStack, Traversable t) =>
t AnyEvent -> m Void
runAllAsync NonEmpty AnyEvent
events
  where
    runAllAsync ::
      ( HasCallStack,
        Traversable t
      ) =>
      t AnyEvent ->
      m Void
    runAllAsync :: forall (t :: Type -> Type).
(HasCallStack, Traversable t) =>
t AnyEvent -> m Void
runAllAsync t AnyEvent
evts = do
      Maybe LogEnv
mLogEnv <- (env -> Maybe LogEnv) -> m (Maybe LogEnv)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> Maybe LogEnv
forall env. HasLogEnv env => env -> Maybe LogEnv
getLogEnv
      case Maybe LogEnv
mLogEnv of
        -- 1. No logging: just run the events.
        Maybe LogEnv
Nothing -> t AnyEvent -> m Void
forall (t :: Type -> Type).
(HasCallStack, Traversable t) =>
t AnyEvent -> m Void
runEvents t AnyEvent
evts
        -- 2. Logging: Run the events and the logger.
        Just LogEnv
logEnv -> do
          m Void -> (Async Void -> m Void) -> m Void
forall a b. HasCallStack => m a -> (Async a -> m b) -> m b
forall (m :: Type -> Type) a b.
(MonadAsync m, HasCallStack) =>
m a -> (Async a -> m b) -> m b
Async.withAsync (LogEnv -> m Void
forall (m :: Type -> Type) env k.
(HasCallStack, MonadLoggerNS m env k, MonadHandleWriter m,
 MonadMask m, MonadSTM m, MonadTerminal m) =>
LogEnv -> m Void
pollLogQueue LogEnv
logEnv) ((Async Void -> m Void) -> m Void)
-> (Async Void -> m Void) -> m Void
forall a b. (a -> b) -> a -> b
$ \Async Void
logThread -> do
            -- NOTE: Need the link here _before_ we run the other two threads.
            -- This ensures that a logger exception successfully kills the entire
            -- app.
            Async Void -> m ()
forall a. HasCallStack => Async a -> m ()
forall (m :: Type -> Type) a.
(MonadAsync m, HasCallStack) =>
Async a -> m ()
Async.link Async Void
logThread
            t AnyEvent -> m Void
forall (t :: Type -> Type).
(HasCallStack, Traversable t) =>
t AnyEvent -> m Void
runEvents t AnyEvent
evts
              m Void -> (SomeException -> m Void) -> m Void
forall (m :: Type -> Type) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchSync` \SomeException
e -> do
                Async Void -> m ()
forall a. HasCallStack => Async a -> m ()
forall (m :: Type -> Type) a.
(MonadAsync m, HasCallStack) =>
Async a -> m ()
Async.cancel Async Void
logThread
                -- handle remaining logs
                let queue :: TBQueue LogStr
queue = LogEnv
logEnv LogEnv
-> Optic' A_Lens NoIx LogEnv (TBQueue LogStr) -> TBQueue LogStr
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx LogEnv (TBQueue LogStr)
#logQueue
                    sendFn :: ByteString -> m ()
sendFn = LogEnv -> ByteString -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadHandleWriter m, MonadTerminal m) =>
LogEnv -> ByteString -> m ()
getLoggerFn LogEnv
logEnv
                TBQueue LogStr -> m [LogStr]
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
TBQueue a -> m [a]
flushTBQueueA TBQueue LogStr
queue m [LogStr] -> ([LogStr] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (LogStr -> m ()) -> [LogStr] -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ByteString -> m ()
sendFn (ByteString -> m ()) -> (LogStr -> ByteString) -> LogStr -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LogStr -> ByteString
logStrToBs)
                SomeException -> m Void
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: Type -> Type) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM SomeException
e

    -- run events and notify threads
    runEvents :: (HasCallStack, Traversable t) => t AnyEvent -> m Void
    runEvents :: forall (t :: Type -> Type).
(HasCallStack, Traversable t) =>
t AnyEvent -> m Void
runEvents t AnyEvent
evts =
      m Void -> (Async Void -> m Void) -> m Void
forall a b. HasCallStack => m a -> (Async a -> m b) -> m b
forall (m :: Type -> Type) a b.
(MonadAsync m, HasCallStack) =>
m a -> (Async a -> m b) -> m b
Async.withAsync (Text -> m Void -> m Void
forall a. Text -> m a -> m a
logExAndRethrow Text
"Notify: " m Void
forall env (m :: Type -> Type) k.
(HasCallStack, HasNoteQueue env, MonadCatch m,
 MonadLoggerNS m env k, MonadNotify m, MonadSTM m) =>
m Void
pollNoteQueue) ((Async Void -> m Void) -> m Void)
-> (Async Void -> m Void) -> m Void
forall a b. (a -> b) -> a -> b
$ \Async Void
noteThread ->
        m (t Void) -> (Async (t Void) -> m Void) -> m Void
forall a b. HasCallStack => m a -> (Async a -> m b) -> m b
forall (m :: Type -> Type) a b.
(MonadAsync m, HasCallStack) =>
m a -> (Async a -> m b) -> m b
Async.withAsync
          ( Text -> m (t Void) -> m (t Void)
forall a. Text -> m a -> m a
logExAndRethrow
              Text
"Event processing: "
              ((AnyEvent -> m Void) -> t AnyEvent -> m (t Void)
forall (m :: Type -> Type) (t :: Type -> Type) a b.
(MonadAsync m, Traversable t) =>
(a -> m b) -> t a -> m (t b)
Async.mapConcurrently AnyEvent -> m Void
forall (m :: Type -> Type) env k.
(HasCallStack, HasNoteQueue env, MonadCatch m, MonadIORef m,
 MonadLoggerNS m env k, MonadSTM m, MonadSystemInfo m,
 MonadThread m) =>
AnyEvent -> m Void
processEvent t AnyEvent
evts)
          )
          (((Void, t Void) -> Void) -> m (Void, t Void) -> m Void
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Void, t Void) -> Void
forall a b. (a, b) -> a
fst (m (Void, t Void) -> m Void)
-> (Async (t Void) -> m (Void, t Void)) -> Async (t Void) -> m Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Async Void -> Async (t Void) -> m (Void, t Void)
forall a b. HasCallStack => Async a -> Async b -> m (a, b)
forall (m :: Type -> Type) a b.
(MonadAsync m, HasCallStack) =>
Async a -> Async b -> m (a, b)
Async.waitBoth Async Void
noteThread)

    logExAndRethrow :: Text -> m a -> m a
    logExAndRethrow :: forall a. Text -> m a -> m a
logExAndRethrow Text
prefix m a
io = m a -> (SomeException -> m a) -> m a
forall (m :: Type -> Type) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
catchSync m a
io ((SomeException -> m a) -> m a) -> (SomeException -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \SomeException
ex -> do
      $(logError) (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
displayExceptiont SomeException
ex)
      SomeException -> m a
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: Type -> Type) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM SomeException
ex
{-# INLINEABLE runNavi #-}

{- HLINT ignore module "Redundant bracket" -}

processEvent ::
  forall m env k.
  ( HasCallStack,
    HasNoteQueue env,
    MonadCatch m,
    MonadIORef m,
    MonadLoggerNS m env k,
    MonadSTM m,
    MonadSystemInfo m,
    MonadThread m
  ) =>
  AnyEvent ->
  m Void
processEvent :: forall (m :: Type -> Type) env k.
(HasCallStack, HasNoteQueue env, MonadCatch m, MonadIORef m,
 MonadLoggerNS m env k, MonadSTM m, MonadSystemInfo m,
 MonadThread m) =>
AnyEvent -> m Void
processEvent (MkAnyEvent Event result trigger
event) = Text -> m Void -> m Void
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
name (m Void -> m Void) -> m Void -> m Void
forall a b. (a -> b) -> a -> b
$ do
  ThreadId
tid <- m ThreadId
forall (m :: Type -> Type).
(MonadThread m, HasCallStack) =>
m ThreadId
myThreadId
  ThreadId -> String -> m ()
forall (m :: Type -> Type).
(MonadThread m, HasCallStack) =>
ThreadId -> String -> m ()
labelThread ThreadId
tid (Text -> String
unpackText Text
name)
  m () -> m Void
forall (f :: Type -> Type) a b. Applicative f => f a -> f b
forever (m () -> m Void) -> m () -> m Void
forall a b. (a -> b) -> a -> b
$ do
    $(logInfo) (Text
"Checking " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)
    Maybe PollInterval
dynamicPollInterval <-
      (Event result trigger -> m (EventSuccess result trigger)
forall (m :: Type -> Type) env k result trigger.
(HasCallStack, MonadLoggerNS m env k, MonadSystemInfo m,
 Show result) =>
Event result trigger -> m (EventSuccess result trigger)
Event.runEvent Event result trigger
event m (EventSuccess result trigger)
-> (EventSuccess result trigger -> m (Maybe PollInterval))
-> m (Maybe PollInterval)
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= EventSuccess result trigger -> m (Maybe PollInterval)
forall trigger result.
(HasCallStack, Ord trigger, Show result, Show trigger) =>
EventSuccess result trigger -> m (Maybe PollInterval)
handleSuccess)
        m (Maybe PollInterval)
-> (EventError -> m (Maybe PollInterval)) -> m (Maybe PollInterval)
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: Type -> Type) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (HasCallStack => EventError -> m ()
EventError -> m ()
handleEventError (EventError -> m ())
-> (m () -> m (Maybe PollInterval))
-> EventError
-> m (Maybe PollInterval)
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (m () -> Maybe PollInterval -> m (Maybe PollInterval)
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> Maybe PollInterval
forall a. Maybe a
Nothing))
        m (Maybe PollInterval)
-> (SomeException -> m (Maybe PollInterval))
-> m (Maybe PollInterval)
forall (m :: Type -> Type) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchSync` (HasCallStack => SomeException -> m ()
SomeException -> m ()
handleSomeException (SomeException -> m ())
-> (m () -> m (Maybe PollInterval))
-> SomeException
-> m (Maybe PollInterval)
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (m () -> Maybe PollInterval -> m (Maybe PollInterval)
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> Maybe PollInterval
forall a. Maybe a
Nothing))
    let pollInterval :: PollInterval
pollInterval = PollInterval -> Maybe PollInterval -> PollInterval
forall a. a -> Maybe a -> a
fromMaybe PollInterval
staticPollInterval Maybe PollInterval
dynamicPollInterval
    Natural -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadThread m) =>
Natural -> m ()
sleep (PollInterval
pollInterval PollInterval -> Optic' An_Iso NoIx PollInterval Natural -> Natural
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx PollInterval Natural
#unPollInterval)
  where
    name :: Text
name = Event result trigger
event Event result trigger
-> Optic' A_Lens NoIx (Event result trigger) Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (Event result trigger) Text
#name
    errorNote :: ErrorNote
errorNote = Event result trigger
event Event result trigger
-> Optic' A_Lens NoIx (Event result trigger) ErrorNote -> ErrorNote
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (Event result trigger) ErrorNote
#errorNote

    staticPollInterval :: PollInterval
staticPollInterval = Event result trigger
event Event result trigger
-> Optic' A_Lens NoIx (Event result trigger) PollInterval
-> PollInterval
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (Event result trigger) PollInterval
#pollInterval

    handleSuccess ::
      (HasCallStack, Ord trigger, Show result, Show trigger) =>
      EventSuccess result trigger ->
      m (Maybe PollInterval)
    handleSuccess :: forall trigger result.
(HasCallStack, Ord trigger, Show result, Show trigger) =>
EventSuccess result trigger -> m (Maybe PollInterval)
handleSuccess EventSuccess result trigger
es =
      Text -> m (Maybe PollInterval) -> m (Maybe PollInterval)
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
"handleSuccess" (m (Maybe PollInterval) -> m (Maybe PollInterval))
-> m (Maybe PollInterval) -> m (Maybe PollInterval)
forall a b. (a -> b) -> a -> b
$ do
        case result -> Maybe (trigger, NaviNote)
raiseAlert result
result of
          Maybe (trigger, NaviNote)
Nothing -> do
            $(logDebug) (Text
"No alert to raise " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> result -> Text
forall a. Show a => a -> Text
showt result
result)
            RepeatEvent trigger -> Maybe trigger -> m ()
forall a (m :: Type -> Type).
(Eq a, MonadIORef m) =>
RepeatEvent a -> Maybe a -> m ()
Event.updatePrevTrigger RepeatEvent trigger
repeatEvent Maybe trigger
forall a. Maybe a
Nothing
          Just (trigger
trigger, NaviNote
note) -> do
            Bool
blocked <- RepeatEvent trigger -> trigger -> m Bool
forall a (m :: Type -> Type) env k.
(Ord a, MonadLoggerNS m env k, MonadIORef m, Show a) =>
RepeatEvent a -> a -> m Bool
Event.blockRepeat RepeatEvent trigger
repeatEvent trigger
trigger
            if Bool
blocked
              then $(logDebug) (Text
"Alert blocked " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> result -> Text
forall a. Show a => a -> Text
showt result
result)
              else do
                $(logInfo) (Text
"Sending note " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NaviNote -> Text
forall a. Show a => a -> Text
showt NaviNote
note)
                RepeatEvent trigger -> Maybe trigger -> m ()
forall a (m :: Type -> Type).
(Eq a, MonadIORef m) =>
RepeatEvent a -> Maybe a -> m ()
Event.updatePrevTrigger RepeatEvent trigger
repeatEvent (trigger -> Maybe trigger
forall a. a -> Maybe a
Just trigger
trigger)
                NaviNote -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasNoteQueue env, MonadReader env m, MonadSTM m) =>
NaviNote -> m ()
sendNoteQueue NaviNote
note
        pure Maybe PollInterval
pollInterval
      where
        pollInterval :: Maybe PollInterval
pollInterval = EventSuccess result trigger
es EventSuccess result trigger
-> Optic'
     A_Lens NoIx (EventSuccess result trigger) (Maybe PollInterval)
-> Maybe PollInterval
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic'
  A_Lens NoIx (EventSuccess result trigger) (Maybe PollInterval)
#pollInterval
        raiseAlert :: result -> Maybe (trigger, NaviNote)
raiseAlert = EventSuccess result trigger
es EventSuccess result trigger
-> Optic'
     A_Lens
     NoIx
     (EventSuccess 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
  (EventSuccess result trigger)
  (result -> Maybe (trigger, NaviNote))
#raiseAlert
        result :: result
result = EventSuccess result trigger
es EventSuccess result trigger
-> Optic' A_Lens NoIx (EventSuccess result trigger) result
-> result
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (EventSuccess result trigger) result
#result
        repeatEvent :: RepeatEvent trigger
repeatEvent = EventSuccess result trigger
es EventSuccess result trigger
-> Optic'
     A_Lens NoIx (EventSuccess 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 (EventSuccess result trigger) (RepeatEvent trigger)
#repeatEvent

    handleEventError :: (HasCallStack) => EventError -> m ()
    handleEventError :: HasCallStack => EventError -> m ()
handleEventError =
      Text -> m () -> m ()
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
"handleEventError"
        (m () -> m ()) -> (EventError -> m ()) -> EventError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (EventError -> NaviNote) -> EventError -> m ()
forall e.
(HasCallStack, Exception e) =>
(e -> NaviNote) -> e -> m ()
handleErr EventError -> NaviNote
eventErrToNote

    handleSomeException :: (HasCallStack) => SomeException -> m ()
    handleSomeException :: HasCallStack => SomeException -> m ()
handleSomeException =
      Text -> m () -> m ()
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
"handleSomeException"
        (m () -> m ()) -> (SomeException -> m ()) -> SomeException -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (SomeException -> NaviNote) -> SomeException -> m ()
forall e.
(HasCallStack, Exception e) =>
(e -> NaviNote) -> e -> m ()
handleErr SomeException -> NaviNote
exToNote

    handleErr :: (HasCallStack, Exception e) => (e -> NaviNote) -> e -> m ()
    handleErr :: forall e.
(HasCallStack, Exception e) =>
(e -> NaviNote) -> e -> m ()
handleErr e -> NaviNote
toNote e
e = do
      Bool
blockErrEvent <- ErrorNote -> m Bool
forall (m :: Type -> Type) env k.
(MonadLoggerNS m env k, MonadIORef m) =>
ErrorNote -> m Bool
Event.blockErr ErrorNote
errorNote
      $(logError) (e -> Text
forall e. Exception e => e -> Text
displayExceptiont e
e)
      if Bool
blockErrEvent
        then $(logDebug) Text
"Error note blocked"
        else NaviNote -> m ()
forall env (m :: Type -> Type).
(HasCallStack, HasNoteQueue env, MonadReader env m, MonadSTM m) =>
NaviNote -> m ()
sendNoteQueue (e -> NaviNote
toNote e
e)
{-# INLINEABLE processEvent #-}

eventErrToNote :: EventError -> NaviNote
eventErrToNote :: EventError -> NaviNote
eventErrToNote EventError
ex =
  MkNaviNote
    { summary :: Text
summary = EventError
ex EventError -> Optic' A_Lens NoIx EventError Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx EventError Text
#name,
      body :: Maybe Text
body = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ EventError
ex EventError -> Optic' A_Lens NoIx EventError Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx EventError Text
#short,
      urgency :: Maybe UrgencyLevel
urgency = UrgencyLevel -> Maybe UrgencyLevel
forall a. a -> Maybe a
Just UrgencyLevel
Critical,
      timeout :: Maybe Timeout
timeout = Maybe Timeout
forall a. Maybe a
Nothing
    }

exToNote :: SomeException -> NaviNote
exToNote :: SomeException -> NaviNote
exToNote SomeException
ex =
  MkNaviNote
    { summary :: Text
summary = Text
"Exception",
      body :: Maybe Text
body = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
packText (SomeException -> String
forall e. Exception e => e -> String
U.displayInner SomeException
ex),
      urgency :: Maybe UrgencyLevel
urgency = UrgencyLevel -> Maybe UrgencyLevel
forall a. a -> Maybe a
Just UrgencyLevel
Critical,
      timeout :: Maybe Timeout
timeout = Maybe Timeout
forall a. Maybe a
Nothing
    }

pollNoteQueue ::
  ( HasCallStack,
    HasNoteQueue env,
    MonadCatch m,
    MonadLoggerNS m env k,
    MonadNotify m,
    MonadSTM m
  ) =>
  m Void
pollNoteQueue :: forall env (m :: Type -> Type) k.
(HasCallStack, HasNoteQueue env, MonadCatch m,
 MonadLoggerNS m env k, MonadNotify m, MonadSTM m) =>
m Void
pollNoteQueue = Text -> m Void -> m Void
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
"note-poller" (m Void -> m Void) -> m Void -> m Void
forall a b. (a -> b) -> a -> b
$ do
  TBQueue NaviNote
queue <- (env -> TBQueue NaviNote) -> m (TBQueue NaviNote)
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks env -> TBQueue NaviNote
forall env. HasNoteQueue env => env -> TBQueue NaviNote
getNoteQueue
  m () -> m Void
forall (f :: Type -> Type) a b. Applicative f => f a -> f b
forever
    (m () -> m Void) -> m () -> m Void
forall a b. (a -> b) -> a -> b
$ TBQueue NaviNote -> m NaviNote
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
TBQueue a -> m a
readTBQueueA TBQueue NaviNote
queue
    m NaviNote -> (NaviNote -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NaviNote
nn ->
      NaviNote -> m ()
forall (m :: Type -> Type).
(MonadNotify m, HasCallStack) =>
NaviNote -> m ()
sendNote NaviNote
nn m () -> (ClientError -> m ()) -> m ()
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: Type -> Type) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \ClientError
ce ->
        -- NOTE: Rethrow all exceptions except:
        --
        -- 1. Non-fatal dbus errors e.g. quickly sending the same notif twice.
        if ClientError -> Bool
clientErrorFatal ClientError
ce
          then ClientError -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: Type -> Type) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM ClientError
ce
          else
            $(logError)
              (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Received non-fatal dbus error: "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
packText (ClientError -> String
forall e. Exception e => e -> String
displayException ClientError
ce)
{-# INLINEABLE pollNoteQueue #-}

pollLogQueue ::
  ( HasCallStack,
    MonadLoggerNS m env k,
    MonadHandleWriter m,
    MonadMask m,
    MonadSTM m,
    MonadTerminal m
  ) =>
  LogEnv ->
  m Void
pollLogQueue :: forall (m :: Type -> Type) env k.
(HasCallStack, MonadLoggerNS m env k, MonadHandleWriter m,
 MonadMask m, MonadSTM m, MonadTerminal m) =>
LogEnv -> m Void
pollLogQueue LogEnv
logEnv = Text -> m Void -> m Void
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
"logger" (m Void -> m Void) -> m Void -> m Void
forall a b. (a -> b) -> a -> b
$ do
  m () -> m Void
forall (f :: Type -> Type) a b. Applicative f => f a -> f b
forever
    (m () -> m Void) -> m () -> m Void
forall a b. (a -> b) -> a -> b
$
    -- NOTE: Rethrow all exceptions
    TBQueue LogStr -> (LogStr -> m ()) -> m ()
forall (m :: Type -> Type) a b.
(HasCallStack, MonadMask m, MonadSTM m) =>
TBQueue a -> (a -> m b) -> m ()
atomicReadWrite TBQueue LogStr
queue (ByteString -> m ()
sendFn (ByteString -> m ()) -> (LogStr -> ByteString) -> LogStr -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LogStr -> ByteString
logStrToBs)
  where
    queue :: TBQueue LogStr
queue = LogEnv
logEnv LogEnv
-> Optic' A_Lens NoIx LogEnv (TBQueue LogStr) -> TBQueue LogStr
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx LogEnv (TBQueue LogStr)
#logQueue
    sendFn :: ByteString -> m ()
sendFn = LogEnv -> ByteString -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadHandleWriter m, MonadTerminal m) =>
LogEnv -> ByteString -> m ()
getLoggerFn LogEnv
logEnv
{-# INLINEABLE pollLogQueue #-}

getLoggerFn ::
  ( HasCallStack,
    MonadHandleWriter m,
    MonadTerminal m
  ) =>
  LogEnv ->
  (ByteString -> m ())
getLoggerFn :: forall (m :: Type -> Type).
(HasCallStack, MonadHandleWriter m, MonadTerminal m) =>
LogEnv -> ByteString -> m ()
getLoggerFn LogEnv
logEnv = (ByteString -> m ())
-> (Handle -> ByteString -> m ())
-> Maybe Handle
-> ByteString
-> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString -> m ()
forall (m :: Type -> Type).
(MonadTerminal m, HasCallStack) =>
ByteString -> m ()
putBinary Handle -> ByteString -> m ()
forall {f :: Type -> Type}.
MonadHandleWriter f =>
Handle -> ByteString -> f ()
toFile Maybe Handle
mfileHandle
  where
    mfileHandle :: Maybe Handle
mfileHandle = LogEnv
logEnv LogEnv -> Optic' A_Lens NoIx LogEnv (Maybe Handle) -> Maybe Handle
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx LogEnv (Maybe Handle)
#logHandle
    toFile :: Handle -> ByteString -> f ()
toFile Handle
h ByteString
bs = Handle -> ByteString -> f ()
forall (m :: Type -> Type).
(MonadHandleWriter m, HasCallStack) =>
Handle -> ByteString -> m ()
hPut Handle
h ByteString
bs f () -> f () -> f ()
forall a b. f a -> f b -> f b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> Handle -> f ()
forall (m :: Type -> Type).
(MonadHandleWriter m, HasCallStack) =>
Handle -> m ()
hFlush Handle
h
{-# INLINEABLE getLoggerFn #-}

atomicReadWrite ::
  ( HasCallStack,
    MonadMask m,
    MonadSTM m
  ) =>
  -- | Queue from which to read.
  TBQueue a ->
  -- | Function to apply.
  (a -> m b) ->
  m ()
atomicReadWrite :: forall (m :: Type -> Type) a b.
(HasCallStack, MonadMask m, MonadSTM m) =>
TBQueue a -> (a -> m b) -> m ()
atomicReadWrite TBQueue a
queue a -> m b
logAction =
  -- NOTE: There are several options we could take here:
  --
  -- 1. uninterruptibleMask_ $ tryReadTBQueueA queue >>= traverse_ logAction
  --
  --    This gives us guaranteed atomicity, at the risk of a possible deadlock,
  --    if either the read or logAction blocks indefinitely. IMPORTANT: If we
  --    go this route, readTBQueueA _must_ be swapped for tryReadTBQueueA, as
  --    the former relies on cancellation via an async exception i.e.
  --    uninterruptibleMask_ + readTBQueueA = deadlock.
  --
  -- 2. mask $ \restore -> restore (readTBQueueA queue) >>= void . logAction
  --
  --    This does not give us absolute atomicity, as logAction could be
  --    interrupted if it is actually blocking; but that is probably the right
  --    choice (responsiveness), and we have atomicity as long as logAction
  --    does not block.
  --
  -- 3. mask_ $ readTBQueueA queue >>= void . logAction
  --
  --    Slightly simpler than 2, has the same caveat regarding atomicity.
  --    The difference is that in the latter, readTBQueueA is also masked
  --    as long as it is not blocking. There really is no reason for this,
  --    as the invariant we care about is _if_ successful read then
  --    successful handle.
  ((forall a. m a -> m a) -> m ()) -> m ()
forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
forall (m :: Type -> Type) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m ()) -> m ())
-> ((forall a. m a -> m a) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> m a -> m a
forall a. m a -> m a
restore (TBQueue a -> m a
forall (m :: Type -> Type) a.
(HasCallStack, MonadSTM m) =>
TBQueue a -> m a
readTBQueueA TBQueue a
queue) m a -> (a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= m b -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (m b -> m ()) -> (a -> m b) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> m b
logAction
{-# INLINEABLE atomicReadWrite #-}