ocaml-opentelemetry/src/trace/opentelemetry_trace.ml

module Otel = Opentelemetry
module TLS = Otel.Thread_local

type span = Trace.span

(** Table indexed by Trace spans *)
module Span_tbl = Hashtbl.Make (struct
  include Int64

  let hash : t -> int = Hashtbl.hash
end)

(** Per-thread set of active spans. *)
module Active_spans = struct
  type span_begin = {
    span_id: Otel.Span_id.t;
    start_time: int64;
    name: string;
    data: (string * Trace.user_data) list;
    __FILE__: string;
    __LINE__: int;
    new_scope: Otel.Scope.t;
    old_scope: Otel.Scope.t option;
  }
  (** Information we get at the beginning of the span *)

  type t = { tbl: span_begin Span_tbl.t } [@@unboxed]
  (** Storage for active spans *)

  let create () : t = { tbl = Span_tbl.create 8 }

  let tls : t TLS.t = TLS.create ()

  let[@inline] get () : t = TLS.get_or_create tls ~create
end

let conv_span_to_i64 (id : Otel.Span_id.t) : int64 =
  let bs = Otel.Span_id.to_bytes id in
  (* lucky that it coincides! *)
  assert (Bytes.length bs = 8);
  Bytes.get_int64_le bs 0

let span_of_i64 (id : int64) : Otel.Span_id.t =
  let bs = Bytes.create 8 in
  Bytes.set_int64_le bs 0 id;
  Otel.Span_id.of_bytes bs

let collector () : Trace.collector =
  let module M = struct
    let enter_span ?__FUNCTION__:_ ~__FILE__ ~__LINE__ ~data name : span =
      let span_id = Otel.Span_id.create () in
      let span = conv_span_to_i64 span_id in

      let start_time = Otel.Timestamp_ns.now_unix_ns () in

      let old_scope = Otel.Scope.get_surrounding () in
      let trace_id =
        match old_scope with
        | None -> Otel.Trace_id.create ()
        | Some sc -> sc.trace_id
      in

      let new_scope =
        { Otel.Scope.span_id; trace_id; events = []; attrs = [] }
      in
      TLS.set Otel.Scope._global_scope new_scope;

      let active_spans = Active_spans.get () in
      Span_tbl.add active_spans.tbl span
        {
          span_id;
          start_time;
          __FILE__;
          __LINE__;
          old_scope;
          new_scope;
          name;
          data;
        };

      span

    let exit_span (span : span) : unit =
      let active_spans = Active_spans.get () in
      match Span_tbl.find_opt active_spans.tbl span with
      | None -> () (* TODO: log warning *)
      | Some
          {
            span_id;
            start_time;
            name;
            __FILE__;
            __LINE__;
            new_scope;
            old_scope;
            data;
          } ->
        let end_time = Otel.Timestamp_ns.now_unix_ns () in

        (* restore previous scope *)
        (match old_scope with
        | None -> TLS.remove Otel.Scope._global_scope
        | Some sc -> TLS.set Otel.Scope._global_scope sc);

        let o_span : Otel.Span.t =
          let attrs =
            [ "file", `String __FILE__; "line", `Int __LINE__ ] @ data
          in
          Otel.Span.create ~trace_id:new_scope.trace_id ~id:span_id ~start_time
            ~end_time ~attrs name
          |> fst
        in

        Otel.Trace.emit [ o_span ];

        ()

    let message ?span ~data:_ msg : unit =
      (* gather information from context *)
      let old_scope = Otel.Scope.get_surrounding () in
      let trace_id = Option.map (fun sc -> sc.Otel.Scope.trace_id) old_scope in

      let span_id =
        match span with
        | Some id -> Some (span_of_i64 id)
        | None -> Option.map (fun sc -> sc.Otel.Scope.span_id) old_scope
      in

      let log = Otel.Logs.make_str ?trace_id ?span_id msg in
      Otel.Logs.emit [ log ]

    let shutdown () = ()

    let name_process _name = ()

    let name_thread _name = ()

    let counter_int name cur_val : unit =
      let m = Otel.Metrics.(gauge ~name [ int cur_val ]) in
      Otel.Metrics.emit [ m ]

    let counter_float name cur_val : unit =
      let m = Otel.Metrics.(gauge ~name [ float cur_val ]) in
      Otel.Metrics.emit [ m ]
  end in
  (module M)

let setup () = Trace.setup_collector @@ collector ()

let setup_with_otel_backend b : unit =
  Otel.Collector.set_backend b;
  setup ()