{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
An exporter backend that outputs \"structured\" logs to your terminal as they are
submitted.

Most traditional programs' logs were textual, single lines, sometimes with a
reasonably well-known internal layout, but regardless very difficult to
actually perform analysis on. Engineers attempting to diagnose problems are
largely limited to doing text searches across masses of logs. It's hard to
correlate between diffent subsystems let alone perform any sort of statistical
analysis.

Other systems in the past gathered copious amounts of metrics but having done
so, left us with the hard problem of actually doing anything useful with them
other than providing fodder for pretty graphs.

Structured logging was a significant step forward for large-scale systems
administration; by combining metrics together with context in the form of
key/value pairs it allows us to perform more detailed investigation and
analysis that this was largely done by emitting copious amounts of enormously
wasteful JSON is astonishing and goes some way to explain why structured
logging took so long to catch on).

Taking the example from 'Core.Telemetry.Observability.telemetry', the output
would be:

@
\$ __burgerservice --telemetry=structured__
{"calories":667.0,"flavour":true,"meal_name":"hamburger","precise":45.0,"timestamp":"2021-10-22T11:12:53.674399531Z"}
...
@

which if pretty printed would have been more recognizable as

@
{
    "calories": 667.0,
    "flavour": true,
    "meal_name": "hamburger",
    "precise": 45.0,
    "timestamp": "2021-10-22T11:12:53.674399531Z",
}
@

but all that whitespace would be wasteful, right?

While more advanced observability systems will directly ingest this data and
assemble it into traces of nested spans, in other situations having
straight-forward metrics output as JSON may be sufficient for your needs. If
you /do/ use this exporter in a program embellished with traces and spans, the
relevant contextual information will be added to the output:

@
{
    "calories": 667.0,
    "flavour": true,
    "meal_name": "hamburger",
    "precise": 45.0,
    "timestamp": "2021-10-22T11:12:53.674399531Z",
    "duration": 3.756717001,
    "span_id": "o7ucNqCeSJBzeviL",
    "span_name": "Process order",
    "trace_id": "order-11430185",
    "service_name": "burger-service"
}
@
-}
module Core.Telemetry.Structured (
    structuredExporter,
) where

import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TQueue (TQueue, writeTQueue)
import Core.Data.Structures (insertKeyValue)
import Core.Encoding.Json
import Core.Program.Arguments
import Core.Program.Context
import Core.Text.Rope

{- |
Output metrics to @stdout@ in the form of a raw JSON object.
-}
structuredExporter :: Exporter
structuredExporter :: Exporter
structuredExporter =
    Exporter
        { $sel:codenameFrom:Exporter :: Rope
codenameFrom = Rope
"structured"
        , $sel:setupConfigFrom:Exporter :: Config -> Config
setupConfigFrom = Config -> Config
setupStructuredConfig
        , $sel:setupActionFrom:Exporter :: forall τ. Context τ -> IO Forwarder
setupActionFrom = forall τ. Context τ -> IO Forwarder
setupStructuredAction
        }

setupStructuredConfig :: Config -> Config
setupStructuredConfig :: Config -> Config
setupStructuredConfig = forall a. a -> a
id

setupStructuredAction :: Context τ -> IO Forwarder
setupStructuredAction :: forall τ. Context τ -> IO Forwarder
setupStructuredAction Context τ
context = do
    let out :: TQueue (Maybe Rope)
out = forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom Context τ
context
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Forwarder
            { $sel:telemetryHandlerFrom:Forwarder :: [Datum] -> IO ()
telemetryHandlerFrom = TQueue (Maybe Rope) -> [Datum] -> IO ()
processStructuredOutput TQueue (Maybe Rope)
out
            }
        )

-- almost exact copy of what we use to send to Honeycomb
convertDatumToJson :: Datum -> JsonValue
convertDatumToJson :: Datum -> JsonValue
convertDatumToJson Datum
datum =
    let spani :: Maybe Span
