wip

dune-project

@@ -28,7 +28,8 @@
    (>= "4.08"))
   ptime
   hmap
-  ambient-context
+  atomic
+  (thread-local-storage (and (>= 0.2) (< 0.3)))
   (odoc :with-doc)
   (alcotest :with-test)
   (pbrt

src/ambient-context/eio/ambient_context_eio.ml

@@ -0,0 +1,37 @@
+module TLS = Ambient_context_thread_local.Thread_local
+module Hmap = Ambient_context.Hmap
+module Fiber = Eio.Fiber
+
+let _internal_key : Hmap.t Fiber.key = Fiber.create_key ()
+let ( let* ) = Option.bind
+
+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 () : Ambient_context.storage = (module M)

src/ambient-context/eio/dune.tmp

@@ -0,0 +1,6 @@
+(library
+ (name ambient_context_eio)
+ (synopsis
+  "Storage backend for ambient-context using Eio's fibre-local storage")
+ (public_name ambient-context-eio)
+ (libraries eio ambient-context ambient-context.thread_local))

src/ambient-context/lwt/ambient_context_lwt.ml

@@ -0,0 +1,35 @@
+module Hmap = Ambient_context.Hmap
+
+let _internal_key : Hmap.t Lwt.key = Lwt.new_key ()
+let ( let* ) = Option.bind
+
+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 () : Ambient_context.storage = (module M)

src/ambient-context/lwt/dune.tmp

@@ -0,0 +1,6 @@
+(library
+ (name ambient_context_lwt)
+ (synopsis
+  "Storage backend for ambient-context using Lwt's sequence-associated storage")
+ (public_name ambient-context-lwt)
+ (libraries lwt ambient-context ambient-context.tls))

src/core/dune

@@ -2,6 +2,6 @@
  (name opentelemetry)
  (synopsis "API for opentelemetry instrumentation")
  (flags :standard -warn-error -a+8)
- (libraries opentelemetry.proto ambient-context ptime ptime.clock.os pbrt threads
+ (libraries opentelemetry.proto opentelemetry.ambient-context ptime ptime.clock.os pbrt threads
    opentelemetry.atomic hmap)
  (public_name opentelemetry))

src/core/opentelemetry.ml

@@ -2,6 +2,8 @@
 
 open struct
   let spf = Printf.sprintf
+
+  module Ambient_context = Opentelemetry_ambient_context
 end
 
 module Lock = Lock