migrate sqlite, client, and daemon to Trace_core

catapult.opam

@@ -10,7 +10,7 @@ bug-reports: "https://github.com/imandra-ai/catapult/issues"
 depends: [
   "dune" {>= "2.7"}
   "base-threads"
-  "base-unix"
+  "trace" {>= "0.3"}
   "odoc" {with-doc}
   "ocaml" {>= "4.08"}
 ]

examples/heavy/dune

@@ -1,5 +1,5 @@
 (executable
  (name heavy)
  (optional)
- (libraries threads.posix unix catapult catapult-file catapult-sqlite
+ (libraries threads.posix trace unix catapult catapult-sqlite
    catapult-client))

examples/heavy/heavy.ml

@@ -1,6 +1,6 @@
-module Tr = Catapult.Tracing
-open Tr.Syntax
+module Tr = Trace
 
+let ( let@ ) = ( @@ )
 let spf = Printf.sprintf
 
 let rec fib n =
@@ -10,30 +10,33 @@ let rec fib n =
     fib (n - 1) + fib (n - 2)
 
 let do_work () =
-  let@ () = Tr.with_ "dowork" in
+  let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "dowork" in
   for j = 0 to 5_000 do
     let n = 15 + (j mod 5) in
-    let@ () = Tr.with_ ~args:[ "j", `Int j; "fib n", `Int n ] "step" in
+    let@ _sp =
+      Trace.with_span ~__FILE__ ~__LINE__
+        ~data:(fun () -> [ "j", `Int j; "fib n", `Int n ])
+        "step"
+    in
     ignore (Sys.opaque_identity (fib n) : int)
   done
 
 let run n =
   Printf.printf "run %d iterations\n%!" n;
 
   for i = 1 to n do
-    let@ () = Tr.with_ "main iter" in
+    let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "main iter" in
     Printf.printf "iteration %d\n%!" i;
     for j = 1 to 4 do
       do_work ()
     done;
     if i mod 3 = 0 then Gc.major ()
   done
 
-type mode = Net | File | Db
+type mode = Net | Db
 
 let mode_of_str = function
   | "net" -> Net
-  | "file" -> File
   | "db" -> Db
   | s -> failwith ("unknown mode: " ^ s)
 
@@ -45,7 +48,7 @@ let sync_of_str = function
 
 let () =
   let n = ref 10 in
-  let mode = ref File in
+  let mode = ref Db in
   let file = ref "trace.json" in
   let addr = ref Catapult_client.default_endpoint in
   let j = ref 1 in
@@ -59,7 +62,7 @@ let () =
       "-n", Arg.Set_int n, " number of iterations";
       "-o", Arg.Set_string file, " output file";
       ( "--mode",
-        Arg.Symbol ([ "net"; "file"; "db" ], fun s -> mode := mode_of_str s),
+        Arg.Symbol ([ "net"; "db" ], fun s -> mode := mode_of_str s),
         " serialization mode" );
       "--worker", Arg.Set worker, " act as a worker";
       ( "--db",
@@ -83,19 +86,10 @@ let () =
   in
   Arg.parse opts (fun _ -> ()) "heavy";
 
-  if !worker then
-    Catapult_sqlite.set_multiproc true
-  else if (not !worker) && !j > 1 then (
-    Catapult_sqlite.set_multiproc true;
-
+  if (not !worker) && !j > 1 then (
     (match !mode with
-    | Net ->
-      if !trace_id <> "" then Catapult_client.set_trace_id !trace_id;
-      trace_id := Catapult_client.get_trace_id ()
-    | Db ->
-      if !trace_id <> "" then Catapult_sqlite.set_trace_id !trace_id;
-      trace_id := Catapult_sqlite.get_trace_id ()
-    | File -> ());
+    | Net -> ()
+    | Db -> failwith "cannot use -j with a sqlite backend");
 
     let bin_name = Sys.executable_name in
     for _k = 2 to !j do
@@ -115,16 +109,17 @@ let () =
   | Net ->
     Printf.printf "use net client %s\n%!"
       (Catapult_client.Endpoint_address.to_string !addr);
-    if !trace_id <> "" then Catapult_client.set_trace_id !trace_id;
-    Catapult_client.set_endpoint !addr;
-    Catapult_client.with_setup run
+    let trace_id =
+      if !trace_id <> "" then
+        Some !trace_id
+      else
+        None
+    in
+    let@ conn = Catapult_client.with_conn ?trace_id ~addr:!addr () in
+    Trace_core.setup_collector (Catapult_client.trace_collector_of_conn conn);
+    run ()
   | Db ->
     Printf.printf "use sqlite backend %s\n%!" !db;
-    if !trace_id <> "" then Catapult_sqlite.set_trace_id !trace_id;
-    Catapult_sqlite.set_file !db;
-    Catapult_sqlite.set_sqlite_sync !sync;
-    Catapult_sqlite.with_setup run
-  | File ->
-    Printf.printf "write to file %S\n%!" !file;
-    Catapult_file.set_file !file;
-    Catapult_file.with_setup run
+    let@ writer = Catapult_sqlite.Writer.with_ ~file:!db ~sync:!sync () in
+    Trace.setup_collector (Catapult_sqlite.trace_collector_of_writer writer);
+    run ()

src/client/backend.ml

@@ -4,18 +4,18 @@ module P = Catapult
 type event = Ser.Event.t
 
 module type ARG = sig
-  val conn : Connections.t
+  val conn : Connection.t
 end
 
 module Make (A : ARG) : P.BACKEND = struct
   let conn = A.conn
-  let teardown () = Connections.close conn
+  let teardown () = Connection.close conn
 
   let[@inline] opt_map_ f = function
     | None -> None
     | Some x -> Some (f x)
 
-  let conv_arg (key, (a : [> `Float of float | Trace.user_data ])) =
+  let conv_arg (key, (a : [< `Float of float | Trace.user_data ])) =
     let open Ser in
     let value =
       match a with
@@ -24,7 +24,6 @@ module Make (A : ARG) : P.BACKEND = struct
       | `Float f -> Arg_value.Float64 f
       | `Bool b -> Arg_value.Bool b
       | `None -> Arg_value.Void
-      | _ -> assert false
     in
     { Arg.key; value }
 
@@ -35,7 +34,7 @@ module Make (A : ARG) : P.BACKEND = struct
       let tid = Int64.of_int tid in
       let pid = Int64.of_int pid in
       let stack = opt_map_ Array.of_list stack in
-      let ph = Event_type.to_char ph |> Char.code in
+      let ph = P.Event_type.to_char ph |> Char.code in
       let cat = opt_map_ Array.of_list cat in
       let extra =
         match extra with
@@ -50,10 +49,16 @@ module Make (A : ARG) : P.BACKEND = struct
       in
       { Event.id; name; ph; tid; pid; cat; ts_us; args; stack; dur; extra }
     in
-    Connections.send_msg conn ~pid ~now:ts_us ev
+    Connection.send_msg conn ~pid ~now:ts_us ev
 
   let tick () =
     let now = P.Clock.now_us () in
     let pid = Unix.getpid () in
     Gc_stats.maybe_emit ~now ~pid ()
 end
+
+let make (c : Connection.t) : P.backend =
+  let module M = Make (struct
+    let conn = c
+  end) in
+  (module M)

src/client/backend.mli

@@ -1,5 +1 @@
-module type ARG = sig
-  val conn : Connections.t
-end
-
-module Make (_ : ARG) : Catapult.BACKEND
+val make : Connection.t -> Catapult.backend

src/client/catapult_client.ml

@@ -1,68 +1,14 @@
-module P = Catapult
-module Endpoint_address = Catapult_utils.Endpoint_address
-
-let trace_id = ref (try Sys.getenv "TRACE_ID" with _ -> "")
-let set_trace_id s = trace_id := s
-
-(* try to make a non-stupid default id, based on PID + date.
-   This is not perfect, use a UUID4 if possible. *)
-let[@inline never] invent_trace_id_ () : string =
-  let pid = Unix.getpid () in
-  let now = Unix.gettimeofday () in
-  let tm = Unix.gmtime now in
-  Printf.sprintf "catapult-%d-%02d-%02d-%02d-%02d-%02d-pid-%d"
-    (1900 + tm.tm_year) (tm.tm_mon + 1) tm.tm_mday tm.tm_hour tm.tm_min
-    tm.tm_sec pid
+(** Backend for Catapult, using a connection to the daemon.
+*)
 
-let[@inline] get_trace_id () =
-  if !trace_id = "" then trace_id := invent_trace_id_ ();
-  !trace_id
+module Endpoint_address = Catapult_utils.Endpoint_address
+module Backend = Backend
+module Connection = Connection
 
 let default_endpoint = Endpoint_address.default
+let with_conn = Connection.with_
+let backend_of_conn : Connection.t -> Catapult.backend = Backend.make
 
-let endpoint =
-  ref
-    (try Endpoint_address.of_string_exn (Sys.getenv "TRACE_ENDPOINT")
-     with _ -> default_endpoint)
-
-let set_endpoint e = endpoint := e
-let get_endpoint () = !endpoint
-let set_tcp_endpoint h p = set_endpoint (Endpoint_address.Tcp (h, p))
-let set_ipc_endpoint file = set_endpoint (Endpoint_address.Unix file)
-let tef_in_env () = List.mem (Sys.getenv_opt "TRACE") [ Some "1"; Some "true" ]
-
-let mk_lazy_enable getenv =
-  let r = ref false in
-  let enabled_thunk = lazy (!r || getenv ()) in
-  let[@inline] enabled () = Lazy.force enabled_thunk in
-  let enable () = if not !r then r := true in
-  enable, enabled
-
-let enable, enabled = mk_lazy_enable tef_in_env
-
-(* FIXME: with_ … *)
-let setup_ =
-  lazy
-    (if enabled () then (
-      at_exit P.Control.teardown;
-      let trace_id = get_trace_id () in
-      let conn = Connections.create ~addr:!endpoint ~trace_id () in
-      let module B = Backend.Make (struct
-        let conn = conn
-      end) in
-      let backend = (module B : P.BACKEND) in
-      P.Control.setup (Some backend)
-    ))
-
-let setup () = Lazy.force setup_
-let teardown = P.Tracing.Control.teardown
-
-let with_setup f =
-  setup ();
-  try
-    let x = f () in
-    teardown ();
-    x
-  with e ->
-    teardown ();
-    raise e
+(** Obtain a trace collector from a network connection *)
+let trace_collector_of_conn : Connection.t -> Trace_core.collector =
+ fun conn -> backend_of_conn conn |> Catapult.trace_collector_of_backend

src/client/connections.ml → src/client/connection.ml

@@ -2,6 +2,9 @@ open Catapult_utils
 module P = Catapult
 module Atomic = P.Atomic_shim_
 
+let ( let@ ) = ( @@ )
+let default_addr = Endpoint_address.default
+
 let connect_endpoint ctx (addr : Endpoint_address.t) : [ `Dealer ] Zmq.Socket.t
     =
   let module E = Endpoint_address in
@@ -82,7 +85,7 @@ let close (self : t) =
         (Printexc.to_string e)
   )
 
-let create ~(addr : Endpoint_address.t) ~trace_id () : t =
+let create ~(addr : Endpoint_address.t) ?(trace_id = "trace") () : t =
   let ctx = Zmq.Context.create () in
   Zmq.Context.set_io_threads ctx 6;
   let per_t =
@@ -94,7 +97,6 @@ let create ~(addr : Endpoint_address.t) ~trace_id () : t =
   Gc.finalise close self;
   self
 
-(* send a message. *)
 let send_msg (self : t) ~pid ~now (ev : Ser.Event.t) : unit =
   if not self.closed then (
     let logger = Thread_local.get_or_create self.per_t in
@@ -107,3 +109,8 @@ let send_msg (self : t) ~pid ~now (ev : Ser.Event.t) : unit =
     (* maybe emit GC stats as well *)
     Gc_stats.maybe_emit ~now:ev.ts_us ~pid:(Int64.to_int ev.pid) ()
   )
+
+let with_ ~addr ?trace_id () f =
+  let conn = create ~addr ?trace_id () in
+  let@ () = Fun.protect ~finally:(fun () -> close conn) in
+  f conn

src/client/connection.mli

@@ -0,0 +1,11 @@
+open Catapult_utils
+
+type t
+
+val default_addr : Endpoint_address.t
+val create : addr:Endpoint_address.t -> ?trace_id:string -> unit -> t
+val send_msg : t -> pid:int -> now:float -> Ser.Event.t -> unit
+val close : t -> unit
+
+val with_ :
+  addr:Endpoint_address.t -> ?trace_id:string -> unit -> (t -> 'a) -> 'a

src/client/dune

@@ -2,4 +2,4 @@
  (name catapult_client)
  (public_name catapult-client)
  (synopsis "Client library for the catapult daemon")
- (libraries catapult catapult.utils zmq unix trace))
+ (libraries trace.core catapult catapult.utils zmq unix trace))