{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}

{- |
Traditional \"monitoring\" systems were concerned with gathering together obscene
quantities of metrics and graphing them. This makes for /very/ pretty billboard
displays in Network Operations Centers which impress visitors tremendously,
but (it turns out) are of limited use when actually trying to troubleshoot
problems or improve the performance of our systems.  We all put a lot of
effort into trying to detect anamolies but really, despite person-centuries of
effort, graphing raw system metrics doesn't get us as far as we would have liked.

Experience with large-scale distributed systems has led to the insight that
what you need is to be able to trace the path a request takes as it moves
through a system, correlating and comparing this trace to others like it. This
has led to the modern \"observability\" movement, more concerned with metrics
which descirbe user-visible experience, service levels, error budgets, and
being able to do ad-hoc analysis of evolving situations.

This library aims to support both models of using telemetry, with the primary
emphasis being on the /traces/ and /spans/ that can be connected together by
an observability tool.

= Usage

To use this capability, first you need to initialize the telemetry subsystem
with an appropriate exporter:

@
import "Core.Program"
import "Core.Telemetry"

main :: 'IO' ()
main = do
    context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('simpleConfig' [])
    context' <- 'initializeTelemetry' ['Core.Telemetry.Console.consoleExporter', 'Core.Telemetry.Structured.structuredExporter', 'Core.Telemetry.Honeycomb.honeycombExporter'] context
    'Core.Program.Execute.executeWith' context' program
@

Then when you run your program you can pick the exporter:

@
\$ __burgerservice --telemetry=structured__
@

to activate sending telemetry, in this case, to the console in the form of
structured JSON logs. Other exporters add additional command-line options with
which to configure how and where the metrics will be sent.

= Traces and Spans

At the top of your program or request loop you need to start a new trace (with
'beginTrace') or continue one inherited from another service (with
'usingTrace'):

@
program :: 'Core.Program.Execute.Program' 'Core.Program.Execute.None' ()
program = do
    'beginTrace' $ do
        'encloseSpan' \"Service request\" $ do

            -- do stuff!

            ...

            obs <- currentSkyObservation
            temp <- currentAirTemperature

            ...

            -- add appropriate telemetry values to the span
            'telemetry'
                [ 'metric' \"sky_colour\" (colourFrom obs)
                , 'metric' \"temperature" temp
                ]
@

will result in @sky_colour=\"Blue\"@ and @temperature=26.1@ or whatever being
sent by the telemetry system to the observability service that's been
activated.

The real magic here is that spans /nest/. As you go into each subcomponent on
your request path you can again call 'encloseSpan' creating a new span, which
can have its own telemetry:

@
currentSkyObservation :: 'Core.Program.Execute.Program' 'Core.Program.Execute.None' Observation
currentSkyObservation = do
    'encloseSpan' "Observe sky" $ do
        ...

        'telemetry'
            [ 'metric' \"radar_frequency\" freq
            , 'metric' \"cloud_cover\" blockageLevel
            ]

        'pure' result
@

Any metrics added before entering the new span will be inherited by the
subspan and sent when it finishes so you don't have to keep re-attaching data
if it's common across all the spans in your trace.

= Events

In other circumstances you will just want to send metrics:

@
        -- not again!
        'sendEvent' \"Cat meowed\"
            [ 'metric' \"room\" (\"living room\" :: 'Rope')
            , 'metric' "volume\" (127.44 :: 'Float') -- decibels
            , 'metric' \"apparently_hungry\" 'True'
            ]
@

will result in @room=\"living room\"@, @volume=127.44@, and
@apparently_hungry=true@ being sent as you'd expect. Ordinarily when you call
'metric' you are passing in a variable that already has a type, but when
hardcoding literals like in this example (less common but not unheard of)
you'll need to add a type annotation.

You /do not/ have to call 'sendEvent' from within a span, but if you do
appropriate metadata will be added to help the observability system link the
event to the context of the span it occured during.

Either way, explicitly sending an event, or upon exiting a span, the telemetry
will be gathered up and sent via the chosen exporter and forwarded to the
observability or monitoring service you have chosen.
-}
module Core.Telemetry.Observability (
    -- * Initializing
    Exporter,
    initializeTelemetry,

    -- * Traces
    Trace (..),
    Span (..),
    beginTrace,
    usingTrace,
    setServiceName,

    -- * Spans
    Label,
    encloseSpan,
    setStartTime,

    -- * Creating telemetry
    MetricValue,
    Telemetry (metric),
    telemetry,

    -- * Events
    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.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.Char (chr)
import Data.Int (Int32, Int64)
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 System.Random (newStdGen, randomRs)

{- |
A telemetry value that can be sent over the wire. This is a wrapper around
JSON values of type string, number, or boolean. You create these using the
'metric' method provided by a 'Telemetry' instance and passing them to the
'telemetry' function in a span or 'sendEvent' if noting an event.
-}

-- a bit specific to Honeycomb's very limited data model, but what else is
-- there?
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)

