unikernel/duniverse/ocaml-caqti/testsuite/test_error_cause.ml

@@ -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