{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK prune #-}

{- |
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
    , usingTrace'
    , setServiceName

      -- * Spans
    , Label
    , encloseSpan
    , setStartTime
    , setSpanName

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

      -- * Events
    , 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)

{- |
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
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 :: forall τ. Rope -> Program τ ()
setServiceName Rope
service = do
    Context τ
context <- forall τ. Program τ (Context τ)
getContext
    let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
            MVar Datum
v
            ( \Datum
datum -> do
                let datum' :: Datum
datum' =
                        Datum
datum
                            { $sel:serviceNameFrom:Datum :: Maybe Rope
serviceNameFrom = forall a. a -> Maybe a
Just Rope
service
                            }
                forall (f :: * -> *) a. Applicative f => a -> f a
pure Datum
datum'
            )

{- |
Adaptor class to take primitive values and send them as metrics. The
underlying types are either strings, numbers, or boolean so any instance will
need to externalize and then convert to one of these three.

(this class is what allows us to act pass in what look like polymorphic lists
of metrics to 'telemetry' and 'sendEvent')
-}
class Telemetry σ where
    metric :: Rope -> σ -> MetricValue

instance Telemetry Int where
    metric :: Rope -> Int -> MetricValue
metric Rope
k Int
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v))

instance Telemetry Int32 where
    metric :: Rope -> Int32 -> MetricValue
metric Rope
k Int32
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
v))

instance Telemetry Int64 where
    metric :: Rope -> Int64 -> MetricValue
metric Rope
k Int64
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
v))

instance Telemetry Word32 where
    metric :: Rope -> Word32 -> MetricValue
metric Rope
k Word32
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
v))

instance Telemetry Word64 where
    metric :: Rope -> Word64 -> MetricValue
metric Rope
k Word64
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v))

instance Telemetry Integer where
    metric :: Rope -> Integer -> MetricValue
metric Rope
k Integer
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber (forall a. Num a => Integer -> a
fromInteger Integer
v))

-- 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 (forall a. Fractional a => Rational -> a
fromRational (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 (forall a. Fractional a => Rational -> a
fromRational (forall a. Real a => a -> Rational
toRational Double
v)))

instance Telemetry Scientific where
    metric :: Rope -> Scientific -> MetricValue
metric Rope
k Scientific
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Scientific -> JsonValue
JsonNumber Scientific
v)

instance Telemetry Rope where
    metric :: Rope -> Rope -> MetricValue
metric Rope
k Rope
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString Rope
v)

instance Telemetry String where
    metric :: Rope -> String -> MetricValue
metric Rope
k String
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall α. Textual α => α -> Rope
intoRope String
v))

instance Telemetry () where
    metric :: Rope -> () -> MetricValue
metric Rope
k ()
_ = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) JsonValue
JsonNull

{- |
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 (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 (forall α. Textual α => α -> Rope
intoRope ByteString
v))

instance Telemetry T.Text where
    metric :: Rope -> Text -> MetricValue
metric Rope
k Text
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall α. Textual α => α -> Rope
intoRope Text
v))

instance Telemetry U.Text where
    metric :: Rope -> Text -> MetricValue
metric Rope
k Text
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall α. Textual α => α -> Rope
intoRope Text
v))

instance Telemetry Bool where
    metric :: Rope -> Bool -> MetricValue
metric Rope
k Bool
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Bool -> JsonValue
JsonBool Bool
v)

instance Telemetry JsonValue where
    metric :: Rope -> JsonValue -> MetricValue
metric Rope
k JsonValue
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) JsonValue
v

{- |
Strip the constructor off if the value is Just, and send `null` if Nothing.

@since 0.2.5
-}
instance Telemetry σ => Telemetry (Maybe σ) where
    metric :: Rope -> Maybe σ -> MetricValue
metric Rope
k Maybe σ
v = case Maybe σ
v of
        Maybe σ
Nothing -> JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) JsonValue
JsonNull
        Just σ
v' -> forall σ. Telemetry σ => Rope -> σ -> MetricValue
metric Rope
k σ
v'

{- |
@since 0.2.5
-}
instance Telemetry UTCTime where
    metric :: Rope -> UTCTime -> MetricValue
metric Rope
k UTCTime
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall ξ. Externalize ξ => ξ -> Rope
formatExternal (forall a. Instant a => a -> Time
intoTime UTCTime
v)))

