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

{- |
Machinery for generating identifiers to be used in traces and spans. Meets the
requirements of the [W3C Trace
Context](https://www.w3.org/TR/trace-context/#traceparent-header)
specification, specifically as relates to forming trace identifiers and span
identifiers into @traceparent@ headers. The key requirements are that traces
be globally unique and that spans be unique within a trace.
-}
module Core.Telemetry.Identifiers (
    -- * Traces and Spans
    getIdentifierTrace,
    getIdentifierSpan,
    setIdentifierSpan,

    -- * Internals
    createIdentifierTrace,
    createIdentifierSpan,
    hostMachineIdentity,
    createTraceParentHeader,
    parseTraceParentHeader,
    -- for testing
    toHexNormal64,
    toHexReversed64,
    toHexNormal32,
    toHexReversed32,
) where

import Control.Concurrent.MVar (modifyMVar_, readMVar)
import Core.Program.Context
import Core.Program.Logging
import Core.System (unsafePerformIO)
import Core.System.Base (liftIO)
import Core.System.External (TimeStamp (unTimeStamp))
import Core.Text.Rope
import Core.Text.Utilities (breakPieces)
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import Data.Text.Internal.Unsafe.Char (unsafeChr8)
import GHC.Word
import Network.Info (MAC (..), NetworkInterface, getNetworkInterfaces, mac)

{- |
Get the MAC address of the first interface that's not the loopback device. If
something goes weird then we return a valid but bogus address (in the locally
administered addresses block).

@since 0.1.9
-}
hostMachineIdentity :: MAC
hostMachineIdentity :: MAC
hostMachineIdentity = IO MAC -> MAC
forall a. IO a -> a
unsafePerformIO (IO MAC -> MAC) -> IO MAC -> MAC
forall a b. (a -> b) -> a -> b
$ do
    [NetworkInterface]
interfaces <- IO [NetworkInterface]
getNetworkInterfaces
    MAC -> IO MAC
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([NetworkInterface] -> MAC
go [NetworkInterface]
interfaces)
  where
    go :: [NetworkInterface] -> MAC
    go :: [NetworkInterface] -> MAC
go [] = MAC
bogusAddress
    go (NetworkInterface
interface : [NetworkInterface]
remainder) =
        let address :: MAC
address = NetworkInterface -> MAC
mac NetworkInterface
interface
         in if MAC
address MAC -> MAC -> Bool
forall a. Eq a => a -> a -> Bool
/= MAC
loopbackAddress
                then MAC
address
                else [NetworkInterface] -> MAC
go [NetworkInterface]
remainder

    loopbackAddress :: MAC
loopbackAddress = Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> MAC
MAC Word8
00 Word8
00 Word8
00 Word8
00 Word8
00 Word8
00
    bogusAddress :: MAC
bogusAddress = Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> MAC
MAC Word8
0xfe Word8
0xff Word8
0xff Word8
0xff Word8
0xff Word8
0xff
{-# NOINLINE hostMachineIdentity #-}

{- |
Generate an identifier suitable for use in a trace context. Trace identifiers
are 16 bytes. We incorporate the time to nanosecond precision, the host
system's MAC address, and a random element. This is similar to a version 1
UUID, but we render the least significant bits of the time stamp ordered first
so that visual distinctiveness is on the left. The MAC address in the lower 48
bits is /not/ reversed, leaving the most distinctiveness [the actual host as
opposed to manufacturer OIN] hanging on the right hand edge of the identifier.
The two bytes of supplied randomness are put in the middle.

@since 0.1.9
-}
createIdentifierTrace :: TimeStamp -> Word16 -> MAC -> Trace
createIdentifierTrace :: TimeStamp -> Word16 -> MAC -> Trace
createIdentifierTrace TimeStamp
time Word16
rand MAC
address =
    let p1 :: Rope
p1 = String -> Rope
packRope (Word64 -> String
toHexReversed64 (TimeStamp -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral TimeStamp
time))
        p2 :: Rope
p2 = String -> Rope
packRope (Word16 -> String
toHexNormal16 Word16
rand)
        p3 :: Rope
p3 = String -> Rope
packRope (MAC -> String
convertMACToHex MAC
address)
     in Rope -> Trace
Trace
            (Rope
p1 Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
p2 Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
p3)

convertMACToHex :: MAC -> [Char]
convertMACToHex :: MAC -> String
convertMACToHex (MAC Word8
b1 Word8
b2 Word8
b3 Word8
b4 Word8
b5 Word8
b6) =
    Word8 -> Int -> Char
forall a. (Integral a, Bits a) => a -> Int -> Char
nibbleToHex Word8
b1 Int
4 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Word8 -> Int -> Char
forall a. (Integral a, Bits a) => a -> Int -> Char
nibbleToHex Word8
b1 Int
0 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Word8 -> Int -> Char
forall a. (Integral a, Bits a) => a -> Int -> Char
nibbleToHex Word8
b2 Int
4 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Word8 -> Int -> Char
forall a. (Integral a, Bits a) => a -> Int -> Char
nibbleToHex Word8
b2 Int
0 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Word8 -> Int -> Char
forall a. (Integral a, Bits a) => a -> Int -> Char
nibbleToHex Word8
b3 Int
4 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Word8 -> Int -> Char
forall a. (Integral a, Bits a) => a -> Int -> Char
nibbleToHex Word8
b3 Int
0 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Word8 -> Int -> Char
forall a. (Integral a, Bits a) => a -> Int -> Char
nibbleToHex Word8
b4 Int
4 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Word8 -> Int -> Char
forall a. (Integral a, Bits a) => a -> Int -> Char
nibbleToHex Word8
b4 Int
0 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Word8 -> Int -> Char
forall a. (Integral a, Bits a) => a -> Int -> Char
nibbleToHex Word8
b5 Int
4 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Word8 -> Int -> Char
forall a. (Integral a, Bits a) => a -> Int -> Char
nibbleToHex Word8
b5 Int
0 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Word8 -> Int -> Char
forall a. (Integral a, Bits a) => a -> Int -> Char
nibbleToHex Word8
b6 Int
4 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Word8 -> Int -> Char
forall a. (Integral a, Bits a) => a -> Int -> Char
nibbleToHex Word8
b6 Int
0 Char -> String -> String
forall a. a -> [a] -> [a]
:
    []
  where
    nibbleToHex :: a -> Int -> Char
nibbleToHex a
w = Word8 -> Char
unsafeToDigit (Word8 -> Char) -> (Int -> Word8) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Word8) -> (Int -> a) -> Int -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a
forall a. Bits a => a -> a -> a
(.&.) a
0x0f (a -> a) -> (Int -> a) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int -> a
forall a. Bits a => a -> Int -> a
shiftR a
w

toHexReversed64 :: Word64 -> [Char]
toHexReversed64 :: Word64 -> String
toHexReversed64 Word64
w =
    Int -> Char
nibbleToHex Int
00 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
04 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
08 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
12 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
16 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
20 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
24 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
28 Char -> String -> String
forall a. a -> [a] -> [a]
: -- Word32
    Int -> Char
nibbleToHex Int
32 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
36 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
40 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
44 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
48 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
52 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
56 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
60 Char -> String -> String
forall a. a -> [a] -> [a]
:
    []
  where
    nibbleToHex :: Int -> Char
nibbleToHex = Word8 -> Char
unsafeToDigit (Word8 -> Char) -> (Int -> Word8) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> (Int -> Word64) -> Int -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
(.&.) Word64
0x0f (Word64 -> Word64) -> (Int -> Word64) -> Int -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftR Word64
w

toHexNormal64 :: Word64 -> [Char]
toHexNormal64 :: Word64 -> String
toHexNormal64 Word64
w =
    Int -> Char
nibbleToHex Int
60 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
56 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
52 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
48 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
44 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
40 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
36 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
32 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
28 Char -> String -> String
forall a. a -> [a] -> [a]
: -- Word32
    Int -> Char
nibbleToHex Int
24 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
20 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
16 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
12 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
08 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
04 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
00 Char -> String -> String
forall a. a -> [a] -> [a]
:
    []
  where
    nibbleToHex :: Int -> Char
nibbleToHex = Word8 -> Char
unsafeToDigit (Word8 -> Char) -> (Int -> Word8) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> (Int -> Word64) -> Int -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
(.&.) Word64
0x0f (Word64 -> Word64) -> (Int -> Word64) -> Int -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftR Word64
w

--
-- Convert a 32-bit word to eight characters, but reversed so the least
-- significant bits are first.
--
toHexReversed32 :: Word32 -> [Char]
toHexReversed32 :: Word32 -> String
toHexReversed32 Word32
w =
    Int -> Char
nibbleToHex Int
00 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
04 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
08 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
12 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
16 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
20 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
24 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
28 Char -> String -> String
forall a. a -> [a] -> [a]
:
    []
  where
    nibbleToHex :: Int -> Char
nibbleToHex = Word8 -> Char
unsafeToDigit (Word8 -> Char) -> (Int -> Word8) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> (Int -> Word32) -> Int -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
(.&.) Word32
0x0f (Word32 -> Word32) -> (Int -> Word32) -> Int -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
w

toHexNormal32 :: Word32 -> [Char]
toHexNormal32 :: Word32 -> String
toHexNormal32 Word32
w =
    Int -> Char
nibbleToHex Int
28 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
24 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
20 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
16 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
12 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
08 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
04 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
00 Char -> String -> String
forall a. a -> [a] -> [a]
:
    []
  where
    nibbleToHex :: Int -> Char
nibbleToHex = Word8 -> Char
unsafeToDigit (Word8 -> Char) -> (Int -> Word8) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> (Int -> Word32) -> Int -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
(.&.) Word32
0x0f (Word32 -> Word32) -> (Int -> Word32) -> Int -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
w

toHexNormal16 :: Word16 -> [Char]
toHexNormal16 :: Word16 -> String
toHexNormal16 Word16
w =
    Int -> Char
nibbleToHex Int
12 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
08 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
04 Char -> String -> String
forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
00 Char -> String -> String
forall a. a -> [a] -> [a]
:
    []
  where
    nibbleToHex :: Int -> Char
nibbleToHex = Word8 -> Char
unsafeToDigit (Word8 -> Char) -> (Int -> Word8) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word8) -> (Int -> Word16) -> Int -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
(.&.) Word16
0x0f (Word16 -> Word16) -> (Int -> Word16) -> Int -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftR Word16
w

