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

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.Lazy as LBS
import Data.Char
import Data.Hashable
import Data.Unique
import Data.Word (Word64, Word8)
import Debug.Trace.Binary
import OpenTelemetry.SpanContext
import OpenTelemetry.Metrics_Internal
import Prelude hiding (span)
import Data.Int

-- 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
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
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, Eq SpanInFlight
Int -> SpanInFlight -> Int
SpanInFlight -> Int
forall a. Eq 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
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 -> ((# #) -> r) -> ((# #) -> r) -> r
BEGIN_SPAN = MsgType 1
pattern $bEND_SPAN :: MsgType
$mEND_SPAN :: forall {r}. MsgType -> ((# #) -> r) -> ((# #) -> r) -> r
END_SPAN = MsgType 2
pattern $bTAG :: MsgType
$mTAG :: forall {r}. MsgType -> ((# #) -> r) -> ((# #) -> r) -> r
TAG = MsgType 3
pattern $bEVENT :: MsgType
$mEVENT :: forall {r}. MsgType -> ((# #) -> r) -> ((# #) -> r) -> r
EVENT = MsgType 4
pattern $bSET_PARENT_CONTEXT :: MsgType
$mSET_PARENT_CONTEXT :: forall {r}. MsgType -> ((# #) -> r) -> ((# #) -> r) -> r
SET_PARENT_CONTEXT = MsgType 5
pattern $bSET_TRACE_ID :: MsgType
$mSET_TRACE_ID :: forall {r}. MsgType -> ((# #) -> r) -> ((# #) -> r) -> r
SET_TRACE_ID = MsgType 6
pattern $bSET_SPAN_ID :: MsgType
$mSET_SPAN_ID :: forall {r}. MsgType -> ((# #) -> r) -> ((# #) -> r) -> r
SET_SPAN_ID = MsgType 7
pattern $bDECLARE_INSTRUMENT :: MsgType
$mDECLARE_INSTRUMENT :: forall {r}. MsgType -> ((# #) -> r) -> ((# #) -> r) -> r
DECLARE_INSTRUMENT = MsgType 8
pattern $bMETRIC_CAPTURE :: MsgType
$mMETRIC_CAPTURE :: forall {r}. MsgType -> ((# #) -> r) -> ((# #) -> r) -> r
METRIC_CAPTURE = MsgType 9

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

{-# INLINE otelMagic #-}
otelMagic :: Int
otelMagic :: Int
otelMagic = Int
v forall a. Bits a => a -> a -> a
.|. Int
t forall a. Bits a => a -> a -> a
.|. Int
o
  where
    !v :: Int
v = forall a. Bits a => a -> Int -> a
shift Int
3 Int
16
    !t :: Int
t = 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 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h
  where
    !h :: Int
h = Int
m forall a. Bits a => a -> a -> a
.|. Int
otelMagic
    !m :: Int
m = forall a. Bits a => a -> Int -> a
shift ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
msgType) :: Int) forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> Int -> a
shift Int
3 Int
3

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

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

{-# INLINE nextLocalSpan #-}
nextLocalSpan :: MonadIO m => m SpanInFlight
nextLocalSpan :: forall (m :: * -> *). MonadIO m => m SpanInFlight
nextLocalSpan = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (Word64 -> SpanInFlight
SpanInFlight 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
. Unique -> Int
hashUnique) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique

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

{-# 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 forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
u 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 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
k
      vlen :: Word32
vlen = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
v
   in MsgType -> Builder
header MsgType
msg forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
u forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
word32LE Word32
klen forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
word32LE Word32
vlen forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
k 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 forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
u forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
sid 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 forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
u 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 forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
u forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64LE Word64
sid

{-# INLINE builder_declareInstrument #-}
builder_declareInstrument :: Instrument s a m -> Builder
builder_declareInstrument :: forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> Builder
builder_declareInstrument Instrument s a m
instrument =
  MsgType -> Builder
header MsgType
DECLARE_INSTRUMENT forall a. Semigroup a => a -> a -> a
<>
  Int8 -> Builder
int8 (forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> Int8
instrumentTag Instrument s a m
instrument) forall a. Semigroup a => a -> a -> a
<>
  Word64 -> Builder
word64LE (forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
Instrument s a m -> Word64
instrumentId Instrument s a m
instrument) forall a. Semigroup a => a -> a -> a
<>
  ByteString -> Builder
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 forall a. Semigroup a => a -> a -> a
<>
  Word64 -> Builder
word64LE Word64
iId forall a. Semigroup a => a -> a -> a
<>
  Int64 -> Builder
int64LE (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)

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

{-# INLINE instrumentTag #-}
instrumentTag :: Instrument s a m -> Int8
instrumentTag :: forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
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 :: forall (s :: Synchronicity) (a :: Additivity) (m :: Monotonicity).
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"