{- |
@since 0.2.6
-}
instance Telemetry Day where
    metric :: Rope -> Day -> MetricValue
metric Rope
k Day
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall ξ. Externalize ξ => ξ -> Rope
formatExternal Day
v))

{- |
@since 0.2.6
-}
instance Telemetry UUID where
    metric :: Rope -> UUID -> MetricValue
metric Rope
k UUID
v = JsonKey -> JsonValue -> MetricValue
MetricValue (Rope -> JsonKey
JsonKey Rope
k) (Rope -> JsonValue
JsonString (forall ξ. Externalize ξ => ξ -> Rope
formatExternal UUID
v))

{- |
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 :: forall τ. [Exporter] -> Context τ -> IO (Context τ)
initializeTelemetry [Exporter]
exporters1 Context τ
context =
    let exporters0 :: [Exporter]
exporters0 = forall τ. Context τ -> [Exporter]
initialExportersFrom Context τ
context
        exporters2 :: [Exporter]
exporters2 = [Exporter]
exporters0 forall a. [a] -> [a] -> [a]
++ [Exporter]
exporters1

        codenames :: [Rope]
codenames =
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Rope
name -> Char -> Rope
singletonRope Char
'"' forall a. Semigroup a => a -> a -> a
<> Rope
name forall a. Semigroup a => a -> a -> a
<> Char -> Rope
singletonRope Char
'"')
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exporter -> Rope
codenameFrom
                forall a b. (a -> b) -> a -> b
$ [Exporter]
exporters2

        config0 :: Config
config0 = forall τ. Context τ -> Config
initialConfigFrom Context τ
context
        config1 :: Config
config1 =
            Options -> Config -> Config
appendOption
                ( LongName -> Maybe Char -> ParameterValue -> Rope -> Options
Option
                    LongName
"telemetry"
                    forall a. Maybe a
Nothing
                    (String -> ParameterValue
Value String
"EXPORTER")
                    ( [quote|
                    Turn on telemetry. Tracing data and metrics from events
                    will be forwarded via the specified exporter. Valid values
                    are
                      |]
                        forall a. Semigroup a => a -> a -> a
<> [Rope] -> Rope
oxford [Rope]
codenames
                    )
                )
                Config
config0

        config2 :: Config
config2 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Config -> Exporter -> Config
f Config
config1 [Exporter]
exporters2
    in  forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( Context τ
context
                { $sel:initialConfigFrom:Context :: Config
initialConfigFrom = Config
config2
                , $sel:initialExportersFrom:Context :: [Exporter]
initialExportersFrom = [Exporter]
exporters2
                }
            )
  where
    -- 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.

By convention the name of a span is the name of the function (method, handler,
action, ...) you've just entered. Additional metadata can be added to the span
using the 'telemetry' function.

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 :: forall z a. Rope -> Program z a -> Program z a
encloseSpan Rope
label Program z a
action = do
    Context z
context <- forall τ. Program τ (Context τ)
getContext

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        -- prepare new span
        Time
start <- IO Time
getCurrentTimeNanoseconds

        Word16
rand <- forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Word16

        let unique :: Span
unique = Time -> Word16 -> Span
createIdentifierSpan Time
start Word16
rand

        forall τ α. Context τ -> Program τ α -> IO α
subProgram Context z
context forall a b. (a -> b) -> a -> b
$ do
            forall τ. Rope -> Program τ ()
internal (Rope
"Enter " forall a. Semigroup a => a -> a -> a
<> Rope
label)
            forall τ. Rope -> Program τ ()
internal (Rope
"span = " forall a. Semigroup a => a -> a -> a
<> Span -> Rope
unSpan Span
unique)

        -- 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 = forall τ. Context τ -> MVar Datum
currentDatumFrom Context z
context
        Datum
datum <- forall a. MVar a -> IO a
readMVar MVar Datum
v

        let datum' :: Datum
datum' =
                Datum
datum
                    { $sel:spanIdentifierFrom:Datum :: Maybe Span
spanIdentifierFrom = forall a. a -> Maybe a
Just Span
unique
                    , $sel:spanNameFrom:Datum :: Rope
spanNameFrom = Rope
label
                    , $sel:spanTimeFrom:Datum :: Time
spanTimeFrom = Time
start
                    , $sel:parentIdentifierFrom:Datum :: Maybe Span
parentIdentifierFrom = Datum -> Maybe Span
spanIdentifierFrom Datum
datum
                    }

        MVar Datum
