-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | The severity mapping, the scribe and the formatters behind "Ecluse.Runtime.Log", which
documents the pipeline and re-exports the curated surface. Importing this module opts out of
that stability promise, the convention @text@ and @bytestring@ use, so production code imports
the public one.
-}
module Ecluse.Runtime.Log.Internal (
    -- * Log format
    LogFormat (..),
    parseLogFormat,

    -- * Log level
    LogLevel (..),
    parseLogLevel,
    severityFloor,
    severityStatus,

    -- * Pipeline construction
    newLogEnv,
    newScribe,
    formatterFor,

    -- * Structured context
    moduleField,

    -- * Log lines outside a handler
    moduleContext,
    logLine,
    moduleLog,

    -- * Datadog trace correlation
    DdContext (..),
    DdSpan (..),
    ddField,
    ddObject,
) where

import Data.Aeson (Value (Object, String), object, toJSON, (.=))
import Data.Aeson.Key (Key)
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Text (encodeToLazyText)
import Data.Text.Lazy.Builder qualified as TB
import Data.Universe.Class (Universe (..))
import Data.Universe.Generic (universeGeneric)
import Katip (
    ColorStrategy (ColorLog),
    Environment,
    Item (..),
    LogEnv,
    LogItem,
    Namespace (Namespace),
    Scribe,
    Severity (AlertS, CriticalS, DebugS, EmergencyS, ErrorS, InfoS, NoticeS, WarningS),
    SimpleLogPayload,
    Verbosity (V2),
    defaultScribeSettings,
    initLogEnv,
    itemJson,
    logFM,
    ls,
    permitItem,
    registerScribe,
    sl,
    unLogStr,
 )
import Katip.Monadic (KatipContextT, runKatipContextT)
import Katip.Scribes.Handle (ItemFormatter, bracketFormat, mkHandleScribeWithFormatter)

import Ecluse.Core.Wire (WireVocab (..), parseWire)

-- | The on-the-wire shape of the log stream, selected by configuration.
data LogFormat
    = {- | One compact JSON object per line to stdout (JSONL): the in-container
      default a log collector's stdout JSON parsing consumes.
      -}
      JsonLog
    | -- | The human-readable bracketed form, for local development.
      ConsoleLog
    deriving stock (LogFormat -> LogFormat -> Bool
(LogFormat -> LogFormat -> Bool)
-> (LogFormat -> LogFormat -> Bool) -> Eq LogFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogFormat -> LogFormat -> Bool
== :: LogFormat -> LogFormat -> Bool
$c/= :: LogFormat -> LogFormat -> Bool
/= :: LogFormat -> LogFormat -> Bool
Eq, (forall x. LogFormat -> Rep LogFormat x)
-> (forall x. Rep LogFormat x -> LogFormat) -> Generic LogFormat
forall x. Rep LogFormat x -> LogFormat
forall x. LogFormat -> Rep LogFormat x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LogFormat -> Rep LogFormat x
from :: forall x. LogFormat -> Rep LogFormat x
$cto :: forall x. Rep LogFormat x -> LogFormat
to :: forall x. Rep LogFormat x -> LogFormat
Generic, Int -> LogFormat -> ShowS
[LogFormat] -> ShowS
LogFormat -> String
(Int -> LogFormat -> ShowS)
-> (LogFormat -> String)
-> ([LogFormat] -> ShowS)
-> Show LogFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogFormat -> ShowS
showsPrec :: Int -> LogFormat -> ShowS
$cshow :: LogFormat -> String
show :: LogFormat -> String
$cshowList :: [LogFormat] -> ShowS
showList :: [LogFormat] -> ShowS
Show)

instance Universe LogFormat where universe :: [LogFormat]
universe = [LogFormat]
forall a. (Generic a, GUniverse (Rep a)) => [a]
universeGeneric

-- The wire vocabulary of a 'LogFormat': the single source both 'parseWire' and
-- the accepted-set message derive from for this type.
instance WireVocab LogFormat where
    wireKind :: Text
wireKind = Text
"log format"
    wireTable :: NonEmpty (LogFormat, Text)
wireTable =
        (LogFormat
JsonLog, Text
"json")
            (LogFormat, Text)
-> [(LogFormat, Text)] -> NonEmpty (LogFormat, Text)
forall a. a -> [a] -> NonEmpty a
:| [(LogFormat
ConsoleLog, Text
"console")]

