(* 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