diff --git a/emit1.sh b/emit1.sh index 8ab2f6a6..86794bc3 100755 --- a/emit1.sh +++ b/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 -- $@ diff --git a/src/opentelemetry.ml b/src/opentelemetry.ml index 16959506..0ce8abb2 100644 --- a/src/opentelemetry.ml +++ b/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 diff --git a/tests/bin/dune b/tests/bin/dune new file mode 100644 index 00000000..d41bf219 --- /dev/null +++ b/tests/bin/dune @@ -0,0 +1,3 @@ +(executable + (name emit1) + (libraries unix opentelemetry opentelemetry-client-ocurl)) diff --git a/tests/emit1.ml b/tests/bin/emit1.ml similarity index 100% rename from tests/emit1.ml rename to tests/bin/emit1.ml diff --git a/tests/dune b/tests/dune index e65353ae..d2246b32 100644 --- a/tests/dune +++ b/tests/dune @@ -1,4 +1,3 @@ - -(executable - (name emit1) - (libraries unix opentelemetry opentelemetry-client-ocurl)) +(tests + (names test_trace_context) + (libraries opentelemetry)) diff --git a/tests/test_trace_context.expected b/tests/test_trace_context.expected new file mode 100644 index 00000000..f885cb83 --- /dev/null +++ b/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" diff --git a/tests/test_trace_context.ml b/tests/test_trace_context.ml new file mode 100644 index 00000000..83cf5bd3 --- /dev/null +++ b/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 "@[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 "@[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")