{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Telemetry.Observability (
Exporter,
initializeTelemetry,
Trace (..),
Span (..),
beginTrace,
usingTrace,
setServiceName,
Label,
encloseSpan,
setStartTime,
MetricValue,
Telemetry (metric),
telemetry,
sendEvent,
clearMetrics,
) where
import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TQueue (writeTQueue)
import qualified Control.Exception.Safe as Safe
import Core.Data.Structures (Map, emptyMap, insertKeyValue)
import Core.Encoding.Json
import Core.Program.Arguments
import Core.Program.Context
import Core.Program.Logging
import Core.System.Base (SomeException, liftIO)
import Core.System.External (TimeStamp (unTimeStamp), getCurrentTimeNanoseconds)
import Core.Telemetry.Identifiers
import Core.Text.Rope
import Core.Text.Utilities (oxford, quote)
import qualified Data.ByteString as B (ByteString)
import qualified Data.ByteString.Lazy as L (ByteString)
import qualified Data.List as List (foldl')
import Data.Scientific (Scientific)
import qualified Data.Text as T (Text)
import qualified Data.Text.Lazy as U (Text)
import GHC.Int
import GHC.Word
import System.Random (randomIO)
data MetricValue
= MetricValue JsonKey JsonValue
deriving (Int -> MetricValue -> ShowS
[MetricValue] -> ShowS
MetricValue -> String
(Int -> MetricValue -> ShowS)
-> (MetricValue -> String)
-> ([MetricValue] -> ShowS)
-> Show MetricValue
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 :: Rope -> Program τ ()
setServiceName Rope
service = do
Context τ
context <- Program τ (Context τ)
forall τ. Program τ (Context τ)
getContext
let v :: MVar Datum
v = Context τ -> MVar Datum
forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
MVar Datum -> (Datum -> IO Datum) -> IO ()
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 = Rope -> Maybe Rope
forall a. a -> Maybe a
Just Rope
service
}
Datum -> IO Datum
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 (Int -> Scientific
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 (Int32 -> Scientific
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 (Int64 -> Scientific
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 (Word32 -> Scientific
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 (Word64 -> Scientific
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 (Integer -> Scientific
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 (Rational -> Scientific
forall a. Fractional a => Rational -> a
fromRational (Float -> Rational
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 (Rational -> Scientific
forall a. Fractional a => Rational -> a
fromRational (Double -> Rational
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 (String -> Rope
forall α. Textual α => α -> Rope
intoRope String
v))
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 (ByteString -> Rope
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 (ByteString -> Rope
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 (Text -> Rope
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 (Text -> Rope
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
initializeTelemetry :: [Exporter] -> Context τ -> IO (Context τ)
initializeTelemetry :: [Exporter] -> Context τ -> IO (Context τ)
initializeTelemetry [Exporter]
exporters1 Context τ
context =
let exporters0 :: [Exporter]
exporters0 = Context τ -> [Exporter]
forall τ. Context τ -> [Exporter]
initialExportersFrom Context τ
context
exporters2 :: [Exporter]
exporters2 = [Exporter]
exporters0 [Exporter] -> [Exporter] -> [Exporter]
forall a. [a] -> [a] -> [a]
++ [Exporter]
exporters1
codenames :: [Rope]
codenames =
(Rope -> Rope) -> [Rope] -> [Rope]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Rope
name -> Char -> Rope
singletonRope Char
'"' Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
name Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Char -> Rope
singletonRope Char
'"')
([Rope] -> [Rope])
-> ([Exporter] -> [Rope]) -> [Exporter] -> [Rope]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exporter -> Rope) -> [Exporter] -> [Rope]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exporter -> Rope
codenameFrom
([Exporter] -> [Rope]) -> [Exporter] -> [Rope]
forall a b. (a -> b) -> a -> b
$ [Exporter]
exporters2
config0 :: Config
config0 = Context τ -> Config
forall τ. Context τ -> Config
initialConfigFrom Context τ
context
config1 :: Config
config1 =
Options -> Config -> Config
appendOption
( LongName -> Maybe Char -> ParameterValue -> Rope -> Options
Option
LongName
"telemetry"
Maybe Char
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
|]
Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> [Rope] -> Rope
oxford [Rope]
codenames
)
)
Config
config0
config2 :: Config
config2 = (Config -> Exporter -> Config) -> Config -> [Exporter] -> Config
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Config -> Exporter -> Config
f Config
config1 [Exporter]
exporters2
in Context τ -> IO (Context τ)
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 :: Rope -> Program z a -> Program z a
encloseSpan Rope
label Program z a
action = do
Context z
context <- Program z (Context z)
forall τ. Program τ (Context τ)
getContext
TimeStamp
start <- IO TimeStamp -> Program z TimeStamp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TimeStamp -> Program z TimeStamp)
-> IO TimeStamp -> Program z TimeStamp
forall a b. (a -> b) -> a -> b
$ do
IO TimeStamp
getCurrentTimeNanoseconds
Word16
rand <- IO Word16 -> Program z Word16
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Word16 -> Program z Word16) -> IO Word16 -> Program z Word16
forall a b. (a -> b) -> a -> b
$ do
(IO Word16
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Word16)
let unique :: Span
unique = TimeStamp -> Word16 -> Span
createIdentifierSpan TimeStamp
start Word16
rand
Rope -> Rope -> Program z ()
forall τ. Rope -> Rope -> Program τ ()
internal Rope
label Rope
emptyRope
Rope -> Rope -> Program z ()
forall τ. Rope -> Rope -> Program τ ()
internal Rope
"span = " (Span -> Rope
unSpan Span
unique)
IO a -> Program z a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Program z a) -> IO a -> Program z a
forall a b. (a -> b) -> a -> b
$ do
let v :: MVar Datum
v = Context z -> MVar Datum
forall τ. Context τ -> MVar Datum
currentDatumFrom Context z
context
Datum
datum <- MVar Datum -> IO Datum
forall a. MVar a -> IO a
readMVar MVar Datum
v
let datum' :: Datum
datum' =
Datum
datum
{ $sel:spanIdentifierFrom:Datum :: Maybe Span
spanIdentifierFrom = Span -> Maybe Span
forall a. a -> Maybe a
Just Span
unique
, $sel:spanNameFrom:Datum :: Rope
spanNameFrom = Rope
label
, $sel:spanTimeFrom:Datum :: TimeStamp
spanTimeFrom = TimeStamp
start
, $sel:parentIdentifierFrom:Datum :: Maybe Span
parentIdentifierFrom = Datum -> Maybe Span
spanIdentifierFrom Datum
datum
}
MVar Datum
v2 <- Datum -> IO (MVar Datum)
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 <-
IO a -> IO (Either SomeException a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Safe.try
(Context z -> Program z a -> IO a
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context z
context2 Program z a
action)
TimeStamp
finish <- IO TimeStamp
getCurrentTimeNanoseconds
Datum
datum2 <- MVar Datum -> IO Datum
forall a. MVar a -> IO a
readMVar MVar Datum
v2
let datum2' :: Datum
datum2' =
Datum
datum2
{ $sel:durationFrom:Datum :: Maybe Int64
durationFrom = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (TimeStamp -> Int64
unTimeStamp TimeStamp
finish Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- TimeStamp -> Int64
unTimeStamp TimeStamp
start)
}
let tel :: TQueue (Maybe Datum)
tel = Context z -> TQueue (Maybe Datum)
forall τ. Context τ -> TQueue (Maybe Datum)
telemetryChannelFrom Context z
context
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TQueue (Maybe Datum) -> Maybe Datum -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Datum)
tel (Datum -> Maybe Datum
forall a. a -> Maybe a
Just Datum
datum2')
case Either SomeException a
result of
Left SomeException
e -> SomeException -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw SomeException
e
Right a
value -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value
beginTrace :: Program τ α -> Program τ α
beginTrace :: Program τ α -> Program τ α
beginTrace Program τ α
action = do
TimeStamp
now <- IO TimeStamp -> Program τ TimeStamp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TimeStamp -> Program τ TimeStamp)
-> IO TimeStamp -> Program τ TimeStamp
forall a b. (a -> b) -> a -> b
$ do
IO TimeStamp
getCurrentTimeNanoseconds
Word16
rand <- IO Word16 -> Program τ Word16
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Word16 -> Program τ Word16) -> IO Word16 -> Program τ Word16
forall a b. (a -> b) -> a -> b
$ do
(IO Word16
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Word16)
let trace :: Trace
trace = TimeStamp -> Word16 -> MAC -> Trace
createIdentifierTrace TimeStamp
now Word16
rand MAC
hostMachineIdentity
Trace -> Maybe Span -> Program τ α -> Program τ α
forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
usingTrace Trace
trace Maybe Span
forall a. Maybe a
Nothing Program τ α
action
usingTrace :: Trace -> Maybe Span -> Program τ α -> Program τ α
usingTrace :: Trace -> Maybe Span -> Program τ α -> Program τ α
usingTrace Trace
trace Maybe Span
possibleParent Program τ α
action = do
Context τ
context <- Program τ (Context τ)
forall τ. Program τ (Context τ)
getContext
case Maybe Span
possibleParent of
Maybe Span
Nothing -> do
Rope -> Rope -> Program τ ()
forall τ. Rope -> Rope -> Program τ ()
internal Rope
"trace = " (Trace -> Rope
unTrace Trace
trace)
Just Span
parent -> do
Rope -> Rope -> Program τ ()
forall τ. Rope -> Rope -> Program τ ()
internal Rope
"trace = " (Trace -> Rope
unTrace Trace
trace)
Rope -> Rope -> Program τ ()
forall τ. Rope -> Rope -> Program τ ()
internal Rope
"parent = " (Span -> Rope
unSpan Span
parent)
IO α -> Program τ α
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO α -> Program τ α) -> IO α -> Program τ α
forall a b. (a -> b) -> a -> b
$ do
let v :: MVar Datum
v = Context τ -> MVar Datum
forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
Datum
datum <- MVar Datum -> IO Datum
forall a. MVar a -> IO a
readMVar MVar Datum
v
let datum2 :: Datum
datum2 =
Datum
datum
{ $sel:traceIdentifierFrom:Datum :: Maybe Trace
traceIdentifierFrom = Trace -> Maybe Trace
forall a. a -> Maybe a
Just Trace
trace
, $sel:spanIdentifierFrom:Datum :: Maybe Span
spanIdentifierFrom = Maybe Span
possibleParent
}
MVar Datum
v2 <- Datum -> IO (MVar Datum)
forall a. a -> IO (MVar a)
newMVar Datum
datum2
let context2 :: Context τ
context2 =
Context τ
context
{ $sel:currentDatumFrom:Context :: MVar Datum
currentDatumFrom = MVar Datum
v2
}
Context τ -> Program τ α -> IO α
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context2 Program τ α
action
telemetry :: [MetricValue] -> Program τ ()
telemetry :: [MetricValue] -> Program τ ()
telemetry [MetricValue]
values = do
Context τ
context <- Program τ (Context τ)
forall τ. Program τ (Context τ)
getContext
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
let v :: MVar Datum
v = Context τ -> MVar Datum
forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
MVar Datum -> (Datum -> IO Datum) -> IO ()
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' = (Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue)
-> Map JsonKey JsonValue -> [MetricValue] -> Map JsonKey JsonValue
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'
}
Datum -> IO Datum
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 JsonKey
k JsonValue
v) = JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
k JsonValue
v Map JsonKey JsonValue
acc
sendEvent :: Label -> [MetricValue] -> Program τ ()
sendEvent :: Rope -> [MetricValue] -> Program τ ()
sendEvent Rope
label [MetricValue]
values = do
Context τ
context <- Program τ (Context τ)
forall τ. Program τ (Context τ)
getContext
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
TimeStamp
now <- IO TimeStamp
getCurrentTimeNanoseconds
let v :: MVar Datum
v = Context τ -> MVar Datum
forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
Datum
datum <- MVar Datum -> IO 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' = (Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue)
-> Map JsonKey JsonValue -> [MetricValue] -> Map JsonKey JsonValue
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 = Maybe Span
forall a. Maybe a
Nothing
, $sel:parentIdentifierFrom:Datum :: Maybe Span
parentIdentifierFrom = Datum -> Maybe Span
spanIdentifierFrom Datum
datum
, $sel:spanTimeFrom:Datum :: TimeStamp
spanTimeFrom = TimeStamp
now
, $sel:attachedMetadataFrom:Datum :: Map JsonKey JsonValue
attachedMetadataFrom = Map JsonKey JsonValue
meta'
}
let tel :: TQueue (Maybe Datum)
tel = Context τ -> TQueue (Maybe Datum)
forall τ. Context τ -> TQueue (Maybe Datum)
telemetryChannelFrom Context τ
context
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TQueue (Maybe Datum) -> Maybe Datum -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Datum)
tel (Datum -> Maybe Datum
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 JsonKey
k JsonValue
v) = JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
k JsonValue
v Map JsonKey JsonValue
acc
setStartTime :: TimeStamp -> Program τ ()
setStartTime :: TimeStamp -> Program τ ()
setStartTime TimeStamp
time = do
Context τ
context <- Program τ (Context τ)
forall τ. Program τ (Context τ)
getContext
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
let v :: MVar Datum
v = Context τ -> MVar Datum
forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
MVar Datum -> (Datum -> IO Datum) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
MVar Datum
v
(\Datum
datum -> Datum -> IO Datum
forall (f :: * -> *) a. Applicative f => a -> f a
pure Datum
datum{$sel:spanTimeFrom:Datum :: TimeStamp
spanTimeFrom = TimeStamp
time})
clearMetrics :: Program τ ()
clearMetrics :: Program τ ()
clearMetrics = do
Context τ
context <- Program τ (Context τ)
forall τ. Program τ (Context τ)
getContext
IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
let v :: MVar Datum
v = Context τ -> MVar Datum
forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
MVar Datum -> (Datum -> IO Datum) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
MVar Datum
v
(\Datum
datum -> Datum -> IO Datum
forall (f :: * -> *) a. Applicative f => a -> f a
pure Datum
datum{$sel:attachedMetadataFrom:Datum :: Map JsonKey JsonValue
attachedMetadataFrom = Map JsonKey JsonValue
forall κ ν. Map κ ν
emptyMap})