v2 <- forall a. a -> IO (MVar a)
newMVar Datum
datum'

        let context2 :: Context z
context2 =
                Context z
context
                    { $sel:currentDatumFrom:Context :: MVar Datum
currentDatumFrom = MVar Datum
v2
                    }

        -- execute nested program. We have to use try (c.f. catch) so that if
        -- an exception has occurred we still enqueue the telemetry datum
        -- before bailing out.
        Either SomeException a
result :: Either SomeException a <-
            forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Safe.try
                (forall τ α. Context τ -> Program τ α -> IO α
subProgram Context z
context2 Program z a
action)

        forall τ α. Context τ -> Program τ α -> IO α
subProgram Context z
context forall a b. (a -> b) -> a -> b
$ do
            forall τ. Rope -> Program τ ()
internal (Rope
"Leave " forall a. Semigroup a => a -> a -> a
<> Rope
label)

        -- extract the Datum as it stands after running the action, finalize
        -- with its duration, and send it. Note that we don't use the original
        -- start time as it may have been overwritten.
        Time
finish <- IO Time
getCurrentTimeNanoseconds
        Datum
datum2 <- forall a. MVar a -> IO a
readMVar MVar Datum
v2
        let start2 :: Time
start2 = Datum -> Time
spanTimeFrom Datum
datum2
        let datum2' :: Datum
datum2' =
                Datum
datum2
                    { $sel:durationFrom:Datum :: Maybe Int64
durationFrom = forall a. a -> Maybe a
Just (Time -> Int64
unTime Time
finish forall a. Num a => a -> a -> a
- Time -> Int64
unTime Time
start2)
                    }

        let tel :: TQueue (Maybe Datum)
tel = forall τ. Context τ -> TQueue (Maybe Datum)
telemetryChannelFrom Context z
context

        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Datum)