{-
byteToHex :: Word8 -> [Char]
byteToHex c =
    let !low = unsafeToDigit (c .&. 0x0f)
        !hi = unsafeToDigit ((c .&. 0xf0) `shiftR` 4)
     in hi : low : []
-}

-- convert a nibble to its hexidecimal character equivalent
unsafeToDigit :: Word8 -> Char
unsafeToDigit :: Word8 -> Char
unsafeToDigit Word8
w =
    if Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
10
        then Word8 -> Char
unsafeChr8 (Word8
48 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
w)
        else Word8 -> Char
unsafeChr8 (Word8
97 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
10)

{- |
Generate an identifier for a span. We only have 8 bytes to work with. We use
the nanosecond prescision timestamp with the nibbles reversed, and then
overwrite the last two bytes with the supplied random value.

@since 0.1.9
-}
createIdentifierSpan :: TimeStamp -> Word16 -> Span
createIdentifierSpan :: TimeStamp -> Word16 -> Span
createIdentifierSpan TimeStamp
time Word16
rand =
    let t :: Word64
t = Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeStamp -> Int64
unTimeStamp TimeStamp
time) :: Word64
        r :: Word64
r = Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
rand :: Word64
        w :: Word64
w = (Word64
t Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x0000ffffffffffff) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL Word64
r Int
48)
     in Rope -> Span
