unikernel/duniverse/ocaml-caqti/caqti/testlib/testlib.ml

@@ -0,0 +1,157 @@
+(* 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 Sig = Sig
+
+let load_uris uris_file =
+  (match open_in uris_file with
+   | exception Sys_error _ ->
+      failwith ("No -u option provided and missing " ^ uris_file)
+   | ic ->
+      let rec loop acc =
+        (match input_line ic with
+         | exception End_of_file -> close_in ic; List.rev acc
+         | ln ->
+            let uri = String.trim ln in
+            if String.length uri = 0 || uri.[0] = '#' then
+              loop acc
+            else
+              loop (Uri.of_string uri :: acc)) in
+      loop [])
+
+type common_args = {
+  uris: Uri.t list;
+  connect_config: Caqti_connect_config.t;
+}
+
+let other_common_args : (common_args -> common_args) Cmdliner.Term.t list ref =
+  ref []
+
+let register_common_arg term = other_common_args := term :: !other_common_args
+
+let common_args () =
+  let open Cmdliner in
+  let uris =
+    let doc = "Database URI(s) to be used for conducting the tests." in
+    Arg.(value @@ opt_all string [] @@ info ~doc ["u"])
+  in
+  let uris_file =
+    let doc = "File from which to load URI(s) if no -u option is passed." in
+    let env = Cmd.Env.info "CAQTI_TEST_URIS_FILE" in
+    Arg.(value @@ opt file "uris.conf" @@ info ~doc ~env ["U"])
+  in
+  let log_level_conv =
+    let pp ppf level =
+      Format.pp_print_string ppf (Logs.level_to_string level)
+    in
+    Arg.conv (Logs.level_of_string, pp)
+  in
+  let log_level =
+    let doc = "Log level." in
+    let env = Cmd.Env.info "CAQTI_TEST_LOG_LEVEL" in
+    Arg.(value @@ opt log_level_conv (Some Logs.Info) @@
+         info ~doc ~env ["log-level"])
+  in
+  let tweaks_version_conv =
+    let parse s =
+      (match String.split_on_char '.' s with
+       | [a; b] ->
+          (try Ok (int_of_string a, int_of_string b) with
+           | Failure _ -> Error (`Msg "Invalid tweaks version."))
+       | _ -> Error (`Msg "Invalid tweaks version."))
+    in
+    let pp ppf (a, b) = Format.fprintf ppf "%d.%d" a b in
+    Arg.conv (parse, pp)
+  in
+  let tweaks_version =
+    let doc =
+      "Enable all tweaks introduced in the given Caqti version, \
+       specified as MAJOR.MINOR"
+    in
+    let env = Cmd.Env.info "CAQTI_COMPAT_VERSION" in
+    Arg.(value @@ opt (some tweaks_version_conv) (Some (1, 8)) @@
+         info ~doc ~env ["tweaks-version"])
+  in
+  let dynamic_prepare_capacity =
+    let doc =
+      "The maximum number of dynamic queries to keep in the prepare cache."
+    in
+    let env = Cmd.Env.info "CAQTI_DYNAMIC_PREPARE_CAPACITY" in
+    Arg.(value @@ opt (some int) None @@
+         info ~doc ~env ["dynamic-prepare-capacity"])
+  in
+  let preprocess
+        tweaks_version dynamic_prepare_capacity log_level uris uris_file =
+    Logs.set_level log_level;
+    let uris =
+      (match uris with
+       | [] -> load_uris uris_file
+       | uris -> List.map Uri.of_string uris)
+    in
+    let connect_config = Caqti_connect_config.default
+      |> Option.fold ~none:Fun.id
+          ~some:Caqti_connect_config.(set tweaks_version) tweaks_version
+      |> Option.fold ~none:Fun.id
+          ~some:Caqti_connect_config.(set dynamic_prepare_capacity)
+          dynamic_prepare_capacity
+    in
+    {uris; connect_config}
+  in
+  let base_term =
+    let open Term in
+    const preprocess
+      $ tweaks_version
+      $ dynamic_prepare_capacity
+      $ log_level
+      $ uris
+      $ uris_file
+  in
+  List.fold_right Term.app !other_common_args base_term
+
+let test_name_of_uri uri =
+  (match Uri.scheme uri with
+   | Some scheme -> scheme
+   | None -> Uri.to_string uri)
+
+let init_list n f = (* List.init is available from OCaml 4.6.0 *)
+ let rec loop acc i = if i < 0 then acc else loop (f i :: acc) (i - 1) in
+ loop [] (n - 1)
+
+module Make_alcotest_cli
+  (Platform : Alcotest_engine.Platform.MAKER)
+  (Monad : Alcotest_engine.Monad.S) =
+struct
+  include Alcotest_engine.V1.Cli.Make (Platform) (Monad)
+
+  let test_case_sync name speed f =
+    test_case name speed (fun x -> Monad.return (f x))
+
+  let run_with_args_dependency ?argv name term make_tests =
+    let tests =
+      (match Cmdliner.Cmd.eval_peek_opts ~version_opt:true ?argv term with
+       | Some arg, _ -> make_tests arg
+       | _ -> [])
+    in
+    run_with_args ?argv name Cmdliner.Term.(const ignore $ term) tests
+end
+
+let () =
+  Random.self_init ();
+  Logs.set_reporter (Logs.format_reporter ());
+
+  (* Needed for bytecode since plugins link against C libraries: *)
+  Dynlink.allow_unsafe_modules true