{- | Parse a 'LogFormat' from its wire name, naming the accepted set on failure.

>>> parseLogFormat "json"
Right JsonLog

>>> parseLogFormat "yaml"
Left "unknown log format \"yaml\" (expected one of: json, console)"
-}
parseLogFormat :: Text -> Either Text LogFormat
parseLogFormat :: Text -> Either Text LogFormat
parseLogFormat = Text -> Either Text LogFormat
forall a. WireVocab a => Text -> Either Text a
parseWire

{- | The lowest severity the stream keeps, selected by configuration. The four values are the
ones 'severityStatus' renders into the @status@ field.
-}
data LogLevel
    = -- | Keep everything, the per-decision diagnostics included.
      DebugLevel
    | -- | The default: normal runtime conditions and worse.
      InfoLevel
    | -- | Warnings and worse.
      WarnLevel
    | -- | Errors alone.
      ErrorLevel
    deriving stock (LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
/= :: LogLevel -> LogLevel -> Bool
Eq, (forall x. LogLevel -> Rep LogLevel x)
-> (forall x. Rep LogLevel x -> LogLevel) -> Generic LogLevel
forall x. Rep LogLevel x -> LogLevel
forall x. LogLevel -> Rep LogLevel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LogLevel -> Rep LogLevel x
from :: forall x. LogLevel -> Rep LogLevel x
$cto :: forall x. Rep LogLevel x -> LogLevel
to :: forall x. Rep LogLevel x -> LogLevel
Generic, Eq LogLevel
Eq LogLevel =>
(LogLevel -> LogLevel -> Ordering)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> LogLevel)
-> (LogLevel -> LogLevel -> LogLevel)
-> Ord LogLevel
LogLevel -> LogLevel -> Bool
LogLevel -> LogLevel -> Ordering
LogLevel -> LogLevel -> LogLevel
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LogLevel -> LogLevel -> Ordering
compare :: LogLevel -> LogLevel -> Ordering
$c< :: LogLevel -> LogLevel -> Bool
< :: LogLevel -> LogLevel -> Bool
$c<= :: LogLevel -> LogLevel -> Bool
<= :: LogLevel -> LogLevel -> Bool
$c> :: LogLevel -> LogLevel -> Bool
> :: LogLevel -> LogLevel -> Bool
$c>= :: LogLevel -> LogLevel -> Bool
>= :: LogLevel -> LogLevel -> Bool
$cmax :: LogLevel -> LogLevel -> LogLevel
max :: LogLevel -> LogLevel -> LogLevel
$cmin :: LogLevel -> LogLevel -> LogLevel
min :: LogLevel -> LogLevel -> LogLevel
Ord, Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogLevel -> ShowS
showsPrec :: Int -> LogLevel -> ShowS
$cshow :: LogLevel -> String
show :: LogLevel -> String
$cshowList :: [LogLevel] -> ShowS
showList :: [LogLevel] -> ShowS
Show)

instance Universe LogLevel where universe :: [LogLevel]
universe = [LogLevel]
forall a. (Generic a, GUniverse (Rep a)) => [a]
universeGeneric

-- The wire vocabulary of a 'LogLevel', listed from most to least verbose so the
-- accepted-set message reads as a ladder.
instance WireVocab LogLevel where
    wireKind :: Text
wireKind = Text
"log level"
    wireTable :: NonEmpty (LogLevel, Text)
wireTable =
        (LogLevel
DebugLevel, Text
"debug")
            (LogLevel, Text) -> [(LogLevel, Text)] -> NonEmpty (LogLevel, Text)
forall a. a -> [a] -> NonEmpty a
:| [ (LogLevel
InfoLevel, Text
"info")
               , (LogLevel
WarnLevel, Text
"warn")
               , (LogLevel
ErrorLevel, Text
"error")
               ]

{- | Parse a 'LogLevel' from its wire name, naming the accepted set on failure.

>>> parseLogLevel "warn"
Right WarnLevel

>>> parseLogLevel "trace"
Left "unknown log level \"trace\" (expected one of: debug, info, warn, error)"
-}
parseLogLevel :: Text -> Either Text LogLevel
parseLogLevel :: Text -> Either Text LogLevel
parseLogLevel = Text -> Either Text LogLevel
forall a. WireVocab a => Text -> Either Text a
parseWire

