{-# 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.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 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
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 :: 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

{-# 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 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 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