Source file trace_provider.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
open Proto.Trace
open Opentelemetry_emitter

open struct
  let provider_ : Tracer.t Atomic.t = Atomic.make Tracer.dummy
end

(** Get current tracer. *)
let get () : Tracer.t = Atomic.get provider_

(** Set current tracer *)
let set (t : Tracer.t) : unit =
  Self_debug.log Info (fun () -> "otel: trace provider installed");
  Atomic.set provider_ t

(** Replace current tracer by the dummy one. All spans will be discarded from
    now on. *)
let clear () : unit =
  Self_debug.log Info (fun () -> "otel: trace provider removed");
  Atomic.set provider_ Tracer.dummy

(** Get a tracer pre-configured with a fixed set of attributes added to every
    span it emits, forwarding to the current global tracer. Intended to be
    called once at the top of a library module.

    @param name instrumentation scope name (recorded as [otel.scope.name])
    @param version
      instrumentation scope version (recorded as [otel.scope.version])
    @param __MODULE__
      the OCaml module name, typically the [__MODULE__] literal (recorded as
      [code.namespace])
    @param attrs additional fixed attributes *)
let get_tracer ?name ?version ?(attrs : (string * [< Value.t ]) list = [])
    ?__MODULE__ () : Tracer.t =
  let extra =
    Scope_attributes.make_attrs ?name ?version ~attrs ?__MODULE__ ()
  in
  {
    Tracer.emit =
      Emitter.make ~signal_name:"spans"
        ~enabled:(fun () -> Emitter.enabled (Atomic.get provider_).emit)
        ~emit:(fun spans ->
          (match extra with
          | [] -> ()
          | _ -> List.iter (fun span -> Span.add_attrs span extra) spans);
          Emitter.emit (Atomic.get provider_).emit spans)
        ();
    clock = { Clock.now = (fun () -> Clock.now (Clock.Main.get ())) };
  }

(** A Tracer.t that lazily reads the global at emit time *)
let default_tracer : Tracer.t = get_tracer ()

(** Emit a span directly via the current global tracer *)
let[@inline] emit (span : Span.t) : unit = Emitter.emit (get ()).emit [ span ]

(** Helper to implement {!with_} and similar functions *)
let with_thunk_and_finally (self : Tracer.t) ?(force_new_trace_id = false)
    ?trace_state ?(attrs : (string * [< Value.t ]) list = []) ?kind ?trace_id
    ?parent ?links name cb =
  let parent =
    match parent with
    | Some _ -> parent
    | None -> Ambient_span.get ()
  in
  let trace_id =
    match trace_id, parent with
    | _ when force_new_trace_id -> Trace_id.create ()
    | Some trace_id, _ -> trace_id
    | None, Some p -> Span.trace_id p
    | None, None -> Trace_id.create ()
  in
  let start_time = Clock.now self.clock in
  let span_id = Span_id.create () in

  let parent_id = Option.map Span.id parent in

  let span : Span.t =
    Span.make ?trace_state ?kind ?parent:parent_id ~trace_id ~id:span_id ~attrs
      ?links ~start_time ~end_time:start_time name
  in
  let () =
    match Dynamic_enricher.collect () with
    | [] -> ()
    | dyn_attrs -> Span.add_attrs span dyn_attrs
  in
  (* called once we're done, to emit a span *)
  let finally res =
    let end_time = Clock.now self.clock in
    span_set_end_time_unix_nano span end_time;

    (match Span.status span with
    | Some _ -> ()
    | None ->
      (match res with
      | Ok () -> ()
      | Error (e, bt) -> Span.record_exception span e bt));

    Emitter.emit self.emit [ span ]
  in
  let thunk () = Ambient_span.with_ambient span (fun () -> cb span) in
  thunk, finally

(** Sync span guard.

    Notably, this includes {e implicit} scope-tracking: if called without a
    [~scope] argument (or [~parent]/[~trace_id]), it will check in the
    {!Ambient_context} for a surrounding environment, and use that as the scope.
    Similarly, it uses {!Scope.with_ambient_scope} to {e set} a new scope in the
    ambient context, so that any logically-nested calls to {!with_} will use
    this span as their parent.

    {b NOTE} be careful not to call this inside a Gc alarm, as it can cause
    deadlocks.

    @param tracer the tracer to use (default [default_tracer])
    @param force_new_trace_id
      if true (default false), the span will not use a ambient scope, the
      [~scope] argument, nor [~trace_id], but will instead always create fresh
      identifiers for this span *)
let with_ ?(tracer = default_tracer) ?force_new_trace_id ?trace_state ?attrs
    ?kind ?trace_id ?parent ?links name (cb : Span.t -> 'a) : 'a =
  let thunk, finally =
    with_thunk_and_finally tracer ?force_new_trace_id ?trace_state ?attrs ?kind
      ?trace_id ?parent ?links name cb
  in
  try
    let rv = thunk () in
    finally (Ok ());
    rv
  with e ->
    let bt = Printexc.get_raw_backtrace () in
    finally (Error (e, bt));
    raise e