feat: parse W3C traceparent header

emit1.sh

@@ -1,2 +1,2 @@
 #!/bin/sh
-exec dune exec --profile=release tests/emit1.exe -- $@
+exec dune exec --profile=release tests/bin/emit1.exe -- $@

src/opentelemetry.ml

@@ -579,3 +579,74 @@ module Metrics = struct
     let rm = make_resource_metrics ?attrs l in
     Collector.send_metrics [rm] ~ret:ignore
 end
+
+
+module Trace_context = struct
+  (** Implementation of the W3C Trace Context spec
+
+      https://www.w3.org/TR/trace-context/
+   *)
+
+  module Traceparent = struct
+    (** The traceparent header
+        https://www.w3.org/TR/trace-context/#traceparent-header
+    *)
+
+    let name = "traceparent"
+
+    (** Parse the value of the traceparent header.
+
+        The values are of the form:
+
+            {version}-{trace_id}-{parent_id}-{flags}
+
+        For example:
+
+            00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01
+
+        {flags} are currently ignored.
+     *)
+    let of_value str : (Trace_id.t * Span_id.t, string) result =
+      let ( let* ) = Result.bind in
+      let blit ~offset ~len ~or_ =
+        let buf = Bytes.create len in
+        let* str =
+          match Bytes.blit_string str offset buf 0 len with
+          | () -> Ok (Bytes.to_string buf)
+          | exception Invalid_argument _ -> Error or_
+        in
+        Ok (str, offset + len)
+      in
+      let consume expected ~offset ~or_ =
+        let len = String.length expected in
+        let* str, offset = blit ~offset ~len ~or_ in
+        (* Printf.printf "got %S\n%!" str; *)
+        if str = expected then Ok offset else Error or_
+      in
+      let offset = 0 in
+      let* offset = consume "00" ~offset ~or_:"Expected version 00" in
+      let* offset = consume "-" ~offset ~or_:"Expected delimiter" in
+      let* trace_id, offset = blit ~offset ~len:32 ~or_:"Expected 32-digit trace-id" in
+      let* trace_id =
+        match Trace_id.of_hex trace_id with
+        | trace_id -> Ok trace_id
+        | exception Failure _ -> Error "Expected hex-encoded trace-id"
+      in
+      let* offset = consume "-" ~offset ~or_:"Expected delimiter" in
+      let* parent_id, offset = blit ~offset ~len:16 ~or_:"Expected 16-digit parent-id" in
+      let* parent_id =
+        match Span_id.of_hex parent_id with
+        | parent_id -> Ok parent_id
+        | exception Failure _ -> Error "Expected hex-encoded parent-id"
+      in
+      let* offset = consume "-" ~offset ~or_:"Expected delimiter" in
+      let* _flags, _offset = blit ~offset ~len:2 ~or_:"Expected 2-digit flags" in
+      Ok (trace_id, parent_id)
+
+    let to_value ~(trace_id : Trace_id.t) ~(parent_id : Span_id.t) () : string =
+      Printf.sprintf "00-%s-%s-00"
+        (Trace_id.to_hex trace_id)
+        (Span_id.to_hex parent_id)
+
+  end
+end

tests/bin/dune

@@ -0,0 +1,3 @@
+(executable
+ (name emit1)
+ (libraries unix opentelemetry opentelemetry-client-ocurl))

tests/dune

@@ -1,4 +1,3 @@
-
+(tests
-(executable
+ (names test_trace_context)
-  (name emit1)
+ (libraries opentelemetry))
-  (libraries unix opentelemetry opentelemetry-client-ocurl))

tests/test_trace_context.expected

@@ -0,0 +1,25 @@
+Trace_context.Traceparent.of_value "xx":
+  Error "Expected version 00"
+Trace_context.Traceparent.of_value "00":
+  Error "Expected delimiter"
+Trace_context.Traceparent.of_value "00-xxxx":
+  Error "Expected 32-digit trace-id"
+Trace_context.Traceparent.of_value "00-xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx":
+  Error "Expected hex-encoded trace-id"
+Trace_context.Traceparent.of_value "00-0123456789abcdef0123456789abcdef":
+  Error "Expected delimiter"
+Trace_context.Traceparent.of_value "00-0123456789abcdef0123456789abcdef-xxxx":
+  Error "Expected 16-digit parent-id"
+Trace_context.Traceparent.of_value "00-0123456789abcdef0123456789abcdef-xxxxxxxxxxxxxxxx":
+  Error "Expected hex-encoded parent-id"
+Trace_context.Traceparent.of_value "00-0123456789abcdef0123456789abcdef-0123456789abcdef":
+  Error "Expected delimiter"
+Trace_context.Traceparent.of_value "00-0123456789abcdef0123456789abcdef-0123456789abcdef-":
+  Error "Expected 2-digit flags"
+Trace_context.Traceparent.of_value "00-0123456789abcdef0123456789abcdef-0123456789abcdef-00":
+  Ok trace_id:"0123456789abcdef0123456789abcdef" parent_id:"0123456789abcdef"
+Trace_context.Traceparent.of_value "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01":
+  Ok trace_id:"4bf92f3577b34da6a3ce929d0e0e4736" parent_id:"00f067aa0ba902b7"
+
+Trace_context.Traceparent.to_value trace_id:"4bf92f3577b34da6a3ce929d0e0e4736" parent_id:"00f067aa0ba902b7":
+  "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-00"

tests/test_trace_context.ml

@@ -0,0 +1,40 @@
+open Opentelemetry
+
+let pp_traceparent fmt (trace_id, parent_id) =
+  let open Format in
+  fprintf fmt "trace_id:%S parent_id:%S"
+    (Trace_id.to_hex trace_id)
+    (Span_id.to_hex parent_id)
+
+
+let test_of_value str =
+  let open Format in
+  printf "@[<v 2>Trace_context.Traceparent.of_value %S:@ %a@]@."
+    str
+    (pp_print_result ~ok:(fun fmt (trace_id, parent_id) ->
+         fprintf fmt "Ok %a" pp_traceparent (trace_id, parent_id))
+       ~error:(fun fmt msg -> fprintf fmt "Error %S" msg))
+    (Trace_context.Traceparent.of_value str)
+
+let () = test_of_value "xx"
+let () = test_of_value "00"
+let () = test_of_value "00-xxxx"
+let () = test_of_value "00-xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
+let () = test_of_value "00-0123456789abcdef0123456789abcdef"
+let () = test_of_value "00-0123456789abcdef0123456789abcdef-xxxx"
+let () = test_of_value "00-0123456789abcdef0123456789abcdef-xxxxxxxxxxxxxxxx"
+let () = test_of_value "00-0123456789abcdef0123456789abcdef-0123456789abcdef"
+let () = test_of_value "00-0123456789abcdef0123456789abcdef-0123456789abcdef-"
+let () = test_of_value "00-0123456789abcdef0123456789abcdef-0123456789abcdef-00"
+let () = test_of_value "00-4bf92f3577b34da6a3ce929d0e0e4736-00f067aa0ba902b7-01"
+
+let () = print_endline ""
+
+let test_to_value trace_id parent_id =
+  let open Format in
+  printf "@[<v 2>Trace_context.Traceparent.to_value %a:@ %S@]@."
+    pp_traceparent (trace_id, parent_id)
+    (Trace_context.Traceparent.to_value ~trace_id ~parent_id ())
+
+
+let () = test_to_value (Trace_id.of_hex "4bf92f3577b34da6a3ce929d0e0e4736") (Span_id.of_hex "00f067aa0ba902b7")