tel (forall a. a -> Maybe a
Just Datum
datum2')

        -- now back to your regularly scheduled Haskell program
        case Either SomeException a
result of
            Left SomeException
e -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw SomeException
e
            Right a
value -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value

{- |
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 :: forall τ α. Program τ α -> Program τ α
beginTrace Program τ α
action = do
    Time
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        IO Time
getCurrentTimeNanoseconds

    Word16
rand <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        (forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Word16)

    let trace :: Trace
trace = Time -> Word16 -> MAC -> Trace
createIdentifierTrace Time
now Word16
rand MAC
hostMachineIdentity

    forall τ. Rope -> Program τ ()
internal Rope
"Begin trace"
    forall τ. Rope -> Program τ ()
internal (Rope
"trace = " forall a. Semigroup a => a -> a -> a
<> Trace -> Rope
unTrace Trace
trace)

    forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace Trace
trace forall a. Maybe a
Nothing Program τ α
action

{- |
Continue an existing trace using a 'Trace' identifier and parent 'Span'
identifier sourced externally. This is the most common case. Internal services
that 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.

@
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) ('Span' parent) $ do
        'encloseSpan' \"Internal processing\" $ do
            ...
@

@since 0.2.0
-}
usingTrace :: Trace -> Span -> Program τ α -> Program τ α
usingTrace :: forall τ α. Trace -> Span -> Program τ α -> Program τ α
usingTrace Trace
trace Span
parent Program τ α
action = do
    forall τ. Rope -> Program τ ()
internal Rope
"Using trace"
    forall τ. Rope -> Program τ ()
internal (Rope
"trace = " forall a. Semigroup a => a -> a -> a
<> Trace -> Rope
unTrace Trace
trace)
    forall τ. Rope -> Program τ ()
internal (Rope
"parent = " forall a. Semigroup a => a -> a -> a
<> Span -> Rope
unSpan Span
parent)

    forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace Trace
trace (forall a. a -> Maybe a
Just Span
parent) Program τ α
action

{- |
Create a new trace with the specified 'Trace' identifier. Unlike 'usingTrace'
this does /not/ set the parent 'Span' identifier, thereby marking this as a
new trace and causing the first span enclosed within this trace to be
considered the \"root\" span of the trace. This is unusual and should only
expected to be used in concert with the 'setIdentifierSpan' override to create
a root spans in asynchronous processes /after/ all the child spans have
already been composed and sent.

Most times, you don't need this. You're much better off using 'beginTrace' to
create a root span. However, life is not kind, and sometimes bad things happen
to good abstractions. Maybe you're tracing your build system, which isn't
obliging enough to be all contained in one Haskell process, but is a
half-dozen steps shotgunned across several different processes. In situations
like this, it's useful to be able to generate a 'Trace' identifier and 'Span'
identifier, use that as the parent across several different process
executions, hanging children spans off of this as you go, then manually send
up the root span at the end of it all.

@
    trace <- ...
    unique <- ...

    -- many child spans in other processes have used these as trace
    -- identifiers and parent span identifier. Now form the root span thereby
    -- finishing the trace.

    'usingTrace'' trace $ do
        'encloseSpan' \"Launch Missiles\" $ do
            'setStartTime' start
            'setIdentifierSpan' unique
            'telemetry'
                [ 'metric' ...
                ]
@

@since 0.2.1
-}
usingTrace' :: Trace -> Program τ α -> Program τ α
usingTrace' :: forall τ α. Trace -> Program τ α -> Program τ α
usingTrace' Trace
trace Program τ α
action = do
    forall τ. Rope -> Program τ ()
internal Rope
"Using trace"
    forall τ. Rope -> Program τ ()
internal (Rope
"trace = " forall a. Semigroup a => a -> a -> a
<> Trace -> Rope
unTrace Trace
trace)

    forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace Trace
trace forall a. Maybe a
Nothing Program τ α
action

encloseTrace :: Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace :: forall τ α. Trace -> Maybe Span -> Program τ α -> Program τ α
encloseTrace Trace
trace Maybe Span
possibleParent Program τ α
action = do
    Context τ
context <- forall τ. Program τ (Context τ)
getContext

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        -- prepare new span
        let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
        Datum
datum <- forall a. MVar a -> IO a
readMVar MVar Datum
v

        let datum2 :: Datum
datum2 =
                Datum
datum
                    { $sel:traceIdentifierFrom:Datum :: Maybe Trace
traceIdentifierFrom = forall a. a -> Maybe a
Just Trace
trace
                    , $sel:spanIdentifierFrom:Datum :: Maybe Span
spanIdentifierFrom = Maybe Span
possibleParent
                    }

        -- fork the Context
        MVar Datum
v2 <- forall a. a -> IO (MVar a)
newMVar Datum
datum2

        let context2 :: Context τ
context2 =
                Context τ
context
                    { $sel:currentDatumFrom:Context :: MVar Datum
currentDatumFrom = MVar Datum
v2
                    }

        -- execute nested program
        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 'Telemetry'
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 :: forall τ. [MetricValue] -> Program τ ()
telemetry [MetricValue]
values = do
    Context τ
context <- forall τ. Program τ (Context τ)
getContext

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        -- get the map out
        let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
        forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
            MVar Datum
v
            ( \Datum
datum -> do
                let meta :: Map JsonKey JsonValue
meta = Datum -> Map JsonKey JsonValue
attachedMetadataFrom Datum
datum

                -- update the map
                let meta' :: Map JsonKey JsonValue
meta' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue
f Map JsonKey JsonValue
meta [MetricValue]
values

                -- 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'
                            }
                forall (f :: * -> *) a. Applicative f => a -> f a
pure Datum
datum'
            )
  where
    f :: Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue
    f :: Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue
f Map JsonKey JsonValue
acc (MetricValue k :: JsonKey
k@(JsonKey Rope
text) JsonValue
v) =
        if Rope -> Bool
nullRope Rope
text
            then forall a. HasCallStack => String -> a
error String
"Empty metric field name not allowed"
            else forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
k JsonValue
v Map JsonKey JsonValue
acc