{- | The @katip@ 'Severity' floor a 'LogLevel' admits: the scribe keeps an item at or above it.
'InfoLevel' therefore keeps 'NoticeS' as well as 'InfoS', since @katip@ orders its severities.
-}
severityFloor :: LogLevel -> Severity
severityFloor :: LogLevel -> Severity
severityFloor = \case
    LogLevel
DebugLevel -> Severity
DebugS
    LogLevel
InfoLevel -> Severity
InfoS
    LogLevel
WarnLevel -> Severity
WarningS
    LogLevel
ErrorLevel -> Severity
ErrorS

{- | The @status@ a @katip@ 'Severity' renders as. A log backend's status facet reads the
four values an operator acts on, so the eight syslog severities fold into them.
-}
severityStatus :: Severity -> Text
severityStatus :: Severity -> Text
severityStatus = \case
    Severity
DebugS -> Text
"debug"
    Severity
InfoS -> Text
"info"
    Severity
NoticeS -> Text
"info"
    Severity
WarningS -> Text
"warn"
    Severity
ErrorS -> Text
"error"
    Severity
CriticalS -> Text
"error"
    Severity
AlertS -> Text
"error"
    Severity
EmergencyS -> Text
"error"

{- | Build the 'LogEnv': one stdout scribe in @format@ that keeps items at or above @level@.
The formatter stamps @logIdentity@ on every line, so a line outside a span names its service.
-}
newLogEnv :: LogFormat -> LogLevel -> DdContext -> Environment -> IO LogEnv
newLogEnv :: LogFormat -> LogLevel -> DdContext -> Environment -> IO LogEnv
newLogEnv LogFormat
format LogLevel
level DdContext
logIdentity Environment
environment = do
    scribe <- LogFormat -> LogLevel -> DdContext -> IO Scribe
newScribe LogFormat
format LogLevel
level DdContext
logIdentity
    base <- initLogEnv (Namespace ["ecluse"]) environment
    registerScribe "stdout" scribe defaultScribeSettings base

{- | Build the stdout 'Scribe' for a 'LogFormat' at a 'LogLevel'. Colour is forced off so no
ANSI escape leaks into a 'JsonLog' object and each line stays valid JSON.
-}
newScribe :: LogFormat -> LogLevel -> DdContext -> IO Scribe
newScribe :: LogFormat -> LogLevel -> DdContext -> IO Scribe
newScribe LogFormat
format LogLevel
level DdContext
logIdentity =
    (forall a. LogItem a => ItemFormatter a)
-> ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
mkHandleScribeWithFormatter
        (LogFormat -> DdContext -> ItemFormatter a
forall a. LogItem a => LogFormat -> DdContext -> ItemFormatter a
formatterFor LogFormat
format DdContext
logIdentity)
        (Bool -> ColorStrategy
ColorLog Bool
False)
        Handle
stdout
        (Severity -> Item a -> IO Bool
forall (m :: * -> *) a. Monad m => Severity -> Item a -> m Bool
permitItem (LogLevel -> Severity
severityFloor LogLevel
level))
        Verbosity
V2

{- | The @katip@ 'ItemFormatter' a 'LogFormat' wires into its scribe. Only the 'JsonLog' form
stamps the @dd@ identity, and 'ConsoleLog' drops it.
-}
formatterFor :: (LogItem a) => LogFormat -> DdContext -> ItemFormatter a
formatterFor :: forall a. LogItem a => LogFormat -> DdContext -> ItemFormatter a
formatterFor LogFormat
format DdContext
logIdentity = case LogFormat
format of
    LogFormat
JsonLog -> DdContext -> ItemFormatter a
forall a. LogItem a => DdContext -> ItemFormatter a
jsonLineFormat DdContext
logIdentity
    LogFormat
ConsoleLog -> ItemFormatter a
forall a. LogItem a => ItemFormatter a
bracketFormat

{- The JSONL encoder: one compact JSON object, no trailing newline (the handle scribe adds it).
The colourise flag is ignored because ANSI escapes would make the line invalid JSON. -}
jsonLineFormat :: (LogItem a) => DdContext -> ItemFormatter a
jsonLineFormat :: forall a. LogItem a => DdContext -> ItemFormatter a
jsonLineFormat DdContext
logIdentity Bool
_colourise Verbosity
verb Item a
logItem =
    Text -> Builder
