{-# LANGUAGE OverloadedStrings #-}

-- | Internal logging implementation for Arbiter.
--
-- This module is not part of the public API.
module Arbiter.Worker.Logger.Internal
  ( withJobContext
  , withJobContextOne
  , withJobContextList
  , runHook
  , tryWarn
  , tryWarnWith
  ) where

import Arbiter.Core.Exceptions (displayEx)
import Arbiter.Core.Job.Types qualified as Job
import Control.Monad (void)
import Data.Aeson (KeyValue (..), object)
import Data.Aeson.Types (Pair)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList)
import Data.Text (Text)
import UnliftIO (MonadUnliftIO, tryAny)

import Arbiter.Worker.Logger (LogConfig (..), LogDestination (..), LogLevel (..), tryLog, warnEx)

-- | Add the jobs' fields to every message a 'LogConfig' emits.
withJobContext :: LogConfig -> NonEmpty (Job.JobRead payload) -> LogConfig
withJobContext :: forall payload.
LogConfig -> NonEmpty (JobRead payload) -> LogConfig
withJobContext LogConfig
config NonEmpty (JobRead payload)
jobs
  | LogConfig -> Bool
loggingActive LogConfig
config = LogConfig
config {additionalContext = (buildJobContext jobs <>) <$> additionalContext config}
  | Bool
otherwise = LogConfig
config

-- | 'withJobContext' scoped to a single job.
withJobContextOne :: LogConfig -> Job.JobRead payload -> LogConfig
withJobContextOne :: forall payload. LogConfig -> JobRead payload -> LogConfig
withJobContextOne LogConfig
config JobRead payload
job = LogConfig -> NonEmpty (JobRead payload) -> LogConfig
forall payload.
LogConfig -> NonEmpty (JobRead payload) -> LogConfig
withJobContext LogConfig
config (JobRead payload
job JobRead payload -> [JobRead payload] -> NonEmpty (JobRead payload)
forall a. a -> [a] -> NonEmpty a
:| [])

-- | 'withJobContext' scoped to a job list. No context when the list is empty.
withJobContextList :: LogConfig -> [Job.JobRead payload] -> LogConfig
withJobContextList :: forall payload. LogConfig -> [JobRead payload] -> LogConfig
withJobContextList LogConfig
config = LogConfig
-> (NonEmpty (JobRead payload) -> LogConfig)
-> Maybe (NonEmpty (JobRead payload))
-> LogConfig
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LogConfig
config (LogConfig -> NonEmpty (JobRead payload) -> LogConfig
forall payload.
LogConfig -> NonEmpty (JobRead payload) -> LogConfig
withJobContext LogConfig
config) (Maybe (NonEmpty (JobRead payload)) -> LogConfig)
-> ([JobRead payload] -> Maybe (NonEmpty (JobRead payload)))
-> [JobRead payload]
-> LogConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JobRead payload] -> Maybe (NonEmpty (JobRead payload))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty

-- | True when some destination emits messages.
loggingActive :: LogConfig -> Bool
loggingActive :: LogConfig -> Bool
loggingActive = LogDestination -> Bool
destinationActive (LogDestination -> Bool)
-> (LogConfig -> LogDestination) -> LogConfig -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogConfig -> LogDestination
logDestination

destinationActive :: LogDestination -> Bool
destinationActive :: LogDestination -> Bool
destinationActive = \case
  LogDestination
LogDiscard -> Bool
False
  LogTee LogDestination
first LogDestination
second -> LogDestination -> Bool
destinationActive LogDestination
first Bool -> Bool -> Bool
|| LogDestination -> Bool
destinationActive LogDestination
second
  LogDestination
_ -> Bool
True

-- | Build structured context for a batch of jobs.
buildJobContext :: NonEmpty (Job.JobRead payload) -> [Pair]
buildJobContext :: forall payload. NonEmpty (JobRead payload) -> [Pair]
buildJobContext NonEmpty (JobRead payload)
jobs = [Key
"jobs" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (JobRead payload -> Value) -> [JobRead payload] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ([Pair] -> Value
object ([Pair] -> Value)
-> (JobRead payload -> [Pair]) -> JobRead payload -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead payload -> [Pair]
forall payload. JobRead payload -> [Pair]
mkContext) (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
toList NonEmpty (JobRead payload)
jobs)]
  where
    mkContext :: Job.JobRead payload -> [Pair]
    mkContext :: forall payload. JobRead payload -> [Pair]
mkContext JobRead payload
job =
      [ Key
"job_id" Key -> Int64 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
Job.primaryKey JobRead payload
job
      , Key
"job_attempts" Key -> Int32 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JobRead payload -> Int32
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Int32
Job.attempts JobRead payload
job
      , Key
"job_group_key" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
Job.groupKey JobRead payload
job
      , Key
"job_queue" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JobRead payload -> Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> q
Job.queueName JobRead payload
job
      ]

-- | Run an observability hook, catching and logging any exceptions.
runHook
  :: (MonadUnliftIO m)
  => LogConfig
  -> Text
  -- ^ Hook name (for logging)
  -> m ()
  -- ^ Hook action
  -> m ()
runHook :: forall (m :: * -> *).
MonadUnliftIO m =>
LogConfig -> Text -> m () -> m ()
runHook LogConfig
cfg Text
hookName m ()
action =
  m () -> m (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny m ()
action
    m (Either SomeException ())
-> (Either SomeException () -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> m ())
-> (() -> m ()) -> Either SomeException () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (\SomeException
exception -> LogConfig -> LogLevel -> Text -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
LogConfig -> LogLevel -> Text -> m ()
tryLog LogConfig
cfg LogLevel
Warning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Observability hook '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hookName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
displayEx SomeException
exception)
      () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Run an action and log a warning if it fails.
tryWarn :: (MonadUnliftIO m) => LogConfig -> Text -> m a -> m ()
tryWarn :: forall (m :: * -> *) a.
MonadUnliftIO m =>
LogConfig -> Text -> m a -> m ()
tryWarn LogConfig
logCfg Text
label m a
act = LogConfig -> Text -> () -> m () -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
LogConfig -> Text -> a -> m a -> m a
tryWarnWith LogConfig
logCfg Text
label () (m a -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m a
act)

-- | Run an action and return a fallback value if it fails.
tryWarnWith :: (MonadUnliftIO m) => LogConfig -> Text -> a -> m a -> m a
tryWarnWith :: forall (m :: * -> *) a.
MonadUnliftIO m =>
LogConfig -> Text -> a -> m a -> m a
tryWarnWith LogConfig
logCfg Text
label a
fallback m a
act =
  m a -> m (Either SomeException a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny m a
act m (Either SomeException a)
-> (Either SomeException a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> m a)
-> (a -> m a) -> Either SomeException a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\SomeException
exception -> a
fallback a -> m () -> m a
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LogConfig -> Text -> SomeException -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
LogConfig -> Text -> SomeException -> m ()
warnEx LogConfig
logCfg Text
label SomeException
exception) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure