{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}

{- |
Module      : OpenTelemetry.Internal.Log.Core
Copyright   :  (c) Ian Duncan, 2026
License     :  BSD-3
Description : Internal implementation of the Logs API: LoggerProvider creation, Logger, and LogRecord emission.
Stability   : experimental
-}
module OpenTelemetry.Internal.Log.Core (
  LoggerProviderOptions (..),
  emptyLoggerProviderOptions,
  createLoggerProvider,
  getLogger,
  setGlobalLoggerProvider,
  getGlobalLoggerProvider,
  shutdownLoggerProvider,
  ShutdownResult (..),
  forceFlushLoggerProvider,
  makeLogger,
  loggerIsEnabled,
  loggerIsEnabled',
  setLoggerMinSeverity,
  getLoggerMinSeverity,
  emitLogRecord,
  addAttribute,
  addAttributes,
  logRecordGetAttributes,
  emitOTelLogRecord,
) where

import Control.Applicative
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as H
import Data.IORef
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Version (showVersion)
import GHC.IO (unsafePerformIO)
import qualified OpenTelemetry.Attributes as A
import OpenTelemetry.Common
import OpenTelemetry.Context
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Internal.Common.Types
import OpenTelemetry.Internal.Log.Types
import OpenTelemetry.Internal.Logging (otelLogWarning)
import OpenTelemetry.Internal.Trace.Types (SpanContext (..), getSpanContext)
import OpenTelemetry.Internal.UnpackedMaybe (fromBaseMaybe)
import OpenTelemetry.LogAttributes (LogAttributes)
import qualified OpenTelemetry.LogAttributes as LA
import OpenTelemetry.Resource (MaterializedResources, emptyMaterializedResources)
import Paths_hs_opentelemetry_api (version)
import System.Timeout (timeout)


foreign import ccall unsafe "hs_otel_gettime_ns"
  getTimestampIO :: IO Timestamp


-- | @since 0.0.1.0
data LoggerProviderOptions = LoggerProviderOptions
  { LoggerProviderOptions -> MaterializedResources
loggerProviderOptionsResource :: MaterializedResources
  , LoggerProviderOptions -> AttributeLimits
loggerProviderOptionsAttributeLimits :: A.AttributeLimits
  , LoggerProviderOptions -> Maybe SeverityNumber
loggerProviderOptionsMinSeverity :: Maybe SeverityNumber
  {- ^ When @Just sev@, log records with severity below @sev@ are
  suppressed (both 'loggerIsEnabled' and 'emitLogRecord' respect
  this). 'Nothing' means no filtering. Can be changed at runtime
  via 'setLoggerMinSeverity'.
  -}
  }


{- | Options for creating a @LoggerProvider@ with no resources and default limits.

 In effect, logging is a no-op when using this configuration and no-op Processors.

@since 0.0.1.0
-}
emptyLoggerProviderOptions :: LoggerProviderOptions
emptyLoggerProviderOptions :: LoggerProviderOptions
emptyLoggerProviderOptions =
  LoggerProviderOptions
    { loggerProviderOptionsResource :: MaterializedResources
loggerProviderOptionsResource = MaterializedResources
emptyMaterializedResources
    , loggerProviderOptionsAttributeLimits :: AttributeLimits
loggerProviderOptionsAttributeLimits = AttributeLimits
A.defaultAttributeLimits
    , loggerProviderOptionsMinSeverity :: Maybe SeverityNumber
loggerProviderOptionsMinSeverity = Maybe SeverityNumber
forall a. Maybe a
Nothing
    }


{- | Initialize a new @LoggerProvider@

 You should generally use @getGlobalLoggerProvider@ for most applications.

@since 0.0.1.0
-}
createLoggerProvider :: (MonadIO m) => [LogRecordProcessor] -> LoggerProviderOptions -> m LoggerProvider
createLoggerProvider :: forall (m :: * -> *).
MonadIO m =>
[LogRecordProcessor] -> LoggerProviderOptions -> m LoggerProvider
createLoggerProvider [LogRecordProcessor]
ps LoggerProviderOptions {Maybe SeverityNumber
AttributeLimits
MaterializedResources
loggerProviderOptionsResource :: LoggerProviderOptions -> MaterializedResources
loggerProviderOptionsAttributeLimits :: LoggerProviderOptions -> AttributeLimits
loggerProviderOptionsMinSeverity :: LoggerProviderOptions -> Maybe SeverityNumber
loggerProviderOptionsResource :: MaterializedResources
loggerProviderOptionsAttributeLimits :: AttributeLimits
loggerProviderOptionsMinSeverity :: Maybe SeverityNumber
..} = IO LoggerProvider -> m LoggerProvider
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LoggerProvider -> m LoggerProvider)
-> IO LoggerProvider -> m LoggerProvider
forall a b. (a -> b) -> a -> b
$ do
  shutRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  sevRef <- newIORef loggerProviderOptionsMinSeverity
  loggerCache <- newIORef H.empty
  let !processors = [LogRecordProcessor] -> Vector LogRecordProcessor
forall a. [a] -> Vector a
V.fromList [LogRecordProcessor]
ps
      !hasProcs = Bool -> Bool
not (Vector LogRecordProcessor -> Bool
forall a. Vector a -> Bool
V.null Vector LogRecordProcessor
processors)
      !onEmit = case [LogRecordProcessor]
ps of
        [] -> \ReadWriteLogRecord
_ Context
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [LogRecordProcessor
p] -> LogRecordProcessor -> ReadWriteLogRecord -> Context -> IO ()
logRecordProcessorOnEmit LogRecordProcessor
p
        [LogRecordProcessor]
_ -> \ReadWriteLogRecord
lr Context
ctx -> (LogRecordProcessor -> IO ()) -> Vector LogRecordProcessor -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ (\LogRecordProcessor
p -> LogRecordProcessor -> ReadWriteLogRecord -> Context -> IO ()
logRecordProcessorOnEmit LogRecordProcessor
p ReadWriteLogRecord
lr Context
ctx) Vector LogRecordProcessor
processors
  pure
    LoggerProvider
      { loggerProviderProcessors = processors
      , loggerProviderResource = loggerProviderOptionsResource
      , loggerProviderAttributeLimits = loggerProviderOptionsAttributeLimits
      , loggerProviderIsShutdown = shutRef
      , loggerProviderHasProcessors = hasProcs
      , loggerProviderOnEmit = onEmit
      , loggerProviderMinSeverity = sevRef
      , loggerProviderLoggerCache = loggerCache
      }


globalLoggerProvider :: IORef LoggerProvider
globalLoggerProvider :: IORef LoggerProvider
globalLoggerProvider = IO (IORef LoggerProvider) -> IORef LoggerProvider
forall a. IO a -> a
unsafePerformIO (IO (IORef LoggerProvider) -> IORef LoggerProvider)
-> IO (IORef LoggerProvider) -> IORef LoggerProvider
forall a b. (a -> b) -> a -> b
$ do
  p <- [LogRecordProcessor] -> LoggerProviderOptions -> IO LoggerProvider
forall (m :: * -> *).
MonadIO m =>
[LogRecordProcessor] -> LoggerProviderOptions -> m LoggerProvider
createLoggerProvider [] LoggerProviderOptions
emptyLoggerProviderOptions
  newIORef p
{-# NOINLINE globalLoggerProvider #-}


{- | Access the globally configured @LoggerProvider@. This @LoggerProvider@ is no-op until initialized by the SDK

@since 0.0.1.0
-}
getGlobalLoggerProvider :: (MonadIO m) => m LoggerProvider
getGlobalLoggerProvider :: forall (m :: * -> *). MonadIO m => m LoggerProvider
getGlobalLoggerProvider = IO LoggerProvider -> m LoggerProvider
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LoggerProvider -> m LoggerProvider)
-> IO LoggerProvider -> m LoggerProvider
forall a b. (a -> b) -> a -> b
$ IORef LoggerProvider -> IO LoggerProvider
forall a. IORef a -> IO a
readIORef IORef LoggerProvider
globalLoggerProvider


{- | Overwrite the globally configured @LoggerProvider@.

 @Logger@s acquired from the previously installed @LoggerProvider@s
 will continue to use that @LoggerProvider@s settings.

@since 0.0.1.0
-}
setGlobalLoggerProvider :: (MonadIO m) => LoggerProvider -> m ()
setGlobalLoggerProvider :: forall (m :: * -> *). MonadIO m => LoggerProvider -> m ()
setGlobalLoggerProvider = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (LoggerProvider -> IO ()) -> LoggerProvider -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef LoggerProvider -> LoggerProvider -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef LoggerProvider
globalLoggerProvider


{- | This method provides a way for provider to do any cleanup required.

 This will also trigger shutdowns on all internal processors.

@since 0.0.1.0
-}
shutdownLoggerProvider
  :: (MonadIO m)
  => LoggerProvider
  -> Maybe Int
  -- ^ Optional timeout in microseconds, defaults to 5,000,000 (5s)
  -> m ShutdownResult
shutdownLoggerProvider :: forall (m :: * -> *).
MonadIO m =>
LoggerProvider -> Maybe Int -> m ShutdownResult
shutdownLoggerProvider LoggerProvider {Vector LogRecordProcessor
loggerProviderProcessors :: LoggerProvider -> Vector LogRecordProcessor
loggerProviderProcessors :: Vector LogRecordProcessor
loggerProviderProcessors, IORef Bool
loggerProviderIsShutdown :: LoggerProvider -> IORef Bool
loggerProviderIsShutdown :: IORef Bool
loggerProviderIsShutdown} Maybe Int
mtimeout = IO ShutdownResult -> m ShutdownResult
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ShutdownResult -> m ShutdownResult)
-> IO ShutdownResult -> m ShutdownResult
forall a b. (a -> b) -> a -> b
$ do
  alreadyShut <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
loggerProviderIsShutdown ((Bool -> (Bool, Bool)) -> IO Bool)
-> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Bool
s -> (Bool
True, Bool
s)
  if alreadyShut
    then pure ShutdownFailure
    else do
      jobs <- V.forM loggerProviderProcessors $ \LogRecordProcessor
processor ->
        IO ShutdownResult -> IO (Async ShutdownResult)
forall a. IO a -> IO (Async a)
async (LogRecordProcessor -> IO ShutdownResult
logRecordProcessorShutdown LogRecordProcessor
processor)
      mresult <-
        timeout (fromMaybe 5_000_000 mtimeout) $
          V.foldM
            ( \ShutdownResult
status Async ShutdownResult
action -> do
                res <- Async ShutdownResult -> IO (Either SomeException ShutdownResult)
forall a. Async a -> IO (Either SomeException a)
waitCatch Async ShutdownResult
action
                pure $! case res of
                  Left SomeException
_err -> ShutdownResult -> ShutdownResult -> ShutdownResult
worstShutdown ShutdownResult
status ShutdownResult
ShutdownFailure
                  Right ShutdownResult
sr -> ShutdownResult -> ShutdownResult -> ShutdownResult
worstShutdown ShutdownResult
status ShutdownResult
sr
            )
            ShutdownSuccess
            jobs
      case mresult of
        Maybe ShutdownResult
Nothing -> do
          (Async ShutdownResult -> IO ())
-> Vector (Async ShutdownResult) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ Async ShutdownResult -> IO ()
forall a. Async a -> IO ()
cancel Vector (Async ShutdownResult)
jobs
          ShutdownResult -> IO ShutdownResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShutdownResult
ShutdownTimeout
        Just ShutdownResult
res -> ShutdownResult -> IO ShutdownResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShutdownResult
res


{- | This method provides a way for provider to immediately export all @LogRecord@s that have not yet
 been exported for all the internal processors.

@since 0.0.1.0
-}
forceFlushLoggerProvider
  :: (MonadIO m)
  => LoggerProvider
  -> Maybe Int
  -- ^ Optional timeout in microseconds, defaults to 5,000,000 (5s)
  -> m FlushResult
  -- ^ Result that denotes whether the flush action succeeded, failed, or timed out.
forceFlushLoggerProvider :: forall (m :: * -> *).
MonadIO m =>
LoggerProvider -> Maybe Int -> m FlushResult
forceFlushLoggerProvider LoggerProvider {Vector LogRecordProcessor
loggerProviderProcessors :: LoggerProvider -> Vector LogRecordProcessor
loggerProviderProcessors :: Vector LogRecordProcessor
loggerProviderProcessors} Maybe Int
mtimeout = IO FlushResult -> m FlushResult
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FlushResult -> m FlushResult)
-> IO FlushResult -> m FlushResult
forall a b. (a -> b) -> a -> b
$ do
  jobs <- Vector LogRecordProcessor
