{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Telemetry.Identifiers
(
getIdentifierTrace
, getIdentifierSpan
, setIdentifierSpan
, createIdentifierTrace
, createIdentifierSpan
, hostMachineIdentity
, createTraceParentHeader
, parseTraceParentHeader
, 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)
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 #-}
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]
: 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]
: 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
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
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)
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
)
)
createTraceParentHeader :: Trace -> Span -> Rope
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
parseTraceParentHeader :: Rope -> Maybe (Trace, Span)
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
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)
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)
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
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})