Source file span.ml

open Common_
open Proto.Trace

type t = span

type id = Span_id.t

type kind = Span_kind.t =
  | Span_kind_unspecified
  | Span_kind_internal
  | Span_kind_server
  | Span_kind_client
  | Span_kind_producer
  | Span_kind_consumer

type key_value =
  string
  * [ `Int of int
    | `String of string
    | `Bool of bool
    | `Float of float
    | `None
    ]

let[@inline] id self = Span_id.of_bytes self.span_id

let[@inline] trace_id self = Trace_id.of_bytes self.trace_id

let[@inline] is_not_dummy self = Span_id.is_valid (id self)

(* spans built without flags (e.g. directly through [Proto]) get the default *)
let[@inline] trace_flags self : Trace_flags.t =
  if span_has_flags self then
    Trace_flags.of_int32 self.flags
  else
    Trace_flags.default

let[@inline] sampled self = Trace_flags.is_sampled (trace_flags self)

let[@inline] is_recording self = is_not_dummy self && sampled self

let pp = Proto.Trace.pp_span

let default_kind = ref Proto.Trace.Span_kind_unspecified

let make ?(kind = !default_kind) ?(trace_flags = Trace_flags.default)
    ?trace_state ?(attrs = []) ?(events = []) ?status ~trace_id ~id ?parent
    ?(links = []) ~start_time ~end_time name : t =
  let trace_id = Trace_id.to_bytes trace_id in
  let parent_span_id = Option.map Span_id.to_bytes parent in
  let attributes = List.map Key_value.conv attrs in
  let flags = Trace_flags.to_int32 trace_flags in
  let span =
    make_span ~trace_id ?parent_span_id ~span_id:(Span_id.to_bytes id) ~flags
      ~attributes ~events ?trace_state ?status ~kind ~name ~links
      ~start_time_unix_nano:start_time ~end_time_unix_nano:end_time ()
  in
  span

let dummy : t =
  Proto.Trace.make_span
    ~trace_id:Trace_id.(dummy |> to_bytes)
    ~span_id:Span_id.(dummy |> to_bytes)
    ()

let create_new ?kind ?trace_flags ?(id = Span_id.create ()) ?trace_state ?attrs
    ?events ?status ~trace_id ?parent ?links ~start_time ~end_time name : t =
  make ?kind ?trace_flags ~id ~trace_id ?trace_state ?attrs ?events ?status
    ?parent ?links ~start_time ~end_time name

let attrs self = self.attributes |> List.rev_map Key_value.of_otel

let events self = self.events

let links self : Span_link.t list = self.links

let status self = self.status

let kind self =
  let k = self.kind in
  if k = Span_kind_unspecified then
    None
  else
    Some k

let to_span_link (self : t) : Span_link.t =
  make_span_link ~attributes:self.attributes
    ?flags:
      (if span_has_flags self then
         Some self.flags
       else
         None)
    ?dropped_attributes_count:
      (if span_has_dropped_attributes_count self then
         Some self.dropped_attributes_count
       else
         None)
    ?trace_state:
      (if span_has_trace_state self then
         Some self.trace_state
       else
         None)
    ~trace_id:self.trace_id ~span_id:self.span_id ()

let[@inline] to_span_ctx (self : t) : Span_ctx.t =
  Span_ctx.make ~trace_flags:(trace_flags self) ~trace_state:self.trace_state
    ~trace_id:(trace_id self) ~parent_id:(id self) ()

(* Note: a span must not be concurrently modified from multiple
   threads or domains. *)
let[@inline] add_event self ev : unit =
  if is_recording self then span_set_events self (ev :: self.events)

let add_event' self ev : unit =
  if is_recording self then span_set_events self (ev () :: self.events)

let record_exception (self : t) (exn : exn) (bt : Printexc.raw_backtrace) : unit
    =
  if is_recording self then (
    let exn_msg = Printexc.to_string exn in
    let ev =
      Event.make "exception"
        ~attrs:
          [
            "exception.message", `String exn_msg;
            "exception.type", `String (Printexc.exn_slot_name exn);
            ( "exception.stacktrace",
              `String (Printexc.raw_backtrace_to_string bt) );
          ]
    in
    add_event self ev;

    let status = make_status ~code:Status_code_error ~message:exn_msg () in
    span_set_status self status
  )

let add_attrs (self : t) (attrs : Key_value.t list) : unit =
  if is_recording self then (
    let attrs = List.rev_map Key_value.conv attrs in
    let attrs = List.rev_append attrs self.attributes in
    span_set_attributes self attrs
  )

let add_attrs' (self : t) (attrs : unit -> Key_value.t list) : unit =
  if is_recording self then (
    let attrs = List.rev_map Key_value.conv (attrs ()) in
    let attrs = List.rev_append attrs self.attributes in
    span_set_attributes self attrs
  )

let add_links (self : t) (links : Span_link.t list) : unit =
  if is_recording self && links <> [] then (
    let links = List.rev_append links self.links in
    span_set_links self links
  )

let add_links' (self : t) (links : unit -> Span_link.t list) : unit =
  if is_recording self then (
    let links = List.rev_append (links ()) self.links in
    span_set_links self links
  )

let set_status self st = if is_recording self then span_set_status self st

let set_kind self k = if is_recording self then span_set_kind self k

let k_ambient : t Context.key = Context.new_key ()