spani = Datum -> Maybe Span
spanIdentifierFrom Datum
datum
        trace :: Maybe Trace
trace = Datum -> Maybe Trace
traceIdentifierFrom Datum
datum
        parent :: Maybe Span
parent = Datum -> Maybe Span
parentIdentifierFrom Datum
datum
        meta0 :: Map JsonKey JsonValue
meta0 = Datum -> Map JsonKey JsonValue
attachedMetadataFrom Datum
datum

        meta1 :: Map JsonKey JsonValue
meta1 = forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"span_name" (Rope -> JsonValue
JsonString (Datum -> Rope
spanNameFrom Datum
datum)) Map JsonKey JsonValue
meta0

        meta2 :: Map JsonKey JsonValue
meta2 = case Maybe Span
spani of
            Maybe Span
Nothing -> Map JsonKey JsonValue
meta1
            Just Span
value -> forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"span_id" (Rope -> JsonValue
JsonString (Span -> Rope
unSpan Span
value)) Map JsonKey JsonValue
meta1

        meta3 :: Map JsonKey JsonValue
meta3 = case Maybe Span
parent of
            Maybe Span
Nothing -> Map JsonKey JsonValue
meta2
            Just Span
value -> forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"parent_id" (Rope -> JsonValue
JsonString (Span -> Rope
unSpan Span
value)) Map JsonKey JsonValue
meta2

        meta4 :: Map JsonKey JsonValue
meta4 = case Maybe Trace
trace of
            Maybe Trace
Nothing -> Map JsonKey JsonValue
meta3
            Just Trace
value -> forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"trace_id" (Rope -> JsonValue
JsonString (Trace -> Rope
unTrace Trace
value)) Map JsonKey JsonValue
meta3

        meta5 :: Map JsonKey JsonValue
meta5 = case Datum -> Maybe Rope
serviceNameFrom Datum
datum of
            Maybe Rope
Nothing -> Map JsonKey JsonValue
meta4
            Just Rope
service -> forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"service_name" (Rope -> JsonValue
JsonString Rope
service) Map JsonKey JsonValue
meta4

        meta6 :: Map JsonKey JsonValue
meta6 = case Datum -> Maybe Int64
durationFrom Datum
datum of
            Maybe Int64
Nothing -> Map JsonKey JsonValue
meta5
            Just Int64
duration ->
                forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue
                    JsonKey
"duration"
                    (Scientific -> JsonValue
JsonNumber (forall a. Fractional a => Rational -> a
fromRational (forall a. Real a => a -> Rational
toRational Int64
duration forall a. Fractional a => a -> a -> a
/ Rational
1e9)))
                    Map JsonKey JsonValue
meta5

        time :: Rope
time = forall α. Textual α => α -> Rope
intoRope (forall a. Show a => a -> String
show (Datum -> Time
spanTimeFrom Datum
datum))
        meta7 :: Map JsonKey JsonValue
meta7 = forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
"timestamp" (Rope -> JsonValue
JsonString Rope
time) Map JsonKey JsonValue
meta6
     in Map JsonKey JsonValue -> JsonValue
JsonObject Map JsonKey JsonValue
meta7

processStructuredOutput :: TQueue (Maybe Rope) -> [Datum] -> IO ()
processStructuredOutput :: TQueue (Maybe Rope) -> [Datum] -> IO ()
processStructuredOutput TQueue (Maybe Rope)
out [Datum]
datums = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Datum -> IO ()
processOne [Datum]
datums
  where
    processOne :: Datum -> IO ()
    processOne :: Datum -> IO ()
processOne Datum
datum = do
        let object :: JsonValue
object = Datum -> JsonValue
convertDatumToJson Datum
datum
            text :: Rope
text = forall α. Textual α => α -> Rope
intoRope (JsonValue -> Bytes
encodeToUTF8 JsonValue
object)

        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out (forall a. a -> Maybe a
Just Rope
text)