{-# 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 (..))
import Data.Text qualified as T
import Effects.Concurrent.Async qualified as Async
import Effects.Concurrent.STM (flushTBQueueM)
import Effects.Concurrent.Thread (sleep)
import Effects.LoggerNamespace
  ( MonadLoggerNamespace,
    addNamespace,
    logStrToBs,
  )
import Effects.System.Terminal (MonadTerminal (putBinary))
import Navi.Data.NaviNote (NaviNote (..), Timeout (..))
import Navi.Effects.MonadNotify (MonadNotify (..), sendNoteQueue)
import Navi.Effects.MonadSystemInfo (MonadSystemInfo (..))
import Navi.Env.Core
  ( HasEvents (..),
    HasLogEnv (getLogEnv),
    HasLogQueue (..),
    HasNoteQueue (..),
  )
import Navi.Event qualified as Event
import Navi.Event.Types (AnyEvent (..), EventError (..), EventSuccess (..))
import Navi.NaviT (NaviT (..), runNaviT)
import Navi.Prelude

-- | Entry point for the application.
runNavi ::
  forall env m.
  ( HasCallStack,
    HasEvents env,
    HasLogEnv env,
    HasLogQueue env,
    HasNoteQueue env,
    MonadAsync m,
    MonadHandleWriter m,
    MonadIORef m,
    MonadLoggerNamespace m,
    MonadMask m,
    MonadNotify m,
    MonadSTM m,
    MonadSystemInfo m,
    MonadTerminal m,
    MonadThread m,
    MonadReader env m
  ) =>
  m Void
runNavi :: forall (env :: OpticKind) (m :: OpticKind -> OpticKind).
(HasCallStack, HasEvents env, HasLogEnv env, HasLogQueue env,
 HasNoteQueue env, MonadAsync m, MonadHandleWriter m, MonadIORef m,
 MonadLoggerNamespace m, MonadMask m, MonadNotify m, MonadSTM m,
 MonadSystemInfo m, MonadTerminal m, MonadThread m,
 MonadReader env m) =>
m Void
runNavi = do
  let welcome :: NaviNote
welcome =
        MkNaviNote
          { $sel:summary:MkNaviNote :: Text
summary = Text
"Navi",
            $sel:body:MkNaviNote :: Maybe Text
body = forall (a :: OpticKind). a -> Maybe a
Just Text
"Navi is up :-)",
            $sel:urgency:MkNaviNote :: Maybe UrgencyLevel
urgency = forall (a :: OpticKind). a -> Maybe a
Just UrgencyLevel
Normal,
            $sel:timeout:MkNaviNote :: Maybe Timeout
timeout = forall (a :: OpticKind). a -> Maybe a
Just forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Word16 -> Timeout
Seconds Word16
10
          }
  forall (env :: OpticKind) (m :: OpticKind -> OpticKind).
(HasCallStack, HasNoteQueue env, MonadReader env m, MonadSTM m) =>
NaviNote -> m ()
sendNoteQueue NaviNote
welcome
  NonEmpty AnyEvent
events <- forall (r :: OpticKind) (m :: OpticKind -> OpticKind)
       (a :: OpticKind).
MonadReader r m =>
(r -> a) -> m a
asks forall (env :: OpticKind).
HasEvents env =>
env -> NonEmpty AnyEvent
getEvents
  forall (t :: OpticKind -> OpticKind).
(HasCallStack, Traversable t) =>
t AnyEvent -> m Void
runAllAsync NonEmpty AnyEvent
events
  where
    runAllAsync ::
      ( HasCallStack,
        Traversable t
      ) =>
      t AnyEvent ->
      m Void
    runAllAsync :: forall (t :: OpticKind -> OpticKind).
(HasCallStack, Traversable t) =>
t AnyEvent -> m Void
runAllAsync t AnyEvent
evts =
      forall (m :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(MonadAsync m, HasCallStack) =>
m a -> (Async a -> m b) -> m b
Async.withAsync forall (env :: OpticKind) (m :: OpticKind -> OpticKind).
(HasCallStack, HasLogQueue env, HasLogEnv env,
 MonadLoggerNamespace m, MonadHandleWriter m, MonadMask m,
 MonadReader env m, MonadSTM m, MonadTerminal m) =>
m Void
pollLogQueue forall (a :: OpticKind) 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.
        forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
(HasCallStack, MonadAsync m) =>
Async a -> m ()
Async.link Async Void
logThread
        forall (t :: OpticKind -> OpticKind).
(HasCallStack, Traversable t) =>
t AnyEvent -> m Void
runEvents t AnyEvent
evts
          forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e -> do
            forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
(HasCallStack, MonadAsync m, MonadCatch m, MonadSTM m,
 MonadThread m) =>
Async a -> m ()
Async.cancel Async Void
logThread
            -- handle remaining logs
            TBQueue LogStr
queue <- forall (r :: OpticKind) (m :: OpticKind -> OpticKind)
       (a :: OpticKind).
MonadReader r m =>
(r -> a) -> m a
asks forall (env :: OpticKind). HasLogQueue env => env -> TBQueue LogStr
getLogQueue
            ByteString -> m ()
sendFn <- forall (env :: OpticKind) (m :: OpticKind -> OpticKind).
(HasCallStack, HasLogEnv env, MonadHandleWriter m,
 MonadReader env m, MonadTerminal m) =>
m (ByteString -> m ())
getLoggerFn
            forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
(HasCallStack, MonadSTM m) =>
TBQueue a -> m [a]
flushTBQueueM TBQueue LogStr
queue forall (m :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Monad m =>
m a -> (a -> m b) -> m b
>>= forall (t :: OpticKind -> OpticKind) (f :: OpticKind -> OpticKind)
       (a :: OpticKind) (b :: OpticKind).
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ByteString -> m ()
sendFn forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
logStrToBs)
            forall (m :: OpticKind -> OpticKind) (e :: OpticKind)
       (a :: OpticKind).
(MonadThrow m, Exception e) =>
e -> m a
throwM SomeException
e
    {-# INLINEABLE runAllAsync #-}

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

    logExAndRethrow :: Text -> m a -> m a
    logExAndRethrow :: forall (a :: OpticKind). Text -> m a -> m a
logExAndRethrow Text
prefix m a
io = forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchAny m a
io forall (a :: OpticKind) b. (a -> b) -> a -> b
$ \SomeException
ex -> do
      $(logError) (Text
prefix forall (a :: OpticKind). Semigroup a => a -> a -> a
<> String -> Text
pack (forall (e :: OpticKind). Exception e => e -> String
displayException SomeException
ex))
      forall (m :: OpticKind -> OpticKind) (e :: OpticKind)
       (a :: OpticKind).
(MonadThrow m, Exception e) =>
e -> m a
throwM SomeException
ex
    {-# INLINEABLE logExAndRethrow #-}
{-# INLINEABLE runNavi #-}

processEvent ::
  forall m env.
  ( HasCallStack,
    HasNoteQueue env,
    MonadCatch m,
    MonadIORef m,
    MonadLoggerNamespace m,
    MonadReader env m,
    MonadSTM m,
    MonadSystemInfo m,
    MonadThread m
  ) =>
  AnyEvent ->
  m Void
processEvent :: forall (m :: OpticKind -> OpticKind) (env :: OpticKind).
(HasCallStack, HasNoteQueue env, MonadCatch m, MonadIORef m,
 MonadLoggerNamespace m, MonadReader env m, MonadSTM m,
 MonadSystemInfo m, MonadThread m) =>
AnyEvent -> m Void
processEvent (MkAnyEvent Event result
event) = forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
MonadLoggerNamespace m =>
Text -> m a -> m a
addNamespace (forall (a :: OpticKind). IsString a => String -> a
fromString forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Text -> String
unpack Text
name) forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
  let pi :: Natural
pi = Event result
event forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. (forall (a :: OpticKind). IsLabel "pollInterval" a => a
#pollInterval forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (a :: OpticKind). IsLabel "unPollInterval" a => a
#unPollInterval)
  forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Applicative f =>
f a -> f b
forever forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
    $(logInfo) (Text
"Checking " forall (a :: OpticKind). Semigroup a => a -> a -> a
<> Text
name)
    (forall (m :: OpticKind -> OpticKind) (result :: OpticKind).
(HasCallStack, MonadLoggerNamespace m, MonadSTM m,
 MonadSystemInfo m, Show result) =>
Event result -> m (EventSuccess result)
Event.runEvent Event result
event forall (m :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Monad m =>
m a -> (a -> m b) -> m b
>>= forall (result :: OpticKind).
(HasCallStack, Eq result, Show result) =>
EventSuccess result -> m ()
handleSuccess)
      forall (m :: OpticKind -> OpticKind) (e :: OpticKind)
       (a :: OpticKind).
(Exception e, HasCallStack, MonadCatch m) =>
m a -> (e -> m a) -> m a
`catchWithCS` HasCallStack => EventError -> m ()
handleEventError
      forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` HasCallStack => SomeException -> m ()
handleSomeException
    forall (m :: OpticKind -> OpticKind).
(HasCallStack, MonadThread m) =>
Natural -> m ()
sleep Natural
pi
  where
    name :: Text
name = Event result
event forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "name" a => a
#name
    errorNote :: ErrorNote
errorNote = Event result
event forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "errorNote" a => a
#errorNote

    handleSuccess ::
      (HasCallStack, Eq result, Show result) =>
      EventSuccess result ->
      m ()
    handleSuccess :: forall (result :: OpticKind).
(HasCallStack, Eq result, Show result) =>
EventSuccess result -> m ()
handleSuccess (MkEventSuccess result
result RepeatEvent result
repeatEvent result -> Maybe NaviNote
raiseAlert) =
      forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
MonadLoggerNamespace m =>
Text -> m a -> m a
addNamespace Text
"handleSuccess" forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
        case result -> Maybe NaviNote
raiseAlert result
result of
          Maybe NaviNote
Nothing -> do
            $(logDebug) (Text
"No alert to raise " forall (a :: OpticKind). Semigroup a => a -> a -> a
<> forall (a :: OpticKind). Show a => a -> Text
showt result
result)
            forall (a :: OpticKind) (m :: OpticKind -> OpticKind).
(Eq a, MonadIORef m) =>
RepeatEvent a -> a -> m ()
Event.updatePrevTrigger RepeatEvent result
repeatEvent result
result
          Just NaviNote
note -> do
            Bool
blocked <- forall (a :: OpticKind) (m :: OpticKind -> OpticKind).
(Eq a, MonadLoggerNamespace m, MonadIORef m, Show a) =>
RepeatEvent a -> a -> m Bool
Event.blockRepeat RepeatEvent result
repeatEvent result
result
            if Bool
blocked
              then $(logDebug) (Text
"Alert blocked " forall (a :: OpticKind). Semigroup a => a -> a -> a
<> forall (a :: OpticKind). Show a => a -> Text
showt result
result)
              else do
                $(logInfo) (Text
"Sending note " forall (a :: OpticKind). Semigroup a => a -> a -> a
<> forall (a :: OpticKind). Show a => a -> Text
showt NaviNote
note)
                forall (a :: OpticKind) (m :: OpticKind -> OpticKind).
(Eq a, MonadIORef m) =>
RepeatEvent a -> a -> m ()
Event.updatePrevTrigger RepeatEvent result
repeatEvent result
result
                forall (env :: OpticKind) (m :: OpticKind -> OpticKind).
(HasCallStack, HasNoteQueue env, MonadReader env m, MonadSTM m) =>
NaviNote -> m ()
sendNoteQueue NaviNote
note

    {-# INLINEABLE handleSuccess #-}

    handleEventError :: HasCallStack => EventError -> m ()
    handleEventError :: HasCallStack => EventError -> m ()
handleEventError =
      forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
MonadLoggerNamespace m =>
Text -> m a -> m a
addNamespace Text
"handleEventError"
        forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (e :: OpticKind).
(HasCallStack, Exception e) =>
(e -> NaviNote) -> e -> m ()
handleErr EventError -> NaviNote
eventErrToNote
    {-# INLINEABLE handleEventError #-}

    handleSomeException :: HasCallStack => SomeException -> m ()
    handleSomeException :: HasCallStack => SomeException -> m ()
handleSomeException =
      forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
MonadLoggerNamespace m =>
Text -> m a -> m a
addNamespace Text
"handleSomeException"
        forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (e :: OpticKind).
(HasCallStack, Exception e) =>
(e -> NaviNote) -> e -> m ()
handleErr SomeException -> NaviNote
exToNote

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

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

exToNote :: SomeException -> NaviNote
exToNote :: SomeException -> NaviNote
exToNote SomeException
ex =
  MkNaviNote
    { $sel:summary:MkNaviNote :: Text
summary = Text
"Exception",
      $sel:body:MkNaviNote :: Maybe Text
body = forall (a :: OpticKind). a -> Maybe a
Just forall (a :: OpticKind) b. (a -> b) -> a -> b
$ String -> Text
pack (forall (e :: OpticKind). Exception e => e -> String
displayException SomeException
ex),
      $sel:urgency:MkNaviNote :: Maybe UrgencyLevel
urgency = forall (a :: OpticKind). a -> Maybe a
Just UrgencyLevel
Critical,
      $sel:timeout:MkNaviNote :: Maybe Timeout
timeout = forall (a :: OpticKind). Maybe a
Nothing
    }
{-# INLINEABLE exToNote #-}

pollNoteQueue ::
  ( HasCallStack,
    HasNoteQueue env,
    MonadCatch m,
    MonadLoggerNamespace m,
    MonadNotify m,
    MonadReader env m,
    MonadSTM m
  ) =>
  m Void
pollNoteQueue :: forall (env :: OpticKind) (m :: OpticKind -> OpticKind).
(HasCallStack, HasNoteQueue env, MonadCatch m,
 MonadLoggerNamespace m, MonadNotify m, MonadReader env m,
 MonadSTM m) =>
m Void
pollNoteQueue = forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
MonadLoggerNamespace m =>
Text -> m a -> m a
addNamespace Text
"note-poller" forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
  TBQueue NaviNote
queue <- forall (r :: OpticKind) (m :: OpticKind -> OpticKind)
       (a :: OpticKind).
MonadReader r m =>
(r -> a) -> m a
asks forall (env :: OpticKind).
HasNoteQueue env =>
env -> TBQueue NaviNote
getNoteQueue
  forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Applicative f =>
f a -> f b
forever forall (a :: OpticKind) b. (a -> b) -> a -> b
$
    forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
(HasCallStack, MonadSTM m) =>
TBQueue a -> m a
readTBQueueM TBQueue NaviNote
queue forall (m :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Monad m =>
m a -> (a -> m b) -> m b
>>= \NaviNote
nn ->
      forall (m :: OpticKind -> OpticKind).
(MonadNotify m, HasCallStack) =>
NaviNote -> m ()
sendNote NaviNote
nn forall (m :: OpticKind -> OpticKind) (e :: OpticKind)
       (a :: OpticKind).
(Exception e, HasCallStack, MonadCatch m) =>
m a -> (e -> m a) -> m a
`catchWithCS` \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 forall (m :: OpticKind -> OpticKind) (e :: OpticKind)
       (a :: OpticKind).
(MonadThrow m, Exception e) =>
e -> m a
throwM ClientError
ce
          else
            $(logError) forall (a :: OpticKind) b. (a -> b) -> a -> b
$
              Text
"Received non-fatal dbus error: " forall (a :: OpticKind). Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall (e :: OpticKind). Exception e => e -> String
displayException ClientError
ce)
{-# INLINEABLE pollNoteQueue #-}

pollLogQueue ::
  ( HasCallStack,
    HasLogQueue env,
    HasLogEnv env,
    MonadLoggerNamespace m,
    MonadHandleWriter m,
    MonadMask m,
    MonadReader env m,
    MonadSTM m,
    MonadTerminal m
  ) =>
  m Void
pollLogQueue :: forall (env :: OpticKind) (m :: OpticKind -> OpticKind).
(HasCallStack, HasLogQueue env, HasLogEnv env,
 MonadLoggerNamespace m, MonadHandleWriter m, MonadMask m,
 MonadReader env m, MonadSTM m, MonadTerminal m) =>
m Void
pollLogQueue = forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
MonadLoggerNamespace m =>
Text -> m a -> m a
addNamespace Text
"logger" forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
  TBQueue LogStr
queue <- forall (r :: OpticKind) (m :: OpticKind -> OpticKind)
       (a :: OpticKind).
MonadReader r m =>
(r -> a) -> m a
asks forall (env :: OpticKind). HasLogQueue env => env -> TBQueue LogStr
getLogQueue
  ByteString -> m ()
sendFn <- forall (env :: OpticKind) (m :: OpticKind -> OpticKind).
(HasCallStack, HasLogEnv env, MonadHandleWriter m,
 MonadReader env m, MonadTerminal m) =>
m (ByteString -> m ())
getLoggerFn
  forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Applicative f =>
f a -> f b
forever forall (a :: OpticKind) b. (a -> b) -> a -> b
$
    -- NOTE: Rethrow all exceptions
    forall (m :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(HasCallStack, MonadMask m, MonadSTM m) =>
TBQueue a -> (a -> m b) -> m ()
atomicReadWrite TBQueue LogStr
queue (ByteString -> m ()
sendFn forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
logStrToBs)
{-# INLINEABLE pollLogQueue #-}

getLoggerFn ::
  ( HasCallStack,
    HasLogEnv env,
    MonadHandleWriter m,
    MonadReader env m,
    MonadTerminal m
  ) =>
  m (ByteString -> m ())
getLoggerFn :: forall (env :: OpticKind) (m :: OpticKind -> OpticKind).
(HasCallStack, HasLogEnv env, MonadHandleWriter m,
 MonadReader env m, MonadTerminal m) =>
m (ByteString -> m ())
getLoggerFn = do
  Maybe Handle
mfileHandle <- forall (r :: OpticKind) (m :: OpticKind -> OpticKind)
       (a :: OpticKind).
MonadReader r m =>
(r -> a) -> m a
asks (forall (k :: OpticKind) (is :: IxList) (s :: OpticKind)
       (a :: OpticKind).
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (forall (a :: OpticKind). IsLabel "logFile" a => a
#logFile forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (a :: OpticKind) (b :: OpticKind).
Prism (Maybe a) (Maybe b) a b
_Just forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (a :: OpticKind). IsLabel "handle" a => a
#handle) forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (env :: OpticKind). HasLogEnv env => env -> LogEnv
getLogEnv)
  pure $ forall (b :: OpticKind) (a :: OpticKind).
b -> (a -> b) -> Maybe a -> b
maybe forall (m :: OpticKind -> OpticKind).
(MonadTerminal m, HasCallStack) =>
ByteString -> m ()
putBinary forall {f :: OpticKind -> OpticKind}.
MonadHandleWriter f =>
Handle -> ByteString -> f ()
toFile Maybe Handle
mfileHandle
  where
    toFile :: Handle -> ByteString -> f ()
toFile Handle
h ByteString
bs = forall (m :: OpticKind -> OpticKind).
(MonadHandleWriter m, HasCallStack) =>
Handle -> ByteString -> m ()
hPut Handle
h ByteString
bs forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Applicative f =>
f a -> f b -> f b
*> forall (m :: OpticKind -> OpticKind).
(MonadHandleWriter m, HasCallStack) =>
Handle -> m ()
hFlush Handle
h

atomicReadWrite ::
  ( HasCallStack,
    MonadMask m,
    MonadSTM m
  ) =>
  -- | Queue from which to read.
  TBQueue a ->
  -- | Function to apply.
  (a -> m b) ->
  m ()
atomicReadWrite :: forall (m :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(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_ $ tryReadTBQueueM 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, readTBQueueM _must_ be swapped for tryReadTBQueueM, as
  --    the former relies on cancellation via an async exception i.e.
  --    uninterruptibleMask_ + readTBQueueM = deadlock.
  --
  -- 2. mask $ \restore -> restore (readTBQueueM 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_ $ readTBQueueM queue >>= void . logAction
  --
  --    Slightly simpler than 2, has the same caveat regarding atomicity.
  --    The difference is that in the latter, readTBQueueM 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 (m :: OpticKind -> OpticKind) (b :: OpticKind).
MonadMask m =>
((forall (a :: OpticKind). m a -> m a) -> m b) -> m b
mask forall (a :: OpticKind) b. (a -> b) -> a -> b
$ \forall (a :: OpticKind). m a -> m a
restore -> forall (a :: OpticKind). m a -> m a
restore (forall (m :: OpticKind -> OpticKind) (a :: OpticKind).
(HasCallStack, MonadSTM m) =>
TBQueue a -> m a
readTBQueueM TBQueue a
queue) forall (m :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Monad m =>
m a -> (a -> m b) -> m b
>>= forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Functor f =>
f a -> f ()
void forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. a -> m b
logAction