TB.fromLazyText (Value -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText (DdContext -> Verbosity -> Item a -> Value
forall a. LogItem a => DdContext -> Verbosity -> Item a -> Value
jsonLine DdContext
logIdentity Verbosity
verb Item a
logItem))

{- The emitter's own @katip@ fields nest under @katip@, so they cannot collide with a reserved
top-level attribute a log backend reads. -}
jsonLine :: (LogItem a) => DdContext -> Verbosity -> Item a -> Value
jsonLine :: forall a. LogItem a => DdContext -> Verbosity -> Item a -> Value
jsonLine DdContext
logIdentity Verbosity
verb Item a
logItem =
    Object -> Value
Object ([Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList (DdContext -> Item a -> Object -> Object -> [Pair]
forall a. DdContext -> Item a -> Object -> Object -> [Pair]
reservedFields DdContext
context Item a
logItem Object
structured Object
katipObject [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> DdContext -> [Pair]
whenPresent DdContext
context))
  where
    katipObject :: KeyMap.KeyMap Value
    katipObject :: Object
katipObject = case Verbosity -> Item a -> Value
forall a. LogItem a => Verbosity -> Item a -> Value
itemJson Verbosity
verb Item a
logItem of
        Object Object
o -> Object
o
        Value
_ -> Object
forall v. KeyMap v
KeyMap.empty

    structured :: KeyMap.KeyMap Value
    structured :: Object
structured = case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"data" Object
katipObject of
        Just (Object Object
o) -> Object
o
        Maybe Value
_ -> Object
forall v. KeyMap v
KeyMap.empty

    -- The identity, with the log site's own active span filled in when it installed one.
    context :: DdContext
    context :: DdContext
context = DdContext
logIdentity{ddSpan = payloadSpan structured <|> ddSpan logIdentity}

reservedFields :: DdContext -> Item a -> KeyMap.KeyMap Value -> KeyMap.KeyMap Value -> [(Key, Value)]
reservedFields :: forall a. DdContext -> Item a -> Object -> Object -> [Pair]
reservedFields DdContext
context Item a
logItem Object
structured Object
katipObject =
    [ (Key
"timestamp", UTCTime -> Value
forall a. ToJSON a => a -> Value
toJSON (Item a -> UTCTime
forall a. Item a -> UTCTime
_itemTime Item a
logItem))
    , (Key
"status", Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Severity -> Text
severityStatus (Item a -> Severity
forall a. Item a -> Severity
_itemSeverity Item a
logItem)))
    , (Key
"message", Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Builder -> Text
TB.toLazyText (LogStr -> Builder
unLogStr (Item a -> LogStr
forall a. Item a -> LogStr
_itemMessage Item a
logItem))))
    , (Key
"service", Text -> Value
forall a. ToJSON a => a -> Value
toJSON (DdContext -> Text
ddService DdContext
context))
    , (Key
"env", Value -> (Text -> Value) -> Maybe Text -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Environment -> Value
forall a. ToJSON a => a -> Value
toJSON (Item a -> Environment
forall a. Item a -> Environment
_itemEnv Item a
logItem)) Text -> Value
forall a. ToJSON a => a -> Value
toJSON (DdContext -> Maybe Text
ddEnv DdContext
context))
    , (Key
"data", Object -> Value
Object (Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
"dd" Object
structured))
    , (Key
"katip", Object -> Value
Object ((Key -> Value -> Bool) -> Object -> Object
forall v. (Key -> v -> Bool) -> KeyMap v -> KeyMap v
KeyMap.filterWithKey (\Key
key Value
_ -> Key
key Key -> [Key] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Key]
promoted) Object
katipObject))
    ]

whenPresent :: DdContext -> [(Key, Value)]
whenPresent :: DdContext -> [Pair]
whenPresent DdContext
context =
    [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
        [ (Key
"version",) (Value -> Pair) -> (Text -> Value) -> Text -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Pair) -> Maybe Text -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DdContext -> Maybe Text
ddVersion DdContext
context
        , (Key
"dd",) (Value -> Pair) -> (DdSpan -> Value) -> DdSpan -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DdSpan -> Value
spanObject (DdSpan -> Pair) -> Maybe DdSpan -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DdContext -> Maybe DdSpan
ddSpan DdContext
context
        ]

