{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}

module OpenTelemetry.Eventlog_Internal where

import Control.Monad.IO.Class
import Data.Bits
import qualified Data.ByteString as BS
import Data.ByteString.Builder
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
import Data.Char
import Data.Hashable
#if __GLASGOW_HASKELL__ < 808
import Debug.Trace.ByteString
#else
import Debug.Trace.Binary
#endif

import Data.Int
import Data.Unique
import Data.Word (Word64, Word8)
import OpenTelemetry.Metrics_Internal as MI
import OpenTelemetry.SpanContext
import Text.Printf
import Prelude hiding (span)

-- This is not a Span Id in terms of OpenTelemetry.
-- It's unique only in scope of one process, not globally.
type ProcessLocalSpanSerialNumber = Word64

newtype SpanInFlight = SpanInFlight ProcessLocalSpanSerialNumber
  deriving (Int -> SpanInFlight -> ShowS
[SpanInFlight] -> ShowS
SpanInFlight -> String
(Int -> SpanInFlight -> ShowS)
-> (SpanInFlight -> String)
-> ([SpanInFlight] -> ShowS)
-> Show SpanInFlight
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpanInFlight] -> ShowS
$cshowList :: [SpanInFlight] -> ShowS
show :: SpanInFlight -> String
$cshow :: SpanInFlight -> String
showsPrec :: Int -> SpanInFlight -> ShowS
$cshowsPrec :: Int -> SpanInFlight -> ShowS
Show, SpanInFlight -> SpanInFlight -> Bool
(SpanInFlight -> SpanInFlight -> Bool)
-> (SpanInFlight -> SpanInFlight -> Bool) -> Eq SpanInFlight
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpanInFlight -> SpanInFlight -> Bool
$c/= :: SpanInFlight -> SpanInFlight -> Bool
== :: SpanInFlight -> SpanInFlight -> Bool
$c== :: SpanInFlight -> SpanInFlight -> Bool
Eq, Int -> SpanInFlight -> Int
SpanInFlight -> Int
(Int -> SpanInFlight -> Int)
-> (SpanInFlight -> Int) -> Hashable SpanInFlight
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: SpanInFlight -> Int
$chash :: SpanInFlight -> Int
hashWithSalt :: Int -> SpanInFlight -> Int
$chashWithSalt :: Int -> SpanInFlight -> Int
Hashable)

newtype MsgType = MsgType Word8
  deriving (Int -> MsgType -> ShowS
[MsgType] -> ShowS
MsgType -> String
(Int -> MsgType -> ShowS)
-> (MsgType -> String) -> ([MsgType] -> ShowS) -> Show MsgType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MsgType] -> ShowS
$cshowList :: [MsgType] -> ShowS
show :: MsgType -> String
$cshow :: MsgType -> String
showsPrec :: Int -> MsgType -> ShowS
$cshowsPrec :: Int -> MsgType -> ShowS
Show)