Span
            ( String -> Rope
packRope
                ( Word64 -> String
toHexReversed64 Word64
w
                )
            )

{- |
Render the 'Trace' and 'Span' identifiers representing a span calling onward
to another component in a distributed system. The W3C Trace Context
recommendation specifies the HTTP header @traceparent@ with a version sequence
(currently hard coded at @00@), the 16 byte trace identifier, the 8 byte span
identifier, and a flag sequence (currently quite ignored), all formatted as
follows:

@ traceparent: 00-fd533dbf96ecdc610156482ae36c24f7-1d1e9dbf96ec4649-00 @

@since 0.1.9
-}
createTraceParentHeader :: Trace -> Span -> Rope
createTraceParentHeader :: Trace -> Span -> Rope
createTraceParentHeader Trace
trace Span
unique =
    let version :: Rope
version = Rope
"00"
        flags :: Rope
flags = Rope
"00"
     in Rope
version Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
"-" Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Trace -> Rope
unTrace Trace
trace Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
"-" Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Span -> Rope
unSpan Span
unique Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
"-" Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
flags

{- |
Parse a @traceparent@ header into a 'Trace' and 'Span', assuming it was a
valid pair according to the W3C Trace Context recommendation. The expectation
is that, if present in an HTTP request, these values would be passed to
'Core.Telemetry.Observability.usingTrace' to allow the program to contribute
spans to an existing trace started by another program or service.

@since 0.1.10
-}
parseTraceParentHeader :: Rope -> Maybe (Trace, Span)
parseTraceParentHeader :: Rope -> Maybe (Trace, Span)
parseTraceParentHeader Rope
header =
    let pieces :: [Rope]