-> (LogRecordProcessor -> IO (Async FlushResult))
-> IO (Vector (Async FlushResult))
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
V.forM Vector LogRecordProcessor
loggerProviderProcessors ((LogRecordProcessor -> IO (Async FlushResult))
 -> IO (Vector (Async FlushResult)))
-> (LogRecordProcessor -> IO (Async FlushResult))
-> IO (Vector (Async FlushResult))
forall a b. (a -> b) -> a -> b
$ \LogRecordProcessor
processor ->
    IO FlushResult -> IO (Async FlushResult)
forall a. IO a -> IO (Async a)
async (IO FlushResult -> IO (Async FlushResult))
-> IO FlushResult -> IO (Async FlushResult)
forall a b. (a -> b) -> a -> b
$
      LogRecordProcessor -> IO FlushResult
logRecordProcessorForceFlush LogRecordProcessor
processor
  mresult <-
    timeout (fromMaybe 5_000_000 mtimeout) $
      V.foldM
        ( \FlushResult
status Async FlushResult
action -> do
            res <- Async FlushResult -> IO (Either SomeException FlushResult)
forall a. Async a -> IO (Either SomeException a)
waitCatch Async FlushResult
action
            pure $! case res of
              Left SomeException
_err -> FlushResult
FlushError
              Right FlushResult
fr -> FlushResult -> FlushResult -> FlushResult
worstFlush FlushResult
status FlushResult
fr
        )
        FlushSuccess
        jobs
  case mresult of
    Maybe FlushResult
Nothing -> do
      (Async FlushResult -> IO ()) -> Vector (Async FlushResult) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ Async FlushResult -> IO ()
forall a. Async a -> IO ()
cancel Vector (Async FlushResult)
jobs
      FlushResult -> IO FlushResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FlushResult
FlushTimeout
    Just FlushResult
res -> FlushResult -> IO FlushResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FlushResult
res


-- | @since 0.0.1.0
makeLogger
  :: LoggerProvider
  -- ^ The @LoggerProvider@ holds the configuration for the @Logger@.
  -> InstrumentationLibrary
  {- ^ The library that the @Logger@ instruments. This uniquely identifies the @Logger@.
  Use a non-empty 'libraryName' per the OpenTelemetry specification; use 'getLogger'
  if you want a warning when the name is empty.
  -}
  -> Logger
makeLogger :: LoggerProvider -> InstrumentationLibrary -> Logger
makeLogger LoggerProvider
loggerLoggerProvider InstrumentationLibrary
loggerInstrumentationScope = Logger {InstrumentationLibrary
LoggerProvider
loggerLoggerProvider :: LoggerProvider
loggerInstrumentationScope :: InstrumentationLibrary
loggerInstrumentationScope :: InstrumentationLibrary
loggerLoggerProvider :: LoggerProvider
..}


{- | Like 'makeLogger', but logs a warning when 'libraryName' is empty.

@since 0.0.1.0
-}
getLogger :: (MonadIO m) => LoggerProvider -> InstrumentationLibrary -> m Logger
getLogger :: forall (m :: * -> *).
MonadIO m =>
LoggerProvider -> InstrumentationLibrary -> m Logger
getLogger LoggerProvider
lp InstrumentationLibrary
il = IO Logger -> m Logger
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Logger -> m Logger) -> IO Logger -> m Logger
forall a b. (a -> b) -> a -> b
$ do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null (InstrumentationLibrary -> Text
libraryName InstrumentationLibrary
il)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
otelLogWarning String
"Logger created with empty name; returning working Logger with empty name per spec"
  let !l :: Logger
l = LoggerProvider -> InstrumentationLibrary -> Logger
makeLogger LoggerProvider
lp InstrumentationLibrary
il
      !key :: InstrumentationLibrary
key = Logger -> InstrumentationLibrary
loggerInstrumentationScope Logger
l
  IORef (HashMap InstrumentationLibrary Logger)
-> (HashMap InstrumentationLibrary Logger
    -> (HashMap InstrumentationLibrary Logger, Logger))
-> IO Logger
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (LoggerProvider -> IORef (HashMap InstrumentationLibrary Logger)
loggerProviderLoggerCache LoggerProvider
lp) ((HashMap InstrumentationLibrary Logger
  -> (HashMap InstrumentationLibrary Logger, Logger))
 -> IO Logger)