{- |
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 :: forall τ. Rope -> [MetricValue] -> Program τ ()
sendEvent Rope
label [MetricValue]
values = do
    Context τ
context <- forall τ. Program τ (Context τ)
getContext

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Time
now <- IO Time
getCurrentTimeNanoseconds
        -- get the map out
        let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
        Datum
datum <- forall a. MVar a -> IO a
readMVar MVar Datum
v

        let meta :: Map JsonKey JsonValue
meta = Datum -> Map JsonKey JsonValue
attachedMetadataFrom Datum
datum

        -- update the map
        let meta' :: Map JsonKey JsonValue
meta' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue
f Map JsonKey JsonValue
meta [MetricValue]
values
        -- 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 = forall a. Maybe a
Nothing
                    , $sel:parentIdentifierFrom:Datum :: Maybe Span
parentIdentifierFrom = Datum -> Maybe Span
spanIdentifierFrom Datum
datum
                    , $sel:spanTimeFrom:Datum :: Time
spanTimeFrom = Time
now
                    , $sel:attachedMetadataFrom:Datum :: Map JsonKey JsonValue
attachedMetadataFrom = Map JsonKey JsonValue
meta'
                    }

        let tel :: TQueue (Maybe Datum)
tel = forall τ. Context τ -> TQueue (Maybe Datum)
telemetryChannelFrom Context τ
context
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Datum)
tel (forall a. a -> Maybe a
Just Datum
datum')
  where
    f :: Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue
    f :: Map JsonKey JsonValue -> MetricValue -> Map JsonKey JsonValue
f Map JsonKey JsonValue
acc (MetricValue k :: JsonKey
k@(JsonKey Rope
text) JsonValue
v) =
        if Rope -> Bool
nullRope Rope
text
            then forall a. HasCallStack => String -> a
error String
"Empty metric field name not allowed"
            else forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue JsonKey
k JsonValue
v Map JsonKey JsonValue
acc

-- 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.

@since 0.1.6
-}
setStartTime :: Time -> Program τ ()
setStartTime :: forall τ. Time -> Program τ ()
setStartTime Time
time = do
    Context τ
context <- forall τ. Program τ (Context τ)
getContext

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        -- get the map out
        let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
        forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
            MVar Datum
v
            (\Datum
datum -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Datum
datum {$sel:spanTimeFrom:Datum :: Time
spanTimeFrom = Time
time})

{- |
Override the name of the current span.

Under normal circumstances this shouldn't be necessary. The label specified
when you call 'encloseSpan' will be used to name the span when it is sent to
the telemetry channel. If, however, the span you are in was created
automatically and the circumstances you find yourself in require a different
name, you can use this function to change it.

@since 0.2.7
-}
setSpanName :: Label -> Program τ ()
setSpanName :: forall τ. Rope -> Program τ ()
setSpanName Rope
label = do
    Context τ
context <- forall τ. Program τ (Context τ)
getContext

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        -- get the map out
        let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
        forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
            MVar Datum
v
            (\Datum
datum -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Datum
datum {$sel:spanNameFrom:Datum :: Rope
spanNameFrom = Rope
label})

{- |
Reset the accumulated metadata metrics to the emtpy set.

This isn't something you'd need in normal circumstances, as inheriting
contextual metrics from surrounding code is usually what you want. But if you
have a significant change of setting then clearing the attached metadata may
be appropriate; after all, observability tools visualizing a trace will show
you the context an event was encountered in.
-}
clearMetrics :: Program τ ()
clearMetrics :: forall τ. Program τ ()
clearMetrics = do
    Context τ
context <- forall τ. Program τ (Context τ)
getContext

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        -- get the map out
        let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
        forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
            MVar Datum
v
            ( \Datum
datum ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    Datum
datum
                        { $sel:attachedMetadataFrom:Datum :: Map JsonKey JsonValue
attachedMetadataFrom = forall κ ν. Map κ ν
emptyMap
                        }
            )

{- |
Reset the program context so that the currently executing program is no longer
within a trace or span.

This is specifically for the occasion where you have forked a new thread but
have not yet received the event which would occasion starting a new trace.

The current "service name" associated with this execution thread is preserved
(usually this is set once per process at startup or once with 'setServiceName'
and having to reset it everytime you call this would be silly).

@since 0.2.4
-}
clearTrace :: Program τ ()
clearTrace :: forall τ. Program τ ()
clearTrace = do
    Context τ
context <- forall τ. Program τ (Context τ)
getContext

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        let v :: MVar Datum
v = forall τ. Context τ -> MVar Datum
currentDatumFrom Context τ
context
        forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_
            MVar Datum
v
            ( \Datum
datum -> do
                let name :: Maybe Rope
name = Datum -> Maybe Rope
serviceNameFrom Datum
datum
                forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    Datum
emptyDatum
                        { $sel:serviceNameFrom:Datum :: Maybe Rope
serviceNameFrom = Maybe Rope
name
                        }
            )