pieces = (Char -> Bool) -> Rope -> [Rope]
breakPieces (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') Rope
header
     in case [Rope]
pieces of
            (Rope
"00" : Rope
trace : Rope
unique : Rope
_ : []) -> (Trace, Span) -> Maybe (Trace, Span)
forall a. a -> Maybe a
Just (Rope -> Trace
Trace Rope
trace, Rope -> Span
Span Rope
unique)
            [Rope]
_ -> Maybe (Trace, Span)
forall a. Maybe a
Nothing

{- |
Get the identifier of the current trace, if you are within a trace started by
'Core.Telemetry.Observability.beginTrace' or
'Core.Telemetry.Observability.usingTrace'.

@since 0.1.9
-}
getIdentifierTrace :: Program τ (Maybe Trace)
getIdentifierTrace :: Program τ (Maybe Trace)
getIdentifierTrace = do
    Context τ
context <- Program τ (Context τ)
forall τ. Program τ (Context τ)
getContext

    IO (Maybe Trace) -> Program τ (Maybe Trace)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Trace) -> Program τ (Maybe Trace))
-> IO (Maybe Trace) -> Program τ (Maybe Trace)
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

        Maybe Trace -> IO (Maybe Trace)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Datum -> Maybe Trace
traceIdentifierFrom Datum
datum)

{- |
Get the identifier of the current span, if you are currently within a span
created by 'Core.Telemetry.Observability.encloseSpan'.

@since 0.1.9
-}
getIdentifierSpan :: Program τ (Maybe Span)
getIdentifierSpan :: Program τ (Maybe Span)
getIdentifierSpan = do
    Context τ
context <- Program τ (Context τ)
forall τ. Program τ (Context τ)
getContext

    IO (Maybe Span) -> Program τ (Maybe Span)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Span) -> Program τ (Maybe Span))
-> IO (Maybe Span) -> Program τ (Maybe Span)
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

        Maybe Span -> IO (Maybe Span)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Datum -> Maybe Span
spanIdentifierFrom Datum
datum)

{- |
Override the identifier of the current span, if you are currently within a
span created by 'Core.Telemetry.Observability.encloseSpan'. This is an unsafe
action, specifically and only for the situation where you need create a parent
span for an asynchronous process whose unique identifier has already been
nominated. In this scenario all child spans would already have been created
with this span identifier as their parent, leaving you with the final task of
creating a "root" span within the trace with that parent identifier.

@since 0.2.1
-}
setIdentifierSpan :: Span -> Program t ()
setIdentifierSpan :: Span -> Program t ()
setIdentifierSpan Span
unique = do
    Context t
context <- Program t (Context t)
forall τ. Program τ (Context τ)
getContext

    Rope -> Program t ()
forall τ. Rope -> Program τ ()
internal (Rope
"span = " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Span -> Rope
unSpan Span
unique)

    IO () -> Program t ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program t ()) -> IO () -> Program t ()
forall a b. (a -> b) -> a -> b
$ do
        -- get the map out
        let v :: MVar Datum
v = Context t -> MVar Datum
forall τ. Context τ -> MVar Datum
currentDatumFrom Context t
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:spanIdentifierFrom:Datum :: Maybe Span
spanIdentifierFrom = Span -> Maybe Span
forall a. a -> Maybe a
Just Span
unique})