-> (HashMap InstrumentationLibrary Logger
    -> (HashMap InstrumentationLibrary Logger, Logger))
-> IO Logger
forall a b. (a -> b) -> a -> b
$ \HashMap InstrumentationLibrary Logger
cache ->
    case InstrumentationLibrary
-> HashMap InstrumentationLibrary Logger -> Maybe Logger
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup InstrumentationLibrary
key HashMap InstrumentationLibrary Logger
cache of
      Just Logger
cached -> (HashMap InstrumentationLibrary Logger
cache, Logger
cached)
      Maybe Logger
Nothing -> (InstrumentationLibrary
-> Logger
-> HashMap InstrumentationLibrary Logger
-> HashMap InstrumentationLibrary Logger
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert InstrumentationLibrary
key Logger
l HashMap InstrumentationLibrary Logger
cache, Logger
l)


{- | Returns @True@ if a log record with the given severity (and optional
event name) would be forwarded to processors.

Checks, in order:

1. Whether the provider has any registered processors.
2. Whether the provider has been shut down.
3. Whether the record's severity meets the provider's minimum severity
   threshold (set via 'LoggerProviderOptions' or 'setLoggerMinSeverity').

When the caller passes 'Nothing' for severity, the minimum-severity gate
is skipped (the record is allowed through).

Callers SHOULD invoke this before each log emit to get the most up-to-date
response, as the result may change over time.

@since 0.1.0.0
-}
loggerIsEnabled :: Logger -> Maybe SeverityNumber -> Maybe Text -> IO Bool
loggerIsEnabled :: Logger -> Maybe SeverityNumber -> Maybe Text -> IO Bool
loggerIsEnabled Logger {loggerLoggerProvider :: Logger -> LoggerProvider
loggerLoggerProvider = LoggerProvider
lp} Maybe SeverityNumber
severity Maybe Text
_eventName = do
  if Bool -> Bool
not (LoggerProvider -> Bool
loggerProviderHasProcessors LoggerProvider
lp)
    then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    else do
      isShutdown <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (LoggerProvider -> IORef Bool
loggerProviderIsShutdown LoggerProvider
lp)
      if isShutdown
        then pure False
        else case severity of
          Maybe SeverityNumber
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          Just SeverityNumber
sev -> do
            minSev <- IORef (Maybe SeverityNumber) -> IO (Maybe SeverityNumber)
forall a. IORef a -> IO a
readIORef (LoggerProvider -> IORef (Maybe SeverityNumber)
loggerProviderMinSeverity LoggerProvider
lp)
            pure $! case minSev of
              Maybe SeverityNumber
Nothing -> Bool
True
              Just SeverityNumber