-- The @katip@ keys the line renders itself, so the nested block does not repeat them.
promoted :: [Key]
promoted :: [Key]
promoted = [Key
"at", Key
"data", Key
"env", Key
"msg", Key
"sev"]

spanObject :: DdSpan -> Value
spanObject :: DdSpan -> Value
spanObject DdSpan
theSpan = [Pair] -> Value
object [Key
"trace_id" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DdSpan -> Text
ddTraceId DdSpan
theSpan, Key
"span_id" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DdSpan -> Text
ddSpanId DdSpan
theSpan]

{- The active span's ids from a log site's own @dd@ payload ('ddField'). Both ids must be
present, so a line never renders a half-filled correlation pair. -}
payloadSpan :: KeyMap.KeyMap Value -> Maybe DdSpan
payloadSpan :: Object -> Maybe DdSpan
payloadSpan Object
structured = case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"dd" Object
structured of
    Just (Object Object
dd) -> Text -> Text -> DdSpan
DdSpan (Text -> Text -> DdSpan) -> Maybe Text -> Maybe (Text -> DdSpan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Object -> Maybe Text
textAt Key
"trace_id" Object
dd Maybe (Text -> DdSpan) -> Maybe Text -> Maybe DdSpan
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Key -> Object -> Maybe Text
textAt Key
"span_id" Object
dd
    Maybe Value
_ -> Maybe DdSpan
forall a. Maybe a
Nothing
  where
    textAt :: Key -> KeyMap.KeyMap Value -> Maybe Text
    textAt :: Key -> Object -> Maybe Text
textAt Key
key Object
o = case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
key Object
o of
        Just (String Text
t) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
        Maybe Value
_ -> Maybe Text
forall a. Maybe a
Nothing

{- | The structured context naming the source module a log line came from. Compose it into a
log site's payload so a reader filters the stream by emitter without the @katip@ namespace.
-}
moduleField :: Text -> SimpleLogPayload
moduleField :: Text -> SimpleLogPayload
moduleField = Text -> Text -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"module"

{- | Run @action@ in a context naming its emitting module. A phase that holds no @Handler@
reader, such as boot or a worker loop, enters the log stream this way.
-}
moduleContext :: LogEnv -> Text -> KatipContextT m a -> m a
moduleContext :: forall (m :: * -> *) a. LogEnv -> Text -> KatipContextT m a -> m a
moduleContext LogEnv
logEnv Text
name = LogEnv -> SimpleLogPayload -> Namespace -> KatipContextT m a -> m a
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
logEnv (Text -> SimpleLogPayload
moduleField Text
name) Namespace
forall a. Monoid a => a
mempty

{- | Log one line through a composition-root 'LogEnv' under @payload@, for a caller whose
context is a payload rather than a module name.
-}
logLine :: LogEnv -> SimpleLogPayload -> Severity -> Text -> IO ()
logLine :: LogEnv -> SimpleLogPayload -> Severity -> Text -> IO ()
logLine LogEnv
logEnv SimpleLogPayload
payload Severity
severity Text
message =
    LogEnv
-> SimpleLogPayload -> Namespace -> KatipContextT IO () -> IO ()
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
logEnv SimpleLogPayload
payload Namespace
forall a. Monoid a => a
mempty (Severity -> LogStr -> KatipContextT IO ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
severity (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message))

-- | One line under a 'moduleField' naming the emitting module and nothing else.
moduleLog :: LogEnv -> Text -> Severity -> Text -> IO ()
moduleLog :: LogEnv -> Text -> Severity -> Text -> IO ()
moduleLog LogEnv
logEnv Text
name Severity
severity Text
message = LogEnv -> Text -> KatipContextT IO () -> IO ()
forall (m :: * -> *) a. LogEnv -> Text -> KatipContextT m a -> m a
moduleContext LogEnv
logEnv Text
name (Severity -> LogStr -> KatipContextT IO ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
severity (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls Text
message))

{- | The unified-service identity stamped onto every log line, resolved by
"Ecluse.Runtime.Telemetry.Resolve" so logs and traces share one identity.
-}
data DdContext = DdContext
    { DdContext -> Text
ddService :: Text
    -- ^ @service@: the resolved service name.
    , DdContext -> Maybe Text
ddEnv :: Maybe Text
    -- ^ @env@: the deployment environment, when configured.
    , DdContext -> Maybe Text
ddVersion :: Maybe Text
    -- ^ @version@: the service version.
    , DdContext -> Maybe DdSpan
ddSpan :: Maybe DdSpan
    -- ^ The active span's correlation ids, when a span is in scope.
    }
    deriving stock (DdContext -> DdContext -> Bool
(DdContext -> DdContext -> Bool)
-> (DdContext -> DdContext -> Bool) -> Eq DdContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DdContext -> DdContext -> Bool
== :: DdContext -> DdContext -> Bool
$c/= :: DdContext -> DdContext -> Bool
/= :: DdContext -> DdContext -> Bool
Eq, Int -> DdContext -> ShowS
[DdContext] -> ShowS
DdContext -> String
(Int -> DdContext -> ShowS)
-> (DdContext -> String)
-> ([DdContext] -> ShowS)
-> Show DdContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DdContext -> ShowS
showsPrec :: Int -> DdContext -> ShowS
$cshow :: DdContext -> String
show :: DdContext -> String
$cshowList :: [DdContext] -> ShowS
showList :: [DdContext] -> ShowS
Show)

{- | The active span's ids, rendered in the Datadog form by
"Ecluse.Runtime.Telemetry.Correlation". They are 'Text', so this type needs no OTel dependency.
-}
data DdSpan = DdSpan
    { DdSpan -> Text
ddTraceId :: Text
    -- ^ @dd.trace_id@: the trace id in Datadog form.
    , DdSpan -> Text
ddSpanId :: Text
    -- ^ @dd.span_id@: the span id in Datadog form.
    }
    deriving stock (DdSpan -> DdSpan -> Bool
(DdSpan -> DdSpan -> Bool)
-> (DdSpan -> DdSpan -> Bool) -> Eq DdSpan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DdSpan -> DdSpan -> Bool
== :: DdSpan -> DdSpan -> Bool
$c/= :: DdSpan -> DdSpan -> Bool
/= :: DdSpan -> DdSpan -> Bool
Eq, Int -> DdSpan -> ShowS
[DdSpan] -> ShowS
DdSpan -> String
(Int -> DdSpan -> ShowS)
-> (DdSpan -> String) -> ([DdSpan] -> ShowS) -> Show DdSpan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DdSpan -> ShowS
showsPrec :: Int -> DdSpan -> ShowS
$cshow :: DdSpan -> String
show :: DdSpan -> String
$cshowList :: [DdSpan] -> ShowS
showList :: [DdSpan] -> ShowS
Show)

-- | The @dd@ object as JSON, the value 'ddField' installs as a log site's context.
ddObject :: DdContext -> Value
ddObject :: DdContext -> Value
ddObject DdContext
ctx =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
        [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
            [ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"service" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DdContext -> Text
ddService DdContext
ctx)
            , (Key
"env" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (Text -> Pair) -> Maybe Text -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DdContext -> Maybe Text
ddEnv DdContext
ctx
            , (Key
"version" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (Text -> Pair) -> Maybe Text -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DdContext -> Maybe Text
ddVersion DdContext
ctx
            , (Key
"trace_id" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (Text -> Pair) -> (DdSpan -> Text) -> DdSpan -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DdSpan -> Text
ddTraceId (DdSpan -> Pair) -> Maybe DdSpan -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DdContext -> Maybe DdSpan
ddSpan DdContext
ctx
            , (Key
"span_id" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (Text -> Pair) -> (DdSpan -> Text) -> DdSpan -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DdSpan -> Text
ddSpanId (DdSpan -> Pair) -> Maybe DdSpan -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DdContext -> Maybe DdSpan
ddSpan DdContext
ctx
            ]

{- | The @dd@ object as a @katip@ payload under the @dd@ key. Install it as the initial
context of a request or worker scope so every line there carries that scope's active span.
-}
ddField :: DdContext -> SimpleLogPayload
ddField :: DdContext -> SimpleLogPayload
ddField = Text -> Value -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
"dd" (Value -> SimpleLogPayload)
-> (DdContext -> Value) -> DdContext -> SimpleLogPayload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DdContext -> Value
ddObject