Merge pull request #68 from paurkedal/issue67

Avoid possibly blocking calls to mysql_free_result.

Author: paurkedal

.github/workflows/workflow.yml

@@ -48,7 +48,7 @@ jobs:
 
       - name: Install system dependencies (ubuntu)
         if: "${{ matrix.os == 'ubuntu' }}"
-        run: "apt-get update && apt-get install -y pkg-config libmariadb-dev"
+        run: "apt-get update && apt-get install -y pkg-config libmariadb-dev libzstd-dev"
 
       - name: Restore cached dependencies
         uses: actions/cache@v3

bindings/ffi_bindings.ml

@@ -346,6 +346,12 @@ module Functions (F : Ctypes.FOREIGN) = struct
 
   (* Nonblocking API *)
 
+  let mysql_free_result_start = foreign "mysql_free_result_start"
+    (res @-> returning int)
+
+  let mysql_free_result_cont = foreign "mysql_free_result_cont"
+    (res @-> int @-> returning int)
+
   let mysql_close_start = foreign "mysql_close_start"
     (mysql @-> returning int)
 

lib/blocking.ml

@@ -182,7 +182,23 @@ end
 module Stmt = struct
   type t = [`Blocking] Common.Stmt.t
 
+  let free_meta stmt =
+    match stmt.Common.Stmt.meta with
+    | None -> ()
+    | Some { res; _ } ->
+        stmt.meta <- None;
+        B.mysql_free_result res
+
+  let free_meta_and_result stmt =
+    match stmt.Common.Stmt.meta with
+    | None -> true
+    | Some { res; _ } ->
+        stmt.meta <- None;
+        B.mysql_free_result res;
+        B.mysql_stmt_free_result stmt.Common.Stmt.raw
+
   let execute stmt params =
+    free_meta stmt;
     let n = B.mysql_stmt_param_count stmt.Common.Stmt.raw in
     if n <> Array.length params then
       Error (0, "parameter count mismatch")
@@ -200,21 +216,14 @@ module Stmt = struct
       | `Error e -> Error e
     end
 
-  let free_res stmt =
-    if stmt.Common.Stmt.meta = None then true else
-    begin
-      Common.Stmt.free_meta stmt;
-      B.mysql_stmt_free_result stmt.Common.Stmt.raw
-    end
-
   let reset stmt =
-    if free_res stmt && B.mysql_stmt_reset stmt.Common.Stmt.raw then
+    if free_meta_and_result stmt && B.mysql_stmt_reset stmt.Common.Stmt.raw then
       Ok ()
     else
       Error (Common.Stmt.error stmt)
 
   let close stmt =
-    if free_res stmt && B.mysql_stmt_close stmt.Common.Stmt.raw then
+    if free_meta_and_result stmt && B.mysql_stmt_close stmt.Common.Stmt.raw then
       Ok ()
     else
       Error (Common.Stmt.error stmt)

lib/common.ml

@@ -375,15 +375,8 @@ module Stmt = struct
         b.Bind.buffers.(i) <- malloc n;
         setf (!@bp) T.Bind.buffer b.Bind.buffers.(i)
 
-  let free_meta stmt =
-    match stmt.meta with
-    | Some { res; _ } ->
-        B.mysql_free_result res;
-        stmt.meta <- None
-    | None -> ()
-
   let update_meta stmt =
-    free_meta stmt;
+    assert (stmt.meta = None);
     stmt.meta <- (
         match B.mysql_stmt_result_metadata stmt.raw with
         | Some res ->

lib/nonblocking.ml

@@ -252,6 +252,19 @@ module Res = struct
 
   let fetch (type t) (module R : Row.S with type t = t) res =
     (fetch_start (module R) res, fetch_cont (module R) res)
+
+  let handle_free = function
+    | 0 -> `Ok
+    | s -> `Wait (Status.of_int s)
+
+  let free_start res =
+    handle_free (B.mysql_free_result_start res)
+
+  let free_cont res status =
+    handle_free (B.mysql_free_result_cont res status)
+
+  let free res =
+    (free_start res, free_cont res)
 end
 
 module Stmt = struct
@@ -635,35 +648,47 @@ module Make (W : Wait) : S with type 'a future = 'a W.IO.future = struct
 
     let insert_id =
       Res.insert_id
+
+    let free = (* not public, but to avoid shadowing *)
+      Res.free
   end
 
   module Stmt = struct
     type t = Stmt.t
 
+    let free_meta stmt =
+      match stmt.Common.Stmt.meta with
+      | None -> return ()
+      | Some { res; _ } ->
+          stmt.Common.Stmt.meta <- None;
+          nonblocking' stmt.Common.Stmt.mariadb (Res.free res)
+
+    let free_meta_and_result stmt =
+      match stmt.Common.Stmt.meta with
+      | None -> return (Ok ())
+      | Some { res; _ } ->
+          stmt.Common.Stmt.meta <- None;
+          nonblocking' stmt.Common.Stmt.mariadb (Res.free res) >>= fun () ->
+          nonblocking stmt.Common.Stmt.mariadb (Stmt.free_result stmt)
+
     let handle_execute = function
       | Ok stmt -> nonblocking stmt.Common.Stmt.mariadb (Stmt.store_result stmt)
       | Error _ as e -> return e
 
     let execute stmt ps =
+      free_meta stmt >>= fun () ->
       match Stmt.execute stmt ps with
       | `Ok nb -> nonblocking stmt.Common.Stmt.mariadb nb >>= handle_execute
       | `Error e -> return (Error e)
 
-    let free_res stmt =
-      if stmt.Common.Stmt.meta = None then return (Ok ()) else
-      begin
-        Common.Stmt.free_meta stmt;
-        nonblocking stmt.Common.Stmt.mariadb (Stmt.free_result stmt)
-      end
-
     let reset stmt =
-      free_res stmt
+      free_meta_and_result stmt
       >>= function
       | Ok () -> nonblocking stmt.Common.Stmt.mariadb (Stmt.reset stmt)
       | Error _ as e -> return e
 
     let close stmt =
-      free_res stmt
+      free_meta_and_result stmt
       >>= function
       | Ok () -> nonblocking stmt.Common.Stmt.mariadb (Stmt.close stmt)
       | Error _ as e -> return e