threshold -> SeverityNumber
sev SeverityNumber -> SeverityNumber -> Bool
forall a. Ord a => a -> a -> Bool
>= SeverityNumber
threshold
{-# INLINE loggerIsEnabled #-}


{- | Like 'loggerIsEnabled' but accepts an explicit 'Context'.
When 'Nothing', uses the current implicit context.

@since 0.4.0.0
-}
loggerIsEnabled' :: (MonadIO m) => Logger -> Maybe SeverityNumber -> Maybe Text -> Maybe Context -> m Bool
loggerIsEnabled' :: forall (m :: * -> *).
MonadIO m =>
Logger
-> Maybe SeverityNumber -> Maybe Text -> Maybe Context -> m Bool
loggerIsEnabled' Logger
logger Maybe SeverityNumber
msev Maybe Text
mname Maybe Context
_mctx = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Logger -> Maybe SeverityNumber -> Maybe Text -> IO Bool
loggerIsEnabled Logger
logger Maybe SeverityNumber
msev Maybe Text
mname
{-# INLINE loggerIsEnabled' #-}


{- | Set the minimum severity for a 'LoggerProvider' at runtime.

Log records with a severity below the threshold will be suppressed by
both 'loggerIsEnabled' and 'emitLogRecord'. Pass 'Nothing' to disable
severity filtering (the default).

@since 0.4.0.0
-}
setLoggerMinSeverity :: (MonadIO m) => LoggerProvider -> Maybe SeverityNumber -> m ()
setLoggerMinSeverity :: forall (m :: * -> *).
MonadIO m =>
LoggerProvider -> Maybe SeverityNumber -> m ()
setLoggerMinSeverity LoggerProvider
lp = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (Maybe SeverityNumber -> IO ()) -> Maybe SeverityNumber -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Maybe SeverityNumber) -> Maybe SeverityNumber -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef (LoggerProvider -> IORef (Maybe SeverityNumber)
loggerProviderMinSeverity LoggerProvider
lp)


{- | Read the current minimum severity threshold for a 'LoggerProvider'.

Returns 'Nothing' when no severity filtering is active.

@since 0.4.0.0
-}
getLoggerMinSeverity :: (MonadIO m) => LoggerProvider -> m (Maybe SeverityNumber)
getLoggerMinSeverity :: forall (m :: * -> *).
MonadIO m =>
LoggerProvider -> m (Maybe SeverityNumber)
getLoggerMinSeverity = IO (Maybe SeverityNumber) -> m (Maybe SeverityNumber)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe SeverityNumber) -> m (Maybe SeverityNumber))
-> (LoggerProvider -> IO (Maybe SeverityNumber))
-> LoggerProvider
-> m (Maybe SeverityNumber)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Maybe SeverityNumber) -> IO (Maybe SeverityNumber)
forall a. IORef a -> IO a
readIORef (IORef (Maybe SeverityNumber) -> IO (Maybe SeverityNumber))
-> (LoggerProvider -> IORef (Maybe SeverityNumber))
-> LoggerProvider
-> IO (Maybe SeverityNumber)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggerProvider -> IORef (Maybe SeverityNumber)
loggerProviderMinSeverity


createImmutableLogRecord
  :: LA.AttributeLimits
  -> Context
  -> LogRecordArguments
  -> IO ImmutableLogRecord
createImmutableLogRecord :: AttributeLimits
-> Context -> LogRecordArguments -> IO ImmutableLogRecord
createImmutableLogRecord AttributeLimits
attributeLimits !Context
ctx LogRecordArguments {Maybe Text
Maybe Timestamp
Maybe Context
Maybe SeverityNumber
HashMap Text AnyValue
AnyValue
timestamp :: Maybe Timestamp
observedTimestamp :: Maybe Timestamp
context :: Maybe Context
severityText :: Maybe Text
severityNumber :: Maybe SeverityNumber
body :: AnyValue
attributes :: HashMap Text AnyValue
eventName :: Maybe Text
attributes :: LogRecordArguments -> HashMap Text AnyValue
body :: LogRecordArguments -> AnyValue
context :: LogRecordArguments -> Maybe Context
eventName :: LogRecordArguments -> Maybe Text
observedTimestamp :: LogRecordArguments -> Maybe Timestamp
severityNumber :: LogRecordArguments -> Maybe SeverityNumber
severityText :: LogRecordArguments -> Maybe Text
timestamp :: LogRecordArguments -> Maybe Timestamp
..} = do
  currentTimestamp <- IO Timestamp
getTimestampIO
  let !logRecordObservedTimestamp = Timestamp -> Maybe Timestamp -> Timestamp
forall a. a -> Maybe a -> a
fromMaybe Timestamp
currentTimestamp Maybe Timestamp
observedTimestamp

  logRecordTracingDetails <- case lookupSpan ctx of
    Maybe Span
Nothing -> TracingDetails -> IO TracingDetails
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TracingDetails
NoTracingDetails
    Just Span
s -> do
      SpanContext {traceId, spanId, traceFlags} <- Span -> IO SpanContext
forall (m :: * -> *). MonadIO m => Span -> m SpanContext
getSpanContext Span
s
      pure $! TracingDetails traceId spanId traceFlags

  let !logRecordAttributes =
        AttributeLimits
-> LogAttributes -> HashMap Text AnyValue -> LogAttributes
forall a.
ToValue a =>
AttributeLimits -> LogAttributes -> HashMap Text a -> LogAttributes
LA.addAttributes
          AttributeLimits
attributeLimits
          LogAttributes
LA.emptyAttributes
          HashMap Text AnyValue
attributes
      !droppedCount = LogAttributes -> Int
