{-# LANGUAGE OverloadedStrings #-}

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

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

-- | 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.
Job 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.
Job 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.
Job 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.
Job 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 = LogConfig -> Text -> m () -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
LogConfig -> Text -> m a -> m ()
tryWarn LogConfig
cfg (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")

-- | Run an observability hook with the job in the log context.
jobHook :: (MonadUnliftIO m) => LogConfig -> Job.JobRead payload -> Text -> m () -> m ()
jobHook :: forall (m :: * -> *) payload.
MonadUnliftIO m =>
LogConfig -> JobRead payload -> Text -> m () -> m ()
jobHook LogConfig
cfg JobRead payload
job = LogConfig -> Text -> m () -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
LogConfig -> Text -> m () -> m ()
runHook (LogConfig -> NonEmpty (JobRead payload) -> LogConfig
forall payload.
LogConfig -> NonEmpty (JobRead payload) -> LogConfig
withJobContext LogConfig
cfg (JobRead payload
job JobRead payload -> [JobRead payload] -> NonEmpty (JobRead payload)
forall a. a -> [a] -> NonEmpty a
:| []))

-- | Log with the jobs in context.
poolLog :: LogConfig -> LogLevel -> [Job.JobRead payload] -> Text -> IO ()
poolLog :: forall payload.
LogConfig -> LogLevel -> [JobRead payload] -> Text -> IO ()
poolLog LogConfig
cfg LogLevel
level [JobRead payload]
jobs = LogConfig -> LogLevel -> Text -> IO ()
forall (m :: * -> *).
MonadUnliftIO m =>
LogConfig -> LogLevel -> Text -> m ()
tryLog (LogConfig
-> (NonEmpty (JobRead payload) -> LogConfig)
-> Maybe (NonEmpty (JobRead payload))
-> LogConfig
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LogConfig
cfg (LogConfig -> NonEmpty (JobRead payload) -> LogConfig
forall payload.
LogConfig -> NonEmpty (JobRead payload) -> LogConfig
withJobContext LogConfig
cfg) ([JobRead payload] -> Maybe (NonEmpty (JobRead payload))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [JobRead payload]
jobs)) LogLevel
level

-- | 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