{- |
Record the name of the service that this span and its children are a part of.
A reasonable default is the name of the binary that's running, but frequently
you'll want to put something a bit more nuanced or specific to your
application. This is the overall name of the independent service, component,
or program complimenting the @label@ set when calling 'encloseSpan', which by
contrast descibes the name of the current phase, step, or even function name
within the overall scope of the \"service\".

This will end up as the @service_name@ parameter when exported.
-}

-- This field name appears to be very Honeycomb specific, but looking around
-- Open Telemmtry it was just a property floating around and regardless of
-- what it gets called it needs to get sent.
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))

-- HELP is this the efficient way to get to a Scientific?
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)))

-- HELP is this the efficient way to get to a Scientific?
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))

{- |
The usual warning about assuming the @ByteString@ is ASCII or UTF-8 applies
here. Don't use this to send binary mush.
-}
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))

{- |
The usual warning about assuming the @ByteString@ is ASCII or UTF-8 applies
here. Don't use this to send binary mush.
-}
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

{- |
Activate the telemetry subsystem for use within the
'Core.Program.Execute.Program' monad.

Each exporter specified here will add setup and configuration to the context,
including command-line options and environment variables needed as
approrpiate:

@
    context' <- 'initializeTelemetry' ['Core.Telemetry.Console.consoleExporter'] context
@

This will allow you to then select the appropriate backend at runtime:

@
\$ __burgerservice --telemetry=console__
@

which will result in it spitting out metrics as it goes,

@
  calories = 667.0
  flavour = true
  meal_name = "hamburger"
  precise = 45.0
@

and so on.
-}
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
    -- This doesn't actually setup the telemetry processor; that's done in
    -- executeAction. Here we're setting up each  of the exporters so they
    -- show up in --help. When we process command-line arguments we'll find
    -- out which exporter was activated, if any.
    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

{- |
Begin a span.

You need to call this from within the context of a trace, which is established
either by calling `beginTrace` or `usingTrace` somewhere above this point in
the program.

You can nest spans as you make your way through your program, which means each
span has a parent (except for the first one, which is the root span) In the
context of a trace, allows an observability tool to reconstruct the sequence
of events and to display them as a nested tree correspoding to your program
flow.

The current time will be noted when entering the 'Program' this span encloses,
and its duration recorded when the sub @Program@ exits. Start time, duration,
the unique identifier of the span (generated for you), the identifier of the
parent, and the unique identifier of the overall trace will be appended as
metadata points and then sent to the telemetry channel.
-}
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 <- IO Rope -> Program z Rope
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Rope
randomIdentifier
    Rope -> Rope -> Program z ()
forall τ. Rope -> Rope -> Program τ ()
debug 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
        -- prepare new span
        TimeStamp
start <- IO TimeStamp
getCurrentTimeNanoseconds

        -- slightly tricky: create a new Context with a new MVar with an
        -- forked copy of the current Datum, creating the nested span.
        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
                    }

        -- execute nested program

        a
result <- Context z -> Program z a -> IO a
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context z
context2 Program z a
action

        -- extract the Datum as it stands after running the action, finalize
        -- with its duration, and send it
        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')

        -- now back to your regularly scheduled Haskell program
        a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result

represent :: Int -> Char
represent :: Int -> Char
represent Int
x
    | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 = Int -> Char
chr (Int
48 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x)
    | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
36 = Int -> Char
chr (Int
65 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10)
    | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
62 = Int -> Char
chr (Int
97 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
36)
    | Bool
otherwise = Char
'@'

-- TODO replace this with something that gets a UUID
randomIdentifier :: IO Rope
randomIdentifier :: IO Rope
randomIdentifier = do
    StdGen
