feat log: richer metadata, various ways to set it

src/log/imandrakit_log.ml

@@ -7,6 +7,7 @@ module Log_ctx = Log_ctx
 module Log_event = Log_event
 module Log_google = Log_google
 module Log_level = Log_level
+module Log_meta = Log_meta
 module Log_reader = Log_reader
 module Logger = Logger
 module Trace_async = Trace_async

src/log/log_ctx.ml

@@ -3,18 +3,23 @@ module LS = Moonpool.Task_local_storage
 type 'a tag = 'a Logs.Tag.def
 
 (** Storage key for the ambient context. *)
-let ctx_k : Logs.Tag.t Str_map.t LS.t = LS.create ()
+let ctx_k : Logs.Tag.t Str_map.t Hmap.key = Hmap.Key.create ()
 
 let create_tag ?doc name pp : _ tag = Logs.Tag.def ?doc name pp
 
 let get_tags_from_ctx () : Logs.Tag.set =
-  let map = LS.get ~default:Str_map.empty ctx_k in
+  let map =
+    LS.get_in_local_hmap_opt ctx_k |> Option.value ~default:Str_map.empty
+  in
   (* build the current set of tags *)
   Str_map.fold
     (fun _ (Logs.Tag.V (tag, v)) set -> Logs.Tag.add tag v set)
     map Logs.Tag.empty
 
 let with_tag (tag : _ tag) v (f : unit -> 'b) : 'b =
-  let old_map = LS.get ~default:Str_map.empty ctx_k in
+  let old_map =
+    LS.get_in_local_hmap_opt ctx_k |> Option.value ~default:Str_map.empty
+  in
   let new_map = Str_map.add (Logs.Tag.name tag) (Logs.Tag.V (tag, v)) old_map in
-  LS.with_value ctx_k new_map f
+  LS.set_in_local_hmap ctx_k new_map;
+  Fun.protect ~finally:(fun () -> LS.set_in_local_hmap ctx_k old_map) f

src/log/log_event.ml

@@ -10,7 +10,7 @@ type t = {
   ts: float;  (** Timestamp, in seconds, since the UNIX epoch. *)
   msg: string;  (** Log message. *)
   src: string;  (** Log source. *)
-  meta: (string * string) list;  (** Additional metadata *)
+  meta: (string * Log_meta.t) list;  (** Additional metadata *)
 }
 [@@deriving show { with_path = false }, serpack, twine]
 (** A log event, which we can store, serialize, send elsewhere, etc. *)
@@ -26,7 +26,8 @@ let to_yojson : t -> json =
   let meta_dict : (string * json) list =
     match meta with
     | [] -> []
-    | _ -> [ "meta", `Assoc (List.map (fun (k, v) -> k, `String v) meta) ]
+    | _ ->
+      [ "meta", `Assoc (List.map (fun (k, v) -> k, Log_meta.to_yojson v) meta) ]
   in
   `Assoc
     (meta_dict
@@ -56,7 +57,7 @@ let of_yojson_ (j : json) : t Err.result =
       match JU.member "meta" j with
       | exception _ -> []
       | `Null -> []
-      | `Assoc l -> List.map (fun (k, v) -> k, JU.to_string v) l
+      | `Assoc l -> List.map (fun (k, v) -> k, Log_meta.of_yojson v) l
       | _ -> Err.fail ~kind:json_error "expected null or object for 'meta'"
     in
     Ok { lvl; ts; msg; src; meta }

src/log/log_google.ml

@@ -10,16 +10,14 @@ let level_to_severity (l : Log_level.t) : string =
 
 let event_to_json ?(other_fields = []) (ev : Log_event.t) : json =
   let { Log_event.lvl; msg; ts; src; meta } = ev in
-  let labels = List.rev_map (fun (k, v) -> k, `String v) meta in
-  let labels = ("src", `String src) :: labels in
+  let meta = List.rev_map (fun (k, v) -> k, Log_meta.to_yojson v) meta in
   let msg = Ansi_clean.remove_escape_codes msg in
   let fields =
-    [
-      "severity", `String (level_to_severity lvl);
-      "timestamp", `String (Timestamp_s.to_string_rfc3339 ~tz_offset_s:0 ts);
-      "textPayload", `String msg;
-      "labels", `Assoc labels;
-    ]
+    ("severity", `String (level_to_severity lvl))
+    :: ("timestamp", `String (Timestamp_s.to_string_rfc3339 ~tz_offset_s:0 ts))
+    :: ("message", `String msg)
+    :: ("imandrax.src", `String src)
+    :: meta
   in
   `Assoc (List.rev_append other_fields fields)
 

src/log/log_meta.ml

@@ -0,0 +1,54 @@
+module Err = Imandrakit_error.Error
+
+(** Meta data *)
+type t =
+  | Null
+  | String of string
+  | Bool of bool
+  | Int of int
+  | Float of float
+  | List of t list
+  | Assoc of (string * t) list
+[@@deriving show { with_path = false }, serpack, twine, eq]
+
+let k_meta : t Hmap.key = Hmap.Key.create ()
+
+type json = Yojson.Safe.t
+
+let rec to_yojson (m : t) : json =
+  match m with
+  | Null -> `Null
+  | String s -> `String s
+  | Bool b -> `Bool b
+  | Int i -> `Int i
+  | Float f -> `Float f
+  | List l -> `List (List.map to_yojson l)
+  | Assoc l -> `Assoc (List.map (fun (k, v) -> k, to_yojson v) l)
+
+let to_trace_data (m : t) : Trace.user_data =
+  match m with
+  | Null -> `None
+  | String s -> `String s
+  | Bool b -> `Bool b
+  | Int i -> `Int i
+  | Float f -> `Float f
+  | List _ | Assoc _ -> `String (show m)
+
+open struct
+  let json_error = Err.Kind.make ~name:"LogJsonError" ()
+end
+
+let rec of_yojson (j : json) : t =
+  match j with
+  | `Null -> Null
+  | `String s -> String s
+  | `Bool b -> Bool b
+  | `Float f -> Float f
+  | `Intlit i ->
+    (try Int (int_of_string i)
+     with _ -> Err.failf ~kind:json_error "invalid int lit %S" i)
+  | `Int i -> Int i
+  | `List l -> List (List.map of_yojson l)
+  | `Assoc l -> Assoc (List.map (fun (k, v) -> k, of_yojson v) l)
+  | `Tuple _ | `Variant _ ->
+    Err.failf ~kind:json_error "unsupported json for Log_event.meta"

src/log/log_reader.ml

@@ -6,7 +6,7 @@ class type t = object
 
   method read_events :
     only_above_level:Logger.level option ->
-    filter_meta:(string * string) list ->
+    filter_meta:(string * Log_meta.t) list ->
     unit ->
     Logger.Log_event.t Iter.t
 end
@@ -25,7 +25,7 @@ let accept_ev ~only_above_level ~filter_meta (ev : Log_event.t) : bool =
   && List.for_all
        (fun (k, v) ->
          match List.assoc_opt k ev.meta with
-         | Some v' -> v = v'
+         | Some v' -> Log_meta.equal v v'
          | None -> false)
        filter_meta
 
@@ -34,7 +34,7 @@ module File_json_l = struct
     file: string;
     buf: Buffer.t;
     only_above_level: Log_level.t option;
-    filter_meta: (string * string) list;
+    filter_meta: (string * Log_meta.t) list;
   }
 
   (** read a single line *)

src/log/log_reader.mli

@@ -9,7 +9,7 @@ class type t = object
 
   method read_events :
     only_above_level:Logger.level option ->
-    filter_meta:(string * string) list ->
+    filter_meta:(string * Log_meta.t) list ->
     unit ->
     Logger.Log_event.t Iter.t
   (** Read events, in order, from the underlying log source.
@@ -24,7 +24,7 @@ class dummy : t
 
 val accept_ev :
   only_above_level:Logs.level option ->
-  filter_meta:(string * string) list ->
+  filter_meta:(string * Log_meta.t) list ->
   Log_event.t ->
   bool
 

src/log/logger.ml

@@ -131,6 +131,54 @@ type task =
   | T_fence of { wakeup: unit Moonpool.Fut.promise }
   | T_emit of Log_event.t
 
+type capture_meta_hook = unit -> (string * Log_meta.t) list
+
+open struct
+  let capture_meta_hooks : capture_meta_hook list Atomic.t = Atomic.make []
+
+  let add_capture_meta_hook c =
+    while
+      let l = Atomic.get capture_meta_hooks in
+      not (Atomic.compare_and_set capture_meta_hooks l (c :: l))
+    do
+      ()
+    done
+
+  let add_hooks_results l : _ list =
+    let hooks = Atomic.get capture_meta_hooks in
+    List.fold_left (fun l h -> List.rev_append (h ()) l) l hooks
+end
+
+let add_capture_meta_hook = add_capture_meta_hook
+
+open struct
+  module LS = Moonpool.Task_local_storage
+
+  let k_ambient_meta : Log_meta.t Str_map.t Hmap.key = Hmap.Key.create ()
+
+  let get_ambient_meta_ () =
+    LS.get_in_local_hmap_opt k_ambient_meta
+    |> Option.value ~default:Str_map.empty
+
+  let add_ambient_meta_ k v : unit =
+    let old_map = get_ambient_meta_ () in
+    let new_map = Str_map.add k v old_map in
+    LS.set_in_local_hmap k_ambient_meta new_map
+
+  let with_ambient_meta_ k v f =
+    let old_map = get_ambient_meta_ () in
+    let new_map = Str_map.add k v old_map in
+    LS.set_in_local_hmap k_ambient_meta new_map;
+    Fun.protect f ~finally:(fun () ->
+        LS.set_in_local_hmap k_ambient_meta old_map)
+
+  let[@inline] add_ambient_meta_to_list l : _ list =
+    Str_map.fold (fun k v l -> (k, v) :: l) (get_ambient_meta_ ()) l
+end
+
+let add_ambient_meta = add_ambient_meta_
+let with_ambient_meta = with_ambient_meta_
+
 type t = {
   q: task Sync_queue.t;
   events: Log_event.t Observer.t;
@@ -166,20 +214,24 @@ let add_tags_to_meta (tags : Logs.Tag.set) acc : _ list =
     (fun (Logs.Tag.V (t_def, v)) l ->
       let k = Logs.Tag.name t_def in
       let v = Fmt.to_string (Logs.Tag.printer t_def) v in
-      (k, v) :: l)
+      (k, Log_meta.String v) :: l)
     tags acc
 
 let to_event_if_ (p : level -> bool) ~emit_ev : Logs.reporter =
   let report src level ~over k msgf =
     if p level then (
       let ts = Util.ptime_now () in
       let src = name_of_src src in
+
       (* get surrounding tags *)
       let ambient_tags = Log_ctx.get_tags_from_ctx () in
 
       let k (tags : Logs.Tag.set) msg =
+        (* gather all metadata in this spot *)
         let meta =
-          [] |> add_tags_to_meta tags |> add_tags_to_meta ambient_tags
+          [] |> add_tags_to_meta tags
+          |> add_tags_to_meta ambient_tags
+          |> add_ambient_meta_to_list |> add_hooks_results
         in
         let ev = { Log_event.msg; ts; src; lvl = level; meta } in
 
@@ -188,9 +240,12 @@ let to_event_if_ (p : level -> bool) ~emit_ev : Logs.reporter =
         if Trace_core.enabled () then (
           let msg = Ansi_clean.remove_escape_codes msg in
           Trace_core.message msg ~data:(fun () ->
-              let meta = List.map (fun (k, v) -> k, `String v) meta in
-              [ "src", `String ev.src; "lvl", `String (show_level level) ]
-              @ meta)
+              let meta =
+                List.map (fun (k, v) -> k, Log_meta.to_trace_data v) meta
+              in
+              ("src", `String ev.src)
+              :: ("lvl", `String (show_level level))
+              :: meta)
         );
 
         emit_ev ev;

src/log/logger.mli

@@ -31,6 +31,19 @@ module Output : sig
       a short period of time. *)
 end
 
+type capture_meta_hook = unit -> (string * Log_meta.t) list
+(** A metadata capture hook, returning a list of metadata *)
+
+val add_capture_meta_hook : capture_meta_hook -> unit
+(** Add a global hook, called at logging point to capture
+  metadata from the ambient context. *)
+
+val add_ambient_meta : string -> Log_meta.t -> unit
+(** [add_ambient_meta str v] sets a piece of metadata for all subsequent
+    calls to the logger in the current task *)
+
+val with_ambient_meta : string -> Log_meta.t -> (unit -> 'a) -> 'a
+
 type t
 (** Main logger. This obtains events from {!Logs} and
     writes them to the current set of {!Output.t}. *)