{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
module Core.Telemetry.Observability (
Exporter,
initializeTelemetry,
Trace (..),
Span (..),
beginTrace,
usingTrace,
setServiceName,
Label,
encloseSpan,
setStartTime,
MetricValue,
Telemetry (metric),
telemetry,
sendEvent,
) where
import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TQueue (writeTQueue)
import Core.Data.Structures (Map, insertKeyValue)
import Core.Encoding.Json
import Core.Program.Arguments
import Core.Program.Context
import Core.Program.Execute (sleepThread)
import Core.Program.Logging
import Core.System.Base (liftIO)
import Core.System.External (TimeStamp (unTimeStamp), getCurrentTimeNanoseconds)
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 Data.Int (Int32, Int64)
import qualified Data.List as List (foldl')
import Data.Locator (padWithZeros, toBase62, toLatin25)
import Data.Scientific (Scientific)
import qualified Data.Text as T (Text)
import qualified Data.Text.Lazy as U (Text)
import Data.UUID (UUID, toWords)
import Data.UUID.V1 (nextUUID)
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 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
Rope
unique <- Program z Rope
forall τ. Program τ Rope
generateIdentifierBase62
Rope -> Rope -> Program z ()
forall τ. Rope -> Rope -> Program τ ()
internal Rope
label Rope
emptyRope
Rope -> Rope -> Program z ()
forall τ. Rope -> Rope -> Program τ ()
internal Rope
"span = " Rope
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
TimeStamp
start <- IO TimeStamp
getCurrentTimeNanoseconds
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 (Rope -> Span
Span Rope
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
}
a
result <- 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')
a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
getUniqueId :: Program τ UUID
getUniqueId :: Program τ UUID
getUniqueId = do
Maybe UUID
next <- IO (Maybe UUID) -> Program τ (Maybe UUID)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe UUID)
nextUUID
case Maybe UUID
next of
Just UUID
uuid -> UUID -> Program τ UUID
forall (f :: * -> *) a. Applicative f => a -> f a
pure UUID
uuid
Maybe UUID
Nothing -> do
Rational -> Program τ ()
forall τ. Rational -> Program τ ()
sleepThread Rational
0.000001
Program τ UUID
forall τ. Program τ UUID
getUniqueId
generateIdentifierLatin25 :: Program τ Rope
generateIdentifierLatin25 :: Program τ Rope
generateIdentifierLatin25 = do
UUID
uuid <- Program τ UUID
forall τ. Program τ UUID
getUniqueId
let (Word32
w1, Word32
w2, Word32
w3, Word32
w4) = UUID -> (Word32, Word32, Word32, Word32)
toWords UUID
uuid
l1 :: Rope
l1 = Word32 -> Rope
convertL Word32
w1
l2 :: Rope
l2 = Word32 -> Rope
convertL Word32
w2
l3 :: Rope
l3 = Word32 -> Rope
convertB Word32
w3
l4 :: Rope
l4 = Word32 -> Rope
convertB Word32
w4
result :: Rope
result = Rope
l1 Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
l2 Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
l3 Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
l4
Rope -> Program τ Rope
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rope
result
where
convertL :: Word32 -> Rope
convertL = String -> Rope
forall α. Textual α => α -> Rope
intoRope (String -> Rope) -> (Word32 -> String) -> Word32 -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
padWithZeros Int
7 ShowS -> (Word32 -> String) -> Word32 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> (Word32 -> String) -> Word32 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
toLatin25 (Int -> String) -> (Word32 -> Int) -> Word32 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
convertB :: Word32 -> Rope
convertB = String -> Rope
forall α. Textual α => α -> Rope
intoRope (String -> Rope) -> (Word32 -> String) -> Word32 -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
padWithZeros Int
7 ShowS -> (Word32 -> String) -> Word32 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
toLatin25 (Int -> String) -> (Word32 -> Int) -> Word32 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
generateIdentifierBase62 :: Program τ Rope
generateIdentifierBase62 :: Program τ Rope
generateIdentifierBase62 = do
UUID
uuid <- Program τ UUID
forall τ. Program τ UUID
getUniqueId
let (Word32
w1, Word32
w2, Word32
w3, Word32
w4) = UUID -> (Word32, Word32, Word32, Word32)
toWords UUID
uuid
b1 :: Rope
b1 = Word32 -> Rope
convertL Word32
w1
b2 :: Rope
b2 = Word32 -> Rope
convertL Word32
w2
b3 :: Rope
b3 = Word32 -> Rope
convertB Word32
w3
b4 :: Rope
b4 = Word32 -> Rope
convertB Word32
w4
result :: Rope
result = Rope
b1 Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
b2 Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
b3 Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
b4
Rope -> Program τ Rope
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rope
result
where
convertL :: Word32 -> Rope
convertL = String -> Rope
forall α. Textual α => α -> Rope
intoRope (String -> Rope) -> (Word32 -> String) -> Word32 -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
padWithZeros Int
6 ShowS -> (Word32 -> String) -> Word32 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> (Word32 -> String) -> Word32 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
toBase62 (Integer -> String) -> (Word32 -> Integer) -> Word32 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
convertB :: Word32 -> Rope
convertB = String -> Rope
forall α. Textual α => α -> Rope
intoRope (String -> Rope) -> (Word32 -> String) -> Word32 -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
padWithZeros Int
6 ShowS -> (Word32 -> String) -> Word32 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
toBase62 (Integer -> String) -> (Word32 -> Integer) -> Word32 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
beginTrace :: Program τ α -> Program τ α
beginTrace :: Program τ α -> Program τ α
beginTrace Program τ α
action = do
Rope
trace <- Program τ Rope
forall τ. Program τ Rope
generateIdentifierLatin25
Trace -> Maybe Span -> Program τ α -> Program τ α
forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
usingTrace (Rope -> Trace
Trace Rope
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:parentIdentifierFrom:Datum :: Maybe Span
parentIdentifierFrom = 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})