[OCaml] High Intensity Training Online
1
(* Per-trainee mutable state, held in a hashtable keyed by trainee id. *)
2
type trainee_state = {
3
mutable active : Repository.routine_id option;
4
mutable current : Evidence.Workout.t option;
5
mutable stored : Repository.record list; (* most recent first *)
6
mutable feedback : Evidence.Feedback.t list; (* most recent first *)
7
mutable next_id : int;
8
mutable next_app_feedback : int;
9
}
10
11
type t = {
12
mutable trainees : Trainee.t list;
13
states : (string, trainee_state) Hashtbl.t;
14
mutable app_feedback : (Trainee.id * Repository.app_feedback) list;
15
mutable app_feedback_votes : (Repository.app_feedback_id * Trainee.id) list;
16
mutable next_trainee : int;
17
}
18
19
let create () =
20
{
21
trainees = [];
22
states = Hashtbl.create 16;
23
app_feedback = [];
24
app_feedback_votes = [];
25
next_trainee = 1;
26
}
27
28
let state t id =
29
let key = Trainee.id_to_string id in
30
match Hashtbl.find_opt t.states key with
31
| Some s -> s
32
| None ->
33
let s =
34
{
35
active = None;
36
current = None;
37
stored = [];
38
feedback = [];
39
next_id = 1;
40
next_app_feedback = 1;
41
}
42
in
43
Hashtbl.replace t.states key s;
44
s
45
46
let create_trainee t ~(username : Trainee.username) ~credential =
47
match
48
List.find_opt
49
(fun (tr : Trainee.t) ->
50
String.equal
51
(Trainee.username_to_string tr.username)
52
(Trainee.username_to_string username))
53
t.trainees
54
with
55
| Some _ -> Lwt.return (Error `Username_taken)
56
| None ->
57
let id = Trainee.id (Printf.sprintf "t%d" t.next_trainee) in
58
t.next_trainee <- t.next_trainee + 1;
59
let trainee = { Trainee.id; username; credential } in
60
t.trainees <- trainee :: t.trainees;
61
Lwt.return (Ok trainee)
62
63
let find_trainee_by_username t (username : Trainee.username) =
64
Lwt.return
65
(List.find_opt
66
(fun (tr : Trainee.t) ->
67
String.equal
68
(Trainee.username_to_string tr.username)
69
(Trainee.username_to_string username))
70
t.trainees)
71
72
let find_trainee t id =
73
Lwt.return
74
(List.find_opt
75
(fun (tr : Trainee.t) ->
76
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
77
t.trainees)
78
79
let replace_trainee t (updated : Trainee.t) =
80
t.trainees <-
81
List.map
82
(fun (tr : Trainee.t) ->
83
if
84
String.equal
85
(Trainee.id_to_string tr.id)
86
(Trainee.id_to_string updated.id)
87
then updated
88
else tr)
89
t.trainees
90
91
let update_username t id (username : Trainee.username) =
92
match
93
List.find_opt
94
(fun (tr : Trainee.t) ->
95
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
96
t.trainees
97
with
98
| None -> Lwt.return (Error `Username_taken)
99
| Some current ->
100
let taken =
101
List.exists
102
(fun (tr : Trainee.t) ->
103
(not
104
(String.equal
105
(Trainee.id_to_string tr.id)
106
(Trainee.id_to_string id)))
107
&& String.equal
108
(Trainee.username_to_string tr.username)
109
(Trainee.username_to_string username))
110
t.trainees
111
in
112
if taken then Lwt.return (Error `Username_taken)
113
else begin
114
let updated = { current with Trainee.username } in
115
replace_trainee t updated;
116
Lwt.return (Ok updated)
117
end
118
119
let update_credential t id credential =
120
match
121
List.find_opt
122
(fun (tr : Trainee.t) ->
123
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
124
t.trainees
125
with
126
| None -> Lwt.return None
127
| Some current ->
128
let updated = { current with Trainee.credential } in
129
replace_trainee t updated;
130
Lwt.return (Some updated)
131
132
let list_routines _ = Catalog.routines
133
let find_routine _ id = Catalog.find id
134
let active_routine t id = Lwt.return (state t id).active
135
136
let set_active_routine t id routine =
137
(state t id).active <- Some routine;
138
Lwt.return_unit
139
140
let in_progress t id = Lwt.return (state t id).current
141
142
let set_in_progress t id workout =
143
(state t id).current <- workout;
144
Lwt.return_unit
145
146
(* Store the finished workout and clear the in-progress slot together. In
147
memory this is a single synchronous update, so it cannot tear. *)
148
let finish_workout t id workout =
149
let s = state t id in
150
let wid = Repository.workout_id (Printf.sprintf "w%d" s.next_id) in
151
let record = { Repository.id = wid; workout } in
152
s.next_id <- s.next_id + 1;
153
s.stored <- record :: s.stored;
154
s.current <- None;
155
Lwt.return record
156
157
let equal_id (a : Repository.workout_id) (b : Repository.workout_id) =
158
String.equal (a :> string) (b :> string)
159
160
let find t id wid =
161
let s = state t id in
162
Lwt.return (List.find_opt (fun r -> equal_id r.Repository.id wid) s.stored)
163
164
let replace t id record =
165
let s = state t id in
166
if
167
not
168
(List.exists
169
(fun r -> equal_id r.Repository.id record.Repository.id)
170
s.stored)
171
then Lwt.return false
172
else begin
173
s.stored <-
174
List.map
175
(fun existing ->
176
if equal_id existing.Repository.id record.Repository.id then record
177
else existing)
178
s.stored;
179
Lwt.return true
180
end
181
182
let log t id =
183
let s = state t id in
184
Lwt.return
185
(List.fold_left
186
(fun log record -> Evidence.Log.add log record.Repository.workout)
187
Evidence.Log.empty (List.rev s.stored))
188
189
let history t id = Lwt.return (state t id).stored
190
191
let save_feedback t id report =
192
let s = state t id in
193
s.feedback <- report :: s.feedback;
194
Lwt.return_unit
195
196
let feedback t id = Lwt.return (state t id).feedback
197
198
let save_app_feedback t id ~submitted_at ~message =
199
let author =
200
match
201
List.find_opt
202
(fun (trainee : Trainee.t) ->
203
String.equal
204
(Trainee.id_to_string trainee.id)
205
(Trainee.id_to_string id))
206
t.trainees
207
with
208
| Some trainee -> Trainee.username_to_string trainee.username
209
| None -> ""
210
in
211
let contributions =
212
1
213
+ List.fold_left
214
(fun count (owner, _) ->
215
if String.equal (Trainee.id_to_string owner) (Trainee.id_to_string id)
216
then count + 1
217
else count)
218
0 t.app_feedback
219
in
220
let s = state t id in
221
let feedback_id =
222
Repository.app_feedback_id
223
(Printf.sprintf "%s:%d" (Trainee.id_to_string id) s.next_app_feedback)
224
in
225
s.next_app_feedback <- s.next_app_feedback + 1;
226
let report =
227
Repository.
228
{
229
feedback_id;
230
author;
231
contributions;
232
submitted_at;
233
message;
234
upvotes = 0;
235
viewer_upvoted = false;
236
viewer_owns = true;
237
}
238
in
239
t.app_feedback <- (id, report) :: t.app_feedback;
240
Lwt.return report
241
242
let app_feedback_id_parts report =
243
let raw =
244
Repository.app_feedback_id_to_string report.Repository.feedback_id
245
in
246
match String.rindex_opt raw ':' with
247
| None -> (raw, 0)
248
| Some separator ->
249
let owner = String.sub raw 0 separator in
250
let sequence =
251
String.sub raw (separator + 1) (String.length raw - separator - 1)
252
|> int_of_string_opt |> Option.value ~default:0
253
in
254
(owner, sequence)
255
256
let app_feedback t ~viewer =
257
let reports =
258
List.map
259
(fun (owner, report) ->
260
let owner_id = Trainee.id_to_string owner in
261
let contributions =
262
List.fold_left
263
(fun count (candidate, _) ->
264
if String.equal owner_id (Trainee.id_to_string candidate) then
265
count + 1
266
else count)
267
0 t.app_feedback
268
in
269
let author =
270
match
271
List.find_opt
272
(fun (trainee : Trainee.t) ->
273
String.equal owner_id (Trainee.id_to_string trainee.id))
274
t.trainees
275
with
276
| Some trainee -> Trainee.username_to_string trainee.username
277
| None -> report.Repository.author
278
in
279
let viewer_upvoted =
280
List.exists
281
(fun (feedback_id, voter) ->
282
String.equal
283
(Repository.app_feedback_id_to_string feedback_id)
284
(Repository.app_feedback_id_to_string
285
report.Repository.feedback_id)
286
&& String.equal
287
(Trainee.id_to_string voter)
288
(Trainee.id_to_string viewer))
289
t.app_feedback_votes
290
in
291
let viewer_owns = String.equal owner_id (Trainee.id_to_string viewer) in
292
{ report with author; contributions; viewer_upvoted; viewer_owns })
293
t.app_feedback
294
in
295
let compare left right =
296
let by_votes =
297
Int.compare right.Repository.upvotes left.Repository.upvotes
298
in
299
if by_votes <> 0 then by_votes
300
else
301
let by_time =
302
Int.compare
303
(Recovery.timestamp_to_unix_seconds right.submitted_at)
304
(Recovery.timestamp_to_unix_seconds left.submitted_at)
305
in
306
if by_time <> 0 then by_time
307
else
308
let left_owner, left_sequence = app_feedback_id_parts left in
309
let right_owner, right_sequence = app_feedback_id_parts right in
310
let by_owner = String.compare left_owner right_owner in
311
if by_owner <> 0 then by_owner
312
else Int.compare right_sequence left_sequence
313
in
314
Lwt.return (List.sort compare reports)
315
316
let upvote_app_feedback t ~voter feedback_id =
317
match
318
List.find_opt
319
(fun (_, report) ->
320
String.equal
321
(Repository.app_feedback_id_to_string report.Repository.feedback_id)
322
(Repository.app_feedback_id_to_string feedback_id))
323
t.app_feedback
324
with
325
| None -> Lwt.return false
326
| Some (owner, _)
327
when String.equal (Trainee.id_to_string owner) (Trainee.id_to_string voter)
328
->
329
Lwt.return false
330
| Some (_, report) ->
331
if
332
List.exists
333
(fun (voted_feedback, existing_voter) ->
334
String.equal
335
(Repository.app_feedback_id_to_string voted_feedback)
336
(Repository.app_feedback_id_to_string feedback_id)
337
&& String.equal
338
(Trainee.id_to_string existing_voter)
339
(Trainee.id_to_string voter))
340
t.app_feedback_votes
341
then Lwt.return false
342
else begin
343
t.app_feedback_votes <- (feedback_id, voter) :: t.app_feedback_votes;
344
t.app_feedback <-
345
List.map
346
(fun (owner, current) ->
347
if
348
String.equal
349
(Repository.app_feedback_id_to_string
350
current.Repository.feedback_id)
351
(Repository.app_feedback_id_to_string
352
report.Repository.feedback_id)
353
then (owner, { current with upvotes = current.upvotes + 1 })
354
else (owner, current))
355
t.app_feedback;
356
Lwt.return true
357
end
358
359
let update_app_feedback t ~author id ~message =
360
let author_id = Trainee.id_to_string author in
361
let updated = ref false in
362
t.app_feedback <-
363
List.map
364
(fun (owner, report) ->
365
if
366
String.equal (Trainee.id_to_string owner) author_id
367
&& String.equal
368
(Repository.app_feedback_id_to_string
369
report.Repository.feedback_id)
370
(Repository.app_feedback_id_to_string id)
371
then begin
372
updated := true;
373
(owner, { report with message })
374
end
375
else (owner, report))
376
t.app_feedback;
377
Lwt.return !updated
378
379
let delete_app_feedback t ~author id =
380
let author_id = Trainee.id_to_string author in
381
let owned (owner, report) =
382
String.equal (Trainee.id_to_string owner) author_id
383
&& String.equal
384
(Repository.app_feedback_id_to_string report.Repository.feedback_id)
385
(Repository.app_feedback_id_to_string id)
386
in
387
let removed = List.exists owned t.app_feedback in
388
if removed then begin
389
t.app_feedback <- List.filter (fun item -> not (owned item)) t.app_feedback;
390
t.app_feedback_votes <-
391
List.filter
392
(fun (feedback_id, _) ->
393
not
394
(String.equal
395
(Repository.app_feedback_id_to_string feedback_id)
396
(Repository.app_feedback_id_to_string id)))
397
t.app_feedback_votes
398
end;
399
Lwt.return removed
400