{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
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
structuredExporter :: Exporter
structuredExporter :: Exporter
structuredExporter =
Exporter :: Rope
-> (Config -> Config)
-> (forall τ. Context τ -> IO Forwarder)
-> Exporter
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 = Config -> Config
forall a. a -> a
id
setupStructuredAction :: Context τ -> IO Forwarder
setupStructuredAction :: Context τ -> IO Forwarder
setupStructuredAction Context τ
context = do
let out :: TQueue (Maybe Rope)
out = Context τ -> TQueue (Maybe Rope)
forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom Context τ
context
Forwarder -> IO Forwarder
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Forwarder :: ([Datum] -> IO ()) -> Forwarder
Forwarder
{ $sel:telemetryHandlerFrom:Forwarder :: [Datum] -> IO ()
telemetryHandlerFrom = TQueue (Maybe Rope) -> [Datum] -> IO ()
processStructuredOutput TQueue (Maybe Rope)
out
}
)
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 = JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
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 -> JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
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 -> JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
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 -> JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
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 -> JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
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 ->
JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue
JsonKey
"duration"
(Scientific -> JsonValue
JsonNumber (Rational -> Scientific
forall a. Fractional a => Rational -> a
fromRational (Int64 -> Rational
forall a. Real a => a -> Rational
toRational Int64
duration Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
1e9)))
Map JsonKey JsonValue
meta5
time :: Rope
time = String -> Rope
forall α. Textual α => α -> Rope
intoRope (Time -> String
forall a. Show a => a -> String
show (Datum -> Time
spanTimeFrom Datum
datum))
meta7 :: Map JsonKey JsonValue
meta7 = JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
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
(Datum -> IO ()) -> [Datum] -> IO ()
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 = Bytes -> Rope
forall α. Textual α => α -> Rope
intoRope (JsonValue -> Bytes
encodeToUTF8 JsonValue
object)
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TQueue (Maybe Rope) -> Maybe Rope -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out (Rope -> Maybe Rope
forall a. a -> Maybe a
Just Rope
text)