Add debugging-metadata and tracing directly to OCaml traits-module

impl/ocaml/dune

@@ -1,4 +1,12 @@
 (library
-  (wrapped false)
-  (name sqlgg_traits)
-  (public_name sqlgg.traits))
+ (wrapped false)
+ (name sqlgg_traits)
+ (public_name sqlgg.traits)
+ (libraries
+  trace.core
+  ; (select
+  ;  possibly_tracing.ml
+  ;  from
+  ;  (trace.core -> possibly_tracing.real.ml)
+  ;  (-> possibly_tracing.stub.ml))
+  ))

impl/ocaml/mariadb/sqlgg_mariadb.ml

@@ -262,7 +262,8 @@ let no_params stmt =
   M.Stmt.execute stmt [||] >>=
   check
 
-let with_stmt db sql f =
+let with_stmt ?operation ?tables ~sql span_name db f =
+  Possibly_tracing.span ?operation ?tables ~system:`mariadb ~sql span_name @@ fun () ->
   let open IO in
   let close stmt = M.Stmt.close stmt >>= fun _ -> return () in
   M.prepare db sql >>=
@@ -271,8 +272,8 @@ let with_stmt db sql f =
 
 let row_array = (module M.Row.Array : M.Row.S with type t = M.Field.t array)
 
-let select db sql set_params callback =
-  with_stmt db sql @@ fun stmt ->
+let select ?operation ?tables ~span_name db sql set_params callback =
+  with_stmt ?operation ?tables ~sql span_name db @@ fun stmt ->
   let open IO in
   let rec loop r =
     M.Res.fetch row_array r >>=
@@ -284,23 +285,23 @@ let select db sql set_params callback =
   set_params stmt >>=
   loop
 
-let execute db sql set_params =
-  with_stmt db sql @@ fun stmt ->
+let execute ?operation ?tables ~span_name db sql set_params =
+  with_stmt ?operation ?tables ~sql span_name db @@ fun stmt ->
   let open IO in
   set_params stmt >>=
   fun res -> return (Int64.of_int (M.Res.affected_rows res))
 
-let select_one_maybe db sql set_params convert =
-  with_stmt db sql @@ fun stmt ->
+let select_one_maybe ?operation ?tables ~span_name db sql set_params convert =
+  with_stmt ?operation ?tables ~sql span_name db @@ fun stmt ->
   let open IO in
   set_params stmt >>=
   M.Res.fetch row_array >>=
   check >>= function
   | Some row -> return (Some (convert row))
   | None -> return None
 
-let select_one db sql set_params convert =
-  with_stmt db sql @@ fun stmt ->
+let select_one ?operation ?tables ~span_name db sql set_params convert =
+  with_stmt ?operation ?tables ~sql span_name db @@ fun stmt ->
   let open IO in
   set_params stmt >>=
   M.Res.fetch row_array >>=

impl/ocaml/mysql/sqlgg_mysql.ml

@@ -187,10 +187,12 @@ let try_finally final f x =
     r
 
 let bracket res dtor k = try_finally (fun () -> dtor res) k res
-let with_stmt db sql = bracket (P.create db sql) P.close
+let with_stmt ?operation ?tables ~sql span_name db =
+  Possibly_tracing.span ?operation ?tables ~system:`mysql ~sql span_name @@ fun () ->
+  bracket (P.create db sql) P.close
 
