Source file Sqlite3Ops.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
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