diff --git a/.gitignore b/.gitignore index fee6d31..b6f3b93 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ /_build/ *.swp +_opam diff --git a/examples/async/dune b/examples/async/dune index 156ab07..208e7a4 100644 --- a/examples/async/dune +++ b/examples/async/dune @@ -1,6 +1,3 @@ -(tests - (names - nonblocking_async_example - nonblocking_async_stress_test) - (libraries mariadb async nonblocking_tests) - (enabled_if %{lib-available:lwt})) +(executable + (name nonblocking_async_example) + (libraries mariadb async)) diff --git a/examples/blocking/blocking_stress_test.ml b/examples/blocking/blocking_stress_test.ml deleted file mode 100644 index 9193330..0000000 --- a/examples/blocking/blocking_stress_test.ml +++ /dev/null @@ -1,45 +0,0 @@ -open Printf - -module M = Mariadb.Blocking - -let env var def = - try Sys.getenv var - with Not_found -> def - -let or_die where = function - | Ok r -> r - | Error (i, e) -> ksprintf failwith "%s: (%d) %s" where i e - -let connect () = - M.connect - ~host:(env "OCAML_MARIADB_HOST" "localhost") - ~user:(env "OCAML_MARIADB_USER" "root") - ~pass:(env "OCAML_MARIADB_PASS" "") - ~db:(env "OCAML_MARIADB_DB" "mysql") () - -let test () = - let dbh = connect () |> or_die "connect" in - (* without CAST result is typed as NULL for some reason *) - let mk_stmt () = M.prepare dbh "SELECT CAST(? AS BINARY)" |> or_die "prepare" in - let stmt = ref (mk_stmt ()) in - for _ = 1 to 100 do - let n = Random.int (1 lsl Random.int 8) in - let s = String.init n (fun _ -> "ACGT".[Random.int 4]) in - let res = M.Stmt.execute !stmt [|`String s|] |> or_die "Stmt.execute" in - assert (M.Res.num_rows res = 1); - (match M.Res.fetch (module M.Row.Array) res |> or_die "Res.fetch" with - | None -> assert false - | Some row -> - let s' = M.Field.string row.(0) in - if s <> s' then printf "@@@ <%s> <%s>\n%!" s s'; - assert (s = s')); - if Random.bool () then begin - M.Stmt.close !stmt |> or_die "Stmt.close"; - stmt := mk_stmt () - end else - M.Stmt.reset !stmt |> or_die "Stmt.reset" - done; - M.Stmt.close !stmt |> or_die "Stmt.close"; - M.close dbh - -let () = for _ = 1 to 500 do test () done diff --git a/examples/blocking/dune b/examples/blocking/dune index 5687bb5..3f83b4f 100644 --- a/examples/blocking/dune +++ b/examples/blocking/dune @@ -1,5 +1,3 @@ -(tests - (names - blocking_example - blocking_stress_test) +(executable + (name blocking_example) (libraries mariadb)) diff --git a/examples/lwt/dune b/examples/lwt/dune index 4abcce5..43459a6 100644 --- a/examples/lwt/dune +++ b/examples/lwt/dune @@ -1,6 +1,3 @@ -(tests - (names - nonblocking_lwt_example - nonblocking_lwt_stress_test) - (libraries mariadb lwt lwt.unix nonblocking_tests) - (enabled_if %{lib-available:lwt})) +(executable + (name nonblocking_lwt_example) + (libraries mariadb lwt lwt.unix)) diff --git a/examples/nonblocking/dune b/examples/nonblocking/dune deleted file mode 100644 index 5bba944..0000000 --- a/examples/nonblocking/dune +++ /dev/null @@ -1,4 +0,0 @@ -(library - (name nonblocking_tests) - (wrapped false) - (libraries mariadb)) diff --git a/examples/nonblocking/nonblocking_stress_test.ml b/examples/nonblocking/nonblocking_stress_test.ml deleted file mode 100644 index c39aeb3..0000000 --- a/examples/nonblocking/nonblocking_stress_test.ml +++ /dev/null @@ -1,167 +0,0 @@ -open Printf - -module Make (W : Mariadb.Nonblocking.Wait) = struct - module M = Mariadb.Nonblocking.Make (W) - open W.IO - - let (>|=) m f = m >>= fun x -> return (f x) - - let env var def = try Sys.getenv var with Not_found -> def - - let or_die where = function - | Ok r -> return r - | Error (i, e) -> eprintf "%s: (%d) %s\n%!" where i e; exit 2 - - let connect () = - M.connect - ~host:(env "OCAML_MARIADB_HOST" "localhost") - ~user:(env "OCAML_MARIADB_USER" "root") - ~pass:(env "OCAML_MARIADB_PASS" "") - ~db:(env "OCAML_MARIADB_DB" "mysql") () - - let rec repeat n f = - if n = 0 then return () else f () >>= fun () -> repeat (n - 1) f - - let string_of_param_type = function - | `Int -> "integer" - | `Float -> "double" - | `String | `Bytes -> "char" - | `Time -> "datetime" - - let random_string () = - let n = Random.int (1 lsl Random.int 8) in - String.init n (fun _ -> "ACGT".[Random.int 4]) - - let random_param_type _ = - match Random.int 5 with - | 0 -> `Int - | 1 -> `Float - | 2 -> `String - | 3 -> `Bytes - | 4 -> `Time - | _ -> assert false - - let random_param param_type = - if Random.int 6 = 0 then `Null else - match param_type with - | `Int -> `Int (Random.bits ()) - | `Float -> `Float (ldexp (Random.float 2.0 -. 1.0) (Random.int 16)) - | `String -> `String (random_string ()) - | `Bytes -> `Bytes (Bytes.of_string (random_string ())) - | `Time -> `Time (M.Time.utc_timestamp (Random.float 1577833200.0)) - - let make_nary_select_stmt dbh param_types = - let buf = Buffer.create 64 in - Buffer.add_string buf "SELECT "; - for i = 0 to Array.length param_types - 1 do - if i > 0 then Buffer.add_string buf ", "; - bprintf buf "CAST(? AS %s)" (string_of_param_type param_types.(i)) - (* CAST is only used as a type annotation to prevent the parameters from - * being cast. *) - done; - M.prepare dbh (Buffer.contents buf) >>= or_die "prepare" - - let string_of_timestamp t = - let y, mon, day = M.Time.(year t, month t, day t) in - let h, m, s, us = M.Time.(hour t, minute t, second t, microsecond t) in - sprintf "%04d-%02d-%02dT%02d:%02d:%02d.%06d" y mon day h m s us - - let string_of_value = function - | `Null -> "NULL" - | `Int i -> sprintf "(%d : int)" i - | `Float x -> sprintf "(%.8g : float)" x - | `String s -> sprintf "(%S : string)" s - | `Bytes s -> sprintf "(%S : bytes)" (Bytes.to_string s) - | `Time t -> string_of_timestamp t - - let equal_float x x' = - abs_float (x -. x') /. (abs_float (x +. x') +. epsilon_float) < 1e-6 - - let equal_time t t' = - let open M.Time in let open Stdlib in - (* Treat `Datetime and `Timestamp as equal. *) - year t = year t' && month t = month t' && day t = day t' && - hour t = hour t' && minute t = minute t' && second t = second t' - - let equal_field v v' = - match v, v' with - | `Null, `Null -> true - | `Null, _ | _, `Null -> false - | `Int i, `Int i' -> i = i' - | `Int i, `Float x | `Float x, `Int i -> float_of_int i = x - | `Int _, _ | _, `Int _ -> false - | `Float x, `Float x' -> equal_float x x' - | `Float _, _ | _, `Float _ -> false - | `String s, `String s' -> s = s' - | `String s, `Bytes s' | `Bytes s', `String s -> s = Bytes.to_string s' - | `String _, _ | _, `String _ -> false - | `Bytes s, `Bytes s' -> s = s' - | `Bytes _, _ | _, `Bytes _ -> false - | `Time t, `Time t' -> equal_time t t' - - let assert_field_equal v v' = - if not (equal_field v v') then begin - eprintf "Parameter %s came back as %s.\n%!" - (string_of_value v) (string_of_value v'); - exit 2 - end - - (* Make sure the conversion between timestamps and strings are consistent - * between MariaDB and OCaml. By sending timestamps to be compared as binary - * and as string, this also verifies the MYSQL_TIME encoding. *) - let test_datetime_and_string_conv dbh = - let t = M.Time.utc_timestamp (Random.float 1577833200.0) in - let s = string_of_timestamp t in - M.prepare dbh "SELECT CAST(? AS DATETIME), DATE_FORMAT(?, '%Y-%m-%dT%T.%f')" - >>= or_die "prepare" >>= fun stmt -> - let params = [|`String s; `Time t|] in - M.Stmt.execute stmt params >>= or_die "Stmt.execute" >>= fun res -> - assert (M.Res.num_rows res = 1); - M.Res.fetch (module M.Row.Array) res >>= or_die "Res.fetch" >|= - (function - | Some [|t'; s'|] -> - assert (equal_time t M.Field.(time t')); - assert (s = M.Field.(string s')) - | _ -> assert false) - - let test () = - let stmt_cache = Hashtbl.create 7 in - connect () >>= or_die "connect" >>= fun dbh -> - test_datetime_and_string_conv dbh >>= fun () -> - repeat 100 begin fun () -> - let n = Random.int (1 lsl Random.int 8) + 1 in - let param_types = Array.init n random_param_type in - let params = Array.map random_param param_types in - begin - try - return (Hashtbl.find stmt_cache param_types) - with Not_found -> - make_nary_select_stmt dbh param_types - end >>= fun stmt -> - M.Stmt.execute stmt params >>= or_die "Stmt.execute" >>= fun res -> - assert (M.Res.num_rows res = 1); - M.Res.fetch (module M.Row.Array) res >>= or_die "Res.fetch" >>= - (function - | None -> assert false - | Some row -> - assert (Array.length row = Array.length params); - for i = 0 to n - 1 do - assert_field_equal params.(i) (M.Field.value row.(i)) - done; - return ()) >>= fun () -> - if Random.bool () then - M.Stmt.close stmt >>= or_die "Stmt.close" >|= fun () -> - Hashtbl.remove stmt_cache param_types - else - M.Stmt.reset stmt >>= or_die "Stmt.reset" >|= fun () -> - Hashtbl.replace stmt_cache param_types stmt - end >>= fun () -> - Hashtbl.fold - (fun _ stmt prologue -> - prologue >>= fun () -> - M.Stmt.close stmt >>= or_die "Stmt.close") - stmt_cache (return ()) >>= fun () -> - M.close dbh - - let main () = repeat 500 test -end diff --git a/examples/select/dune b/examples/select/dune index 23f9e0b..798d021 100644 --- a/examples/select/dune +++ b/examples/select/dune @@ -1,5 +1,3 @@ -(tests - (names - nonblocking_select_example - nonblocking_select_stress_test) - (libraries mariadb unix nonblocking_tests)) +(executable + (name nonblocking_select_example) + (libraries mariadb unix)) diff --git a/tests/README.md b/tests/README.md new file mode 100644 index 0000000..f297957 --- /dev/null +++ b/tests/README.md @@ -0,0 +1,20 @@ +This directory contains the test suite. The main code split up according to +whether the tests are using the blocking or non-blocking API, and for the +latter there are instances depending on the concurrency library: + +| Directory | Description +| --------- | ----------- +| nonblocking | Abstract tests suite implementation. +| blocking | Tests the blocking and nonblocking APIs without concurrency. +| nonblocking-async | Tests the nonblocking API using async. +| nonblocking-lwt | Tests the nonblocking API using Lwt. + +Tests require access to a MariaDB instance to run. You will likely need to +set some environment variables to point the test suite to the right place: + +| Environment variable | Description +| -------------------- | ----------- +| `OCAML_MARIADB_HOST` | Host to connect to. +| `OCAML_MARIADB_USER` | Authenticate as the given user. +| `OCAML_MARIADB_PASS` | Authenticate with the given password. +| `OCAML_MARIADB_DB` | Connect to the given database. diff --git a/examples/select/nonblocking_select_stress_test.ml b/tests/blocking/blocking_testsuite.ml similarity index 68% rename from examples/select/nonblocking_select_stress_test.ml rename to tests/blocking/blocking_testsuite.ml index 0a341e1..5ec7572 100644 --- a/examples/select/nonblocking_select_stress_test.ml +++ b/tests/blocking/blocking_testsuite.ml @@ -1,6 +1,7 @@ module S = Mariadb.Nonblocking.Status -module Test = Nonblocking_stress_test.Make (struct +module Wait = struct + module IO = struct type 'a future = 'a let (>>=) x f = f x @@ -28,6 +29,17 @@ module Test = Nonblocking_stress_test.Make (struct () with Unix.Unix_error (_, _, _) -> return @@ S.create ~timeout: true () -end) -let () = Test.main () +end + +(* Test for the blocking API. *) +module Test_blocking = + Nonblocking_testsuite.Make (Wait.IO) (Mariadb.Blocking) + +(* Test for the non-blocking API without concurrency. *) +module Test_nonblocking = + Nonblocking_testsuite.Make (Wait.IO) (Mariadb.Nonblocking.Make (Wait)) + +let () = + Test_blocking.main (); + Test_nonblocking.main () diff --git a/tests/blocking/dune b/tests/blocking/dune new file mode 100644 index 0000000..752d9ac --- /dev/null +++ b/tests/blocking/dune @@ -0,0 +1,3 @@ +(test + (name blocking_testsuite) + (libraries mariadb nonblocking_testsuite unix)) diff --git a/tests/nonblocking-async/dune b/tests/nonblocking-async/dune new file mode 100644 index 0000000..d41a570 --- /dev/null +++ b/tests/nonblocking-async/dune @@ -0,0 +1,4 @@ +(test + (name nonblocking_testsuite_async) + (libraries mariadb async nonblocking_testsuite) + (enabled_if %{lib-available:lwt})) diff --git a/examples/async/nonblocking_async_stress_test.ml b/tests/nonblocking-async/nonblocking_testsuite_async.ml similarity index 93% rename from examples/async/nonblocking_async_stress_test.ml rename to tests/nonblocking-async/nonblocking_testsuite_async.ml index 5601566..904a31c 100644 --- a/examples/async/nonblocking_async_stress_test.ml +++ b/tests/nonblocking-async/nonblocking_testsuite_async.ml @@ -4,7 +4,7 @@ open Async module S = Mariadb.Nonblocking.Status -module Test = Nonblocking_stress_test.Make (struct +module Wait = struct module IO = struct type 'a future = 'a Deferred.t @@ -45,8 +45,10 @@ module Test = Nonblocking_stress_test.Make (struct Fd.close ~file_descriptor_handling:Fd.Do_not_close_file_descriptor fd >>= fun () -> Deferred.return @@ S.create ~read ~write ~timeout () +end -end) +module Test = + Nonblocking_testsuite.Make (Wait.IO) (Mariadb.Nonblocking.Make (Wait)) let _main : unit Deferred.t = Test.main () >>= fun () -> Shutdown.exit 0 diff --git a/tests/nonblocking-lwt/dune b/tests/nonblocking-lwt/dune new file mode 100644 index 0000000..ab949ee --- /dev/null +++ b/tests/nonblocking-lwt/dune @@ -0,0 +1,4 @@ +(test + (name nonblocking_testsuite_lwt) + (libraries mariadb lwt lwt.unix nonblocking_testsuite) + (enabled_if %{lib-available:lwt})) diff --git a/examples/lwt/nonblocking_lwt_stress_test.ml b/tests/nonblocking-lwt/nonblocking_testsuite_lwt.ml similarity index 90% rename from examples/lwt/nonblocking_lwt_stress_test.ml rename to tests/nonblocking-lwt/nonblocking_testsuite_lwt.ml index 147a12c..0ce6e0b 100644 --- a/examples/lwt/nonblocking_lwt_stress_test.ml +++ b/tests/nonblocking-lwt/nonblocking_testsuite_lwt.ml @@ -2,7 +2,7 @@ open Lwt.Infix module S = Mariadb.Nonblocking.Status -module Test = Nonblocking_stress_test.Make (struct +module Wait = struct module IO = struct type 'a future = 'a Lwt.t @@ -32,6 +32,10 @@ module Test = Nonblocking_stress_test.Make (struct (function | Lwt_unix.Timeout -> Lwt.return @@ S.create ~timeout:true () | e -> Lwt.fail e) -end) + +end + +module Test = + Nonblocking_testsuite.Make (Wait.IO) (Mariadb.Nonblocking.Make (Wait)) let () = Lwt_main.run (Test.main ()) diff --git a/tests/nonblocking/dune b/tests/nonblocking/dune new file mode 100644 index 0000000..0ce257a --- /dev/null +++ b/tests/nonblocking/dune @@ -0,0 +1,3 @@ +(library + (name nonblocking_testsuite) + (libraries mariadb)) diff --git a/tests/nonblocking/nonblocking_testsuite.ml b/tests/nonblocking/nonblocking_testsuite.ml new file mode 100644 index 0000000..c186f9a --- /dev/null +++ b/tests/nonblocking/nonblocking_testsuite.ml @@ -0,0 +1,330 @@ +open Printf + +module type IO = sig + type 'a future + val (>>=) : 'a future -> ('a -> 'b future) -> 'b future + val return : 'a -> 'a future +end + +module Make + (IO : IO) + (M : Mariadb.Nonblocking.S with type 'a future := 'a IO.future) = +struct + open IO + + let (>|=) m f = m >>= fun x -> return (f x) + + let env var def = try Sys.getenv var with Not_found -> def + + let or_die where = function + | Ok r -> return r + | Error (i, e) -> eprintf "%s: (%d) %s\n%!" where i e; exit 2 + + let rec iter_s_list f = function + | [] -> return () + | x :: xs -> f x >>= fun () -> iter_s_list f xs + + let rec map_s_list f = function + | [] -> return [] + | x :: xs -> f x >>= fun y -> map_s_list f xs >|= fun ys -> y :: ys + + let connect () = + M.connect + ~host:(env "OCAML_MARIADB_HOST" "localhost") + ~user:(env "OCAML_MARIADB_USER" "root") + ~pass:(env "OCAML_MARIADB_PASS" "") + ~db:(env "OCAML_MARIADB_DB" "mysql") + ~port:(int_of_string (env "OCAML_MARIADB_PORT" "0")) () + + let rec repeat n f = + if n = 0 then return () else f () >>= fun () -> repeat (n - 1) f + + let string_of_param_type = function + | `Int -> "integer" + | `Float -> "double" + | `String | `Bytes -> "char" + | `Time -> "datetime" + + let random_string () = + let n = Random.int (1 lsl Random.int 8) in + String.init n (fun _ -> "ACGT".[Random.int 4]) + + let random_param_type _ = + match Random.int 5 with + | 0 -> `Int + | 1 -> `Float + | 2 -> `String + | 3 -> `Bytes + | 4 -> `Time + | _ -> assert false + + let random_param param_type = + if Random.int 6 = 0 then `Null else + match param_type with + | `Int -> `Int (Random.bits ()) + | `Float -> `Float (ldexp (Random.float 2.0 -. 1.0) (Random.int 16)) + | `String -> `String (random_string ()) + | `Bytes -> `Bytes (Bytes.of_string (random_string ())) + | `Time -> `Time (M.Time.utc_timestamp (Random.float 1577833200.0)) + + let make_nary_select_stmt dbh param_types = + let buf = Buffer.create 64 in + Buffer.add_string buf "SELECT "; + for i = 0 to Array.length param_types - 1 do + if i > 0 then Buffer.add_string buf ", "; + bprintf buf "CAST(? AS %s)" (string_of_param_type param_types.(i)) + (* CAST is only used as a type annotation to prevent the parameters from + * being cast. *) + done; + M.prepare dbh (Buffer.contents buf) >>= or_die "prepare" + + let string_of_timestamp t = + let y, mon, day = M.Time.(year t, month t, day t) in + let h, m, s, us = M.Time.(hour t, minute t, second t, microsecond t) in + sprintf "%04d-%02d-%02dT%02d:%02d:%02d.%06d" y mon day h m s us + + let string_of_value = function + | `Null -> "NULL" + | `Int i -> sprintf "(%d : int)" i + | `Float x -> sprintf "(%.8g : float)" x + | `String s -> sprintf "(%S : string)" s + | `Bytes s -> sprintf "(%S : bytes)" (Bytes.to_string s) + | `Time t -> string_of_timestamp t + + let equal_float x x' = + abs_float (x -. x') /. (abs_float (x +. x') +. epsilon_float) < 1e-6 + + let equal_time t t' = + let open M.Time in let open Stdlib in + (* Treat `Datetime and `Timestamp as equal. *) + year t = year t' && month t = month t' && day t = day t' && + hour t = hour t' && minute t = minute t' && second t = second t' + + let equal_field v v' = + match v, v' with + | `Null, `Null -> true + | `Null, _ | _, `Null -> false + | `Int i, `Int i' -> i = i' + | `Int i, `Float x | `Float x, `Int i -> float_of_int i = x + | `Int _, _ | _, `Int _ -> false + | `Float x, `Float x' -> equal_float x x' + | `Float _, _ | _, `Float _ -> false + | `String s, `String s' -> s = s' + | `String s, `Bytes s' | `Bytes s', `String s -> s = Bytes.to_string s' + | `String _, _ | _, `String _ -> false + | `Bytes s, `Bytes s' -> s = s' + | `Bytes _, _ | _, `Bytes _ -> false + | `Time t, `Time t' -> equal_time t t' + + let assert_field_equal v v' = + if not (equal_field v v') then begin + eprintf "Parameter %s came back as %s.\n%!" + (string_of_value v) (string_of_value v'); + exit 2 + end + + let execute_no_data stmt = + M.Stmt.execute stmt [||] >>= or_die "execute" >|= fun res -> + assert (M.Res.num_rows res = 0) + + let fetch_single_row res = + assert (M.Res.num_rows res = 1); + M.Res.fetch (module M.Row.Array) res >>= or_die "fetch" >|= fun row -> + (match row with + | None -> failwith "expecting one row, no rows returned" + | Some a -> a) + + let test_insert_id () = + connect () >>= or_die "connect" >>= fun dbh -> + M.prepare dbh + "CREATE TEMPORARY TABLE ocaml_mariadb_test \ + (id integer PRIMARY KEY AUTO_INCREMENT)" + >>= or_die "prepare" + >>= fun create_table_stmt -> + execute_no_data create_table_stmt >>= fun () -> + M.prepare dbh "INSERT INTO ocaml_mariadb_test VALUES (DEFAULT)" + >>= or_die "prepare" + >>= fun insert_stmt -> + let rec check_inserts_from expected_id = + if expected_id > 5 then return () else + M.Stmt.execute insert_stmt [||] >>= or_die "insert" >>= fun res -> + assert (M.Res.num_rows res = 0); + assert (M.Res.insert_id res = expected_id); + check_inserts_from (expected_id + 1) + in + check_inserts_from 1 >>= fun () -> + M.close dbh + + let test_txn () = + connect () >>= or_die "connect" >>= fun dbh -> + + M.prepare dbh + "CREATE TEMPORARY TABLE ocaml_mariadb_test (i integer PRIMARY KEY)" + >>= or_die "prepare create_table_stmt" + >>= fun create_table_stmt -> + execute_no_data create_table_stmt >>= fun () -> + + map_s_list (fun s -> M.prepare dbh s >>= or_die "prepare") + ["INSERT INTO ocaml_mariadb_test VALUES (1), (2)"; + "INSERT INTO ocaml_mariadb_test SELECT i + 10 FROM ocaml_mariadb_test"] + >>= fun insert_stmts -> + M.prepare dbh "SELECT CAST(sum(i) AS integer) FROM ocaml_mariadb_test" + >>= or_die "prepare sum" + >>= fun sum_stmt -> + + M.start_txn dbh >>= or_die "start_txn" >>= fun () -> + iter_s_list execute_no_data insert_stmts >>= fun () -> + M.rollback dbh >>= or_die "rollback" >>= fun () -> + M.Stmt.execute sum_stmt [||] >>= or_die "execute" >>= fun res -> + fetch_single_row res >>= fun row -> + assert (Array.length row = 1 && M.Field.null_value row.(0)); + + M.start_txn dbh >>= or_die "start_txn" >>= fun () -> + iter_s_list execute_no_data insert_stmts >>= fun () -> + M.commit dbh >>= or_die "rollback" >>= fun () -> + M.Stmt.execute sum_stmt [||] >>= or_die "execute" >>= fun res -> + fetch_single_row res >>= fun row -> + assert (Array.length row = 1 && M.Field.int row.(0) = 26); + + M.close dbh + + (* Make sure the conversion between timestamps and strings are consistent + * between MariaDB and OCaml. By sending timestamps to be compared as binary + * and as string, this also verifies the MYSQL_TIME encoding. *) + let test_datetime_and_string_conv dbh = + let t = M.Time.utc_timestamp (Random.float 1577833200.0) in + let s = string_of_timestamp t in + M.prepare dbh "SELECT CAST(? AS DATETIME), DATE_FORMAT(?, '%Y-%m-%dT%T.%f')" + >>= or_die "prepare" >>= fun stmt -> + let params = [|`String s; `Time t|] in + M.Stmt.execute stmt params >>= or_die "Stmt.execute" >>= fun res -> + assert (M.Res.num_rows res = 1); + M.Res.fetch (module M.Row.Array) res >>= or_die "Res.fetch" >|= + (function + | Some [|t'; s'|] -> + assert (equal_time t M.Field.(time t')); + assert (s = M.Field.(string s')) + | _ -> assert false) + + let test_random_select () = + let stmt_cache = Hashtbl.create 7 in + connect () >>= or_die "connect" >>= fun dbh -> + test_datetime_and_string_conv dbh >>= fun () -> + repeat 100 begin fun () -> + let n = Random.int (1 lsl Random.int 8) + 1 in + let param_types = Array.init n random_param_type in + let params = Array.map random_param param_types in + begin + try + return (Hashtbl.find stmt_cache param_types) + with Not_found -> + make_nary_select_stmt dbh param_types + end >>= fun stmt -> + M.Stmt.execute stmt params >>= or_die "Stmt.execute" >>= fun res -> + assert (M.Res.num_rows res = 1); + M.Res.fetch (module M.Row.Array) res >>= or_die "Res.fetch" >>= + (function + | None -> assert false + | Some row -> + assert (Array.length row = Array.length params); + for i = 0 to n - 1 do + assert_field_equal params.(i) (M.Field.value row.(i)) + done; + return ()) >>= fun () -> + if Random.bool () then + M.Stmt.close stmt >>= or_die "Stmt.close" >|= fun () -> + Hashtbl.remove stmt_cache param_types + else + M.Stmt.reset stmt >>= or_die "Stmt.reset" >|= fun () -> + Hashtbl.replace stmt_cache param_types stmt + end >>= fun () -> + Hashtbl.fold + (fun _ stmt prologue -> + prologue >>= fun () -> + M.Stmt.close stmt >>= or_die "Stmt.close") + stmt_cache (return ()) >>= fun () -> + M.close dbh + + let test_many_select () = repeat 500 test_random_select + + let test_integer, test_bigint = + let make_check type_ = + connect () >>= or_die "connect" >>= fun dbh -> + M.prepare dbh + (Printf.sprintf + "CREATE TEMPORARY TABLE ocaml_mariadb_test (id integer PRIMARY KEY \ + AUTO_INCREMENT, value %s, value_unsigned %s unsigned)" + type_ type_) + >>= or_die "prepare create" + >>= fun create_table_stmt -> + execute_no_data create_table_stmt >>= fun () -> + let check (value : [ `Signed of int | `Unsigned of int ]) = + let column = + match value with + | `Signed _ -> "value" + | `Unsigned _ -> "value_unsigned" + in + M.prepare dbh + (Printf.sprintf "INSERT INTO ocaml_mariadb_test (%s) VALUES (?)" + column) + >>= or_die "prepare insert" + >>= fun insert_stmt -> + let value_to_insert = + match value with `Signed n -> n | `Unsigned n -> n + in + M.Stmt.execute insert_stmt [| `Int value_to_insert |] + >>= or_die "insert" + >>= fun res -> + M.prepare dbh + (Printf.sprintf "SELECT %s FROM ocaml_mariadb_test WHERE id = (?)" + column) + >>= or_die "prepare select" + >>= fun select_stmt -> + M.Stmt.execute select_stmt [| `Int (M.Res.insert_id res) |] + >>= or_die "Stmt.execute" + >>= M.Res.fetch (module M.Row.Array) + >>= or_die "Res.fetch" + >|= function + | Some [| inserted_value |] -> + assert_field_equal (`Int value_to_insert) + (`Int (M.Field.int inserted_value)) + | _ -> assert false + in + return (dbh, check) + in + let test_integer () = + make_check "integer" >>= fun (dbh, check) -> + let input = + [ + `Signed + (Int32.max_int |> Int32.to_int (* max value for integer column *)); + `Signed + (Int32.min_int |> Int32.to_int (* min value for integer column *)); + `Unsigned (Unsigned.UInt32.max_int |> Unsigned.UInt32.to_int) + (* max value for unsgined integer column. + Produces the following error: insert: (1264) Out of range value for column 'value_unsigned' at row 1 *); + ] + in + iter_s_list check input >>= fun () -> M.close dbh + in + let test_bigint () = + make_check "bigint" >>= fun (dbh, check) -> + let input = + [ + `Signed Int.max_int + (* [Int.max_int] is below the max value for bigint column (which is equivalent to [Int64.max_int]) + Produces the following error: Parameter (4611686018427387903 : int) came back as (-1 : int) *); + `Unsigned Int.max_int + (* insert: (1264) Out of range value for column 'value_unsigned' at row 1 *); + ] + in + iter_s_list check input >>= fun () -> M.close dbh + in + (test_integer, test_bigint) + + let main () = + test_insert_id () >>= fun () -> + test_txn () >>= fun () -> + test_many_select () >>= fun () -> + test_integer () >>= fun () -> test_bigint () +end