{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Telemetry.Observability
(
Exporter
, initializeTelemetry
, Trace (..)
, Span (..)
, beginTrace
, usingTrace
, usingTrace'
, setServiceName
, Label
, encloseSpan
, setStartTime
, setSpanName
, MetricValue
, Telemetry (metric)
, telemetry
, sendEvent
, clearMetrics
, clearTrace
) where
import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TQueue (writeTQueue)
import Control.Exception.Safe qualified as Safe
import Core.Data.Clock
import Core.Data.Structures (Map, emptyMap, insertKeyValue)
import Core.Encoding.External
import Core.Encoding.Json
import Core.Program.Arguments
import Core.Program.Context
import Core.Program.Logging
import Core.System.Base (SomeException, liftIO)
import Core.Telemetry.Identifiers
import Core.Text.Rope
import Core.Text.Utilities (oxford, quote)
import Data.ByteString qualified as B (ByteString)
import Data.ByteString.Lazy qualified as L (ByteString)
import Data.List qualified as List (foldl')
import Data.Scientific (Scientific)
import Data.Text qualified as T (Text)
import Data.Text.Lazy qualified as U (Text)
import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime)
import Data.UUID.Types (UUID)
import GHC.Int
import GHC.Word
import System.Random (randomIO)
data MetricValue
= MetricValue JsonKey JsonValue
deriving (Int -> MetricValue -> ShowS
[MetricValue] -> ShowS
MetricValue -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MetricValue] -> ShowS
$cshowList :: [MetricValue] -> ShowS
show :: MetricValue -> String
$cshow :: MetricValue -> String
showsPrec :: Int -> MetricValue -> ShowS
$cshowsPrec :: Int -> MetricValue -> ShowS
Show)
setServiceName :: Rope -> Program τ ()
setServiceName :: forall τ. Rope -> Program τ ()
setServiceName Rope
service = do
Context τ
context <- forall τ. Program τ (Context τ)
getContext
let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
MVar Datum
v
( \Datum
datum -> do
let datum' :: Datum
datum' =
Datum
datum
{ $sel:serviceNameFrom:Datum :: Maybe Rope
serviceNameFrom = forall a. a -> Maybe a
Just Rope
service
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure Datum
datum'
)
class Telemetry σ where
metric :: Rope -> σ -> MetricValue
instance Telemetry Int where
metric :: Rope -> Int -> MetricValue
metric Rope
k Int
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v))
instance Telemetry Int32 where
metric :: Rope -> Int32 -> MetricValue
metric Rope
k Int32
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
v))
instance Telemetry Int64 where
metric :: Rope -> Int64 -> MetricValue
metric Rope
k Int64
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
v))
instance Telemetry Word32 where
metric :: Rope -> Word32 -> MetricValue
metric Rope
k Word32
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
v))
instance Telemetry Word64 where
metric :: Rope -> Word64 -> MetricValue
metric Rope
k Word64
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v))
instance Telemetry Integer where
metric :: Rope -> Integer -> MetricValue
metric Rope
k Integer
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a. Num a => Integer -> a
fromInteger Integer
v))
instance Telemetry Float where
metric :: Rope -> Float -> MetricValue
metric Rope
k Float
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a. Fractional a => Rational -> a
fromRational (forall a. Real a => a -> Rational
toRational Float
v)))
instance Telemetry Double where
metric :: Rope -> Double -> MetricValue
metric Rope
k Double
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a. Fractional a => Rational -> a
fromRational (forall a. Real a => a -> Rational
toRational Double
v)))
instance Telemetry Scientific where
metric :: Rope -> Scientific -> MetricValue
metric Rope
k Scientific
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber Scientific
v)
instance Telemetry Rope where
metric :: Rope -> Rope -> MetricValue
metric Rope
k Rope
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString Rope
v)
instance Telemetry String where
metric :: Rope -> String -> MetricValue
metric Rope
k String
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall α. Textual α => α -> Rope
intoRope String
v))
instance Telemetry () where
metric :: Rope -> () -> MetricValue
metric Rope
k ()
_ = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) JsonValue
JsonNull
instance Telemetry B.ByteString where
metric :: Rope -> ByteString -> MetricValue
metric Rope
k ByteString
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall α. Textual α => α -> Rope
intoRope ByteString
v))
instance Telemetry L.ByteString where
metric :: Rope -> ByteString -> MetricValue
metric Rope
k ByteString
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall α. Textual α => α -> Rope
intoRope ByteString
v))
instance Telemetry T.Text where
metric :: Rope -> Text -> MetricValue
metric Rope
k Text
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall α. Textual α => α -> Rope
intoRope Text
v))
instance Telemetry U.Text where
metric :: Rope -> Text -> MetricValue
metric Rope
k Text
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall α. Textual α => α -> Rope
intoRope Text
v))
instance Telemetry Bool where
metric :: Rope -> Bool -> MetricValue
metric Rope
k Bool
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Bool -> JsonValue
JsonBool Bool
v)
instance Telemetry JsonValue where
metric :: Rope -> JsonValue -> MetricValue
metric Rope
k JsonValue
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) JsonValue
v
instance Telemetry σ => Telemetry (Maybe σ) where
metric :: Rope -> Maybe σ -> MetricValue
metric Rope
k Maybe σ
v = case Maybe σ
v of
Maybe σ
Nothing -> JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) JsonValue
JsonNull
Just σ
v' -> forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
k σ
v'
instance Telemetry UTCTime where
metric :: Rope -> UTCTime -> MetricValue
metric Rope
k UTCTime
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall ξ. Externalize ξ => ξ -> Rope
formatExternal (forall a. Instant a => a -> Time
intoTime UTCTime
v)))
instance Telemetry Day where
metric :: Rope -> Day -> MetricValue
metric Rope
k Day
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall ξ. Externalize ξ => ξ -> Rope
formatExternal Day
v))
instance Telemetry UUID where
metric :: Rope -> UUID -> MetricValue
metric Rope
k UUID
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall ξ. Externalize ξ => ξ -> Rope
formatExternal UUID
v))
initializeTelemetry :: [Exporter] -> Context τ -> IO (Context τ)
initializeTelemetry :: forall τ. [Exporter] -> Context τ -> IO (Context τ)
initializeTelemetry [Exporter]
exporters1 Context τ
context =
let exporters0 :: [Exporter]
exporters0 = forall τ. Context τ -> [Exporter]
initialExportersFrom Context τ
context
exporters2 :: [Exporter]
exporters2 = [Exporter]
exporters0 forall a. [a] -> [a] -> [a]
++ [Exporter]
exporters1
codenames :: [Rope]
codenames =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Rope
name -> Char -> Rope
singletonRope Char
'"' forall a. Semigroup a => a -> a -> a
<> Rope
name forall a. Semigroup a => a -> a -> a
<> Char -> Rope
singletonRope Char
'"')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exporter -> Rope
codenameFrom
forall a b. (a -> b) -> a -> b
$ [Exporter]
exporters2
config0 :: Config
config0 = forall τ. Context τ -> Config
initialConfigFrom Context τ
context
config1 :: Config
config1 =
Options -> Config -> Config
appendOption
( LongName -> Maybe Char -> ParameterValue -> Rope -> Options
Option
LongName
"telemetry"
forall a. Maybe a
Nothing
(String -> ParameterValue
Value String
"EXPORTER")
( [quote|
Turn on telemetry. Tracing data and metrics from events
will be forwarded via the specified exporter. Valid values
are
|]
forall a. Semigroup a => a -> a -> a
<> [Rope] -> Rope
oxford [Rope]
codenames
)
)
Config
config0
config2 :: Config
config2 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Config -> Exporter -> Config
f Config
config1 [Exporter]
exporters2
in forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Context τ
context
{ $sel:initialConfigFrom:Context :: Config
initialConfigFrom = Config
config2
, $sel:initialExportersFrom:Context :: [Exporter]
initialExportersFrom = [Exporter]
exporters2
}
)
where
f :: Config -> Exporter -> Config
f :: Config -> Exporter -> Config
f Config
config Exporter
exporter =
let setup :: Config -> Config
setup = Exporter -> Config -> Config
setupConfigFrom Exporter
exporter
in Config -> Config
setup Config
config
type Label = Rope
encloseSpan :: Label -> Program z a -> Program z a
encloseSpan :: forall z a. Rope -> Program z a -> Program z a
encloseSpan Rope
label Program z a
action = do
Context z
context <- forall τ. Program τ (Context τ)
getContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Time
start <- IO Time
getCurrentTimeNanoseconds
Word16
rand <- forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Word16
let unique :: Span
unique = Time -> Word16 -> Span
createIdentifierSpan Time
start Word16
rand
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context z
context forall a b. (a -> b) -> a -> b
$ do
forall τ. Rope -> Program τ ()
internal (Rope
"Enter " forall a. Semigroup a => a -> a -> a
<> Rope
label)
forall τ. Rope -> Program τ ()
internal (Rope
"span = " forall a. Semigroup a => a -> a -> a
<> Span -> Rope
unSpan Span
unique)
let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context z
context
Datum
datum <- forall a. MVar a -> IO a
readMVar MVar Datum
v
let datum' :: Datum
datum' =
Datum
datum
{ $sel:spanIdentifierFrom:Datum :: Maybe Span
spanIdentifierFrom = forall a. a -> Maybe a
Just Span
unique
, $sel:spanNameFrom:Datum :: Rope
spanNameFrom = Rope
label
, $sel:spanTimeFrom:Datum :: Time
spanTimeFrom = Time
start
, $sel:parentIdentifierFrom:Datum :: Maybe Span
parentIdentifierFrom = Datum -> Maybe Span
spanIdentifierFrom Datum
datum
}
MVar Datum
v2 <- forall a. a -> IO (MVar a)
newMVar Datum
datum'
let context2 :: Context z
context2 =
Context z
context
{ $sel:currentDatumFrom:Context :: MVar Datum
currentDatumFrom = MVar Datum
v2
}
Either SomeException a
result :: Either SomeException a <-
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Safe.try
(forall τ α. Context τ -> Program τ α -> IO α
subProgram Context z
context2 Program z a
action)
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context z
context forall a b. (a -> b) -> a -> b
$ do
forall τ. Rope -> Program τ ()
internal (Rope
"Leave " forall a. Semigroup a => a -> a -> a
<> Rope
label)
Time
finish <- IO Time
getCurrentTimeNanoseconds
Datum
datum2 <- forall a. MVar a -> IO a
readMVar MVar Datum
v2
let start2 :: Time
start2 = Datum -> Time
spanTimeFrom Datum
datum2
let datum2' :: Datum
datum2' =
Datum
datum2
{ $sel:durationFrom:Datum :: Maybe Int64
durationFrom = forall a. a -> Maybe a
Just (Time -> Int64
unTime Time
finish forall a. Num a => a -> a -> a
- Time -> Int64
unTime Time
start2)
}
let tel :: TQueue (Maybe Datum)
tel = forall τ. Context τ -> TQueue (Maybe Datum)
telemetryChannelFrom Context z
context
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Datum)
tel (forall a. a -> Maybe a
Just Datum
datum2')
case Either SomeException a
result of
Left SomeException
e -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw SomeException
e
Right a
value -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value
beginTrace :: Program τ α -> Program τ α
beginTrace :: forall τ α. Program τ α -> Program τ α
beginTrace Program τ α
action = do
Time
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
IO Time
getCurrentTimeNanoseconds
Word16
rand <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
(forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Word16)
let trace :: Trace
trace = Time -> Word16 -> MAC -> Trace
createIdentifierTrace Time
now Word16
rand MAC
hostMachineIdentity
forall τ. Rope -> Program τ ()
internal Rope
"Begin trace"
forall τ. Rope -> Program τ ()
internal (Rope
"trace = " forall a. Semigroup a => a -> a -> a
<> Trace -> Rope
unTrace Trace
trace)
forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace Trace
trace forall a. Maybe a
Nothing Program τ α
action
usingTrace :: Trace -> Span -> Program τ α -> Program τ α
usingTrace :: forall τ α. Trace -> Span -> Program τ α -> Program τ α
usingTrace Trace
trace Span
parent Program τ α
action = do
forall τ. Rope -> Program τ ()
internal Rope
"Using trace"
forall τ. Rope -> Program τ ()
internal (Rope
"trace = " forall a. Semigroup a => a -> a -> a
<> Trace -> Rope
unTrace Trace
trace)
forall τ. Rope -> Program τ ()
internal (Rope
"parent = " forall a. Semigroup a => a -> a -> a
<> Span -> Rope
unSpan Span
parent)
forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace Trace
trace (forall a. a -> Maybe a
Just Span
parent) Program τ α
action
usingTrace' :: Trace -> Program τ α -> Program τ α
usingTrace' :: forall τ α. Trace -> Program τ α -> Program τ α
usingTrace' Trace
trace Program τ α
action = do
forall τ. Rope -> Program τ ()
internal Rope
"Using trace"
forall τ. Rope -> Program τ ()
internal (Rope
"trace = " forall a. Semigroup a => a -> a -> a
<> Trace -> Rope
unTrace Trace
trace)
forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace Trace
trace forall a. Maybe a
Nothing Program τ α
action
encloseTrace :: Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace :: forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace Trace
trace Maybe Span
possibleParent Program τ α
action = do
Context τ
context <- forall τ. Program τ (Context τ)
getContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
Datum
datum <- forall a. MVar a -> IO a
readMVar MVar Datum
v
let datum2 :: Datum
datum2 =
Datum
datum
{ $sel:traceIdentifierFrom:Datum :: Maybe Trace
traceIdentifierFrom = forall a. a -> Maybe a
Just Trace
trace
, $sel:spanIdentifierFrom:Datum :: Maybe Span
spanIdentifierFrom = Maybe Span
possibleParent
}
MVar Datum
v2 <- forall a. a -> IO (MVar a)
newMVar Datum
datum2
let context2 :: Context τ
context2 =
Context τ
context
{ $sel:currentDatumFrom:Context :: MVar Datum
currentDatumFrom = MVar Datum
v2
}
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context2 Program τ α
action
telemetry :: [MetricValue] -> Program τ ()
telemetry :: forall τ. [MetricValue] -> Program τ ()
telemetry [MetricValue]
values = do
Context τ
context <- forall τ. Program τ (Context τ)
getContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
MVar Datum
v
( \Datum
datum -> do
let meta :: Map JsonKey JsonValue
meta = Datum -> Map JsonKey JsonValue
attachedMetadataFrom Datum
datum
let meta' :: Map JsonKey JsonValue
meta' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue
f Map JsonKey JsonValue
meta [MetricValue]
values
let datum' :: Datum
datum' =
Datum
datum
{ $sel:attachedMetadataFrom:Datum :: Map JsonKey JsonValue
attachedMetadataFrom = Map JsonKey JsonValue
meta'
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure Datum
datum'
)
where
f :: Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue
f :: Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue
f Map JsonKey JsonValue
acc (MetricValue k :: JsonKey
k@(JsonKey Rope
text) JsonValue
v) =
if Rope -> Bool
nullRope Rope
text
then forall a. HasCallStack => String -> a
error String
"Empty metric field name not allowed"
else forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
k JsonValue
v Map JsonKey JsonValue
acc
sendEvent :: Label -> [MetricValue] -> Program τ ()
sendEvent :: forall τ. Rope -> [MetricValue] -> Program τ ()
sendEvent Rope
label [MetricValue]
values = do
Context τ
context <- forall τ. Program τ (Context τ)
getContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Time
now <- IO Time
getCurrentTimeNanoseconds
let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
Datum
datum <- forall a. MVar a -> IO a
readMVar MVar Datum
v
let meta :: Map JsonKey JsonValue
meta = Datum -> Map JsonKey JsonValue
attachedMetadataFrom Datum
datum
let meta' :: Map JsonKey JsonValue
meta' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue
f Map JsonKey JsonValue
meta [MetricValue]
values
let datum' :: Datum
datum' =
Datum
datum
{ $sel:spanNameFrom:Datum :: Rope
spanNameFrom = Rope
label
, $sel:spanIdentifierFrom:Datum :: Maybe Span
spanIdentifierFrom = forall a. Maybe a
Nothing
, $sel:parentIdentifierFrom:Datum :: Maybe Span
parentIdentifierFrom = Datum -> Maybe Span
spanIdentifierFrom Datum
datum
, $sel:spanTimeFrom:Datum :: Time
spanTimeFrom = Time
now
, $sel:attachedMetadataFrom:Datum :: Map JsonKey JsonValue
attachedMetadataFrom = Map JsonKey JsonValue
meta'
}
let tel :: TQueue (Maybe Datum)
tel = forall τ. Context τ -> TQueue (Maybe Datum)
telemetryChannelFrom Context τ
context
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Datum)
tel (forall a. a -> Maybe a
Just Datum
datum')
where
f :: Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue
f :: Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue
f Map JsonKey JsonValue
acc (MetricValue k :: JsonKey
k@(JsonKey Rope
text) JsonValue
v) =
if Rope -> Bool
nullRope Rope
text
then forall a. HasCallStack => String -> a
error String
"Empty metric field name not allowed"
else forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
k JsonValue
v Map JsonKey JsonValue
acc
setStartTime :: Time -> Program τ ()
setStartTime :: forall τ. Time -> Program τ ()
setStartTime Time
time = do
Context τ
context <- forall τ. Program τ (Context τ)
getContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
MVar Datum
v
(\Datum
datum -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Datum
datum {$sel:spanTimeFrom:Datum :: Time
spanTimeFrom = Time
time})
setSpanName :: Label -> Program τ ()
setSpanName :: forall τ. Rope -> Program τ ()
setSpanName Rope
label = do
Context τ
context <- forall τ. Program τ (Context τ)
getContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
MVar Datum
v
(\Datum
datum -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Datum
datum {$sel:spanNameFrom:Datum :: Rope
spanNameFrom = Rope
label})
clearMetrics :: Program τ ()
clearMetrics :: forall τ. Program τ ()
clearMetrics = do
Context τ
context <- forall τ. Program τ (Context τ)
getContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
MVar Datum
v
( \Datum
datum ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Datum
datum
{ $sel:attachedMetadataFrom:Datum :: Map JsonKey JsonValue
attachedMetadataFrom = forall κ ν. Map κ ν
emptyMap
}
)
clearTrace :: Program τ ()
clearTrace :: forall τ. Program τ ()
clearTrace = do
Context τ
context <- forall τ. Program τ (Context τ)
getContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
MVar Datum
v
( \Datum
datum -> do
let name :: Maybe Rope
name = Datum -> Maybe Rope
serviceNameFrom Datum
datum
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Datum
emptyDatum
{ $sel:serviceNameFrom:Datum :: Maybe Rope
serviceNameFrom = Maybe Rope
name
}
)