{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Arbiter's logs as OTel log records.
module Arbiter.Otel.Logs
  ( loggerDestination
  , otelLogs
  ) where

import Arbiter.Worker.Logger (LogConfig (..), LogDestination (..), LogLevel (..), Pair)
import Control.Monad (void)
import Data.Aeson (Value (..))
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KM
import Data.Foldable (toList)
import Data.HashMap.Strict qualified as HM
import Data.Scientific (toRealFloat)
import Data.Text (Text)
import OpenTelemetry.Log.Core qualified as Log

-- | Send a config's logs to @dest@ as well as its own. 'Nothing' leaves the
-- destination alone. A config that discards its own logs still exports them.
otelLogs :: Maybe LogDestination -> LogConfig -> LogConfig
otelLogs :: Maybe LogDestination -> LogConfig -> LogConfig
otelLogs Maybe LogDestination
dest LogConfig
cfg = LogConfig
-> (LogDestination -> LogConfig)
-> Maybe LogDestination
-> LogConfig
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LogConfig
cfg (\LogDestination
destination -> LogConfig
cfg {logDestination = teed destination}) Maybe LogDestination
dest
  where
    teed :: LogDestination -> LogDestination
teed LogDestination
destination = case LogConfig -> LogDestination
logDestination LogConfig
cfg of
      LogDestination
LogDiscard -> LogDestination
destination
      LogDestination
existing -> LogDestination -> LogDestination -> LogDestination
LogTee LogDestination
existing LogDestination
destination

-- | Route Arbiter's logs to @provider@ as OTel log records.
loggerDestination :: Log.LoggerProvider -> LogDestination
loggerDestination :: LoggerProvider -> LogDestination
loggerDestination LoggerProvider
provider = (LogLevel -> Text -> [Pair] -> IO ()) -> LogDestination
LogCallback (Logger -> LogLevel -> Text -> [Pair] -> IO ()
otelLogCallback (LoggerProvider -> InstrumentationLibrary -> Logger
Log.makeLogger LoggerProvider
provider InstrumentationLibrary
"arbiter"))

-- | One Arbiter log line as an OTel log record, with its structured context as attributes.
otelLogCallback :: Log.Logger -> LogLevel -> Text -> [Pair] -> IO ()
otelLogCallback :: Logger -> LogLevel -> Text -> [Pair] -> IO ()
otelLogCallback Logger
logger LogLevel
level Text
msg [Pair]
context =
  IO ReadWriteLogRecord -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ReadWriteLogRecord -> IO ())
-> (LogRecordArguments -> IO ReadWriteLogRecord)
-> LogRecordArguments
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> LogRecordArguments -> IO ReadWriteLogRecord
forall (m :: * -> *).
MonadIO m =>
Logger -> LogRecordArguments -> m ReadWriteLogRecord
Log.emitLogRecord Logger
logger (LogRecordArguments -> IO ()) -> LogRecordArguments -> IO ()
forall a b. (a -> b) -> a -> b
$
    Log.LogRecordArguments
      { timestamp :: Maybe Timestamp
Log.timestamp = Maybe Timestamp
forall a. Maybe a
Nothing
      , observedTimestamp :: Maybe Timestamp
Log.observedTimestamp = Maybe Timestamp
forall a. Maybe a
Nothing
      , context :: Maybe Context
Log.context = Maybe Context
forall a. Maybe a
Nothing
      , -- The record derives the spec's short name.
        severityText :: Maybe Text
Log.severityText = Maybe Text
forall a. Maybe a
Nothing
      , severityNumber :: Maybe SeverityNumber
Log.severityNumber = SeverityNumber -> Maybe SeverityNumber
forall a. a -> Maybe a
Just (LogLevel -> SeverityNumber
severityOf LogLevel
level)
      , body :: AnyValue
Log.body = Text -> AnyValue
Log.TextValue Text
msg
      , attributes :: HashMap Text AnyValue
Log.attributes = [(Text, AnyValue)] -> HashMap Text AnyValue
forall k v. Hashable k => [(k, v)] -> HashMap k v
HM.fromList ((Pair -> (Text, AnyValue)) -> [Pair] -> [(Text, AnyValue)]
forall a b. (a -> b) -> [a] -> [b]
map Pair -> (Text, AnyValue)
logAttribute [Pair]
context)
      , eventName :: Maybe Text
Log.eventName = Maybe Text
forall a. Maybe a
Nothing
      }

severityOf :: LogLevel -> Log.SeverityNumber
severityOf :: LogLevel -> SeverityNumber
severityOf = \case
  LogLevel
Debug -> SeverityNumber
Log.Debug
  LogLevel
Info -> SeverityNumber
Log.Info
  LogLevel
Warning -> SeverityNumber
Log.Warn
  LogLevel
Error -> SeverityNumber
Log.Error

logAttribute :: Pair -> (Text, Log.AnyValue)
logAttribute :: Pair -> (Text, AnyValue)
logAttribute (Key
key, Value
value) = (Key -> Text
Key.toText Key
key, Value -> AnyValue
anyValue Value
value)

anyValue :: Value -> Log.AnyValue
anyValue :: Value -> AnyValue
anyValue = \case
  String Text
text -> Text -> AnyValue
Log.TextValue Text
text
  Bool Bool
bool -> Bool -> AnyValue
Log.BoolValue Bool
bool
  -- JSON has one number type. A key keeps one wire type.
  Number Scientific
number -> Double -> AnyValue
Log.DoubleValue (Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
number)
  Array Array
items -> [AnyValue] -> AnyValue
Log.ArrayValue ((Value -> AnyValue) -> [Value] -> [AnyValue]
forall a b. (a -> b) -> [a] -> [b]
map Value -> AnyValue
anyValue (Array -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
items))
  Object Object
object -> HashMap Text AnyValue -> AnyValue
Log.HashMapValue ([(Text, AnyValue)] -> HashMap Text AnyValue
forall k v. Hashable k => [(k, v)] -> HashMap k v
HM.fromList ((Pair -> (Text, AnyValue)) -> [Pair] -> [(Text, AnyValue)]
forall a b. (a -> b) -> [a] -> [b]
map Pair -> (Text, AnyValue)
logAttribute (Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
object)))
  Value
Null -> AnyValue
Log.NullValue