pattern BEGIN_SPAN, END_SPAN, TAG, EVENT, SET_PARENT_CONTEXT, SET_TRACE_ID, SET_SPAN_ID, DECLARE_INSTRUMENT, METRIC_CAPTURE :: MsgType
pattern $bBEGIN_SPAN :: MsgType
$mBEGIN_SPAN :: forall r. MsgType -> (Void# -> r) -> (Void# -> r) -> r
BEGIN_SPAN = MsgType 1
pattern $bEND_SPAN :: MsgType
$mEND_SPAN :: forall r. MsgType -> (Void# -> r) -> (Void# -> r) -> r
END_SPAN = MsgType 2
pattern $bTAG :: MsgType
$mTAG :: forall r. MsgType -> (Void# -> r) -> (Void# -> r) -> r
TAG = MsgType 3
pattern $bEVENT :: MsgType
$mEVENT :: forall r. MsgType -> (Void# -> r) -> (Void# -> r) -> r
EVENT = MsgType 4
pattern $bSET_PARENT_CONTEXT :: MsgType
$mSET_PARENT_CONTEXT :: forall r. MsgType -> (Void# -> r) -> (Void# -> r) -> r
SET_PARENT_CONTEXT = MsgType 5
pattern $bSET_TRACE_ID :: MsgType
$mSET_TRACE_ID :: forall r. MsgType -> (Void# -> r) -> (Void# -> r) -> r
SET_TRACE_ID = MsgType 6
pattern $bSET_SPAN_ID :: MsgType
$mSET_SPAN_ID :: forall r. MsgType -> (Void# -> r) -> (Void# -> r) -> r
SET_SPAN_ID = MsgType 7
pattern $bDECLARE_INSTRUMENT :: MsgType
$mDECLARE_INSTRUMENT :: forall r. MsgType -> (Void# -> r) -> (Void# -> r) -> r
DECLARE_INSTRUMENT = MsgType 8
pattern $bMETRIC_CAPTURE :: MsgType
$mMETRIC_CAPTURE :: forall r. MsgType -> (Void# -> r) -> (Void# -> r) -> r
METRIC_CAPTURE = MsgType 9

{-# INLINE maxMsgLen #-}
maxMsgLen :: Int
maxMsgLen :: Int
maxMsgLen = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shift Int
2 Int
16

{-# INLINE otelMagic #-}
otelMagic :: Int
otelMagic :: Int
otelMagic = Int
v Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
t Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o
  where
    !v :: Int
v = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shift Int
3 Int
16
    !t :: Int
t = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shift (Char -> Int
ord Char
'T') Int
8
    !o :: Int
o = Char -> Int
ord Char
'O'

{-# INLINE header #-}
header :: MsgType -> Builder
header :: MsgType -> Builder
header (MsgType Word8
msgType) = Word32 -> Builder
word32LE (Word32 -> Builder) -> Word32 -> Builder
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h
  where
    !h :: Int
h = Int
m Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
otelMagic
    !m :: Int
m = Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shift ((Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
msgType) :: Int) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shift Int
3 Int
3

headerSize :: Int
headerSize :: Int
headerSize = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (MsgType -> Builder
header MsgType
TAG Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
0)

{-# INLINE checkSize #-}
checkSize :: Int -> m -> m
checkSize :: Int -> m -> m
checkSize Int
s m
next = do
  let !exceed :: Int
exceed = Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
headerSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
maxMsgLen
  if Int
exceed Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    then String -> m
forall a. HasCallStack => String -> a
error (String -> m) -> String -> m
forall a b. (a -> b) -> a -> b
$ String
"eventlog message size exceed 64k by " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
exceed
    else m
next

{-# INLINE nextLocalSpan #-}
nextLocalSpan :: MonadIO m => m SpanInFlight
nextLocalSpan :: m SpanInFlight
nextLocalSpan = IO SpanInFlight -> m SpanInFlight
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SpanInFlight -> m SpanInFlight)
-> IO SpanInFlight -> m SpanInFlight
forall a b. (a -> b) -> a -> b
$ (Word64 -> SpanInFlight
SpanInFlight (Word64 -> SpanInFlight)
-> (Unique -> Word64) -> Unique -> SpanInFlight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> (Unique -> Int) -> Unique -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
hashUnique) (Unique -> SpanInFlight) -> IO Unique -> IO SpanInFlight
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique

{-# INLINE nextInstrumentId #-}
nextInstrumentId :: MonadIO m => m InstrumentId
nextInstrumentId :: m Word64
nextInstrumentId = IO Word64 -> m Word64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Word64 -> m Word64) -> IO Word64 -> m Word64
forall a b. (a -> b) -> a -> b
$ (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> (Unique -> Int) -> Unique -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
hashUnique) (Unique -> Word64) -> IO Unique -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique

-- These functions all depend on the binary eventlog to be useful.
#if __GLASGOW_HASKELL__ >= 808
{-# INLINE builder_beginSpan #-}
builder_beginSpan :: SpanInFlight -> BS.ByteString -> Builder
builder_beginSpan :: SpanInFlight -> ByteString -> Builder
builder_beginSpan (SpanInFlight Word64
u) ByteString
operation =
  MsgType -> Builder
header MsgType
BEGIN_SPAN Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
u Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
operation

{-# INLINE builder_endSpan #-}
builder_endSpan :: SpanInFlight -> Builder
builder_endSpan :: SpanInFlight -> Builder
builder_endSpan (SpanInFlight Word64
u) = MsgType -> Builder
header MsgType
END_SPAN Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
u

{-# INLINE builder_key_value #-}
builder_key_value :: MsgType -> SpanInFlight -> BS.ByteString -> BS.ByteString -> Builder
builder_key_value :: MsgType -> SpanInFlight -> ByteString -> ByteString -> Builder
builder_key_value MsgType
msg (SpanInFlight Word64
u) ByteString
k ByteString
v =
  let klen :: Word32
klen = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
k
      vlen :: Word32
vlen = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
v
   in MsgType -> Builder
header MsgType
msg Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
u Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
word32LE Word32
klen Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
word32LE Word32
vlen Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
k Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
v

{-# INLINE builder_setTag #-}
builder_setTag :: SpanInFlight -> BS.ByteString -> BS.ByteString -> Builder
builder_setTag :: SpanInFlight -> ByteString -> ByteString -> Builder
builder_setTag = MsgType -> SpanInFlight -> ByteString -> ByteString -> Builder
builder_key_value MsgType
TAG

{-# INLINE builder_addEvent #-}
builder_addEvent :: SpanInFlight -> BS.ByteString -> BS.ByteString -> Builder
builder_addEvent :: SpanInFlight -> ByteString -> ByteString -> Builder
builder_addEvent = MsgType -> SpanInFlight -> ByteString -> ByteString -> Builder
builder_key_value MsgType
EVENT

{-# INLINE builder_setParentSpanContext #-}
builder_setParentSpanContext :: SpanInFlight -> SpanContext -> Builder
builder_setParentSpanContext :: SpanInFlight -> SpanContext -> Builder
builder_setParentSpanContext (SpanInFlight Word64
u) (SpanContext (SId Word64
sid) (TId Word64
tid)) =
  MsgType -> Builder
header MsgType
SET_PARENT_CONTEXT Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
u Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
sid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
tid

{-# INLINE builder_setTraceId #-}
builder_setTraceId :: SpanInFlight -> TraceId -> Builder
builder_setTraceId :: SpanInFlight -> TraceId -> Builder
builder_setTraceId (SpanInFlight Word64
u) (TId Word64
tid) = MsgType -> Builder
header MsgType
SET_TRACE_ID Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
u Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
tid

{-# INLINE builder_setSpanId #-}
builder_setSpanId :: SpanInFlight -> SpanId -> Builder
builder_setSpanId :: SpanInFlight -> SpanId -> Builder
builder_setSpanId (SpanInFlight Word64
u) (SId Word64
sid) = MsgType -> Builder
header MsgType
SET_SPAN_ID Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
u Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
sid

{-# INLINE builder_declareInstrument #-}
builder_declareInstrument :: Instrument s a m -> Builder
builder_declareInstrument :: Instrument s a m -> Builder
builder_declareInstrument Instrument s a m
instrument =
  MsgType -> Builder
header MsgType
DECLARE_INSTRUMENT Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Int8 -> Builder
int8 (Instrument s a m -> Int8
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> Int8
instrumentTag Instrument s a m
instrument) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Word64 -> Builder
word64LE (Instrument s a m -> Word64
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> Word64
instrumentId Instrument s a m
instrument) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  ByteString -> Builder
byteString (Instrument s a m -> ByteString
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> ByteString
instrumentName Instrument s a m
instrument)

{-# INLINE builder_captureMetric #-}
builder_captureMetric :: InstrumentId -> Int -> Builder
builder_captureMetric :: Word64 -> Int -> Builder
builder_captureMetric Word64
iId Int
v =
  MsgType -> Builder
header MsgType
METRIC_CAPTURE Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Word64 -> Builder
word64LE Word64
iId Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Int64 -> Builder
int64LE (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)

{-# INLINE traceBuilder #-}
traceBuilder :: MonadIO m => Builder -> m ()
traceBuilder :: Builder -> m ()
traceBuilder = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Builder -> IO ()) -> Builder -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
traceBinaryEventIO (ByteString -> IO ())
-> (Builder -> ByteString) -> Builder -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString
#endif

-- For use with human-readable eventlog

beginSpan' :: SpanInFlight -> String -> String
beginSpan' :: SpanInFlight -> ShowS
beginSpan' (SpanInFlight Word64
u64) String
operation =
  String -> Word64 -> ShowS
forall r. PrintfType r => String -> r
printf String
"ot2 begin span %d %s" Word64
u64 String
operation

endSpan' :: SpanInFlight -> String
endSpan' :: SpanInFlight -> String
endSpan' (SpanInFlight Word64
u64) = String -> Word64 -> String
forall r. PrintfType r => String -> r
printf String
"ot2 end span %d" Word64
u64

setTag' :: SpanInFlight -> String -> BS8.ByteString -> String
setTag' :: SpanInFlight -> String -> ByteString -> String
setTag' (SpanInFlight Word64
u64) String
k ByteString
v =
  String -> Word64 -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"ot2 set tag %d %s %s" Word64
u64 String
k (ByteString -> String
BS8.unpack ByteString
v)

addEvent' :: SpanInFlight -> String -> BS8.ByteString -> String
addEvent' :: SpanInFlight -> String -> ByteString -> String
addEvent' (SpanInFlight Word64
u64) String
k ByteString
v =
  String -> Word64 -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"ot2 add event %d %s %s" Word64
u64 String
k (ByteString -> String
BS8.unpack ByteString
v)

setParentSpanContext' :: SpanInFlight -> SpanContext -> String
setParentSpanContext' :: SpanInFlight -> SpanContext -> String
setParentSpanContext' (SpanInFlight Word64
u64) (SpanContext (SId Word64
sid) (TId Word64
tid)) =
  (String -> Word64 -> Word64 -> Word64 -> String
forall r. PrintfType r => String -> r
printf String
"ot2 set parent %d %016x %016x" Word64
u64 Word64
tid Word64
sid)

setTraceId' :: SpanInFlight -> TraceId -> String
setTraceId' :: SpanInFlight -> TraceId -> String
setTraceId' (SpanInFlight Word64
u64) (TId Word64
tid) =
  String -> Word64 -> Word64 -> String
forall r. PrintfType r => String -> r
printf String
"ot2 set traceid %d %016x" Word64
u64 Word64
tid

setSpanId' :: SpanInFlight -> SpanId -> String
setSpanId' :: SpanInFlight -> SpanId -> String
setSpanId' (SpanInFlight Word64
u64) (SId Word64
sid) =
  String -> Word64 -> Word64 -> String
forall r. PrintfType r => String -> r
printf String
"ot2 set spanid %d %016x" Word64
u64 Word64
sid

createInstrument' :: MI.Instrument s a m -> String
createInstrument' :: Instrument s a m -> String
createInstrument' Instrument s a m
i = String -> String -> Word64 -> ShowS
forall r. PrintfType r => String -> r
printf String
"ot2 metric create %s %016x %s" (Instrument s a m -> String
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> String
instrumentTagStr Instrument s a m
i) (Instrument s a m -> Word64
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> Word64
instrumentId Instrument s a m
i) (ByteString -> String
BS8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Instrument s a m -> ByteString
forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> ByteString
instrumentName Instrument s a m
i)

writeMetric' :: InstrumentId -> Int -> String
writeMetric' :: Word64 -> Int -> String
writeMetric' Word64
iid Int
v = String -> Word64 -> ShowS
forall r. PrintfType r => String -> r
printf String
"ot2 metric capture %016x %s" Word64
iid (Int -> String
forall a. Show a => a -> String
show Int
v)

{-# INLINE instrumentTag #-}
instrumentTag :: Instrument s a m -> Int8
instrumentTag :: Instrument s a m -> Int8
instrumentTag Counter {} = Int8
1
instrumentTag UpDownCounter {} = Int8
2
instrumentTag ValueRecorder {} = Int8
3
instrumentTag SumObserver {} = Int8
4
instrumentTag UpDownSumObserver {} = Int8
5
instrumentTag ValueObserver {} = Int8
6

{-# INLINE instrumentTagStr #-}
instrumentTagStr :: Instrument s a m -> String
instrumentTagStr :: Instrument s a m -> String
instrumentTagStr Counter {} = String
"Counter"
instrumentTagStr UpDownCounter {} = String
"UpDownCounter"
instrumentTagStr ValueRecorder {} = String
"ValueRecorder"
instrumentTagStr SumObserver {} = String
"SumObserver"
instrumentTagStr UpDownSumObserver {} = String
"UpDownSumObserver"
instrumentTagStr ValueObserver {} = String
"ValueObserver"