{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# 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.Data.Clock
import Core.Program.Context
import Core.Program.Logging
import Core.System (unsafePerformIO)
import Core.System.Base (liftIO)
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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    [NetworkInterface]
interfaces <- IO [NetworkInterface]
getNetworkInterfaces
    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 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 :: Time -> Word16 -> MAC -> Trace
createIdentifierTrace :: Time -> Word16 -> MAC -> Trace
createIdentifierTrace Time
time Word16
rand MAC
address =
    let p1 :: Rope
p1 = String -> Rope
packRope (Word64 -> String
toHexReversed64 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Time -> Int64
unTime Time
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 forall a. Semigroup a => a -> a -> a
<> Rope
p2 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) =
    forall {b}. (Integral b, Bits b) => b -> Int -> Char
nibbleToHex Word8
b1 Int
4 forall a. a -> [a] -> [a]
:
    forall {b}. (Integral b, Bits b) => b -> Int -> Char
nibbleToHex Word8
b1 Int
0 forall a. a -> [a] -> [a]
:
    forall {b}. (Integral b, Bits b) => b -> Int -> Char
nibbleToHex Word8
b2 Int
4 forall a. a -> [a] -> [a]
:
    forall {b}. (Integral b, Bits b) => b -> Int -> Char
nibbleToHex Word8
b2 Int
0 forall a. a -> [a] -> [a]
:
    forall {b}. (Integral b, Bits b) => b -> Int -> Char
nibbleToHex Word8
b3 Int
4 forall a. a -> [a] -> [a]
:
    forall {b}. (Integral b, Bits b) => b -> Int -> Char
nibbleToHex Word8
b3 Int
0 forall a. a -> [a] -> [a]
:
    forall {b}. (Integral b, Bits b) => b -> Int -> Char
nibbleToHex Word8
b4 Int
4 forall a. a -> [a] -> [a]
:
    forall {b}. (Integral b, Bits b) => b -> Int -> Char
nibbleToHex Word8
b4 Int
0 forall a. a -> [a] -> [a]
:
    forall {b}. (Integral b, Bits b) => b -> Int -> Char
nibbleToHex Word8
b5 Int
4 forall a. a -> [a] -> [a]
:
    forall {b}. (Integral b, Bits b) => b -> Int -> Char
nibbleToHex Word8
b5 Int
0 forall a. a -> [a] -> [a]
:
    forall {b}. (Integral b, Bits b) => b -> Int -> Char
nibbleToHex Word8
b6 Int
4 forall a. a -> [a] -> [a]
:
    forall {b}. (Integral b, Bits b) => b -> Int -> Char
nibbleToHex Word8
b6 Int
0 forall a. a -> [a] -> [a]
:
    []
  where
    nibbleToHex :: b -> Int -> Char
nibbleToHex b
w = Word8 -> Char
unsafeToDigit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bits a => a -> a -> a
(.&.) b
0x0f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bits a => a -> Int -> a
shiftR b
w

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

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

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

toHexNormal16 :: Word16 -> [Char]
toHexNormal16 :: Word16 -> String
toHexNormal16 Word16
w =
    Int -> Char
nibbleToHex Int
12 forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
08 forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
04 forall a. a -> [a] -> [a]
:
    Int -> Char
nibbleToHex Int
00 forall a. a -> [a] -> [a]
:
    []
  where
    nibbleToHex :: Int -> Char
nibbleToHex = Word8 -> Char
unsafeToDigit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bits a => a -> a -> a
(.&.) Word16
0x0f forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Ord a => a -> a -> Bool
< Word8
10
        then Word8 -> Char
unsafeChr8 (Word8
48 forall a. Num a => a -> a -> a
+ Word8
w)
        else Word8 -> Char
unsafeChr8 (Word8
97 forall a. Num a => a -> a -> a
+ Word8
w 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 Time with the nibbles reversed, and then
overwrite the last two bytes with the supplied random value.

@since 0.1.9
-}
createIdentifierSpan :: Time -> Word16 -> Span
createIdentifierSpan :: Time -> Word16 -> Span
createIdentifierSpan Time
time Word16
rand =
    let t :: Word64
t = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Time -> Int64
unTime Time
time) :: Word64
        r :: Word64
r = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
rand :: Word64
        w :: Word64
w = (Word64
t forall a. Bits a => a -> a -> a
.&. Word64
0x0000ffffffffffff) forall a. Bits a => a -> a -> a
.|. (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 forall a. Semigroup a => a -> a -> a
<> Rope
"-" forall a. Semigroup a => a -> a -> a
<> Trace -> Rope
unTrace Trace
trace forall a. Semigroup a => a -> a -> a
<> Rope
"-" forall a. Semigroup a => a -> a -> a
<> Span -> Rope
unSpan Span
unique forall a. Semigroup a => a -> a -> a
<> 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 (forall a. Eq a => a -> a -> Bool
== Char
'-') Rope
header
     in case [Rope]
pieces of
            (Rope
"00" : Rope
trace : Rope
unique : Rope
_ : []) -> forall a. a -> Maybe a
Just (Rope -> Trace
Trace Rope
trace, Rope -> Span
Span Rope
unique)
            [Rope]
_ -> 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 :: forall τ. Program τ (Maybe Trace)
getIdentifierTrace = 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
        Datum
datum <- forall a. MVar a -> IO a
readMVar MVar Datum
v

        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 :: forall τ. Program τ (Maybe Span)
getIdentifierSpan = 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
        Datum
datum <- forall a. MVar a -> IO a
readMVar MVar Datum
v

        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 :: forall t. Span -> Program t ()
setIdentifierSpan Span
unique = do
    Context t
context <- forall τ. Program τ (Context τ)
getContext

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

    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 t
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:spanIdentifierFrom:Datum :: Maybe Span
spanIdentifierFrom = forall a. a -> Maybe a
Just Span
unique})