swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

10
unikernel/duniverse/ocaml-caqti/testsuite/README.md Normal file
View file

@ -0,0 +1,10 @@
## Main Testsuite
This directory contains tests to be run across different concurrency engines
and across different database drivers. Additional tests can be found in the
`test` subdirectories of some per-package subdirectories.
By default the tests are only run against sqlite3. To run it against other
database systems, create a file `uris.conf` in the current directory
containing a list of database URLs, one per line. This will cause each test
executable to run a duplicate of the testsuite for each URL.

115
unikernel/duniverse/ocaml-caqti/testsuite/deps_of_uris.ml Normal file
View file

@ -0,0 +1,115 @@
(* Copyright (C) 2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking Exception.
*
* This library is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Testlib
module String_set = Set.Make (String)
(* This has been edited to emit (package ...) instead of precise internal
* dependencies, since the latter does not support runtest with -p. *)
let (^/) p q = if p = "." then q else if q = "." then p else Filename.concat p q
let (%) f g x = f (g x)
let fold_list f = Fun.flip (List.fold_left (Fun.flip f))
let failwithf = Format.kasprintf failwith
let get_install_dir () =
let rec loop dir sw acc =
(match Filename.basename dir with
| "." | "/" -> failwith "Cannot determine toplevel build directory."
| "_build" -> acc ^/ "_build/install" ^/ sw
| sw -> loop (Filename.dirname dir) sw (acc ^/ ".."))
in
let cwd = Sys.getcwd () in
loop (Filename.dirname cwd) (Filename.basename cwd) "."
let library_deps public_name =
let libdir = get_install_dir () ^/ "lib" in
let priv_name = String.map (function '-' | '.' -> '_' | c -> c) public_name in
let package, library_dir =
(match String.split_on_char '.' public_name with
| [] -> assert false
| (package :: _) as comps -> (package, String.concat "/" comps))
in
[
libdir ^/ package ^/ "META";
libdir ^/ library_dir ^/ priv_name ^ ".cma";
libdir ^/ library_dir ^/ priv_name ^ ".cmxs";
]
let plugin_deps public_name =
let libdir = get_install_dir () ^/ "lib" in
let plugin_name = String.map (function '.' -> '-' | c -> c) public_name in
let plugin_meta = libdir ^/ "caqti/plugins" ^/ plugin_name ^/ "META" in
plugin_meta :: library_deps public_name
let driver_package_of_uri uri =
(match Uri.scheme uri with
| Some "mariadb" ->
"caqti-driver-mariadb"
| Some ("postgres" | "postgresql") ->
"caqti-driver-postgresql"
| Some "pgx" ->
"caqti-driver-pgx"
| Some "sqlite3" ->
"caqti-driver-sqlite3"
| _ ->
failwithf "Cannot determine driver dependency for %a." Uri.pp uri)
let package_deps_of_uri uri =
["(package " ^ driver_package_of_uri uri ^ ")"]
let library_deps_of_uri uri =
library_deps "caqti" @ plugin_deps (driver_package_of_uri uri)
let main common_args profile tls_library =
let is_release = profile = "release" in
let tls_deps =
let tls_configured =
Caqti_connect_config.mem_name "tls" common_args.connect_config
in
(match tls_configured, tls_library with
| false, _ | _, None -> []
| true, Some tls_library ->
if is_release then
["(package " ^ List.hd (String.split_on_char '.' tls_library) ^ ")"]
else
plugin_deps tls_library)
in
let deps_of_uri =
if is_release then package_deps_of_uri else library_deps_of_uri
in
String_set.of_list tls_deps
|> fold_list (fold_list String_set.add % deps_of_uri) common_args.uris
|> String_set.elements
|> String.concat " "
|> Printf.printf "(%s)\n"
let main_cmd =
let open Cmdliner in
let profile =
let docv = "profile-name" in
Arg.(value @@ opt string "dev" @@ info ~docv ["profile"])
in
let tls_library =
let docv = "public-library-name" in
Arg.(value @@ opt (some string) None @@ info ~docv ["tls-library"])
in
Cmd.v (Cmd.info "deps_of_uris")
Term.(const main $ Testlib.common_args () $ profile $ tls_library)
let () =
exit (Cmdliner.Cmd.eval main_cmd)

186
unikernel/duniverse/ocaml-caqti/testsuite/dune Normal file
View file

@ -0,0 +1,186 @@
; Generate default file containing DB URIs to test against, if not present.
(rule
(targets uris.conf)
(mode fallback)
(action (write-file %{targets} "sqlite3:test.db?busy_timeout=60000\n")))
(executable
(name deps_of_uris)
(modules deps_of_uris)
(libraries testlib testlib_tls uri))
(rule
(target dune.uri-deps-blocking)
(deps
(:U %{env:CAQTI_TEST_URIS_FILE=uris.conf})
(env_var CAQTI_TEST_X509_AUTHENTICATOR))
(action
; FIXME: Do we need to work around missing TLS?
(with-stdout-to %{target}
(run %{dep:deps_of_uris.exe} --profile %{profile} -U %{U}))))
(rule
(target dune.uri-deps-eio)
(deps
(:U %{env:CAQTI_TEST_URIS_FILE=uris.conf})
(env_var CAQTI_TEST_X509_AUTHENTICATOR))
(action
(with-stdout-to %{target}
(run %{dep:deps_of_uris.exe} --profile %{profile} -U %{U}
--tls-library caqti-tls-eio))))
(rule
(target dune.uri-deps-lwt)
(deps
(:U %{env:CAQTI_TEST_URIS_FILE=uris.conf})
(env_var CAQTI_TEST_X509_AUTHENTICATOR))
(action
(with-stdout-to %{target}
(run %{dep:deps_of_uris.exe} --profile %{profile} -U %{U}
--tls-library caqti-tls-lwt.unix))))
(rule
(target dune.uri-deps-async)
(deps
(:U %{env:CAQTI_TEST_URIS_FILE=uris.conf})
(env_var CAQTI_TEST_X509_AUTHENTICATOR))
(action
(with-stdout-to %{target}
(run %{dep:deps_of_uris.exe} --profile %{profile} -U %{U}
--tls-library caqti-tls-async))))
(rule
(target dune.uri-deps-miou-unix)
(deps
(:U %{env:CAQTI_TEST_URIS_FILE=uris.conf})
(env_var CAQTI_TEST_X509_AUTHENTICATOR))
(action
(with-stdout-to
%{target}
(run
%{dep:deps_of_uris.exe}
--profile
%{profile}
-U
%{U}
--tls-library
caqti-tls-miou))))
; The generic testsuite as a library.
(library
(name testsuite)
(wrapped false)
(flags (:standard -alert -caqti_unstable))
(modules
test_connect
test_error_cause
test_failure
test_parallel
test_param
test_sql)
(libraries caqti caqti.platform ptime.clock.os testlib testlib_tls))
; Instantiations of the testsuite.
(executable
(name main_blocking)
(modules main_blocking)
(libraries
caqti caqti.blocking caqti.plugin
alcotest testlib testlib_blocking testsuite))
(rule
(alias runtest)
; This breaks the scheme of placing tests under the platform packages in order
; to avoid a cyclic with-test dependency.
(package caqti-driver-sqlite3)
(deps
(:test main_blocking.exe)
(:U %{env:CAQTI_TEST_URIS_FILE=uris.conf})
(include dune.uri-deps-blocking)
(env_var CAQTI_TEST_X509_AUTHENTICATOR))
(locks /db/testsuite)
(action (run %{test} -U %{U})))
(executable
(name main_eio_unix)
(enabled_if (>= %{ocaml_version} "5.0"))
(modules main_eio_unix)
(libraries
caqti caqti-eio.unix caqti.plugin
alcotest eio eio_main mirage-crypto-rng.unix
testlib testlib_eio_unix testsuite))
(rule
(alias runtest)
(package caqti-eio)
(enabled_if (>= %{ocaml_version} "5.0"))
(deps
(:test main_eio_unix.exe)
(:U %{env:CAQTI_TEST_URIS_FILE=uris.conf})
(include dune.uri-deps-eio)
(env_var CAQTI_TEST_X509_AUTHENTICATOR))
(locks /db/testsuite)
(action (run %{test} -U %{U})))
(executable
(name main_miou_unix)
(enabled_if
(>= %{ocaml_version} "5.0"))
(modules main_miou_unix)
(libraries
caqti
caqti-miou.unix
caqti.plugin
alcotest
threads
mirage-crypto-rng-miou-unix
testlib
testlib_miou_unix
testsuite))
(rule
(alias runtest)
(package caqti-miou)
(enabled_if
(>= %{ocaml_version} "5.0"))
(deps
(:test main_miou_unix.exe)
(:U %{env:CAQTI_TEST_URIS_FILE=uris.conf})
(include dune.uri-deps-miou-unix)
(env_var CAQTI_TEST_X509_AUTHENTICATOR))
(locks /db/testsuite)
(action
(run %{test} -U %{U})))
(executable
(name main_async)
(modules main_async)
(libraries
caqti caqti.platform caqti.plugin caqti-async
alcotest-async testlib testlib_async testsuite))
(rule
(alias runtest)
(package caqti-async)
(deps
(:test main_async.exe)
(:U %{env:CAQTI_TEST_URIS_FILE=uris.conf})
(include dune.uri-deps-async)
(env_var CAQTI_TEST_X509_AUTHENTICATOR))
(locks /db/testsuite)
(action (run %{test} -U %{U})))
(executable
(name main_lwt_unix)
(modules main_lwt_unix)
(libraries
caqti caqti.platform caqti.plugin
caqti-lwt caqti-lwt.unix
alcotest-lwt testlib testlib_lwt_unix testsuite))
(rule
(alias runtest)
(package caqti-lwt)
(deps (:test main_lwt_unix.exe) (include dune.uri-deps-lwt) uris.conf)
(locks /db/testsuite)
(action (run %{test})))

84
unikernel/duniverse/ocaml-caqti/testsuite/main_async.ml Normal file
View file

@ -0,0 +1,84 @@
(* Copyright (C) 2014--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking Exception.
*
* This library is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Async_kernel
open Async_unix
open Core
module List = Stdlib.List
open Testlib
open Testlib_async
module Test_error_cause = Test_error_cause.Make (Testlib_async)
module Test_parallel = Test_parallel.Make (Testlib_async)
module Test_param = Test_param.Make (Testlib_async)
module Test_sql = Test_sql.Make (Testlib_async)
module Test_failure = Test_failure.Make (Testlib_async)
module Test_connect = Test_connect.Make (Testlib_async)
let mk_test (name, connect, pool) =
let pass_connect (name, speed, f) = (name, speed, (fun () -> f connect)) in
let pass_conn (name, speed, f) =
let f' () =
Caqti_async.Pool.use (fun c -> f c >>| fun () -> Ok ()) pool >>| function
| Ok () -> ()
| Error err -> Alcotest.failf "%a" Caqti_error.pp err
in
(name, speed, f')
in
let pass_pool (name, speed, f) = (name, speed, (fun () -> f pool)) in
let test_cases =
List.map pass_conn Test_sql.connection_test_cases @
List.map pass_conn Test_error_cause.test_cases @
List.map pass_pool Test_parallel.test_cases @
List.map pass_conn Test_param.test_cases @
List.map pass_conn Test_failure.test_cases @
List.map pass_pool Test_sql.pool_test_cases @
List.map pass_connect Test_connect.test_cases
in
(name, test_cases)
let post_connect conn =
List_result_fiber.iter_s (fun f -> f conn) [
Test_sql.post_connect;
]
let env =
let (&) f g di var = try f di var with Stdlib.Not_found -> g di var in
Test_sql.env & Test_error_cause.env
let mk_tests {uris; connect_config} =
let pool_config = Caqti_pool_config.create ~max_size:16 () in
let create_target uri =
let connect () = Caqti_async.connect ~config:connect_config ~env uri in
(match Caqti_async.connect_pool uri
~pool_config ~post_connect ~config:connect_config ~env with
| Ok pool ->
(test_name_of_uri uri, connect, pool)
| Error err ->
Error.raise (Error.of_exn (Caqti_error.Exn err)))
in
let targets = List.map create_target uris in
List.map mk_test targets
let main () =
Deferred.upon
(Alcotest_cli.run_with_args_dependency "test_sql_async"
(Testlib.common_args ()) mk_tests)
(fun () -> Shutdown.shutdown 0)
let () = never_returns (Scheduler.go_main ~main ())

71
unikernel/duniverse/ocaml-caqti/testsuite/main_blocking.ml Normal file
View file

@ -0,0 +1,71 @@
(* Copyright (C) 2018--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking Exception.
*
* This library is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Testlib
open Testlib_blocking
module Test_error_cause = Test_error_cause.Make (Testlib_blocking)
module Test_param = Test_param.Make (Testlib_blocking)
module Test_sql = Test_sql.Make (Testlib_blocking)
module Test_failure = Test_failure.Make (Testlib_blocking)
module Test_connect = Test_connect.Make (Testlib_blocking)
let mk_test (name, connect, pool) =
let pass_connect (name, speed, f) = (name, speed, (fun () -> f connect)) in
let pass_conn (name, speed, f) =
let f' () =
Caqti_blocking.Pool.use (fun c -> Ok (f c)) pool |> function
| Ok () -> ()
| Error err -> Alcotest.failf "%a" Caqti_error.pp err
in
(name, speed, f')
in
let pass_pool (name, speed, f) = (name, speed, (fun () -> f pool)) in
let test_cases =
List.map pass_conn Test_sql.connection_test_cases @
List.map pass_conn Test_error_cause.test_cases @
List.map pass_conn Test_param.test_cases @
List.map pass_conn Test_failure.test_cases @
List.map pass_pool Test_sql.pool_test_cases @
List.map pass_connect Test_connect.test_cases
in
(name, test_cases)
let post_connect conn =
List_result_fiber.iter_s (fun f -> f conn) [
Test_sql.post_connect;
]
let env =
let (&) f g di var = try f di var with Not_found -> g di var in
Test_sql.env & Test_error_cause.env
let mk_tests {uris; connect_config} =
let pool_config = Caqti_pool_config.create ~max_size:1 () in
let create_target uri =
let connect () = Caqti_blocking.connect ~config:connect_config ~env uri in
(match Caqti_blocking.connect_pool uri
~pool_config ~post_connect ~config:connect_config ~env with
| Ok pool -> (test_name_of_uri uri, connect, pool)
| Error err -> raise (Caqti_error.Exn err))
in
let targets = List.map create_target uris in
List.map mk_test targets
let () =
Alcotest_cli.run_with_args_dependency "test_sql_blocking"
(Testlib.common_args ()) mk_tests

81
unikernel/duniverse/ocaml-caqti/testsuite/main_eio_unix.ml Normal file
View file

@ -0,0 +1,81 @@
(* Copyright (C) 2022--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking Exception.
*
* This library is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Eio.Std
open Testlib
open Testlib_eio_unix
module Test_error_cause = Test_error_cause.Make (Testlib_eio_unix)
module Test_param = Test_param.Make (Testlib_eio_unix)
module Test_sql = Test_sql.Make (Testlib_eio_unix)
module Test_failure = Test_failure.Make (Testlib_eio_unix)
module Test_connect = Test_connect.Make (Testlib_eio_unix)
let (%) f g x = f (g x)
let mk_test (name, connect, pool) =
let pass_connect (name, speed, f) = (name, speed, (fun () -> f connect)) in
let pass_conn (name, speed, f) =
let f' () =
Caqti_eio.Pool.use (fun c -> Ok (f c)) pool |> function
| Ok () -> ()
| Error err -> Alcotest.failf "%a" Caqti_error.pp err
in
(name, speed, f')
in
let pass_pool (name, speed, f) = (name, speed, (fun () -> f pool)) in
let test_cases =
List.map pass_conn Test_sql.connection_test_cases @
List.map pass_conn Test_error_cause.test_cases @
List.map pass_conn Test_param.test_cases @
List.map pass_conn Test_failure.test_cases @
List.map pass_pool Test_sql.pool_test_cases @
List.map pass_connect Test_connect.test_cases
in
(name, test_cases)
let post_connect conn =
List_result_fiber.iter_s (fun f -> f conn) [
Test_sql.post_connect;
]
let env =
let (&) f g di var = try f di var with Not_found -> g di var in
Test_sql.env & Test_error_cause.env
let mk_tests (stdenv, sw) {uris; connect_config} =
let pool_config = Caqti_pool_config.create ~max_size:16 () in
let create_target uri =
let connect () =
Eio.Switch.check sw;
Caqti_eio_unix.connect ~sw ~stdenv ~config:connect_config ~env uri
in
(match Caqti_eio_unix.connect_pool ~sw ~stdenv uri
~pool_config ~post_connect ~config:connect_config ~env with
| Ok pool -> (test_name_of_uri uri, connect, pool)
| Error err -> raise (Caqti_error.Exn err))
in
List.map (mk_test % create_target) uris
let () =
Mirage_crypto_rng_unix.use_default ();
Eio_main.run @@ fun stdenv ->
Switch.run @@ fun sw ->
Alcotest_cli.run_with_args_dependency "test_sql_eio"
(Testlib.common_args ())
(mk_tests ((stdenv :> Caqti_eio.stdenv), sw))

75
unikernel/duniverse/ocaml-caqti/testsuite/main_lwt_unix.ml Normal file
View file

@ -0,0 +1,75 @@
(* Copyright (C) 2018--2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking Exception.
*
* This library is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Lwt.Infix
open Testlib
open Testlib_lwt_unix
module Test_error_cause = Test_error_cause.Make (Testlib_lwt_unix)
module Test_parallel = Test_parallel.Make (Testlib_lwt_unix)
module Test_param = Test_param.Make (Testlib_lwt_unix)
module Test_sql = Test_sql.Make (Testlib_lwt_unix)
module Test_failure = Test_failure.Make (Testlib_lwt_unix)
module Test_connect = Test_connect.Make (Testlib_lwt_unix)
let mk_test (name, connect, pool) =
let pass_connect (name, speed, f) = (name, speed, (fun () -> f connect)) in
let pass_conn (name, speed, f) =
let f' () =
Caqti_lwt_unix.Pool.use (fun c -> Lwt_result.ok (f c)) pool >|= function
| Ok () -> ()
| Error err -> Alcotest.failf "%a" Caqti_error.pp err
in
(name, speed, f')
in
let pass_pool (name, speed, f) = (name, speed, (fun () -> f pool)) in
let test_cases =
List.map pass_conn Test_sql.connection_test_cases @
List.map pass_conn Test_error_cause.test_cases @
List.map pass_pool Test_parallel.test_cases @
List.map pass_conn Test_param.test_cases @
List.map pass_conn Test_failure.test_cases @
List.map pass_pool Test_sql.pool_test_cases @
List.map pass_connect Test_connect.test_cases
in
(name, test_cases)
let post_connect conn =
List_result_fiber.iter_s (fun f -> f conn) [
Test_sql.post_connect;
]
let env =
let (&) f g di var = try f di var with Not_found -> g di var in
Test_sql.env & Test_error_cause.env
let mk_tests {uris; connect_config} =
let pool_config = Caqti_pool_config.create ~max_size:16 () in
let create_target uri =
let connect () = Caqti_lwt_unix.connect ~config:connect_config ~env uri in
(match Caqti_lwt_unix.connect_pool uri
~pool_config ~post_connect ~config:connect_config ~env with
| Ok pool -> (test_name_of_uri uri, connect, pool)
| Error err -> raise (Caqti_error.Exn err))
in
let targets = List.map create_target uris in
List.map mk_test targets
let () = Lwt_main.run begin
Alcotest_cli.run_with_args_dependency "test_sql_lwt_unix"
(Testlib.common_args ()) mk_tests
end

60
unikernel/duniverse/ocaml-caqti/testsuite/main_miou_unix.ml Normal file
View file

@ -0,0 +1,60 @@
open Testlib
open Testlib_miou_unix
module Test_error_cause = Test_error_cause.Make (Testlib_miou_unix)
module Test_parallel = Test_parallel.Make (Testlib_miou_unix)
module Test_param = Test_param.Make (Testlib_miou_unix)
module Test_sql = Test_sql.Make (Testlib_miou_unix)
module Test_failure = Test_failure.Make (Testlib_miou_unix)
module Test_connect = Test_connect.Make (Testlib_miou_unix)
let mk_test (name, connect, pool) =
let pass_connect (name, speed, f) = (name, speed, (fun () -> f connect)) in
let pass_conn (name, speed, f) =
let f' () =
match Caqti_miou_unix.Pool.use (fun c -> Ok (f c)) pool with
| Ok () -> ()
| Error err -> Alcotest.failf "%a" Caqti_error.pp err
in
(name, speed, f')
in
let pass_pool (name, speed, f) = (name, speed, (fun () -> f pool)) in
let test_cases =
List.map pass_conn Test_sql.connection_test_cases @
List.map pass_conn Test_error_cause.test_cases @
List.map pass_pool Test_parallel.test_cases @
List.map pass_conn Test_param.test_cases @
List.map pass_conn Test_failure.test_cases @
List.map pass_pool Test_sql.pool_test_cases @
List.map pass_connect Test_connect.test_cases
in
(name, test_cases)
let post_connect conn =
List_result_fiber.iter_s (fun f -> f conn) [
Test_sql.post_connect;
]
let env =
let (&) f g di var = try f di var with Not_found -> g di var in
Test_sql.env & Test_error_cause.env
let mk_tests sw {uris; connect_config} =
let pool_config = Caqti_pool_config.create ~max_size:16 () in
let create_target uri =
let connect () = Caqti_miou_unix.connect ~sw ~config:connect_config ~env uri in
(match Caqti_miou_unix.connect_pool ~sw uri
~pool_config ~post_connect ~config:connect_config ~env with
| Ok pool -> (test_name_of_uri uri, connect, pool)
| Error err -> raise (Caqti_error.Exn err))
in
let targets = List.map create_target uris in
List.map mk_test targets
let () = Miou_unix.run @@ fun () ->
let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in
let finally () = Mirage_crypto_rng_miou_unix.kill rng in
Fun.protect ~finally @@ fun () ->
Caqti_miou.Switch.run @@ fun sw ->
Alcotest_cli.run_with_args_dependency "test_sql_miou_unix"
(Testlib.common_args ()) (mk_tests sw)

34
unikernel/duniverse/ocaml-caqti/testsuite/test_connect.ml Normal file
View file

@ -0,0 +1,34 @@
(* Copyright (C) 2024 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking Exception.
*
* This library is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
module Make (Ground : Testlib.Sig.Ground) = struct
open Ground
open Ground.Fiber.Infix
let test_connect connect =
let rec loop n =
if n = 0 then Fiber.return () else
connect () >>= or_fail >>= fun (module C : CONNECTION) ->
C.disconnect () >>= fun () ->
loop (n - 1)
in
loop 2049 (* assumes ulimit -n 2048 or smaller *)
let test_cases = [
"connect", `Slow, test_connect;
]
end

108
unikernel/duniverse/ocaml-caqti/testsuite/test_error_cause.ml Normal file
View file

@ -0,0 +1,108 @@
(* Copyright (C) 2022--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking Exception.
*
* This library is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
module Make (Ground : Testlib.Sig.Ground) = struct
open Ground
open Ground.Fiber.Infix
let env driver_info = function
| "engine_innodb" ->
(match Caqti_driver_info.dialect_tag driver_info with
| `Mysql -> Caqti_query.L" ENGINE = InnoDB"
| _ -> Caqti_query.S[])
| _ -> raise Not_found
let create_reqs =
List.map Caqti_template.Create.(direct T.(unit -->. unit)) [
"DROP TABLE IF EXISTS caqti_test_publication";
"DROP TABLE IF EXISTS caqti_test_genre";
"CREATE TABLE caqti_test_genre \
(id INTEGER PRIMARY KEY, \
genre VARCHAR(40) UNIQUE NOT NULL CHECK (genre != ''))\
$(engine_innodb)";
"CREATE TABLE caqti_test_publication \
(title VARCHAR(160) UNIQUE NOT NULL, \
author TEXT NOT NULL, \
genre_id INTEGER NOT NULL, \
FOREIGN KEY (genre_id) REFERENCES caqti_test_genre (id))\
$(engine_innodb)";
"INSERT INTO caqti_test_genre VALUES (1, 'fiction'), (2, 'nonfiction')";
"INSERT INTO caqti_test_publication VALUES ('Fiction', 'N.N.', 2)"
]
let not_null_violation_req =
Caqti_template.Create.(static T.(unit -->. unit))
"INSERT INTO caqti_test_genre VALUES (NULL, NULL)"
let unique_violation_req =
Caqti_template.Create.(static T.(unit -->. unit))
"INSERT INTO caqti_test_genre VALUES (3, 'fiction')"
let foreign_key_violation_req =
Caqti_template.Create.(static T.(unit -->. unit))
"INSERT INTO caqti_test_publication \
VALUES ('Unclassified', 'N.N.', 0)"
let check_violation_req =
Caqti_template.Create.(static T.(unit -->. unit))
"INSERT INTO caqti_test_genre VALUES (3, '')"
(* Missing:
* - Restrict violation is only mapped for PostgreSQL, but even there it is
* likely unused (deleting a restricted FK casuse FK violation.
* - Exclusion violation is also only mapped for PostgreSQL. *)
let check_restrict_violation_req =
Caqti_template.Create.(static T.(unit -->. unit))
"DELETE FROM caqti_test_genre WHERE id = 2"
(* TODO: exclusion *)
let harness (module Db : CONNECTION) =
List_result_fiber.iter_s (fun req -> Db.exec req ()) create_reqs
>>= or_fail
let make_test_case (expected_cause, req) =
let test (module Db : CONNECTION) =
Db.exec req () >|= function
| Ok () -> Alcotest.fail "Error not reported."
| Error (`Request_failed _ | `Response_failed _ as err) ->
let actual_cause = Caqti_error.cause err in
(* Skip for sqlite3 < 5.2.0 due to missing extended error code. *)
let open Caqti_template.Version.Infix in
(match Db.dialect with
| Caqti_template.Dialect.Sqlite {server_version; _} ->
if server_version <=* "5.2" then Alcotest.skip ()
| _ -> ());
Alcotest.(check string) "cause"
(Caqti_error.show_cause expected_cause)
(Caqti_error.show_cause actual_cause)
| Error err ->
Alcotest.failf "Unexpected error: %a" Caqti_error.pp err
in
(Caqti_error.show_cause expected_cause, `Quick, test)
let test_cases =
("harness", `Quick, harness) ::
List.map make_test_case [
`Not_null_violation, not_null_violation_req;
`Unique_violation, unique_violation_req;
`Foreign_key_violation, foreign_key_violation_req;
`Check_violation, check_violation_req;
]
end

76
unikernel/duniverse/ocaml-caqti/testsuite/test_failure.ml Normal file
View file

@ -0,0 +1,76 @@
(* Copyright (C) 2021--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking Exception.
*
* This library is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
module Q = struct
open Caqti_template.Create
let select_two = static T.(unit -->! int) "SELECT 2"
let select_twice = static T.(int -->! int) "SELECT 2 * ?"
let sleep =
static_gen T.(unit -->! option int) @@ function
| D.Pgsql _ -> Q.parse "SELECT pg_sleep(2)"
| _ -> Q.parse "SELECT sleep(2)"
end
module Make (Ground : Testlib.Sig.Ground) = struct
open Ground
open Ground.Fiber.Infix
let test_raise_in_call fail' (module Db : CONNECTION) =
let test i =
Fiber.catch
(fun () ->
Db.call ~f:(fun _ -> fail' Not_found) Q.select_two () >>= function
| Ok _ -> Alcotest.fail "Exception from call-back lost."
| Error err -> Alcotest.failf "%a" Caqti_error.pp err)
(function
| Not_found -> Fiber.return ()
| exn -> failwith ("unexpected exception: " ^ Printexc.to_string exn))
>>= fun () ->
Db.find Q.select_twice i
>|= (function Ok j -> assert (j = 2 * i) | _ -> assert false)
in
test 3 >>= fun () ->
test 5 >>= fun () ->
test 15
let test_statement_timeout (module Db : CONNECTION) =
if Caqti_driver_info.dialect_tag Db.driver_info = `Sqlite then
Fiber.return () (* Does not support statement timeout. *)
else
let check_timed_out = function
| Error (`Request_failed _) -> ()
| Error err -> failwith ("unexpected error: " ^ Caqti_error.show err)
| Ok _ -> assert false
in
let test i =
Db.find Q.sleep () >|= check_timed_out >>= fun () ->
Db.find Q.select_twice i
>|= (function Ok j -> assert (j = 2 * i) | _ -> assert false)
in
Db.set_statement_timeout (Some 0.1) >>= or_fail >>= fun () ->
test 3 >>= fun () ->
test 5 >>= fun () ->
Db.set_statement_timeout None >>= or_fail
let test_cases = [
"raise in call", `Quick, test_raise_in_call raise;
"fail in call", `Quick, test_raise_in_call Fiber.fail;
"statement timeout", `Quick, test_statement_timeout;
]
end

101
unikernel/duniverse/ocaml-caqti/testsuite/test_parallel.ml Normal file
View file

@ -0,0 +1,101 @@
(* Copyright (C) 2015--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking Exception.
*
* This library is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
module Q = struct
open Caqti_template.Create
let create = static T.(unit -->. unit)
"CREATE TABLE test_parallel (x int NOT NULL, y int NOT NULL)"
let drop = static T.(unit -->. unit)
"DROP TABLE IF EXISTS test_parallel"
let insert = static T.(t2 int int -->. unit)
"INSERT INTO test_parallel VALUES (?, ?)"
let delete = static T.(int -->. unit)
"DELETE FROM test_parallel WHERE x = ?"
let select_1 = static T.(int -->* int)
"SELECT y FROM test_parallel WHERE x < ?"
let select_2 = static T.(int -->! option int)
"SELECT sum(a.y*b.y) \
FROM test_parallel a JOIN test_parallel b ON a.x < b.x \
WHERE b.x < ?"
end
let random_int () = Random.int (1 + Random.int 16)
module Make (Ground : Testlib.Sig.Ground) = struct
open Ground
open Ground.Fiber.Infix
let do_query pool =
pool |> Pool.use @@ fun (module C : CONNECTION) ->
(match Random.int 4 with
| 0 ->
C.exec Q.insert (random_int (), random_int ()) >>=? fun () ->
Fiber.return (Ok 0)
| 1 ->
C.exec Q.delete (random_int ()) >>=? fun () ->
Fiber.return (Ok 0)
| 2 ->
C.fold Q.select_1 (fun x acc -> x + acc) (random_int ()) 0
| 3 ->
C.find Q.select_2 (random_int ())
>|=? (function None -> 0 | Some i -> i)
| _ ->
assert false)
let rec list_diff f = function
| x0 :: x1 :: xs -> f x1 x0 :: list_diff f (x1 :: xs)
| [_] -> []
| [] -> invalid_arg "list_diff"
let reduce f xs acc =
let rec loop = function
| [] -> fun acc -> Fiber.return (Ok acc)
| mx :: mxs -> fun acc -> mx >>=? fun x -> loop mxs (f x acc)
in
loop xs acc
let rec test_parallel' pool n =
if n = 0 then Fiber.return (Ok 0) else
if n = 1 then do_query pool else
let thread_count = Random.int n * (Random.int n + 1) / n + 1 in
let ns = Array.init thread_count (fun _ -> Random.int n)
|> Array.to_list |> (fun xs -> n :: xs)
|> List.sort compare
|> list_diff (-)
|> List.filter ((<>) 0)
in
let xs = List.map (test_parallel' pool) ns in
reduce (+) xs 0
let test_parallel pool =
begin
Pool.use
(fun (module C : CONNECTION) ->
C.exec Q.drop () >>=? fun () ->
C.exec Q.create ())
pool >>=? fun () ->
test_parallel' pool 1000
end >|= function
| Ok _ -> ()
| Error err -> Alcotest.failf "%a" Caqti_error.pp err
let test_cases = [
"parallel", `Slow, test_parallel;
]
end

71
unikernel/duniverse/ocaml-caqti/testsuite/test_param.ml Normal file
View file

@ -0,0 +1,71 @@
(* Copyright (C) 2017--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking Exception.
*
* This library is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
module Q = struct
open Caqti_template.Create
let nonlin1 =
static_gen T.(t3 int int int -->! int) @@ fun _ ->
Q.concat [
Q.lit "SELECT 2 * "; Q.param 2; Q.lit " + "; Q.param 2;
Q.lit " - 3 * "; Q.param 0; Q.lit " + 5 * "; Q.param 1;
]
let nonlin2 =
static T.(t3 int int int -->! int)
"SELECT 2 * $3 + $3 - 3 * $1 + 5 * $2"
let env1 =
let env = let open Caqti_template.Create in function
| "." -> Q.lit "100"
| "fourty" -> Q.lit "40"
| _ -> raise Not_found
in
let q = "SELECT $. - $(fourty)"
|> Caqti_template.Query.parse
|> Caqti_template.Query.expand env
in
static_gen T.(Caqti_type.unit -->! Caqti_type.int) (fun _ -> q)
end
module Make (Ground : Testlib.Sig.Ground) = struct
open Ground
open Ground.Fiber.Infix
let nonlin (p0, p1, p2) = 2 * p2 + p2 - 3 * p0 + 5 * p1
let test_nonlin (module Db : CONNECTION) =
let rec loop n =
if n = 0 then Fiber.return () else
let p = (Random.int 1000, Random.int 1000, Random.int 1000) in
(Db.find Q.nonlin1 p >>= or_fail >|= fun y -> assert (y = nonlin p))
>>= fun () ->
(Db.find Q.nonlin2 p >>= or_fail >|= fun y -> assert (y = nonlin p))
>>= fun () ->
loop (n - 1)
in
loop 1000
let test_env (module Db : CONNECTION) =
Db.find Q.env1 () >>= or_fail >|= fun y -> assert (y = 60)
let test_cases = [
"nonlinear", `Quick, test_nonlin;
"environment", `Quick, test_env;
]
end

725
unikernel/duniverse/ocaml-caqti/testsuite/test_sql.ml Normal file
View file

@ -0,0 +1,725 @@
(* Copyright (C) 2014--2025 Petter A. Urkedal <paurkedal@gmail.com>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, either version 3 of the License, or (at your
* option) any later version, with the LGPL-3.0 Linking Exception.
*
* This library is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* and the LGPL-3.0 Linking Exception along with this library. If not, see
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
*)
open Printf
type abc = [`Aye | `Bee | `Cee]
let string_of_abc = function
| `Aye -> "aye"
| `Bee -> "bee"
| `Cee -> "cee"
let abc_of_string = function
| "aye" -> Ok `Aye
| "bee" -> Ok `Bee
| "cee" -> Ok `Cee
| _ -> Error "abc_of_string"
module Q = struct
open Caqti_template.Create
let (%) f g x = f (g x)
let select_null_etc =
static T.(t2 (option int) (option int) -->! t2 bool (option int))
"SELECT ? IS NULL, ?"
let select_and = static T.(t2 bool bool -->! bool)
"SELECT ? AND ?"
let select_plus_int = static T.(t2 int int -->! int)
"SELECT ? + ?"
let select_plus_int64 = static T.(t2 int64 int64 -->! int64)
"SELECT ? + ?"
let select_plus_float = static T.(t2 float float -->! float)
"SELECT ? + ?"
let select_cat = static_gen T.(t2 string string -->! string) @@ function
| D.Mysql _ -> Q.parse "SELECT concat(?, ?)"
| _ -> Q.parse "SELECT ? || ?"
let select_octets_identity = static_gen T.(octets -->! octets) @@ function
| D.Mysql _ -> Q.parse "SELECT CAST(? AS binary)"
| D.Pgsql _ -> Q.parse "SELECT ?"
| D.Sqlite _ -> Q.parse "SELECT CAST(? AS blob)"
| _ -> failwith "Unimplemented."
let select_compound_option =
static
T.(t2 (option int) (option int) -->!
t3 int (option (t3 (option int) (option int) (option int))) int)
"SELECT -1, $1 + 1, $2 + 1, $1 + 1, -2"
let abc =
Caqti_template.Row_type.enum
~encode:string_of_abc ~decode:abc_of_string "abc"
let create_type_abc = static T.(unit -->. unit)
"CREATE TYPE abc AS ENUM ('aye', 'bee', 'cee')"
let drop_type_abc = static T.(unit -->. unit)
"DROP TYPE IF EXISTS abc"
let create_table_test_abc =
static_gen T.(unit -->. unit) @@ Q.parse % function
| D.Pgsql _ ->
"CREATE TEMPORARY TABLE test_abc \
(e abc PRIMARY KEY, s char(3) NOT NULL)"
| D.Mysql _ ->
"CREATE TEMPORARY TABLE test_abc \
(e ENUM('aye', 'bee', 'cee') PRIMARY KEY, s char(3) NOT NULL)"
| D.Sqlite _ ->
"CREATE TEMPORARY TABLE test_abc \
(e text PRIMARY KEY, s char(3) NOT NULL)"
| _ -> failwith "Unimplemented."
let drop_table_test_abc = static T.(unit -->. unit)
"DROP TABLE test_abc"
let insert_into_test_abc = static T.(t2 abc string -->. unit)
"INSERT INTO test_abc VALUES (?, ?)"
let select_from_test_abc = static T.(unit -->* t2 abc string)
"SELECT * FROM test_abc"
let select_expanded =
static_gen T.(unit -->! t2 int string) @@ Q.parse % function
| D.Mysql _ -> "SELECT $(x1), CAST($(x2) AS char)"
| _ -> "SELECT $(x1), $(x2)"
let create_post_connect = static T.(unit -->. unit)
"CREATE TEMPORARY TABLE test_post_connect \
(id serial PRIMARY KEY, word text NOT NULL)"
let insert_into_post_connect = static T.(string -->. unit)
"INSERT INTO test_post_connect (word) VALUES (?)"
let create_tmp = static_gen T.(unit -->. unit) @@ Q.parse % function
| D.Pgsql _ ->
"CREATE TEMPORARY TABLE test_sql \
(id SERIAL NOT NULL, \
i INTEGER NOT NULL, \
s TEXT NOT NULL, \
o BYTEA NOT NULL)"
| D.Mysql _ ->
"CREATE TEMPORARY TABLE test_sql \
(id SERIAL NOT NULL, \
i INTEGER NOT NULL, \
s TEXT NOT NULL, \
o BLOB NOT NULL)"
| D.Sqlite _ ->
"CREATE TEMPORARY TABLE test_sql \
(id INTEGER PRIMARY KEY, \
i INTEGER NOT NULL, \
s TEXT NOT NULL, \
o BLOB NOT NULL)"
| _ -> failwith "Unimplemented."
let create_tmp_nullable = static_gen T.(unit -->. unit) @@ Q.parse % function
| D.Pgsql _ ->
"CREATE TEMPORARY TABLE test_sql \
(id SERIAL NOT NULL, i INTEGER NOT NULL, s TEXT, o BYTEA)"
| D.Mysql _ ->
"CREATE TEMPORARY TABLE test_sql \
(id SERIAL NOT NULL, i INTEGER NOT NULL, s TEXT, o BLOB)"
| D.Sqlite _ ->
"CREATE TEMPORARY TABLE test_sql \
(id INTEGER PRIMARY KEY, i INTEGER NOT NULL, s TEXT, o BLOB)"
| _ -> failwith "Unimplemented."
let create_tmp_binary = static_gen T.(unit -->. unit) @@ Q.parse % function
| D.Pgsql _ ->
"CREATE TEMPORARY TABLE test_sql \
(id SERIAL NOT NULL, data BYTEA NOT NULL)"
| D.Mysql _ ->
"CREATE TEMPORARY TABLE test_sql \
(id SERIAL NOT NULL, data BLOB NOT NULL)"
| D.Sqlite _ ->
"CREATE TEMPORARY TABLE test_sql \
(id INTEGER PRIMARY KEY, data BLOB NOT NULL)"
| _ -> failwith "Unimplemented"
let drop_tmp = static T.(unit -->. unit)
"DROP TABLE test_sql"
let insert_into_tmp = static T.(t3 int string octets -->. unit)
"INSERT INTO test_sql (i, s, o) VALUES (?, ?, ?)"
let update_in_tmp_where_i = static T.(t2 octets int -->. unit)
"UPDATE test_sql SET o = ? WHERE i = ?"
let update_in_tmp = static T.(unit -->. unit)
"UPDATE test_sql SET s = 'ZERO'"
let delete_from_tmp_where_i = static T.(int -->. unit)
"DELETE FROM test_sql WHERE i = ?"
let delete_from_tmp = static T.(unit -->. unit)
"DELETE FROM test_sql"
let select_from_tmp = static T.(unit -->* t3 int string octets)
"SELECT i, s, o FROM test_sql ORDER BY i ASC"
let select_from_tmp_where_i_lt =
static T.(int -->* t3 int string octets)
"SELECT i, s, o FROM test_sql WHERE i < ?"
let select_from_tmp_nullable =
static T.(unit -->* t3 int (option string) (option octets))
"SELECT i, s, o FROM test_sql"
let select_from_tmp_binary = static T.(unit -->* octets)
"SELECT data FROM test_sql"
let select_current_time =
static T.(unit -->! ptime) "SELECT current_timestamp"
let select_given_time =
static_gen T.(ptime -->! ptime) @@ Q.parse % function
| D.Pgsql _ | D.Sqlite _ -> "SELECT ?"
| D.Mysql _ -> "SELECT CAST(? AS datetime)"
| _ -> failwith "Unimplemented."
let compare_to_known_time =
static_gen T.(ptime -->! bool) @@ Q.parse % function
| D.Pgsql _ -> "SELECT ? = '2017-01-29T12:00:00.001002Z'"
| D.Sqlite _ -> "SELECT ? = '2017-01-29 12:00:00.001'"
| D.Mysql _ -> "SELECT CAST(? AS datetime) \
= CAST('2017-01-29T12:00:00.001002' AS datetime)"
| _ -> failwith "Unimplemented."
let select_interval =
static_gen T.(ptime_span -->! ptime_span) @@ Q.parse % function
| D.Pgsql _ | D.Sqlite _ -> "SELECT ?"
| D.Mysql _ -> "SELECT CAST(? AS double)"
| _ -> failwith "Unimplemented"
end
module Make (Ground : Testlib.Sig.Ground) = struct
open Ground
open Ground.Fiber.Infix
let repeat n f =
let rec loop i =
if i = n then Fiber.return () else
f i >>= fun () -> loop (i + 1) in
loop 0
let env _ =
let open Caqti_template.Create in
(function
| "x1" -> Q.lit "734"
| "x2" -> Q.quote "I'm quoted."
| _ -> raise Not_found)
let test_expand (module Db : CONNECTION) =
Db.find Q.select_expanded () >>= or_fail >|= fun (x1, x2) ->
Alcotest.(check int) "expanded int" 734 x1;
Alcotest.(check string) "expanded quote" "I'm quoted." x2
let post_connect (module Db : CONNECTION) =
Db.exec Q.create_post_connect () >|= function
| Ok x -> Ok x
| Error err -> Error (`Post_connect err)
let test_post_connect (module Db : CONNECTION) =
Db.exec Q.insert_into_post_connect "swallow" >>= or_fail
let test_expr (module Db : CONNECTION) =
let maybe_deallocate q =
if Random.int 50 = 0 then
Db.deallocate q >>= or_fail
else
Fiber.return ()
in
(* Non-prepared and prepared with non-linear parameters and quotes. *)
repeat 254 (fun i ->
let i = i mod 127 + 1 in
let prepare_policy : Caqti_template.Request.prepare_policy =
(match Random.int 3 with 0 -> Direct | 1 -> Dynamic | _ -> Static)
in
let s1 = String.make 1 (Char.chr i) in
let s2 = String.make i '\'' in
let req =
let open Caqti_template.Create in
let make_query dialect =
let cast_if_mariadb tn f =
(match dialect with
| D.Mysql _ -> fun x ->
"CAST(" ^++ f x @++ " AS " ^++ Q.lit tn ++^ ")"
| _ -> f)
in
let quote_int = cast_if_mariadb "INTEGER"
(match i mod 4 with
| 0 -> fun x -> Q.int x
| 1 -> fun x -> Q.int16 x
| 2 -> fun x -> Q.int32 (Int32.of_int x)
| 3 -> fun x -> Q.int64 (Int64.of_int x)
| _ -> assert false)
in
let quote_string = cast_if_mariadb "CHAR"
(match i mod 2 with
| 0 -> fun x -> Q.quote x
| 1 -> fun x -> Q.string x
| _ -> assert false)
in
Q.concat [
Q.lit "SELECT ";
Q.param 1; Q.lit " + 10, "; (* last parameter first *)
Q.param 1; Q.lit " + 20, "; (* and duplicated *)
quote_int (i + 30); Q.lit ", "; (* first quote *)
Q.lit (string_of_int i); Q.lit ", ";
quote_string s1; Q.lit ", "; (* second quote *)
Q.lit "'"; Q.lit (string_of_int i); Q.lit "', ";
quote_string s2; Q.lit ", "; (* third quote *)
Q.param 0; Q.lit " + 10"; (* first paramater last *)
]
in
Caqti_template.Request.create prepare_policy
T.(t2 int int -->! t8 int int int64 int string string string int)
make_query
in
Db.find req (i + 1, i + 2) >>= or_fail
>>= fun (i12, i22, i30, i', s1', si', s2', i11) ->
(if prepare_policy = Direct then Fiber.return () else
Db.deallocate req >>= or_fail) >|= fun () ->
Alcotest.(check int) "first $2 occurrence" (i + 12) i12;
Alcotest.(check int) "second $2 occurrence" (i + 22) i22;
Alcotest.(check int64) "first quote" (Int64.of_int (i + 30)) i30;
Alcotest.(check int) "int literal" (i + 11) i11;
Alcotest.(check int) "int literal" i i';
Alcotest.(check string) "second quote" s1 s1';
Alcotest.(check string) "third quote" s2 s2';
Alcotest.(check string) "only $1 occurrence" (string_of_int i) si'
) >>= fun () ->
(* Prepared: null *)
repeat 3 (fun _ ->
maybe_deallocate Q.select_null_etc >>= fun () ->
Db.find Q.select_null_etc (None, None) >>= or_fail >>= fun (c1, c2) ->
assert (c1 && c2 = None);
Fiber.return ()
) >>= fun () ->
(* Prepared: bool *)
let ck_and a b =
maybe_deallocate Q.select_and >>= fun () ->
Db.find Q.select_and (a, b) >>= or_fail >|= fun c ->
assert (c = (a && b)) in
ck_and false false >>= fun () -> ck_and false true >>= fun () ->
ck_and true false >>= fun () -> ck_and true true >>= fun () ->
(* Prepared: int *)
let ck_plus_int i j =
maybe_deallocate Q.select_plus_int >>= fun () ->
Db.find Q.select_plus_int (i, j) >>= or_fail >>= fun k ->
assert (k = (i + j)); Fiber.return () in
repeat 200 (fun _ ->
let i, j = Random.int (1 lsl 29), Random.int (1 lsl 29) in
ck_plus_int i j
) >>= fun () ->
(* Prepared: int64 *)
let ck_plus_int64 i j =
maybe_deallocate Q.select_plus_int64 >>= fun () ->
Db.find Q.select_plus_int64 (i, j) >>= or_fail >|= fun k ->
assert (k = Int64.add i j) in
repeat 200 (fun _ ->
let i = Random.int64 Int64.(shift_left one 29) in
let j = Random.int64 Int64.(shift_left one 29) in
ck_plus_int64 i j
) >>= fun () ->
(* Prepared: float *)
let ck_plus_float x y =
maybe_deallocate Q.select_plus_float >>= fun () ->
Db.find Q.select_plus_float (x, y) >>= or_fail >>= fun z ->
assert (abs_float (z -. (x +. y)) < 1e-6 *. (x +. y));
Fiber.return () in
repeat 200 (fun _ ->
let i, j = Random.float 1e8, Random.float 1e8 in
ck_plus_float i j
) >>= fun () ->
(* Prepared: string *)
let ck_string x y =
maybe_deallocate Q.select_cat >>= fun () ->
Db.find Q.select_cat (x, y) >>= or_fail >>= fun s ->
assert (s = x ^ y); Fiber.return () in
repeat 200 (fun _ ->
let x = sprintf "%x" (Random.int (1 lsl 29)) in
let y = sprintf "%x" (Random.int (1 lsl 29)) in
ck_string x y
) >>= fun () ->
(* Prepared: octets *)
let ck_octets x =
maybe_deallocate Q.select_cat >>= fun () ->
Db.find Q.select_octets_identity x >>= or_fail >>= fun s ->
assert (s = x); Fiber.return () in
repeat 256 (fun i ->
let x = sprintf "%c" (Char.chr i) in
ck_octets x
) >>= fun () ->
(* Prepared: time *)
begin
let t0 = Ptime_clock.now () in
Db.find Q.select_current_time () >>= or_fail >>= fun t ->
let t1 = Ptime_clock.now () in
assert (Ptime.to_float_s t0 -. 1.1 <= Ptime.to_float_s t &&
Ptime.to_float_s t <= Ptime.to_float_s t1 +. 1.1);
Db.find Q.select_given_time t >>= or_fail >>= fun t' ->
assert (Ptime.Span.to_float_s (Ptime.Span.abs (Ptime.diff t t')) < 1.1);
Db.find Q.compare_to_known_time (Ptime.v (17195, 43200_001_002_000_000L))
>>= or_fail >>= fun r ->
assert r;
let rec test_times = function
| [] -> Fiber.return ()
| tf :: tfs ->
let t =
(match Ptime.Span.of_float_s tf with
| Some t -> t
| None -> assert false) in
Db.find Q.select_interval t >>= or_fail >>= fun t' ->
assert Ptime.Span.(equal (round ~frac_s:6 t) (round ~frac_s:6 t'));
test_times tfs
in
test_times [0.0; -1.2e-5; 1.23e-3; -1.001; 1.23e2; -1.23e5]
end >>= fun () ->
(* Prepared: compound option *)
let check x y z =
Db.find Q.select_compound_option (x, y) >>= or_fail
>|= fun (a, b, c) ->
assert (a = -1 && b = z && c = -2);
in
check None None None >>= fun () ->
check None (Some 3) (Some (None, Some 4, None)) >>= fun () ->
check (Some 7) None (Some (Some 8, None, Some 8)) >>= fun () ->
check (Some 7) (Some 3) (Some (Some 8, Some 4, Some 8))
let test_enum (module Db : CONNECTION) =
let with_type_abc f =
let module D = Caqti_template.Dialect in
(match Db.dialect with
| D.Sqlite _ | D.Mysql _ -> f ()
| _ ->
Db.exec Q.drop_type_abc () >>=? fun () ->
Db.exec Q.create_type_abc () >>=? fun () ->
f () >>=? fun () ->
Db.exec Q.drop_type_abc ())
in
with_type_abc begin fun () ->
Db.exec Q.create_table_test_abc () >>=? fun () ->
Db.exec Q.insert_into_test_abc (`Bee, "bee") >>=? fun () ->
Db.collect_list Q.select_from_test_abc () >>=? fun rows ->
assert (rows = [`Bee, "bee"]);
Db.exec Q.drop_table_test_abc ()
end >>= or_fail
let test_table (module Db : CONNECTION) =
(* Create, insert, select *)
Db.exec Q.create_tmp () >>= or_fail >>= fun () ->
begin
if Caqti_driver_info.can_transact Db.driver_info then
Db.start () >>= or_fail >>= fun () ->
Db.exec Q.insert_into_tmp (1, "one", "one")
>>= or_fail >>= fun () ->
Db.rollback () >>= or_fail
else
Fiber.return ()
end >>= fun () ->
Db.start () >>= or_fail >>= fun () ->
Db.exec Q.insert_into_tmp (2, "two", "two\x00")
>>= or_fail >>= fun () ->
Db.exec Q.insert_into_tmp (3, "three", "three'\"")
>>= or_fail >>= fun () ->
Db.exec Q.insert_into_tmp (5, "five", "five\x05")
>>= or_fail >>= fun () ->
Db.commit () >>= or_fail >>= fun () ->
Db.fold Q.select_from_tmp
(fun (i, s, o) (i_acc, s_acc, o_acc) ->
i_acc + i, s_acc ^ "+" ^ s, o_acc ^ "+" ^ o)
()
(0, "zero", "zero")
>>= or_fail >>= fun (i_acc, s_acc, o_acc) ->
assert (i_acc = 10);
assert (s_acc = "zero+two+three+five");
assert (o_acc = "zero+two\x00+three'\"+five\x05");
Db.exec Q.drop_tmp () >>= or_fail
let test_affected_count (module Db : CONNECTION) =
let select_all exp_i exp_s exp_o =
Db.fold Q.select_from_tmp
(fun (i, s, o) (i_acc, s_acc, o_acc) ->
i_acc + i, s_acc ^ "+" ^ s, o_acc ^ "+" ^ o)
()
(0, "zero", "zero")
>>= or_fail >>= fun (i_acc, s_acc, o_acc) ->
assert (i_acc = exp_i);
assert (s_acc = exp_s);
assert (o_acc = exp_o);
Fiber.return ()
in
let check_affected n = function
| Ok nrows -> assert (nrows = n); Fiber.return ()
| Error `Unsupported -> Fiber.return ()
| Error #Caqti_error.t as err -> or_fail err
in
(* prepare db *)
Db.exec Q.create_tmp () >>= or_fail >>= fun () ->
Db.start () >>= or_fail >>= fun () ->
Db.exec_with_affected_count Q.insert_into_tmp (2, "two", "X")
>>= check_affected 1 >>= fun () ->
Db.exec Q.insert_into_tmp (3, "three", "Y")
>>= or_fail >>= fun () ->
Db.exec Q.insert_into_tmp (5, "five", "Z")
>>= or_fail >>= fun () ->
select_all 10 "zero+two+three+five" "zero+X+Y+Z" >>= fun () ->
(* update where i = 1 -> 0 affected rows *)
Db.exec_with_affected_count Q.update_in_tmp_where_i ("null", 0)
>>= check_affected 0 >>= fun () ->
select_all 10 "zero+two+three+five" "zero+X+Y+Z" >>= fun () ->
(* update where i = 3 -> 1 affected row*)
Db.exec_with_affected_count Q.update_in_tmp_where_i ("drei", 3)
>>= check_affected 1 >>= fun () ->
select_all 10 "zero+two+three+five" "zero+X+drei+Z" >>= fun () ->
(* update w/o id -> 3 affected rows *)
Db.exec_with_affected_count Q.update_in_tmp ()
>>= check_affected 3 >>= fun () ->
select_all 10 "zero+ZERO+ZERO+ZERO" "zero+X+drei+Z" >>= fun () ->
(* delete where i = 1 -> no affected rows *)
Db.exec_with_affected_count Q.delete_from_tmp_where_i 1
>>= check_affected 0 >>= fun () ->
select_all 10 "zero+ZERO+ZERO+ZERO" "zero+X+drei+Z" >>= fun () ->
(* delete where i = 3 -> one affected row *)
Db.exec_with_affected_count Q.delete_from_tmp_where_i 3
>>= check_affected 1 >>= fun () ->
select_all 7 "zero+ZERO+ZERO" "zero+X+Z" >>= fun () ->
(* delete where i = 3 -> no affected rows *)
Db.exec_with_affected_count Q.delete_from_tmp_where_i 3
>>= check_affected 0 >>= fun () ->
select_all 7 "zero+ZERO+ZERO" "zero+X+Z" >>= fun () ->
(* delete w/o condition -> 2 affected rows *)
Db.exec_with_affected_count Q.delete_from_tmp ()
>>= check_affected 2 >>= fun () ->
select_all 0 "zero" "zero" >>= fun () ->
Db.commit () >>= or_fail >>= fun () ->
Db.exec Q.drop_tmp () >>= or_fail
let test_tuples =
let module Q = struct
open Caqti_template.Create
let sel2 =
static T.(t2 int int -->! t2 int int)
"SELECT -$2, -$1"
let sel3 =
static T.(t3 int int int -->! t3 int int int)
"SELECT -$3, -$2, -$1"
let sel4 =
static T.(t4 int int int int -->! t4 int int int int)
"SELECT -$4, -$3, -$2, -$1"
let sel5 =
static T.(t5 int int int int int -->! t5 int int int int int)
"SELECT -$5, -$4, -$3, -$2, -$1"
let sel6 =
static T.(t6 int int int int int int -->! t6 int int int int int int)
"SELECT -$6, -$5, -$4, -$3, -$2, -$1"
let sel7 =
static
T.(t7 int int int int int int int -->! t7 int int int int int int int)
"SELECT -$7, -$6, -$5, -$4, -$3, -$2, -$1"
let sel8 =
static
T.(t8 int int int int int int int int -->!
t8 int int int int int int int int)
"SELECT -$8, -$7, -$6, -$5, -$4, -$3, -$2, -$1"
end in
fun (module Db : CONNECTION) ->
let i1, i2, i3, i4, i5, i6, i7, i8 = 2, 3, 5, 7, 11, 13, 17, 19 in
let check q x y =
Db.find q x >>= or_fail >|= fun y' -> assert (y = y')
in
check Q.sel2 (i1, i2) (-i2, -i1) >>= fun () ->
check Q.sel3 (i1, i2, i3) (-i3, -i2, -i1) >>= fun () ->
check Q.sel4 (i1, i2, i3, i4) (-i4, -i3, -i2, -i1) >>= fun () ->
check Q.sel5 (i1, i2, i3, i4, i5) (-i5, -i4, -i3, -i2, -i1) >>= fun () ->
check Q.sel6
(i1, i2, i3, i4, i5, i6)
(-i6, -i5, -i4, -i3, -i2, -i1) >>= fun () ->
check Q.sel7
(i1, i2, i3, i4, i5, i6, i7)
(-i7, -i6, -i5, -i4, -i3, -i2, -i1) >>= fun () ->
check Q.sel8
(i1, i2, i3, i4, i5, i6, i7, i8)
(-i8, -i7, -i6, -i5, -i4, -i3, -i2, -i1)
let test_stream (module Db : CONNECTION) =
let assert_stream_is expected =
Db.call
~f:(fun response ->
let open Db.Response in
Stream.to_list @@ to_stream response >>= fun actual ->
assert (actual = expected);
Fiber.return (Ok ()))
Q.select_from_tmp
()
in
Db.exec Q.create_tmp () >>= or_fail >>= fun () ->
assert_stream_is (Ok []) >>= or_fail >>= fun () ->
Db.exec Q.insert_into_tmp (1, "one", "one") >>= or_fail >>= fun () ->
assert_stream_is (Ok [(1, "one", "one")]) >>= or_fail >>= fun () ->
Db.exec Q.insert_into_tmp (2, "two", "two") >>= or_fail >>= fun () ->
assert_stream_is (Ok [(1, "one", "one"); (2, "two", "two")])
>>= or_fail >>= fun () ->
Db.exec Q.drop_tmp () >>= or_fail
let test_stream_both_ways (module Db : CONNECTION) =
let show_string_option = function
| None -> "None"
| Some s -> "Some \"" ^ s ^ "\""
in
let assert_stream_both_ways expected =
let input_stream = Stream.of_list expected in
Db.exec Q.create_tmp_nullable () >>= or_fail >>= fun () ->
Db.populate
~table:"test_sql"
~columns:["i"; "s"; "o"]
Caqti_type.(t3 int (option string) (option octets))
input_stream
>|= Caqti_error.uncongested >>= or_fail >>= fun () ->
Db.collect_list Q.select_from_tmp_nullable ()
>>= or_fail >>= fun actual ->
if actual <> expected then
begin
let repr a = a
|> List.map (fun (i, s, o) ->
let repr_s = show_string_option s in
let repr_o = show_string_option o in
"(" ^ (string_of_int i) ^ "," ^ repr_s ^ "," ^ repr_o ^ ")")
|> String.concat "; "
|> (fun s -> "[" ^ s ^ "]")
in
eprintf "Expected: %s\nActual: %s\n" (repr expected) (repr actual)
end;
assert (actual = expected);
Db.exec Q.drop_tmp ()
in
assert_stream_both_ways
[] >>= or_fail >>= fun () ->
assert_stream_both_ways
[(1, Some "one", Some "one")] >>= or_fail >>= fun () ->
assert_stream_both_ways
[(1, Some "one", Some "one");
(2, Some "two", Some "two")] >>= or_fail >>= fun () ->
assert_stream_both_ways
[(1, Some "bad1\"\"", Some "bad1\"\"");
(2, Some "bad2,\"\n", Some "bad2,\"\n");
(3, None, None);
(4, Some "", Some "");
(5, Some "\\\"", Some "\\\"")] >>= or_fail
let test_stream_binary (module Db : CONNECTION) =
(* Insert and retrieve all pairs of bytes as strings *)
let all_bytes =
Testlib.init_list 256 (fun c -> String.make 1 (Char.chr c))
in
let all_pairs = all_bytes
|> List.map (fun a -> List.map (fun b -> a ^ b) all_bytes)
|> List.flatten
in
let all_pairs_len = List.length all_pairs in
assert (all_pairs_len = 65536);
let input_stream = Stream.of_list all_pairs in
Db.exec Q.create_tmp_binary () >>= or_fail >>= fun () ->
Db.populate
~table:"test_sql"
~columns:["data"]
Caqti_type.octets
input_stream
>|= Caqti_error.uncongested >>= or_fail >>= fun () ->
Db.collect_list Q.select_from_tmp_binary ()
>>= or_fail >>= fun actual ->
if actual <> all_pairs then
begin
let actual_len = List.length actual in
if actual_len <> all_pairs_len then
eprintf
"Expected length: %d\nActual length: %d\n"
all_pairs_len
actual_len
else
List.iteri
(fun i (a, e) ->
if a <> e then
eprintf
"Element in position %d differs: Actual %s, Expected: %s\n"
i a (String.escaped e))
(List.combine actual all_pairs)
end;
assert (actual = all_pairs);
Db.exec Q.drop_tmp () >>= or_fail
let prepared_statement_count =
let req =
let open Caqti_template.Create in
direct_gen T.(unit -->! int) @@ function
| D.Mysql _ ->
Q.lit "SELECT VARIABLE_VALUE FROM information_schema.SESSION_STATUS \
WHERE VARIABLE_NAME = 'Prepared_stmt_count'"
| D.Pgsql _ ->
Q.lit "SELECT count(*) FROM pg_prepared_statements"
| _ ->
Q.lit "SELECT 0"
in
fun (module Db : CONNECTION) -> Db.find req () >>= or_fail
let test_dynamic_release (module Db : CONNECTION) =
let rec loop n =
if n = 0 then Fiber.return () else
let i = Random.int n in
let req =
let open Caqti_template.Create in
Caqti_template.Request.create Dynamic T.(unit -->! int) @@ fun _ ->
"SELECT " ^++ Q.int i
in
Db.find req () >>= or_fail >>= fun i' ->
Alcotest.(check int) (Printf.sprintf "SELECT %d" i) i i';
loop (n - 1)
in
prepared_statement_count (module Db) >>= fun c_pre ->
loop 4_000 >>= fun () ->
Gc.compact ();
loop 4_000 >>= fun () ->
Gc.compact ();
loop 4_000 >>= fun () ->
Gc.compact ();
loop 4_000 >>= fun () ->
Gc.compact ();
loop 4_000 >>= fun () ->
prepared_statement_count (module Db) >|= fun c_post ->
if c_post - c_pre > 4_000 then
Alcotest.failf "Too many prepared statements left, %d - %d" c_post c_pre
let test_drain pool = Pool.drain pool
let connection_test_cases = [
"post_connect", `Quick, test_post_connect;
"expand", `Quick, test_expand;
"expr", `Quick, test_expr;
"enum", `Quick, test_enum;
"table", `Quick, test_table;
"tuples", `Quick, test_tuples;
"affected_count", `Quick, test_affected_count;
"stream", `Quick, test_stream;
"stream_both_ways", `Quick, test_stream_both_ways;
"stream_binary", `Quick, test_stream_binary;
"dynamic_release", `Slow, test_dynamic_release;
]
let pool_test_cases = [
"drain", `Quick, test_drain;
]
end