LA.attributesDropped LogAttributes
logRecordAttributes

  when (droppedCount > 0) $
    otelLogWarning ("LogRecord dropped " <> show droppedCount <> " attribute(s) due to limits")

  pure
    ImmutableLogRecord
      { logRecordTimestamp = fromBaseMaybe timestamp
      , logRecordObservedTimestamp
      , logRecordTracingDetails
      , logRecordSeverityNumber = fromBaseMaybe severityNumber
      , logRecordSeverityText = fromBaseMaybe (severityText <|> (toShortName =<< severityNumber))
      , logRecordBody = body
      , logRecordAttributes
      , logRecordEventName = fromBaseMaybe eventName
      }


-- | WARNING: this function should only be used to emit logs from the hs-opentelemetry-api library. DO NOT USE this function in any other context.
emitOTelLogRecord :: (MonadIO m) => H.HashMap Text LA.AnyValue -> SeverityNumber -> Text -> m ReadWriteLogRecord
emitOTelLogRecord :: forall (m :: * -> *).
MonadIO m =>
HashMap Text AnyValue
-> SeverityNumber -> Text -> m ReadWriteLogRecord
emitOTelLogRecord HashMap Text AnyValue
attrs SeverityNumber
severity Text
bodyText = do
  glp <- m LoggerProvider
forall (m :: * -> *). MonadIO m => m LoggerProvider
getGlobalLoggerProvider
  let gl =
        LoggerProvider -> InstrumentationLibrary -> Logger
makeLogger LoggerProvider
glp (InstrumentationLibrary -> Logger)
-> InstrumentationLibrary -> Logger
forall a b. (a -> b) -> a -> b
$
          InstrumentationLibrary
            { libraryName :: Text
libraryName = Text
"hs-opentelemetry-api"
            , libraryVersion :: Text
libraryVersion = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Version -> String
showVersion Version
version
            , librarySchemaUrl :: Text
librarySchemaUrl = Text
""
            , libraryAttributes :: Attributes
libraryAttributes = Attributes
A.emptyAttributes
            }

  emitLogRecord gl $
    emptyLogRecordArguments
      { severityNumber = Just severity
      , body = toValue bodyText
      , attributes = attrs
      }


{- | Emits a @LogRecord@ with properties specified by the passed in Logger and LogRecordArguments.
If observedTimestamp is not set in LogRecordArguments, it will default to the current timestamp.
If context is not specified in LogRecordArguments it will default to the current context.

The emitted @LogRecord@ will be passed to any @LogRecordProcessor@s registered on the @LoggerProvider@
that created the @Logger@, provided the record's severity meets the provider's minimum severity
threshold.

@since 0.0.1.0
-}
emitLogRecord
  :: (MonadIO m)
  => Logger
  -> LogRecordArguments
  -> m ReadWriteLogRecord
emitLogRecord :: forall (m :: * -> *).
MonadIO m =>
Logger -> LogRecordArguments -> m ReadWriteLogRecord
emitLogRecord Logger
l LogRecordArguments
args = IO ReadWriteLogRecord -> m ReadWriteLogRecord
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ReadWriteLogRecord -> m ReadWriteLogRecord)
-> IO ReadWriteLogRecord -> m ReadWriteLogRecord
forall a b. (a -> b) -> a -> b
$ do
  let !lp :: LoggerProvider
lp = Logger -> LoggerProvider
loggerLoggerProvider Logger
l
  ctx <- IO Context
-> (Context -> IO Context) -> Maybe Context -> IO Context
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Context
forall (m :: * -> *). MonadIO m => m Context
getContext Context -> IO Context
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LogRecordArguments -> Maybe Context
context LogRecordArguments
args)
  ilr <- createImmutableLogRecord (loggerProviderAttributeLimits lp) ctx args
  lr <- mkReadWriteLogRecord l ilr
  when (loggerProviderHasProcessors lp) $ do
    isShutdown <- readIORef (loggerProviderIsShutdown lp)
    unless isShutdown $ do
      minSev <- readIORef (loggerProviderMinSeverity lp)
      let dominated = case Maybe SeverityNumber
minSev of
            Maybe SeverityNumber
Nothing -> Bool
False
            Just SeverityNumber
threshold -> case LogRecordArguments -> Maybe SeverityNumber
severityNumber LogRecordArguments
args of
              Maybe SeverityNumber
