Source file Sqlite3Ops.ml

open MlFront_Errors

let rc_err db r =
  (match Sqlite3.Rc.to_string r with
  | "" -> ()
  | s ->
      Errors.Details.add_context (fun ppf () ->
          Fmt.pf ppf "@[<hov 2>sqlite3 result:@ %a@]" Fmt.words s));
  (match Sqlite3.errmsg db with
  | "" -> ()
  | s ->
      Errors.Details.add_error (fun ppf () ->
          Fmt.pf ppf "@[<hov 2>sqlite3 error:@ %a@]" Fmt.words s));
  Error `ErrorCaptured

let lift_rc_ok db = function Sqlite3.Rc.OK -> Ok () | r -> rc_err db r
let lift_rc_done db = function Sqlite3.Rc.DONE -> Ok () | r -> rc_err db r

let lift_rc_row db stmt = function
  | Sqlite3.Rc.ROW -> Ok (Sqlite3.row_data stmt)
  | r -> rc_err db r

let lift_msg = function
  | Ok v -> Ok v
  | Error (`Msg msg) ->
      Errors.Details.add_problem (fun ppf () -> Fmt.string ppf msg);
      Error `ErrorCaptured

(* let lift_captured = function
   | Ok v -> Ok v
   | Error `ErrorCaptured -> MlFront_Errors.BindsResult.zero () *)

let friendly_bind_names_exn stmt lst =
  let rec loop = function
    | [] -> Sqlite3.Rc.OK
    | (name, data) :: rest ->
    match Sqlite3.bind_name stmt name data with
    | rc -> if rc = Sqlite3.Rc.OK then loop rest else rc
    | exception Not_found ->
        Errors.Details.add_error (fun ppf () ->
            Fmt.pf ppf
              "The name %s could not be bound because it was not present in \
               the SQL"
              name);
        Errors.Details.raise_error ()
  in
  loop lst

let exec_ddl_exn ~errbrief db ddl =
  let ddl = String.trim ddl in
  MlFront_Errors.ExitHandler.proc
    ~problem:(fun () -> errbrief)
    (fun () ->
      Errors.Details.add_context (fun ppf () ->
          Fmt.pf ppf "@[<hov 2>DDL:@ %a@]" Fmt.words ddl);
      Sqlite3.exec db ddl |> lift_rc_ok db)

let exec_dml_exn ~errbrief db dml binds =
  let ( let* ) = Result.bind in
  let open Sqlite3 in
  let dml = String.trim dml in
  MlFront_Errors.ExitHandler.proc
    ~problem:(fun () -> errbrief)
    (fun () ->
      Errors.Details.add_context (fun ppf () ->
          Fmt.pf ppf "@[<hov 2>DML:@ %a@]" Fmt.words dml);
      let stmt = prepare db dml in
      let* () = friendly_bind_names_exn stmt binds |> lift_rc_ok db in
      (* A DML should be immediately done. *)
      let* () = step stmt |> lift_rc_done db in
      finalize stmt |> lift_rc_ok db)

(** [query_generic] expects one, and only one, record. *)
let query_generic_exn ~errbrief ~cond ~condwhat db sql binds =
  let ( let* ) = Result.bind in
  let open Sqlite3 in
  let sql = String.trim sql in
  MlFront_Errors.ExitHandler.proc
    ~problem:(fun () -> errbrief)
    (fun () ->
      Errors.Details.add_context (fun ppf () ->
          Fmt.pf ppf "@[<hov 2>SQL:@ %a@]" Fmt.words sql);
      let stmt = prepare db sql in
      let* () = friendly_bind_names_exn stmt binds |> lift_rc_ok db in
      let* data_arr = step stmt |> lift_rc_row db stmt in
      let data = data_arr.(0) in
      let* () = finalize stmt |> lift_rc_ok db in
      match cond data with
      | Some value -> Ok value
      | None ->
          Errors.Details.add_problem (fun ppf () ->
              Fmt.pf ppf "Expected an %s result, not:@ %s" condwhat
                (Sqlite3.Data.to_string_debug data));
          Error `ErrorCaptured)

(** [query_generic_option] expects zero or one records.

    You do not need to check for NULL in [cond]. NULLs are automatically
    converted to [None] return values. *)
let query_generic_option_exn ~errbrief ~cond ~condwhat db sql binds =
  let ( let* ) = Result.bind in
  let open Sqlite3 in
  let sql = String.trim sql in
  MlFront_Errors.ExitHandler.proc
    ~problem:(fun () -> errbrief)
    (fun () ->
      Errors.Details.add_context (fun ppf () ->
          Fmt.pf ppf "@[<hov 2>SQL:@ %a@]" Fmt.words sql);
      let stmt = prepare db sql in
      let* () = friendly_bind_names_exn stmt binds |> lift_rc_ok db in
      match step stmt with
      | Rc.DONE -> Ok None
      | Rc.ROW -> begin
          let* data_arr = lift_rc_row db stmt Rc.ROW in
          let data = data_arr.(0) in
          let* () = finalize stmt |> lift_rc_ok db in
          match data with
          | Sqlite3.Data.NULL -> Ok None
          | _ ->
          match cond data with
          | Some value -> Ok (Some value)
          | None ->
              Errors.Details.add_problem (fun ppf () ->
                  Fmt.pf ppf "Expected an %s result, not:@ %s" condwhat
                    (Sqlite3.Data.to_string_debug data));
              Error `ErrorCaptured
        end
      | r -> rc_err db r)

let query_int64_exn ~errbrief db sql binds =
  query_generic_exn ~errbrief
    ~cond:(function Sqlite3.Data.INT intval -> Some intval | _ -> None)
    ~condwhat:"INT" db sql binds

let query_int64_option_exn ~errbrief db sql binds =
  query_generic_option_exn ~errbrief
    ~cond:(function Sqlite3.Data.INT intval -> Some intval | _ -> None)
    ~condwhat:"INT" db sql binds

let query_string_option_exn ~errbrief db sql binds =
  query_generic_option_exn ~errbrief
    ~cond:(function Sqlite3.Data.TEXT textval -> Some textval | _ -> None)
    ~condwhat:"TEXT" db sql binds