unikernel/duniverse/ocaml-caqti/caqti/test/dune

@@ -0,0 +1,5 @@
+(test
+ (name main)
+ (package caqti)
+ (flags (:standard -alert -caqti_unstable))
+ (libraries alcotest caqti caqti.platform re.pcre))

unikernel/duniverse/ocaml-caqti/caqti/test/main.ml

@@ -0,0 +1,27 @@
+(* 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.
+ *)
+
+let tests = [
+  "heap", Test_heap.test_cases;
+  "query", Test_query.test_cases;
+  "request", Test_request.test_cases;
+  "request_cache", Test_request_cache.test_cases;
+  "switch", Test_switch.test_cases;
+  "version", Test_version.test_cases;
+]
+
+let () = Alcotest.V1.run "caqti" tests

unikernel/duniverse/ocaml-caqti/caqti/test/test_heap.ml

@@ -0,0 +1,35 @@
+(* Copyright (C) 2014--2022  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 H =
+  Caqti_platform.Heap.Make (struct type t = int let compare = compare end)
+
+let test_push_pop_n n =
+  let a = Array.init n (fun _ -> Random.int n) in
+  let h = Array.fold_right H.push a H.empty in
+  Array.sort (fun i j -> compare j i) a;
+  let check_pop x h =
+    let x', h' = H.pop_e h in
+    assert (x = x'); h' in
+  let h' = Array.fold_right check_pop a h in
+  assert (H.is_empty h')
+
+let test_push_pop () = for i = 0 to 599 do test_push_pop_n i done
+
+let test_cases = [
+  "push, pop", `Quick, test_push_pop;
+]

unikernel/duniverse/ocaml-caqti/caqti/test/test_query.ml

@@ -0,0 +1,193 @@
+(* Copyright (C) 2019--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 Query = Caqti_template.Query
+module Query_fmt = Caqti_template.Query_fmt
+
+module A = struct
+  include Alcotest.V1
+
+  let query = testable Query.pp (fun x y -> Query.(equal (normal x) (normal y)))
+
+  let approx_query_string =
+    let pp ppf x = Format.fprintf ppf "%S" x in
+    let normalize =
+      let re = Re.Pcre.regexp {|\$([0-9]|[A-Za-z0-9_]*\.)|} in
+      let f g =
+        let s = Re.Group.get g 1 in
+        if s.[String.length s - 1] = '.' then "$(" ^ s ^ ")" else "?"
+      in
+      Re.replace re ~f
+    in
+    testable pp (fun x y -> String.equal (normalize x) (normalize y))
+end
+
+let random_letter () = Char.chr (Char.code 'a' + Random.int 26)
+
+let rec random_query n =
+  if n <= 1 then
+    if Random.bool ()
+      then Query.param (Random.int 8)
+      else Query.lit (String.init (Random.int 3) (fun _ -> random_letter ()))
+  else
+    Query.concat (random_queries n)
+and random_queries n =
+  if n = 0 then [] else
+  if Random.bool () then [random_query n] else
+  let m = Random.int (n + 1) in
+  random_queries m @ random_queries (n - m)
+
+let test_show_and_hash_once () =
+  let q1 = random_query (Random.int 8 + Random.int (1 lsl Random.int 8)) in
+  let q2 = random_query (Random.int 8 + Random.int (1 lsl Random.int 8)) in
+  let s1 = Query.show q1 in
+  let s2 = Query.show q2 in
+  if Query.equal q1 q2 then assert (Query.hash q1 = Query.hash q2);
+  assert ((s1 = s2) = (Query.(equal (normal q1) (normal q2))))
+
+let test_show_and_hash () =
+  try
+    for _ = 0 to 9999 do test_show_and_hash_once () done
+  with Failure msg ->
+    Printf.eprintf "%s\n" msg;
+    exit 1
+
+let random_query_string () =
+  let random_char _ = Char.chr (0x20 + Random.int 0x60) in
+  String.init (Random.int 128) random_char
+
+let test_parse_special_cases () =
+  let check_reject ~pos s =
+    (match Caqti_query.of_string s with
+     | Ok _ ->
+        A.failf "Invalid expression %S accepted by parser." s
+     | Error (`Invalid (pos', msg)) ->
+        if pos' <> pos then
+          A.failf "Position %d should be %d for error %S while parsing %s"
+                  pos' pos msg s)
+  in
+  let check_normal' s =
+    (match Caqti_query.of_string_exn s with
+     | q ->
+        A.(check string) "same" s (Caqti_query.show q)
+     | exception Failure msg ->
+        A.failf "Failed to parse %S: %s" s msg)
+  in
+  let check_normal s =
+    check_normal' s;
+    check_normal' (" " ^ s);
+    check_normal' (s ^ " ")
+  in
+  let check_expect q s =
+    A.(check query "same" q (Caqti_query.of_string_exn s))
+  in
+  check_reject ~pos:0 {|$0|}; check_reject ~pos:1 {|x$01|};
+  check_reject ~pos:1 {|?0|}; check_reject ~pos:2 {|x?1x|};
+  List.iter check_normal [
+    {||}; {|a|}; {|ab|}; {| a b |};
+    {|''|}; {|'a'|}; {|'''a''b'''|};
+    {|""|}; {|"a"|}; {|"""a""b"""|};
+    {|$(.)|}; {|$(a.)|}; {|$(ab.)|}; {|$(a)|}; {|$(ab)|};
+    {|$$ a $(x.) $(y) b $$|};
+    {|$$"$$|}; {|$$'$$|}; {|$QUOTE$ ' " $QUOTE$|};
+    {|$QUOTE$ a $x. $. $( z) b ?0 $QUOTE $$QUOTE$|};
+    (* Allowed by angstrom_parser_with_semicolon but not by angstrom_parser: *)
+    {|a;b|};
+  ];
+  check_expect
+    Query.(concat [lit "SELECT "; param 0; lit "::smallint"])
+    {|SELECT ?::smallint|};
+  check_expect
+    Query.(concat [lit "$$ "; var "x"; lit " $$"])
+    "$$ $(x) $$";
+  check_expect
+    Query.(concat [lit "$Q$ $(x) $Q$"])
+    "$Q$ $(x) $Q$";
+  check_expect
+    Query.(concat [param 0; lit " $$ ? $$ "; param 1; lit " "; param 2])
+    "? $$ ? $$ ? ?"
+
+let test_parse_random_strings () =
+  let check_normal_or_exn s =
+    (match Caqti_query.of_string s with
+     | Ok q ->
+        A.(check approx_query_string) "same" s (Caqti_query.show q)
+     | Error (`Invalid (_, "Inconsistent parameter style.")) -> ()
+     | Error (`Invalid (ok_len, _)) ->
+        if ok_len > 0 && ok_len < String.length s then begin
+          let s' = String.sub s 0 ok_len in
+          (match Caqti_query.of_string s' with
+           | Ok q ->
+              A.(check approx_query_string) "same" s' (Caqti_query.show q)
+           | Error (`Invalid (_, "Inconsistent parameter style.")) ->
+              () (* only checked after successful parse *)
+           | Error (`Invalid (pos, msg)) ->
+              A.failf "Supposed valid substring [0, %d) of %S fails at %d: %s"
+                ok_len s pos msg)
+        end)
+  in
+  for _ = 1 to 50_000 do
+    check_normal_or_exn (random_query_string ())
+  done
+
+let test_expand () =
+  let env1 = function
+   | "" -> Query.lit "default"
+   | "alt" -> Query.lit "other"
+   | _ -> raise Not_found
+  in
+  let env2 = function
+   | "." -> Query.lit "default."
+   | "alt." -> Query.lit "other."
+   | _ -> raise Not_found
+  in
+  let env3 = function
+   | "." -> Query.lit "dot"
+   | "cat" -> Query.lit "mouse"
+   | "cat." -> Query.lit "dog"
+   | _ -> raise Not_found
+  in
+  let q1 = Query.parse " $. $(.) $alt. $(alt.) $cat. $(cat) " in
+  let q1' = Query.parse " default. default. other. other. $cat. $(cat) " in
+  let q1'3 = Query.parse " dot dot $alt. $(alt.) dog mouse " in
+  A.(check query) "same" q1' (Caqti_query.expand env1 q1);
+  A.(check query) "same" q1' (Caqti_query.expand env2 q1);
+  A.(check query) "same" q1'3 (Caqti_query.expand env3 q1)
+
+let test_qprintf () =
+  let check_expect q1 q2 =
+    A.(check query "same" (Query.normal q1) (Query.normal q2))
+  in
+  check_expect
+    Query.(concat [
+      lit "SELECT "; param 0; lit " WHERE "; quote "quote"; lit " = "; var "env"
+    ])
+    Query_fmt.(
+      qprintf {|%a %a WHERE %a = %a|}
+        query (Query.lit "SELECT") param 0 quote "quote" env "env");
+  check_expect
+    Query.(concat [lit "WHERE "; var "tbl4"; lit ".name = "; quote "John Wayne"])
+    Query_fmt.(qprintf {|WHERE @{<E>tbl%d@}.name = @{<Q>%s Wayne@}|} 4 "John")
+
+
+let test_cases = [
+  A.test_case "show, hash" `Quick test_show_and_hash;
+  A.test_case "parse special cases" `Quick test_parse_special_cases;
+  A.test_case "parse random strings" `Quick test_parse_random_strings;
+  A.test_case "expand" `Quick test_expand;
+  A.test_case "qprintf" `Quick test_qprintf;
+]

unikernel/duniverse/ocaml-caqti/caqti/test/test_request.ml

@@ -0,0 +1,49 @@
+(* Copyright (C) 2020--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
+
+module Q = Caqti_template.Query
+
+let expect_parse ~subst qs q' =
+  let rq =
+    let open Caqti_template.Create in
+    let q = qs |> Q.parse |> Q.expand subst in
+    static_gen T.(unit -->. unit) @@ fun _ -> q
+  in
+  let q = Caqti_query.normal (Caqti_request.query rq Caqti_driver_info.dummy) in
+  if not (Q.equal q q') then begin
+    eprintf "Parsed:   %s\nExpected: %s\n"
+      (Q.show q) (Q.show q');
+    assert false
+  end
+
+let test_request_parse () =
+  let subst = function
+   | "alpha" -> Q.lit "α"
+   | "beta" -> Q.lit "β"
+   | "beta." -> Q.lit "β[dot]"
+   | "gamma" -> Q.lit "γ"
+   | "delta" -> Q.lit "δ"
+   | _ -> raise Not_found
+  in
+  expect_parse ~subst "$(alpha) $$ $beta. $(gamma) $delta. $$ $Q$ $beta. $Q$"
+    (Q.lit "α $$ β[dot] γ δ. $$ $Q$ $beta. $Q$")
+
+let test_cases = [
+  "parse", `Quick, test_request_parse;
+]

unikernel/duniverse/ocaml-caqti/caqti/test/test_request_cache.ml

@@ -0,0 +1,98 @@
+(* Copyright (C) 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 Caqti_template
+open Caqti_platform
+
+module A = Alcotest.V1
+
+module Cache = Request_cache.Make (struct type t = int let weight _ = 1 end)
+
+let dialect =
+  Dialect.create_unknown ~purpose:`Dummy () [@alert "-caqti_private"]
+
+let static_select =
+  let open Caqti_template.Create in
+  static T.(unit -->! int) "SELECT -1"
+
+let dynamic_select i =
+  let open Caqti_template.Create in
+  let query = Q.("SELECT " ^++ int i) in
+  let request_type = T.(unit -->! int) in
+  Request.create Dynamic request_type (fun _ -> query)
+
+let is_promoted i = Hashtbl.hash (i : int) land 1 = 0
+let is_retained i = Hashtbl.hash (i : int) land 2 = 0
+let is_orphaned i = not (is_promoted i || is_retained i)
+
+let test_hit_or_miss () =
+  let n = 1000 in
+  let all = List.init n Fun.id in
+  let promoted = List.filter is_promoted all in
+  let retained = List.filter is_retained all in
+  let orphaned = List.filter is_orphaned all in
+  let retained_requests = Queue.create () in
+  let dynamic_capacity = n - List.length orphaned in
+  let cache = Cache.create ~dynamic_capacity dialect in
+  Cache.add cache static_select (-1);
+  let promote_upto j =
+    promoted |> List.iter begin fun i ->
+      if i < j then
+        let elt = Cache.find_and_promote cache (dynamic_select i) in
+        A.(check (option int)) "promote" (Some i) elt
+    end
+  in
+  for i = 0 to n - 1 do
+    if i < dynamic_capacity then
+      A.(check int) "weight" i (Cache.dynamic_weight cache);
+    let request = dynamic_select i in
+    if is_retained i then Queue.add request retained_requests;
+    Cache.add cache request i;
+    if is_orphaned i then promote_upto i
+  done;
+
+  (* The second Gc.compact call is needed for OCaml 5.0.0 and 5.1.1. *)
+  Gc.compact ();
+  Gc.compact ();
+
+  let trimmed, commit = Cache.trim ~max_promote_count:n cache in
+  A.(check (list int)) "trim" orphaned (List.sort Int.compare trimmed);
+  commit ();
+
+  retained |> List.iter begin fun i ->
+    A.(check (option int)) "retained dynamic hit" (Some i)
+      (Cache.find_and_promote cache (dynamic_select i))
+  end;
+
+  promoted |> List.iter begin fun i ->
+    A.(check (option int)) "dynamic hit" (Some i)
+      (Cache.find_and_promote cache (dynamic_select i))
+  end;
+
+  orphaned |> List.iter begin fun i ->
+    A.(check (option int)) "dynamic miss" None
+      (Cache.find_and_promote cache (dynamic_select i))
+  end;
+
+  A.(check (option int)) "static hit" (Some (-1))
+    (Cache.find_and_promote cache static_select);
+
+  ignore (Queue.iter ignore retained_requests)
+
+let test_cases = [
+  A.test_case "hit or miss" `Quick test_hit_or_miss;
+]

unikernel/duniverse/ocaml-caqti/caqti/test/test_switch.ml

@@ -0,0 +1,67 @@
+(* Copyright (C) 2023  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 A = Alcotest.V1
+
+module Switch = Caqti_platform.Switch.Make (struct
+  type 'a t = 'a
+  let return = Fun.id
+  module Infix = struct
+    let (>>=) m f = f m
+  end
+  let finally f h = try let y = f () in h (); y with exn -> h (); raise exn
+end)
+
+let test_switch sw =
+  Switch.check sw;
+  let state = ref 0 in
+  let transit i j () = A.(check int) "transit" i !state; state := j in
+  let _ = Switch.on_release_cancellable sw (transit 2 3) in
+  let hook1 = Switch.on_release_cancellable sw (fun () -> A.fail "removed") in
+  let _ = Switch.on_release_cancellable sw (transit 1 2) in
+  let hook2 = Switch.on_release_cancellable sw (fun () -> A.fail "removed") in
+  let _ = Switch.on_release_cancellable sw (transit 0 1) in
+  Switch.remove_hook hook1;
+  Switch.remove_hook hook2;
+  Switch.check sw
+
+let test_eternal () =
+  let sw = Switch.eternal in
+  let _ = Switch.on_release_cancellable sw (fun () -> A.fail "on eternal") in
+  let hook = Switch.on_release_cancellable sw (fun () -> A.fail "on eternal") in
+  Switch.remove_hook hook
+
+let test_create () =
+  let sw = Switch.create () in
+  test_switch sw;
+  Switch.release sw;
+  A.check_raises "released switch" Switch.Off (fun () -> Switch.check sw)
+
+let test_run () =
+  let sw' = ref None in
+  Switch.run begin fun sw ->
+    sw' := Some sw;
+    test_switch sw
+  end;
+  A.check_raises "outside run"
+    Switch.Off (fun () -> Option.iter Switch.check !sw')
+
+let test_cases = [
+  A.test_case "eternal" `Quick test_eternal;
+  A.test_case "create" `Quick test_create;
+  A.test_case "run" `Quick test_run;
+]

unikernel/duniverse/ocaml-caqti/caqti/test/test_version.ml

@@ -0,0 +1,59 @@
+(* Copyright (C) 2024--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.
+ *)
+
+[@@@alert "-caqti_private"]
+
+open Caqti_template
+
+module A = struct
+  include Alcotest.V1
+
+  let version = testable Version.pp Version.equal
+end
+
+let versions = List.map (List.map Version.of_string_unsafe) [
+  ["~beta"];
+  ["0~beta"; "00~beta"];
+  [""; "0"; "0.0"; "0.0.0"; "0.000.0"; "000.00.0"];
+  ["0.1~"];
+  ["0.1.0~"];
+  ["0.1"; "0.1.0"; "000.1.000"];
+  ["0.1.0r1"; "00.001.0r1"; "000.1.000r1"];
+  ["0.1r1"];
+  ["0.2~"];
+  ["0.2.0.000"];
+  ["0.2-2"];
+  ["0.2.1"];
+  ["25.100"; "025.0100"];
+]
+
+let test_equal () =
+  let equal_to v0 v = A.(check version) "same version" v0 v in
+  let all_equal = function
+   | [] -> assert false
+   | v0 :: vs -> List.iter (equal_to v0) vs
+  in
+  List.iter all_equal versions
+
+let test_compare () =
+  let versions = List.map List.hd versions in
+  A.(check (list version)) "order" versions (List.sort Version.compare versions)
+
+let test_cases = [
+  A.test_case "equal" `Quick test_equal;
+  A.test_case "compare" `Quick test_compare;
+]