Nothing -> Bool
False
              Just SeverityNumber
sev -> SeverityNumber
sev SeverityNumber -> SeverityNumber -> Bool
forall a. Ord a => a -> a -> Bool
< SeverityNumber
threshold
      unless dominated $
        loggerProviderOnEmit lp lr ctx
  pure lr


{- | Add an attribute to a log record. Not an atomic modification.

See the [OTel attribute naming conventions](https://opentelemetry.io/docs/specs/otel/common/attribute-naming/)
for guidance on choosing attribute names.

@since 0.0.1.0
-}
addAttribute :: (IsReadWriteLogRecord r, MonadIO m, ToValue a) => r -> Text -> a -> m ()
addAttribute :: forall r (m :: * -> *) a.
(IsReadWriteLogRecord r, MonadIO m, ToValue a) =>
r -> Text -> a -> m ()
addAttribute r
lr Text
k a
v =
  let attributeLimits :: AttributeLimits
attributeLimits = r -> AttributeLimits
forall r. IsReadWriteLogRecord r => r -> AttributeLimits
readLogRecordAttributeLimits r
lr
  in IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
       r -> (ImmutableLogRecord -> ImmutableLogRecord) -> IO ()
forall r.
IsReadWriteLogRecord r =>
r -> (ImmutableLogRecord -> ImmutableLogRecord) -> IO ()
modifyLogRecord
         r
lr
         ( \ilr :: ImmutableLogRecord
ilr@ImmutableLogRecord {LogAttributes
logRecordAttributes :: ImmutableLogRecord -> LogAttributes
logRecordAttributes :: LogAttributes
logRecordAttributes} ->
             ImmutableLogRecord
ilr
               { logRecordAttributes =
                   LA.addAttribute
                     attributeLimits
                     logRecordAttributes
                     k
                     v
               }
         )


{- | A convenience function related to 'addAttribute' that adds multiple attributes to a @LogRecord@ at the same time.

This function may be slightly more performant than repeatedly calling 'addAttribute'.

This is not an atomic modification

@since 0.0.1.0
-}
addAttributes :: (IsReadWriteLogRecord r, MonadIO m, ToValue a) => r -> HashMap Text a -> m ()
addAttributes :: forall r (m :: * -> *) a.
(IsReadWriteLogRecord r, MonadIO m, ToValue a) =>
r -> HashMap Text a -> m ()
addAttributes r
lr HashMap Text a
attrs =
  let attributeLimits :: AttributeLimits
attributeLimits = r -> AttributeLimits
forall r. IsReadWriteLogRecord r => r -> AttributeLimits
readLogRecordAttributeLimits r
lr
  in IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
       r -> (ImmutableLogRecord -> ImmutableLogRecord) -> IO ()
forall r.
IsReadWriteLogRecord r =>
r -> (ImmutableLogRecord -> ImmutableLogRecord) -> IO ()
modifyLogRecord
         r
lr
         ( \ilr :: ImmutableLogRecord
ilr@ImmutableLogRecord {LogAttributes
logRecordAttributes :: ImmutableLogRecord -> LogAttributes
logRecordAttributes :: LogAttributes
logRecordAttributes} ->
             ImmutableLogRecord
ilr
               { logRecordAttributes =
                   LA.addAttributes
                     attributeLimits
                     logRecordAttributes
                     attrs
               }
         )


{- | This can be useful for pulling data for attributes and
 using it to copy / otherwise use the data to further enrich
 instrumentation.

@since 0.0.1.0
-}
logRecordGetAttributes :: (IsReadableLogRecord r, MonadIO m) => r -> m LogAttributes
logRecordGetAttributes :: forall r (m :: * -> *).
(IsReadableLogRecord r, MonadIO m) =>
r -> m LogAttributes
logRecordGetAttributes r
lr = IO LogAttributes -> m LogAttributes
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LogAttributes -> m LogAttributes)
-> IO LogAttributes -> m LogAttributes
forall a b. (a -> b) -> a -> b
$ ImmutableLogRecord -> LogAttributes
logRecordAttributes (ImmutableLogRecord -> LogAttributes)
-> IO ImmutableLogRecord -> IO LogAttributes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r -> IO ImmutableLogRecord
forall r. IsReadableLogRecord r => r -> IO ImmutableLogRecord
readLogRecord r
lr