-let select db sql set_params callback =
-  with_stmt db sql (fun stmt ->
+let select ?operation ?tables ~span_name db sql set_params callback =
+  with_stmt ?operation ?tables ~sql span_name db (fun stmt ->
     let r = set_params stmt in
     let rec loop () =
       match P.fetch r with
@@ -199,20 +201,20 @@ let select db sql set_params callback =
     in
     loop ())
 
-let execute db sql set_params =
-  with_stmt db sql (fun stmt ->
+let execute ?operation ?tables ~span_name db sql set_params =
+  with_stmt ?operation ?tables ~sql span_name db (fun stmt ->
     let _ = set_params stmt in
     if 0 <> P.real_status stmt then oops "execute : %s" sql;
     P.affected stmt)
 
-let select_one_maybe db sql set_params convert =
-  with_stmt db sql (fun stmt ->
+let select_one_maybe ?operation ?tables ~span_name db sql set_params convert =
+  with_stmt ?operation ?tables ~sql span_name db (fun stmt ->
     match P.fetch (set_params stmt) with
     | Some row -> Some (convert row)
     | None -> None)
 
-let select_one db sql set_params convert =
-  with_stmt db sql (fun stmt ->
+let select_one ?operation ?tables ~span_name db sql set_params convert =
+  with_stmt ?operation ?tables ~sql span_name db (fun stmt ->
     match P.fetch (set_params stmt) with
     | Some row -> convert row
     | None -> oops "no row but one expected : %s" sql)

impl/ocaml/possibly_tracing.ml

@@ -0,0 +1,25 @@
+let somes_into_strings =
+  List.filter_map (function
+    | (key : string), Some (value : string) -> Some (key, `String value)
+    | _, None -> None)
+
+let span ?operation ?tables ~system ~sql name thunk =
+  let data () =
+    let system =
+      match system with
+      (* From the OpenTelemetry semantic conventions:
+         <https://github.com/open-telemetry/semantic-conventions/blob/eff30869/docs/database/database-spans.md#notes-and-well-known-identifiers-for-dbsystem> *)
+      | `mariadb -> "mariadb"
+      | `mysql -> "mysql"
+      | `sqlite -> "sqlite"
+    in
+    somes_into_strings
+      [
+        "db.system", Some system;
+        "db.statement", Some sql;
+        "db.operation", operation;
+        "db.table", Option.map List.hd tables;
+        "db.tables", Option.map (String.concat ",") tables;
+      ]
+  in
+  Trace_core.with_span ~__FILE__:"" ~__LINE__:0 ~data name @@ fun _ -> thunk ()

impl/ocaml/possibly_tracing.mli

@@ -0,0 +1,8 @@
+val span :
+   ?operation:string ->
+   ?tables:string list ->
+   system: [ `mariadb | `mysql | `sqlite ] ->
+   sql:string ->
+   string (* span-name *) ->
+   (unit -> 'rv) ->
+   'rv

impl/ocaml/sqlgg_traits.ml

@@ -85,25 +85,56 @@ module type M = sig
     Perform query (cardinality "any") and return results via callback for each row
     @raise Oops on error
   *)
-  val select : [>`RO] connection -> string -> (statement -> result) -> (row -> unit) -> unit
+  val select :
+    ?operation:string ->
+    ?tables:string list ->
+    span_name:string ->
+    [>`RO] connection ->
+    string ->
+    (statement -> result) ->
+    (row -> unit) ->
+    unit
 
   (**
     Perform query (cardinality "zero or one") and return first row if available
     @raise Oops on error
   *)
-  val select_one_maybe : [>`RO] connection -> string -> (statement -> result) -> (row -> 'r) -> 'r option
+  val select_one_maybe :
+    ?operation:string ->
+    ?tables:string list ->
+    span_name:string ->
+    [>`RO] connection ->
+    string ->
+    (statement -> result) ->
+    (row -> 'r) ->
+    'r option
 
   (**
     Perform query (cardinality "one") and return first row
     @raise Oops on error
   *)
-  val select_one : [>`RO] connection -> string -> (statement -> result) -> (row -> 'r) -> 'r
+  val select_one :
+    ?operation:string ->
+    ?tables:string list ->
+    span_name:string ->
+    [>`RO] connection ->
+    string ->
+    (statement -> result) ->
+    (row -> 'rv) ->
+    'rv
 
   (** Execute non-query.
     @raise Oops on error
     @return number of affected rows
   *)
-  val execute : [>`WR] connection -> string -> (statement -> result) -> int64
+  val execute :
+    ?operation:string ->
+    ?tables:string list ->
+    span_name:string ->
+    [>`WR] connection ->
+    string ->
+    (statement -> result) ->
+    int64
 
 end
 
@@ -117,12 +148,43 @@ module type M_io = sig
 
   val no_params : statement -> result IO.future
 
-  val select : [>`RO] connection -> string -> (statement -> result IO.future) -> (row -> unit) -> unit IO.future
-
-  val select_one_maybe : [>`RO] connection -> string -> (statement -> result IO.future) -> (row -> 'b) -> 'b option IO.future
-
-  val select_one : [>`RO] connection -> string -> (statement -> result IO.future) -> (row -> 'b) -> 'b IO.future
-
-  val execute : [>`WR] connection -> string -> (statement -> result IO.future) -> int64 IO.future
+  val select :
+    ?operation:string ->
+    ?tables:string list ->
+    span_name:string ->
+    [>`RO] connection ->
+    string ->
+    (statement -> result IO.future) ->
+    (row -> unit) ->
+    unit IO.future
+
+  val select_one_maybe :
+    ?operation:string ->
+    ?tables:string list ->
+    span_name:string ->
+    [>`RO] connection ->
+    string ->
+    (statement -> result IO.future) ->
+    (row -> 'rv) ->
+    'rv option IO.future
+
+  val select_one :
+    ?operation:string ->
+    ?tables:string list ->
+    span_name:string ->
+    [>`RO] connection ->
+    string ->
+    (statement -> result IO.future) ->
+    (row -> 'rv) ->
+    'rv IO.future
+
+  val execute :
+    ?operation:string ->
+    ?tables:string list ->
+    span_name:string ->
+    [>`WR] connection ->
+    string ->
+    (statement -> result IO.future) ->
+    int64 IO.future
 
 end

impl/ocaml/sqlite3/sqlgg_sqlite3.ml

@@ -140,37 +140,38 @@ let try_finally final f x =
     final ();
     r
 
-let with_sql db sql f =
+let with_sql ?operation ?tables ~sql span_name db f =
+  Possibly_tracing.span ?operation ?tables ~system:`sqlite ~sql span_name @@ fun () ->
   let stmt = S.prepare db sql in
   try_finally
     (fun () -> test_ok sql (S.finalize stmt))
     f (stmt,sql)
 
-let select db sql set_params callback =
-  with_sql db sql (fun stmt ->
+let select ?operation ?tables ~span_name db sql set_params callback =
+  with_sql ?operation ?tables ~sql span_name db (fun stmt ->
     set_params stmt;
     while S.Rc.ROW = S.step (fst stmt) do
       callback stmt
     done)
 
-let execute db sql set_params =
-  with_sql db sql (fun stmt ->
+let execute ?operation ?tables ~span_name db sql set_params =
+  with_sql ?operation ?tables ~sql span_name db (fun stmt ->
     set_params stmt;
     let rc = S.step (fst stmt) in
     if rc <> S.Rc.DONE then raise (Oops (sprintf "execute : %s" sql));
     Int64.of_int (S.changes db)
   )
 
-let select_one_maybe db sql set_params convert =
-  with_sql db sql (fun stmt ->
+let select_one_maybe ?operation ?tables ~span_name db sql set_params convert =
+  with_sql ?operation ?tables ~sql span_name db (fun stmt ->
     set_params stmt;
     if S.Rc.ROW = S.step (fst stmt) then
       Some (convert stmt)
     else
       None)
 
-let select_one db sql set_params convert =
-  with_sql db sql (fun stmt ->
+let select_one ?operation ?tables ~span_name db sql set_params convert =
+  with_sql ?operation ?tables ~sql span_name db (fun stmt ->
     set_params stmt;
     if S.Rc.ROW = S.step (fst stmt) then
       convert stmt

lib/stmt.ml

@@ -20,10 +20,36 @@ type kind = | Select of cardinality
             | Delete of Sql.table_name list
             | Alter of Sql.table_name list
             | Drop of Sql.table_name
-            | CreateRoutine of string
+            | CreateRoutine of string * Sql.Type.t option
             | Other
             [@@deriving show {with_path=false}]
 
+let kind_to_operation_name = function
+| Select _ -> Some "SELECT"
+| Insert _ -> Some "INSERT"
+| Create _ -> Some "CREATE TABLE"
+| CreateIndex _ -> Some "CREATE INDEX"
+| Update _ -> Some "UPDATE"
+| Delete _ -> Some "DELETE"
+| Alter _ -> Some "ALTER TABLE"
+| Drop _ -> Some "DROP TABLE"
+| CreateRoutine (_, Some _) -> Some "CREATE FUNCTION"
+| CreateRoutine (_, None) -> Some "CREATE PROCEDURE"
+| Other -> None
+
+let kind_to_table_names = function
+| Create t -> [t]
+| CreateIndex _ -> [] (* FIXME *)
+| Update (Some t) -> [t]
+| Update None -> []
+| Insert (_,t) -> [t]
+| Delete ts -> ts
+| Alter ts -> ts
+| Drop t -> [t]
+| Select _  ->  [] (* FIXME *)
+| CreateRoutine (_s, _ret) -> []
+| Other -> []
+
 type category = DDL | DQL | DML | DCL | TCL | OTHER [@@deriving show {with_path=false}, enum]
 
 let all_categories = List.init (max_category - min_category) (fun i -> Option.get @@ category_of_enum @@ min_category + i)

lib/syntax.ml

@@ -506,8 +506,8 @@ let eval (stmt:Sql.stmt) =
     let params = update_tables sources ss w in
     [], params, Update None
   | Select select -> eval_select_full empty_env select
-  | CreateRoutine (name,_,_) ->
-    [], [], CreateRoutine name
+  | CreateRoutine (name,ret,_) ->
+    [], [], CreateRoutine (name, ret)
 
 (* FIXME unify each choice separately *)
 let unify_params l =

sqlgg.opam

@@ -25,6 +25,10 @@ depopts: [
   "mariadb"
   "mysql"
   "sqlite3"
+  "trace"
+]
+conflicts: [
+  "trace" {< "0.3.0" | >= "0.6.0"}
 ]
 synopsis: "SQL Guided (code) Generator"
 description: """

src/gen.ml

@@ -63,7 +63,7 @@ let choose_name props kind index =
   | Alter t -> sprintf "alter_%s_%u" (String.concat "_" @@ List.map fix t) index
   | Drop t -> sprintf "drop_%s" (fix t)
   | Select _  -> sprintf "select_%u" index
-  | CreateRoutine s -> sprintf "create_routine_%s" (fix' s)
+  | CreateRoutine (s, _ret) -> sprintf "create_routine_%s" (fix' s)
   | Other -> sprintf "statement_%u" index
   in
   make_name props name