{-# LANGUAGE TemplateHaskell #-}
module Navi
(
runNavi,
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
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
Maybe LogEnv
Nothing -> t AnyEvent -> m Void
forall (t :: Type -> Type).
(HasCallStack, Traversable t) =>
t AnyEvent -> m Void
runEvents t AnyEvent
evts
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
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
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
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 #-}
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 ->
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
$
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
) =>
TBQueue a ->
(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 =
((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 #-}