{-# 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,
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
(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 () 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 (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
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' -> Rope -> σ -> MetricValue
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 (Time -> Rope
forall ξ. Externalize ξ => ξ -> Rope
formatExternal (UTCTime -> Time
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 (Day -> Rope
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 (UUID -> Rope
forall ξ. Externalize ξ => ξ -> Rope
formatExternal UUID
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
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
Time
start <- IO Time
getCurrentTimeNanoseconds
Word16
rand <- IO Word16
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Word16
let unique :: Span
unique = Time -> Word16 -> Span
createIdentifierSpan Time
start Word16
rand
Context z -> Program z () -> IO ()
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context z
context (Program z () -> IO ()) -> Program z () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Rope -> Program z ()
forall τ. Rope -> Program τ ()
internal (Rope
"Enter " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
label)
Rope -> Program z ()
forall τ. Rope -> Program τ ()
internal (Rope
"span = " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Span -> Rope
unSpan Span
unique)
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 :: Time
spanTimeFrom = Time
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)
Context z -> Program z () -> IO ()
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context z
context (Program z () -> IO ()) -> Program z () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Rope -> Program z ()
forall τ. Rope -> Program τ ()
internal (Rope
"Leave " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
label)
Time
finish <- IO Time
getCurrentTimeNanoseconds
Datum
datum2 <- MVar Datum -> IO Datum
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 = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Time -> Int64
unTime Time
finish Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Time -> Int64
unTime Time
start2)
}
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
Time
now <- IO Time -> Program τ Time
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Time -> Program τ Time) -> IO Time -> Program τ Time
forall a b. (a -> b) -> a -> b
$ do
IO Time
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 = Time -> Word16 -> MAC -> Trace
createIdentifierTrace Time
now Word16
rand MAC
hostMachineIdentity
Rope -> Program τ ()
forall τ. Rope -> Program τ ()
internal Rope
"Begin trace"
Rope -> Program τ ()
forall τ. Rope -> Program τ ()
internal (Rope
"trace = " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Trace -> Rope
unTrace Trace
trace)
Trace -> Maybe Span -> Program τ α -> Program τ α
forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace Trace
trace Maybe Span
forall a. Maybe a
Nothing Program τ α
action
usingTrace :: Trace -> Span -> Program τ α -> Program τ α
usingTrace :: Trace -> Span -> Program τ α -> Program τ α
usingTrace Trace
trace Span
parent Program τ α
action = do
Rope -> Program τ ()
forall τ. Rope -> Program τ ()
internal Rope
"Using trace"
Rope -> Program τ ()
forall τ. Rope -> Program τ ()
internal (Rope
"trace = " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Trace -> Rope
unTrace Trace
trace)
Rope -> Program τ ()
forall τ. Rope -> Program τ ()
internal (Rope
"parent = " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Span -> Rope
unSpan Span
parent)
Trace -> Maybe Span -> Program τ α -> Program τ α
forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace Trace
trace (Span -> Maybe Span
forall a. a -> Maybe a
Just Span
parent) Program τ α
action
usingTrace' :: Trace -> Program τ α -> Program τ α
usingTrace' :: Trace -> Program τ α -> Program τ α
usingTrace' Trace
trace Program τ α
action = do
Rope -> Program τ ()
forall τ. Rope -> Program τ ()
internal Rope
"Using trace"
Rope -> Program τ ()
forall τ. Rope -> Program τ ()
internal (Rope
"trace = " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Trace -> Rope
unTrace Trace
trace)
Trace -> Maybe Span -> Program τ α -> Program τ α
forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace Trace
trace Maybe Span
forall a. Maybe a
Nothing Program τ α
action
encloseTrace :: Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace :: Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace Trace
trace Maybe Span
possibleParent Program τ α
action = 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
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 k :: JsonKey
k@(JsonKey Rope
text) JsonValue
v) =
if Rope -> Bool
nullRope Rope
text
then String -> Map JsonKey JsonValue
forall a. HasCallStack => String -> a
error String
"Empty metric field name not allowed"
else 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
Time
now <- IO Time
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 :: Time
spanTimeFrom = Time
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 k :: JsonKey
k@(JsonKey Rope
text) JsonValue
v) =
if Rope -> Bool
nullRope Rope
text
then String -> Map JsonKey JsonValue
forall a. HasCallStack => String -> a
error String
"Empty metric field name not allowed"
else JsonKey
-> JsonValue -> Map JsonKey JsonValue -> Map JsonKey JsonValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
k JsonValue
v Map JsonKey JsonValue
acc
setStartTime :: Time -> Program τ ()
setStartTime :: Time -> Program τ ()
setStartTime Time
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 :: Time
spanTimeFrom = Time
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
}
)
clearTrace :: Program τ ()
clearTrace :: Program τ ()
clearTrace = 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 name :: Maybe Rope
name = Datum -> Maybe Rope
serviceNameFrom Datum
datum
Datum -> IO Datum
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Datum
emptyDatum
{ $sel:serviceNameFrom:Datum :: Maybe Rope
serviceNameFrom = Maybe Rope
name
}
)