[OCaml] High Intensity Training Online
fix quarantine a corrupt row instead of failing the read
A stored row the codec refused raised Corrupt, so one malformed workout, feedback report, import batch, or imported record aborted the whole list read for that trainee and surfaced as a silent 500. A single bad row hid the trainee's entire history. List reads now skip a corrupt row and report it on stderr with its position and the codec's reason, so the rest of the history stays readable and the corruption is visible. A targeted read of one record still raises, because the caller asked for that record and answering "not found" would lose it silently.
Changed files
lib/persistence/sqlite_repo.ml
@@ -207,11 +207,28 @@
207
207
208
208
let find_routine_by_name = Catalog.find_by_name
209
209
210
Added:
(* A stored row the codec refuses is corrupt: a storage invariant failed, not a
211
Added:
user error. A targeted read of one record raises [Corrupt], because the caller
212
Added:
asked for that record and silently answering "not found" would lose it. A
213
Added:
list read quarantines the row instead: it is skipped and reported here, so
214
Added:
one bad row never hides a trainee's whole history. *)
215
Added:
let warn_corrupt ~what ~id detail =
216
Added:
Printf.eprintf "hito: corrupt %s %S skipped: %s\n%!" what id detail
217
Added:
210
218
let decode encoded =
211
219
match Codec.decode_workout ~find_routine:find_routine_by_name encoded with
212
220
| Ok workout -> workout
213
221
| Error e -> raise (Corrupt e)
214
222
223
Added:
(* Decode one history row, or quarantine it. *)
224
Added:
let decode_history_row (wid, encoded) =
225
Added:
match Codec.decode_workout ~find_routine:find_routine_by_name encoded with
226
Added:
| Ok workout -> Some { Repository.id = Repository.workout_id wid; workout }
227
Added:
| Error e ->
228
Added:
warn_corrupt ~what:"workout" ~id:wid
229
Added:
(Format.asprintf "%a" Codec.pp_error e);
230
Added:
None
231
Added:
215
232
(* --- accounts --- *)
216
233
217
234
let create_trainee t ~username ~credential =
@@ -388,11 +405,7 @@
388
405
let history t id =
389
406
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
390
407
Db.collect_list Q.history (Trainee.id_to_string id))
391
Removed:
>|= fun rows ->
392
Removed:
List.map
393
Removed:
(fun (wid, encoded) ->
394
Removed:
{ Repository.id = Repository.workout_id wid; workout = decode encoded })
395
Removed:
rows
408
Added:
>|= List.filter_map decode_history_row
396
409
397
410
let log t id =
398
411
history t id >|= fun records ->
@@ -411,15 +424,22 @@
411
424
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
412
425
Db.exec Q.insert_feedback (trainee, seq, encoded))
413
426
414
Removed:
let decode_feedback encoded =
415
Removed:
match Codec.decode_feedback encoded with
416
Removed:
| Ok report -> report
417
Removed:
| Error e -> raise (Corrupt e)
427
Added:
(* Quarantine a corrupt row in a list read, naming its position. *)
428
Added:
let quarantine ~what ~pp_error decode rows =
429
Added:
List.mapi (fun i encoded -> (i + 1, decode encoded)) rows
430
Added:
|> List.filter_map (fun (position, decoded) ->
431
Added:
match decoded with
432
Added:
| Ok v -> Some v
433
Added:
| Error e ->
434
Added:
warn_corrupt ~what ~id:(string_of_int position)
435
Added:
(Format.asprintf "%a" pp_error e);
436
Added:
None)
418
437
419
438
let feedback t id =
420
439
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
421
440
Db.collect_list Q.feedback (Trainee.id_to_string id))
422
Removed:
>|= List.map decode_feedback
441
Added:
>|= quarantine ~what:"feedback report" ~pp_error:Codec.pp_error
442
Added:
Codec.decode_feedback
423
443
424
444
let save_app_feedback t id ~submitted_at ~message =
425
445
let trainee = Trainee.id_to_string id in
@@ -547,11 +567,6 @@
547
567
| Ok batch -> batch
548
568
| Error e -> raise (Import_corrupt e)
549
569
550
Removed:
let decode_record encoded =
551
Removed:
match Import_codec.decode_record encoded with
552
Removed:
| Ok record -> record
553
Removed:
| Error e -> raise (Import_corrupt e)
554
Removed:
555
570
let save_import_batch t id batch =
556
571
let trainee = Trainee.id_to_string id in
557
572
let batch_id =
@@ -576,7 +591,8 @@
576
591
let import_batches t id =
577
592
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
578
593
Db.collect_list Q.import_batches (Trainee.id_to_string id))
579
Removed:
>|= List.map decode_batch
594
Added:
>|= quarantine ~what:"import batch" ~pp_error:Import_codec.pp_error
595
Added:
(Import_codec.decode_snapshot ~find_exercise)
580
596
581
597
(* Deleting a provisional batch leaves its promoted records: there is no foreign
582
598
key, so no cascade can reach them. *)
@@ -608,4 +624,5 @@
608
624
let imported_records t id =
609
625
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
610
626
Db.collect_list Q.imported_records (Trainee.id_to_string id))
611
Removed:
>|= List.map decode_record
627
Added:
>|= quarantine ~what:"imported record" ~pp_error:Import_codec.pp_error
628
Added:
Import_codec.decode_record
test/dune
@@ -16,4 +16,8 @@
16
16
dream
17
17
dream-html
18
18
lwt
19
Removed:
caqti))
19
Added:
caqti
20
Added:
caqti-lwt
21
Added:
caqti-lwt.unix
22
Added:
caqti-driver-sqlite3
23
Added:
uri))
test/test_sqlite_repo.ml
@@ -41,6 +41,62 @@
41
41
42
42
let durability_tests =
43
43
[
44
Added:
( "a corrupt history row is quarantined, not fatal",
45
Added:
`Quick,
46
Added:
fun () ->
47
Added:
(* One malformed stored workout must not hide a trainee's whole
48
Added:
history. The row is skipped with a warning and the rest read. *)
49
Added:
let path, uri = temp_uri () in
50
Added:
Fun.protect
51
Added:
~finally:(fun () -> cleanup path)
52
Added:
(fun () ->
53
Added:
let id =
54
Added:
let repo = connect uri in
55
Added:
let s = S.make ~repo in
56
Added:
let trainee =
57
Added:
ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))
58
Added:
in
59
Added:
let id = trainee.Trainee.id in
60
Added:
let finish_one ?stimulus day_n =
61
Added:
let _ =
62
Added:
ok
63
Added:
(run
64
Added:
(S.begin_workout s id ~routine:ideal ~now:(day day_n)
65
Added:
~override:() ()))
66
Added:
in
67
Added:
Option.iter
68
Added:
(fun stim -> ignore (ok (run (S.log s id stim))))
69
Added:
stimulus;
70
Added:
let _ = run (S.finish s id ~ended_at:(day day_n)) in
71
Added:
()
72
Added:
in
73
Added:
(* Day 1 prescribes Laterals; Day 2 does not, so it is finished
74
Added:
without a record. Both are stored rows either way. *)
75
Added:
finish_one ~stimulus:(single "laterals" 12. 8) 1;
76
Added:
finish_one 3;
77
Added:
id
78
Added:
in
79
Added:
(* Corrupt the first stored workout behind the repository's back. *)
80
Added:
let corrupt =
81
Added:
let open Lwt.Infix in
82
Added:
Caqti_lwt_unix.connect (Uri.of_string uri) >>= function
83
Added:
| Error e -> Lwt.fail_with (Caqti_error.show e)
84
Added:
| Ok (module Db : Caqti_lwt.CONNECTION) -> (
85
Added:
let req =
86
Added:
Caqti_request.Infix.(Caqti_type.Std.(unit ->. unit))
87
Added:
"UPDATE workout SET encoded = 'not a workout' WHERE seq \
88
Added:
= (SELECT MIN(seq) FROM workout)"
89
Added:
in
90
Added:
Db.exec req () >>= function
91
Added:
| Ok () -> Lwt.return_unit
92
Added:
| Error e -> Lwt.fail_with (Caqti_error.show e))
93
Added:
in
94
Added:
run corrupt;
95
Added:
let repo = connect uri in
96
Added:
let s = S.make ~repo in
97
Added:
let history = run (S.history s id) in
98
Added:
Alcotest.(check int)
99
Added:
"the intact record is still read" 1 (List.length history)) );
44
100
( "a finished workout survives a reconnect to the same file",
45
101
`Quick,
46
102
fun () ->