{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Telemetry.Identifiers (
getIdentifierTrace,
getIdentifierSpan,
createIdentifierTrace,
createIdentifierSpan,
hostMachineIdentity,
createTraceParentHeader,
toHexNormal64,
toHexReversed64,
toHexNormal32,
toHexReversed32,
) where
import Control.Concurrent.MVar (readMVar)
import Core.Program.Context
import Core.System (unsafePerformIO)
import Core.System.Base (liftIO)
import Core.System.External (TimeStamp (unTimeStamp))
import Core.Text.Rope
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 = 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 #-}
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]
:
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]
:
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
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
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)
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
)
)
createTraceParentHeader :: Trace -> Span -> Rope
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
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)
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)