[OCaml] High Intensity Training Online
fix preserve repository identities and ownership
Seed SQLite trainee identities from persisted rows and keep in-memory feedback sequences monotonic. Expose stable viewer ownership, align adapter ranking, remove the unused non-atomic save port, and cover reconnect, rename, edit, and deletion cases.
Changed files
lib/app/memory_repo.ml
@@ -5,6 +5,7 @@
5
5
mutable stored : Repository.record list; (* most recent first *)
6
6
mutable feedback : Evidence.Feedback.t list; (* most recent first *)
7
7
mutable next_id : int;
8
Added:
mutable next_app_feedback : int;
8
9
}
9
10
10
11
type t = {
@@ -36,6 +37,7 @@
36
37
stored = [];
37
38
feedback = [];
38
39
next_id = 1;
40
Added:
next_app_feedback = 1;
39
41
}
40
42
in
41
43
Hashtbl.replace t.states key s;
@@ -141,14 +143,6 @@
141
143
(state t id).current <- workout;
142
144
Lwt.return_unit
143
145
144
Removed:
let save t id workout =
145
Removed:
let s = state t id in
146
Removed:
let wid = Repository.workout_id (Printf.sprintf "w%d" s.next_id) in
147
Removed:
let record = { Repository.id = wid; workout } in
148
Removed:
s.next_id <- s.next_id + 1;
149
Removed:
s.stored <- record :: s.stored;
150
Removed:
Lwt.return record
151
Removed:
152
146
(* Store the finished workout and clear the in-progress slot together. In
153
147
memory this is a single synchronous update, so it cannot tear. *)
154
148
let finish_workout t id workout =
@@ -223,10 +217,12 @@
223
217
else count)
224
218
0 t.app_feedback
225
219
in
220
Added:
let s = state t id in
226
221
let feedback_id =
227
222
Repository.app_feedback_id
228
Removed:
(Printf.sprintf "%s:%d" (Trainee.id_to_string id) contributions)
223
Added:
(Printf.sprintf "%s:%d" (Trainee.id_to_string id) s.next_app_feedback)
229
224
in
225
Added:
s.next_app_feedback <- s.next_app_feedback + 1;
230
226
let report =
231
227
Repository.
232
228
{
@@ -237,11 +233,26 @@
237
233
message;
238
234
upvotes = 0;
239
235
viewer_upvoted = false;
236
Added:
viewer_owns = true;
240
237
}
241
238
in
242
239
t.app_feedback <- (id, report) :: t.app_feedback;
243
240
Lwt.return report
244
241
242
Added:
let app_feedback_id_parts report =
243
Added:
let raw =
244
Added:
Repository.app_feedback_id_to_string report.Repository.feedback_id
245
Added:
in
246
Added:
match String.rindex_opt raw ':' with
247
Added:
| None -> (raw, 0)
248
Added:
| Some separator ->
249
Added:
let owner = String.sub raw 0 separator in
250
Added:
let sequence =
251
Added:
String.sub raw (separator + 1) (String.length raw - separator - 1)
252
Added:
|> int_of_string_opt |> Option.value ~default:0
253
Added:
in
254
Added:
(owner, sequence)
255
Added:
245
256
let app_feedback t ~viewer =
246
257
let reports =
247
258
List.map
@@ -255,6 +266,16 @@
255
266
else count)
256
267
0 t.app_feedback
257
268
in
269
Added:
let author =
270
Added:
match
271
Added:
List.find_opt
272
Added:
(fun (trainee : Trainee.t) ->
273
Added:
String.equal owner_id (Trainee.id_to_string trainee.id))
274
Added:
t.trainees
275
Added:
with
276
Added:
| Some trainee -> Trainee.username_to_string trainee.username
277
Added:
| None -> report.Repository.author
278
Added:
in
258
279
let viewer_upvoted =
259
280
List.exists
260
281
(fun (feedback_id, voter) ->
@@ -267,7 +288,8 @@
267
288
(Trainee.id_to_string viewer))
268
289
t.app_feedback_votes
269
290
in
270
Removed:
{ report with contributions; viewer_upvoted })
291
Added:
let viewer_owns = String.equal owner_id (Trainee.id_to_string viewer) in
292
Added:
{ report with author; contributions; viewer_upvoted; viewer_owns })
271
293
t.app_feedback
272
294
in
273
295
let compare left right =
@@ -276,9 +298,18 @@
276
298
in
277
299
if by_votes <> 0 then by_votes
278
300
else
279
Removed:
Int.compare
280
Removed:
(Recovery.timestamp_to_unix_seconds right.submitted_at)
281
Removed:
(Recovery.timestamp_to_unix_seconds left.submitted_at)
301
Added:
let by_time =
302
Added:
Int.compare
303
Added:
(Recovery.timestamp_to_unix_seconds right.submitted_at)
304
Added:
(Recovery.timestamp_to_unix_seconds left.submitted_at)
305
Added:
in
306
Added:
if by_time <> 0 then by_time
307
Added:
else
308
Added:
let left_owner, left_sequence = app_feedback_id_parts left in
309
Added:
let right_owner, right_sequence = app_feedback_id_parts right in
310
Added:
let by_owner = String.compare left_owner right_owner in
311
Added:
if by_owner <> 0 then by_owner
312
Added:
else Int.compare right_sequence left_sequence
282
313
in
283
314
Lwt.return (List.sort compare reports)
284
315
lib/app/repository.ml
@@ -21,6 +21,7 @@
21
21
message : string;
22
22
upvotes : int;
23
23
viewer_upvoted : bool;
24
Added:
viewer_owns : bool;
24
25
}
25
26
26
27
module type S = sig
@@ -53,7 +54,6 @@
53
54
val set_in_progress :
54
55
t -> Trainee.id -> Evidence.Workout.t option -> unit Lwt.t
55
56
56
Removed:
val save : t -> Trainee.id -> Evidence.Workout.t -> record Lwt.t
57
57
val finish_workout : t -> Trainee.id -> Evidence.Workout.t -> record Lwt.t
58
58
val find : t -> Trainee.id -> workout_id -> record option Lwt.t
59
59
val replace : t -> Trainee.id -> record -> bool Lwt.t
lib/app/repository.mli
@@ -32,8 +32,9 @@
32
32
message : string;
33
33
upvotes : int;
34
34
viewer_upvoted : bool;
35
Added:
viewer_owns : bool;
35
36
}
36
Removed:
(** A ranked application comment with its author and viewer vote state. *)
37
Added:
(** A ranked application comment with viewer vote and ownership state. *)
37
38
38
39
(** Effects run in Lwt: an adapter may talk to a database. *)
39
40
module type S = sig
@@ -81,9 +82,6 @@
81
82
(** [None] clears the slot. *)
82
83
83
84
(** {2 History} *)
84
Removed:
85
Removed:
val save : t -> Trainee.id -> Evidence.Workout.t -> record Lwt.t
86
Removed:
(** Store the workout under an identity the adapter assigns. *)
87
85
88
86
val finish_workout : t -> Trainee.id -> Evidence.Workout.t -> record Lwt.t
89
87
(** Store a finished workout and clear the in-progress slot as one unit. An
lib/app/sqlite_repo.ml
@@ -25,6 +25,11 @@
25
25
(string ->? t3 string string string)
26
26
"SELECT id, username, credential FROM trainee WHERE id = ?"
27
27
28
Added:
let next_trainee =
29
Added:
(unit ->! int)
30
Added:
"SELECT COALESCE(MAX(CAST(SUBSTR(id, 2) AS INTEGER)), 0) + 1 FROM \
31
Added:
trainee WHERE id GLOB 't[0-9]*'"
32
Added:
28
33
let update_username =
29
34
(t2 string string ->. unit) "UPDATE trainee SET username = ? WHERE id = ?"
30
35
@@ -141,10 +146,15 @@
141
146
let connect uri =
142
147
match Caqti_lwt_unix.connect_pool (Uri.of_string uri) with
143
148
| Error e -> Lwt.return (Error (e :> Caqti_error.t))
144
Removed:
| Ok pool -> (
145
Removed:
Caqti_lwt_unix.Pool.use Migrations.apply pool >>= function
146
Removed:
| Error e -> Lwt.return (Error e)
147
Removed:
| Ok () -> Lwt.return (Ok { pool; next_trainee = 1 }))
149
Added:
| Ok pool ->
150
Added:
let open Lwt_result.Syntax in
151
Added:
let* () = Caqti_lwt_unix.Pool.use Migrations.apply pool in
152
Added:
let* next_trainee =
153
Added:
Caqti_lwt_unix.Pool.use
154
Added:
(fun (module Db : Caqti_lwt.CONNECTION) -> Db.find Q.next_trainee ())
155
Added:
pool
156
Added:
in
157
Added:
Lwt_result.return { pool; next_trainee }
148
158
149
159
(* --- decoding stored workouts --- *)
150
160
@@ -279,15 +289,6 @@
279
289
280
290
(* --- history --- *)
281
291
282
Removed:
let save t id workout =
283
Removed:
let trainee = Trainee.id_to_string id in
284
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) -> Db.find Q.next_seq trainee)
285
Removed:
>>= fun seq ->
286
Removed:
let wid = Printf.sprintf "%s:w%d" trainee seq in
287
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
288
Removed:
Db.exec Q.insert_workout (wid, trainee, seq, encode workout))
289
Removed:
>|= fun () -> { Repository.id = Repository.workout_id wid; workout }
290
Removed:
291
292
(* Save a finished workout and clear the in-progress slot in one transaction,
292
293
so the two rows never disagree after a crash. Both statements run on the same
293
294
connection, checked out once, inside [with_transaction]. *)
@@ -383,6 +384,7 @@
383
384
message;
384
385
upvotes = 0;
385
386
viewer_upvoted = false;
387
Added:
viewer_owns = true;
386
388
}
387
389
388
390
let app_feedback t ~viewer =
@@ -410,6 +412,7 @@
410
412
message;
411
413
upvotes;
412
414
viewer_upvoted = List.mem (trainee, seq) voted;
415
Added:
viewer_owns = String.equal trainee (Trainee.id_to_string viewer);
413
416
})
414
417
rows
415
418
test/test_service.ml
@@ -658,6 +658,26 @@
658
658
Alcotest.(check int)
659
659
"bob sees the same reports" 2
660
660
(List.length (run (S.app_feedback s bob))) );
661
Added:
( "application feedback ownership survives an author rename",
662
Added:
`Quick,
663
Added:
fun () ->
664
Added:
let s, alice = fixture () in
665
Added:
let _ =
666
Added:
ok
667
Added:
(run
668
Added:
(S.record_app_feedback s alice ~submitted_at:(day 1)
669
Added:
~message:"Before rename"))
670
Added:
in
671
Added:
let _ = ok (run (S.change_username s alice ~username:"athlete")) in
672
Added:
match run (S.app_feedback s alice) with
673
Added:
| [ report ] ->
674
Added:
Alcotest.(check string)
675
Added:
"current author name" "athlete" report.author;
676
Added:
Alcotest.(check bool)
677
Added:
"viewer still owns report" true report.viewer_owns
678
Added:
| reports ->
679
Added:
Alcotest.failf "expected one report, got %d" (List.length reports)
680
Added:
);
661
681
( "application feedback is ranked and supports cross-user votes",
662
682
`Quick,
663
683
fun () ->
@@ -718,6 +738,57 @@
718
738
Alcotest.(check int) "upvote count" 1 voted_bob.Repository.upvotes;
719
739
Alcotest.(check bool)
720
740
"viewer vote state" true voted_bob.Repository.viewer_upvoted );
741
Added:
( "editing application feedback to a blank message is refused",
742
Added:
`Quick,
743
Added:
fun () ->
744
Added:
let s, alice = fixture () in
745
Added:
let report =
746
Added:
ok
747
Added:
(run
748
Added:
(S.record_app_feedback s alice ~submitted_at:(day 1)
749
Added:
~message:"Original"))
750
Added:
in
751
Added:
match
752
Added:
run
753
Added:
(S.edit_app_feedback s alice report.Repository.feedback_id
754
Added:
~message:" ")
755
Added:
with
756
Added:
| Error `Empty_message -> ()
757
Added:
| Error `Unknown_feedback -> Alcotest.fail "feedback must still exist"
758
Added:
| Ok () -> Alcotest.fail "expected a blank edit to be refused" );
759
Added:
( "removed application feedback identities are not reused",
760
Added:
`Quick,
761
Added:
fun () ->
762
Added:
let s, alice = fixture () in
763
Added:
let first =
764
Added:
ok
765
Added:
(run
766
Added:
(S.record_app_feedback s alice ~submitted_at:(day 1)
767
Added:
~message:"First"))
768
Added:
in
769
Added:
let second =
770
Added:
ok
771
Added:
(run
772
Added:
(S.record_app_feedback s alice ~submitted_at:(day 2)
773
Added:
~message:"Second"))
774
Added:
in
775
Added:
Alcotest.(check bool)
776
Added:
"first removal succeeds" true
777
Added:
(run (S.remove_app_feedback s alice first.Repository.feedback_id));
778
Added:
let third =
779
Added:
ok
780
Added:
(run
781
Added:
(S.record_app_feedback s alice ~submitted_at:(day 3)
782
Added:
~message:"Third"))
783
Added:
in
784
Added:
Alcotest.(check bool)
785
Added:
"new identity differs from the surviving identity" false
786
Added:
(String.equal
787
Added:
(Repository.app_feedback_id_to_string second.feedback_id)
788
Added:
(Repository.app_feedback_id_to_string third.feedback_id));
789
Added:
Alcotest.(check string)
790
Added:
"sequence does not rewind" "t1:3"
791
Added:
(Repository.app_feedback_id_to_string third.feedback_id) );
721
792
( "application feedback CRUD is owner-scoped",
722
793
`Quick,
723
794
fun () ->
test/test_sqlite_repo.ml
@@ -75,6 +75,31 @@
75
75
Alcotest.(check int)
76
76
"history persisted" 1
77
77
(List.length (run (S.history s trainee_id)))) );
78
Added:
( "a new trainee gets a fresh identity after reconnect",
79
Added:
`Quick,
80
Added:
fun () ->
81
Added:
let path, uri = temp_uri () in
82
Added:
Fun.protect
83
Added:
~finally:(fun () -> cleanup path)
84
Added:
(fun () ->
85
Added:
let first_id =
86
Added:
let repo = connect uri in
87
Added:
let s = S.make ~repo in
88
Added:
let trainee =
89
Added:
ok (run (S.register s ~username:"alice" ~password:"first"))
90
Added:
in
91
Added:
Trainee.id_to_string trainee.Trainee.id
92
Added:
in
93
Added:
let repo = connect uri in
94
Added:
let s = S.make ~repo in
95
Added:
let second =
96
Added:
ok (run (S.register s ~username:"bobby" ~password:"second"))
97
Added:
in
98
Added:
let second_id = Trainee.id_to_string second.Trainee.id in
99
Added:
Alcotest.(check bool)
100
Added:
"identity is not reused" false
101
Added:
(String.equal first_id second_id);
102
Added:
Alcotest.(check string) "sequence continues" "t2" second_id) );
78
103
( "the workout in progress is durable and per-trainee",
79
104
`Quick,
80
105
fun () ->