a database layer insipred by caqti and ecto
gdiazlo.tngl.sh
1type change =
2 | StringChange of string
3 | IntChange of int
4 | FloatChange of float
5 | BoolChange of bool
6 | NullChange
7
8module StringMap = Map.Make (String)
9module StringSet = Set.Make (String)
10
11type 'a t = {
12 data : 'a;
13 changes : change StringMap.t;
14 errors : Error.validation_error list;
15 valid : bool;
16 action : action option;
17 constraints : constraint_def list;
18}
19
20and action = Insert | Update | Delete
21
22and constraint_def = {
23 constraint_name : string;
24 constraint_field : string;
25 constraint_type : constraint_type;
26}
27
28and constraint_type =
29 | UniqueConstraint
30 | ForeignKeyConstraint of { table : string; column : string }
31 | CheckConstraint of string
32
33let create data =
34 {
35 data;
36 changes = StringMap.empty;
37 errors = [];
38 valid = true;
39 action = None;
40 constraints = [];
41 }
42
43let change data = create data
44
45let for_insert data =
46 {
47 data;
48 changes = StringMap.empty;
49 errors = [];
50 valid = true;
51 action = Some Insert;
52 constraints = [];
53 }
54
55let for_update data =
56 {
57 data;
58 changes = StringMap.empty;
59 errors = [];
60 valid = true;
61 action = Some Update;
62 constraints = [];
63 }
64
65let cast params ~fields t =
66 let allowed =
67 List.fold_left
68 (fun acc f -> StringSet.add (Field.name f) acc)
69 StringSet.empty fields
70 in
71 let changes =
72 List.fold_left
73 (fun acc (k, v) ->
74 if StringSet.mem k allowed then StringMap.add k (StringChange v) acc
75 else acc)
76 StringMap.empty params
77 in
78 { t with changes }
79
80let cast_assoc assoc ~fields t =
81 let allowed =
82 List.fold_left
83 (fun acc f -> StringSet.add (Field.name f) acc)
84 StringSet.empty fields
85 in
86 let changes =
87 List.fold_left
88 (fun acc (k, v) ->
89 if StringSet.mem k allowed then StringMap.add k v acc else acc)
90 StringMap.empty assoc
91 in
92 { t with changes }
93
94let put_change field value t =
95 let name = Field.name field in
96 { t with changes = StringMap.add name (StringChange value) t.changes }
97
98let delete_change field t =
99 let name = Field.name field in
100 { t with changes = StringMap.remove name t.changes }
101
102let get_change t field =
103 let name = Field.name field in
104 match StringMap.find_opt name t.changes with
105 | Some (StringChange s) -> Some s
106 | _ -> None
107
108let get_field t field = Field.get field t.data
109
110let add_error ~field ~message ~validation t =
111 let error = Error.{ field; message; validation } in
112 { t with errors = error :: t.errors; valid = false }
113
114let validate_required fields t =
115 List.fold_left
116 (fun acc field ->
117 let name = Field.name field in
118 match StringMap.find_opt name acc.changes with
119 | Some (StringChange s) when s <> "" -> acc
120 | Some (StringChange _) | Some NullChange | None ->
121 add_error ~field:name ~message:"can't be blank" ~validation:"required"
122 acc
123 | Some _ -> acc)
124 t fields
125
126let validate_format field ~pattern t =
127 let name = Field.name field in
128 match StringMap.find_opt name t.changes with
129 | None -> t
130 | Some (StringChange value) ->
131 let re = Re.Pcre.regexp pattern in
132 if Re.execp re value then t
133 else
134 add_error ~field:name ~message:"has invalid format" ~validation:"format"
135 t
136 | _ -> t
137
138let validate_length field ?min ?max ?is t =
139 let name = Field.name field in
140 match StringMap.find_opt name t.changes with
141 | None -> t
142 | Some (StringChange value) -> (
143 let len = String.length value in
144 let t =
145 match min with
146 | Some m when len < m ->
147 add_error ~field:name
148 ~message:(Printf.sprintf "should be at least %d character(s)" m)
149 ~validation:"length" t
150 | _ -> t
151 in
152 let t =
153 match max with
154 | Some m when len > m ->
155 add_error ~field:name
156 ~message:(Printf.sprintf "should be at most %d character(s)" m)
157 ~validation:"length" t
158 | _ -> t
159 in
160 match is with
161 | Some expected when len <> expected ->
162 add_error ~field:name
163 ~message:(Printf.sprintf "should be %d character(s)" expected)
164 ~validation:"length" t
165 | _ -> t)
166 | _ -> t
167
168let validate_inclusion field ~values t =
169 let name = Field.name field in
170 match StringMap.find_opt name t.changes with
171 | None -> t
172 | Some (StringChange value) ->
173 if List.mem value values then t
174 else add_error ~field:name ~message:"is invalid" ~validation:"inclusion" t
175 | _ -> t
176
177let validate_exclusion field ~values t =
178 let name = Field.name field in
179 match StringMap.find_opt name t.changes with
180 | None -> t
181 | Some (StringChange value) ->
182 if not (List.mem value values) then t
183 else
184 add_error ~field:name ~message:"is reserved" ~validation:"exclusion" t
185 | _ -> t
186
187let validate_number field ?greater_than ?less_than ?greater_than_or_equal
188 ?less_than_or_equal t =
189 let name = Field.name field in
190 match StringMap.find_opt name t.changes with
191 | None -> t
192 | Some (StringChange value) -> (
193 match int_of_string_opt value with
194 | None ->
195 add_error ~field:name ~message:"is not a valid number"
196 ~validation:"number" t
197 | Some n -> (
198 let t =
199 match greater_than with
200 | Some m when n <= m ->
201 add_error ~field:name
202 ~message:(Printf.sprintf "must be greater than %d" m)
203 ~validation:"number" t
204 | _ -> t
205 in
206 let t =
207 match less_than with
208 | Some m when n >= m ->
209 add_error ~field:name
210 ~message:(Printf.sprintf "must be less than %d" m)
211 ~validation:"number" t
212 | _ -> t
213 in
214 let t =
215 match greater_than_or_equal with
216 | Some m when n < m ->
217 add_error ~field:name
218 ~message:
219 (Printf.sprintf "must be greater than or equal to %d" m)
220 ~validation:"number" t
221 | _ -> t
222 in
223 match less_than_or_equal with
224 | Some m when n > m ->
225 add_error ~field:name
226 ~message:(Printf.sprintf "must be less than or equal to %d" m)
227 ~validation:"number" t
228 | _ -> t))
229 | Some (IntChange n) ->
230 let t =
231 match greater_than with
232 | Some m when n <= m ->
233 add_error ~field:name
234 ~message:(Printf.sprintf "must be greater than %d" m)
235 ~validation:"number" t
236 | _ -> t
237 in
238 let t =
239 match less_than with
240 | Some m when n >= m ->
241 add_error ~field:name
242 ~message:(Printf.sprintf "must be less than %d" m)
243 ~validation:"number" t
244 | _ -> t
245 in
246 t
247 | _ -> t
248
249let validate_acceptance field t =
250 let name = Field.name field in
251 match StringMap.find_opt name t.changes with
252 | None ->
253 add_error ~field:name ~message:"must be accepted" ~validation:"acceptance"
254 t
255 | Some (BoolChange true) -> t
256 | Some (StringChange "true") -> t
257 | Some (StringChange "1") -> t
258 | _ ->
259 add_error ~field:name ~message:"must be accepted" ~validation:"acceptance"
260 t
261
262let validate_confirmation field ~confirmation_field t =
263 let name = Field.name field in
264 let conf_name = Field.name confirmation_field in
265 let value = StringMap.find_opt name t.changes in
266 let conf_value = StringMap.find_opt conf_name t.changes in
267 match (value, conf_value) with
268 | Some v1, Some v2 when v1 = v2 -> t
269 | Some _, Some _ ->
270 add_error ~field:conf_name ~message:"does not match"
271 ~validation:"confirmation" t
272 | _ -> t
273
274let validate_change field validator t =
275 match get_change t field with
276 | None -> t
277 | Some value -> (
278 match validator value with
279 | Ok () -> t
280 | Error msg ->
281 add_error ~field:(Field.name field) ~message:msg ~validation:"custom"
282 t)
283
284let validate t f = f t
285
286let unique_constraint field t =
287 let name = Field.name field in
288 let constraint_def =
289 {
290 constraint_name = name ^ "_unique";
291 constraint_field = name;
292 constraint_type = UniqueConstraint;
293 }
294 in
295 { t with constraints = constraint_def :: t.constraints }
296
297let foreign_key_constraint field ~references:(table, column) t =
298 let name = Field.name field in
299 let constraint_def =
300 {
301 constraint_name = name ^ "_fkey";
302 constraint_field = name;
303 constraint_type = ForeignKeyConstraint { table; column };
304 }
305 in
306 { t with constraints = constraint_def :: t.constraints }
307
308let check_constraint ~name field ~expression t =
309 let field_name = Field.name field in
310 let constraint_def =
311 {
312 constraint_name = name;
313 constraint_field = field_name;
314 constraint_type = CheckConstraint expression;
315 }
316 in
317 { t with constraints = constraint_def :: t.constraints }
318
319let is_valid t = t.valid
320let errors t = t.errors
321let data t = t.data
322let changes t = StringMap.bindings t.changes
323let changes_map t = t.changes
324let action t = t.action
325
326let get_error t field =
327 let name = Field.name field in
328 List.find_opt (fun e -> e.Error.field = name) t.errors
329
330let has_error t field = Option.is_some (get_error t field)
331
332let traverse_errors t f =
333 List.iter (fun err -> f err.Error.field err.Error.message) t.errors
334
335let error_messages t =
336 List.map
337 (fun err -> Printf.sprintf "%s %s" err.Error.field err.Error.message)
338 t.errors
339
340let apply_action t = if t.valid then Ok t.data else Error t.errors
341
342type 'a assoc_changeset = {
343 assoc_name : string;
344 assoc_changesets : 'a t list;
345 on_replace : [ `Raise | `Mark_as_invalid | `Delete | `Update ];
346}
347
348let cast_assoc_one ~assoc_name ~params ~cast_fn t =
349 match List.assoc_opt assoc_name params with
350 | None -> t
351 | Some assoc_params ->
352 let child_changeset = cast_fn assoc_params in
353 if is_valid child_changeset then t
354 else
355 let child_errors = errors child_changeset in
356 let prefixed_errors =
357 List.map
358 (fun err ->
359 Error.
360 {
361 field = assoc_name ^ "." ^ err.field;
362 message = err.message;
363 validation = err.validation;
364 })
365 child_errors
366 in
367 { t with errors = prefixed_errors @ t.errors; valid = false }
368
369let cast_assoc_many ~assoc_name ~params_list ~cast_fn t =
370 let process_one idx params =
371 let child_changeset = cast_fn params in
372 if is_valid child_changeset then []
373 else
374 let child_errors = errors child_changeset in
375 List.map
376 (fun err ->
377 Error.
378 {
379 field = Printf.sprintf "%s[%d].%s" assoc_name idx err.field;
380 message = err.message;
381 validation = err.validation;
382 })
383 child_errors
384 in
385 let all_errors = List.concat (List.mapi process_one params_list) in
386 if all_errors = [] then t
387 else { t with errors = all_errors @ t.errors; valid = false }
388
389let put_assoc ~assoc_name ~json_string t =
390 let change = StringChange json_string in
391 { t with changes = StringMap.add assoc_name change t.changes }
392
393let cast_embed ~embed_name ~params ~parse t =
394 match List.assoc_opt embed_name params with
395 | None -> t
396 | Some embed_params -> (
397 match parse embed_params with
398 | Ok _embedded -> t
399 | Error msg ->
400 add_error ~field:embed_name ~message:msg ~validation:"embedded" t)
401
402let put_embed ~embed_name ~json_string t =
403 let change = StringChange json_string in
404 { t with changes = StringMap.add embed_name change t.changes }
405
406let merge_errors parent_changeset child_changeset ~prefix =
407 let child_errors = errors child_changeset in
408 let prefixed_errors =
409 List.map
410 (fun err ->
411 Error.
412 {
413 field = prefix ^ "." ^ err.field;
414 message = err.message;
415 validation = err.validation;
416 })
417 child_errors
418 in
419 {
420 parent_changeset with
421 errors = prefixed_errors @ parent_changeset.errors;
422 valid = parent_changeset.valid && is_valid child_changeset;
423 }