From 327afa8ce18d69bf9d4d6a3b00a863a79953f7c2 Mon Sep 17 00:00:00 2001 From: Dario Teixeira Date: Wed, 24 Apr 2019 13:22:16 +0200 Subject: [PATCH] Make the API future-proof We plan to add soon per-query control of statement caching. The changes to the API in this PR ensure that this feature can be implemented in a minor release. --- CHANGES.md | 6 +++ README.md | 50 +++++++++++++------ .../hello_world_with_async.ml | 4 +- .../mysql_with_async.ml | 2 + .../hello_world_with_identity.ml | 4 +- .../hello_world_with_lwt.ml | 4 +- .../hello_world_with_lwt/mysql_with_lwt.ml | 2 + .../mysql_with_identity.ml | 2 + lib/runtime/ppx_mysql_runtime.ml | 44 ++++++++++------ lib/runtime/ppx_mysql_runtime.mli | 18 +++++-- ppx/ppx_mysql.ml | 2 +- tests/test_ppx/test_ppx.expected.ml | 38 +++++++------- 12 files changed, 116 insertions(+), 60 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 1dbdab8..79e012f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,9 @@ +1.0 +=== + +* All statements are now cached +* First public release + 0.5 === diff --git a/README.md b/README.md index 44763a9..9e3a682 100644 --- a/README.md +++ b/README.md @@ -79,13 +79,31 @@ sig type stmt type stmt_result type error + type wrapped_dbh type wrapped_error = [`Mysql_error of error] - val create : dbh -> string -> (stmt, [> wrapped_error]) result IO.t - val execute_null : stmt -> string option array -> (stmt_result, [> wrapped_error]) result IO.t - val fetch : stmt_result -> (string option array option, [> wrapped_error]) result IO.t - val close : stmt -> (unit, [> wrapped_error]) result IO.t - val with_stmt : dbh -> string -> (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> ('a, 'e) result IO.t + val init : dbh -> wrapped_dbh + + val execute_null : + stmt -> + string option array -> + (stmt_result, [> wrapped_error]) result IO.t + + val fetch : + stmt_result -> + (string option array option, [> wrapped_error]) result IO.t + + val with_stmt_cached : + wrapped_dbh -> + string -> + (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> + ('a, 'e) result IO.t + + val with_stmt_uncached : + wrapped_dbh -> + string -> + (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> + ('a, 'e) result IO.t end end ``` @@ -136,7 +154,7 @@ neither necessary nor recommended for actual code. Here's the same ```ocaml let get_employee dbh employee_id = let q : - Prepared.dbh -> + Prepared.wrapped_dbh -> employee_id:int32 -> ((int32 * int32 option * string * string option), error) result IO.t = [%mysql select_one @@ -149,7 +167,9 @@ let get_employee dbh employee_id = Things to note: - - Type `Prepared.dbh` is the type of database handles. + - Type `Prepared.wrapped_dbh` is a wrapper around a raw database handle. + You can obtain a value of this type by invoking function `Prepared.init` + with a raw database handle as argument. - We denote input parameters using the syntax `%TYPE{name}`, where `TYPE` is a type specification (see next section), and `name` is the OCaml named @@ -250,7 +270,7 @@ other errors may still occur). ```ocaml let get_supervisor dbh employee_id = let q : - Prepared.dbh -> + Prepared.wrapped_dbh -> employee_id:int32 -> ((int32 * int32 option * string * string option) option, error) result IO.t = [%mysql select_opt @@ -269,7 +289,7 @@ may occur). ```ocaml let get_underlings dbh supervisor_id = let q : - Prepared.dbh -> + Prepared.wrapped_dbh -> supervisor_id:int32 -> ((int32 * int32 option * string * string option) list, error) result IO.t = [%mysql select_all @@ -294,7 +314,7 @@ one does not usually need to worry about the order). ```ocaml let insert_employee dbh {id; supervisor_id; name; phone} = let q : - Prepared.dbh -> + Prepared.wrapped_dbh -> id:int32 -> supervisor_id:int32 option -> name:string -> @@ -325,7 +345,7 @@ declaration. ```ocaml let insert_employees dbh rows = let q : - Prepared.dbh -> + Prepared.wrapped_dbh -> (int32 * int32 option * string * string option) list -> (unit, error) result IO.t = [%mysql execute @@ -343,7 +363,7 @@ this use case: ```ocaml let select_employees dbh ids = let q : - Prepared.dbh -> + Prepared.wrapped_dbh -> int32 list -> name:string -> ((int32 * int32 option * string * string option) list, error) result IO.t = @@ -382,12 +402,12 @@ Special cases ------------- Should there be no input parameters, the function generated by the syntax -extension will take only the database handle as parameter: +extension will take only the wrapped database handle as parameter: ```ocaml let get_unsupervised dbh = let q : - Prepared.dbh -> + Prepared.wrapped_dbh -> ((int32 * int32 option * string * string option) list, error) result IO.t = [%mysql select_all "SELECT @int32{id}, @int32?{supervisor_id}, @string{name}, @string?{phone} @@ -403,7 +423,7 @@ SQL statement, the generated function will take it only once: ```ocaml let is_related dbh id = let q : - Prepared.dbh -> + Prepared.wrapped_dbh -> id:int32 -> ((int32 * int32 option * string * string option) list, error) result IO.t = [%mysql select_all diff --git a/examples/hello_world_with_async/hello_world_with_async.ml b/examples/hello_world_with_async/hello_world_with_async.ml index e1e42d9..b7427dc 100644 --- a/examples/hello_world_with_async/hello_world_with_async.ml +++ b/examples/hello_world_with_async/hello_world_with_async.ml @@ -119,8 +119,8 @@ let test dbh = let main () = let open Deferred.Infix in let dbh = Mysql.quick_connect ~database:"test" ~user:"root" () in - let caching_dbh = Prepared.init dbh in - test caching_dbh >>= fun res -> + let wrapped_dbh = Prepared.init dbh in + test wrapped_dbh >>= fun res -> Mysql.disconnect dbh; match res with | Ok () -> diff --git a/examples/hello_world_with_async/mysql_with_async.ml b/examples/hello_world_with_async/mysql_with_async.ml index 133f483..274d31c 100644 --- a/examples/hello_world_with_async/mysql_with_async.ml +++ b/examples/hello_world_with_async/mysql_with_async.ml @@ -23,6 +23,8 @@ include Ppx_mysql_runtime.Make_context (struct let create dbh sql = wrap (Mysql.Prepared.create dbh) sql + let close stmt = wrap Mysql.Prepared.close stmt + let execute_null stmt args = wrap (Mysql.Prepared.execute_null stmt) args let fetch stmt_res = wrap Mysql.Prepared.fetch stmt_res diff --git a/examples/hello_world_with_identity/hello_world_with_identity.ml b/examples/hello_world_with_identity/hello_world_with_identity.ml index 3af92d1..1eec6e0 100644 --- a/examples/hello_world_with_identity/hello_world_with_identity.ml +++ b/examples/hello_world_with_identity/hello_world_with_identity.ml @@ -114,8 +114,8 @@ let test dbh = let main () = let dbh = Mysql.quick_connect ~database:"test" ~user:"root" () in - let caching_dbh = Prepared.init dbh in - let res = test caching_dbh in + let wrapped_dbh = Prepared.init dbh in + let res = test wrapped_dbh in Mysql.disconnect dbh; match res with | Ok () -> Printf.printf "All went well!\n" diff --git a/examples/hello_world_with_lwt/hello_world_with_lwt.ml b/examples/hello_world_with_lwt/hello_world_with_lwt.ml index 832cd50..2e492fb 100644 --- a/examples/hello_world_with_lwt/hello_world_with_lwt.ml +++ b/examples/hello_world_with_lwt/hello_world_with_lwt.ml @@ -114,8 +114,8 @@ let test dbh = let main () = let open Lwt.Infix in let dbh = Mysql.quick_connect ~database:"test" ~user:"root" () in - let caching_dbh = Prepared.init dbh in - test caching_dbh >>= fun res -> + let wrapped_dbh = Prepared.init dbh in + test wrapped_dbh >>= fun res -> Mysql.disconnect dbh; match res with | Ok () -> Lwt_io.printf "All went well!\n" diff --git a/examples/hello_world_with_lwt/mysql_with_lwt.ml b/examples/hello_world_with_lwt/mysql_with_lwt.ml index 330ee99..66120b3 100644 --- a/examples/hello_world_with_lwt/mysql_with_lwt.ml +++ b/examples/hello_world_with_lwt/mysql_with_lwt.ml @@ -18,6 +18,8 @@ include Ppx_mysql_runtime.Make_context (struct let create dbd sql = wrap (Mysql.Prepared.create dbd) sql + let close stmt = wrap Mysql.Prepared.close stmt + let execute_null stmt args = wrap (Mysql.Prepared.execute_null stmt) args let fetch stmt_res = wrap Mysql.Prepared.fetch stmt_res diff --git a/lib/mysql_with_identity/mysql_with_identity.ml b/lib/mysql_with_identity/mysql_with_identity.ml index e5a9145..1c40bb2 100644 --- a/lib/mysql_with_identity/mysql_with_identity.ml +++ b/lib/mysql_with_identity/mysql_with_identity.ml @@ -20,6 +20,8 @@ include Ppx_mysql_runtime.Make_context (struct let create dbh sql = wrap (Mysql.Prepared.create dbh) sql + let close stmt = wrap Mysql.Prepared.close stmt + let execute_null stmt args = wrap (Mysql.Prepared.execute_null stmt) args let fetch stmt_res = wrap Mysql.Prepared.fetch stmt_res diff --git a/lib/runtime/ppx_mysql_runtime.ml b/lib/runtime/ppx_mysql_runtime.ml index 9a639d9..c136f8e 100644 --- a/lib/runtime/ppx_mysql_runtime.ml +++ b/lib/runtime/ppx_mysql_runtime.ml @@ -81,6 +81,8 @@ module type PPX_MYSQL_CONTEXT_ARG = sig val create : dbh -> string -> (stmt, error) result IO.t + val close : stmt -> (unit, error) result IO.t + val execute_null : stmt -> string option array -> (stmt_result, error) result IO.t val fetch : stmt_result -> (string option array option, error) result IO.t @@ -117,11 +119,11 @@ module type PPX_MYSQL_CONTEXT = sig type error - type wrapped_error = [`Mysql_error of error] + type wrapped_dbh - type caching_dbh + type wrapped_error = [`Mysql_error of error] - val init : dbh -> caching_dbh + val init : dbh -> wrapped_dbh val execute_null : stmt -> @@ -132,8 +134,14 @@ module type PPX_MYSQL_CONTEXT = sig : stmt_result -> (string option array option, [> wrapped_error]) result IO.t - val with_stmt - : caching_dbh -> + val with_stmt_cached + : wrapped_dbh -> + string -> + (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> + ('a, 'e) result IO.t + + val with_stmt_uncached + : wrapped_dbh -> string -> (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> ('a, 'e) result IO.t @@ -173,13 +181,13 @@ module Make_context (M : PPX_MYSQL_CONTEXT_ARG) : type error = M.Prepared.error - type wrapped_error = [`Mysql_error of error] - - type caching_dbh = { + type wrapped_dbh = { dbh : dbh; - stmt_cache : (Digest.t, stmt) Hashtbl.t + stmt_cache : (string, stmt) Hashtbl.t } + type wrapped_error = [`Mysql_error of error] + let wrap f x = IO.bind (f x) @@ function | Ok _ as ok -> IO.return ok @@ -190,20 +198,28 @@ module Make_context (M : PPX_MYSQL_CONTEXT_ARG) : let create dbh sql = wrap (M.Prepared.create dbh) sql let create_or_reuse {dbh; stmt_cache} sql = - let digest = Digest.string sql in - match Hashtbl.find_opt stmt_cache digest with + match Hashtbl.find_opt stmt_cache sql with | Some stmt -> IO_result.return stmt | None -> IO_result.bind (create dbh sql) @@ fun stmt -> - Hashtbl.replace stmt_cache digest stmt; + Hashtbl.replace stmt_cache sql stmt; IO_result.return stmt + let close stmt = wrap M.Prepared.close stmt + let execute_null stmt args = wrap (M.Prepared.execute_null stmt) args let fetch stmt_res = wrap M.Prepared.fetch stmt_res - let with_stmt caching_dbh sql f = - IO_result.bind (create_or_reuse caching_dbh sql) @@ fun stmt -> f stmt + let with_stmt_cached wrapped_dbh sql f = + IO_result.bind (create_or_reuse wrapped_dbh sql) @@ fun stmt -> f stmt + + let with_stmt_uncached {dbh; stmt_cache = _} sql f = + IO_result.bind (create dbh sql) @@ fun stmt -> + IO.bind (f stmt) @@ fun res -> + IO.bind (close stmt) @@ function + | Ok () -> IO.return res + | Error _ as e -> IO.return e end end diff --git a/lib/runtime/ppx_mysql_runtime.mli b/lib/runtime/ppx_mysql_runtime.mli index 4e7846a..02a9b1d 100644 --- a/lib/runtime/ppx_mysql_runtime.mli +++ b/lib/runtime/ppx_mysql_runtime.mli @@ -70,6 +70,8 @@ module type PPX_MYSQL_CONTEXT_ARG = sig val create : dbh -> string -> (stmt, error) result IO.t + val close : stmt -> (unit, error) result IO.t + val execute_null : stmt -> string option array -> (stmt_result, error) result IO.t val fetch : stmt_result -> (string option array option, error) result IO.t @@ -106,11 +108,11 @@ module type PPX_MYSQL_CONTEXT = sig type error - type wrapped_error = [`Mysql_error of error] + type wrapped_dbh - type caching_dbh + type wrapped_error = [`Mysql_error of error] - val init : dbh -> caching_dbh + val init : dbh -> wrapped_dbh val execute_null : stmt -> @@ -121,8 +123,14 @@ module type PPX_MYSQL_CONTEXT = sig : stmt_result -> (string option array option, [> wrapped_error]) result IO.t - val with_stmt - : caching_dbh -> + val with_stmt_cached + : wrapped_dbh -> + string -> + (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> + ('a, 'e) result IO.t + + val with_stmt_uncached + : wrapped_dbh -> string -> (stmt -> ('a, ([> wrapped_error] as 'e)) result IO.t) -> ('a, 'e) result IO.t diff --git a/ppx/ppx_mysql.ml b/ppx/ppx_mysql.ml index 03fc119..eadebab 100644 --- a/ppx/ppx_mysql.ml +++ b/ppx/ppx_mysql.ml @@ -285,7 +285,7 @@ let actually_expand ~loc sql_variant query = let[@warning "-26"] process_out_params = [%e build_out_param_processor ~loc out_params] in - Prepared.with_stmt [%e dbh_ident] sql (fun stmt -> + Prepared.with_stmt_cached [%e dbh_ident] sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> [%e process_rows] () )] in diff --git a/tests/test_ppx/test_ppx.expected.ml b/tests/test_ppx/test_ppx.expected.ml index 7c1f647..601daa9 100644 --- a/tests/test_ppx/test_ppx.expected.ml +++ b/tests/test_ppx/test_ppx.expected.ml @@ -13,7 +13,7 @@ let test_no_params dbh = else Result.Error (`Unexpected_number_of_columns (len_row, 0)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -58,7 +58,7 @@ let test_single_output_params dbh = else Result.Error (`Unexpected_number_of_columns (len_row, 1)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -113,7 +113,7 @@ let test_pair_output_params dbh = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -161,7 +161,7 @@ let test_one_input_params dbh ~(id : int) = else Result.Error (`Unexpected_number_of_columns (len_row, 1)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -220,7 +220,7 @@ let test_two_input_pair_output_params dbh ~(id : int) ~(name : string) = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -274,7 +274,7 @@ let test_select_all dbh = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -330,7 +330,7 @@ let test_repeated_input_params dbh ~(id : int) = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -385,7 +385,7 @@ let test_select_opt dbh ~(id : int) = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -421,7 +421,7 @@ let test_execute dbh ~(id : int) = else Result.Error (`Unexpected_number_of_columns (len_row, 0)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> Prepared.fetch stmt_result >>= function @@ -471,7 +471,7 @@ let test_int dbh ~(a : int) ~(b : int option) = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -529,7 +529,7 @@ let test_int32 dbh ~(a : int32) ~(b : int32 option) = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -587,7 +587,7 @@ let test_int64 dbh ~(a : int64) ~(b : int64 option) = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -646,7 +646,7 @@ let test_bool dbh ~(a : bool) ~(b : bool option) = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -705,7 +705,7 @@ let test_string dbh ~(a : string) ~(b : string option) = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -763,7 +763,7 @@ let test_custom_type dbh ~(a : Id.t) ~(b : Phone.t option) = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -834,7 +834,7 @@ let test_list0 dbh elems = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -884,7 +884,7 @@ let test_list1 dbh elems = else Result.Error (`Unexpected_number_of_columns (len_row, 0)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> Prepared.fetch stmt_result >>= function @@ -951,7 +951,7 @@ let test_list2 dbh elems ~(name : string) ~(age : int) = else Result.Error (`Unexpected_number_of_columns (len_row, 2)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> let rec loop acc = @@ -1003,7 +1003,7 @@ let test_list3 dbh elems = else Result.Error (`Unexpected_number_of_columns (len_row, 0)) [@@warning "-26"] in - Prepared.with_stmt dbh sql (fun stmt -> + Prepared.with_stmt_cached dbh sql (fun stmt -> Prepared.execute_null stmt params >>= fun stmt_result -> (fun () -> Prepared.fetch stmt_result >>= function