feat: add Logs integration

This PR upstreams the logs integration I wrote for Semgrep, and that
we've been using succesfully for months!

dune-project

@@ -88,6 +88,19 @@
   (alcotest :with-test))
  (synopsis "Collector client for opentelemetry, using http + ezcurl"))
 
+(package
+ (name opentelemetry-logs)
+ (depends
+  (ocaml
+   (>= "4.08"))
+  (opentelemetry
+   (= :version))
+  (odoc :with-doc)
+  (logs
+   (>= "0.7.0"))
+  (alcotest :with-test))
+ (synopsis "Opentelemetry tracing for Cohttp HTTP servers"))
+
 (package
  (name opentelemetry-cohttp-lwt)
  (depends

opentelemetry-logs.opam

@@ -0,0 +1,38 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+version: "0.11.2"
+synopsis: "Opentelemetry tracing for Cohttp HTTP servers"
+maintainer: [
+  "Simon Cruanes <simon.cruanes.2007@m4x.org>"
+  "Matt Bray <mattjbray@gmail.com>"
+  "ELLIOTTCABLE <opam@ell.io>"
+]
+authors: ["the Imandra team and contributors"]
+license: "MIT"
+homepage: "https://github.com/imandra-ai/ocaml-opentelemetry"
+bug-reports: "https://github.com/imandra-ai/ocaml-opentelemetry/issues"
+depends: [
+  "dune" {>= "2.9"}
+  "ocaml" {>= "4.08"}
+  "opentelemetry" {= version}
+  "odoc" {with-doc}
+  "logs" {>= "0.7.0"}
+  "alcotest" {with-test}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "--promote-install-files=false"
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+  ["dune" "install" "-p" name "--create-install-files" name]
+]
+dev-repo: "git+https://github.com/imandra-ai/ocaml-opentelemetry.git"

src/integrations/logs/dune

@@ -0,0 +1,4 @@
+(library
+ (name opentelemetry_logs)
+ (public_name opentelemetry-logs)
+ (libraries opentelemetry logs))

src/integrations/logs/opentelemetry_logs.ml

@@ -0,0 +1,115 @@
+module Otel = Opentelemetry
+
+(*****************************************************************************)
+(* Prelude *)
+(*****************************************************************************)
+(* This module is for sending logs from the Logs library
+   (https://github.com/dbuenzli/logs) via OTel. It is NOT a general logging
+   library (See Logs for that).
+*)
+(*****************************************************************************)
+(* Levels *)
+(*****************************************************************************)
+(* Convert log level to Otel severity *)
+let log_level_to_severity (level : Logs.level) : Otel.Logs.severity =
+  match level with
+  | Logs.App -> Otel.Logs.Severity_number_info (* like info, but less severe  *)
+  | Logs.Info -> Otel.Logs.Severity_number_info2
+  | Logs.Error -> Otel.Logs.Severity_number_error
+  | Logs.Warning -> Otel.Logs.Severity_number_warn
+  | Logs.Debug -> Otel.Logs.Severity_number_debug
+
+(*****************************************************************************)
+(* Logs Util *)
+(*****************************************************************************)
+
+let create_tag (tag : string) : string Logs.Tag.def =
+  Logs.Tag.def tag Format.pp_print_string
+
+let emit_telemetry_tag =
+  Logs.Tag.def ~doc:"Whether or not to emit this log via telemetry"
+    "emit_telemetry" Format.pp_print_bool
+
+let emit_telemetry do_emit = Logs.Tag.(empty |> add emit_telemetry_tag do_emit)
+
+(*****************************************************************************)
+(* Logging *)
+(*****************************************************************************)
+
+(* Log a message to otel with some attrs *)
+let log ?service_name ?(attrs = []) ?(scope = Otel.Scope.get_ambient_scope ())
+    ~level msg =
+  let log_level = Logs.level_to_string (Some level) in
+  let span_id =
+    Option.map (fun (scope : Otel.Scope.t) -> scope.span_id) scope
+  in
+  let trace_id =
+    Option.map (fun (scope : Otel.Scope.t) -> scope.trace_id) scope
+  in
+  let severity = log_level_to_severity level in
+  let log = Otel.Logs.make_str ~severity ~log_level ?trace_id ?span_id msg in
+  (* Noop if no backend is set *)
+  Otel.Logs.emit ?service_name ~attrs [ log ]
+
+let otel_reporter ?service_name ?(attributes = []) () : Logs.reporter =
+  let report src level ~over k msgf =
+    msgf (fun ?header ?(tags : Logs.Tag.set option) fmt ->
+        let k _ =
+          over ();
+          k ()
+        in
+        Format.kasprintf
+          (fun msg ->
+            let tags = Option.value ~default:Logs.Tag.empty tags in
+            let attrs =
+              let tags =
+                Logs.Tag.fold
+                  (fun (Logs.Tag.(V (d, v)) : Logs.Tag.t) acc ->
+                    let name = Logs.Tag.name d in
+                    (* Is there a better way to compare tags? structural equality does not work *)
+                    if String.equal name (Logs.Tag.name emit_telemetry_tag) then
+                      (* Don't include the emit_telemetry_tag in the attributes *)
+                      acc
+                    else (
+                      let value =
+                        let value_printer = Logs.Tag.printer d in
+                        (* Also the default for Format.asprintf *)
+                        let buffer = Buffer.create 512 in
+                        let formatter = Format.formatter_of_buffer buffer in
+                        value_printer formatter v;
+                        Buffer.contents buffer
+                      in
+                      let s = name, `String value in
+                      s :: acc
+                    ))
+                  tags []
+              in
+              let header =
+                match header with
+                | None -> []
+                | Some h -> [ "header", `String h ]
+              in
+              let src_str = Logs.Src.name src in
+              header @ [ "src", `String src_str ] @ tags @ attributes
+            in
+            let do_emit =
+              Option.value ~default:true (Logs.Tag.find emit_telemetry_tag tags)
+            in
+            if do_emit then log ?service_name ~attrs ~level msg;
+            k ())
+          fmt)
+  in
+  { Logs.report }
+
+let attach_otel_reporter ?service_name ?attributes reporter =
+  (* Copied directly from the Logs.mli docs. Just calls a bunch of reporters in a
+   row *)
+  let combine r1 r2 =
+    let report src level ~over k msgf =
+      let v = r1.Logs.report src level ~over:(fun () -> ()) k msgf in
+      r2.Logs.report src level ~over (fun () -> v) msgf
+    in
+    { Logs.report }
+  in
+  let otel_reporter = otel_reporter ?service_name ?attributes () in
+  combine reporter otel_reporter

src/integrations/logs/opentelemetry_logs.mli

@@ -0,0 +1,79 @@
+val emit_telemetry_tag : bool Logs.Tag.def
+(** [emit_telemetry_tag] is a logging tag that when applied to a log, determines
+    if a log will be emitted by the tracing/telemetry backend.
+
+    Since some OTel backends can cause deadlocks if used during a GC alarm, this
+    is useful for when you may want logging during a GC alarm. It is also useful
+    if you want to log sensitive information, but not report it via
+    Opentelemetry.
+
+    If this tag is not set on a log, said log will be emitted by default if the
+    otel reporter is registered.
+
+    Example:
+    {[
+      let tags =
+        Logs.Tag.(add Opentelemetry_logs.emit_telemetry_tag false other_tags)
+      in
+      Logs.info (fun m ->
+          m ~tags "This log will not be sent to the telemetry backend")
+    ]} *)
+
+val emit_telemetry : bool -> Logs.Tag.set
+(** [emit_telemetry emit_or_not] creates a tag set with the
+    {!emit_telemetry_tag} as its only member *)
+
+val otel_reporter :
+  ?service_name:string ->
+  ?attributes:(string * Opentelemetry.value) list ->
+  unit ->
+  Logs.reporter
+(** [otel_reporter ?service_name ?tag_value_pp_buffer_size ?attrs ()] creates a
+    [Logs.reporter] that will create and emit an OTel log with the following
+    info:
+    {ul
+     {- Log severity is converted to OTel severity as follows:
+        {[
+          module Otel = Opentelemetry
+          match level with
+          | Logs.App -> Otel.Logs.Severity_number_info (* like info, but less severe  *)
+          | Logs.Info -> Otel.Logs.Severity_number_info2
+          | Logs.Error -> Otel.Logs.Severity_number_error
+          | Logs.Warning -> Otel.Logs.Severity_number_warn
+          | Logs.Debug -> Otel.Logs.Severity_number_debug
+        ]}
+     }
+     {- message is the formatted with the given [fmt] and [msgf] function, and
+        emitted as the log body
+     }
+     {- [header] and [src] will be added as attributes
+        [("header", `String header)] and [("src", `String (Logs.Src.name src))]
+        respectively
+     }
+     {- [tags] will be also added as attributes, with the tag name as the key,
+        and the value formatted via its formatter as the value.
+     }
+     {- [attributes] will also be added as attributes, and are useful for
+        setting static attributes such as a library name
+     }
+    }
+
+    Example use: [Logs.set_reporter (Opentelemetery_logs.otel_reporter ())] *)
+
+val attach_otel_reporter :
+  ?service_name:string ->
+  ?attributes:(string * Opentelemetry.value) list ->
+  Logs.reporter ->
+  Logs.reporter
+(** [attach_otel_reporter ?service_name ?attributes reporter] will create a
+    reporter that first calls the reporter passed as an argument, then an otel
+    report created via {!otel_reporter}, for every log. This is useful for if
+    you want to emit logs to stderr and to OTel at the same time.
+
+    Example:
+    {[
+      let reporter = Logs_fmt.reporter () in
+      Logs.set_reporter
+        (Opentelemetry_logs.attach_otel_reporter ?service_name ?attributes
+           reporter)
+    ]} *)

tests/bin/dune

@@ -37,6 +37,20 @@
   opentelemetry.client
   opentelemetry-client-cohttp-eio))
 
+(executable
+ (name emit_logs_cohttp)
+ (modules emit_logs_cohttp)
+ (preprocess
+  (pps lwt_ppx))
+ (libraries
+  cohttp-lwt-unix
+  opentelemetry
+  opentelemetry-client-cohttp-lwt
+  opentelemetry-cohttp-lwt
+  opentelemetry-logs
+  logs
+))
+
 (executable
  (name cohttp_client)
  (modules cohttp_client)
@@ -45,3 +59,5 @@
   opentelemetry
   opentelemetry-client-cohttp-lwt
   opentelemetry-cohttp-lwt))
+
+