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

wip: migrate to trace 0.11 and ambient-context 0.2

Browse source
This commit is contained in:
Simon Cruanes 2026-02-17 19:54:38 -05:00
parent 98a364b046
commit 573e35fec9
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
26 changed files with 189 additions and 894 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
CHANGES.md
View file

@ -1,4 +1,12 @@
## 0.13
- feat: adapt to trace 0.11 (callbacks-based collector API, extensible span type, no more manual spans)
- breaking: remove vendored `opentelemetry.ambient-context`; use the
`ambient-context` 0.2 package directly instead. To configure the
storage backend, call `Ambient_context.set_current_storage` (e.g.
`Ambient_context.set_current_storage Ambient_context_lwt.storage`).
## 0.12
- breaking: change `Collector.cleanup` so it takes a callback

17
README.md
View file

@ -1,5 +1,5 @@
# Opentelemetry [![build](https://github.com/imandra-ai/ocaml-opentelemetry/actions/workflows/main.yml/badge.svg)](https://github.com/imandra-ai/ocaml-opentelemetry/actions/workflows/main.yml)
# Opentelemetry [![build](https://github.com/ocaml-tracing/ocaml-opentelemetry/actions/workflows/main.yml/badge.svg)](https://github.com/ocaml-tracing/ocaml-opentelemetry/actions/workflows/main.yml)
This project provides an API for instrumenting server software
using [opentelemetry](https://opentelemetry.io/docs), as well as
@ -28,7 +28,7 @@ MIT
* [x] batching, perf, etc.
- [ ] async collector relying on ocurl-multi
- [ ] interface with `logs` (carry context around)
- [x] implicit scope (via vendored `ambient-context`, see `opentelemetry.ambient-context`)
- [x] implicit scope (via [`ambient-context`](https://github.com/ocaml-tracing/ambient-context))
## Use
@ -65,16 +65,17 @@ let main () =
Otel.Globals.service_name := "my_service";
Otel.GC_metrics.basic_setup();
Opentelemetry_ambient_context.set_storage_provider (Opentelemetry_ambient_context_lwt.storage ());
(* install Lwt's fiber-local storage as the ambient context backend *)
Ambient_context.set_current_storage Ambient_context_lwt.storage;
Opentelemetry_client_ocurl.with_setup () @@ fun () ->
(* … *)
foo ();
(* … *)
```
[`service_name`]: <https://v3.ocaml.org/p/opentelemetry/0.5/doc/Opentelemetry/Globals/index.html#val-service_name>
[`Collector`]: <https://v3.ocaml.org/p/opentelemetry/0.5/doc/Opentelemetry/Collector/index.html>
[ambient-context]: now vendored as `opentelemetry.ambient-context`, formerly <https://v3.ocaml.org/p/ambient-context>
[`service_name`]: <https://github.com/ocaml-tracing/ocaml-opentelemetry>
[`Collector`]: <https://github.com/ocaml-tracing/ocaml-opentelemetry>
[ambient-context]: <https://github.com/ocaml-tracing/ambient-context>
## Configuration
@ -93,7 +94,7 @@ or the datadog agent).
Do note that this backend uses a thread pool and is incompatible
with uses of `fork` on some Unixy systems.
See [#68](https://github.com/imandra-ai/ocaml-opentelemetry/issues/68) for a possible workaround.
See [#68](https://github.com/ocaml-tracing/ocaml-opentelemetry/issues/68) for a possible workaround.
## Collector opentelemetry-client-cohttp-lwt
@ -103,7 +104,7 @@ inside a `Lwt_main.run` scope.
## Opentelemetry-trace
The optional library `opentelemetry.trace`, present if [trace](https://github.com/c-cube/trace) is
The optional library `opentelemetry.trace`, present if [trace](https://github.com/ocaml-tracing/ocaml-trace) is
installed, provides a collector for `trace`. This collector forwards and translates
events from `trace` into `opentelemetry`. It's only useful if there also is also a OTEL collector.

3
dune-project
View file

@ -40,6 +40,7 @@
(>= 3.0)
(< 4.0)))
(ocaml-lsp-server :with-dev-setup)
(ambient-context (and (>= 0.2) (< 0.3)))
(ocamlformat
(and
:with-dev-setup
@ -48,7 +49,7 @@
(depopts trace lwt eio)
(conflicts
(trace
(< 0.10)))
(< 0.11)))
(tags
(instrumentation tracing opentelemetry datadog jaeger)))

3
opentelemetry.opam
View file

@ -23,11 +23,12 @@ depends: [
"alcotest" {with-test}
"pbrt" {>= "3.0" & < "4.0"}
"ocaml-lsp-server" {with-dev-setup}
"ambient-context" {>= "0.2" & < "0.3"}
"ocamlformat" {with-dev-setup & >= "0.27" & < "0.28"}
]
depopts: ["trace" "lwt" "eio"]
conflicts: [
"trace" {< "0.10"}
"trace" {< "0.11"}
]
build: [
["dune" "subst"] {dev}

15
src/ambient-context/dune
View file

@ -1,15 +0,0 @@
(library
(name opentelemetry_ambient_context)
(public_name opentelemetry.ambient-context)
(synopsis
"Abstraction over thread-local storage and fiber-local storage mechanisms")
(private_modules hmap_key_)
(libraries
thread-local-storage
threads
atomic
opentelemetry.ambient-context.types
(select
hmap_key_.ml
from
(-> hmap_key_.new.ml))))

7
src/ambient-context/eio/dune
View file

@ -1,7 +0,0 @@
(library
(name opentelemetry_ambient_context_eio)
(public_name opentelemetry.ambient-context.eio)
(synopsis
"Storage backend for ambient-context using Eio's fibre-local storage")
(optional) ; eio
(libraries eio hmap opentelemetry.ambient-context thread-local-storage))

39
src/ambient-context/eio/opentelemetry_ambient_context_eio.ml
View file

@ -1,39 +0,0 @@
module Fiber = Eio.Fiber
open struct
let _internal_key : Hmap.t Fiber.key = Fiber.create_key ()
let ( let* ) = Option.bind
end
module M = struct
let name = "Storage_eio"
let[@inline] get_map () = Fiber.get _internal_key
let[@inline] with_map m cb = Fiber.with_binding _internal_key m cb
let create_key = Hmap.Key.create
let get k =
let* context = get_map () in
Hmap.find k context
let with_binding k v cb =
let new_context =
match get_map () with
| None -> Hmap.singleton k v
| Some old_context -> Hmap.add k v old_context
in
with_map new_context cb
let without_binding k cb =
let new_context =
match get_map () with
| None -> Hmap.empty
| Some old_context -> Hmap.rem k old_context
in
with_map new_context cb
end
let storage () : Opentelemetry_ambient_context.storage = (module M)

2
src/ambient-context/eio/opentelemetry_ambient_context_eio.mli
View file

@ -1,2 +0,0 @@
val storage : unit -> Opentelemetry_ambient_context.storage
(** Storage using Eio's fibers local storage *)

1
src/ambient-context/hmap_key_.new.ml
View file

@ -1 +0,0 @@
let key : Hmap.t Thread_local_storage.t = Thread_local_storage.create ()

7
src/ambient-context/lwt/dune
View file

@ -1,7 +0,0 @@
(library
(name opentelemetry_ambient_context_lwt)
(public_name opentelemetry.ambient-context.lwt)
(optional) ; lwt
(synopsis
"Storage backend for ambient-context using Lwt's sequence-associated storage")
(libraries lwt opentelemetry.ambient-context thread-local-storage))

37
src/ambient-context/lwt/opentelemetry_ambient_context_lwt.ml
View file

@ -1,37 +0,0 @@
open struct
let _internal_key : Hmap.t Lwt.key = Lwt.new_key ()
let ( let* ) = Option.bind
end
module M = struct
let name = "Storage_lwt"
let[@inline] get_map () = Lwt.get _internal_key
let[@inline] with_map m cb = Lwt.with_value _internal_key (Some m) cb
let create_key = Hmap.Key.create
let get k =
let* context = get_map () in
Hmap.find k context
let with_binding k v cb =
let new_context =
match get_map () with
| None -> Hmap.singleton k v
| Some old_context -> Hmap.add k v old_context
in
with_map new_context cb
let without_binding k cb =
let new_context =
match get_map () with
| None -> Hmap.empty
| Some old_context -> Hmap.rem k old_context
in
with_map new_context cb
end
let storage () : Opentelemetry_ambient_context.storage = (module M)

2
src/ambient-context/lwt/opentelemetry_ambient_context_lwt.mli
View file

@ -1,2 +0,0 @@
val storage : unit -> Opentelemetry_ambient_context.storage
(** Storage using Lwt keys *)

124
src/ambient-context/opentelemetry_ambient_context.ml
View file

@ -1,124 +0,0 @@
module TLS = Thread_local_storage
include Opentelemetry_ambient_context_types
type 'a key = int * 'a Hmap.key
let debug =
match Sys.getenv_opt "OCAML_AMBIENT_CONTEXT_DEBUG" with
| Some ("1" | "true") -> true
| _ -> false
let _debug_id_ = Atomic.make 0
let[@inline] generate_debug_id () = Atomic.fetch_and_add _debug_id_ 1
let compare_key : int -> int -> int = Stdlib.compare
module Storage_tls_hmap = struct
let[@inline] ( let* ) o f =
match o with
| None -> None
| Some x -> f x
let key : Hmap.t TLS.t = Hmap_key_.key
let name = "Storage_tls"
let[@inline] get_map () = TLS.get_opt key
let[@inline] with_map m cb =
let old = TLS.get_opt key |> Option.value ~default:Hmap.empty in
TLS.set key m;
Fun.protect ~finally:(fun () -> TLS.set key old) cb
let create_key = Hmap.Key.create
let get k =
let* context = get_map () in
Hmap.find k context
let with_binding k v cb =
let new_context =
match get_map () with
| None -> Hmap.singleton k v
| Some old_context -> Hmap.add k v old_context
in
with_map new_context @@ fun _context -> cb ()
let without_binding k cb =
match get_map () with
| None -> cb ()
| Some old_context ->
let new_context = Hmap.rem k old_context in
with_map new_context @@ fun _context -> cb ()
end
let default_storage : storage = (module Storage_tls_hmap)
let k_current_storage : storage TLS.t = TLS.create ()
let get_current_storage () =
match TLS.get_exn k_current_storage with
| v -> v
| exception TLS.Not_set ->
let v = default_storage in
TLS.set k_current_storage v;
v
let create_key () =
let (module Store : STORAGE) = get_current_storage () in
if not debug then
0, Store.create_key ()
else (
let id = generate_debug_id () in
Printf.printf "%s: create_key %i\n%!" Store.name id;
id, Store.create_key ()
)
let get (id, k) =
let (module Store : STORAGE) = get_current_storage () in
if not debug then
Store.get k
else (
let rv = Store.get k in
(match rv with
| Some _ -> Printf.printf "%s: get %i -> Some\n%!" Store.name id
| None -> Printf.printf "%s: get %i -> None\n%!" Store.name id);
rv
)
let with_binding : 'a key -> 'a -> (unit -> 'r) -> 'r =
fun (id, k) v cb ->
let (module Store : STORAGE) = get_current_storage () in
if not debug then
Store.with_binding k v cb
else (
Printf.printf "%s: with_binding %i enter\n%!" Store.name id;
let rv = Store.with_binding k v cb in
Printf.printf "%s: with_binding %i exit\n%!" Store.name id;
rv
)
let without_binding (id, k) cb =
let (module Store : STORAGE) = get_current_storage () in
if not debug then
Store.without_binding k cb
else (
Printf.printf "%s: without_binding %i enter\n%!" Store.name id;
let rv = Store.without_binding k cb in
Printf.printf "%s: without_binding %i exit\n%!" Store.name id;
rv
)
let set_storage_provider store_new =
let store_before = get_current_storage () in
if store_new == store_before then
()
else
TLS.set k_current_storage store_new;
if debug then (
let (module Store_before : STORAGE) = store_before in
let (module Store_new : STORAGE) = store_new in
Printf.printf "set_storage_provider %s (previously %s)\n%!" Store_new.name
Store_before.name
)

55
src/ambient-context/opentelemetry_ambient_context.mli
View file

@ -1,55 +0,0 @@
(** Ambient context.
The ambient context, like the Matrix, is everywhere around you.
It is responsible for keeping track of that context in a manner that's
consistent with the program's choice of control flow paradigm:
- for synchronous/threaded/direct style code, {b TLS} ("thread local
storage") keeps track of a global variable per thread. Each thread has its
own copy of the variable and updates it independently of other threads.
- for Lwt, any ['a Lwt.t] created inside the [with_binding k v (fun _ -> …)]
will inherit the [k := v] assignment.
- for Eio, fibers created inside [with_binding k v (fun () -> …)] will
inherit the [k := v] assignment. This is consistent with the structured
concurrency approach of Eio.
The only data stored by this storage is a {!Hmap.t}, ie a heterogeneous map.
Various users (libraries, user code, etc.) can create their own {!key} to
store what they are interested in, without affecting other parts of the
storage. *)
module Types := Opentelemetry_ambient_context_types
module type STORAGE = Types.STORAGE
type storage = (module STORAGE)
val default_storage : storage
val get_current_storage : unit -> storage
val set_storage_provider : storage -> unit
type 'a key
(** A key that can be mapped to values of type ['a] in the ambient context. *)
val compare_key : int -> int -> int
(** Total order on keys *)
val create_key : unit -> 'a key
(** Create a new fresh key, distinct from any previously created key. *)
val get : 'a key -> 'a option
(** Get the current value for a given key, or [None] if no value was associated
with the key in the ambient context. *)
val with_binding : 'a key -> 'a -> (unit -> 'r) -> 'r
(** [with_binding k v cb] calls [cb()] in a context in which [k] is bound to
[v]. This does not affect storage outside of [cb()]. *)
val without_binding : 'a key -> (unit -> 'b) -> 'b
(** [without_binding k cb] calls [cb()] in a context where [k] has no binding
(possibly shadowing the current ambient binding of [k] if it exists). *)

4
src/ambient-context/types/dune
View file

@ -1,4 +0,0 @@
(library
(name opentelemetry_ambient_context_types)
(public_name opentelemetry.ambient-context.types)
(libraries hmap thread-local-storage))

19
src/ambient-context/types/opentelemetry_ambient_context_types.ml
View file

@ -1,19 +0,0 @@
type 'a key = 'a Hmap.key
module type STORAGE = sig
val name : string
val get_map : unit -> Hmap.t option
val with_map : Hmap.t -> (unit -> 'b) -> 'b
val create_key : unit -> 'a key
val get : 'a key -> 'a option
val with_binding : 'a key -> 'a -> (unit -> 'b) -> 'b
val without_binding : 'a key -> (unit -> 'b) -> 'b
end
type storage = (module STORAGE)

32
src/ambient-context/types/opentelemetry_ambient_context_types.mli
View file

@ -1,32 +0,0 @@
(** Storage implementation.
There is a singleton storage for a given program, responsible for providing
ambient context to the rest of the program. *)
type 'a key = 'a Hmap.key
module type STORAGE = sig
val name : string
(** Name of the storage implementation. *)
val get_map : unit -> Hmap.t option
(** Get the hmap from the current ambient context, or [None] if there is no
ambient context. *)
val with_map : Hmap.t -> (unit -> 'b) -> 'b
(** [with_hmap h cb] calls [cb()] in an ambient context in which [get_map()]
will return [h]. Once [cb()] returns, the storage is reset to its previous
value. *)
val create_key : unit -> 'a key
(** Create a new storage key, guaranteed to be distinct from any previously
created key. *)
val get : 'a key -> 'a option
val with_binding : 'a key -> 'a -> (unit -> 'b) -> 'b
val without_binding : 'a key -> (unit -> 'b) -> 'b
end
type storage = (module STORAGE)

6
src/client/batch.mli
View file

@ -47,6 +47,6 @@ val pop_if_ready : ?force:bool -> now:Mtime.t -> 'a t -> 'a list option
batches before exit or because the user asks for it *)
val push : 'a t -> 'a list -> [ `Dropped | `Ok ]
(** [push b xs] is [`Ok] if it succeeds in pushing the values in [xs] into the batch
[b], or [`Dropped] if the current size of the batch has exceeded the high water
mark determined by the [batch] argument to [{!make}]. ) *)
(** [push b xs] is [`Ok] if it succeeds in pushing the values in [xs] into the
batch [b], or [`Dropped] if the current size of the batch has exceeded the
high water mark determined by the [batch] argument to [{!make}]. ) *)

3
src/core/dune
View file

@ -4,7 +4,8 @@
(flags :standard -warn-error -a+8)
(libraries
opentelemetry.proto
opentelemetry.ambient-context
ambient-context.core
ambient-context
ptime
ptime.clock.os
pbrt

9
src/core/opentelemetry.ml
View file

@ -4,7 +4,7 @@ open struct
let spf = Printf.sprintf
module Atomic = Opentelemetry_atomic.Atomic
module Ambient_context = Opentelemetry_ambient_context
module Ambient_context = Ambient_context
end
module Lock = Lock
@ -961,7 +961,7 @@ module Scope : sig
(** Set the span's kind.
@since 0.11 *)
val ambient_scope_key : t Ambient_context.key
val ambient_scope_key : t Ambient_context.Context.key
(** The opaque key necessary to access/set the ambient scope with
{!Ambient_context}. *)
@ -1097,7 +1097,8 @@ end = struct
let set_kind (scope : t) (k : Span_kind.t) : unit =
if Collector.has_backend () then scope.items <- Span_kind (k, scope.items)
let ambient_scope_key : t Ambient_context.key = Ambient_context.create_key ()
let ambient_scope_key : t Ambient_context.Context.key =
Ambient_context.new_key ()
let get_ambient_scope ?scope () : t option =
match scope with
@ -1105,7 +1106,7 @@ end = struct
| None -> Ambient_context.get ambient_scope_key
let[@inline] with_ambient_scope (sc : t) (f : unit -> 'a) : 'a =
Ambient_context.with_binding ambient_scope_key sc (fun _ -> f ())
Ambient_context.with_key_bound_to ambient_scope_key sc f
end
(** {2 Traces} *)

23
src/integrations/cohttp/opentelemetry_cohttp_lwt.ml
View file

@ -145,14 +145,21 @@ let client ?(scope : Otel.Scope.t option) (module C : Cohttp_lwt.S.Client) =
(* These types and values are not customized by our client, but are required to satisfy
[Cohttp_lwt.S.Client]. *)
include (C : sig
type ctx = C.ctx
type 'a io = 'a C.io
type 'a with_context = 'a C.with_context
type body = C.body
val map_context : 'a with_context -> ('a -> 'b) -> 'b with_context
val set_cache : Cohttp_lwt.S.call -> unit
end)
include (
C :
sig
type ctx = C.ctx
type 'a io = 'a C.io
type 'a with_context = 'a C.with_context
type body = C.body
val map_context : 'a with_context -> ('a -> 'b) -> 'b with_context
val set_cache : Cohttp_lwt.S.call -> unit
end)
let attrs_for ~uri ~meth:_ () =
[

2
src/trace/dune
View file

@ -3,4 +3,4 @@
(public_name opentelemetry.trace)
(synopsis "Use opentelemetry as a collector for trace")
(optional)
(libraries opentelemetry.ambient-context trace.core opentelemetry))
(libraries ambient-context.core ambient-context trace.core opentelemetry))

429
src/trace/opentelemetry_trace.ml
View file

@ -6,149 +6,32 @@ open struct
let spf = Printf.sprintf
end
module Conv = struct
let[@inline] trace_id_of_otel (id : Otel.Trace_id.t) : Otrace.trace_id =
if id == Otel.Trace_id.dummy then
Otrace.Collector.dummy_trace_id
else
Bytes.unsafe_to_string (Otel.Trace_id.to_bytes id)
let[@inline] trace_id_to_otel (id : Otrace.trace_id) : Otel.Trace_id.t =
if id == Otrace.Collector.dummy_trace_id then
Otel.Trace_id.dummy
else
Otel.Trace_id.of_bytes @@ Bytes.unsafe_of_string id
let[@inline] span_id_of_otel (id : Otel.Span_id.t) : Otrace.span =
if id == Otel.Span_id.dummy then
Otrace.Collector.dummy_span
else
Bytes.get_int64_le (Otel.Span_id.to_bytes id) 0
let[@inline] span_id_to_otel (id : Otrace.span) : Otel.Span_id.t =
if id == Otrace.Collector.dummy_span then
Otel.Span_id.dummy
else (
let b = Bytes.create 8 in
Bytes.set_int64_le b 0 id;
Otel.Span_id.of_bytes b
)
let[@inline] ctx_to_otel (self : Otrace.explicit_span_ctx) : Otel.Span_ctx.t =
Otel.Span_ctx.make
~trace_id:(trace_id_to_otel self.trace_id)
~parent_id:(span_id_to_otel self.span)
()
let[@inline] ctx_of_otel (ctx : Otel.Span_ctx.t) : Otrace.explicit_span_ctx =
{
trace_id = trace_id_of_otel (Otel.Span_ctx.trace_id ctx);
span = span_id_of_otel (Otel.Span_ctx.parent_id ctx);
}
end
open Conv
module Well_known = struct
let spankind_key = "otrace.spankind"
let internal = `String "INTERNAL"
let server = `String "SERVER"
let client = `String "CLIENT"
let producer = `String "PRODUCER"
let consumer = `String "CONSUMER"
let spankind_of_string =
let open Otel.Span in
function
| "INTERNAL" -> Span_kind_internal
| "SERVER" -> Span_kind_server
| "CLIENT" -> Span_kind_client
| "PRODUCER" -> Span_kind_producer
| "CONSUMER" -> Span_kind_consumer
| _ -> Span_kind_unspecified
let otel_attrs_of_otrace_data data =
let kind : Otel.Span.kind ref = ref Otel.Span.Span_kind_unspecified in
let data =
List.filter_map
(function
| name, `String v when name = "otrace.spankind" ->
kind := spankind_of_string v;
None
| x -> Some x)
data
in
!kind, data
(** Key to store an error [Otel.Span.status] with the message. Set
["otrace.error" = "mymsg"] in a span data to set the span's status to
[{message="mymsg"; code=Error}]. *)
let status_error_key = "otrace.error"
end
open Well_known
module Well_known = struct end
let on_internal_error =
ref (fun msg -> Printf.eprintf "error in Opentelemetry_trace: %s\n%!" msg)
type Otrace.extension_event +=
| Ev_link_span of Otrace.explicit_span * Otrace.explicit_span
| Ev_set_span_kind of Otrace.explicit_span * Otel.Span_kind.t
| Ev_record_exn of Otrace.explicit_span * exn * Printexc.raw_backtrace
module Internal = struct
type span_begin = {
module Span_info = struct
type t = {
start_time: int64;
name: string;
__FILE__: string;
__LINE__: int;
__FUNCTION__: string option;
scope: Otel.Scope.t;
parent: Otel.Span_ctx.t option;
}
end
module Active_span_tbl = Hashtbl.Make (struct
include Int64
type Otrace.span += Span_otel of Span_info.t
let hash : t -> int = Hashtbl.hash
end)
type Otrace.extension_event +=
| Ev_link_span of Otrace.span * Otrace.span
| Ev_set_span_kind of Otrace.span * Otel.Span_kind.t
| Ev_record_exn of Otrace.span * exn * Printexc.raw_backtrace
(** key to access a OTEL scope from an explicit span *)
let k_explicit_scope : Otel.Scope.t Otrace.Meta_map.key =
Otrace.Meta_map.Key.create ()
(** Per-thread set of active spans. *)
module Active_spans = struct
type t = { tbl: span_begin Active_span_tbl.t } [@@unboxed]
let create () : t = { tbl = Active_span_tbl.create 32 }
let k_tls : t TLS.t = TLS.create ()
let[@inline] get () : t =
try TLS.get_exn k_tls
with TLS.Not_set ->
let self = create () in
TLS.set k_tls self;
self
end
let otrace_of_otel (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 enter_span' ?(explicit_parent : Otrace.explicit_span_ctx option)
~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name =
module Internal = struct
let enter_span' ?(parent_span : Otrace.span option) ~__FUNCTION__ ~__FILE__
~__LINE__ ~data name : Span_info.t =
let open Otel in
let otel_id = Span_id.create () in
let otrace_id = otrace_of_otel otel_id in
let span_id = Span_id.create () in
let parent_scope = Scope.get_ambient_scope () in
let trace_id =
@ -157,215 +40,121 @@ module Internal = struct
| None -> Trace_id.create ()
in
let parent =
match explicit_parent, parent_scope with
| Some p, _ ->
Some
(Otel.Span_ctx.make ~trace_id ~parent_id:(span_id_to_otel p.span) ())
| None, Some parent -> Some (Otel.Scope.to_span_ctx parent)
| None, None -> None
match parent_span, parent_scope with
| Some (Span_otel parent_span), _ ->
Some (Otel.Scope.to_span_ctx parent_span.scope)
| _, Some sc -> Some (Otel.Scope.to_span_ctx sc)
| _, None -> None
in
let new_scope = Otel.Scope.make ~trace_id ~span_id:otel_id ~attrs:data () in
let new_scope = Otel.Scope.make ~trace_id ~span_id ~attrs:data () in
let start_time = Timestamp_ns.now_unix_ns () in
let sb =
{
start_time;
name;
__FILE__;
__LINE__;
__FUNCTION__;
scope = new_scope;
parent;
}
let attrs_function =
match __FUNCTION__ with
| None -> []
| Some __FUNCTION__ ->
(try
let last_dot = String.rindex __FUNCTION__ '.' in
let module_path = String.sub __FUNCTION__ 0 last_dot in
let function_name =
String.sub __FUNCTION__ (last_dot + 1)
(String.length __FUNCTION__ - last_dot - 1)
in
[
"code.function", `String function_name;
"code.namespace", `String module_path;
]
with Not_found -> [])
in
let active_spans = Active_spans.get () in
Active_span_tbl.add active_spans.tbl otrace_id sb;
(* directly store file, line, etc in scope *)
Otel.Scope.add_attrs new_scope (fun () ->
("code.filepath", `String __FILE__)
:: ("code.lineno", `Int __LINE__)
:: attrs_function);
otrace_id, sb
{ Span_info.start_time; name; scope = new_scope; parent }
let exit_span_
{ start_time; name; __FILE__; __LINE__; __FUNCTION__; scope; parent } =
let exit_span_ ({ name; start_time; scope; parent } : Span_info.t) :
Otel.Span.t =
let open Otel in
let end_time = Timestamp_ns.now_unix_ns () in
let kind, attrs = otel_attrs_of_otrace_data (Scope.attrs scope) in
let attrs = Scope.attrs scope in
let parent_id = Option.map Span_ctx.parent_id parent in
let kind = Scope.kind scope in
let status = Scope.status scope in
let status : Span_status.t =
match List.assoc_opt Well_known.status_error_key attrs with
| Some (`String message) -> { message; code = Status_code_error }
| _ -> { message = ""; code = Status_code_ok }
in
let attrs =
match __FUNCTION__ with
| None ->
[ "code.filepath", `String __FILE__; "code.lineno", `Int __LINE__ ]
@ attrs
| Some __FUNCTION__ ->
let last_dot = String.rindex __FUNCTION__ '.' in
let module_path = String.sub __FUNCTION__ 0 last_dot in
let function_name =
String.sub __FUNCTION__ (last_dot + 1)
(String.length __FUNCTION__ - last_dot - 1)
in
[
"code.filepath", `String __FILE__;
"code.lineno", `Int __LINE__;
"code.function", `String function_name;
"code.namespace", `String module_path;
]
@ attrs
in
let parent_id = Option.map Otel.Span_ctx.parent_id parent in
Span.create ~kind ~trace_id:scope.trace_id ?parent:parent_id ~status
Span.create ?kind ~trace_id:scope.trace_id ?parent:parent_id ?status
~id:scope.span_id ~start_time ~end_time ~attrs
~events:(Scope.events scope) name
~events:(Scope.events scope) ~links:(Scope.links scope) name
|> fst
let exit_span' otrace_id otel_span_begin =
let active_spans = Active_spans.get () in
Active_span_tbl.remove active_spans.tbl otrace_id;
exit_span_ otel_span_begin
let enter_span _st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level:_ ~params:_ ~data
~parent name : Otrace.span =
let parent_span =
match parent with
| Otrace.P_some sp -> Some sp
| _ -> None
in
let span_info =
enter_span' ?parent_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name
in
Span_otel span_info
let exit_span_from_id otrace_id =
let active_spans = Active_spans.get () in
match Active_span_tbl.find_opt active_spans.tbl otrace_id with
| None -> None
| Some otel_span_begin ->
Active_span_tbl.remove active_spans.tbl otrace_id;
Some (exit_span_ otel_span_begin)
let exit_span _st (span : Otrace.span) =
match span with
| Span_otel span_info ->
let otel_span = exit_span_ span_info in
Otel.Trace.emit [ otel_span ]
| _ -> ()
let[@inline] get_scope (span : Otrace.explicit_span) : Otel.Scope.t option =
Otrace.Meta_map.find k_explicit_scope span.meta
let add_data_to_span _st (span : Otrace.span) data =
match span with
| Span_otel span_info ->
Otel.Scope.add_attrs span_info.scope (fun () -> data)
| _ -> ()
module M = struct
let with_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name cb =
let otrace_id, sb =
enter_span' ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name
in
let message _st ~level:_ ~params:_ ~data:_ ~span msg : unit =
let trace_id, span_id =
match span with
| Some (Span_otel si) -> Some si.scope.trace_id, Some si.scope.span_id
| _ ->
(match Otel.Scope.get_ambient_scope () with
| None -> None, None
| Some scope -> Some scope.trace_id, Some scope.span_id)
in
Otel.Scope.with_ambient_scope sb.scope @@ fun () ->
match cb otrace_id with
| res ->
let otel_span = exit_span' otrace_id sb in
Otel.Trace.emit [ otel_span ];
res
| exception e ->
let bt = Printexc.get_raw_backtrace () in
let log = Otel.Logs.make_str ?trace_id ?span_id msg in
Otel.Logs.emit [ log ]
Otel.Scope.record_exception sb.scope e bt;
let otel_span = exit_span' otrace_id sb in
Otel.Trace.emit [ otel_span ];
Printexc.raise_with_backtrace e bt
let enter_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name :
Trace_core.span =
let otrace_id, _sb =
enter_span' ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data 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] *)
otrace_id
let exit_span otrace_id =
match exit_span_from_id otrace_id with
| None -> ()
| Some otel_span -> Otel.Trace.emit [ otel_span ]
let enter_manual_span ~(parent : Otrace.explicit_span_ctx option) ~flavor:_
~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name : Otrace.explicit_span =
let otrace_id, sb =
match parent with
| None -> enter_span' ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name
| Some parent ->
enter_span' ~explicit_parent:parent ~__FUNCTION__ ~__FILE__ ~__LINE__
~data name
in
let active_spans = Active_spans.get () in
Active_span_tbl.add active_spans.tbl otrace_id sb;
Otrace.
{
span = otrace_id;
trace_id = trace_id_of_otel sb.scope.trace_id;
meta = Meta_map.(empty |> add k_explicit_scope sb.scope);
}
let exit_manual_span Otrace.{ span = otrace_id; _ } =
let active_spans = Active_spans.get () in
match Active_span_tbl.find_opt active_spans.tbl otrace_id with
| None -> !on_internal_error (spf "no active span with ID %Ld" otrace_id)
| Some sb ->
let otel_span = exit_span' otrace_id sb in
Otel.Trace.emit [ otel_span ]
let add_data_to_span otrace_id data =
let active_spans = Active_spans.get () in
match Active_span_tbl.find_opt active_spans.tbl otrace_id with
| None -> !on_internal_error (spf "no active span with ID %Ld" otrace_id)
| Some sb -> Otel.Scope.add_attrs sb.scope (fun () -> data)
let add_data_to_manual_span (span : Otrace.explicit_span) data : unit =
match get_scope span with
| None ->
!on_internal_error (spf "manual span does not a contain an OTEL scope")
| Some scope -> Otel.Scope.add_attrs scope (fun () -> data)
let message ?span ~data:_ msg : unit =
(* gather information from context *)
let old_scope = Otel.Scope.get_ambient_scope () 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_id_to_otel 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 ~data name cur_val : unit =
let _kind, attrs = otel_attrs_of_otrace_data data in
let m = Otel.Metrics.(gauge ~name [ int ~attrs cur_val ]) in
let metric _st ~level:_ ~params:_ ~data:attrs name v =
let open Otrace.Core_ext in
match v with
| Metric_int i ->
let m = Otel.Metrics.(gauge ~name [ int ~attrs i ]) in
Otel.Metrics.emit [ m ]
let counter_float ~data name cur_val : unit =
let _kind, attrs = otel_attrs_of_otrace_data data in
let m = Otel.Metrics.(gauge ~name [ float ~attrs cur_val ]) in
| Metric_float f ->
let m = Otel.Metrics.(gauge ~name [ float ~attrs f ]) in
Otel.Metrics.emit [ m ]
| _ -> ()
let extension_event = function
| Ev_link_span (sp1, sp2) ->
(match get_scope sp1, get_scope sp2 with
| Some sc1, Some sc2 ->
Otel.Scope.add_links sc1 (fun () -> [ Otel.Scope.to_span_link sc2 ])
| _ -> !on_internal_error "could not find scope for OTEL span")
| Ev_set_span_kind (sp, k) ->
(match get_scope sp with
| None -> !on_internal_error "could not find scope for OTEL span"
| Some sc -> Otel.Scope.set_kind sc k)
| Ev_record_exn (sp, exn, bt) ->
(match get_scope sp with
| None -> !on_internal_error "could not find scope for OTEL span"
| Some sc -> Otel.Scope.record_exception sc exn bt)
| _ -> ()
end
let extension _st ~level:_ ev =
match ev with
| Ev_link_span (Span_otel sb1, Span_otel sb2) ->
Otel.Scope.add_links sb1.scope (fun () ->
[ Otel.Scope.to_span_link sb2.scope ])
| Ev_set_span_kind (Span_otel sb, k) -> Otel.Scope.set_kind sb.scope k
| Ev_record_exn (Span_otel sb, exn, bt) ->
Otel.Scope.record_exception sb.scope exn bt
| _ -> ()
let callbacks : unit Otrace.Collector.Callbacks.t =
Otrace.Collector.Callbacks.make ~enter_span ~exit_span ~add_data_to_span
~message ~metric ~extension ()
end
let link_spans (sp1 : Otrace.explicit_span) (sp2 : Otrace.explicit_span) : unit
=
let link_spans (sp1 : Otrace.span) (sp2 : Otrace.span) : unit =
if Otrace.enabled () then Otrace.extension_event @@ Ev_link_span (sp1, sp2)
let set_span_kind sp k : unit =
@ -374,7 +163,13 @@ let set_span_kind sp k : unit =
let record_exception sp exn bt : unit =
if Otrace.enabled () then Otrace.extension_event @@ Ev_record_exn (sp, exn, bt)
let collector () : Otrace.collector = (module Internal.M)
let with_ambient_span (sp : Otrace.span) f =
match sp with
| Span_otel sb -> Otel.Scope.with_ambient_scope sb.scope f
| _ -> f ()
let collector () : Otrace.collector =
Trace_core.Collector.C_some ((), Internal.callbacks)
let setup () = Otrace.setup_collector @@ collector ()

219
src/trace/opentelemetry_trace.mli
View file

@ -1,21 +1,3 @@
module Otel := Opentelemetry
module Otrace := Trace_core
module TLS := Thread_local_storage
module Conv : sig
val trace_id_of_otel : Otel.Trace_id.t -> string
val trace_id_to_otel : string -> Otel.Trace_id.t
val span_id_of_otel : Otel.Span_id.t -> int64
val span_id_to_otel : int64 -> Otel.Span_id.t
val ctx_to_otel : Otrace.explicit_span_ctx -> Otel.Span_ctx.t
val ctx_of_otel : Otel.Span_ctx.t -> Otrace.explicit_span_ctx
end
(** [opentelemetry.trace] implements a {!Trace_core.Collector} for
{{:https://v3.ocaml.org/p/trace} ocaml-trace}.
@ -23,33 +5,27 @@ end
that use [ocaml-trace], and they will automatically emit OpenTelemetry spans
and logs.
Both explicit scope (in the [_manual] functions such as [enter_manual_span])
and implicit scope (in {!Internal.M.with_span}, via {!Ambient_context}) are
supported; see the detailed notes on {!Internal.M.enter_manual_span}.
[Ambient_context] is used to propagate the current span to child spans.
{1:wellknown Well-known identifiers}
Because [ocaml-trace]'s API is a subset of OpenTelemetry functionality, this
interface allows for a few 'well-known' identifiers to be used in
[Trace]-instrumented libraries that wish to further support OpenTelemetry
usage.
(These strings will not change in subsequent versions of this library, so
you do not need to depend on [opentelemetry.trace] to use them.)
- If a key of exactly ["otrace.spankind"] is included in the
{!Trace_core.user_data} passed to [with_span] et al., it will be used as
the {!Opentelemetry.Span.kind} of the emitted span. (See
{!Internal.spankind_of_string} for the list of supported values.)
[Trace_core.extension_event] is used to expose OTEL-specific features on top
of the common tracing interface, e.g. to set the span kind:
{[
ocaml
let describe () = [ Opentelemetry_trace.(spankind_key, client) ] in
Trace_core.with_span ~__FILE__ ~__LINE__ ~data:describe "my-span"
@@ fun _ ->
(* ... *)
let@ span = Trace_core.with_span ~__FILE__ ~__LINE__ "my-span" in
Opentelemetry_trace.set_span_kind span Span_kind_client
(* ... *)
]} *)
module Otel := Opentelemetry
module Otrace := Trace_core
type Otrace.extension_event +=
| Ev_link_span of Otrace.span * Otrace.span
(** Link the two spans together. Both must be currently active spans. *)
| Ev_set_span_kind of Otrace.span * Otel.Span_kind.t
| Ev_record_exn of Otrace.span * exn * Printexc.raw_backtrace
(** Record exception and potentially turn span to an error *)
val on_internal_error : (string -> unit) ref
(** Callback to print errors in the library itself (ie bugs) *)
@ -62,166 +38,23 @@ val setup_with_otel_backend : Opentelemetry.Collector.backend -> unit
val collector : unit -> Trace_core.collector
(** Make a Trace collector that uses the OTEL backend to send spans and logs *)
val link_spans : Otrace.explicit_span -> Otrace.explicit_span -> unit
val link_spans : Otrace.span -> Otrace.span -> unit
(** [link_spans sp1 sp2] modifies [sp1] by adding a span link to [sp2].
@since 0.11 *)
val set_span_kind : Otrace.explicit_span -> Otel.Span.kind -> unit
val set_span_kind : Otrace.span -> Otel.Span_kind.t -> unit
(** [set_span_kind sp k] sets the span's kind.
@since 0.11 *)
val record_exception :
Otrace.explicit_span -> exn -> Printexc.raw_backtrace -> unit
val record_exception : Otrace.span -> exn -> Printexc.raw_backtrace -> unit
(** Record exception in the current span.
@since 0.11 *)
(** Static references for well-known identifiers; see {!label-wellknown}. *)
module Well_known : sig
val spankind_key : string
val with_ambient_span : Otrace.span -> (unit -> 'a) -> 'a
(** [with_ambient_span sp f] calls [f()] in an ambient context where [sp] is the
current span. *)
val internal : Otrace.user_data
val server : Otrace.user_data
val client : Otrace.user_data
val producer : Otrace.user_data
val consumer : Otrace.user_data
val spankind_of_string : string -> Otel.Span.kind
val otel_attrs_of_otrace_data :
(string * Otrace.user_data) list ->
Otel.Span.kind * Otel.Span.key_value list
end
[@@deprecated "use the regular functions for this"]
(**/**)
(** Internal implementation details; do not consider these stable. *)
module Internal : sig
module M : sig
val with_span :
__FUNCTION__:string option ->
__FILE__:string ->
__LINE__:int ->
data:(string * Otrace.user_data) list ->
string (* span name *) ->
(Otrace.span -> 'a) ->
'a
(** Implements {!Trace_core.Collector.S.with_span}, with the OpenTelemetry
collector as the backend. Invoked via {!Trace_core.with_span}.
Notably, this has the same implicit-scope semantics as
{!Opentelemetry.Trace.with_}, and requires configuration of
{!Ambient_context}.
@see <https://github.com/ELLIOTTCABLE/ocaml-ambient-context>
ambient-context docs *)
val enter_manual_span :
parent:Otrace.explicit_span_ctx option ->
flavor:'a ->
__FUNCTION__:string option ->
__FILE__:string ->
__LINE__:int ->
data:(string * Otrace.user_data) list ->
string (* span name *) ->
Otrace.explicit_span
(** Implements {!Trace_core.Collector.S.enter_manual_span}, with the
OpenTelemetry collector as the backend. Invoked at
{!Trace_core.enter_manual_toplevel_span} and
{!Trace_core.enter_manual_sub_span}; requires an eventual call to
{!Trace_core.exit_manual_span}.
These 'manual span' functions {e do not} implement the same implicit-
scope semantics of {!with_span}; and thus don't need to wrap a single
stack-frame / callback; you can freely enter a span at any point, store
the returned {!Trace_core.explicit_span}, and exit it at any later point
with {!Trace_core.exit_manual_span}.
However, for that same reason, they also cannot update the
{!Ambient_context} — that is, when you invoke the various [manual]
functions, if you then invoke other functions that use
{!Trace_core.with_span}, those callees {e will not} see the span you
entered manually as their [parent].
Generally, the best practice is to only use these [manual] functions at
the 'leaves' of your callstack: that is, don't invoke user callbacks
from within them; or if you do, make sure to pass the [explicit_span]
you recieve from this function onwards to the user callback, so they can
create further child-spans. *)
val exit_manual_span : Otrace.explicit_span -> unit
(** Implements {!Trace_core.Collector.S.exit_manual_span}, with the
OpenTelemetry collector as the backend. Invoked at
{!Trace_core.exit_manual_span}. Expects the [explicit_span] returned
from an earlier call to {!Trace_core.enter_manual_toplevel_span} or
{!Trace_core.enter_manual_sub_span}.
(See the notes at {!enter_manual_span} about {!Ambient_context}.) *)
val add_data_to_span :
Otrace.span -> (string * Otrace.user_data) list -> unit
val add_data_to_manual_span :
Otrace.explicit_span -> (string * Otrace.user_data) list -> unit
val message :
?span:Otrace.span ->
data:(string * Otrace.user_data) list ->
string ->
unit
val shutdown : unit -> unit
val name_process : string -> unit
val name_thread : string -> unit
val counter_int :
data:(string * Otrace.user_data) list -> string -> int -> unit
val counter_float :
data:(string * Otrace.user_data) list -> string -> float -> unit
end
type span_begin = {
start_time: int64;
name: string;
__FILE__: string;
__LINE__: int;
__FUNCTION__: string option;
scope: Otel.Scope.t;
parent: Otel.Span_ctx.t option;
}
module Active_span_tbl : Hashtbl.S with type key = Otrace.span
(** Table indexed by ocaml-trace spans. *)
module Active_spans : sig
type t = private { tbl: span_begin Active_span_tbl.t } [@@unboxed]
val create : unit -> t
val k_tls : t TLS.t
val get : unit -> t
end
val otrace_of_otel : Otel.Span_id.t -> Otrace.span
val enter_span' :
?explicit_parent:Otrace.explicit_span_ctx ->
__FUNCTION__:string option ->
__FILE__:string ->
__LINE__:int ->
data:(string * Otrace.user_data) list ->
string ->
Otrace.span * span_begin
val exit_span' : Otrace.span -> span_begin -> Otel.Span.t
end
(**/**)
module Well_known : sig end
[@@deprecated
"use the regular functions such as `link_spans` or `set_span_kind` for this"]
(** Static references for well-known identifiers *)

5
tests/bin/dune
View file

@ -48,8 +48,7 @@
opentelemetry-client-cohttp-lwt
opentelemetry-cohttp-lwt
opentelemetry-logs
logs
))
logs))
(executable
(name cohttp_client)
@ -59,5 +58,3 @@
opentelemetry
opentelemetry-client-cohttp-lwt
opentelemetry-cohttp-lwt))

12
tests/logs/dune
View file

@ -3,16 +3,10 @@
; Make the binaries for the test emitters available on the path for the components defined in this dir.
; See https://dune.readthedocs.io/en/stable/reference/dune/env.html
(binaries
(../bin/emit_logs_cohttp.exe as emit_logs_cohttp)
)))
(../bin/emit_logs_cohttp.exe as emit_logs_cohttp))))
(tests
(names test_logs_e2e)
(package opentelemetry-logs)
(libraries
opentelemetry
opentelemetry-logs
signal_gatherer
alcotest)
(deps %{bin:emit_logs_cohttp})
)
(libraries opentelemetry opentelemetry-logs signal_gatherer alcotest)
(deps %{bin:emit_logs_cohttp}))