Source file trace_subscriber.ml

open Trace_core
module Callbacks = Callbacks
module Subscriber = Subscriber
include Types

type t = Subscriber.t

module Private_ = struct
  let get_now_ns_ = ref None
  let get_tid_ = ref None

  (** Now, in nanoseconds *)
  let[@inline] now_ns () : float =
    match !get_now_ns_ with
    | Some f -> f ()
    | None -> Time_.get_time_ns ()

  let[@inline] tid_ () : int =
    match !get_tid_ with
    | Some f -> f ()
    | None -> Thread_.get_tid ()
end

open struct
  module A = Trace_core.Internal_.Atomic_

  type manual_span_info = {
    name: string;
    flavor: flavor option;
    mutable data: (string * user_data) list;
  }

  (** Key used to carry some information between begin and end of
    manual spans, by way of the meta map *)
  let key_manual_info : manual_span_info Meta_map.key = Meta_map.Key.create ()

  (** key used to carry a unique "id" for all spans in an async context *)
  let key_async_trace_id : int Meta_map.key = Meta_map.Key.create ()
end

let[@inline] conv_flavor = function
  | `Async -> Async
  | `Sync -> Sync

let[@inline] conv_flavor_opt = function
  | None -> None
  | Some f -> Some (conv_flavor f)

let[@inline] conv_user_data = function
  | `Int i -> U_int i
  | `Bool b -> U_bool b
  | `Float f -> U_float f
  | `String s -> U_string s
  | `None -> U_none

let rec conv_data = function
  | [] -> []
  | [ (k, v) ] -> [ k, conv_user_data v ]
  | (k, v) :: tl -> (k, conv_user_data v) :: conv_data tl

(** A collector that calls the callbacks of subscriber *)
let collector (Sub { st; callbacks = (module CB) } : Subscriber.t) : collector =
  let open Private_ in
  let module M = struct
    let trace_id_gen_ = A.make 0

    (** generator for span ids *)
    let new_span_ : unit -> int =
      let span_id_gen_ = A.make 0 in
      fun [@inline] () -> A.fetch_and_add span_id_gen_ 1

    let enter_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name : span =
      let span = Int64.of_int (new_span_ ()) in
      let tid = tid_ () in
      let time_ns = now_ns () in
      let data = conv_data data in
      CB.on_enter_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~time_ns ~tid ~data
        ~name span;
      span

    let exit_span span : unit =
      let time_ns = now_ns () in
      let tid = tid_ () in
      CB.on_exit_span st ~time_ns ~tid span

    let with_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name f =
      let span = enter_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name in
      try
        let x = f span in
        exit_span span;
        x
      with exn ->
        let bt = Printexc.get_raw_backtrace () in
        exit_span span;
        Printexc.raise_with_backtrace exn bt

    let add_data_to_span span data =
      if data <> [] then (
        let data = conv_data data in
        CB.on_add_data st ~data span
      )

    let enter_manual_span ~(parent : explicit_span option) ~flavor ~__FUNCTION__
        ~__FILE__ ~__LINE__ ~data name : explicit_span =
      let span = Int64.of_int (new_span_ ()) in
      let tid = tid_ () in
      let time_ns = now_ns () in
      let data = conv_data data in
      let flavor = conv_flavor_opt flavor in

      (* get the common trace id, or make a new one *)
      let trace_id, parent =
        match parent with
        | Some m -> Meta_map.find_exn key_async_trace_id m.meta, Some m.span
        | None -> A.fetch_and_add trace_id_gen_ 1, None
      in

      CB.on_enter_manual_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~parent ~data
        ~time_ns ~tid ~name ~flavor ~trace_id span;
      let meta =
        Meta_map.empty
        |> Meta_map.add key_manual_info { name; flavor; data = [] }
        |> Meta_map.add key_async_trace_id trace_id
      in
      { span; meta }

    let exit_manual_span (es : explicit_span) : unit =
      let time_ns = now_ns () in
      let tid = tid_ () in
      let trace_id =
        match Meta_map.find key_async_trace_id es.meta with
        | None -> assert false
        | Some id -> id
      in
      let minfo =
        match Meta_map.find key_manual_info es.meta with
        | None -> assert false
        | Some m -> m
      in
      CB.on_exit_manual_span st ~tid ~time_ns ~data:minfo.data ~name:minfo.name
        ~flavor:minfo.flavor ~trace_id es.span

    let add_data_to_manual_span (es : explicit_span) data =
      if data <> [] then (
        let data = conv_data data in
        match Meta_map.find key_manual_info es.meta with
        | None -> assert false
        | Some m -> m.data <- List.rev_append data m.data
      )

    let message ?span ~data msg : unit =
      let time_ns = now_ns () in
      let tid = tid_ () in
      let data = conv_data data in
      CB.on_message st ~time_ns ~tid ~span ~data msg

    let counter_float ~data name f : unit =
      let time_ns = now_ns () in
      let tid = tid_ () in
      let data = conv_data data in
      CB.on_counter st ~tid ~time_ns ~data ~name f

    let[@inline] counter_int ~data name i =
      counter_float ~data name (float_of_int i)

    let name_process name : unit =
      let tid = tid_ () in
      let time_ns = now_ns () in
      CB.on_name_process st ~time_ns ~tid ~name

    let name_thread name : unit =
      let tid = tid_ () in
      let time_ns = now_ns () in
      CB.on_name_thread st ~time_ns ~tid ~name

    let shutdown () =
      let time_ns = now_ns () in
      CB.on_shutdown st ~time_ns

    let () =
      (* init code *)
      let time_ns = now_ns () in
      CB.on_init st ~time_ns
  end in
  (module M)