simon/ocaml-opentelemetry
1
0
Fork 0
mirror of https://github.com/ocaml-tracing/ocaml-opentelemetry.git synced 2026-03-07 18:37:56 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

refactor trace: adapt to newer trace 0.99

Browse source 
no more global state 🥳
This commit is contained in:
Simon Cruanes 2026-01-16 20:55:13 -05:00
parent 96aef5e021
commit 26e70ed1af
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
4 changed files with 123 additions and 333 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
src/trace/common_.ml
View file

@ -1,5 +1,6 @@
module OTEL = Opentelemetry module OTEL = Opentelemetry
module Otrace = Trace_core (* ocaml-trace *) module Otrace = Trace_core (* ocaml-trace *)
module Ambient_context = Opentelemetry_ambient_context
let ( let@ ) = ( @@ ) let ( let@ ) = ( @@ )

3
src/trace/dune
View file

@ -9,5 +9,4 @@
(re_export opentelemetry.util) (re_export opentelemetry.util)
opentelemetry.atomic opentelemetry.atomic
(re_export opentelemetry) (re_export opentelemetry)
(re_export trace.core) (re_export trace.core)))
trace.subscriber))

419
src/trace/opentelemetry_trace.ml
View file

@ -1,25 +1,5 @@
open Opentelemetry_atomic
open Common_ open Common_
let on_internal_error =
ref (fun msg -> Printf.eprintf "error in Opentelemetry_trace: %s\n%!" msg)
open struct
module Opt_syntax = struct
let[@inline] ( let+ ) o f =
match o with
| None -> None
| Some x -> Some (f x)
let ( >|= ) = ( let+ )
let[@inline] ( <?> ) a b =
match a, b with
| Some _, _ -> a
| None, _ -> b
end
end
module Extensions = struct module Extensions = struct
type Otrace.extension_event += type Otrace.extension_event +=
| Ev_link_span of Otrace.span * OTEL.Span_ctx.t | Ev_link_span of Otrace.span * OTEL.Span_ctx.t
@ -34,84 +14,44 @@ end
open Extensions open Extensions
module Internal = struct open struct
type span_begin = { span: OTEL.Span.t } [@@unboxed] type Otrace.span += Span_otel of OTEL.Span.t
end
(* use the fast, thread safe span table that relies on picos. *)
module Active_span_tbl = Trace_subscriber.Span_tbl
open struct
type state = { type state = {
tbl: span_begin Active_span_tbl.t;
span_gen: int Atomic.t;
clock: Opentelemetry_core.Clock.t; clock: Opentelemetry_core.Clock.t;
exporter: OTEL.Exporter.t;
} }
let create_state ~clock () : state = let create_state ~(exporter : OTEL.Exporter.t) () : state =
{ tbl = Active_span_tbl.create (); span_gen = Atomic.make 0; clock } let clock = exporter.clock in
{ clock; exporter }
(* sanity check: otrace meta-map must be the same as hmap *) (* sanity check: otrace meta-map must be the same as hmap *)
let () = ignore (fun (k : _ Hmap.key) : _ Otrace.Meta_map.key -> k) let () = ignore (fun (k : _ Hmap.key) : _ Ambient_context.Context.key -> k)
let[@inline] get_span_ (self : state) (span : Otrace.span) : (** Key to access the current span context. *)
OTEL.Span.t option = let k_span_ctx : OTEL.Span_ctx.t Ambient_context.Context.key =
match Active_span_tbl.find_exn self.tbl span with Ambient_context.Context.new_key ()
| exception Not_found -> None
| { span } -> Some span
(** key to access a OTEL span (the current span) from an (* TODO: params *)
[Otrace.explicit_span]. We can reuse the context key because we know that
[Otrace.Meta_map == Hmap]. *)
let k_span_otrace : OTEL.Span.t Otrace.Meta_map.key = OTEL.Span.k_context
let[@inline] get_span_explicit_ (span : Otrace.explicit_span) : let enter_span (self : state) ~__FUNCTION__ ~__FILE__ ~__LINE__ ~params:_
OTEL.Span.t option = ~(data : (_ * Otrace.user_data) list) ~parent name : Otrace.span =
Otrace.Meta_map.find k_span_otrace span.meta let start_time = OTEL.Clock.now self.clock in
let trace_id, parent_id =
let enter_span_ (self : state) match parent with
?(explicit_parent : Otrace.explicit_span_ctx option) ~__FUNCTION__ | Otrace.P_some (Span_otel sp) ->
~__FILE__ ~__LINE__ ~data ~(otrace_span : Otrace.span) name : span_begin = OTEL.Span.trace_id sp, Some (OTEL.Span.id sp)
let open OTEL in | _ ->
(* we create a random span ID here, it's not related in any way to (match Ambient_context.get k_span_ctx with
the [Otrace.span] which is sequential. The [Otrace.span] has strong | Some sp_ctx ->
guarantees of uniqueness and thus we {i can} use it as an index OTEL.Span_ctx.trace_id sp_ctx, Some (OTEL.Span_ctx.parent_id sp_ctx)
in [Span_tbl], whereas an 8 bytes OTEL span ID might be prone to | None -> OTEL.Trace_id.create (), None)
collisions over time. *)
let otel_id = Span_id.create () in
(* get data from parent *)
let trace_id_from_parent, parent_id_from_parent =
let open Opt_syntax in
match explicit_parent with
| Some p ->
let trace_id = Otrace.Meta_map.find OTEL.Trace_id.k_trace_id p.meta in
let span_id =
Otrace.Meta_map.find k_span_otrace p.meta >|= OTEL.Span.id
in
let span_ctx = Otrace.Meta_map.find OTEL.Span_ctx.k_span_ctx p.meta in
( trace_id <?> (span_ctx >|= OTEL.Span_ctx.trace_id),
span_id <?> (span_ctx >|= OTEL.Span_ctx.parent_id) )
| None -> None, None
in in
(* get data from implicit context *) let span_id = OTEL.Span_id.create () in
let trace_id_from_ambient, parent_id_from_ambient =
if Option.is_none trace_id_from_parent then
let open Opt_syntax in
let implicit_parent = OTEL.Ambient_span.get () in
implicit_parent >|= OTEL.Span.trace_id, implicit_parent >|= OTEL.Span.id
else
None, None
in
let trace_id =
match trace_id_from_parent, trace_id_from_ambient with
| Some t, _ | None, Some t -> t
| None, None -> Trace_id.create ()
in
let parent_id =
Opt_syntax.(parent_id_from_parent <?> parent_id_from_ambient)
in
let attrs = let attrs =
("code.filepath", `String __FILE__) ("code.filepath", `String __FILE__)
@ -119,251 +59,116 @@ module Internal = struct
:: data :: data
in in
let start_time = Clock.now self.clock in let otel_sp : OTEL.Span.t =
let span : OTEL.Span.t = OTEL.Span.make ~start_time ~id:span_id ~trace_id ~attrs ?parent:parent_id
OTEL.Span.make ?parent:parent_id ~trace_id ~id:otel_id ~attrs name ~end_time:0L name
~start_time ~end_time:start_time
in in
let sb = { span } in (* add more data if [__FUNCTION__] is present *)
(match __FUNCTION__ with (match __FUNCTION__ with
| Some __FUNCTION__ when OTEL.Span.is_not_dummy span -> | Some __FUNCTION__ when OTEL.Span.is_not_dummy otel_sp ->
let last_dot = String.rindex __FUNCTION__ '.' in let last_dot = String.rindex __FUNCTION__ '.' in
let module_path = String.sub __FUNCTION__ 0 last_dot in let module_path = String.sub __FUNCTION__ 0 last_dot in
let function_name = let function_name =
String.sub __FUNCTION__ (last_dot + 1) String.sub __FUNCTION__ (last_dot + 1)
(String.length __FUNCTION__ - last_dot - 1) (String.length __FUNCTION__ - last_dot - 1)
in in
Span.add_attrs span OTEL.Span.add_attrs otel_sp
[ [
"code.function", `String function_name; "code.function", `String function_name;
"code.namespace", `String module_path; "code.namespace", `String module_path;
] ]
| _ -> ()); | _ -> ());
Active_span_tbl.add self.tbl otrace_span sb; Span_otel otel_sp
sb
let exit_span_ self { span } : OTEL.Span.t = let exit_span (self : state) sp =
let open OTEL in match sp with
if Span.is_not_dummy span then ( | Span_otel span when OTEL.Span.is_not_dummy span ->
let end_time = Clock.now self.clock in (* emit the span after setting the end timestamp *)
Proto.Trace.span_set_end_time_unix_nano span end_time let end_time = OTEL.Clock.now self.clock in
); OTEL.Proto.Trace.span_set_end_time_unix_nano span end_time;
span OTEL.Exporter.send_trace self.exporter [ span ]
let exit_span' (self : state) otrace_id otel_span_begin =
Active_span_tbl.remove self.tbl otrace_id;
exit_span_ self otel_span_begin
(** Find the OTEL span corresponding to this Trace span *)
let exit_span_from_id (self : state) otrace_id =
match Active_span_tbl.find_exn self.tbl otrace_id with
| exception Not_found -> None
| otel_span_begin ->
Active_span_tbl.remove self.tbl otrace_id;
Some (exit_span_ self otel_span_begin)
end
module type COLLECTOR_ARG = sig
val exporter : OTEL.Exporter.t
end
module Make_collector (A : COLLECTOR_ARG) = struct
open Internal
let exporter = A.exporter
let state = create_state ~clock:exporter.clock ()
(* NOTE: perf: it would be interesting to keep the "current (OTEL) span" in
local storage/ambient-context, to accelerate most span-modifying
operations. They'd first look in local storage, and if the span isn't the
expected one, then look in the main span tbl. *)
let with_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name cb =
let otrace_span : Otrace.span =
Int64.of_int (Atomic.fetch_and_add state.span_gen 1)
in
let sb : span_begin =
enter_span_ state ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name
~otrace_span
in
match
let@ () = OTEL.Ambient_span.with_ambient sb.span in
cb otrace_span
with
| res ->
let otel_span = exit_span' state otrace_span sb in
OTEL.Exporter.send_trace exporter [ otel_span ];
res
| exception e ->
let bt = Printexc.get_raw_backtrace () in
let otrace_span : Otrace.span =
Int64.of_int (Atomic.fetch_and_add state.span_gen 1)
in
OTEL.Span.record_exception sb.span e bt;
let otel_span = exit_span' state otrace_span sb in
OTEL.Exporter.send_trace exporter [ otel_span ];
Printexc.raise_with_backtrace e bt
let enter_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name : Trace_core.span
=
let otrace_span : Otrace.span =
Int64.of_int (Atomic.fetch_and_add state.span_gen 1)
in
let _sb =
enter_span_ state ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data ~otrace_span
name
in
(* NOTE: we cannot enter ambient scope in a disjoint way
with the exit, because we only have [Ambient_context.with_binding],
no [set_binding]. This is what {!with_parent_span} is for! *)
otrace_span
let exit_span otrace_id =
match exit_span_from_id state otrace_id with
| None -> ()
| Some otel_span -> OTEL.Exporter.send_trace exporter [ otel_span ]
let enter_manual_span ~(parent : Otrace.explicit_span_ctx option) ~flavor:_
~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name : Otrace.explicit_span =
let otrace_span : Otrace.span =
Int64.of_int (Atomic.fetch_and_add state.span_gen 1)
in
let sb =
match parent with
| None ->
enter_span_ state ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data ~otrace_span
name
| Some parent ->
enter_span_ state ~explicit_parent:parent ~__FUNCTION__ ~__FILE__
~__LINE__ ~data ~otrace_span name
in
Active_span_tbl.add state.tbl otrace_span sb;
{
Otrace.span = otrace_span;
meta = Otrace.Meta_map.(empty |> add k_span_otrace sb.span);
}
let exit_manual_span { Otrace.span = otrace_id; _ } =
match Active_span_tbl.find_exn state.tbl otrace_id with
| exception Not_found ->
!on_internal_error (spf "no active span with ID %Ld" otrace_id)
| sb ->
let otel_span = exit_span' state otrace_id sb in
OTEL.Exporter.send_trace exporter [ otel_span ]
let add_data_to_span otrace_id data =
match Active_span_tbl.find_exn state.tbl otrace_id with
| exception Not_found ->
!on_internal_error (spf "no active span with ID %Ld" otrace_id)
| sb -> OTEL.Span.add_attrs sb.span data
let add_data_to_manual_span (span : Otrace.explicit_span) data : unit =
match get_span_explicit_ span with
| None ->
!on_internal_error (spf "manual span does not a contain an OTEL scope")
| Some span -> OTEL.Span.add_attrs span data
let message ?(span : Otrace.span option) ~data:_ msg : unit =
let trace_id_from_parent, span_id_from_parent =
let open Opt_syntax in
match span with
| Some p ->
let sp = get_span_ state p in
( (let+ sp = sp in
OTEL.Span.trace_id sp),
let+ sp = sp in
OTEL.Span.id sp )
| None -> None, None
in
(* get data from implicit context *)
let trace_id_from_ambient, span_id_from_ambient =
if Option.is_none trace_id_from_parent then
let open Opt_syntax in
let implicit_parent = OTEL.Ambient_span.get () in
implicit_parent >|= OTEL.Span.trace_id, implicit_parent >|= OTEL.Span.id
else
None, None
in
let trace_id =
Opt_syntax.(trace_id_from_parent <?> trace_id_from_ambient)
in
let span_id = Opt_syntax.(span_id_from_parent <?> span_id_from_ambient) in
let log =
let observed_time_unix_nano = OTEL.Clock.now exporter.clock in
OTEL.Log_record.make_str ~observed_time_unix_nano ?trace_id ?span_id msg
in
OTEL.Exporter.send_logs exporter [ log ]
let shutdown () = ()
let name_process _name = ()
let name_thread _name = ()
let counter_int ~data:attrs name cur_val : unit =
let now = OTEL.Clock.now exporter.clock in
let m = OTEL.Metrics.(gauge ~name [ int ~attrs ~now cur_val ]) in
OTEL.Exporter.send_metrics exporter [ m ]
let counter_float ~data:attrs name cur_val : unit =
let now = OTEL.Clock.now exporter.clock in
let m = OTEL.Metrics.(gauge ~name [ float ~attrs ~now cur_val ]) in
OTEL.Exporter.send_metrics exporter [ m ]
let extension_event = function
| Ev_link_span (sp1, sc2) ->
(match get_span_ state sp1 with
| Some sc1 -> OTEL.Span.add_links sc1 [ OTEL.Span_link.of_span_ctx sc2 ]
| _ -> !on_internal_error "could not find scope for OTEL span")
| Ev_set_span_kind (sp, k) ->
(match get_span_ state sp with
| None -> !on_internal_error "could not find scope for OTEL span"
| Some sc -> OTEL.Span.set_kind sc k)
| Ev_set_span_status (sp, st) ->
(match get_span_ state sp with
| None -> !on_internal_error "could not find scope for OTEL span"
| Some sc -> OTEL.Span.set_status sc st)
| Ev_record_exn { sp; exn; bt } ->
(match get_span_ state sp with
| None -> !on_internal_error "could not find scope for OTEL span"
| Some sc -> OTEL.Span.record_exception sc exn bt)
| _ -> () | _ -> ()
let add_data_to_span _self span (data : (_ * Otrace.user_data) list) =
match span with
| Span_otel sp -> OTEL.Span.add_attrs sp data
| _ -> ()
let message (self : state) ~params:_ ~data ~span msg : unit =
let trace_id, span_id =
match span with
| Some (Span_otel sp) ->
Some (OTEL.Span.trace_id sp), Some (OTEL.Span.id sp)
| _ ->
(match Ambient_context.get k_span_ctx with
| Some sp ->
Some (OTEL.Span_ctx.trace_id sp), Some (OTEL.Span_ctx.parent_id sp)
| _ -> None, None)
in
let observed_time_unix_nano = OTEL.Clock.now self.clock in
let log =
OTEL.Log_record.make ?trace_id ?span_id ~attrs:data
~observed_time_unix_nano (`String msg)
in
OTEL.Exporter.send_logs self.exporter [ log ]
let counter_int (self : state) ~params:_ ~data:attrs name cur_val : unit =
let now = OTEL.Clock.now self.clock in
let m = OTEL.Metrics.(gauge ~name [ int ~attrs ~now cur_val ]) in
OTEL.Exporter.send_metrics self.exporter [ m ]
let counter_float (self : state) ~params:_ ~data:attrs name cur_val : unit =
let now = OTEL.Clock.now self.clock in
let m = OTEL.Metrics.(gauge ~name [ float ~attrs ~now cur_val ]) in
OTEL.Exporter.send_metrics self.exporter [ m ]
let extension (_self : state) ev =
match ev with
| Ev_link_span (Span_otel sp1, sc2) ->
OTEL.Span.add_links sp1 [ OTEL.Span_link.of_span_ctx sc2 ]
| Ev_link_span _ -> ()
| Ev_set_span_kind (Span_otel sp, k) -> OTEL.Span.set_kind sp k
| Ev_set_span_kind _ -> ()
| Ev_set_span_status (Span_otel sp, st) -> OTEL.Span.set_status sp st
| Ev_set_span_status _ -> ()
| Ev_record_exn { sp = Span_otel sp; exn; bt } ->
OTEL.Span.record_exception sp exn bt
| Ev_record_exn _ -> ()
| _ -> ()
let shutdown self = OTEL.Exporter.shutdown self.exporter
let callbacks : state Otrace.Collector.Callbacks.t =
Otrace.Collector.Callbacks.make ~enter_span ~exit_span ~add_data_to_span
~message ~counter_int ~counter_float ~extension ~shutdown ()
end end
let collector_of_exporter (exp : OTEL.Exporter.t) : Trace_core.collector = let collector_of_exporter (exporter : OTEL.Exporter.t) : Trace_core.collector =
let module M = Make_collector (struct let st = create_state ~exporter () in
let exporter = exp Trace_core.Collector.C_some (st, callbacks)
end) in
(module M : Trace_core.Collector.S)
let with_ambient_span (sp : Otrace.explicit_span) f = let with_ambient_span (sp : Otrace.span) f =
let open Internal in match sp with
match get_span_explicit_ sp with | Span_otel sp ->
| None -> f () Ambient_context.with_key_bound_to k_span_ctx (OTEL.Span.to_span_ctx sp) f
| Some otel_sp -> Opentelemetry.Ambient_span.with_ambient otel_sp f | _ -> f ()
let with_ambient_span_ctx (sp : OTEL.Span_ctx.t) f =
Ambient_context.with_key_bound_to k_span_ctx sp f
let link_span_to_otel_ctx (sp1 : Otrace.span) (sp2 : OTEL.Span_ctx.t) : unit = let link_span_to_otel_ctx (sp1 : Otrace.span) (sp2 : OTEL.Span_ctx.t) : unit =
if Otrace.enabled () then Otrace.extension_event @@ Ev_link_span (sp1, sp2) if Otrace.enabled () then Otrace.extension_event @@ Ev_link_span (sp1, sp2)
(* let link_spans (sp1 : Otrace.span) (sp2 : Otrace.span) : unit =
let link_spans (sp1 : Otrace.explicit_span) (sp2 : Otrace.explicit_span) : unit if Otrace.enabled () then (
= match sp2 with
if Otrace.enabled () then Otrace.extension_event @@ Ev_link_span (sp1, sp2) | Span_otel sp2 ->
*) Otrace.extension_event @@ Ev_link_span (sp1, OTEL.Span.to_span_ctx sp2)
| _ -> ()
)
let[@inline] set_span_kind sp k : unit = let[@inline] set_span_kind sp k : unit =
if Otrace.enabled () then Otrace.extension_event @@ Ev_set_span_kind (sp, k) if Otrace.enabled () then Otrace.extension_event @@ Ev_set_span_kind (sp, k)

33
src/trace/opentelemetry_trace.mli
View file

@ -5,9 +5,7 @@
that use [ocaml-trace], and they will automatically emit OpenTelemetry spans that use [ocaml-trace], and they will automatically emit OpenTelemetry spans
and logs. and logs.
Both explicit scope (in the [_manual] functions such as [enter_manual_span]) Ambient_context is used to track the current ambient span.
and implicit scope (in {!Internal.M.with_span}, via {!Ambient_context}) are
supported; see the detailed notes on {!Internal.M.enter_manual_span}.
We use [Trace_core.extension_event] to add more features on top of the We use [Trace_core.extension_event] to add more features on top of the
common tracing interface. For example to set the "span kind": common tracing interface. For example to set the "span kind":
@ -37,9 +35,6 @@ module Extensions : sig
| Ev_set_span_status of Otrace.span * OTEL.Span_status.t | Ev_set_span_status of Otrace.span * OTEL.Span_status.t
end end
val on_internal_error : (string -> unit) ref
(** Callback to print errors in the library itself (ie bugs) *)
val setup : unit -> unit val setup : unit -> unit
(** Install the OTEL backend as a Trace collector *) (** Install the OTEL backend as a Trace collector *)
@ -49,24 +44,16 @@ val setup_with_otel_exporter : OTEL.Exporter.t -> unit
val setup_with_otel_backend : OTEL.Exporter.t -> unit val setup_with_otel_backend : OTEL.Exporter.t -> unit
[@@deprecated "use setup_with_otel_exporter"] [@@deprecated "use setup_with_otel_exporter"]
(* TODO: subscriber, with the next gen of Trace_subscriber
that allows us to provide [new_trace_id] so we can produce 16B trace IDs.
val subscriber_of_exporter : OTEL.Exporter.t -> Trace_subscriber.t
*)
val collector_of_exporter : OTEL.Exporter.t -> Trace_core.collector val collector_of_exporter : OTEL.Exporter.t -> Trace_core.collector
val collector : unit -> Trace_core.collector val collector : unit -> Trace_core.collector
[@@deprecated "use collector_of_exporter, avoid global state"] [@@deprecated "use collector_of_exporter, avoid global state"]
(** Make a Trace collector that uses the OTEL backend to send spans and logs *) (** Make a Trace collector that uses the main OTEL backend to send spans and
logs *)
(* NOTE: we cannot be sure that [sc2] is still alive and findable val link_spans : Otrace.span -> Otrace.span -> unit
in the active spans table. We could provide this operation under
the explicit precondition that it is?
val link_spans : Otrace.explicit_span -> Otrace.explicit_span -> unit
(** [link_spans sp1 sp2] modifies [sp1] by adding a span link to [sp2]. (** [link_spans sp1 sp2] modifies [sp1] by adding a span link to [sp2].
@since 0.11 *) @since 0.11 *)
*)
val link_span_to_otel_ctx : Otrace.span -> OTEL.Span_ctx.t -> unit val link_span_to_otel_ctx : Otrace.span -> OTEL.Span_ctx.t -> unit
(** [link_spans sp1 sp_ctx2] modifies [sp1] by adding a span link to [sp_ctx2]. (** [link_spans sp1 sp_ctx2] modifies [sp1] by adding a span link to [sp_ctx2].
@ -82,15 +69,13 @@ val set_span_status : Otrace.span -> OTEL.Span_status.t -> unit
val record_exception : Otrace.span -> exn -> Printexc.raw_backtrace -> unit val record_exception : Otrace.span -> exn -> Printexc.raw_backtrace -> unit
(** Record exception in the current span. *) (** Record exception in the current span. *)
val with_ambient_span : Otrace.explicit_span -> (unit -> 'a) -> 'a val with_ambient_span : Otrace.span -> (unit -> 'a) -> 'a
(** [with_ambient_span sp f] calls [f()] in an ambient context where [sp] is the (** [with_ambient_span sp f] calls [f()] in an ambient context where [sp] is the
current span. current span. *)
Explicit spans are typically entered and exited using [enter_manual_span] val with_ambient_span_ctx : OTEL.Span_ctx.t -> (unit -> 'a) -> 'a
and [exit_manual_span], whereas ambient-context requires a (** [with_ambient_span_ctx spc f] calls [f()] in a scope where [spc] is the
[with_span span f] kind of approach. This function is here to bridge the gap ambient span-context *)
whenever possible. For regular [Otrace.span] this is not needed because the
collector will set the ambient span automatically. *)
module Well_known : sig end module Well_known : sig end
[@@deprecated [@@deprecated