gen <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
    let result :: Rope
result = String -> Rope
packRope (String -> Rope) -> (StdGen -> String) -> StdGen -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Char) -> [Int] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Char
represent ([Int] -> String) -> (StdGen -> [Int]) -> StdGen -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
16 ([Int] -> [Int]) -> (StdGen -> [Int]) -> StdGen -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> StdGen -> [Int]
forall a g. (Random a, RandomGen g) => (a, a) -> g -> [a]
randomRs (Int
0, Int
61) (StdGen -> Rope) -> StdGen -> Rope
forall a b. (a -> b) -> a -> b
$ StdGen
gen
    Rope -> IO Rope
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rope
result

{- |
Start a new trace. A random identifier will be generated.

You /must/ have a single \"root span\" immediately below starting a new trace.

@
program :: 'Core.Program.Execute.Program' 'Core.Program.Execute.None' ()
program = do
    'beginTrace' $ do
        'encloseSpan' \"Service Request\" $ do
            ...
@
-}
beginTrace :: Program τ α -> Program τ α
beginTrace :: Program τ α -> Program τ α
beginTrace Program τ α
action = do
    Rope
trace <- IO Rope -> Program τ Rope
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Rope
randomIdentifier
    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

{- |
Begin a new trace, but using a trace identifier provided externally. This is
the most common case. Internal services that are play a part of a larger
request will inherit a job identifier, sequence number, or other externally
supplied unique code. Even an internet facing web service might have a
correlation ID provided by the outside load balancers.

If you are continuting an existing trace within the execution path of another,
larger, enclosing service then you need to specify what the parent span's
identifier is in the second argument.

@
program :: 'Core.Program.Execute.Program' 'Core.Program.Execute.None' ()
program = do

    -- do something that gets the trace ID
    trace <- ...

    -- and something to get the parent span ID
    parent <- ...

    'usingTrace' ('Trace' trace) ('Just' ('Span' span)) $ do
        'encloseSpan' \"Internal processing\" $ do
            ...
@
-}
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 τ ()
debug Rope
"trace" (Trace -> Rope
unTrace Trace
trace)
        Just Span
parent -> do
            Rope -> Rope -> Program τ ()
forall τ. Rope -> Rope -> Program τ ()
debug Rope
"trace" (Trace -> Rope
unTrace Trace
trace)
            Rope -> Rope -> Program τ ()
forall τ. Rope -> Rope -> Program τ ()
debug 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
        -- prepare new span
        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
                    }

        -- fork the Context
        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
                    }

        -- execute nested program
        Context τ -> Program τ α -> IO α
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context2 Program τ α
action

{- |
Add measurements to the current span.

@
        'telemetry'
            [ 'metric' \"calories\" (667 :: 'Int')
            , 'metric' \"precise\" measurement
            , 'metric' \"meal_name\" ("hamburger" :: 'Rope')
            , 'metric' \"flavour\" 'True'
            ]
@

The 'metric' function is a method provided by instances of the 'Telemtetry'
typeclass which is mostly a wrapper around constructing key/value pairs
suitable to be sent as measurements up to an observability service.
-}
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
        -- get the map out
        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

                -- update the map
                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

                -- replace the map back into the Datum (and thereby back into the
                -- Context), updating it
                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

{- |
Record telemetry about an event. Specify a label for the event and then
whichever metrics you wish to record.


The emphasis of this package is to create traces and spans. There are,
however, times when you just want to send telemetry about an event. You can
use 'sendEvent' to accomplish this.

If you do call 'sendEvent' within an enclosing span created with 'encloseSpan'
(the usual and expected use case) then this event will be \"linked\" to this
span so that the observability tool can display it attached to the span in
the in which it occured.

@
        'sendEvent'
            "Make tea"
            [ 'metric' \"sugar\" 'False'
            ]
@
-}
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
        -- get the map out
        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

        -- update the map
        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
        -- replace the map back into the Datum and queue for sending
        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

-- get current time after digging out datum and override spanTimeFrom before
-- sending Datum

{- |
Override the start time of the current span.

Under normal circumstances this shouldn't be necessary. The start and end of a
span are recorded automatically when calling 'encloseSpan'. Observabilty tools
are designed to be used live; traces and spans should be created in real time
in your code.
-}
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
        -- get the map out
        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})