[OCaml] High Intensity Training Online
refactor Simplify web boundaries
Enforce the presenter boundary with a separate library and split the web layer along feature seams. Keep test-only persistence code outside the production library.
Changed files
- ARCHITECTURE.org
- lib/core/evidence.mli
- lib/persistence/memory_repo.ml
- lib/persistence/memory_repo.mli
- lib/presenter/dune
- lib/presenter/page_kit.ml
- lib/presenter/page_shell.ml
- lib/presenter/pages.ml
- lib/presenter/pages.mli
- lib/presenter/pages_app_feedback.ml
- lib/presenter/pages_auth.ml
- lib/presenter/pages_error.ml
- lib/presenter/pages_import.ml
- lib/presenter/pages_logbook.ml
- lib/presenter/pages_profile.ml
- lib/presenter/pages_routine.ml
- lib/presenter/pages_settings.ml
- lib/presenter/pages_workout.ml
- lib/presenter/routes.ml
- lib/presenter/view_model.ml
- lib/web/dune
- lib/web/handlers.ml
- lib/web/handlers_app_feedback.ml
- lib/web/handlers_assets.ml
- lib/web/handlers_auth.ml
- lib/web/handlers_current_workout.ml
- lib/web/handlers_import.ml
- lib/web/handlers_kit.ml
- lib/web/handlers_logbook.ml
- lib/web/handlers_overview.ml
- lib/web/handlers_profile.ml
- lib/web/handlers_settings.ml
- test/dune
- test/memory_repo.ml
- test/memory_repo.mli
- test/test_architecture.ml
- test/test_hito.ml
- test/test_import_repo.ml
ARCHITECTURE.org
@@ -635,3 +635,25 @@
635
635
- HD2 consolidation, once sourced.
636
636
- A separate session store, for concurrency beyond local use.
637
637
- A native client, which would sit on =hito.app= beside the web tier.
638
Added:
639
Added:
* Software boundaries
640
Added:
641
Added:
The build graph enforces the dependency rule. =hito.core= has no library
642
Added:
dependencies. =hito.app= depends only on =hito.core= and =lwt=. Persistence
643
Added:
adapters depend on the app and core. =hito.web= depends inward on the app and
644
Added:
core, and on =hito.presenter= for rendering.
645
Added:
646
Added:
=hito.presenter= contains routes, view models, and pages. It depends only on
647
Added:
Dream and dream-html. It cannot name a core entity, a service, or a repository
648
Added:
adapter. This compiler boundary replaces a source-scanning architecture test.
649
Added:
650
Added:
Inside each tier, the large renderer and controller are split into feature
651
Added:
modules behind a stable façade. =Pages= re-exports the per-feature page modules
652
Added:
(=Pages_auth=, =Pages_routine=, =Pages_workout=, =Pages_logbook=,
653
Added:
=Pages_app_feedback=, =Pages_profile=, =Pages_settings=, =Pages_import=), which
654
Added:
share =Page_kit= and =Page_shell=. =Handlers.Make= instantiates one
655
Added:
=Handlers_kit= and threads that single instance through a functor per feature
656
Added:
(=Handlers_auth=, =Handlers_overview=, =Handlers_current_workout=,
657
Added:
=Handlers_logbook=, =Handlers_app_feedback=, =Handlers_profile=,
658
Added:
=Handlers_settings=, =Handlers_import=), so their =t=, =Service=, and =Present=
659
Added:
types stay identical. The =Pages= and =Handlers.Make= interfaces do not change.
lib/core/evidence.mli
@@ -87,7 +87,10 @@
87
87
val signals : t -> signal list
88
88
end
89
89
90
Removed:
(** A performed or in-progress prescribed workout. *)
90
Added:
(** A prescribed workout as observed through its whole life. A workout may be
91
Added:
edited before or after it ends. The log records what happened, so
92
Added:
[add_stimulus], [replace_stimulus], and [record_at] deliberately accept an
93
Added:
ended workout as well as an in-progress workout. *)
91
94
module Workout : sig
92
95
type t
93
96
type shape = As_single | As_pair
lib/persistence/memory_repo.ml
@@ -1,495 +0,0 @@
1
Removed:
open Hito_app
2
Removed:
3
Removed:
(* Per-trainee mutable state, held in a hashtable keyed by trainee id. *)
4
Removed:
type trainee_state = {
5
Removed:
mutable active : Repository.routine_id option;
6
Removed:
mutable current : Evidence.Workout.t option;
7
Removed:
mutable stored : Repository.record list; (* most recent first *)
8
Removed:
mutable feedback : Evidence.Feedback.t list; (* most recent first *)
9
Removed:
mutable batches : Workout_import.batch list;
10
Removed:
(* insertion order, newest first *)
11
Removed:
mutable records : Repository.imported_record list; (* newest ended_at first *)
12
Removed:
mutable next_id : int;
13
Removed:
mutable next_app_feedback : int;
14
Removed:
}
15
Removed:
16
Removed:
type t = {
17
Removed:
mutable trainees : Trainee.t list;
18
Removed:
states : (string, trainee_state) Hashtbl.t;
19
Removed:
mutable app_feedback : (Trainee.id * Repository.app_feedback) list;
20
Removed:
mutable app_feedback_votes : (Repository.app_feedback_id * Trainee.id) list;
21
Removed:
mutable next_trainee : int;
22
Removed:
}
23
Removed:
24
Removed:
let create () =
25
Removed:
{
26
Removed:
trainees = [];
27
Removed:
states = Hashtbl.create 16;
28
Removed:
app_feedback = [];
29
Removed:
app_feedback_votes = [];
30
Removed:
next_trainee = 1;
31
Removed:
}
32
Removed:
33
Removed:
let state t id =
34
Removed:
let key = Trainee.id_to_string id in
35
Removed:
match Hashtbl.find_opt t.states key with
36
Removed:
| Some s -> s
37
Removed:
| None ->
38
Removed:
let s =
39
Removed:
{
40
Removed:
active = None;
41
Removed:
current = None;
42
Removed:
stored = [];
43
Removed:
feedback = [];
44
Removed:
batches = [];
45
Removed:
records = [];
46
Removed:
next_id = 1;
47
Removed:
next_app_feedback = 1;
48
Removed:
}
49
Removed:
in
50
Removed:
Hashtbl.replace t.states key s;
51
Removed:
s
52
Removed:
53
Removed:
let create_trainee t ~(username : Trainee.username) ~credential =
54
Removed:
match
55
Removed:
List.find_opt
56
Removed:
(fun (tr : Trainee.t) ->
57
Removed:
String.equal
58
Removed:
(Trainee.username_to_string tr.username)
59
Removed:
(Trainee.username_to_string username))
60
Removed:
t.trainees
61
Removed:
with
62
Removed:
| Some _ -> Lwt.return (Error `Username_taken)
63
Removed:
| None ->
64
Removed:
let id = Trainee.id (Printf.sprintf "t%d" t.next_trainee) in
65
Removed:
t.next_trainee <- t.next_trainee + 1;
66
Removed:
let trainee = { Trainee.id; username; credential } in
67
Removed:
t.trainees <- trainee :: t.trainees;
68
Removed:
Lwt.return (Ok trainee)
69
Removed:
70
Removed:
let find_trainee_by_username t (username : Trainee.username) =
71
Removed:
Lwt.return
72
Removed:
(List.find_opt
73
Removed:
(fun (tr : Trainee.t) ->
74
Removed:
String.equal
75
Removed:
(Trainee.username_to_string tr.username)
76
Removed:
(Trainee.username_to_string username))
77
Removed:
t.trainees)
78
Removed:
79
Removed:
let find_trainee t id =
80
Removed:
Lwt.return
81
Removed:
(List.find_opt
82
Removed:
(fun (tr : Trainee.t) ->
83
Removed:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
84
Removed:
t.trainees)
85
Removed:
86
Removed:
let replace_trainee t (updated : Trainee.t) =
87
Removed:
t.trainees <-
88
Removed:
List.map
89
Removed:
(fun (tr : Trainee.t) ->
90
Removed:
if
91
Removed:
String.equal
92
Removed:
(Trainee.id_to_string tr.id)
93
Removed:
(Trainee.id_to_string updated.id)
94
Removed:
then updated
95
Removed:
else tr)
96
Removed:
t.trainees
97
Removed:
98
Removed:
let update_username t id (username : Trainee.username) =
99
Removed:
match
100
Removed:
List.find_opt
101
Removed:
(fun (tr : Trainee.t) ->
102
Removed:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
103
Removed:
t.trainees
104
Removed:
with
105
Removed:
| None -> Lwt.return (Error `Username_taken)
106
Removed:
| Some current ->
107
Removed:
let taken =
108
Removed:
List.exists
109
Removed:
(fun (tr : Trainee.t) ->
110
Removed:
(not
111
Removed:
(String.equal
112
Removed:
(Trainee.id_to_string tr.id)
113
Removed:
(Trainee.id_to_string id)))
114
Removed:
&& String.equal
115
Removed:
(Trainee.username_to_string tr.username)
116
Removed:
(Trainee.username_to_string username))
117
Removed:
t.trainees
118
Removed:
in
119
Removed:
if taken then Lwt.return (Error `Username_taken)
120
Removed:
else begin
121
Removed:
let updated = { current with Trainee.username } in
122
Removed:
replace_trainee t updated;
123
Removed:
Lwt.return (Ok updated)
124
Removed:
end
125
Removed:
126
Removed:
let update_credential t id credential =
127
Removed:
match
128
Removed:
List.find_opt
129
Removed:
(fun (tr : Trainee.t) ->
130
Removed:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
131
Removed:
t.trainees
132
Removed:
with
133
Removed:
| None -> Lwt.return None
134
Removed:
| Some current ->
135
Removed:
let updated = { current with Trainee.credential } in
136
Removed:
replace_trainee t updated;
137
Removed:
Lwt.return (Some updated)
138
Removed:
139
Removed:
let list_routines _ = Catalog.routines
140
Removed:
let find_routine _ id = Catalog.find id
141
Removed:
let active_routine t id = Lwt.return (state t id).active
142
Removed:
143
Removed:
let set_active_routine t id routine =
144
Removed:
(state t id).active <- Some routine;
145
Removed:
Lwt.return_unit
146
Removed:
147
Removed:
let in_progress t id = Lwt.return (state t id).current
148
Removed:
149
Removed:
let set_in_progress t id workout =
150
Removed:
(state t id).current <- workout;
151
Removed:
Lwt.return_unit
152
Removed:
153
Removed:
(* Store the finished workout and clear the in-progress slot together. In
154
Removed:
memory this is a single synchronous update, so it cannot tear. *)
155
Removed:
let finish_workout t id workout =
156
Removed:
let s = state t id in
157
Removed:
let wid = Repository.workout_id (Printf.sprintf "w%d" s.next_id) in
158
Removed:
let record = { Repository.id = wid; workout } in
159
Removed:
s.next_id <- s.next_id + 1;
160
Removed:
s.stored <- record :: s.stored;
161
Removed:
s.current <- None;
162
Removed:
Lwt.return record
163
Removed:
164
Removed:
let equal_id (a : Repository.workout_id) (b : Repository.workout_id) =
165
Removed:
String.equal (a :> string) (b :> string)
166
Removed:
167
Removed:
let find t id wid =
168
Removed:
let s = state t id in
169
Removed:
Lwt.return (List.find_opt (fun r -> equal_id r.Repository.id wid) s.stored)
170
Removed:
171
Removed:
let replace t id record =
172
Removed:
let s = state t id in
173
Removed:
if
174
Removed:
not
175
Removed:
(List.exists
176
Removed:
(fun r -> equal_id r.Repository.id record.Repository.id)
177
Removed:
s.stored)
178
Removed:
then Lwt.return false
179
Removed:
else begin
180
Removed:
s.stored <-
181
Removed:
List.map
182
Removed:
(fun existing ->
183
Removed:
if equal_id existing.Repository.id record.Repository.id then record
184
Removed:
else existing)
185
Removed:
s.stored;
186
Removed:
Lwt.return true
187
Removed:
end
188
Removed:
189
Removed:
let log t id =
190
Removed:
let s = state t id in
191
Removed:
Lwt.return
192
Removed:
(List.fold_left
193
Removed:
(fun log record -> Evidence.Log.add log record.Repository.workout)
194
Removed:
Evidence.Log.empty (List.rev s.stored))
195
Removed:
196
Removed:
let history t id = Lwt.return (state t id).stored
197
Removed:
198
Removed:
let save_feedback t id report =
199
Removed:
let s = state t id in
200
Removed:
s.feedback <- report :: s.feedback;
201
Removed:
Lwt.return_unit
202
Removed:
203
Removed:
let feedback t id = Lwt.return (state t id).feedback
204
Removed:
205
Removed:
let save_app_feedback t id ~submitted_at ~message =
206
Removed:
let author =
207
Removed:
match
208
Removed:
List.find_opt
209
Removed:
(fun (trainee : Trainee.t) ->
210
Removed:
String.equal
211
Removed:
(Trainee.id_to_string trainee.id)
212
Removed:
(Trainee.id_to_string id))
213
Removed:
t.trainees
214
Removed:
with
215
Removed:
| Some trainee -> Trainee.username_to_string trainee.username
216
Removed:
| None -> ""
217
Removed:
in
218
Removed:
let contributions =
219
Removed:
1
220
Removed:
+ List.fold_left
221
Removed:
(fun count (owner, _) ->
222
Removed:
if String.equal (Trainee.id_to_string owner) (Trainee.id_to_string id)
223
Removed:
then count + 1
224
Removed:
else count)
225
Removed:
0 t.app_feedback
226
Removed:
in
227
Removed:
let s = state t id in
228
Removed:
let feedback_id =
229
Removed:
Repository.app_feedback_id
230
Removed:
(Printf.sprintf "%s:%d" (Trainee.id_to_string id) s.next_app_feedback)
231
Removed:
in
232
Removed:
s.next_app_feedback <- s.next_app_feedback + 1;
233
Removed:
let report =
234
Removed:
Repository.
235
Removed:
{
236
Removed:
feedback_id;
237
Removed:
author;
238
Removed:
contributions;
239
Removed:
submitted_at;
240
Removed:
message;
241
Removed:
upvotes = 0;
242
Removed:
viewer_upvoted = false;
243
Removed:
viewer_owns = true;
244
Removed:
}
245
Removed:
in
246
Removed:
t.app_feedback <- (id, report) :: t.app_feedback;
247
Removed:
Lwt.return report
248
Removed:
249
Removed:
let app_feedback_id_parts report =
250
Removed:
let raw =
251
Removed:
Repository.app_feedback_id_to_string report.Repository.feedback_id
252
Removed:
in
253
Removed:
match String.rindex_opt raw ':' with
254
Removed:
| None -> (raw, 0)
255
Removed:
| Some separator ->
256
Removed:
let owner = String.sub raw 0 separator in
257
Removed:
let sequence =
258
Removed:
String.sub raw (separator + 1) (String.length raw - separator - 1)
259
Removed:
|> int_of_string_opt |> Option.value ~default:0
260
Removed:
in
261
Removed:
(owner, sequence)
262
Removed:
263
Removed:
let app_feedback t ~viewer =
264
Removed:
let reports =
265
Removed:
List.map
266
Removed:
(fun (owner, report) ->
267
Removed:
let owner_id = Trainee.id_to_string owner in
268
Removed:
let contributions =
269
Removed:
List.fold_left
270
Removed:
(fun count (candidate, _) ->
271
Removed:
if String.equal owner_id (Trainee.id_to_string candidate) then
272
Removed:
count + 1
273
Removed:
else count)
274
Removed:
0 t.app_feedback
275
Removed:
in
276
Removed:
let author =
277
Removed:
match
278
Removed:
List.find_opt
279
Removed:
(fun (trainee : Trainee.t) ->
280
Removed:
String.equal owner_id (Trainee.id_to_string trainee.id))
281
Removed:
t.trainees
282
Removed:
with
283
Removed:
| Some trainee -> Trainee.username_to_string trainee.username
284
Removed:
| None -> report.Repository.author
285
Removed:
in
286
Removed:
let viewer_upvoted =
287
Removed:
List.exists
288
Removed:
(fun (feedback_id, voter) ->
289
Removed:
String.equal
290
Removed:
(Repository.app_feedback_id_to_string feedback_id)
291
Removed:
(Repository.app_feedback_id_to_string
292
Removed:
report.Repository.feedback_id)
293
Removed:
&& String.equal
294
Removed:
(Trainee.id_to_string voter)
295
Removed:
(Trainee.id_to_string viewer))
296
Removed:
t.app_feedback_votes
297
Removed:
in
298
Removed:
let viewer_owns = String.equal owner_id (Trainee.id_to_string viewer) in
299
Removed:
{ report with author; contributions; viewer_upvoted; viewer_owns })
300
Removed:
t.app_feedback
301
Removed:
in
302
Removed:
let compare left right =
303
Removed:
let by_votes =
304
Removed:
Int.compare right.Repository.upvotes left.Repository.upvotes
305
Removed:
in
306
Removed:
if by_votes <> 0 then by_votes
307
Removed:
else
308
Removed:
let by_time =
309
Removed:
Int.compare
310
Removed:
(Recovery.timestamp_to_unix_seconds right.submitted_at)
311
Removed:
(Recovery.timestamp_to_unix_seconds left.submitted_at)
312
Removed:
in
313
Removed:
if by_time <> 0 then by_time
314
Removed:
else
315
Removed:
let left_owner, left_sequence = app_feedback_id_parts left in
316
Removed:
let right_owner, right_sequence = app_feedback_id_parts right in
317
Removed:
let by_owner = String.compare left_owner right_owner in
318
Removed:
if by_owner <> 0 then by_owner
319
Removed:
else Int.compare right_sequence left_sequence
320
Removed:
in
321
Removed:
Lwt.return (List.sort compare reports)
322
Removed:
323
Removed:
let upvote_app_feedback t ~voter feedback_id =
324
Removed:
match
325
Removed:
List.find_opt
326
Removed:
(fun (_, report) ->
327
Removed:
String.equal
328
Removed:
(Repository.app_feedback_id_to_string report.Repository.feedback_id)
329
Removed:
(Repository.app_feedback_id_to_string feedback_id))
330
Removed:
t.app_feedback
331
Removed:
with
332
Removed:
| None -> Lwt.return false
333
Removed:
| Some (owner, _)
334
Removed:
when String.equal (Trainee.id_to_string owner) (Trainee.id_to_string voter)
335
Removed:
->
336
Removed:
Lwt.return false
337
Removed:
| Some (_, report) ->
338
Removed:
if
339
Removed:
List.exists
340
Removed:
(fun (voted_feedback, existing_voter) ->
341
Removed:
String.equal
342
Removed:
(Repository.app_feedback_id_to_string voted_feedback)
343
Removed:
(Repository.app_feedback_id_to_string feedback_id)
344
Removed:
&& String.equal
345
Removed:
(Trainee.id_to_string existing_voter)
346
Removed:
(Trainee.id_to_string voter))
347
Removed:
t.app_feedback_votes
348
Removed:
then Lwt.return false
349
Removed:
else begin
350
Removed:
t.app_feedback_votes <- (feedback_id, voter) :: t.app_feedback_votes;
351
Removed:
t.app_feedback <-
352
Removed:
List.map
353
Removed:
(fun (owner, current) ->
354
Removed:
if
355
Removed:
String.equal
356
Removed:
(Repository.app_feedback_id_to_string
357
Removed:
current.Repository.feedback_id)
358
Removed:
(Repository.app_feedback_id_to_string
359
Removed:
report.Repository.feedback_id)
360
Removed:
then (owner, { current with upvotes = current.upvotes + 1 })
361
Removed:
else (owner, current))
362
Removed:
t.app_feedback;
363
Removed:
Lwt.return true
364
Removed:
end
365
Removed:
366
Removed:
let update_app_feedback t ~author id ~message =
367
Removed:
let author_id = Trainee.id_to_string author in
368
Removed:
let updated = ref false in
369
Removed:
t.app_feedback <-
370
Removed:
List.map
371
Removed:
(fun (owner, report) ->
372
Removed:
if
373
Removed:
String.equal (Trainee.id_to_string owner) author_id
374
Removed:
&& String.equal
375
Removed:
(Repository.app_feedback_id_to_string
376
Removed:
report.Repository.feedback_id)
377
Removed:
(Repository.app_feedback_id_to_string id)
378
Removed:
then begin
379
Removed:
updated := true;
380
Removed:
(owner, { report with message })
381
Removed:
end
382
Removed:
else (owner, report))
383
Removed:
t.app_feedback;
384
Removed:
Lwt.return !updated
385
Removed:
386
Removed:
let delete_app_feedback t ~author id =
387
Removed:
let author_id = Trainee.id_to_string author in
388
Removed:
let owned (owner, report) =
389
Removed:
String.equal (Trainee.id_to_string owner) author_id
390
Removed:
&& String.equal
391
Removed:
(Repository.app_feedback_id_to_string report.Repository.feedback_id)
392
Removed:
(Repository.app_feedback_id_to_string id)
393
Removed:
in
394
Removed:
let removed = List.exists owned t.app_feedback in
395
Removed:
if removed then begin
396
Removed:
t.app_feedback <- List.filter (fun item -> not (owned item)) t.app_feedback;
397
Removed:
t.app_feedback_votes <-
398
Removed:
List.filter
399
Removed:
(fun (feedback_id, _) ->
400
Removed:
not
401
Removed:
(String.equal
402
Removed:
(Repository.app_feedback_id_to_string feedback_id)
403
Removed:
(Repository.app_feedback_id_to_string id)))
404
Removed:
t.app_feedback_votes
405
Removed:
end;
406
Removed:
Lwt.return removed
407
Removed:
408
Removed:
(* --- workout import --- *)
409
Removed:
410
Removed:
let batch_id_eq a b =
411
Removed:
String.equal
412
Removed:
(Workout_import.batch_id_to_string a)
413
Removed:
(Workout_import.batch_id_to_string b)
414
Removed:
415
Removed:
(* Upsert a batch by its identity, dropping any earlier version and prepending
416
Removed:
the new one so the list stays newest-first by insertion. *)
417
Removed:
let save_import_batch t id batch =
418
Removed:
let s = state t id in
419
Removed:
let identity = Workout_import.batch_identity batch in
420
Removed:
s.batches <-
421
Removed:
batch
422
Removed:
:: List.filter
423
Removed:
(fun b -> not (batch_id_eq (Workout_import.batch_identity b) identity))
424
Removed:
s.batches;
425
Removed:
Lwt.return_unit
426
Removed:
427
Removed:
let find_import_batch t id batch_id =
428
Removed:
let s = state t id in
429
Removed:
Lwt.return
430
Removed:
(List.find_opt
431
Removed:
(fun b -> batch_id_eq (Workout_import.batch_identity b) batch_id)
432
Removed:
s.batches)
433
Removed:
434
Removed:
(* Most recent [imported_at] first; ties broken by batch id descending, for a
435
Removed:
deterministic order that does not depend on insertion. *)
436
Removed:
let import_batches t id =
437
Removed:
let s = state t id in
438
Removed:
let compare a b =
439
Removed:
let by_time =
440
Removed:
Int.compare
441
Removed:
(Recovery.timestamp_to_unix_seconds
442
Removed:
(Workout_import.batch_imported_at b))
443
Removed:
(Recovery.timestamp_to_unix_seconds
444
Removed:
(Workout_import.batch_imported_at a))
445
Removed:
in
446
Removed:
if by_time <> 0 then by_time
447
Removed:
else
448
Removed:
String.compare
449
Removed:
(Workout_import.batch_id_to_string (Workout_import.batch_identity b))
450
Removed:
(Workout_import.batch_id_to_string (Workout_import.batch_identity a))
451
Removed:
in
452
Removed:
Lwt.return (List.stable_sort compare s.batches)
453
Removed:
454
Removed:
(* Deleting a provisional batch never touches promoted records: their lifecycle
455
Removed:
is independent. *)
456
Removed:
let delete_import_batch t id batch_id =
457
Removed:
let s = state t id in
458
Removed:
let present =
459
Removed:
List.exists
460
Removed:
(fun b -> batch_id_eq (Workout_import.batch_identity b) batch_id)
461
Removed:
s.batches
462
Removed:
in
463
Removed:
if present then
464
Removed:
s.batches <-
465
Removed:
List.filter
466
Removed:
(fun b -> not (batch_id_eq (Workout_import.batch_identity b) batch_id))
467
Removed:
s.batches;
468
Removed:
Lwt.return present
469
Removed:
470
Removed:
let workout_id_eq a b =
471
Removed:
String.equal
472
Removed:
(Workout_import.workout_id_to_string a)
473
Removed:
(Workout_import.workout_id_to_string b)
474
Removed:
475
Removed:
(* Atomic upsert keyed by workout id: a re-promotion replaces the observations
476
Removed:
and revision of the prior record for the same workout. *)
477
Removed:
let replace_imported_record t id record =
478
Removed:
let s = state t id in
479
Removed:
s.records <-
480
Removed:
record
481
Removed:
:: List.filter
482
Removed:
(fun r ->
483
Removed:
not
484
Removed:
(workout_id_eq r.Repository.workout_id record.Repository.workout_id))
485
Removed:
s.records;
486
Removed:
Lwt.return_unit
487
Removed:
488
Removed:
let imported_records t id =
489
Removed:
let s = state t id in
490
Removed:
let compare a b =
491
Removed:
Int.compare
492
Removed:
(Recovery.timestamp_to_unix_seconds b.Repository.ended_at)
493
Removed:
(Recovery.timestamp_to_unix_seconds a.Repository.ended_at)
494
Removed:
in
495
Removed:
Lwt.return (List.stable_sort compare s.records)
lib/persistence/memory_repo.mli
@@ -1,8 +0,0 @@
1
Removed:
(** In-memory {!Repository.S} for tests. Nothing survives a restart, and it is
2
Removed:
never used in production — durable storage is {!Sqlite_repo}. *)
3
Removed:
4
Removed:
open Hito_app
5
Removed:
include Repository.S
6
Removed:
7
Removed:
val create : unit -> t
8
Removed:
(** Seeded with the shared routine catalog. *)
lib/presenter/dune
@@ -0,0 +1,24 @@
1
Added:
; The presenter renders only view models and route values. It has no path to
2
Added:
; domain entities, services, or persistence adapters.
3
Added:
4
Added:
(library
5
Added:
(name hito_presenter)
6
Added:
(public_name hito.presenter)
7
Added:
(modules
8
Added:
page_kit
9
Added:
page_shell
10
Added:
pages_error
11
Added:
pages_auth
12
Added:
pages_routine
13
Added:
pages_workout
14
Added:
pages_logbook
15
Added:
pages_app_feedback
16
Added:
pages_profile
17
Added:
pages_settings
18
Added:
pages_import
19
Added:
routes
20
Added:
view_model
21
Added:
pages)
22
Added:
(preprocess
23
Added:
(pps dream-html.ppx))
24
Added:
(libraries dream dream-html))
lib/presenter/page_kit.ml
@@ -0,0 +1,30 @@
1
Added:
type page = Dream_html.node
2
Added:
3
Added:
let tag = Dream_html.std_tag
4
Added:
let void = Dream_html.void_tag
5
Added:
let class_ value = Dream_html.string_attr "class" value
6
Added:
let name value = Dream_html.string_attr "name" value
7
Added:
let value value = Dream_html.string_attr "value" value
8
Added:
let rel value = Dream_html.string_attr "rel" value
9
Added:
let type_ value = Dream_html.string_attr "type" value
10
Added:
let step value = Dream_html.string_attr "step" value
11
Added:
let id value = Dream_html.string_attr "id" value
12
Added:
let tabindex value = Dream_html.string_attr "tabindex" value
13
Added:
let required = Dream_html.attr "required"
14
Added:
let href path = Dream_html.path_attr (Dream_html.uri_attr "href") path
15
Added:
let src path = Dream_html.path_attr (Dream_html.uri_attr "src") path
16
Added:
let action path = Dream_html.path_attr (Dream_html.uri_attr "action") path
17
Added:
let post_form = Dream_html.string_attr "method" "post"
18
Added:
let flash_key = "hito.flash"
19
Added:
20
Added:
let error_text = function
21
Added:
| "error.required" -> "Enter a value."
22
Added:
| "error.expected.number" -> "Enter a valid number."
23
Added:
| "error.expected.int" -> "Enter a valid whole number."
24
Added:
| "error.reps" -> "Enter at least one repetition."
25
Added:
| "error.load" -> "Enter a finite, nonnegative load."
26
Added:
| "error.extension" -> "Select one of the offered endings."
27
Added:
| key -> key
28
Added:
29
Added:
let errors_to_text errors =
30
Added:
errors |> List.map (fun (_, key) -> error_text key) |> String.concat " "
lib/presenter/page_shell.ml
@@ -0,0 +1,233 @@
1
Added:
open Dream_html
2
Added:
open Page_kit
3
Added:
4
Added:
(* The shell. [viewer] and [request] are present on authenticated pages, which
5
Added:
then show a logout control and the username on the history link. Auth pages
6
Added:
omit both. *)
7
Added:
let theme_session_key = "hito.theme"
8
Added:
9
Added:
let html_page ?viewer ?request ?(active = "") ?(logging = false)
10
Added:
?(show_nav = false) title content =
11
Added:
let spa_client = true in
12
Added:
let theme =
13
Added:
match request with
14
Added:
| Some request -> (
15
Added:
match Dream.session_field request theme_session_key with
16
Added:
| Some "dark" -> "dark"
17
Added:
| _ -> "light")
18
Added:
| None -> "light"
19
Added:
in
20
Added:
let nav_link page path label =
21
Added:
let attrs = [ href path ] in
22
Added:
let attrs =
23
Added:
if spa_client then Dream_html.attr "data-hito-app-link" :: attrs
24
Added:
else attrs
25
Added:
in
26
Added:
let attrs =
27
Added:
if String.equal page active then
28
Added:
Dream_html.string_attr "aria-current" "page" :: attrs
29
Added:
else attrs
30
Added:
in
31
Added:
tag "a" attrs [ txt "%s" label ]
32
Added:
in
33
Added:
(* Three always-available actions. The middle slot points to the routine
34
Added:
normally and to the workout in progress while logging, so a running
35
Added:
workout stays one tap away without adding a fourth destination. The logbook
36
Added:
tab always reads "Logbook". The username lives on its own profile control. *)
37
Added:
let navigation_links () =
38
Added:
[
39
Added:
nav_link "home" Routes.home "Home";
40
Added:
(if logging then nav_link "workout" Routes.workout "Current workout"
41
Added:
else nav_link "routine" Routes.routine "Routine");
42
Added:
nav_link "logbook" Routes.logbook "Logbook";
43
Added:
]
44
Added:
in
45
Added:
(* The profile control names the signed-in trainee and opens a drop-down of
46
Added:
account actions: Profile, Settings, and Sign out. It sits in the masthead,
47
Added:
and on mobile it is the top-bar profile control the bottom nav has no room
48
Added:
for. Settings points at the profile page too — account settings live there
49
Added:
and there is no separate settings page. A <details> menu needs no client
50
Added:
script, so it works before the SPA enhancement loads. The Sign-out form is
51
Added:
nested inside and keeps its CSRF token. *)
52
Added:
let profile_area =
53
Added:
match (viewer, request) with
54
Added:
| Some (viewer : View_model.Viewer.t), Some request ->
55
Added:
let menu_link page path label =
56
Added:
let attrs = [ class_ "profile-menu-item"; href path ] in
57
Added:
let attrs = Dream_html.string_attr "role" "menuitem" :: attrs in
58
Added:
let attrs =
59
Added:
if spa_client then Dream_html.attr "data-hito-app-link" :: attrs
60
Added:
else attrs
61
Added:
in
62
Added:
let attrs =
63
Added:
if String.equal page active then
64
Added:
Dream_html.string_attr "aria-current" "page" :: attrs
65
Added:
else attrs
66
Added:
in
67
Added:
tag "a" attrs [ txt "%s" label ]
68
Added:
in
69
Added:
let summary_attrs =
70
Added:
if String.equal "profile" active || String.equal "settings" active
71
Added:
then
72
Added:
[ class_ "profile"; Dream_html.string_attr "aria-current" "page" ]
73
Added:
else [ class_ "profile" ]
74
Added:
in
75
Added:
[
76
Added:
tag "details"
77
Added:
[ class_ "profile-menu" ]
78
Added:
[
79
Added:
tag "summary" summary_attrs
80
Added:
[ txt "%s" viewer.View_model.Viewer.username ];
81
Added:
tag "div"
82
Added:
[
83
Added:
class_ "profile-menu-drawer";
84
Added:
Dream_html.string_attr "role" "menu";
85
Added:
Dream_html.string_attr "aria-label" "Profile menu";
86
Added:
]
87
Added:
[
88
Added:
menu_link "profile" Routes.profile "Profile";
89
Added:
menu_link "settings" Routes.settings "Settings";
90
Added:
menu_link "app-feedback" Routes.app_feedback "Feedback";
91
Added:
tag "form"
92
Added:
[
93
Added:
action Routes.logout;
94
Added:
post_form;
95
Added:
class_ "logout";
96
Added:
Dream_html.attr "data-hito-app-form";
97
Added:
]
98
Added:
[
99
Added:
Dream_html.csrf_tag request;
100
Added:
void "input"
101
Added:
[
102
Added:
type_ "submit";
103
Added:
class_ "profile-menu-item";
104
Added:
Dream_html.string_attr "role" "menuitem";
105
Added:
value "Sign out";
106
Added:
];
107
Added:
];
108
Added:
];
109
Added:
];
110
Added:
]
111
Added:
| _ -> []
112
Added:
in
113
Added:
let account_area = [] in
114
Added:
let primary_nav =
115
Added:
match (viewer, request) with
116
Added:
| Some (_ : View_model.Viewer.t), Some _ ->
117
Added:
[ tag "nav" [ class_ "primary-nav" ] (navigation_links ()) ]
118
Added:
| _ when show_nav ->
119
Added:
[ tag "nav" [ class_ "primary-nav" ] (navigation_links ()) ]
120
Added:
| _ -> []
121
Added:
in
122
Added:
let bottom_nav =
123
Added:
match (viewer, request) with
124
Added:
| Some (_ : View_model.Viewer.t), Some _ ->
125
Added:
[
126
Added:
tag "nav"
127
Added:
[
128
Added:
class_ "bottom-nav";
129
Added:
Dream_html.string_attr "aria-label" "Mobile navigation";
130
Added:
]
131
Added:
(navigation_links ());
132
Added:
]
133
Added:
| _ when show_nav ->
134
Added:
[
135
Added:
tag "nav"
136
Added:
[
137
Added:
class_ "bottom-nav";
138
Added:
Dream_html.string_attr "aria-label" "Mobile navigation";
139
Added:
]
140
Added:
(navigation_links ());
141
Added:
]
142
Added:
| _ -> []
143
Added:
in
144
Added:
let flash_notice =
145
Added:
match request with
146
Added:
| Some request -> (
147
Added:
match Dream.session_field request flash_key with
148
Added:
| Some message ->
149
Added:
[
150
Added:
tag "div"
151
Added:
[
152
Added:
class_ "toast";
153
Added:
Dream_html.attr "data-hito-toast";
154
Added:
Dream_html.string_attr "role" "status";
155
Added:
Dream_html.string_attr "aria-live" "polite";
156
Added:
]
157
Added:
[ txt "%s" message ];
158
Added:
]
159
Added:
| None -> [])
160
Added:
| None -> []
161
Added:
in
162
Added:
tag "html"
163
Added:
[
164
Added:
Dream_html.string_attr "lang" "en";
165
Added:
Dream_html.string_attr "data-theme" "%s" theme;
166
Added:
]
167
Added:
[
168
Added:
tag "head" []
169
Added:
[
170
Added:
tag "title" [] [ txt "Hito — %s" title ];
171
Added:
void "meta" [ Dream_html.string_attr "charset" "utf-8" ];
172
Added:
void "meta"
173
Added:
[
174
Added:
Dream_html.string_attr "name" "viewport";
175
Added:
Dream_html.string_attr "content"
176
Added:
"width=device-width,initial-scale=1";
177
Added:
];
178
Added:
void "link" [ rel "stylesheet"; href Routes.stylesheet ];
179
Added:
];
180
Added:
tag "body"
181
Added:
[ Dream_html.string_attr "class" "hito-app" ]
182
Added:
(flash_notice
183
Added:
@ [
184
Added:
tag "a"
185
Added:
[
186
Added:
class_ "skip-link";
187
Added:
Dream_html.string_attr "href" "#main-content";
188
Added:
]
189
Added:
[ txt "Skip to main content" ];
190
Added:
tag "div"
191
Added:
([
192
Added:
Dream_html.string_attr "class" "app-shell page-%s" active;
193
Added:
Dream_html.string_attr "data-hito-page-title" "Hito — %s" title;
194
Added:
]
195
Added:
@
196
Added:
if spa_client then [ Dream_html.attr "data-hito-app-shell" ]
197
Added:
else [])
198
Added:
([
199
Added:
tag "header"
200
Added:
[ class_ "masthead" ]
201
Added:
([
202
Added:
tag "a"
203
Added:
([ class_ "brand"; href Routes.home ]
204
Added:
@
205
Added:
if spa_client then
206
Added:
[ Dream_html.attr "data-hito-app-link" ]
207
Added:
else [])
208
Added:
[ txt "hito" ];
209
Added:
]
210
Added:
@ primary_nav @ profile_area @ account_area);
211
Added:
tag "main"
212
Added:
[ id "main-content"; tabindex "-1" ]
213
Added:
[
214
Added:
tag "div"
215
Added:
([ class_ "page-surface" ]
216
Added:
@
217
Added:
if spa_client then
218
Added:
[ Dream_html.attr "data-hito-app-content" ]
219
Added:
else [])
220
Added:
content;
221
Added:
];
222
Added:
]
223
Added:
@ bottom_nav);
224
Added:
]
225
Added:
@
226
Added:
if spa_client then
227
Added:
[
228
Added:
tag "script"
229
Added:
[ src Routes.workout_client; Dream_html.attr "defer" ]
230
Added:
[];
231
Added:
]
232
Added:
else []);
233
Added:
]
lib/presenter/pages.ml
@@ -0,0 +1,27 @@
1
Added:
(* The presenter's page façade. Each feature's pages live in their own module;
2
Added:
this re-exports them under the stable [Pages] interface the web tier binds
3
Added:
to. See [pages.mli] for the public surface. *)
4
Added:
5
Added:
type page = Page_kit.page
6
Added:
7
Added:
let problem = Pages_error.problem
8
Added:
let error_page = Pages_error.error_page
9
Added:
let login = Pages_auth.login
10
Added:
let register = Pages_auth.register
11
Added:
let choose_routine = Pages_routine.choose_routine
12
Added:
let home = Pages_routine.home
13
Added:
let workout_in_progress = Pages_routine.workout_in_progress
14
Added:
let routine = Pages_routine.routine
15
Added:
let workout = Pages_workout.workout
16
Added:
17
Added:
type feedback_flow = Pages_logbook.feedback_flow = {
18
Added:
step : int;
19
Added:
answers : (string * string) list;
20
Added:
}
21
Added:
22
Added:
let feedback_factors = Pages_logbook.feedback_factors
23
Added:
let logbook = Pages_logbook.logbook
24
Added:
let app_feedback = Pages_app_feedback.app_feedback
25
Added:
let profile = Pages_profile.profile
26
Added:
let settings = Pages_settings.settings
27
Added:
let import_review = Pages_import.import_review
lib/presenter/pages.mli
@@ -0,0 +1,124 @@
1
Added:
type page = Dream_html.node
2
Added:
3
Added:
val login :
4
Added:
Dream.request -> ?error:string -> ?registration_open:bool -> unit -> page
5
Added:
(** [registration_open] shows the "Register" link. Defaults to [false]. *)
6
Added:
7
Added:
val register : Dream.request -> ?error:string -> unit -> page
8
Added:
9
Added:
val choose_routine :
10
Added:
Dream.request ->
11
Added:
logging:bool ->
12
Added:
viewer:View_model.Viewer.t ->
13
Added:
routines:View_model.Routine_choice.t list ->
14
Added:
page
15
Added:
16
Added:
val home :
17
Added:
Dream.request -> viewer:View_model.Viewer.t -> home:View_model.Home.t -> page
18
Added:
19
Added:
val workout_in_progress :
20
Added:
Dream.request -> viewer:View_model.Viewer.t -> workout_name:string -> page
21
Added:
(** The Home card shown while a workout is in progress. Links to the current
22
Added:
workout so it stays one tap away. *)
23
Added:
24
Added:
val routine :
25
Added:
Dream.request ->
26
Added:
?logging:bool ->
27
Added:
viewer:View_model.Viewer.t ->
28
Added:
View_model.Routine.t ->
29
Added:
page
30
Added:
31
Added:
val workout :
32
Added:
Dream.request ->
33
Added:
viewer:View_model.Viewer.t ->
34
Added:
?errors:(string * string) list ->
35
Added:
?editing:int ->
36
Added:
?logging:bool ->
37
Added:
record_id:string option ->
38
Added:
active_slot:int ->
39
Added:
View_model.Workout.t ->
40
Added:
page
41
Added:
(** Renders one prescribed slot at a time under a dropdown that selects the
42
Added:
exercise. Authenticated pages carry generic progressive-enhancement markers.
43
Added:
Current workouts additionally mark slot links and forms, while saved-record
44
Added:
edits use the generic authenticated form path. [active_slot] is the slot the
45
Added:
view opens on. A handler clamps a requested slot and falls back to the first
46
Added:
outstanding slot. [record_id] is [None] for the workout in progress and
47
Added:
[Some id] for a saved history record. [logging] sets the middle navigation
48
Added:
action. It defaults to a live workout view (true when [record_id] is
49
Added:
[None]). *)
50
Added:
51
Added:
type feedback_flow = { step : int; answers : (string * string) list }
52
Added:
53
Added:
val feedback_factors : (string * string) list
54
Added:
(** Ordered factor codes and labels used by the sequential feedback flow. *)
55
Added:
56
Added:
val logbook :
57
Added:
Dream.request ->
58
Added:
?logging:bool ->
59
Added:
viewer:View_model.Viewer.t ->
60
Added:
?feedback:View_model.Feedback.report list ->
61
Added:
?suggest_feedback:bool ->
62
Added:
?feedback_flow:feedback_flow ->
63
Added:
?feedback_open:bool ->
64
Added:
View_model.Logbook_entry.t list ->
65
Added:
page
66
Added:
(** The logbook: recorded workouts and a modal sequential subjective feedback
67
Added:
flow. [feedback] lists past reports, most recent first. [suggest_feedback]
68
Added:
shows a prompt inviting feedback, set after a workout finishes. *)
69
Added:
70
Added:
val profile :
71
Added:
Dream.request ->
72
Added:
?logging:bool ->
73
Added:
viewer:View_model.Viewer.t ->
74
Added:
?username_error:string ->
75
Added:
?password_error:string ->
76
Added:
?notice:string ->
77
Added:
unit ->
78
Added:
page
79
Added:
(** The account profile page: rename the account and change the password, each
80
Added:
an independent form. [username_error] and [password_error] report a refused
81
Added:
change inline. [notice] confirms a successful one. *)
82
Added:
83
Added:
val settings :
84
Added:
Dream.request ->
85
Added:
?logging:bool ->
86
Added:
viewer:View_model.Viewer.t ->
87
Added:
theme:string ->
88
Added:
unit ->
89
Added:
page
90
Added:
(** The session-scoped theme settings page. *)
91
Added:
92
Added:
val import_review :
93
Added:
Dream.request ->
94
Added:
viewer:View_model.Viewer.t ->
95
Added:
View_model.Import_review.t ->
96
Added:
page
97
Added:
(** The review of a provisional Hevy import batch. Lists the rows dropped on
98
Added:
parse, then each workout with its sets, blockers, and acknowledgement state.
99
Added:
Renders a mapping form per distinct source name, a normal-set confirmation
100
Added:
form, a per-workout promote form, and a batch promote form. Basic accessible
101
Added:
HTML: it names no core entity, only the view model. *)
102
Added:
103
Added:
val problem : title:string -> detail:string -> page
104
Added:
105
Added:
val error_page :
106
Added:
?viewer:View_model.Viewer.t ->
107
Added:
?request:Dream.request ->
108
Added:
status:int ->
109
Added:
unit ->
110
Added:
page
111
Added:
(** A branded page for an HTTP failure. It names only the class of failure, so
112
Added:
no server-supplied string leaks, and keeps the navigation affordances: top
113
Added:
on desktop, bottom on mobile. *)
114
Added:
115
Added:
val app_feedback :
116
Added:
Dream.request ->
117
Added:
?logging:bool ->
118
Added:
viewer:View_model.Viewer.t ->
119
Added:
?tab:[ `Write | `Submitted ] ->
120
Added:
?error:string ->
121
Added:
View_model.App_feedback.t list ->
122
Added:
page
123
Added:
(** The authenticated application feedback page. One tab accepts a freeform
124
Added:
message. The other lists the trainee's submitted messages. *)
lib/presenter/pages_app_feedback.ml
@@ -0,0 +1,206 @@
1
Added:
open Dream_html
2
Added:
open Page_kit
3
Added:
open Page_shell
4
Added:
5
Added:
(* The authenticated application feedback page. It keeps writing and reviewing
6
Added:
feedback in separate tabs, while both tabs remain plain links for no-script
7
Added:
use and progressive enhancement. *)
8
Added:
let app_feedback_tab ~selected ~tab ~label =
9
Added:
let path =
10
Added:
match tab with
11
Added:
| `Write -> "/app-feedback?tab=write"
12
Added:
| `Submitted -> "/app-feedback?tab=submitted"
13
Added:
in
14
Added:
let attrs =
15
Added:
[
16
Added:
class_ "feedback-tab";
17
Added:
Dream_html.string_attr "href" "%s" path;
18
Added:
Dream_html.attr "data-hito-app-link";
19
Added:
]
20
Added:
in
21
Added:
let attrs =
22
Added:
if selected = tab then Dream_html.string_attr "aria-current" "page" :: attrs
23
Added:
else attrs
24
Added:
in
25
Added:
tag "a" attrs [ txt "%s" label ]
26
Added:
27
Added:
let app_feedback_form request ?error () =
28
Added:
let error_block =
29
Added:
match error with
30
Added:
| None -> []
31
Added:
| Some message ->
32
Added:
[
33
Added:
tag "p"
34
Added:
[ class_ "warn"; Dream_html.string_attr "role" "alert" ]
35
Added:
[ txt "%s" message ];
36
Added:
]
37
Added:
in
38
Added:
tag "form"
39
Added:
[
40
Added:
action Routes.submit_app_feedback;
41
Added:
post_form;
42
Added:
class_ "app-feedback-form";
43
Added:
Dream_html.attr "data-hito-app-form";
44
Added:
]
45
Added:
(Dream_html.csrf_tag request
46
Added:
:: tag "label"
47
Added:
[ Dream_html.string_attr "for" "app-feedback-message" ]
48
Added:
[ txt "Your feedback" ]
49
Added:
:: tag "textarea"
50
Added:
[
51
Added:
name "message";
52
Added:
id "app-feedback-message";
53
Added:
Dream_html.string_attr "rows" "8";
54
Added:
required;
55
Added:
Dream_html.string_attr "placeholder"
56
Added:
"Tell us what works well or what needs attention.";
57
Added:
]
58
Added:
[]
59
Added:
:: error_block
60
Added:
@ [ void "input" [ type_ "submit"; value "Submit feedback" ] ])
61
Added:
62
Added:
let app_feedback_vote_form request (report : View_model.App_feedback.t) =
63
Added:
if report.viewer_owns then
64
Added:
tag "p" [ class_ "app-feedback-own" ] [ txt "Your feedback" ]
65
Added:
else
66
Added:
let label =
67
Added:
if report.viewer_upvoted then "Upvoted"
68
Added:
else Printf.sprintf "Upvote (%d)" report.upvotes
69
Added:
in
70
Added:
let attrs =
71
Added:
[
72
Added:
action Routes.upvote_app_feedback report.id;
73
Added:
post_form;
74
Added:
class_ "app-feedback-vote";
75
Added:
Dream_html.attr "data-hito-app-form";
76
Added:
]
77
Added:
in
78
Added:
let attrs =
79
Added:
if report.viewer_upvoted then Dream_html.attr "disabled" :: attrs
80
Added:
else attrs
81
Added:
in
82
Added:
tag "form" attrs
83
Added:
[
84
Added:
Dream_html.csrf_tag request;
85
Added:
void "input"
86
Added:
[ type_ "submit"; Dream_html.string_attr "value" "%s" label ];
87
Added:
]
88
Added:
89
Added:
let app_feedback_edit_form request (report : View_model.App_feedback.t) =
90
Added:
tag "form"
91
Added:
[
92
Added:
action Routes.edit_app_feedback report.id;
93
Added:
post_form;
94
Added:
class_ "app-feedback-edit-form";
95
Added:
Dream_html.attr "data-hito-app-form";
96
Added:
]
97
Added:
[
98
Added:
Dream_html.csrf_tag request;
99
Added:
tag "label"
100
Added:
[ Dream_html.string_attr "for" "app-feedback-edit-%s" report.id ]
101
Added:
[ txt "Edit feedback" ];
102
Added:
tag "textarea"
103
Added:
[
104
Added:
name "message";
105
Added:
Dream_html.string_attr "id" "app-feedback-edit-%s" report.id;
106
Added:
Dream_html.string_attr "rows" "4";
107
Added:
required;
108
Added:
]
109
Added:
[ txt "%s" report.message ];
110
Added:
void "input" [ type_ "submit"; value "Save edit" ];
111
Added:
]
112
Added:
113
Added:
let app_feedback_remove_form request (report : View_model.App_feedback.t) =
114
Added:
tag "form"
115
Added:
[
116
Added:
action Routes.remove_app_feedback report.id;
117
Added:
post_form;
118
Added:
class_ "app-feedback-remove-form";
119
Added:
Dream_html.attr "data-hito-app-form";
120
Added:
]
121
Added:
[
122
Added:
Dream_html.csrf_tag request;
123
Added:
void "input" [ type_ "submit"; value "Remove feedback" ];
124
Added:
]
125
Added:
126
Added:
let app_feedback_actions request (report : View_model.App_feedback.t) =
127
Added:
if report.viewer_owns then
128
Added:
tag "div"
129
Added:
[ class_ "app-feedback-actions" ]
130
Added:
[
131
Added:
app_feedback_edit_form request report;
132
Added:
app_feedback_remove_form request report;
133
Added:
]
134
Added:
else
135
Added:
tag "div"
136
Added:
[ class_ "app-feedback-actions" ]
137
Added:
[ app_feedback_vote_form request report ]
138
Added:
139
Added:
let app_feedback request ?(logging = false) ~viewer ?(tab = `Write) ?error
140
Added:
reports =
141
Added:
let panel =
142
Added:
match tab with
143
Added:
| `Write ->
144
Added:
[
145
Added:
tag "h2" [] [ txt "Write feedback" ];
146
Added:
tag "p" []
147
Added:
[ txt "Tell us about your experience using the application." ];
148
Added:
app_feedback_form request ?error ();
149
Added:
]
150
Added:
| `Submitted ->
151
Added:
[
152
Added:
tag "h2" [] [ txt "Submitted feedback" ];
153
Added:
(if reports = [] then
154
Added:
tag "p" []
155
Added:
[ txt "You have not submitted any application feedback." ]
156
Added:
else
157
Added:
tag "ul"
158
Added:
[ class_ "app-feedback-list" ]
159
Added:
(List.map
160
Added:
(fun (report : View_model.App_feedback.t) ->
161
Added:
tag "li" []
162
Added:
[
163
Added:
tag "p"
164
Added:
[ class_ "app-feedback-author" ]
165
Added:
[
166
Added:
txt "%s — %d contributions" report.author
167
Added:
report.contributions;
168
Added:
];
169
Added:
tag "time"
170
Added:
[
171
Added:
class_ "app-feedback-time";
172
Added:
Dream_html.string_attr "datetime" "%s"
173
Added:
report.submitted_at;
174
Added:
]
175
Added:
[ txt "%s" report.submitted_at ];
176
Added:
tag "p"
177
Added:
[ class_ "app-feedback-message" ]
178
Added:
[ txt "%s" report.message ];
179
Added:
tag "p"
180
Added:
[ class_ "app-feedback-upvotes" ]
181
Added:
[ txt "Upvotes: %d" report.upvotes ];
182
Added:
app_feedback_actions request report;
183
Added:
])
184
Added:
reports));
185
Added:
]
186
Added:
in
187
Added:
html_page ~viewer ~request ~active:"app-feedback" ~logging "App feedback"
188
Added:
[
189
Added:
tag "div" []
190
Added:
([
191
Added:
tag "h1" [] [ txt "App feedback" ];
192
Added:
tag "p" [] [ txt "Help us improve hito by sharing your experience." ];
193
Added:
tag "nav"
194
Added:
[
195
Added:
class_ "feedback-tabs";
196
Added:
Dream_html.string_attr "aria-label" "App feedback tabs";
197
Added:
]
198
Added:
[
199
Added:
app_feedback_tab ~selected:tab ~tab:`Write
200
Added:
~label:"Write feedback";
201
Added:
app_feedback_tab ~selected:tab ~tab:`Submitted
202
Added:
~label:"Submitted feedback";
203
Added:
];
204
Added:
]
205
Added:
@ panel);
206
Added:
]
lib/presenter/pages_auth.ml
@@ -0,0 +1,86 @@
1
Added:
open Dream_html
2
Added:
open Page_kit
3
Added:
open Page_shell
4
Added:
5
Added:
let auth_error = function
6
Added:
| None -> []
7
Added:
| Some message ->
8
Added:
[
9
Added:
tag "p"
10
Added:
[ class_ "warn"; Dream_html.string_attr "role" "alert" ]
11
Added:
[ txt "%s" message ];
12
Added:
]
13
Added:
14
Added:
let credentials_form request ~submit ~action_path =
15
Added:
tag "form"
16
Added:
[ action action_path; post_form; Dream_html.attr "data-hito-app-form" ]
17
Added:
[
18
Added:
Dream_html.csrf_tag request;
19
Added:
tag "div"
20
Added:
[ class_ "field" ]
21
Added:
[
22
Added:
tag "label"
23
Added:
[ Dream_html.string_attr "for" "username" ]
24
Added:
[ txt "Username" ];
25
Added:
void "input"
26
Added:
[
27
Added:
type_ "text";
28
Added:
name "username";
29
Added:
Dream_html.string_attr "id" "username";
30
Added:
Dream_html.string_attr "autocomplete" "username";
31
Added:
required;
32
Added:
];
33
Added:
];
34
Added:
tag "div"
35
Added:
[ class_ "field" ]
36
Added:
[
37
Added:
tag "label"
38
Added:
[ Dream_html.string_attr "for" "password" ]
39
Added:
[ txt "Password" ];
40
Added:
void "input"
41
Added:
[
42
Added:
type_ "password";
43
Added:
name "password";
44
Added:
Dream_html.string_attr "id" "password";
45
Added:
Dream_html.string_attr "autocomplete" "current-password";
46
Added:
required;
47
Added:
];
48
Added:
];
49
Added:
void "input" [ type_ "submit"; value submit ];
50
Added:
]
51
Added:
52
Added:
let login request ?error ?(registration_open = false) () =
53
Added:
let register_prompt =
54
Added:
if registration_open then
55
Added:
[
56
Added:
tag "p" []
57
Added:
[
58
Added:
txt "No account yet? ";
59
Added:
tag "a"
60
Added:
[ href Routes.register; Dream_html.attr "data-hito-app-link" ]
61
Added:
[ txt "Register" ];
62
Added:
];
63
Added:
]
64
Added:
else []
65
Added:
in
66
Added:
html_page ~active:"auth" "Sign in"
67
Added:
([
68
Added:
tag "h1" [] [ txt "Sign in" ];
69
Added:
credentials_form request ~submit:"Sign in" ~action_path:Routes.login;
70
Added:
]
71
Added:
@ register_prompt @ auth_error error)
72
Added:
73
Added:
let register request ?error () =
74
Added:
html_page ~active:"auth" "Register"
75
Added:
([
76
Added:
tag "h1" [] [ txt "Create an account" ];
77
Added:
credentials_form request ~submit:"Register" ~action_path:Routes.register;
78
Added:
tag "p" []
79
Added:
[
80
Added:
txt "Already registered? ";
81
Added:
tag "a"
82
Added:
[ href Routes.login; Dream_html.attr "data-hito-app-link" ]
83
Added:
[ txt "Sign in" ];
84
Added:
];
85
Added:
]
86
Added:
@ auth_error error)
lib/presenter/pages_error.ml
@@ -0,0 +1,31 @@
1
Added:
(** Branded error pages. These pages expose no domain or service detail. *)
2
Added:
3
Added:
open Dream_html
4
Added:
open Page_kit
5
Added:
open Page_shell
6
Added:
7
Added:
let problem ~title ~detail =
8
Added:
html_page title
9
Added:
[
10
Added:
tag "p" [ class_ "eyebrow" ] [ txt "Attention required" ];
11
Added:
tag "h1" [] [ txt "%s" title ];
12
Added:
tag "p" [ class_ "warn" ] [ txt "%s" detail ];
13
Added:
]
14
Added:
15
Added:
let error_page ?viewer ?request ~status () =
16
Added:
let title, detail =
17
Added:
match status with
18
Added:
| 404 ->
19
Added:
("Page not found", "That page does not exist. Use the navigation below.")
20
Added:
| 400 -> ("Bad request", "That request could not be understood.")
21
Added:
| 403 -> ("Forbidden", "You do not have access to that page.")
22
Added:
| s when s >= 500 ->
23
Added:
("Something went wrong", "The server hit a problem. Try again shortly.")
24
Added:
| _ -> ("Something went wrong", "That request could not be completed.")
25
Added:
in
26
Added:
html_page ?viewer ?request ~show_nav:true title
27
Added:
[
28
Added:
tag "p" [ class_ "eyebrow" ] [ txt "%d" status ];
29
Added:
tag "h1" [] [ txt "%s" title ];
30
Added:
tag "p" [ class_ "warn" ] [ txt "%s" detail ];
31
Added:
]
lib/presenter/pages_import.ml
@@ -0,0 +1,161 @@
1
Added:
open Dream_html
2
Added:
open Page_kit
3
Added:
open Page_shell
4
Added:
5
Added:
(* The review of a provisional import batch. It renders the parse warnings, then
6
Added:
each workout with its sets, blockers, and forms. Every form is a plain POST
7
Added:
carrying its CSRF token, so cleaning and promotion need no script. The page
8
Added:
names only the view model: the controller has already phrased set types,
9
Added:
blockers, and warnings, so no core entity crosses the boundary here. *)
10
Added:
let import_review request ~viewer (vm : View_model.Import_review.t) =
11
Added:
let warnings_block =
12
Added:
match vm.View_model.Import_review.warnings with
13
Added:
| [] -> []
14
Added:
| warnings ->
15
Added:
[
16
Added:
tag "section"
17
Added:
[ class_ "import-warnings" ]
18
Added:
[
19
Added:
tag "h2" [] [ txt "Dropped rows" ];
20
Added:
tag "ul" []
21
Added:
(List.map
22
Added:
(fun (w : View_model.Import_warning.t) ->
23
Added:
tag "li" []
24
Added:
[
25
Added:
txt "Row %d: %s" w.View_model.Import_warning.row
26
Added:
w.View_model.Import_warning.detail;
27
Added:
])
28
Added:
warnings);
29
Added:
];
30
Added:
]
31
Added:
in
32
Added:
(* One row per set. A mapped set shows the catalog name it resolves to. *)
33
Added:
let set_row (s : View_model.Import_set.t) =
34
Added:
let mapping =
35
Added:
match s.View_model.Import_set.mapping with
36
Added:
| Some name -> Printf.sprintf " → %s" name
37
Added:
| None -> " → unmapped"
38
Added:
in
39
Added:
tag "li" []
40
Added:
[
41
Added:
txt "Row %d: %s (%s) %s kg × %s reps%s" s.View_model.Import_set.row
42
Added:
s.View_model.Import_set.exercise_name s.View_model.Import_set.set_type
43
Added:
s.View_model.Import_set.weight s.View_model.Import_set.reps mapping;
44
Added:
]
45
Added:
in
46
Added:
(* One mapping form per distinct source name in the workout. The source name
47
Added:
is fixed by a hidden field; the trainee supplies the catalog exercise id. *)
48
Added:
let mapping_form batch_id workout_id source_name =
49
Added:
tag "form"
50
Added:
[
51
Added:
action Routes.import_map batch_id workout_id;
52
Added:
post_form;
53
Added:
class_ "import-map-form";
54
Added:
]
55
Added:
[
56
Added:
Dream_html.csrf_tag request;
57
Added:
void "input"
58
Added:
[
59
Added:
type_ "hidden";
60
Added:
name "source_name";
61
Added:
Dream_html.string_attr "value" "%s" source_name;
62
Added:
];
63
Added:
tag "div"
64
Added:
[ class_ "field" ]
65
Added:
[
66
Added:
tag "label" [] [ txt "Map %s to exercise id" source_name ];
67
Added:
void "input" [ type_ "text"; name "exercise_id"; required ];
68
Added:
];
69
Added:
void "input" [ type_ "submit"; value "Map exercise" ];
70
Added:
]
71
Added:
in
72
Added:
let confirm_form batch_id workout_id acknowledgement =
73
Added:
tag "form"
74
Added:
[
75
Added:
action Routes.import_confirm batch_id workout_id;
76
Added:
post_form;
77
Added:
class_ "import-confirm-form";
78
Added:
]
79
Added:
[
80
Added:
Dream_html.csrf_tag request;
81
Added:
tag "div"
82
Added:
[ class_ "field" ]
83
Added:
[
84
Added:
tag "label" [] [ txt "Confirm normal sets" ];
85
Added:
void "input"
86
Added:
([ type_ "text"; name "acknowledgement"; required ]
87
Added:
@
88
Added:
match acknowledgement with
89
Added:
| Some ack -> [ Dream_html.string_attr "value" "%s" ack ]
90
Added:
| None -> []);
91
Added:
];
92
Added:
void "input" [ type_ "submit"; value "Confirm normal sets" ];
93
Added:
]
94
Added:
in
95
Added:
let promote_workout_form batch_id workout_id =
96
Added:
tag "form"
97
Added:
[
98
Added:
action Routes.import_promote_workout batch_id workout_id;
99
Added:
post_form;
100
Added:
class_ "import-promote-workout-form";
101
Added:
]
102
Added:
[
103
Added:
Dream_html.csrf_tag request;
104
Added:
void "input" [ type_ "submit"; value "Promote workout" ];
105
Added:
]
106
Added:
in
107
Added:
let blockers_block (w : View_model.Import_workout.t) =
108
Added:
match w.View_model.Import_workout.blockers with
109
Added:
| [] -> [ tag "p" [ class_ "import-ready" ] [ txt "Ready to promote." ] ]
110
Added:
| blockers ->
111
Added:
[
112
Added:
tag "p" [] [ txt "Blocked:" ];
113
Added:
tag "ul"
114
Added:
[ class_ "import-blockers" ]
115
Added:
(List.map (fun b -> tag "li" [] [ txt "%s" b ]) blockers);
116
Added:
]
117
Added:
in
118
Added:
let workout_section (w : View_model.Import_workout.t) =
119
Added:
let batch_id = vm.View_model.Import_review.batch_id in
120
Added:
let workout_id = w.View_model.Import_workout.id in
121
Added:
(* Every distinct source name, in first-appearance order. *)
122
Added:
let source_names =
123
Added:
List.fold_left
124
Added:
(fun acc (s : View_model.Import_set.t) ->
125
Added:
let n = s.View_model.Import_set.exercise_name in
126
Added:
if List.mem n acc then acc else acc @ [ n ])
127
Added:
[] w.View_model.Import_workout.sets
128
Added:
in
129
Added:
tag "section"
130
Added:
[ class_ "import-workout" ]
131
Added:
([
132
Added:
tag "h2" [] [ txt "%s" w.View_model.Import_workout.title ];
133
Added:
tag "ul"
134
Added:
[ class_ "import-sets" ]
135
Added:
(List.map set_row w.View_model.Import_workout.sets);
136
Added:
]
137
Added:
@ blockers_block w
138
Added:
@ List.map (mapping_form batch_id workout_id) source_names
139
Added:
@ [
140
Added:
confirm_form batch_id workout_id
141
Added:
w.View_model.Import_workout.acknowledgement;
142
Added:
promote_workout_form batch_id workout_id;
143
Added:
])
144
Added:
in
145
Added:
let batch_promote_form =
146
Added:
tag "form"
147
Added:
[
148
Added:
action Routes.import_promote_batch vm.View_model.Import_review.batch_id;
149
Added:
post_form;
150
Added:
class_ "import-promote-batch-form";
151
Added:
]
152
Added:
[
153
Added:
Dream_html.csrf_tag request;
154
Added:
void "input" [ type_ "submit"; value "Promote whole batch" ];
155
Added:
]
156
Added:
in
157
Added:
html_page ~viewer ~request ~active:"profile" "Import review"
158
Added:
([ tag "h1" [] [ txt "Import review" ] ]
159
Added:
@ warnings_block
160
Added:
@ List.map workout_section vm.View_model.Import_review.workouts
161
Added:
@ [ batch_promote_form ])
lib/presenter/pages_logbook.ml
@@ -0,0 +1,385 @@
1
Added:
open Dream_html
2
Added:
open Page_kit
3
Added:
open Page_shell
4
Added:
5
Added:
(* The subjective feedback form. Radio groups report sleep, appetite,
6
Added:
readiness, motivation, and difficulty against a personal baseline. Flags
7
Added:
report pain, injury, and insufficient preparation. A field left blank reports
8
Added:
nothing, so the trainee submits only what they mean to. Feedback is
9
Added:
standalone — recorded from the Logbook at any time. *)
10
Added:
type feedback_flow = { step : int; answers : (string * string) list }
11
Added:
12
Added:
let feedback_factors =
13
Added:
[
14
Added:
("sleep", "Sleep");
15
Added:
("appetite", "Appetite");
16
Added:
("readiness", "Readiness");
17
Added:
("motivation", "Motivation");
18
Added:
("difficulty", "Perceived difficulty");
19
Added:
]
20
Added:
21
Added:
(* Each subjective metric uses five unselected radio buttons styled as inline
22
Added:
buttons. The server shows one metric at a time. *)
23
Added:
let feedback_level_buttons field label ~selected =
24
Added:
let choice code text =
25
Added:
tag "label"
26
Added:
[ class_ "feedback-choice"; Dream_html.attr "data-hito-feedback-choice" ]
27
Added:
[
28
Added:
void "input"
29
Added:
([
30
Added:
type_ "radio";
31
Added:
Dream_html.string_attr "name" "choice";
32
Added:
Dream_html.string_attr "value" "%s" code;
33
Added:
Dream_html.string_attr "id" "%s-%s" field code;
34
Added:
]
35
Added:
@
36
Added:
if String.equal code selected then [ Dream_html.attr "checked" ]
37
Added:
else []);
38
Added:
tag "span" [] [ txt "%s" text ];
39
Added:
]
40
Added:
in
41
Added:
tag "div"
42
Added:
[ class_ "feedback-group" ]
43
Added:
[
44
Added:
tag "p" [ class_ "feedback-group-label" ] [ txt "%s" label ];
45
Added:
tag "div"
46
Added:
[
47
Added:
class_ "feedback-buttons";
48
Added:
Dream_html.string_attr "role" "group";
49
Added:
Dream_html.string_attr "aria-label" "%s" label;
50
Added:
]
51
Added:
[
52
Added:
choice "1" "1 — very poor";
53
Added:
choice "2" "2";
54
Added:
choice "3" "3";
55
Added:
choice "4" "4";
56
Added:
choice "5" "5 — very good";
57
Added:
];
58
Added:
]
59
Added:
60
Added:
let feedback_flag field label =
61
Added:
tag "label"
62
Added:
[ class_ "feedback-flag" ]
63
Added:
[
64
Added:
void "input"
65
Added:
[
66
Added:
type_ "checkbox";
67
Added:
Dream_html.string_attr "name" "%s" field;
68
Added:
value "true";
69
Added:
];
70
Added:
txt " %s" label;
71
Added:
]
72
Added:
73
Added:
let feedback_progress step =
74
Added:
let completed = min 5 (max 0 step) in
75
Added:
tag "div"
76
Added:
[ class_ "feedback-progress" ]
77
Added:
[
78
Added:
tag "progress"
79
Added:
[
80
Added:
Dream_html.string_attr "value" "%s" (string_of_int completed);
81
Added:
Dream_html.string_attr "max" "5";
82
Added:
Dream_html.string_attr "aria-label" "Feedback progress";
83
Added:
]
84
Added:
[ txt "%d of 5 factors" completed ];
85
Added:
tag "p" [ class_ "ledger-meta" ] [ txt "%d of 5 factors" completed ];
86
Added:
]
87
Added:
88
Added:
let feedback_action_button ~action ~label ?(secondary = false) () =
89
Added:
tag "button"
90
Added:
([
91
Added:
type_ "submit";
92
Added:
name "action";
93
Added:
value action;
94
Added:
Dream_html.attr "data-hito-feedback-action";
95
Added:
]
96
Added:
@ if secondary then [ class_ "secondary" ] else [])
97
Added:
[ txt "%s" label ]
98
Added:
99
Added:
let feedback_flow_form request flow =
100
Added:
let step = min 5 (max 0 flow.step) in
101
Added:
let fields =
102
Added:
[
103
Added:
void "input"
104
Added:
[
105
Added:
type_ "hidden";
106
Added:
name "step";
107
Added:
Dream_html.string_attr "value" "%s" (string_of_int step);
108
Added:
];
109
Added:
void "input"
110
Added:
[
111
Added:
type_ "hidden";
112
Added:
name "action";
113
Added:
Dream_html.string_attr "value" "";
114
Added:
Dream_html.attr "data-hito-feedback-action-value";
115
Added:
];
116
Added:
Dream_html.csrf_tag request;
117
Added:
]
118
Added:
in
119
Added:
let body =
120
Added:
if step < 5 then
121
Added:
let field, label = List.nth feedback_factors step in
122
Added:
fields
123
Added:
@ [
124
Added:
tag "h3" [] [ txt "%s" label ];
125
Added:
feedback_level_buttons field label
126
Added:
~selected:
127
Added:
(Option.value (List.assoc_opt field flow.answers) ~default:"");
128
Added:
feedback_progress (step + 1);
129
Added:
tag "div"
130
Added:
[ class_ "feedback-actions" ]
131
Added:
((if step > 0 then
132
Added:
let _, previous_label = List.nth feedback_factors (step - 1) in
133
Added:
[
134
Added:
feedback_action_button ~action:"back"
135
Added:
~label:(Printf.sprintf "Back to %s" previous_label)
136
Added:
~secondary:true ();
137
Added:
]
138
Added:
else [])
139
Added:
@ [
140
Added:
feedback_action_button ~action:"skip" ~label:"Skip this factor"
141
Added:
~secondary:true ();
142
Added:
]);
143
Added:
]
144
Added:
else
145
Added:
fields
146
Added:
@ [
147
Added:
tag "h3" [] [ txt "Anything else?" ];
148
Added:
tag "p" []
149
Added:
[ txt "Add an optional note about pain, injury, or preparation." ];
150
Added:
tag "div"
151
Added:
[ class_ "field" ]
152
Added:
[
153
Added:
feedback_flag "pain" "Pain";
154
Added:
feedback_flag "injury" "Injury";
155
Added:
feedback_flag "preparation" "Preparation was insufficient";
156
Added:
];
157
Added:
feedback_progress 5;
158
Added:
tag "div"
159
Added:
[ class_ "feedback-actions" ]
160
Added:
[
161
Added:
feedback_action_button ~action:"back"
162
Added:
~label:"Back to Perceived difficulty" ~secondary:true ();
163
Added:
feedback_action_button ~action:"save" ~label:"Submit feedback" ();
164
Added:
];
165
Added:
]
166
Added:
in
167
Added:
tag "form"
168
Added:
[
169
Added:
action Routes.feedback;
170
Added:
post_form;
171
Added:
class_ "feedback-form";
172
Added:
Dream_html.attr "data-hito-feedback-form";
173
Added:
Dream_html.attr "data-hito-app-form";
174
Added:
]
175
Added:
[ tag "fieldset" [] body ]
176
Added:
177
Added:
let feedback_modal request ~flow ~open_ =
178
Added:
tag "dialog"
179
Added:
([ class_ "feedback-modal"; Dream_html.attr "data-hito-feedback-modal" ]
180
Added:
@ if open_ then [ Dream_html.attr "open" ] else [])
181
Added:
[
182
Added:
tag "div"
183
Added:
[ class_ "feedback-modal-content" ]
184
Added:
[
185
Added:
tag "div"
186
Added:
[ class_ "feedback-modal-heading" ]
187
Added:
[
188
Added:
tag "h2" [] [ txt "How are you feeling?" ];
189
Added:
(* Close cancels the flow: it submits the cancel form, so the
190
Added:
partial progress is discarded rather than kept for later. *)
191
Added:
tag "form"
192
Added:
[
193
Added:
action Routes.cancel_feedback;
194
Added:
post_form;
195
Added:
class_ "feedback-close-form";
196
Added:
Dream_html.attr "data-hito-app-form";
197
Added:
]
198
Added:
[
199
Added:
Dream_html.csrf_tag request;
200
Added:
tag "button"
201
Added:
[
202
Added:
type_ "submit";
203
Added:
class_ "feedback-modal-close";
204
Added:
Dream_html.string_attr "aria-label" "Close feedback";
205
Added:
]
206
Added:
[ txt "×" ];
207
Added:
];
208
Added:
];
209
Added:
feedback_flow_form request flow;
210
Added:
];
211
Added:
]
212
Added:
213
Added:
(* A small inline-SVG line chart of leveled feedback over time, one polyline per
214
Added:
factor. No script and no dependency: the logbook records, and this only draws
215
Added:
what it already holds. Shown once at least two reports carry a leveled
216
Added:
factor, since a single point is not a trend. *)
217
Added:
let feedback_graph (reports : View_model.Feedback.report list) =
218
Added:
let chronological =
219
Added:
List.sort
220
Added:
(fun (a : View_model.Feedback.report) (b : View_model.Feedback.report) ->
221
Added:
Int.compare a.at_unix b.at_unix)
222
Added:
reports
223
Added:
in
224
Added:
let count = List.length chronological in
225
Added:
let score_of field (report : View_model.Feedback.report) =
226
Added:
match List.assoc_opt field report.factor_scores with
227
Added:
| Some s -> s
228
Added:
| None -> None
229
Added:
in
230
Added:
let series =
231
Added:
List.map
232
Added:
(fun (field, label) ->
233
Added:
( label,
234
Added:
List.mapi (fun i report -> (i, score_of field report)) chronological
235
Added:
))
236
Added:
feedback_factors
237
Added:
in
238
Added:
(* A factor charts only if it holds at least two scored points. *)
239
Added:
let plottable (_, points) =
240
Added:
List.length (List.filter (fun (_, s) -> Option.is_some s) points) >= 2
241
Added:
in
242
Added:
let series = List.filter plottable series in
243
Added:
if count < 2 || series = [] then []
244
Added:
else
245
Added:
let width = 480 and height = 180 in
246
Added:
let pad_left = 28 and pad_right = 12 and pad_top = 12 and pad_bottom = 24 in
247
Added:
let plot_w = width - pad_left - pad_right in
248
Added:
let plot_h = height - pad_top - pad_bottom in
249
Added:
let x_of i =
250
Added:
if count = 1 then pad_left + (plot_w / 2)
251
Added:
else pad_left + (i * plot_w / (count - 1))
252
Added:
in
253
Added:
(* Score 1..5 maps low-to-high, so 5 sits at the top. *)
254
Added:
let y_of score = pad_top + ((5 - score) * plot_h / 4) in
255
Added:
let polyline label points =
256
Added:
let coords =
257
Added:
List.filter_map
258
Added:
(fun (i, s) ->
259
Added:
Option.map (fun s -> Printf.sprintf "%d,%d" (x_of i) (y_of s)) s)
260
Added:
points
261
Added:
in
262
Added:
tag "polyline"
263
Added:
[
264
Added:
class_ "feedback-graph-line";
265
Added:
Dream_html.string_attr "points" "%s" (String.concat " " coords);
266
Added:
Dream_html.string_attr "fill" "none";
267
Added:
Dream_html.string_attr "data-factor" "%s" label;
268
Added:
]
269
Added:
[]
270
Added:
in
271
Added:
let axis =
272
Added:
List.map
273
Added:
(fun score ->
274
Added:
let y = y_of score in
275
Added:
tag "text"
276
Added:
[
277
Added:
class_ "feedback-graph-tick";
278
Added:
Dream_html.string_attr "x" "%d" (pad_left - 6);
279
Added:
Dream_html.string_attr "y" "%d" (y + 3);
280
Added:
Dream_html.string_attr "text-anchor" "end";
281
Added:
]
282
Added:
[ txt "%d" score ])
283
Added:
[ 1; 2; 3; 4; 5 ]
284
Added:
in
285
Added:
let legend =
286
Added:
tag "ul"
287
Added:
[ class_ "feedback-graph-legend" ]
288
Added:
(List.map
289
Added:
(fun (label, _) ->
290
Added:
tag "li"
291
Added:
[ Dream_html.string_attr "data-factor" "%s" label ]
292
Added:
[ txt "%s" label ])
293
Added:
series)
294
Added:
in
295
Added:
[
296
Added:
tag "figure"
297
Added:
[ class_ "feedback-graph" ]
298
Added:
[
299
Added:
tag "figcaption" [] [ txt "Feedback over time" ];
300
Added:
tag "svg"
301
Added:
[
302
Added:
class_ "feedback-graph-svg";
303
Added:
Dream_html.string_attr "viewBox" "0 0 %d %d" width height;
304
Added:
Dream_html.string_attr "role" "img";
305
Added:
Dream_html.string_attr "aria-label"
306
Added:
"Subjective feedback scores over time, one line per factor";
307
Added:
]
308
Added:
(axis
309
Added:
@ List.map (fun (label, points) -> polyline label points) series);
310
Added:
legend;
311
Added:
];
312
Added:
]
313
Added:
314
Added:
let feedback_list (reports : View_model.Feedback.report list) =
315
Added:
if reports = [] then []
316
Added:
else
317
Added:
[
318
Added:
tag "ul"
319
Added:
[ class_ "feedback-list" ]
320
Added:
(List.map
321
Added:
(fun (report : View_model.Feedback.report) ->
322
Added:
let signals = String.concat ", " report.signals in
323
Added:
tag "li" []
324
Added:
[ txt "%s" (if signals = "" then "No signals" else signals) ])
325
Added:
reports);
326
Added:
]
327
Added:
328
Added:
let logbook request ?(logging = false) ~viewer ?(feedback = [])
329
Added:
?(suggest_feedback = false) ?feedback_flow ?(feedback_open = false) records
330
Added:
=
331
Added:
let feedback_flow =
332
Added:
Option.value feedback_flow ~default:{ step = 0; answers = [] }
333
Added:
in
334
Added:
html_page ~viewer ~request ~active:"logbook" ~logging "Logbook"
335
Added:
[
336
Added:
tag "h1" [] [ txt "Logbook" ];
337
Added:
(if records = [] then tag "p" [] [ txt "Nothing logged yet." ]
338
Added:
else
339
Added:
tag "ul" []
340
Added:
(List.map
341
Added:
(fun (entry : View_model.Logbook_entry.t) ->
342
Added:
tag "li" []
343
Added:
[
344
Added:
tag "a"
345
Added:
[
346
Added:
href Routes.record entry.id;
347
Added:
Dream_html.attr "data-hito-app-link";
348
Added:
]
349
Added:
[
350
Added:
txt "%s — %d stimuli" entry.workout_name
351
Added:
entry.stimuli_count;
352
Added:
];
353
Added:
tag "p"
354
Added:
[ class_ "done" ]
355
Added:
[
356
Added:
txt "%s"
357
Added:
(if entry.complete then "complete" else "incomplete");
358
Added:
];
359
Added:
])
360
Added:
records));
361
Added:
tag "section"
362
Added:
[ class_ "feedback-section" ]
363
Added:
([
364
Added:
tag "h2" [] [ txt "How are you feeling?" ];
365
Added:
(if suggest_feedback then
366
Added:
tag "p"
367
Added:
[ class_ "eyebrow" ]
368
Added:
[ txt "Workout saved — add feedback while it is fresh." ]
369
Added:
else txt "");
370
Added:
tag "p" []
371
Added:
[
372
Added:
txt
373
Added:
"Report each factor in turn. Skip any factor or the full flow.";
374
Added:
];
375
Added:
tag "a"
376
Added:
[
377
Added:
class_ "feedback-toggle";
378
Added:
Dream_html.string_attr "href" "/logbook?feedback=start";
379
Added:
Dream_html.attr "data-hito-feedback-open";
380
Added:
]
381
Added:
[ txt "Record feedback" ];
382
Added:
feedback_modal request ~flow:feedback_flow ~open_:feedback_open;
383
Added:
]
384
Added:
@ feedback_graph feedback @ feedback_list feedback);
385
Added:
]
lib/presenter/pages_profile.ml
@@ -0,0 +1,260 @@
1
Added:
open Dream_html
2
Added:
open Page_kit
3
Added:
open Page_shell
4
Added:
5
Added:
(* The account profile page. It names the signed-in trainee and offers two
6
Added:
independent forms: rename the account, and change the password. Each form
7
Added:
reports its own error inline. [notice] confirms a successful change. Both are
8
Added:
plain authenticated app-forms, so they work with or without script. *)
9
Added:
let profile request ?(logging = false) ~viewer ?username_error ?password_error
10
Added:
?notice () =
11
Added:
let notice_block =
12
Added:
match notice with
13
Added:
| Some message -> [ tag "p" [ class_ "notice" ] [ txt "%s" message ] ]
14
Added:
| None -> []
15
Added:
in
16
Added:
let error_block = function
17
Added:
| Some message ->
18
Added:
[
19
Added:
tag "p"
20
Added:
[ class_ "warn"; Dream_html.string_attr "role" "alert" ]
21
Added:
[ txt "%s" message ];
22
Added:
]
23
Added:
| None -> []
24
Added:
in
25
Added:
html_page ~viewer ~request ~active:"profile" ~logging "Profile"
26
Added:
([ tag "h1" [] [ txt "Profile" ] ]
27
Added:
@ notice_block
28
Added:
@ [
29
Added:
(* Username: show the current value and a button that opens the edit
30
Added:
modal. The modal holds the rename form. A no-script client, or an
31
Added:
error re-render, opens the dialog through the [open] attribute so the
32
Added:
form stays reachable and its inline error shows. *)
33
Added:
tag "section"
34
Added:
[ class_ "profile-section" ]
35
Added:
[
36
Added:
tag "h2" [] [ txt "Username" ];
37
Added:
tag "div"
38
Added:
[ class_ "profile-value" ]
39
Added:
[
40
Added:
tag "span" [ class_ "profile-value-label" ] [ txt "Username" ];
41
Added:
tag "span"
42
Added:
[ class_ "profile-value-text" ]
43
Added:
[ txt "%s" viewer.View_model.Viewer.username ];
44
Added:
tag "button"
45
Added:
[
46
Added:
type_ "button";
47
Added:
class_ "profile-edit";
48
Added:
Dream_html.string_attr "data-hito-dialog-open"
49
Added:
"username-dialog";
50
Added:
]
51
Added:
[ txt "Change username" ];
52
Added:
];
53
Added:
tag "dialog"
54
Added:
([
55
Added:
Dream_html.string_attr "id" "username-dialog";
56
Added:
class_ "profile-dialog";
57
Added:
]
58
Added:
@
59
Added:
if Option.is_some username_error then [ Dream_html.attr "open" ]
60
Added:
else [])
61
Added:
[
62
Added:
tag "div"
63
Added:
[ class_ "profile-dialog-content" ]
64
Added:
([
65
Added:
tag "h3" [] [ txt "Change username" ];
66
Added:
tag "form"
67
Added:
[
68
Added:
action Routes.profile_username;
69
Added:
post_form;
70
Added:
class_ "profile-form";
71
Added:
Dream_html.attr "data-hito-app-form";
72
Added:
]
73
Added:
[
74
Added:
Dream_html.csrf_tag request;
75
Added:
tag "div"
76
Added:
[ class_ "field" ]
77
Added:
[
78
Added:
tag "label"
79
Added:
[ Dream_html.string_attr "for" "username" ]
80
Added:
[ txt "Username" ];
81
Added:
void "input"
82
Added:
[
83
Added:
type_ "text";
84
Added:
name "username";
85
Added:
Dream_html.string_attr "id" "username";
86
Added:
Dream_html.string_attr "value" "%s"
87
Added:
viewer.View_model.Viewer.username;
88
Added:
required;
89
Added:
];
90
Added:
];
91
Added:
tag "div"
92
Added:
[ class_ "profile-dialog-actions" ]
93
Added:
[
94
Added:
tag "button"
95
Added:
[
96
Added:
type_ "button";
97
Added:
class_ "secondary";
98
Added:
Dream_html.attr "data-hito-dialog-close";
99
Added:
]
100
Added:
[ txt "Cancel" ];
101
Added:
void "input"
102
Added:
[ type_ "submit"; value "Change username" ];
103
Added:
];
104
Added:
];
105
Added:
]
106
Added:
@ error_block username_error);
107
Added:
];
108
Added:
];
109
Added:
(* Password: a button opens the change-password modal. *)
110
Added:
tag "section"
111
Added:
[ class_ "profile-section" ]
112
Added:
[
113
Added:
tag "h2" [] [ txt "Password" ];
114
Added:
tag "div"
115
Added:
[ class_ "profile-value" ]
116
Added:
[
117
Added:
tag "span" [ class_ "profile-value-label" ] [ txt "Password" ];
118
Added:
tag "span" [ class_ "profile-value-text" ] [ txt "••••••••" ];
119
Added:
tag "button"
120
Added:
[
121
Added:
type_ "button";
122
Added:
class_ "profile-edit";
123
Added:
Dream_html.string_attr "data-hito-dialog-open"
124
Added:
"password-dialog";
125
Added:
]
126
Added:
[ txt "Change password" ];
127
Added:
];
128
Added:
tag "dialog"
129
Added:
([
130
Added:
Dream_html.string_attr "id" "password-dialog";
131
Added:
class_ "profile-dialog";
132
Added:
]
133
Added:
@
134
Added:
if Option.is_some password_error then [ Dream_html.attr "open" ]
135
Added:
else [])
136
Added:
[
137
Added:
tag "div"
138
Added:
[ class_ "profile-dialog-content" ]
139
Added:
([
140
Added:
tag "h3" [] [ txt "Change password" ];
141
Added:
tag "form"
142
Added:
[
143
Added:
action Routes.profile_password;
144
Added:
post_form;
145
Added:
class_ "profile-form";
146
Added:
Dream_html.attr "data-hito-app-form";
147
Added:
]
148
Added:
[
149
Added:
Dream_html.csrf_tag request;
150
Added:
tag "div"
151
Added:
[ class_ "field" ]
152
Added:
[
153
Added:
tag "label"
154
Added:
[ Dream_html.string_attr "for" "current" ]
155
Added:
[ txt "Current password" ];
156
Added:
void "input"
157
Added:
[
158
Added:
type_ "password";
159
Added:
name "current";
160
Added:
Dream_html.string_attr "id" "current";
161
Added:
required;
162
Added:
];
163
Added:
];
164
Added:
tag "div"
165
Added:
[ class_ "field" ]
166
Added:
[
167
Added:
tag "label"
168
Added:
[ Dream_html.string_attr "for" "next" ]
169
Added:
[ txt "New password" ];
170
Added:
void "input"
171
Added:
[
172
Added:
type_ "password";
173
Added:
name "next";
174
Added:
Dream_html.string_attr "id" "next";
175
Added:
required;
176
Added:
];
177
Added:
];
178
Added:
tag "div"
179
Added:
[ class_ "profile-dialog-actions" ]
180
Added:
[
181
Added:
tag "button"
182
Added:
[
183
Added:
type_ "button";
184
Added:
class_ "secondary";
185
Added:
Dream_html.attr "data-hito-dialog-close";
186
Added:
]
187
Added:
[ txt "Cancel" ];
188
Added:
void "input"
189
Added:
[ type_ "submit"; value "Change password" ];
190
Added:
];
191
Added:
];
192
Added:
]
193
Added:
@ error_block password_error);
194
Added:
];
195
Added:
];
196
Added:
(* Import: a multipart form uploads a native Hevy CSV export. The file
197
Added:
field is [csv], the wall-clock offset is [utc_offset_seconds], and an
198
Added:
optional checkbox overrides duplicate-source rejection. The form is a
199
Added:
plain multipart POST with its CSRF token, so it needs no script. *)
200
Added:
tag "section"
201
Added:
[ class_ "profile-section" ]
202
Added:
[
203
Added:
tag "h2" [] [ txt "Import" ];
204
Added:
tag "form"
205
Added:
[
206
Added:
action Routes.import_upload;
207
Added:
post_form;
208
Added:
Dream_html.string_attr "enctype" "multipart/form-data";
209
Added:
class_ "profile-form";
210
Added:
]
211
Added:
[
212
Added:
Dream_html.csrf_tag request;
213
Added:
tag "div"
214
Added:
[ class_ "field" ]
215
Added:
[
216
Added:
tag "label"
217
Added:
[ Dream_html.string_attr "for" "csv" ]
218
Added:
[ txt "Hevy CSV export" ];
219
Added:
void "input"
220
Added:
[
221
Added:
type_ "file";
222
Added:
name "csv";
223
Added:
Dream_html.string_attr "id" "csv";
224
Added:
Dream_html.string_attr "accept" ".csv,text/csv";
225
Added:
required;
226
Added:
];
227
Added:
];
228
Added:
tag "div"
229
Added:
[ class_ "field" ]
230
Added:
[
231
Added:
tag "label"
232
Added:
[ Dream_html.string_attr "for" "utc_offset_seconds" ]
233
Added:
[ txt "UTC offset in seconds" ];
234
Added:
void "input"
235
Added:
[
236
Added:
type_ "number";
237
Added:
name "utc_offset_seconds";
238
Added:
Dream_html.string_attr "id" "utc_offset_seconds";
239
Added:
Dream_html.string_attr "value" "0";
240
Added:
required;
241
Added:
];
242
Added:
];
243
Added:
tag "div"
244
Added:
[ class_ "field" ]
245
Added:
[
246
Added:
void "input"
247
Added:
[
248
Added:
type_ "checkbox";
249
Added:
name "allow_duplicate";
250
Added:
Dream_html.string_attr "id" "allow_duplicate";
251
Added:
value "true";
252
Added:
];
253
Added:
tag "label"
254
Added:
[ Dream_html.string_attr "for" "allow_duplicate" ]
255
Added:
[ txt "Import even if this export was imported before" ];
256
Added:
];
257
Added:
void "input" [ type_ "submit"; value "Upload import" ];
258
Added:
];
259
Added:
];
260
Added:
])
lib/presenter/pages_routine.ml
@@ -0,0 +1,197 @@
1
Added:
open Dream_html
2
Added:
open Page_kit
3
Added:
open Page_shell
4
Added:
5
Added:
let choose_routine request ~logging ~viewer
6
Added:
~(routines : View_model.Routine_choice.t list) =
7
Added:
html_page ~viewer ~request ~active:"home" ~logging "Choose a routine"
8
Added:
[
9
Added:
tag "h1" [] [ txt "Routines" ];
10
Added:
tag "div" []
11
Added:
(List.map
12
Added:
(fun (choice : View_model.Routine_choice.t) ->
13
Added:
tag "form"
14
Added:
[
15
Added:
action Routes.select_routine choice.id;
16
Added:
post_form;
17
Added:
Dream_html.attr "data-hito-app-form";
18
Added:
]
19
Added:
[
20
Added:
Dream_html.csrf_tag request;
21
Added:
tag "fieldset" []
22
Added:
[
23
Added:
tag "legend" [] [ txt "%s" choice.name ];
24
Added:
tag "p" []
25
Added:
[ txt "%d workouts in the cycle." choice.workout_count ];
26
Added:
void "input" [ type_ "submit"; value "Use this routine" ];
27
Added:
];
28
Added:
])
29
Added:
routines);
30
Added:
]
31
Added:
32
Added:
let begin_form request ~routine_id ~override label =
33
Added:
tag "form"
34
Added:
[ action Routes.workout; post_form; Dream_html.attr "data-hito-app-form" ]
35
Added:
[
36
Added:
Dream_html.csrf_tag request;
37
Added:
void "input"
38
Added:
[
39
Added:
type_ "hidden";
40
Added:
name "routine";
41
Added:
Dream_html.string_attr "value" "%s" routine_id;
42
Added:
];
43
Added:
void "input"
44
Added:
[
45
Added:
type_ "hidden";
46
Added:
name "override";
47
Added:
Dream_html.string_attr "value" "%s" (string_of_bool override);
48
Added:
];
49
Added:
void "input" [ type_ "submit"; value label ];
50
Added:
]
51
Added:
52
Added:
(* Beginning under override needs an explicit acknowledgement, so its submit is
53
Added:
gated behind a confirmation modal. Without script the form submits at once —
54
Added:
the doctrine's deviation stays possible. The modal only makes it deliberate.
55
Added:
The client reuses the shared confirm machinery: [data-hito-confirm-cancel]
56
Added:
opens the dialog, [data-hito-confirm-form] is the form its accept submits. *)
57
Added:
let override_begin request ~routine_id =
58
Added:
[
59
Added:
tag "form"
60
Added:
[
61
Added:
action Routes.workout;
62
Added:
post_form;
63
Added:
Dream_html.attr "data-hito-app-form";
64
Added:
Dream_html.attr "data-hito-confirm-form";
65
Added:
]
66
Added:
[
67
Added:
Dream_html.csrf_tag request;
68
Added:
void "input"
69
Added:
[
70
Added:
type_ "hidden";
71
Added:
name "routine";
72
Added:
Dream_html.string_attr "value" "%s" routine_id;
73
Added:
];
74
Added:
void "input"
75
Added:
[
76
Added:
type_ "hidden";
77
Added:
name "override";
78
Added:
Dream_html.string_attr "value" "true";
79
Added:
];
80
Added:
void "input"
81
Added:
[
82
Added:
type_ "submit";
83
Added:
value "Begin under override";
84
Added:
Dream_html.attr "data-hito-confirm-cancel";
85
Added:
];
86
Added:
];
87
Added:
tag "dialog"
88
Added:
[ class_ "confirm-dialog"; Dream_html.attr "data-hito-confirm-modal" ]
89
Added:
[
90
Added:
tag "h2" [] [ txt "Begin before recovery is complete?" ];
91
Added:
tag "p" []
92
Added:
[
93
Added:
txt
94
Added:
"Heavy Duty grows muscle during recovery, not in the gym. \
95
Added:
Training early can cut into it. This is recorded as an \
96
Added:
override.";
97
Added:
];
98
Added:
tag "div"
99
Added:
[ class_ "button-group" ]
100
Added:
[
101
Added:
tag "button"
102
Added:
[
103
Added:
type_ "button";
104
Added:
class_ "secondary";
105
Added:
Dream_html.attr "data-hito-confirm-dismiss";
106
Added:
]
107
Added:
[ txt "Wait to recover" ];
108
Added:
tag "button"
109
Added:
[ type_ "button"; Dream_html.attr "data-hito-confirm-accept" ]
110
Added:
[ txt "Begin under override" ];
111
Added:
];
112
Added:
];
113
Added:
]
114
Added:
115
Added:
let home request ~viewer ~home:(vm : View_model.Home.t) =
116
Added:
let status, gate =
117
Added:
match vm.gate with
118
Added:
| View_model.Home.Ready ->
119
Added:
( "Recovery is complete.",
120
Added:
[
121
Added:
begin_form request ~routine_id:vm.routine_id ~override:false
122
Added:
"Begin next workout";
123
Added:
] )
124
Added:
| View_model.Home.Recovering { status } ->
125
Added:
( status,
126
Added:
[
127
Added:
tag "div"
128
Added:
[ class_ "warn" ]
129
Added:
([
130
Added:
tag "p" []
131
Added:
[
132
Added:
txt "Heavy Duty requires recovery before the next workout.";
133
Added:
];
134
Added:
]
135
Added:
@ override_begin request ~routine_id:vm.routine_id);
136
Added:
] )
137
Added:
in
138
Added:
html_page ~viewer ~request ~active:"home" "Home"
139
Added:
([
140
Added:
tag "h1" [] [ txt "%s" vm.routine_name ];
141
Added:
tag "p" [ class_ "ledger-meta" ] [ txt "Next: %s" vm.next_workout ];
142
Added:
tag "p" [ class_ "ledger-meta" ] [ txt "%s" status ];
143
Added:
]
144
Added:
@ gate)
145
Added:
146
Added:
(* Home while a workout is in progress. Rather than the recovery gate or the
147
Added:
routine chooser, Home shows a single card: the workout is under way and one
148
Added:
tap returns to it. The middle navigation action already reads "Current
149
Added:
workout" here, and this card is the matching Home affordance. *)
150
Added:
let workout_in_progress request ~viewer ~workout_name =
151
Added:
html_page ~viewer ~request ~active:"home" ~logging:true "Home"
152
Added:
[
153
Added:
tag "a"
154
Added:
[
155
Added:
class_ "in-progress-card";
156
Added:
href Routes.workout;
157
Added:
Dream_html.attr "data-hito-app-link";
158
Added:
]
159
Added:
[
160
Added:
tag "p" [ class_ "eyebrow" ] [ txt "Workout in progress" ];
161
Added:
tag "h1" [] [ txt "%s" workout_name ];
162
Added:
tag "p" [] [ txt "Return to the current workout to keep logging." ];
163
Added:
];
164
Added:
]
165
Added:
166
Added:
let routine request ?(logging = false) ~viewer (vm : View_model.Routine.t) =
167
Added:
html_page ~viewer ~request ~active:"routine" ~logging "Routine"
168
Added:
[
169
Added:
tag "h1" [] [ txt "%s" vm.name ];
170
Added:
tag "div"
171
Added:
[ class_ "routine-accordions" ]
172
Added:
(List.map
173
Added:
(fun (workout : View_model.Routine.workout) ->
174
Added:
tag "details"
175
Added:
[ class_ "routine-accordion" ]
176
Added:
[
177
Added:
tag "summary" [] [ txt "%s" workout.name ];
178
Added:
tag "div"
179
Added:
[ class_ "routine-description" ]
180
Added:
[
181
Added:
tag "ul" []
182
Added:
(List.map
183
Added:
(fun (exercise : View_model.Routine.exercise) ->
184
Added:
tag "li" []
185
Added:
[
186
Added:
tag "span"
187
Added:
[ class_ "routine-exercise" ]
188
Added:
[ txt "%s" exercise.name ];
189
Added:
tag "span"
190
Added:
[ class_ "routine-reps" ]
191
Added:
[ txt "%s" exercise.reps ];
192
Added:
])
193
Added:
workout.exercises);
194
Added:
];
195
Added:
])
196
Added:
vm.workouts);
197
Added:
]
lib/presenter/pages_settings.ml
@@ -0,0 +1,35 @@
1
Added:
open Dream_html
2
Added:
open Page_kit
3
Added:
open Page_shell
4
Added:
5
Added:
(* The settings page. It currently stores the user's light or dark theme choice
6
Added:
in the session. *)
7
Added:
let settings request ?(logging = false) ~viewer ~theme () =
8
Added:
let next_theme, label =
9
Added:
match theme with
10
Added:
| "dark" -> ("light", "Use light theme")
11
Added:
| _ -> ("dark", "Use dark theme")
12
Added:
in
13
Added:
html_page ~viewer ~request ~active:"settings" ~logging "Settings"
14
Added:
[
15
Added:
tag "h1" [] [ txt "Settings" ];
16
Added:
tag "section"
17
Added:
[ class_ "settings-section" ]
18
Added:
[
19
Added:
tag "h2" [] [ txt "Theme" ];
20
Added:
tag "p" [] [ txt "Choose a light or dark theme for this session." ];
21
Added:
tag "form"
22
Added:
[ action Routes.settings_theme; post_form; class_ "settings-form" ]
23
Added:
[
24
Added:
Dream_html.csrf_tag request;
25
Added:
void "input"
26
Added:
[
27
Added:
type_ "hidden";
28
Added:
name "theme";
29
Added:
Dream_html.string_attr "value" "%s" next_theme;
30
Added:
];
31
Added:
void "input"
32
Added:
[ type_ "submit"; Dream_html.string_attr "value" "%s" label ];
33
Added:
];
34
Added:
];
35
Added:
]
lib/presenter/pages_workout.ml
@@ -0,0 +1,466 @@
1
Added:
open Dream_html
2
Added:
open Page_kit
3
Added:
open Page_shell
4
Added:
5
Added:
let error_id input_id = input_id ^ "-error"
6
Added:
7
Added:
let extension_select ?(selected = "") ?(invalid = false) ~input_id () =
8
Added:
let error_attrs =
9
Added:
if invalid then
10
Added:
[
11
Added:
Dream_html.string_attr "aria-invalid" "true";
12
Added:
Dream_html.string_attr "aria-describedby" "%s" (error_id input_id);
13
Added:
]
14
Added:
else []
15
Added:
in
16
Added:
let option (code : string) label =
17
Added:
let attrs = [ Dream_html.string_attr "value" "%s" code ] in
18
Added:
let attrs =
19
Added:
if String.equal code selected then Dream_html.attr "selected" :: attrs
20
Added:
else attrs
21
Added:
in
22
Added:
tag "option" attrs [ txt "%s" label ]
23
Added:
in
24
Added:
tag "select"
25
Added:
([ name "extension"; Dream_html.string_attr "id" "%s" input_id ]
26
Added:
@ error_attrs)
27
Added:
[
28
Added:
option "" "to positive failure";
29
Added:
option "forced" "then forced reps";
30
Added:
option "negatives" "then negatives";
31
Added:
option "rest-pause" "then rest-pause";
32
Added:
option "static" "then a static hold";
33
Added:
]
34
Added:
35
Added:
let error_for ~input_id (field : string) (errors : (string * string) list) =
36
Added:
match List.assoc_opt field errors with
37
Added:
| None -> []
38
Added:
| Some error ->
39
Added:
[
40
Added:
tag "p"
41
Added:
[
42
Added:
Dream_html.string_attr "id" "%s" (error_id input_id);
43
Added:
class_ "warn";
44
Added:
Dream_html.string_attr "role" "alert";
45
Added:
]
46
Added:
[ txt "%s" (errors_to_text [ (field, error) ]) ];
47
Added:
]
48
Added:
49
Added:
let input_row ?value:v ?(invalid = false) ?placeholder ?(hide_label = false)
50
Added:
~input_id (field : string) label =
51
Added:
let error_attrs =
52
Added:
if invalid then
53
Added:
[
54
Added:
Dream_html.string_attr "aria-invalid" "true";
55
Added:
Dream_html.string_attr "aria-describedby" "%s" (error_id input_id);
56
Added:
]
57
Added:
else []
58
Added:
in
59
Added:
let placeholder_attr =
60
Added:
match placeholder with
61
Added:
| None -> []
62
Added:
| Some p -> [ Dream_html.string_attr "placeholder" "%s" p ]
63
Added:
in
64
Added:
tag "div"
65
Added:
[ class_ "field" ]
66
Added:
[
67
Added:
tag "label"
68
Added:
[
69
Added:
Dream_html.string_attr "for" "%s" input_id;
70
Added:
class_ (if hide_label then "sr-only" else "");
71
Added:
]
72
Added:
[ txt "%s" label ];
73
Added:
void "input"
74
Added:
([
75
Added:
type_ "number";
76
Added:
Dream_html.string_attr "name" "%s" field;
77
Added:
Dream_html.string_attr "id" "%s" input_id;
78
Added:
step "0.5";
79
Added:
required;
80
Added:
]
81
Added:
@ placeholder_attr @ error_attrs
82
Added:
@
83
Added:
match v with
84
Added:
| None -> []
85
Added:
| Some v -> [ Dream_html.string_attr "value" "%s" v ]);
86
Added:
]
87
Added:
88
Added:
(* A movement's fields as cells of the fieldset grid: the exercise name, the
89
Added:
load input, and the reps input. The cells are direct participants of the one
90
Added:
[.logging-grid] the fieldset wraps them in — a [display: contents] wrapper
91
Added:
groups a movement without opening a nested grid — so every movement's name,
92
Added:
load, and reps columns line up across the whole fieldset. The name reads as a
93
Added:
heading, the inputs as labelled fields. *)
94
Added:
let movement_row ~(errors : (string * string) list) ~name ~load_id ~load_field
95
Added:
~reps_id ~reps_field ?load_value ?reps_value ~reps_label
96
Added:
?(hide_labels = false) () =
97
Added:
tag "div"
98
Added:
[ class_ "movement" ]
99
Added:
[
100
Added:
tag "p" [ class_ "exercise-name" ] [ txt "%s" name ];
101
Added:
input_row ?value:load_value ~placeholder:"kg" ~hide_label:hide_labels
102
Added:
~invalid:(List.mem_assoc load_field errors)
103
Added:
~input_id:load_id load_field "Load (kg)";
104
Added:
input_row ?value:reps_value ~placeholder:"reps" ~hide_label:hide_labels
105
Added:
~invalid:(List.mem_assoc reps_field errors)
106
Added:
~input_id:reps_id reps_field reps_label;
107
Added:
]
108
Added:
109
Added:
(* A shared heading row for a multi-exercise group: empty name cell, then the
110
Added:
Load and Reps column headings. Rendered once as cells of the fieldset grid so
111
Added:
the labels are not repeated above every input. *)
112
Added:
let exercise_fields_head ~reps_label () =
113
Added:
tag "div"
114
Added:
[ class_ "movement movement-head" ]
115
Added:
[
116
Added:
tag "span" [ class_ "exercise-name" ] [ txt "" ];
117
Added:
tag "span" [ class_ "col-heading" ] [ txt "Load (kg)" ];
118
Added:
tag "span" [ class_ "col-heading" ] [ txt "%s" reps_label ];
119
Added:
]
120
Added:
121
Added:
(* [movements] carries the record/correction field spec the controller built
122
Added:
from the slot's prescription: one row for a single exercise, two for a
123
Added:
pre-exhaust pair, each already pre-filled when correcting. [submit] names the
124
Added:
action. Load and reps of each movement are laid out side by side. *)
125
Added:
let form_for_stimulus request ~action_path ~slot
126
Added:
~(movements : View_model.Workout.movement list) ~selected_extension
127
Added:
?(enhanced = false) ?(submit = "Record") ~(errors : (string * string) list)
128
Added:
() =
129
Added:
let field_id field = Printf.sprintf "slot-%d-%s" slot field in
130
Added:
let selected = selected_extension in
131
Added:
(* A single-exercise slot shows one row with a visible "Reps to failure"
132
Added:
label. A pre-exhaust pair shows a shared column heading and hides the
133
Added:
per-row labels. *)
134
Added:
let hide_labels = List.length movements > 1 in
135
Added:
let head =
136
Added:
match movements with
137
Added:
| first :: _ :: _ ->
138
Added:
[
139
Added:
exercise_fields_head ~reps_label:first.View_model.Workout.reps_label
140
Added:
();
141
Added:
]
142
Added:
| _ -> []
143
Added:
in
144
Added:
let movement_of (m : View_model.Workout.movement) =
145
Added:
movement_row ~errors ~name:m.name ~load_id:(field_id m.load_field)
146
Added:
~load_field:m.load_field ~reps_id:(field_id m.reps_field)
147
Added:
~reps_field:m.reps_field ?load_value:m.load_value ?reps_value:m.reps_value
148
Added:
~reps_label:m.reps_label ~hide_labels ()
149
Added:
in
150
Added:
let fields = head @ List.map movement_of movements in
151
Added:
(* The error rows follow the fields present, so a single-exercise slot reports
152
Added:
load/reps and a pre-exhaust slot reports the iso/comp fields. *)
153
Added:
let field_names =
154
Added:
List.concat_map
155
Added:
(fun (m : View_model.Workout.movement) -> [ m.load_field; m.reps_field ])
156
Added:
movements
157
Added:
@ [ "extension" ]
158
Added:
in
159
Added:
tag "form"
160
Added:
([ action_path; post_form ]
161
Added:
@
162
Added:
if enhanced then [ Dream_html.attr "data-hito-workout-form" ]
163
Added:
else [ Dream_html.attr "data-hito-app-form" ])
164
Added:
[
165
Added:
Dream_html.csrf_tag request;
166
Added:
tag "fieldset"
167
Added:
[ class_ "logging-fieldset" ]
168
Added:
(tag "div"
169
Added:
[ class_ "logging-grid" ]
170
Added:
(fields
171
Added:
@ [
172
Added:
tag "div"
173
Added:
[ class_ "field field-ending" ]
174
Added:
[
175
Added:
tag "label"
176
Added:
[
177
Added:
Dream_html.string_attr "for" "%s" (field_id "extension");
178
Added:
]
179
Added:
[ txt "Ending" ];
180
Added:
extension_select ~selected
181
Added:
~invalid:(List.mem_assoc "extension" errors)
182
Added:
~input_id:(field_id "extension") ();
183
Added:
];
184
Added:
])
185
Added:
:: List.concat_map
186
Added:
(fun field -> error_for ~input_id:(field_id field) field errors)
187
Added:
field_names
188
Added:
@ [
189
Added:
void "input"
190
Added:
[ type_ "submit"; Dream_html.string_attr "value" "%s" submit ];
191
Added:
]);
192
Added:
]
193
Added:
194
Added:
let workout request ~viewer ?(errors = []) ?editing ?logging ~record_id
195
Added:
~active_slot (vm : View_model.Workout.t) =
196
Added:
let enhanced = Option.is_none record_id in
197
Added:
(* A live workout view is itself the workout in progress, so the middle nav
198
Added:
action reads "Current workout". A saved-record view defers to the handler,
199
Added:
which knows whether a separate workout is in progress. *)
200
Added:
let logging = Option.value logging ~default:enhanced in
201
Added:
let slot_count = List.length vm.slots in
202
Added:
let filled_slots =
203
Added:
List.length
204
Added:
(List.filter
205
Added:
(fun (s : View_model.Workout.slot) ->
206
Added:
Option.is_some s.recorded_summary)
207
Added:
vm.slots)
208
Added:
in
209
Added:
let record_action slot =
210
Added:
match record_id with
211
Added:
| None -> action Routes.workout_slot slot
212
Added:
| Some record_id -> action Routes.record_slot record_id slot
213
Added:
in
214
Added:
let edit_action slot =
215
Added:
match record_id with
216
Added:
| None -> action Routes.workout_slot_edit slot
217
Added:
| Some record_id -> action Routes.record_slot_edit record_id slot
218
Added:
in
219
Added:
(* The early-workout notice. The override was already confirmed in a modal, so
220
Added:
on the workout screen this is informational only: a toast rather than a
221
Added:
component in the main content. It is a polite live region. The client shows
222
Added:
it briefly then dismisses it. Without script it stays visible as a quiet
223
Added:
fixed notice, so a no-JS visitor is still told. *)
224
Added:
let override_note =
225
Added:
if vm.overridden then
226
Added:
[
227
Added:
tag "div"
228
Added:
[
229
Added:
class_ "toast";
230
Added:
Dream_html.attr "data-hito-toast";
231
Added:
Dream_html.string_attr "role" "status";
232
Added:
Dream_html.string_attr "aria-live" "polite";
233
Added:
]
234
Added:
[ txt "Begun before recovery finished." ];
235
Added:
]
236
Added:
else []
237
Added:
in
238
Added:
(* The exercise selector: a dropdown naming every prescription slot. Choosing
239
Added:
an option opens that exercise below. The selector is a GET form so it works
240
Added:
without script — submitting navigates to the slot via a [?slot=] query, the
241
Added:
same contract the panel already reads. The client enhances it: it navigates
242
Added:
the moment the selection changes, so the submit button is a no-JS fallback.
243
Added:
A recorded slot is marked done in its label. *)
244
Added:
let select_action_base =
245
Added:
match record_id with None -> "/workout" | Some id -> "/logbook/" ^ id
246
Added:
in
247
Added:
let exercise_group =
248
Added:
let option_for (slot : View_model.Workout.slot) =
249
Added:
let done_ = Option.is_some slot.recorded_summary in
250
Added:
let label =
251
Added:
if done_ then Printf.sprintf "%d. %s (done)" (slot.index + 1) slot.label
252
Added:
else Printf.sprintf "%d. %s" (slot.index + 1) slot.label
253
Added:
in
254
Added:
let attrs = [ Dream_html.string_attr "value" "%d" slot.index ] in
255
Added:
let attrs =
256
Added:
if slot.index = active_slot then Dream_html.attr "selected" :: attrs
257
Added:
else attrs
258
Added:
in
259
Added:
tag "option" attrs [ txt "%s" label ]
260
Added:
in
261
Added:
let form_attrs =
262
Added:
[
263
Added:
Dream_html.string_attr "method" "get";
264
Added:
Dream_html.string_attr "action" "%s" select_action_base;
265
Added:
class_ "exercise-select";
266
Added:
]
267
Added:
in
268
Added:
let form_attrs =
269
Added:
if enhanced then Dream_html.attr "data-hito-exercise-form" :: form_attrs
270
Added:
else form_attrs
271
Added:
in
272
Added:
tag "form" form_attrs
273
Added:
[
274
Added:
tag "label"
275
Added:
[ Dream_html.string_attr "for" "exercise-choice"; class_ "sr-only" ]
276
Added:
[ txt "Exercise" ];
277
Added:
tag "select"
278
Added:
[
279
Added:
name "slot";
280
Added:
id "exercise-choice";
281
Added:
Dream_html.attr "data-hito-exercise-select";
282
Added:
]
283
Added:
(List.map option_for vm.slots);
284
Added:
void "input"
285
Added:
[
286
Added:
type_ "submit"; class_ "secondary exercise-select-go"; value "Open";
287
Added:
];
288
Added:
]
289
Added:
in
290
Added:
(* The panel for the active slot. It shows one exercise at a time: a recorded
291
Added:
slot renders its read-only summary and a pre-filled correction form (which
292
Added:
replaces the slot rather than adding volume). An outstanding slot renders
293
Added:
the record form. *)
294
Added:
let active_panel =
295
Added:
match List.nth_opt vm.slots active_slot with
296
Added:
| None ->
297
Added:
[
298
Added:
tag "p"
299
Added:
[ class_ "warn" ]
300
Added:
[ txt "That exercise is not part of this workout." ];
301
Added:
]
302
Added:
| Some (slot : View_model.Workout.slot) ->
303
Added:
let errors = if editing = Some active_slot then errors else [] in
304
Added:
let heading = tag "h2" [] [ txt "%s" slot.label ] in
305
Added:
let body =
306
Added:
match slot.recorded_summary with
307
Added:
| Some summary ->
308
Added:
[
309
Added:
tag "p" [ class_ "eyebrow" ] [ txt "Recorded" ];
310
Added:
tag "p" [ class_ "done" ] [ txt "%s" summary ];
311
Added:
form_for_stimulus request ~action_path:(edit_action active_slot)
312
Added:
~slot:active_slot ~movements:slot.movements
313
Added:
~selected_extension:slot.selected_extension ~enhanced
314
Added:
~submit:"Save correction" ~errors ();
315
Added:
]
316
Added:
| None ->
317
Added:
[
318
Added:
form_for_stimulus request
319
Added:
~action_path:(record_action active_slot)
320
Added:
~slot:active_slot ~movements:slot.movements
321
Added:
~selected_extension:slot.selected_extension ~enhanced ~errors
322
Added:
();
323
Added:
]
324
Added:
in
325
Added:
[ tag "section" [ class_ "slot-panel" ] (heading :: body) ]
326
Added:
in
327
Added:
let complete_note =
328
Added:
if vm.all_recorded then
329
Added:
[
330
Added:
tag "p"
331
Added:
[ class_ "done" ]
332
Added:
[ txt "Everything prescribed has been recorded." ];
333
Added:
]
334
Added:
else []
335
Added:
in
336
Added:
(* A sticky timer bar for the workout in progress. It carries the workout's
337
Added:
start time as an epoch, and the client ticks the elapsed time from it.
338
Added:
Reading the true start on every render means an SPA content swap never
339
Added:
resets the count. Only the live workout shows it. *)
340
Added:
let timer_bar =
341
Added:
if enhanced then
342
Added:
let started = vm.started_at_unix in
343
Added:
[
344
Added:
tag "div"
345
Added:
[
346
Added:
class_ "workout-timer";
347
Added:
Dream_html.attr "data-hito-workout-timer";
348
Added:
Dream_html.string_attr "data-started" "%d" started;
349
Added:
]
350
Added:
[
351
Added:
tag "span" [ class_ "workout-timer-label" ] [ txt "Elapsed" ];
352
Added:
tag "span"
353
Added:
[
354
Added:
class_ "workout-timer-value";
355
Added:
Dream_html.string_attr "aria-live" "off";
356
Added:
Dream_html.attr "data-hito-workout-timer-value";
357
Added:
]
358
Added:
[ txt "0:00" ];
359
Added:
];
360
Added:
]
361
Added:
else []
362
Added:
in
363
Added:
let finish_section =
364
Added:
match record_id with
365
Added:
| Some _ -> []
366
Added:
| None ->
367
Added:
[
368
Added:
tag "div"
369
Added:
[ class_ "button-group" ]
370
Added:
[
371
Added:
tag "form"
372
Added:
[
373
Added:
action Routes.finish_workout;
374
Added:
post_form;
375
Added:
Dream_html.attr "data-hito-app-form";
376
Added:
]
377
Added:
[
378
Added:
Dream_html.csrf_tag request;
379
Added:
void "input" [ type_ "submit"; value "Finish workout" ];
380
Added:
];
381
Added:
(* Cancel is a native POST form. Without script, it submits
382
Added:
immediately. The client only opens the confirm dialog. Its
383
Added:
acceptance submits this form as a full document navigation so
384
Added:
the cancelled workout cannot leave a stale app shell behind. *)
385
Added:
tag "form"
386
Added:
[
387
Added:
action Routes.cancel_workout;
388
Added:
post_form;
389
Added:
Dream_html.attr "data-hito-confirm-form";
390
Added:
Dream_html.attr "data-hito-cancel-form";
391
Added:
]
392
Added:
[
393
Added:
Dream_html.csrf_tag request;
394
Added:
void "input"
395
Added:
[
396
Added:
type_ "submit";
397
Added:
class_ "secondary";
398
Added:
value "Cancel logging";
399
Added:
Dream_html.attr "data-hito-confirm-cancel";
400
Added:
];
401
Added:
];
402
Added:
];
403
Added:
(* The confirmation modal. Native dialog for built-in focus trapping
404
Added:
and Escape-to-close. The client opens it. "Cancel workout" submits
405
Added:
the cancel form, "Keep logging" closes it. *)
406
Added:
tag "dialog"
407
Added:
[
408
Added:
class_ "confirm-dialog"; Dream_html.attr "data-hito-confirm-modal";
409
Added:
]
410
Added:
[
411
Added:
tag "h2" [] [ txt "Cancel this workout?" ];
412
Added:
tag "p" []
413
Added:
[
414
Added:
txt
415
Added:
"The workout is discarded and leaves no record, then you \
416
Added:
return Home.";
417
Added:
];
418
Added:
tag "div"
419
Added:
[ class_ "button-group" ]
420
Added:
[
421
Added:
tag "button"
422
Added:
[
423
Added:
type_ "button";
424
Added:
class_ "secondary";
425
Added:
Dream_html.attr "data-hito-confirm-dismiss";
426
Added:
]
427
Added:
[ txt "Keep logging" ];
428
Added:
tag "button"
429
Added:
[
430
Added:
type_ "button"; Dream_html.attr "data-hito-confirm-accept";
431
Added:
]
432
Added:
[ txt "Cancel workout" ];
433
Added:
];
434
Added:
];
435
Added:
]
436
Added:
in
437
Added:
html_page ~viewer ~request ~active:"workout" ~logging vm.name
438
Added:
[
439
Added:
tag "div"
440
Added:
(if enhanced then
441
Added:
[
442
Added:
Dream_html.attr "data-hito-workout";
443
Added:
Dream_html.attr "data-hito-workout-content";
444
Added:
]
445
Added:
else [])
446
Added:
(timer_bar @ override_note
447
Added:
@ [
448
Added:
tag "h1" [] [ txt "%s" vm.name ];
449
Added:
tag "p"
450
Added:
[ class_ "ledger-meta" ]
451
Added:
[ txt "%d of %d recorded." filled_slots slot_count ];
452
Added:
exercise_group;
453
Added:
]
454
Added:
@ active_panel @ complete_note @ finish_section
455
Added:
@
456
Added:
if enhanced then
457
Added:
[
458
Added:
tag "p"
459
Added:
[
460
Added:
Dream_html.string_attr "aria-live" "polite";
461
Added:
Dream_html.attr "data-hito-workout-status";
462
Added:
]
463
Added:
[];
464
Added:
]
465
Added:
else []);
466
Added:
]
lib/presenter/routes.ml
@@ -0,0 +1,39 @@
1
Added:
(* The path values carry format types that are inferred and checked at each use.
2
Added:
Writing an interface for them would add noise without adding safety. *)
3
Added:
4
Added:
let%path home = "/"
5
Added:
let%path register = "/register"
6
Added:
let%path login = "/login"
7
Added:
let%path logout = "/logout"
8
Added:
let%path routines = "/routines"
9
Added:
let%path select_routine = "/routines/%s/select"
10
Added:
let%path routine = "/routine"
11
Added:
let%path workout = "/workout"
12
Added:
let%path workout_slot = "/workout/slots/%d"
13
Added:
let%path workout_slot_edit = "/workout/slots/%d/edit"
14
Added:
let%path finish_workout = "/workout/finish"
15
Added:
let%path cancel_workout = "/workout/cancel"
16
Added:
let%path logbook = "/logbook"
17
Added:
let%path profile = "/profile"
18
Added:
let%path settings = "/settings"
19
Added:
let%path settings_theme = "/settings/theme"
20
Added:
let%path profile_username = "/profile/username"
21
Added:
let%path profile_password = "/profile/password"
22
Added:
let%path import_upload = "/profile/import"
23
Added:
let%path import_review = "/profile/import/%s"
24
Added:
let%path import_map = "/profile/import/%s/workouts/%s/map"
25
Added:
let%path import_confirm = "/profile/import/%s/workouts/%s/confirm"
26
Added:
let%path import_promote_workout = "/profile/import/%s/workouts/%s/promote"
27
Added:
let%path import_promote_batch = "/profile/import/%s/promote"
28
Added:
let%path app_feedback = "/app-feedback"
29
Added:
let%path submit_app_feedback = "/app-feedback/submit"
30
Added:
let%path upvote_app_feedback = "/app-feedback/%s/upvote"
31
Added:
let%path edit_app_feedback = "/app-feedback/%s/edit"
32
Added:
let%path remove_app_feedback = "/app-feedback/%s/remove"
33
Added:
let%path feedback = "/feedback"
34
Added:
let%path cancel_feedback = "/feedback/cancel"
35
Added:
let%path record = "/logbook/%s"
36
Added:
let%path record_slot = "/logbook/%s/slots/%d"
37
Added:
let%path record_slot_edit = "/logbook/%s/slots/%d/edit"
38
Added:
let%path stylesheet = "/assets/hito.css"
39
Added:
let%path workout_client = "/assets/workout-client.js"
lib/presenter/view_model.ml
@@ -0,0 +1,183 @@
1
Added:
(** View models: the simple data structures the presenter renders.
2
Added:
3
Added:
The Clean Architecture rule for crossing a boundary is that the data passed
4
Added:
is a plain structure, never an entity or a database row. These DTOs are that
5
Added:
structure. A handler (the controller) maps a repository record or a core
6
Added:
entity into a view model, and the presenter ({!Pages}) renders the view
7
Added:
model without ever naming an inner-circle type.
8
Added:
9
Added:
Every page now crosses the boundary as a DTO. No page names a core entity.
10
Added:
Add a page DTO here before the presenter renders it. *)
11
Added:
12
Added:
module Viewer = struct
13
Added:
type t = { username : string }
14
Added:
(** The signed-in trainee, as the shell needs them: a name to show, nothing
15
Added:
more. Replaces passing the [Trainee.t] entity into the presenter. *)
16
Added:
end
17
Added:
18
Added:
module App_feedback = struct
19
Added:
type t = {
20
Added:
id : string; (** Opaque feedback identity, already stringified. *)
21
Added:
author : string;
22
Added:
contributions : int;
23
Added:
submitted_at : string; (** Pre-formatted "YYYY-MM-DD HH:MM" in UTC. *)
24
Added:
message : string;
25
Added:
upvotes : int;
26
Added:
viewer_upvoted : bool;
27
Added:
viewer_owns : bool;
28
Added:
}
29
Added:
(** One application-feedback entry, ready to render. Carries no timestamp
30
Added:
type, no opaque id, no repository record — only what the view shows. *)
31
Added:
end
32
Added:
33
Added:
module Feedback = struct
34
Added:
type report = {
35
Added:
at_unix : int; (** Report time in Unix seconds, for chronological order. *)
36
Added:
signals : string list; (** Each signal already described, for the list. *)
37
Added:
factor_scores : (string * int option) list;
38
Added:
(** Score per leveled factor field, aligned with the factor order the
39
Added:
presenter graphs. [None] where the report gave that factor no level.
40
Added:
Flags such as pain carry no score and are absent here. *)
41
Added:
}
42
Added:
(** One subjective-feedback report, ready to render. Carries no
43
Added:
[Evidence.Feedback] variant and no timestamp type. *)
44
Added:
end
45
Added:
46
Added:
module Routine = struct
47
Added:
type exercise = { name : string; reps : string }
48
Added:
(** One prescribed exercise line, its name and rep band already phrased. *)
49
Added:
50
Added:
type workout = { name : string; exercises : exercise list }
51
Added:
52
Added:
type t = { name : string; workouts : workout list }
53
Added:
(** A routine as the accordion descriptions render it: names, numeric rep
54
Added:
bands, and workout grouping only. No [Prescription] entity. *)
55
Added:
end
56
Added:
57
Added:
module Routine_choice = struct
58
Added:
type t = { id : string; name : string; workout_count : int }
59
Added:
(** One selectable routine on the chooser: its id for the select form, its
60
Added:
name, and how many workouts the cycle holds. *)
61
Added:
end
62
Added:
63
Added:
module Home = struct
64
Added:
type gate =
65
Added:
| Ready
66
Added:
| Recovering of { status : string }
67
Added:
(** Whether the next workout may begin, and the recovery status line to
68
Added:
show while it may not. *)
69
Added:
70
Added:
type t = {
71
Added:
routine_id : string; (** For the begin/override forms. *)
72
Added:
routine_name : string;
73
Added:
next_workout : string;
74
Added:
gate : gate;
75
Added:
}
76
Added:
(** The overview while no workout is in progress. The recovery policy has
77
Added:
already decided [gate] in the use case. The page only renders it. *)
78
Added:
end
79
Added:
80
Added:
module Workout = struct
81
Added:
type movement = {
82
Added:
name : string; (** The exercise name shown for this input row. *)
83
Added:
load_field : string; (** Form field name for the load input. *)
84
Added:
reps_field : string; (** Form field name for the reps input. *)
85
Added:
reps_label : string;
86
Added:
load_value : string option;
87
Added:
(** Pre-fill when correcting a recorded slot. *)
88
Added:
reps_value : string option;
89
Added:
}
90
Added:
(** One input row of a slot's record/correction form. The controller emits one
91
Added:
movement for a single-exercise slot and two for a pre-exhaust pair, so the
92
Added:
presenter renders whatever movements it is given and never inspects the
93
Added:
prescription's [delivery] shape itself. *)
94
Added:
95
Added:
type slot = {
96
Added:
index : int;
97
Added:
label : string; (** Exercise label for the selector option and heading. *)
98
Added:
movements : movement list;
99
Added:
recorded_summary : string option;
100
Added:
(** [Some description] once the slot is filled. [None] while
101
Added:
outstanding. Drives the recorded/outstanding branch without an
102
Added:
entity. *)
103
Added:
selected_extension : string;
104
Added:
(** The ending code to pre-select when correcting a recorded slot ("",
105
Added:
"forced", "negatives", "rest-pause", "static"). "" for an
106
Added:
outstanding slot. *)
107
Added:
}
108
Added:
109
Added:
type t = {
110
Added:
name : string; (** The workout (prescription) name, for the page title. *)
111
Added:
slots : slot list;
112
Added:
active_slot : int;
113
Added:
started_at_unix : int; (** Workout start, for the elapsed timer. *)
114
Added:
overridden : bool; (** Begun before recovery finished. *)
115
Added:
all_recorded : bool; (** Every prescribed slot has a record. *)
116
Added:
}
117
Added:
(** A workout view: the slot the trainee is on, the record/correction state of
118
Added:
each slot, and the timer and override facts. Carries no Evidence or
119
Added:
Prescription entity. Extension/ending selection stays in the presenter
120
Added:
form, since its option set is fixed UI vocabulary, not domain data. *)
121
Added:
end
122
Added:
123
Added:
module Logbook_entry = struct
124
Added:
type t = {
125
Added:
id : string; (** Record id for the link. *)
126
Added:
workout_name : string;
127
Added:
stimuli_count : int;
128
Added:
complete : bool;
129
Added:
}
130
Added:
(** One saved workout as the logbook list shows it: a link, a name, how many
131
Added:
stimuli it holds, and whether it is complete. No Repository record and no
132
Added:
Evidence.Workout entity. *)
133
Added:
end
134
Added:
135
Added:
module Import_warning = struct
136
Added:
type t = {
137
Added:
row : int; (** The source row that the adapter dropped. *)
138
Added:
detail : string; (** Why the row was dropped, already phrased. *)
139
Added:
}
140
Added:
(** One dropped import row, ready to render. The controller phrases the
141
Added:
reason, so no adapter warning variant crosses the boundary. *)
142
Added:
end
143
Added:
144
Added:
module Import_set = struct
145
Added:
type t = {
146
Added:
row : int; (** The source row, for provenance. *)
147
Added:
exercise_name : string; (** The export's exercise name, before mapping. *)
148
Added:
set_type : string; (** The set type, already phrased. *)
149
Added:
weight : string; (** The load, already formatted. *)
150
Added:
reps : string; (** The rep count, already formatted. *)
151
Added:
mapping : string option;
152
Added:
(** The catalog exercise name this set maps to, when confirmed. *)
153
Added:
}
154
Added:
(** One provisional import set, ready to render. Carries only strings, no
155
Added:
source-set entity. *)
156
Added:
end
157
Added:
158
Added:
module Import_workout = struct
159
Added:
type t = {
160
Added:
id : string; (** The workout id, for the per-workout forms. *)
161
Added:
title : string;
162
Added:
sets : Import_set.t list;
163
Added:
blockers : string list;
164
Added:
(** Why the workout cannot promote yet, each already phrased. Empty when
165
Added:
the workout can promote. *)
166
Added:
acknowledgement : string option;
167
Added:
(** The retained normal-set acknowledgement, when present. *)
168
Added:
revision : int; (** The workout revision, for provenance display. *)
169
Added:
}
170
Added:
(** One provisional import workout, ready to render: its sets, its blockers,
171
Added:
and its acknowledgement state. No Workout_import entity. *)
172
Added:
end
173
Added:
174
Added:
module Import_review = struct
175
Added:
type t = {
176
Added:
batch_id : string;
177
Added:
warnings : Import_warning.t list;
178
Added:
workouts : Import_workout.t list;
179
Added:
}
180
Added:
(** A provisional import batch under review: the rows dropped on parse and the
181
Added:
workouts awaiting cleaning and promotion. No batch entity crosses the
182
Added:
boundary. *)
183
Added:
end
lib/web/dune
@@ -29,14 +29,21 @@
29
29
(name hito_web)
30
30
(public_name hito.web)
31
31
(modules
32
Removed:
routes
33
32
decode
34
33
hevy_csv
35
Removed:
view_model
36
Removed:
pages
34
Added:
handlers_assets
35
Added:
handlers_kit
36
Added:
handlers_auth
37
Added:
handlers_overview
38
Added:
handlers_current_workout
39
Added:
handlers_logbook
40
Added:
handlers_app_feedback
41
Added:
handlers_profile
42
Added:
handlers_settings
43
Added:
handlers_import
37
44
handlers
38
45
stylesheet
39
46
workout_client_asset)
40
47
(preprocess
41
48
(pps dream-html.ppx))
42
Removed:
(libraries hito.core hito.app dream dream-html lwt unix csv))
49
Added:
(libraries hito.core hito.app hito.presenter dream dream-html lwt unix csv))
lib/web/handlers.ml
@@ -1,1613 +1,25 @@
1
1
open Lwt.Infix
2
2
open Hito_app
3
Removed:
4
Removed:
module Make (R : Repository.S) (H : Password_hash.S) = struct
5
Removed:
module Service = Service.Make (R) (H)
6
Removed:
7
Removed:
type t = {
8
Removed:
service : Service.t;
9
Removed:
now : unit -> Recovery.timestamp;
10
Removed:
registration_open : bool;
11
Removed:
}
12
Removed:
13
Removed:
let default_now () =
14
Removed:
Recovery.timestamp_of_unix_seconds (int_of_float (Unix.gettimeofday ()))
15
Removed:
16
Removed:
let make ~repo ?(now = default_now) ?(registration_open = false) () =
17
Removed:
{ service = Service.make ~repo; now; registration_open }
18
Removed:
19
Removed:
let flash_key = "hito.flash"
20
Removed:
let html ?status page = Dream_html.respond ?status page
21
Removed:
let redirect request path = Dream_html.redirect request path
22
Removed:
23
Removed:
let redirect_to request path =
24
Removed:
redirect request (Dream_html.path_attr Dream_html.HTML.href path)
25
Removed:
26
Removed:
let redirect_with_flash request path message =
27
Removed:
Dream.set_session_field request flash_key message >>= fun () ->
28
Removed:
redirect_to request path
29
Removed:
30
Removed:
let redirect_with_flash_attr request path message =
31
Removed:
Dream.set_session_field request flash_key message >>= fun () ->
32
Removed:
redirect request path
33
Removed:
34
Removed:
let redirect_with_flash_raw request path message =
35
Removed:
Dream.set_session_field request flash_key message >>= fun () ->
36
Removed:
Dream.redirect request path
37
Removed:
38
Removed:
let not_found detail =
39
Removed:
html (Pages.problem ~title:"Not found" ~detail) ~status:`Not_Found
40
Removed:
41
Removed:
let bad_request detail =
42
Removed:
html (Pages.problem ~title:"Invalid request" ~detail) ~status:`Bad_Request
43
Removed:
44
Removed:
(* --- presentation of errors ---
45
Removed:
46
Removed:
Every domain and service error becomes a user-facing sentence here, so a
47
Removed:
handler renders a message rather than deciding its wording. One module owns
48
Removed:
the phrasing, and adding an error variant surfaces as a missing case. *)
49
Removed:
module Present = struct
50
Removed:
let form_invalid = "The submitted form is not valid."
51
Removed:
52
Removed:
let registration : Service.register_error -> string = function
53
Removed:
| `Username e -> Format.asprintf "%a" Trainee.pp_username_error e
54
Removed:
| `Username_taken -> "That username is already registered."
55
Removed:
56
Removed:
let sign_in_failed = "That username and password do not match."
57
Removed:
let routine = Format.asprintf "%a" Service.pp_error
58
Removed:
59
Removed:
let log_error : Service.log_error -> string = function
60
Removed:
| Service.No_workout_in_progress -> "No workout is in progress."
61
Removed:
| Service.Rejected error ->
62
Removed:
Format.asprintf "%a" Evidence.Workout.pp_error error
63
Removed:
64
Removed:
let edit_error : Service.edit_error -> string = function
65
Removed:
| Service.Unknown_workout -> "That saved workout no longer exists."
66
Removed:
| Service.Rejected_edit error ->
67
Removed:
Format.asprintf "%a" Evidence.Workout.pp_error error
68
Removed:
69
Removed:
let unknown_routine = "That routine is not in the catalogue."
70
Removed:
let unknown_record = "That saved workout no longer exists."
71
Removed:
let no_workout = "No workout is in progress."
72
Removed:
let slot_not_awaiting = "That slot is not awaiting a record."
73
Removed:
74
Removed:
let change_username : Service.change_username_error -> string = function
75
Removed:
| `Username e -> Format.asprintf "%a" Trainee.pp_username_error e
76
Removed:
| `Username_taken -> "That username is already registered."
77
Removed:
| `Unknown -> "That account no longer exists."
78
Removed:
79
Removed:
let change_password : Service.change_password_error -> string = function
80
Removed:
| `Incorrect_password -> "The current password is not correct."
81
Removed:
| `Unknown -> "That account no longer exists."
82
Removed:
83
Removed:
let app_feedback_empty = "Enter feedback before submitting."
84
Removed:
let username_changed = "Username changed."
85
Removed:
let password_changed = "Password changed."
86
Removed:
end
87
Removed:
88
Removed:
(* --- sessions and authentication --- *)
89
Removed:
90
Removed:
let session_key = "trainee"
91
Removed:
92
Removed:
let current_trainee t request =
93
Removed:
match Dream.session_field request session_key with
94
Removed:
| None -> Lwt.return None
95
Removed:
| Some id -> Service.find_trainee t.service (Trainee.id id)
96
Removed:
97
Removed:
(* Resolve the authenticated trainee, or send an unauthenticated request to
98
Removed:
the sign-in page. [handler] receives the trainee. The request and any path
99
Removed:
captures stay in the caller's scope, so this one combinator serves every
100
Removed:
route regardless of how many captures Dream passes. *)
101
Removed:
let authenticated t request handler =
102
Removed:
current_trainee t request >>= function
103
Removed:
| Some trainee -> (
104
Removed:
handler trainee >>= fun response ->
105
Removed:
match Dream.method_ request with
106
Removed:
| `GET ->
107
Removed:
Dream.drop_session_field request flash_key >|= fun () -> response
108
Removed:
| _ -> Lwt.return response)
109
Removed:
| None -> redirect_to request Routes.login
110
Removed:
111
Removed:
let decode_form decoder request =
112
Removed:
Dream_html.form decoder ~csrf:true request >|= function
113
Removed:
| `Ok value -> Ok value
114
Removed:
| `Invalid errors -> Error (`Invalid errors)
115
Removed:
| _ -> Error `Bad_request
116
Removed:
117
Removed:
(* Plain (non-dream-html) form read with CSRF, for auth forms. *)
118
Removed:
let read_credentials request =
119
Removed:
Dream.form request >|= function
120
Removed:
| `Ok fields -> (
121
Removed:
let get k = List.assoc_opt k fields in
122
Removed:
match (get "username", get "password") with
123
Removed:
| Some username, Some password -> Ok (username, password)
124
Removed:
| _ -> Error `Bad_request)
125
Removed:
| _ -> Error `Bad_request
126
Removed:
127
Removed:
(* A CSRF guard for state-changing POSTs whose body carries no fields other
128
Removed:
than the token. [Dream.form] verifies the token and returns [`Ok] only
129
Removed:
when it is valid, so this rejects a forged or missing token. *)
130
Removed:
let guard_csrf request =
131
Removed:
Dream.form request >|= function `Ok _ -> Ok () | _ -> Error `Bad_request
132
Removed:
133
Removed:
module Auth = struct
134
Removed:
let login_page t request =
135
Removed:
current_trainee t request >>= function
136
Removed:
| Some _ -> redirect_to request Routes.home
137
Removed:
| None ->
138
Removed:
html (Pages.login request ~registration_open:t.registration_open ())
139
Removed:
140
Removed:
let register_page t request =
141
Removed:
current_trainee t request >>= function
142
Removed:
| Some _ -> redirect_to request Routes.home
143
Removed:
| None -> html (Pages.register request ())
144
Removed:
145
Removed:
let establish request (trainee : Trainee.t) =
146
Removed:
Dream.set_session_field request session_key
147
Removed:
(Trainee.id_to_string trainee.id)
148
Removed:
>>= fun () -> redirect_to request Routes.home
149
Removed:
150
Removed:
let register t request =
151
Removed:
read_credentials request >>= function
152
Removed:
| Error _ ->
153
Removed:
html ~status:`Bad_Request
154
Removed:
(Pages.register request ~error:Present.form_invalid ())
155
Removed:
| Ok (username, password) -> (
156
Removed:
Service.register t.service ~username ~password >>= function
157
Removed:
| Ok trainee -> establish request trainee
158
Removed:
| Error err ->
159
Removed:
html ~status:`Bad_Request
160
Removed:
(Pages.register request ~error:(Present.registration err) ()))
161
Removed:
162
Removed:
let login t request =
163
Removed:
read_credentials request >>= function
164
Removed:
| Error _ ->
165
Removed:
html ~status:`Bad_Request
166
Removed:
(Pages.login request ~error:Present.form_invalid ())
167
Removed:
| Ok (username, password) -> (
168
Removed:
Service.authenticate t.service ~username ~password >>= function
169
Removed:
| Some trainee -> establish request trainee
170
Removed:
| None ->
171
Removed:
html ~status:`Unauthorized
172
Removed:
(Pages.login request ~error:Present.sign_in_failed ()))
173
Removed:
174
Removed:
let logout _t request =
175
Removed:
guard_csrf request >>= function
176
Removed:
| Error _ -> bad_request Present.form_invalid
177
Removed:
| Ok () ->
178
Removed:
Dream.invalidate_session request >>= fun () ->
179
Removed:
redirect_to request Routes.login
180
Removed:
181
Removed:
let routes t =
182
Removed:
(* Public sign-up is disabled by default. The [/register] routes appear
183
Removed:
only when [registration_open] is set. Everything else is unconditional. *)
184
Removed:
let register_routes =
185
Removed:
if t.registration_open then
186
Removed:
[
187
Removed:
Dream_html.get Routes.register (register_page t);
188
Removed:
Dream_html.post Routes.register (register t);
189
Removed:
]
190
Removed:
else []
191
Removed:
in
192
Removed:
[
193
Removed:
Dream_html.get Routes.login (login_page t);
194
Removed:
Dream_html.post Routes.login (login t);
195
Removed:
Dream_html.post Routes.logout (logout t);
196
Removed:
]
197
Removed:
@ register_routes
198
Removed:
end
199
Removed:
200
Removed:
(* --- helpers over the service --- *)
201
Removed:
202
Removed:
let record_target t trainee id =
203
Removed:
Service.find_record t.service trainee (Repository.workout_id id)
204
Removed:
>|= Option.map (fun record ->
205
Removed:
(record.Repository.id, record.Repository.workout))
206
Removed:
207
Removed:
let outstanding workout slot =
208
Removed:
List.assoc_opt slot (Evidence.Workout.outstanding workout)
209
Removed:
210
Removed:
(* The prescription at any valid slot, filled or not — the edit handlers
211
Removed:
correct filled slots, which [outstanding] does not list. *)
212
Removed:
let prescription_at workout slot =
213
Removed:
List.nth_opt
214
Removed:
(Prescription.Workout.stimuli (Evidence.Workout.prescription workout))
215
Removed:
slot
216
Removed:
217
Removed:
(* The slot a workout view should open on: the first slot still awaiting a
218
Removed:
record, or the first slot when every slot is filled. A caller clamps a
219
Removed:
requested slot against the prescription. This supplies the default. *)
220
Removed:
let default_slot workout =
221
Removed:
match Evidence.Workout.outstanding workout with
222
Removed:
| (slot, _) :: _ -> slot
223
Removed:
| [] -> 0
224
Removed:
225
Removed:
(* The slot a workout view should open on. An explicit [?slot=] query
226
Removed:
wins when it names a real slot. Otherwise the view defaults to the first
227
Removed:
incomplete slot. A [?slot=] out of range, or absent, falls back to the
228
Removed:
default, so a bookmarked or hand-edited URL never renders an empty view. *)
229
Removed:
let active_slot request workout =
230
Removed:
let slot_count =
231
Removed:
List.length
232
Removed:
(Prescription.Workout.stimuli (Evidence.Workout.prescription workout))
233
Removed:
in
234
Removed:
match Dream.query request "slot" with
235
Removed:
| Some raw -> (
236
Removed:
match int_of_string_opt raw with
237
Removed:
| Some slot when slot >= 0 && slot < slot_count -> slot
238
Removed:
| _ -> default_slot workout)
239
Removed:
| None -> default_slot workout
240
Removed:
241
Removed:
(* Map an [Evidence.Workout.t] into the view-model DTO the presenter renders,
242
Removed:
so no Evidence or Prescription type crosses the boundary into Pages. The
243
Removed:
same mapping serves the live workout and a saved-record view. The caller
244
Removed:
supplies [record_id]/[editing]/[errors] separately. *)
245
Removed:
246
Removed:
(* The ending code a single-choice form uses, taken from an effort's outcome.
247
Removed:
The form offers one ending, so the first extension stands for it. *)
248
Removed:
let extension_code_of_effort effort =
249
Removed:
match Evidence.Stimulus.Effort.outcome effort with
250
Removed:
| Evidence.Stimulus.Positive_failure -> ""
251
Removed:
| Evidence.Stimulus.Beyond_failure (first, _) -> (
252
Removed:
match first with
253
Removed:
| Evidence.Stimulus.Forced_reps -> "forced"
254
Removed:
| Evidence.Stimulus.Negatives -> "negatives"
255
Removed:
| Evidence.Stimulus.Rest_pause -> "rest-pause"
256
Removed:
| Evidence.Stimulus.Static_hold -> "static")
257
Removed:
258
Removed:
(* One line describing a recorded stimulus: the efforts joined by "into", then
259
Removed:
any extensions appended. *)
260
Removed:
let describe_stimulus stimulus =
261
Removed:
let effort effort =
262
Removed:
Format.asprintf "%s %g kg x %d"
263
Removed:
(Exercise.name (Evidence.Stimulus.Effort.exercise effort))
264
Removed:
(Evidence.Stimulus.Effort.load effort)
265
Removed:
(Evidence.Stimulus.Effort.reps effort)
266
Removed:
in
267
Removed:
let body =
268
Removed:
String.concat " into "
269
Removed:
(List.map effort (Evidence.Stimulus.efforts stimulus))
270
Removed:
in
271
Removed:
match Evidence.Stimulus.extensions stimulus with
272
Removed:
| [] -> body
273
Removed:
| extensions ->
274
Removed:
body ^ ", "
275
Removed:
^ String.concat " then "
276
Removed:
(List.map
277
Removed:
(Format.asprintf "%a" Evidence.Stimulus.pp_extension)
278
Removed:
extensions)
279
Removed:
280
Removed:
let workout_view ~active_slot workout : View_model.Workout.t =
281
Removed:
let prescription = Evidence.Workout.prescription workout in
282
Removed:
let prescribed_slots = Prescription.Workout.stimuli prescription in
283
Removed:
(* One entry per filled slot, the first fill in performance order — the fill
284
Removed:
[replace_stimulus] keeps in place when a correction lands. *)
285
Removed:
let filled =
286
Removed:
List.fold_left
287
Removed:
(fun acc (slot, stimulus) ->
288
Removed:
if List.mem_assoc slot acc then acc else acc @ [ (slot, stimulus) ])
289
Removed:
[]
290
Removed:
(Evidence.Workout.performed workout)
291
Removed:
in
292
Removed:
let load_string load = Printf.sprintf "%g" load in
293
Removed:
let reps_string reps = string_of_int reps in
294
Removed:
let label p =
295
Removed:
match Prescription.Stimulus.delivery p with
296
Removed:
| Prescription.Stimulus.Single e -> Exercise.name e
297
Removed:
| Prescription.Stimulus.Pre_exhaust { isolation; compound } ->
298
Removed:
Printf.sprintf "%s + %s" (Exercise.name isolation)
299
Removed:
(Exercise.name compound)
300
Removed:
in
301
Removed:
let slot_view index p : View_model.Workout.slot =
302
Removed:
let recorded = List.assoc_opt index filled in
303
Removed:
let efforts = Option.map Evidence.Stimulus.efforts recorded in
304
Removed:
let nth n = Option.bind efforts (fun es -> List.nth_opt es n) in
305
Removed:
let load_of n =
306
Removed:
Option.map
307
Removed:
(fun e -> load_string (Evidence.Stimulus.Effort.load e))
308
Removed:
(nth n)
309
Removed:
in
310
Removed:
let reps_of n =
311
Removed:
Option.map
312
Removed:
(fun e -> reps_string (Evidence.Stimulus.Effort.reps e))
313
Removed:
(nth n)
314
Removed:
in
315
Removed:
let movements : View_model.Workout.movement list =
316
Removed:
match Prescription.Stimulus.delivery p with
317
Removed:
| Prescription.Stimulus.Single exercise ->
318
Removed:
[
319
Removed:
{
320
Removed:
name = Exercise.name exercise;
321
Removed:
load_field = "load";
322
Removed:
reps_field = "reps";
323
Removed:
reps_label = "Reps to failure";
324
Removed:
load_value = load_of 0;
325
Removed:
reps_value = reps_of 0;
326
Removed:
};
327
Removed:
]
328
Removed:
| Prescription.Stimulus.Pre_exhaust { isolation; compound } ->
329
Removed:
[
330
Removed:
{
331
Removed:
name = Exercise.name isolation;
332
Removed:
load_field = "iso_load";
333
Removed:
reps_field = "iso_reps";
334
Removed:
reps_label = "Reps";
335
Removed:
load_value = load_of 0;
336
Removed:
reps_value = reps_of 0;
337
Removed:
};
338
Removed:
{
339
Removed:
name = Exercise.name compound;
340
Removed:
load_field = "comp_load";
341
Removed:
reps_field = "comp_reps";
342
Removed:
reps_label = "Reps";
343
Removed:
load_value = load_of 1;
344
Removed:
reps_value = reps_of 1;
345
Removed:
};
346
Removed:
]
347
Removed:
in
348
Removed:
let selected_extension =
349
Removed:
match recorded with
350
Removed:
| None -> ""
351
Removed:
| Some s -> (
352
Removed:
(* The ending lives on the last effort (the compound of a pair). *)
353
Removed:
match List.rev (Evidence.Stimulus.efforts s) with
354
Removed:
| last :: _ -> extension_code_of_effort last
355
Removed:
| [] -> "")
356
Removed:
in
357
Removed:
{
358
Removed:
index;
359
Removed:
label = label p;
360
Removed:
movements;
361
Removed:
recorded_summary = Option.map describe_stimulus recorded;
362
Removed:
selected_extension;
363
Removed:
}
364
Removed:
in
365
Removed:
let overridden =
366
Removed:
match Recovery.basis (Evidence.Workout.clearance workout) with
367
Removed:
| Recovery.Overridden _ -> true
368
Removed:
| Recovery.Recovered -> false
369
Removed:
in
370
Removed:
{
371
Removed:
name = Prescription.Workout.name prescription;
372
Removed:
slots = List.mapi slot_view prescribed_slots;
373
Removed:
active_slot;
374
Removed:
started_at_unix =
375
Removed:
Recovery.timestamp_to_unix_seconds (Evidence.Workout.started_at workout);
376
Removed:
overridden;
377
Removed:
all_recorded = Evidence.Workout.outstanding workout = [];
378
Removed:
}
379
Removed:
380
Removed:
let save_current t trainee stimulus =
381
Removed:
Service.log t.service trainee stimulus >|= function
382
Removed:
| Ok _ -> Ok ()
383
Removed:
| Error e -> Error (Present.log_error e)
384
Removed:
385
Removed:
let replace_current t trainee ~slot stimulus =
386
Removed:
Service.replace_current t.service trainee ~slot stimulus >|= function
387
Removed:
| Ok _ -> Ok ()
388
Removed:
| Error e -> Error (Present.log_error e)
389
Removed:
390
Removed:
let save_record t trainee id stimulus =
391
Removed:
Service.add_to_record t.service trainee id stimulus >|= function
392
Removed:
| Ok _ -> Ok ()
393
Removed:
| Error e -> Error (Present.edit_error e)
394
Removed:
395
Removed:
let replace_record t trainee id ~slot stimulus =
396
Removed:
Service.replace_in_record t.service trainee id ~slot stimulus >|= function
397
Removed:
| Ok _ -> Ok ()
398
Removed:
| Error e -> Error (Present.edit_error e)
399
Removed:
400
Removed:
module Overview = struct
401
Removed:
(* Map service entities into the view-model DTOs the presenter renders, so
402
Removed:
no Prescription or Recovery type crosses the boundary into Pages. These
403
Removed:
replicate the phrasing the shared presenter formatters use. *)
404
Removed:
let routine_choice_view
405
Removed:
((rid, r) : Repository.routine_id * Prescription.Routine.t) :
406
Removed:
View_model.Routine_choice.t =
407
Removed:
{
408
Removed:
id = (rid :> string);
409
Removed:
name = Prescription.Routine.name r;
410
Removed:
workout_count = List.length (Prescription.Routine.workouts r);
411
Removed:
}
412
Removed:
413
Removed:
let exercise_string prescription =
414
Removed:
match Prescription.Stimulus.delivery prescription with
415
Removed:
| Prescription.Stimulus.Single exercise -> Exercise.name exercise
416
Removed:
| Prescription.Stimulus.Pre_exhaust { isolation; compound } ->
417
Removed:
Printf.sprintf "%s into %s, no pause" (Exercise.name isolation)
418
Removed:
(Exercise.name compound)
419
Removed:
420
Removed:
let reps_string prescription =
421
Removed:
let min_reps, max_reps =
422
Removed:
Prescription.Rep_range.bounds
423
Removed:
(Prescription.Stimulus.rep_range prescription)
424
Removed:
in
425
Removed:
Printf.sprintf "%d-%d" min_reps max_reps
426
Removed:
427
Removed:
let routine_view r : View_model.Routine.t =
428
Removed:
{
429
Removed:
name = Prescription.Routine.name r;
430
Removed:
workouts =
431
Removed:
List.map
432
Removed:
(fun w : View_model.Routine.workout ->
433
Removed:
{
434
Removed:
name = Prescription.Workout.name w;
435
Removed:
exercises =
436
Removed:
List.map
437
Removed:
(fun s : View_model.Routine.exercise ->
438
Removed:
{ name = exercise_string s; reps = reps_string s })
439
Removed:
(Prescription.Workout.stimuli w);
440
Removed:
})
441
Removed:
(Prescription.Routine.workouts r);
442
Removed:
}
443
Removed:
444
Removed:
let duration_hours duration =
445
Removed:
let hours =
446
Removed:
float_of_int (Recovery.duration_to_seconds duration) /. 3600.
447
Removed:
in
448
Removed:
if Float.equal hours (Float.round hours) then Printf.sprintf "%.0fh" hours
449
Removed:
else Printf.sprintf "%.1fh" hours
450
Removed:
451
Removed:
let home_view ~(routine : Repository.routine_id) ~routine_name ~next
452
Removed:
~readiness : View_model.Home.t =
453
Removed:
{
454
Removed:
routine_id = (routine :> string);
455
Removed:
routine_name;
456
Removed:
next_workout = Prescription.Workout.name next;
457
Removed:
gate =
458
Removed:
(match readiness with
459
Removed:
| Recovery.Ready -> View_model.Home.Ready
460
Removed:
| Recovery.Recovering { rested; recommended } ->
461
Removed:
View_model.Home.Recovering
462
Removed:
{
463
Removed:
status =
464
Removed:
Printf.sprintf "Recovery: %s of %s." (duration_hours rested)
465
Removed:
(duration_hours recommended);
466
Removed:
});
467
Removed:
}
468
Removed:
469
Removed:
let page t trainee request =
470
Removed:
let viewer =
471
Removed:
{
472
Removed:
View_model.Viewer.username =
473
Removed:
Trainee.username_to_string trainee.Trainee.username;
474
Removed:
}
475
Removed:
in
476
Removed:
Service.in_progress t.service trainee.Trainee.id >>= function
477
Removed:
| Some workout ->
478
Removed:
let workout_name =
479
Removed:
Prescription.Workout.name (Evidence.Workout.prescription workout)
480
Removed:
in
481
Removed:
Lwt.return (Pages.workout_in_progress request ~viewer ~workout_name)
482
Removed:
| None -> (
483
Removed:
Service.active_routine t.service trainee.Trainee.id >>= function
484
Removed:
| None ->
485
Removed:
Lwt.return
486
Removed:
(Pages.choose_routine request ~logging:false ~viewer
487
Removed:
~routines:
488
Removed:
(List.map routine_choice_view
489
Removed:
(Service.list_routines t.service)))
490
Removed:
| Some (routine, selected) -> (
491
Removed:
Service.next_workout t.service trainee.Trainee.id ~routine
492
Removed:
>>= fun next ->
493
Removed:
Service.readiness t.service trainee.Trainee.id ~routine
494
Removed:
~now:(t.now ())
495
Removed:
>|= fun readiness ->
496
Removed:
match (next, readiness) with
497
Removed:
| Ok next, Ok readiness ->
498
Removed:
Pages.home request ~viewer
499
Removed:
~home:
500
Removed:
(home_view ~routine
501
Removed:
~routine_name:(Prescription.Routine.name selected)
502
Removed:
~next ~readiness)
503
Removed:
| Error error, _ | _, Error error ->
504
Removed:
Pages.problem ~title:"Routine unavailable"
505
Removed:
~detail:(Present.routine error)))
506
Removed:
507
Removed:
let home t trainee request = page t trainee request >>= html
508
Removed:
509
Removed:
let routines t trainee request =
510
Removed:
let viewer =
511
Removed:
{
512
Removed:
View_model.Viewer.username =
513
Removed:
Trainee.username_to_string trainee.Trainee.username;
514
Removed:
}
515
Removed:
in
516
Removed:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
517
Removed:
html
518
Removed:
(Pages.choose_routine request
519
Removed:
~logging:(Option.is_some in_progress)
520
Removed:
~viewer
521
Removed:
~routines:
522
Removed:
(List.map routine_choice_view (Service.list_routines t.service)))
523
Removed:
524
Removed:
let select_routine t trainee request id =
525
Removed:
guard_csrf request >>= function
526
Removed:
| Error _ -> redirect_with_flash request Routes.home Present.form_invalid
527
Removed:
| Ok () -> (
528
Removed:
Service.select_routine t.service trainee.Trainee.id
529
Removed:
(Repository.routine_id id)
530
Removed:
>>= function
531
Removed:
| Ok () -> redirect_with_flash request Routes.home "Routine selected."
532
Removed:
| Error _ -> not_found Present.unknown_routine)
533
Removed:
534
Removed:
let routine t trainee request =
535
Removed:
let viewer =
536
Removed:
{
537
Removed:
View_model.Viewer.username =
538
Removed:
Trainee.username_to_string trainee.Trainee.username;
539
Removed:
}
540
Removed:
in
541
Removed:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
542
Removed:
Service.active_routine t.service trainee.Trainee.id >>= function
543
Removed:
| Some (_, routine) ->
544
Removed:
html
545
Removed:
(Pages.routine request
546
Removed:
~logging:(Option.is_some in_progress)
547
Removed:
~viewer (routine_view routine))
548
Removed:
| None -> redirect_to request Routes.routines
549
Removed:
550
Removed:
let routes t =
551
Removed:
[
552
Removed:
Dream_html.get Routes.home (fun request ->
553
Removed:
authenticated t request (fun trainee -> home t trainee request));
554
Removed:
Dream_html.get Routes.routines (fun request ->
555
Removed:
authenticated t request (fun trainee -> routines t trainee request));
556
Removed:
Dream_html.post Routes.select_routine (fun request id ->
557
Removed:
authenticated t request (fun trainee ->
558
Removed:
select_routine t trainee request id));
559
Removed:
Dream_html.get Routes.routine (fun request ->
560
Removed:
authenticated t request (fun trainee -> routine t trainee request));
561
Removed:
]
562
Removed:
end
563
Removed:
564
Removed:
module Current_workout = struct
565
Removed:
let begin_workout t trainee request =
566
Removed:
decode_form Decode.override request >>= function
567
Removed:
| Error _ -> redirect_with_flash request Routes.home Present.form_invalid
568
Removed:
| Ok override -> (
569
Removed:
Service.active_routine t.service trainee.Trainee.id >>= function
570
Removed:
| None -> redirect_to request Routes.routines
571
Removed:
| Some (routine, _) -> (
572
Removed:
let override = if override then Some () else None in
573
Removed:
Service.begin_workout t.service trainee.Trainee.id ~routine
574
Removed:
~now:(t.now ()) ?override ()
575
Removed:
>>= function
576
Removed:
| Ok _ ->
577
Removed:
redirect_with_flash request Routes.workout "Workout started."
578
Removed:
| Error (Service.Not_recovered _) ->
579
Removed:
redirect_with_flash request Routes.home
580
Removed:
"The workout needs an explicit recovery override."
581
Removed:
| Error Service.Unknown_routine ->
582
Removed:
not_found Present.unknown_routine))
583
Removed:
584
Removed:
let show t trainee request =
585
Removed:
let viewer =
586
Removed:
{
587
Removed:
View_model.Viewer.username =
588
Removed:
Trainee.username_to_string trainee.Trainee.username;
589
Removed:
}
590
Removed:
in
591
Removed:
Service.in_progress t.service trainee.Trainee.id >>= function
592
Removed:
| Some workout ->
593
Removed:
let active_slot = active_slot request workout in
594
Removed:
html
595
Removed:
(Pages.workout request ~viewer ~record_id:None ~active_slot
596
Removed:
(workout_view ~active_slot workout))
597
Removed:
| None -> redirect_to request Routes.home
598
Removed:
599
Removed:
let log t trainee request slot =
600
Removed:
Service.in_progress t.service trainee.Trainee.id >>= function
601
Removed:
| None -> not_found Present.no_workout
602
Removed:
| Some workout -> (
603
Removed:
match outstanding workout slot with
604
Removed:
| None -> not_found Present.slot_not_awaiting
605
Removed:
| Some prescription -> (
606
Removed:
decode_form (Decode.stimulus prescription) request >>= function
607
Removed:
| Error (`Invalid errors) ->
608
Removed:
redirect_with_flash request Routes.workout
609
Removed:
(Decode.errors_to_text errors)
610
Removed:
| Error `Bad_request ->
611
Removed:
redirect_with_flash request Routes.workout
612
Removed:
Present.form_invalid
613
Removed:
| Ok stimulus -> (
614
Removed:
save_current t trainee.Trainee.id stimulus >>= function
615
Removed:
| Ok () ->
616
Removed:
redirect_with_flash request Routes.workout "Record saved."
617
Removed:
| Error detail ->
618
Removed:
redirect_with_flash request Routes.workout detail)))
619
Removed:
620
Removed:
(* Correct a recorded slot of the workout in progress. The slot may be
621
Removed:
filled, so its prescription comes from the workout, not [outstanding].
622
Removed:
[replace_current] targets the slot and never adds volume. *)
623
Removed:
let edit t trainee request slot =
624
Removed:
Service.in_progress t.service trainee.Trainee.id >>= function
625
Removed:
| None -> not_found Present.no_workout
626
Removed:
| Some workout -> (
627
Removed:
match prescription_at workout slot with
628
Removed:
| None -> not_found Present.slot_not_awaiting
629
Removed:
| Some prescription -> (
630
Removed:
decode_form (Decode.stimulus prescription) request >>= function
631
Removed:
| Error (`Invalid errors) ->
632
Removed:
redirect_with_flash request Routes.workout
633
Removed:
(Decode.errors_to_text errors)
634
Removed:
| Error `Bad_request ->
635
Removed:
redirect_with_flash request Routes.workout
636
Removed:
Present.form_invalid
637
Removed:
| Ok stimulus -> (
638
Removed:
replace_current t trainee.Trainee.id ~slot stimulus
639
Removed:
>>= function
640
Removed:
| Ok () ->
641
Removed:
redirect_with_flash request Routes.workout "Record saved."
642
Removed:
| Error detail ->
643
Removed:
redirect_with_flash request Routes.workout detail)))
644
Removed:
645
Removed:
let finish t trainee request =
646
Removed:
guard_csrf request >>= function
647
Removed:
| Error _ -> redirect_with_flash request Routes.home Present.form_invalid
648
Removed:
| Ok () -> (
649
Removed:
Service.finish t.service trainee.Trainee.id ~ended_at:(t.now ())
650
Removed:
>>= function
651
Removed:
| Some _ ->
652
Removed:
redirect_with_flash_raw request "/logbook?prompt=feedback"
653
Removed:
"Workout finished."
654
Removed:
| None -> redirect_with_flash request Routes.home Present.no_workout)
655
Removed:
656
Removed:
(* Cancelling discards the current workout and returns Home. An abandoned
657
Removed:
session is not evidence, so it leaves no record. A forged or missing
658
Removed:
CSRF token skips the discard but still leaves the workout view. *)
659
Removed:
let cancel t trainee request =
660
Removed:
guard_csrf request >>= function
661
Removed:
| Error _ ->
662
Removed:
redirect_with_flash request Routes.home
663
Removed:
"Workout cancellation was not confirmed."
664
Removed:
| Ok () ->
665
Removed:
Service.cancel t.service trainee.Trainee.id >>= fun _ ->
666
Removed:
redirect_with_flash request Routes.home "Workout cancelled."
667
Removed:
668
Removed:
let routes t =
669
Removed:
[
670
Removed:
Dream_html.get Routes.workout (fun request ->
671
Removed:
authenticated t request (fun trainee -> show t trainee request));
672
Removed:
Dream_html.post Routes.workout (fun request ->
673
Removed:
authenticated t request (fun trainee ->
674
Removed:
begin_workout t trainee request));
675
Removed:
Dream_html.post Routes.workout_slot (fun request slot ->
676
Removed:
authenticated t request (fun trainee -> log t trainee request slot));
677
Removed:
Dream_html.post Routes.workout_slot_edit (fun request slot ->
678
Removed:
authenticated t request (fun trainee -> edit t trainee request slot));
679
Removed:
Dream_html.post Routes.finish_workout (fun request ->
680
Removed:
authenticated t request (fun trainee -> finish t trainee request));
681
Removed:
Dream_html.post Routes.cancel_workout (fun request ->
682
Removed:
authenticated t request (fun trainee -> cancel t trainee request));
683
Removed:
]
684
Removed:
end
685
Removed:
686
Removed:
module Logbook = struct
687
Removed:
let feedback_session_key = "hito.feedback.flow"
688
Removed:
let feedback_factors = List.map fst Pages.feedback_factors
689
Removed:
690
Removed:
let valid_choice = function
691
Removed:
| ("1" | "2" | "3" | "4" | "5") as choice -> Some choice
692
Removed:
| _ -> None
693
Removed:
694
Removed:
let valid_factor field = List.mem field feedback_factors
695
Removed:
696
Removed:
let encode_feedback_flow (flow : Pages.feedback_flow) =
697
Removed:
let answers =
698
Removed:
List.map (fun (field, choice) -> field ^ ":" ^ choice) flow.answers
699
Removed:
in
700
Removed:
Printf.sprintf "%d|%s" flow.step (String.concat ";" answers)
701
Removed:
702
Removed:
let decode_feedback_flow raw =
703
Removed:
match String.split_on_char '|' raw with
704
Removed:
| [ step; answers ] -> (
705
Removed:
match int_of_string_opt step with
706
Removed:
| None -> None
707
Removed:
| Some step when step < 0 || step > 5 -> None
708
Removed:
| Some step ->
709
Removed:
let answers =
710
Removed:
answers |> String.split_on_char ';'
711
Removed:
|> List.filter_map (fun answer ->
712
Removed:
match String.split_on_char ':' answer with
713
Removed:
| [ field; choice ]
714
Removed:
when valid_factor field
715
Removed:
&& Option.is_some (valid_choice choice) ->
716
Removed:
Some (field, choice)
717
Removed:
| _ -> None)
718
Removed:
in
719
Removed:
Some Pages.{ step; answers })
720
Removed:
| _ -> None
721
Removed:
722
Removed:
let feedback_flow request =
723
Removed:
Dream.session_field request feedback_session_key |> fun raw ->
724
Removed:
Option.bind raw decode_feedback_flow
725
Removed:
726
Removed:
let initial_feedback_flow = Pages.{ step = 0; answers = [] }
727
Removed:
728
Removed:
let set_feedback_flow request flow =
729
Removed:
Dream.set_session_field request feedback_session_key
730
Removed:
(encode_feedback_flow flow)
731
Removed:
732
Removed:
let clear_feedback_flow request =
733
Removed:
Dream.drop_session_field request feedback_session_key
734
Removed:
735
Removed:
let field name fields = List.assoc_opt name fields
736
Removed:
737
Removed:
let feedback_signals answers flags =
738
Removed:
let level choice =
739
Removed:
match int_of_string_opt choice with
740
Removed:
| Some n -> (
741
Removed:
match Evidence.Feedback.level_of_score n with
742
Removed:
| Some l -> l
743
Removed:
| None -> Evidence.Feedback.Fair)
744
Removed:
| None -> Evidence.Feedback.Fair
745
Removed:
in
746
Removed:
let leveled field make =
747
Removed:
List.find_map
748
Removed:
(fun (answer_field, choice) ->
749
Removed:
if String.equal field answer_field then
750
Removed:
Option.map
751
Removed:
(fun choice -> make (level choice))
752
Removed:
(valid_choice choice)
753
Removed:
else None)
754
Removed:
answers
755
Removed:
in
756
Removed:
let optional_flag name signal =
757
Removed:
match field name flags with Some "true" -> Some signal | _ -> None
758
Removed:
in
759
Removed:
List.filter_map Fun.id
760
Removed:
[
761
Removed:
leveled "sleep" (fun l -> Evidence.Feedback.Sleep l);
762
Removed:
leveled "appetite" (fun l -> Evidence.Feedback.Appetite l);
763
Removed:
leveled "readiness" (fun l -> Evidence.Feedback.Readiness l);
764
Removed:
leveled "motivation" (fun l -> Evidence.Feedback.Motivation l);
765
Removed:
leveled "difficulty" (fun l -> Evidence.Feedback.Difficulty l);
766
Removed:
optional_flag "pain" Evidence.Feedback.Pain;
767
Removed:
optional_flag "injury" Evidence.Feedback.Injury;
768
Removed:
optional_flag "preparation" Evidence.Feedback.Preparation_insufficient;
769
Removed:
]
770
Removed:
771
Removed:
(* Describe one signal for the list, and compute a factor's score for the
772
Removed:
graph. These read the Evidence.Feedback entity here in the controller, so
773
Removed:
the presenter receives only strings and scores. *)
774
Removed:
let describe_signal (signal : Evidence.Feedback.signal) =
775
Removed:
let level l =
776
Removed:
let score = Evidence.Feedback.level_to_score l in
777
Removed:
match l with
778
Removed:
| Evidence.Feedback.Very_poor -> Printf.sprintf "%d (very poor)" score
779
Removed:
| Very_good -> Printf.sprintf "%d (very good)" score
780
Removed:
| _ -> string_of_int score
781
Removed:
in
782
Removed:
match signal with
783
Removed:
| Sleep l -> Printf.sprintf "Sleep %s" (level l)
784
Removed:
| Appetite l -> Printf.sprintf "Appetite %s" (level l)
785
Removed:
| Readiness l -> Printf.sprintf "Readiness %s" (level l)
786
Removed:
| Motivation l -> Printf.sprintf "Motivation %s" (level l)
787
Removed:
| Difficulty l -> Printf.sprintf "Difficulty %s" (level l)
788
Removed:
| Pain -> "Pain"
789
Removed:
| Injury -> "Injury"
790
Removed:
| Preparation_insufficient -> "Preparation insufficient"
791
Removed:
792
Removed:
let factor_fields =
793
Removed:
[ "sleep"; "appetite"; "readiness"; "motivation"; "difficulty" ]
794
Removed:
795
Removed:
let factor_score field (report : Evidence.Feedback.t) =
796
Removed:
let of_signal (signal : Evidence.Feedback.signal) =
797
Removed:
match (field, signal) with
798
Removed:
| "sleep", Sleep l
799
Removed:
| "appetite", Appetite l
800
Removed:
| "readiness", Readiness l
801
Removed:
| "motivation", Motivation l
802
Removed:
| "difficulty", Difficulty l ->
803
Removed:
Some (Evidence.Feedback.level_to_score l)
804
Removed:
| _ -> None
805
Removed:
in
806
Removed:
List.find_map of_signal (Evidence.Feedback.signals report)
807
Removed:
808
Removed:
let entry_view (record : Repository.record) : View_model.Logbook_entry.t =
809
Removed:
let workout = record.Repository.workout in
810
Removed:
{
811
Removed:
id = (record.Repository.id :> string);
812
Removed:
workout_name =
813
Removed:
Prescription.Workout.name (Evidence.Workout.prescription workout);
814
Removed:
stimuli_count = List.length (Evidence.Workout.stimuli workout);
815
Removed:
complete =
816
Removed:
(match Evidence.Workout.completeness workout with
817
Removed:
| Evidence.Workout.Complete -> true
818
Removed:
| Incomplete -> false);
819
Removed:
}
820
Removed:
821
Removed:
let feedback_view (report : Evidence.Feedback.t) :
822
Removed:
View_model.Feedback.report =
823
Removed:
{
824
Removed:
at_unix =
825
Removed:
Recovery.timestamp_to_unix_seconds
826
Removed:
(Evidence.Feedback.reported_at report);
827
Removed:
signals = List.map describe_signal (Evidence.Feedback.signals report);
828
Removed:
factor_scores =
829
Removed:
List.map (fun f -> (f, factor_score f report)) factor_fields;
830
Removed:
}
831
Removed:
832
Removed:
let index t trainee request =
833
Removed:
let viewer =
834
Removed:
{
835
Removed:
View_model.Viewer.username =
836
Removed:
Trainee.username_to_string trainee.Trainee.username;
837
Removed:
}
838
Removed:
in
839
Removed:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
840
Removed:
Service.history t.service trainee.Trainee.id >>= fun records ->
841
Removed:
Service.feedback t.service trainee.Trainee.id >>= fun feedback ->
842
Removed:
let feedback = List.map feedback_view feedback in
843
Removed:
let records = List.map entry_view records in
844
Removed:
let saved_flow = feedback_flow request in
845
Removed:
let feedback_open =
846
Removed:
match
847
Removed:
(Dream.query request "feedback", Dream.query request "prompt")
848
Removed:
with
849
Removed:
| Some "start", _ | _, Some "feedback" -> true
850
Removed:
| _ -> Option.is_some saved_flow
851
Removed:
in
852
Removed:
html
853
Removed:
(Pages.logbook request
854
Removed:
~logging:(Option.is_some in_progress)
855
Removed:
~viewer ~feedback
856
Removed:
~suggest_feedback:
857
Removed:
(match Dream.query request "prompt" with
858
Removed:
| Some "feedback" -> true
859
Removed:
| _ -> false)
860
Removed:
~feedback_flow:
861
Removed:
(Option.value saved_flow ~default:initial_feedback_flow)
862
Removed:
~feedback_open records)
863
Removed:
864
Removed:
let finish_feedback t trainee request flow flags =
865
Removed:
let signals = feedback_signals flow.Pages.answers flags in
866
Removed:
Service.record_feedback t.service trainee.Trainee.id
867
Removed:
~reported_at:(t.now ()) signals
868
Removed:
>>= function
869
Removed:
| Ok _ ->
870
Removed:
clear_feedback_flow request >>= fun () ->
871
Removed:
redirect_with_flash request Routes.logbook "Feedback saved."
872
Removed:
| Error _ ->
873
Removed:
clear_feedback_flow request >>= fun () ->
874
Removed:
redirect_with_flash request Routes.logbook Present.form_invalid
875
Removed:
876
Removed:
(* Advance one factor. The answer map stays in the session until the final
877
Removed:
optional-observations step, so refreshes never lose earlier choices. *)
878
Removed:
let record_feedback t trainee request =
879
Removed:
Dream.form request >>= function
880
Removed:
| `Ok fields -> (
881
Removed:
let flow =
882
Removed:
Option.value (feedback_flow request) ~default:initial_feedback_flow
883
Removed:
in
884
Removed:
match
885
Removed:
field "step" fields |> fun raw ->
886
Removed:
(Option.bind raw int_of_string_opt, flow.step)
887
Removed:
with
888
Removed:
| Some step, expected when step = expected ->
889
Removed:
let action =
890
Removed:
match field "action" fields with
891
Removed:
| Some ("next" | "Next") -> Some "next"
892
Removed:
| Some ("back" | "Back") -> Some "back"
893
Removed:
| Some ("skip" | "Skip this factor" | "Skip this step") ->
894
Removed:
Some "skip"
895
Removed:
| Some ("save" | "Record feedback") -> Some "save"
896
Removed:
| _ -> None
897
Removed:
in
898
Removed:
(* Back steps to the previous factor and keeps every answer, so a
899
Removed:
trainee can revise an earlier report without losing the rest. *)
900
Removed:
if action = Some "back" then
901
Removed:
if step = 0 then redirect_to request Routes.logbook
902
Removed:
else
903
Removed:
let previous = Pages.{ flow with step = step - 1 } in
904
Removed:
set_feedback_flow request previous >>= fun () ->
905
Removed:
redirect_to request Routes.logbook
906
Removed:
else if step = 5 then
907
Removed:
if action = Some "skip" then
908
Removed:
finish_feedback t trainee request flow []
909
Removed:
else if action = Some "save" then
910
Removed:
finish_feedback t trainee request flow fields
911
Removed:
else
912
Removed:
redirect_with_flash request Routes.logbook
913
Removed:
Present.form_invalid
914
Removed:
else
915
Removed:
let factor = List.nth feedback_factors step in
916
Removed:
let answers =
917
Removed:
match
918
Removed:
( action,
919
Removed:
field "choice" fields |> fun raw ->
920
Removed:
Option.bind raw valid_choice )
921
Removed:
with
922
Removed:
| Some "next", Some choice -> (factor, choice) :: flow.answers
923
Removed:
| Some "skip", _ -> flow.answers
924
Removed:
| _ -> flow.answers
925
Removed:
in
926
Removed:
if action <> Some "next" && action <> Some "skip" then
927
Removed:
redirect_with_flash request Routes.logbook
928
Removed:
Present.form_invalid
929
Removed:
else
930
Removed:
let next = Pages.{ step = step + 1; answers } in
931
Removed:
set_feedback_flow request next >>= fun () ->
932
Removed:
redirect_to request Routes.logbook
933
Removed:
| _ -> redirect_with_flash request Routes.logbook Present.form_invalid
934
Removed:
)
935
Removed:
| _ -> redirect_with_flash request Routes.logbook Present.form_invalid
936
Removed:
937
Removed:
let cancel_feedback _t _trainee request =
938
Removed:
guard_csrf request >>= function
939
Removed:
| Error _ ->
940
Removed:
redirect_with_flash request Routes.logbook Present.form_invalid
941
Removed:
| Ok () ->
942
Removed:
clear_feedback_flow request >>= fun () ->
943
Removed:
redirect_with_flash request Routes.logbook "Feedback skipped."
944
Removed:
945
Removed:
let show t trainee request id =
946
Removed:
let viewer =
947
Removed:
{
948
Removed:
View_model.Viewer.username =
949
Removed:
Trainee.username_to_string trainee.Trainee.username;
950
Removed:
}
951
Removed:
in
952
Removed:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
953
Removed:
record_target t trainee.Trainee.id id >>= function
954
Removed:
| None -> not_found Present.unknown_record
955
Removed:
| Some (_, workout) ->
956
Removed:
let active_slot = active_slot request workout in
957
Removed:
html
958
Removed:
(Pages.workout request ~viewer
959
Removed:
~logging:(Option.is_some in_progress)
960
Removed:
~record_id:(Some id) ~active_slot
961
Removed:
(workout_view ~active_slot workout))
962
Removed:
963
Removed:
let log t trainee request id slot =
964
Removed:
record_target t trainee.Trainee.id id >>= function
965
Removed:
| None -> not_found Present.unknown_record
966
Removed:
| Some (record_id, workout) -> (
967
Removed:
match outstanding workout slot with
968
Removed:
| None -> not_found Present.slot_not_awaiting
969
Removed:
| Some prescription -> (
970
Removed:
decode_form (Decode.stimulus prescription) request >>= function
971
Removed:
| Error (`Invalid errors) ->
972
Removed:
redirect_with_flash_attr request
973
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.record id)
974
Removed:
(Decode.errors_to_text errors)
975
Removed:
| Error `Bad_request ->
976
Removed:
redirect_with_flash_attr request
977
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.record id)
978
Removed:
Present.form_invalid
979
Removed:
| Ok stimulus -> (
980
Removed:
save_record t trainee.Trainee.id record_id stimulus
981
Removed:
>>= function
982
Removed:
| Ok () ->
983
Removed:
redirect_with_flash_attr request
984
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
985
Removed:
id)
986
Removed:
"Record saved."
987
Removed:
| Error detail ->
988
Removed:
redirect_with_flash_attr request
989
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
990
Removed:
id)
991
Removed:
detail)))
992
Removed:
993
Removed:
(* Correct a recorded slot of a saved workout. [replace_record] targets the
994
Removed:
slot, replacing its record rather than appending volume. *)
995
Removed:
let edit t trainee request id slot =
996
Removed:
record_target t trainee.Trainee.id id >>= function
997
Removed:
| None -> not_found Present.unknown_record
998
Removed:
| Some (record_id, workout) -> (
999
Removed:
match prescription_at workout slot with
1000
Removed:
| None -> not_found Present.slot_not_awaiting
1001
Removed:
| Some prescription -> (
1002
Removed:
decode_form (Decode.stimulus prescription) request >>= function
1003
Removed:
| Error (`Invalid errors) ->
1004
Removed:
redirect_with_flash_attr request
1005
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.record id)
1006
Removed:
(Decode.errors_to_text errors)
1007
Removed:
| Error `Bad_request ->
1008
Removed:
redirect_with_flash_attr request
1009
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.record id)
1010
Removed:
Present.form_invalid
1011
Removed:
| Ok stimulus -> (
1012
Removed:
replace_record t trainee.Trainee.id record_id ~slot stimulus
1013
Removed:
>>= function
1014
Removed:
| Ok () ->
1015
Removed:
redirect_with_flash_attr request
1016
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
1017
Removed:
id)
1018
Removed:
"Record saved."
1019
Removed:
| Error detail ->
1020
Removed:
redirect_with_flash_attr request
1021
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
1022
Removed:
id)
1023
Removed:
detail)))
1024
Removed:
1025
Removed:
let routes t =
1026
Removed:
[
1027
Removed:
Dream_html.get Routes.logbook (fun request ->
1028
Removed:
authenticated t request (fun trainee -> index t trainee request));
1029
Removed:
Dream_html.post Routes.feedback (fun request ->
1030
Removed:
authenticated t request (fun trainee ->
1031
Removed:
record_feedback t trainee request));
1032
Removed:
Dream_html.post Routes.cancel_feedback (fun request ->
1033
Removed:
authenticated t request (fun trainee ->
1034
Removed:
cancel_feedback t trainee request));
1035
Removed:
Dream_html.get Routes.record (fun request id ->
1036
Removed:
authenticated t request (fun trainee -> show t trainee request id));
1037
Removed:
Dream_html.post Routes.record_slot (fun request id slot ->
1038
Removed:
authenticated t request (fun trainee ->
1039
Removed:
log t trainee request id slot));
1040
Removed:
Dream_html.post Routes.record_slot_edit (fun request id slot ->
1041
Removed:
authenticated t request (fun trainee ->
1042
Removed:
edit t trainee request id slot));
1043
Removed:
]
1044
Removed:
end
1045
Removed:
1046
Removed:
module App_feedback = struct
1047
Removed:
let tab request =
1048
Removed:
match Dream.query request "tab" with
1049
Removed:
| Some "submitted" -> `Submitted
1050
Removed:
| _ -> `Write
1051
Removed:
1052
Removed:
let time_to_string timestamp =
1053
Removed:
let tm =
1054
Removed:
Unix.gmtime
1055
Removed:
(float_of_int (Recovery.timestamp_to_unix_seconds timestamp))
1056
Removed:
in
1057
Removed:
Printf.sprintf "%04d-%02d-%02d %02d:%02d" (tm.Unix.tm_year + 1900)
1058
Removed:
(tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min
1059
Removed:
1060
Removed:
(* Map a repository record into the view model the presenter renders, so no
1061
Removed:
entity or record crosses the boundary into Pages. *)
1062
Removed:
let view_of (report : Repository.app_feedback) : View_model.App_feedback.t =
1063
Removed:
{
1064
Removed:
id = Repository.app_feedback_id_to_string report.Repository.feedback_id;
1065
Removed:
author = report.Repository.author;
1066
Removed:
contributions = report.Repository.contributions;
1067
Removed:
submitted_at = time_to_string report.Repository.submitted_at;
1068
Removed:
message = report.Repository.message;
1069
Removed:
upvotes = report.Repository.upvotes;
1070
Removed:
viewer_upvoted = report.Repository.viewer_upvoted;
1071
Removed:
viewer_owns = report.Repository.viewer_owns;
1072
Removed:
}
1073
Removed:
1074
Removed:
let show t trainee request =
1075
Removed:
let viewer =
1076
Removed:
{
1077
Removed:
View_model.Viewer.username =
1078
Removed:
Trainee.username_to_string trainee.Trainee.username;
1079
Removed:
}
1080
Removed:
in
1081
Removed:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
1082
Removed:
Service.app_feedback t.service trainee.Trainee.id >>= fun reports ->
1083
Removed:
html
1084
Removed:
(Pages.app_feedback request
1085
Removed:
~logging:(Option.is_some in_progress)
1086
Removed:
~viewer ~tab:(tab request) (List.map view_of reports))
1087
Removed:
1088
Removed:
let submit t trainee request =
1089
Removed:
decode_form Decode.app_feedback request >>= function
1090
Removed:
| Error _ ->
1091
Removed:
redirect_with_flash_raw request "/app-feedback?tab=write"
1092
Removed:
Present.form_invalid
1093
Removed:
| Ok message -> (
1094
Removed:
Service.record_app_feedback t.service trainee.Trainee.id
1095
Removed:
~submitted_at:(t.now ()) ~message
1096
Removed:
>>= function
1097
Removed:
| Ok _ ->
1098
Removed:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
1099
Removed:
"Feedback submitted."
1100
Removed:
| Error `Empty_message ->
1101
Removed:
redirect_with_flash_raw request "/app-feedback?tab=write"
1102
Removed:
Present.app_feedback_empty
1103
Removed:
| Error `Unknown_feedback ->
1104
Removed:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
1105
Removed:
"That feedback is no longer available.")
1106
Removed:
1107
Removed:
let upvote t trainee request id =
1108
Removed:
guard_csrf request >>= function
1109
Removed:
| Error _ ->
1110
Removed:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
1111
Removed:
Present.form_invalid
1112
Removed:
| Ok () ->
1113
Removed:
Service.upvote_app_feedback t.service trainee.Trainee.id
1114
Removed:
(Repository.app_feedback_id id)
1115
Removed:
>>= fun added ->
1116
Removed:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
1117
Removed:
(if added then "Vote recorded." else "Vote was not added.")
1118
Removed:
1119
Removed:
let edit t trainee request id =
1120
Removed:
decode_form Decode.app_feedback request >>= function
1121
Removed:
| Error _ ->
1122
Removed:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
1123
Removed:
Present.form_invalid
1124
Removed:
| Ok message -> (
1125
Removed:
Service.edit_app_feedback t.service trainee.Trainee.id
1126
Removed:
(Repository.app_feedback_id id)
1127
Removed:
~message
1128
Removed:
>>= function
1129
Removed:
| Ok () ->
1130
Removed:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
1131
Removed:
"Feedback updated."
1132
Removed:
| Error `Empty_message ->
1133
Removed:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
1134
Removed:
Present.app_feedback_empty
1135
Removed:
| Error `Unknown_feedback ->
1136
Removed:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
1137
Removed:
"That feedback is no longer available.")
1138
Removed:
1139
Removed:
let remove t trainee request id =
1140
Removed:
guard_csrf request >>= function
1141
Removed:
| Error _ ->
1142
Removed:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
1143
Removed:
Present.form_invalid
1144
Removed:
| Ok () ->
1145
Removed:
Service.remove_app_feedback t.service trainee.Trainee.id
1146
Removed:
(Repository.app_feedback_id id)
1147
Removed:
>>= fun removed ->
1148
Removed:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
1149
Removed:
(if removed then "Feedback removed."
1150
Removed:
else "That feedback is no longer available.")
1151
Removed:
1152
Removed:
let routes t =
1153
Removed:
[
1154
Removed:
Dream_html.get Routes.app_feedback (fun request ->
1155
Removed:
authenticated t request (fun trainee -> show t trainee request));
1156
Removed:
Dream_html.post Routes.submit_app_feedback (fun request ->
1157
Removed:
authenticated t request (fun trainee -> submit t trainee request));
1158
Removed:
Dream_html.post Routes.upvote_app_feedback (fun request id ->
1159
Removed:
authenticated t request (fun trainee -> upvote t trainee request id));
1160
Removed:
Dream_html.post Routes.edit_app_feedback (fun request id ->
1161
Removed:
authenticated t request (fun trainee -> edit t trainee request id));
1162
Removed:
Dream_html.post Routes.remove_app_feedback (fun request id ->
1163
Removed:
authenticated t request (fun trainee -> remove t trainee request id));
1164
Removed:
]
1165
Removed:
end
1166
Removed:
1167
Removed:
module Profile = struct
1168
Removed:
(* The profile page. A [?changed=] query set by a successful redirect shows
1169
Removed:
a confirmation notice, so a refresh never re-posts a change. *)
1170
Removed:
let show t trainee request =
1171
Removed:
let viewer =
1172
Removed:
{
1173
Removed:
View_model.Viewer.username =
1174
Removed:
Trainee.username_to_string trainee.Trainee.username;
1175
Removed:
}
1176
Removed:
in
1177
Removed:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
1178
Removed:
let notice =
1179
Removed:
match Dream.query request "changed" with
1180
Removed:
| Some "username" -> Some Present.username_changed
1181
Removed:
| Some "password" -> Some Present.password_changed
1182
Removed:
| _ -> None
1183
Removed:
in
1184
Removed:
html
1185
Removed:
(Pages.profile request
1186
Removed:
~logging:(Option.is_some in_progress)
1187
Removed:
~viewer ?notice ())
1188
Removed:
1189
Removed:
let render_error t trainee request ?username_error ?password_error () =
1190
Removed:
let viewer =
1191
Removed:
{
1192
Removed:
View_model.Viewer.username =
1193
Removed:
Trainee.username_to_string trainee.Trainee.username;
1194
Removed:
}
1195
Removed:
in
1196
Removed:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
1197
Removed:
html ~status:`Bad_Request
1198
Removed:
(Pages.profile request
1199
Removed:
~logging:(Option.is_some in_progress)
1200
Removed:
~viewer ?username_error ?password_error ())
1201
Removed:
1202
Removed:
let change_username t trainee request =
1203
Removed:
decode_form Decode.profile_username request >>= function
1204
Removed:
| Error _ -> bad_request Present.form_invalid
1205
Removed:
| Ok username -> (
1206
Removed:
Service.change_username t.service trainee.Trainee.id ~username
1207
Removed:
>>= function
1208
Removed:
| Ok _ -> Dream.redirect request "/profile?changed=username"
1209
Removed:
| Error error ->
1210
Removed:
render_error t trainee request
1211
Removed:
~username_error:(Present.change_username error)
1212
Removed:
())
1213
Removed:
1214
Removed:
let change_password t trainee request =
1215
Removed:
decode_form Decode.profile_password request >>= function
1216
Removed:
| Error _ -> bad_request Present.form_invalid
1217
Removed:
| Ok (current, next) -> (
1218
Removed:
Service.change_password t.service trainee.Trainee.id ~current ~next
1219
Removed:
>>= function
1220
Removed:
| Ok _ -> Dream.redirect request "/profile?changed=password"
1221
Removed:
| Error error ->
1222
Removed:
render_error t trainee request
1223
Removed:
~password_error:(Present.change_password error)
1224
Removed:
())
1225
Removed:
1226
Removed:
let routes t =
1227
Removed:
[
1228
Removed:
Dream_html.get Routes.profile (fun request ->
1229
Removed:
authenticated t request (fun trainee -> show t trainee request));
1230
Removed:
Dream_html.post Routes.profile_username (fun request ->
1231
Removed:
authenticated t request (fun trainee ->
1232
Removed:
change_username t trainee request));
1233
Removed:
Dream_html.post Routes.profile_password (fun request ->
1234
Removed:
authenticated t request (fun trainee ->
1235
Removed:
change_password t trainee request));
1236
Removed:
]
1237
Removed:
end
1238
Removed:
1239
Removed:
module Settings = struct
1240
Removed:
let theme_session_key = "hito.theme"
1241
Removed:
1242
Removed:
let theme request =
1243
Removed:
match Dream.session_field request theme_session_key with
1244
Removed:
| Some "dark" -> "dark"
1245
Removed:
| _ -> "light"
1246
Removed:
1247
Removed:
let show t trainee request =
1248
Removed:
let viewer =
1249
Removed:
{
1250
Removed:
View_model.Viewer.username =
1251
Removed:
Trainee.username_to_string trainee.Trainee.username;
1252
Removed:
}
1253
Removed:
in
1254
Removed:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
1255
Removed:
html
1256
Removed:
(Pages.settings request
1257
Removed:
~logging:(Option.is_some in_progress)
1258
Removed:
~viewer ~theme:(theme request) ())
1259
Removed:
1260
Removed:
let update _trainee request =
1261
Removed:
guard_csrf request >>= function
1262
Removed:
| Error _ ->
1263
Removed:
redirect_with_flash request Routes.settings Present.form_invalid
1264
Removed:
| Ok () -> (
1265
Removed:
Dream.form request >>= function
1266
Removed:
| `Ok fields -> (
1267
Removed:
match List.assoc_opt "theme" fields with
1268
Removed:
| Some (("light" | "dark") as value) ->
1269
Removed:
Dream.set_session_field request theme_session_key value
1270
Removed:
>>= fun () -> Dream.redirect request "/settings"
1271
Removed:
| _ ->
1272
Removed:
redirect_with_flash request Routes.settings
1273
Removed:
Present.form_invalid)
1274
Removed:
| _ ->
1275
Removed:
redirect_with_flash request Routes.settings Present.form_invalid)
1276
Removed:
1277
Removed:
let routes t =
1278
Removed:
[
1279
Removed:
Dream_html.get Routes.settings (fun request ->
1280
Removed:
authenticated t request (fun trainee -> show t trainee request));
1281
Removed:
Dream_html.post Routes.settings_theme (fun request ->
1282
Removed:
authenticated t request (fun trainee -> update trainee request));
1283
Removed:
]
1284
Removed:
end
1285
Removed:
1286
Removed:
module Import = struct
1287
Removed:
let max_source_bytes = 10 * 1024 * 1024
1288
Removed:
1289
Removed:
(* Phrase an adapter warning for the view. The controller owns the wording,
1290
Removed:
so no warning variant crosses into the presenter. *)
1291
Removed:
let warning_view (w : Workout_import.warning) : View_model.Import_warning.t
1292
Removed:
=
1293
Removed:
let detail =
1294
Removed:
match w.Workout_import.kind with
1295
Removed:
| Workout_import.Warmup_dropped -> "warmup set dropped"
1296
Removed:
| Workout_import.Unsupported_row reason -> reason
1297
Removed:
in
1298
Removed:
{ row = w.Workout_import.row; detail }
1299
Removed:
1300
Removed:
let set_type_string : Workout_import.source_set_type -> string = function
1301
Removed:
| Workout_import.Normal -> "normal"
1302
Removed:
| Workout_import.Failure -> "failure"
1303
Removed:
| Workout_import.Dropset -> "dropset"
1304
Removed:
1305
Removed:
(* Phrase one promotion blocker for the view. *)
1306
Removed:
let blocker_string : Workout_import.blocker -> string = function
1307
Removed:
| Workout_import.No_sets -> "The workout has no promotable sets."
1308
Removed:
| Workout_import.Dropset_present rows ->
1309
Removed:
Printf.sprintf "Drop sets cannot be promoted (rows %s)."
1310
Removed:
(String.concat ", " (List.map string_of_int rows))
1311
Removed:
| Workout_import.Unmapped_exercise name ->
1312
Removed:
Printf.sprintf "The exercise %S is not mapped to a catalog entry."
1313
Removed:
name
1314
Removed:
| Workout_import.Normal_sets_unconfirmed ->
1315
Removed:
"The normal sets need a confirmation acknowledgement."
1316
Removed:
1317
Removed:
let set_view workout (s : Workout_import.source_set) :
1318
Removed:
View_model.Import_set.t =
1319
Removed:
let mapping =
1320
Removed:
Workout_import.workout_mapping workout
1321
Removed:
~source_name:s.Workout_import.exercise_name
1322
Removed:
|> Option.map Exercise.name
1323
Removed:
in
1324
Removed:
{
1325
Removed:
row = s.Workout_import.row;
1326
Removed:
exercise_name = s.Workout_import.exercise_name;
1327
Removed:
set_type = set_type_string s.Workout_import.set_type;
1328
Removed:
weight = Printf.sprintf "%g" s.Workout_import.weight_kg;
1329
Removed:
reps = string_of_int s.Workout_import.reps;
1330
Removed:
mapping;
1331
Removed:
}
1332
Removed:
1333
Removed:
let workout_view (workout : Workout_import.workout) :
1334
Removed:
View_model.Import_workout.t =
1335
Removed:
{
1336
Removed:
id =
1337
Removed:
Workout_import.workout_id_to_string
1338
Removed:
(Workout_import.workout_identity workout);
1339
Removed:
title = Workout_import.workout_title workout;
1340
Removed:
sets = List.map (set_view workout) (Workout_import.workout_sets workout);
1341
Removed:
blockers = List.map blocker_string (Workout_import.blockers workout);
1342
Removed:
acknowledgement = Workout_import.workout_acknowledgement workout;
1343
Removed:
revision = Workout_import.workout_revision workout;
1344
Removed:
}
1345
Removed:
1346
Removed:
let review_view (batch : Workout_import.batch) : View_model.Import_review.t
1347
Removed:
=
1348
Removed:
{
1349
Removed:
batch_id =
1350
Removed:
Workout_import.batch_id_to_string
1351
Removed:
(Workout_import.batch_identity batch);
1352
Removed:
warnings = List.map warning_view (Workout_import.batch_warnings batch);
1353
Removed:
workouts = List.map workout_view (Workout_import.batch_workouts batch);
1354
Removed:
}
1355
Removed:
1356
Removed:
let viewer_of (trainee : Trainee.t) =
1357
Removed:
{
1358
Removed:
View_model.Viewer.username = Trainee.username_to_string trainee.username;
1359
Removed:
}
1360
Removed:
1361
Removed:
(* A distinct batch id even when a duplicate override re-imports the same
1362
Removed:
source: the fingerprint prefix, the import time in seconds, and a random
1363
Removed:
suffix keep two imports of one export apart, so an override never
1364
Removed:
overwrites the original batch. *)
1365
Removed:
let generate_batch_id ~fingerprint ~imported_at =
1366
Removed:
let prefix =
1367
Removed:
String.sub fingerprint 0 (min 8 (String.length fingerprint))
1368
Removed:
in
1369
Removed:
let seconds = Recovery.timestamp_to_unix_seconds imported_at in
1370
Removed:
let suffix = Dream.to_base64url (Dream.random 6) in
1371
Removed:
Printf.sprintf "%s-%d-%s" prefix seconds suffix
1372
Removed:
1373
Removed:
(* Extract the single CSV file and the offset from a verified multipart
1374
Removed:
form. Dream verifies the CSRF token, so a bad token never reaches here. *)
1375
Removed:
let read_upload request =
1376
Removed:
Dream.multipart ~csrf:true request >|= function
1377
Removed:
| `Ok fields -> (
1378
Removed:
let csv =
1379
Removed:
match List.assoc_opt "csv" fields with
1380
Removed:
| Some ((_, content) :: _) -> Some content
1381
Removed:
| _ -> None
1382
Removed:
in
1383
Removed:
let offset =
1384
Removed:
match List.assoc_opt "utc_offset_seconds" fields with
1385
Removed:
| Some ((_, raw) :: _) -> int_of_string_opt (String.trim raw)
1386
Removed:
| _ -> None
1387
Removed:
in
1388
Removed:
let allow_duplicate =
1389
Removed:
match List.assoc_opt "allow_duplicate" fields with
1390
Removed:
| Some ((_, "true") :: _) -> true
1391
Removed:
| _ -> false
1392
Removed:
in
1393
Removed:
match (csv, offset) with
1394
Removed:
| Some source, Some offset -> Ok (source, offset, allow_duplicate)
1395
Removed:
| _ -> Error `Bad_request)
1396
Removed:
| _ -> Error `Bad_request
1397
Removed:
1398
Removed:
let upload t trainee request =
1399
Removed:
read_upload request >>= function
1400
Removed:
| Error `Bad_request ->
1401
Removed:
redirect_with_flash request Routes.profile
1402
Removed:
"The import upload is missing its file or offset."
1403
Removed:
| Ok (source, _, _) when String.length source > max_source_bytes ->
1404
Removed:
redirect_with_flash request Routes.profile
1405
Removed:
"The import file exceeds the 10 MiB limit."
1406
Removed:
| Ok (source, utc_offset_seconds, allow_duplicate) -> (
1407
Removed:
let fingerprint = Digest.to_hex (Digest.string source) in
1408
Removed:
let imported_at = t.now () in
1409
Removed:
let batch_id =
1410
Removed:
Workout_import.batch_id
1411
Removed:
(generate_batch_id ~fingerprint ~imported_at)
1412
Removed:
in
1413
Removed:
match
1414
Removed:
Hevy_csv.parse ~batch_id ~fingerprint ~imported_at
1415
Removed:
~utc_offset_seconds source
1416
Removed:
with
1417
Removed:
| Error e ->
1418
Removed:
redirect_with_flash request Routes.profile
1419
Removed:
(Format.asprintf "%a" Hevy_csv.pp_error e)
1420
Removed:
| Ok batch -> (
1421
Removed:
let allow_duplicate = if allow_duplicate then Some () else None in
1422
Removed:
Service.store_import_batch t.service trainee.Trainee.id
1423
Removed:
?allow_duplicate batch
1424
Removed:
>>= function
1425
Removed:
| Ok () ->
1426
Removed:
redirect_with_flash_attr request
1427
Removed:
(Dream_html.path_attr Dream_html.HTML.href
1428
Removed:
Routes.import_review
1429
Removed:
(Workout_import.batch_id_to_string batch_id))
1430
Removed:
"Import stored. Review it below."
1431
Removed:
| Error `Duplicate_source ->
1432
Removed:
redirect_with_flash request Routes.profile
1433
Removed:
"This export was already imported. Re-submit with the \
1434
Removed:
duplicate override to import it again."
1435
Removed:
| Error _ ->
1436
Removed:
redirect_with_flash request Routes.profile
1437
Removed:
"The import could not be stored."))
1438
Removed:
1439
Removed:
let review_target t trainee id =
1440
Removed:
Service.find_import_batch t.service trainee (Workout_import.batch_id id)
1441
Removed:
1442
Removed:
let review_url id =
1443
Removed:
Dream_html.path_attr Dream_html.HTML.href Routes.import_review id
1444
Removed:
1445
Removed:
let review t trainee request id =
1446
Removed:
review_target t trainee.Trainee.id id >>= function
1447
Removed:
| None -> not_found "That import batch no longer exists."
1448
Removed:
| Some batch ->
1449
Removed:
html
1450
Removed:
(Pages.import_review request ~viewer:(viewer_of trainee)
1451
Removed:
(review_view batch))
1452
Removed:
1453
Removed:
let map t trainee request batch_id workout_id =
1454
Removed:
Dream.form request >>= function
1455
Removed:
| `Ok fields -> (
1456
Removed:
match
1457
Removed:
( List.assoc_opt "source_name" fields,
1458
Removed:
List.assoc_opt "exercise_id" fields )
1459
Removed:
with
1460
Removed:
| Some source_name, Some exercise_id -> (
1461
Removed:
match Exercise.find_id (String.trim exercise_id) with
1462
Removed:
| None ->
1463
Removed:
redirect_with_flash_attr request (review_url batch_id)
1464
Removed:
"That exercise id is not in the catalogue."
1465
Removed:
| Some exercise -> (
1466
Removed:
Service.map_import_exercise t.service trainee.Trainee.id
1467
Removed:
~batch:(Workout_import.batch_id batch_id)
1468
Removed:
~workout:(Workout_import.workout_id workout_id)
1469
Removed:
~source_name exercise
1470
Removed:
>>= function
1471
Removed:
| Ok _ ->
1472
Removed:
redirect_with_flash_attr request (review_url batch_id)
1473
Removed:
"Exercise mapped."
1474
Removed:
| Error `Unknown_batch ->
1475
Removed:
not_found "That import batch no longer exists."
1476
Removed:
| Error _ ->
1477
Removed:
redirect_with_flash_attr request (review_url batch_id)
1478
Removed:
"That mapping could not be applied."))
1479
Removed:
| _ ->
1480
Removed:
redirect_with_flash_attr request (review_url batch_id)
1481
Removed:
Present.form_invalid)
1482
Removed:
| _ ->
1483
Removed:
redirect_with_flash_attr request (review_url batch_id)
1484
Removed:
Present.form_invalid
1485
Removed:
1486
Removed:
let confirm t trainee request batch_id workout_id =
1487
Removed:
Dream.form request >>= function
1488
Removed:
| `Ok fields -> (
1489
Removed:
match List.assoc_opt "acknowledgement" fields with
1490
Removed:
| Some acknowledgement -> (
1491
Removed:
Service.confirm_import_normal_sets t.service trainee.Trainee.id
1492
Removed:
~batch:(Workout_import.batch_id batch_id)
1493
Removed:
~workout:(Workout_import.workout_id workout_id)
1494
Removed:
~acknowledgement
1495
Removed:
>>= function
1496
Removed:
| Ok _ ->
1497
Removed:
redirect_with_flash_attr request (review_url batch_id)
1498
Removed:
"Normal sets confirmed."
1499
Removed:
| Error `Unknown_batch ->
1500
Removed:
not_found "That import batch no longer exists."
1501
Removed:
| Error (`Import Workout_import.Empty_acknowledgement) ->
1502
Removed:
redirect_with_flash_attr request (review_url batch_id)
1503
Removed:
"Enter an acknowledgement before confirming."
1504
Removed:
| Error _ ->
1505
Removed:
redirect_with_flash_attr request (review_url batch_id)
1506
Removed:
"That confirmation could not be applied.")
1507
Removed:
| None ->
1508
Removed:
redirect_with_flash_attr request (review_url batch_id)
1509
Removed:
Present.form_invalid)
1510
Removed:
| _ ->
1511
Removed:
redirect_with_flash_attr request (review_url batch_id)
1512
Removed:
Present.form_invalid
1513
Removed:
1514
Removed:
let promote_workout t trainee request batch_id workout_id =
1515
Removed:
guard_csrf request >>= function
1516
Removed:
| Error _ ->
1517
Removed:
redirect_with_flash_attr request (review_url batch_id)
1518
Removed:
Present.form_invalid
1519
Removed:
| Ok () -> (
1520
Removed:
Service.promote_import_workout t.service trainee.Trainee.id
1521
Removed:
~batch:(Workout_import.batch_id batch_id)
1522
Removed:
~workout:(Workout_import.workout_id workout_id)
1523
Removed:
>>= function
1524
Removed:
| Ok (Workout_import.Promoted _) ->
1525
Removed:
redirect_with_flash_attr request (review_url batch_id)
1526
Removed:
"Workout promoted."
1527
Removed:
| Ok (Workout_import.Already_promoted _) ->
1528
Removed:
redirect_with_flash_attr request (review_url batch_id)
1529
Removed:
"Workout was already promoted."
1530
Removed:
| Ok (Workout_import.Blocked blockers) ->
1531
Removed:
redirect_with_flash_attr request (review_url batch_id)
1532
Removed:
(Printf.sprintf "Workout blocked: %s"
1533
Removed:
(String.concat " " (List.map blocker_string blockers)))
1534
Removed:
| Error `Unknown_batch ->
1535
Removed:
not_found "That import batch no longer exists."
1536
Removed:
| Error _ ->
1537
Removed:
redirect_with_flash_attr request (review_url batch_id)
1538
Removed:
"That promotion could not be applied.")
1539
Removed:
1540
Removed:
let promote_batch t trainee request batch_id =
1541
Removed:
guard_csrf request >>= function
1542
Removed:
| Error _ ->
1543
Removed:
redirect_with_flash_attr request (review_url batch_id)
1544
Removed:
Present.form_invalid
1545
Removed:
| Ok () -> (
1546
Removed:
Service.promote_import_batch t.service trainee.Trainee.id
1547
Removed:
~batch:(Workout_import.batch_id batch_id)
1548
Removed:
>>= function
1549
Removed:
| Ok result ->
1550
Removed:
let promoted = List.length result.Workout_import.promoted in
1551
Removed:
let already =
1552
Removed:
List.length result.Workout_import.already_promoted
1553
Removed:
in
1554
Removed:
let blocked = List.length result.Workout_import.blocked in
1555
Removed:
redirect_with_flash_attr request (review_url batch_id)
1556
Removed:
(Printf.sprintf "Promoted %d, already promoted %d, blocked %d."
1557
Removed:
promoted already blocked)
1558
Removed:
| Error `Unknown_batch ->
1559
Removed:
not_found "That import batch no longer exists."
1560
Removed:
| Error _ ->
1561
Removed:
redirect_with_flash_attr request (review_url batch_id)
1562
Removed:
"That promotion could not be applied.")
1563
Removed:
1564
Removed:
let routes t =
1565
Removed:
[
1566
Removed:
Dream_html.post Routes.import_upload (fun request ->
1567
Removed:
authenticated t request (fun trainee -> upload t trainee request));
1568
Removed:
Dream_html.get Routes.import_review (fun request id ->
1569
Removed:
authenticated t request (fun trainee -> review t trainee request id));
1570
Removed:
Dream_html.post Routes.import_map (fun request batch_id workout_id ->
1571
Removed:
authenticated t request (fun trainee ->
1572
Removed:
map t trainee request batch_id workout_id));
1573
Removed:
Dream_html.post Routes.import_confirm
1574
Removed:
(fun request batch_id workout_id ->
1575
Removed:
authenticated t request (fun trainee ->
1576
Removed:
confirm t trainee request batch_id workout_id));
1577
Removed:
Dream_html.post Routes.import_promote_workout
1578
Removed:
(fun request batch_id workout_id ->
1579
Removed:
authenticated t request (fun trainee ->
1580
Removed:
promote_workout t trainee request batch_id workout_id));
1581
Removed:
Dream_html.post Routes.import_promote_batch (fun request batch_id ->
1582
Removed:
authenticated t request (fun trainee ->
1583
Removed:
promote_batch t trainee request batch_id));
1584
Removed:
]
1585
Removed:
end
1586
Removed:
1587
Removed:
module Assets = struct
1588
Removed:
let stylesheet =
1589
Removed:
match Stylesheet.read "hito.css" with
1590
Removed:
| Some stylesheet -> stylesheet
1591
Removed:
| None -> failwith "Embedded stylesheet hito.css is missing"
1592
Removed:
1593
Removed:
let workout_client =
1594
Removed:
match Workout_client_asset.read "workout_client.js" with
1595
Removed:
| Some script -> script
1596
Removed:
| None -> failwith "Embedded workout client is missing"
1597
Removed:
1598
Removed:
let routes =
1599
Removed:
[
1600
Removed:
Dream_html.get Routes.stylesheet (fun _ ->
1601
Removed:
Dream.respond
1602
Removed:
~headers:[ ("Content-Type", "text/css; charset=utf-8") ]
1603
Removed:
stylesheet);
1604
Removed:
Dream_html.get Routes.workout_client (fun _ ->
1605
Removed:
Dream.respond
1606
Removed:
~headers:
1607
Removed:
[ ("Content-Type", "application/javascript; charset=utf-8") ]
1608
Removed:
workout_client);
1609
Removed:
]
1610
Removed:
end
3
Added:
open Hito_presenter
4
Added:
5
Added:
(* The web controller. Each feature lives in its own [Handlers_<feature>] module,
6
Added:
a functor over the shared [Handlers_kit]. [Make] instantiates the kit once and
7
Added:
threads that single instance through every feature, so their [t], [Service],
8
Added:
and [Present] types are identical. It then assembles the route table and the
9
Added:
error handler. See [handlers.mli] for the public surface. *)
10
Added:
11
Added:
module Make (R : Repository.S) (H : Password_hash.S) = struct
12
Added:
module Kit = Handlers_kit.Make (R) (H)
13
Added:
include Kit
14
Added:
module Auth = Handlers_auth.Make (R) (H) (Kit)
15
Added:
module Overview = Handlers_overview.Make (R) (H) (Kit)
16
Added:
module Current_workout = Handlers_current_workout.Make (R) (H) (Kit)
17
Added:
module Logbook = Handlers_logbook.Make (R) (H) (Kit)
18
Added:
module App_feedback = Handlers_app_feedback.Make (R) (H) (Kit)
19
Added:
module Profile = Handlers_profile.Make (R) (H) (Kit)
20
Added:
module Settings = Handlers_settings.Make (R) (H) (Kit)
21
Added:
module Import = Handlers_import.Make (R) (H) (Kit)
22
Added:
module Assets = Handlers_assets
1611
23
1612
24
(* A catch-all for any path no route claims. It renders the branded 404 so an
1613
25
unknown URL keeps the navigation and leaks nothing, rather than the empty
lib/web/handlers_app_feedback.ml
@@ -0,0 +1,141 @@
1
Added:
open Lwt.Infix
2
Added:
open Hito_app
3
Added:
open Hito_presenter
4
Added:
5
Added:
module Make
6
Added:
(R : Repository.S)
7
Added:
(H : Password_hash.S)
8
Added:
(Kit : module type of Handlers_kit.Make (R) (H)) =
9
Added:
struct
10
Added:
open Kit
11
Added:
12
Added:
let tab request =
13
Added:
match Dream.query request "tab" with
14
Added:
| Some "submitted" -> `Submitted
15
Added:
| _ -> `Write
16
Added:
17
Added:
let time_to_string timestamp =
18
Added:
let tm =
19
Added:
Unix.gmtime (float_of_int (Recovery.timestamp_to_unix_seconds timestamp))
20
Added:
in
21
Added:
Printf.sprintf "%04d-%02d-%02d %02d:%02d" (tm.Unix.tm_year + 1900)
22
Added:
(tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min
23
Added:
24
Added:
(* Map a repository record into the view model the presenter renders, so no
25
Added:
entity or record crosses the boundary into Pages. *)
26
Added:
let view_of (report : Repository.app_feedback) : View_model.App_feedback.t =
27
Added:
{
28
Added:
id = Repository.app_feedback_id_to_string report.Repository.feedback_id;
29
Added:
author = report.Repository.author;
30
Added:
contributions = report.Repository.contributions;
31
Added:
submitted_at = time_to_string report.Repository.submitted_at;
32
Added:
message = report.Repository.message;
33
Added:
upvotes = report.Repository.upvotes;
34
Added:
viewer_upvoted = report.Repository.viewer_upvoted;
35
Added:
viewer_owns = report.Repository.viewer_owns;
36
Added:
}
37
Added:
38
Added:
let show t trainee request =
39
Added:
let viewer =
40
Added:
{
41
Added:
View_model.Viewer.username =
42
Added:
Trainee.username_to_string trainee.Trainee.username;
43
Added:
}
44
Added:
in
45
Added:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
46
Added:
Service.app_feedback t.service trainee.Trainee.id >>= fun reports ->
47
Added:
html
48
Added:
(Pages.app_feedback request
49
Added:
~logging:(Option.is_some in_progress)
50
Added:
~viewer ~tab:(tab request) (List.map view_of reports))
51
Added:
52
Added:
let submit t trainee request =
53
Added:
decode_form Decode.app_feedback request >>= function
54
Added:
| Error _ ->
55
Added:
redirect_with_flash request
56
Added:
(Dream_html.string_attr "href" "/app-feedback?tab=write")
57
Added:
Present.form_invalid
58
Added:
| Ok message -> (
59
Added:
Service.record_app_feedback t.service trainee.Trainee.id
60
Added:
~submitted_at:(t.now ()) ~message
61
Added:
>>= function
62
Added:
| Ok _ ->
63
Added:
redirect_with_flash request
64
Added:
(Dream_html.string_attr "href" "/app-feedback?tab=submitted")
65
Added:
"Feedback submitted."
66
Added:
| Error `Empty_message ->
67
Added:
redirect_with_flash request
68
Added:
(Dream_html.string_attr "href" "/app-feedback?tab=write")
69
Added:
Present.app_feedback_empty
70
Added:
| Error `Unknown_feedback ->
71
Added:
redirect_with_flash request
72
Added:
(Dream_html.string_attr "href" "/app-feedback?tab=submitted")
73
Added:
"That feedback is no longer available.")
74
Added:
75
Added:
let upvote t trainee request id =
76
Added:
guard_csrf request >>= function
77
Added:
| Error _ ->
78
Added:
redirect_with_flash request
79
Added:
(Dream_html.string_attr "href" "/app-feedback?tab=submitted")
80
Added:
Present.form_invalid
81
Added:
| Ok () ->
82
Added:
Service.upvote_app_feedback t.service trainee.Trainee.id
83
Added:
(Repository.app_feedback_id id)
84
Added:
>>= fun added ->
85
Added:
redirect_with_flash request
86
Added:
(Dream_html.string_attr "href" "/app-feedback?tab=submitted")
87
Added:
(if added then "Vote recorded." else "Vote was not added.")
88
Added:
89
Added:
let edit t trainee request id =
90
Added:
decode_form Decode.app_feedback request >>= function
91
Added:
| Error _ ->
92
Added:
redirect_with_flash request
93
Added:
(Dream_html.string_attr "href" "/app-feedback?tab=submitted")
94
Added:
Present.form_invalid
95
Added:
| Ok message -> (
96
Added:
Service.edit_app_feedback t.service trainee.Trainee.id
97
Added:
(Repository.app_feedback_id id)
98
Added:
~message
99
Added:
>>= function
100
Added:
| Ok () ->
101
Added:
redirect_with_flash request
102
Added:
(Dream_html.string_attr "href" "/app-feedback?tab=submitted")
103
Added:
"Feedback updated."
104
Added:
| Error `Empty_message ->
105
Added:
redirect_with_flash request
106
Added:
(Dream_html.string_attr "href" "/app-feedback?tab=submitted")
107
Added:
Present.app_feedback_empty
108
Added:
| Error `Unknown_feedback ->
109
Added:
redirect_with_flash request
110
Added:
(Dream_html.string_attr "href" "/app-feedback?tab=submitted")
111
Added:
"That feedback is no longer available.")
112
Added:
113
Added:
let remove t trainee request id =
114
Added:
guard_csrf request >>= function
115
Added:
| Error _ ->
116
Added:
redirect_with_flash request
117
Added:
(Dream_html.string_attr "href" "/app-feedback?tab=submitted")
118
Added:
Present.form_invalid
119
Added:
| Ok () ->
120
Added:
Service.remove_app_feedback t.service trainee.Trainee.id
121
Added:
(Repository.app_feedback_id id)
122
Added:
>>= fun removed ->
123
Added:
redirect_with_flash request
124
Added:
(Dream_html.string_attr "href" "/app-feedback?tab=submitted")
125
Added:
(if removed then "Feedback removed."
126
Added:
else "That feedback is no longer available.")
127
Added:
128
Added:
let routes t =
129
Added:
[
130
Added:
Dream_html.get Routes.app_feedback (fun request ->
131
Added:
authenticated t request (fun trainee -> show t trainee request));
132
Added:
Dream_html.post Routes.submit_app_feedback (fun request ->
133
Added:
authenticated t request (fun trainee -> submit t trainee request));
134
Added:
Dream_html.post Routes.upvote_app_feedback (fun request id ->
135
Added:
authenticated t request (fun trainee -> upvote t trainee request id));
136
Added:
Dream_html.post Routes.edit_app_feedback (fun request id ->
137
Added:
authenticated t request (fun trainee -> edit t trainee request id));
138
Added:
Dream_html.post Routes.remove_app_feedback (fun request id ->
139
Added:
authenticated t request (fun trainee -> remove t trainee request id));
140
Added:
]
141
Added:
end
lib/web/handlers_assets.ml
@@ -0,0 +1,26 @@
1
Added:
(** Static asset routes. Kept outside the controller functor because they have
2
Added:
no service or session dependency. *)
3
Added:
4
Added:
open Hito_presenter
5
Added:
6
Added:
let stylesheet =
7
Added:
match Stylesheet.read "hito.css" with
8
Added:
| Some stylesheet -> stylesheet
9
Added:
| None -> failwith "Embedded stylesheet hito.css is missing"
10
Added:
11
Added:
let workout_client =
12
Added:
match Workout_client_asset.read "workout_client.js" with
13
Added:
| Some script -> script
14
Added:
| None -> failwith "Embedded workout client is missing"
15
Added:
16
Added:
let routes =
17
Added:
[
18
Added:
Dream_html.get Routes.stylesheet (fun _ ->
19
Added:
Dream.respond
20
Added:
~headers:[ ("Content-Type", "text/css; charset=utf-8") ]
21
Added:
stylesheet);
22
Added:
Dream_html.get Routes.workout_client (fun _ ->
23
Added:
Dream.respond
24
Added:
~headers:[ ("Content-Type", "application/javascript; charset=utf-8") ]
25
Added:
workout_client);
26
Added:
]
lib/web/handlers_auth.ml
@@ -0,0 +1,76 @@
1
Added:
open Lwt.Infix
2
Added:
open Hito_app
3
Added:
open Hito_presenter
4
Added:
5
Added:
module Make
6
Added:
(R : Repository.S)
7
Added:
(H : Password_hash.S)
8
Added:
(Kit : module type of Handlers_kit.Make (R) (H)) =
9
Added:
struct
10
Added:
open Kit
11
Added:
12
Added:
let login_page t request =
13
Added:
current_trainee t request >>= function
14
Added:
| Some _ -> redirect_to request Routes.home
15
Added:
| None ->
16
Added:
html (Pages.login request ~registration_open:t.registration_open ())
17
Added:
18
Added:
let register_page t request =
19
Added:
current_trainee t request >>= function
20
Added:
| Some _ -> redirect_to request Routes.home
21
Added:
| None -> html (Pages.register request ())
22
Added:
23
Added:
let establish request (trainee : Trainee.t) =
24
Added:
Dream.set_session_field request session_key
25
Added:
(Trainee.id_to_string trainee.id)
26
Added:
>>= fun () -> redirect_to request Routes.home
27
Added:
28
Added:
let register t request =
29
Added:
read_credentials request >>= function
30
Added:
| Error _ ->
31
Added:
html ~status:`Bad_Request
32
Added:
(Pages.register request ~error:Present.form_invalid ())
33
Added:
| Ok (username, password) -> (
34
Added:
Service.register t.service ~username ~password >>= function
35
Added:
| Ok trainee -> establish request trainee
36
Added:
| Error err ->
37
Added:
html ~status:`Bad_Request
38
Added:
(Pages.register request ~error:(Present.registration err) ()))
39
Added:
40
Added:
let login t request =
41
Added:
read_credentials request >>= function
42
Added:
| Error _ ->
43
Added:
html ~status:`Bad_Request
44
Added:
(Pages.login request ~error:Present.form_invalid ())
45
Added:
| Ok (username, password) -> (
46
Added:
Service.authenticate t.service ~username ~password >>= function
47
Added:
| Some trainee -> establish request trainee
48
Added:
| None ->
49
Added:
html ~status:`Unauthorized
50
Added:
(Pages.login request ~error:Present.sign_in_failed ()))
51
Added:
52
Added:
let logout _t request =
53
Added:
guard_csrf request >>= function
54
Added:
| Error _ -> bad_request Present.form_invalid
55
Added:
| Ok () ->
56
Added:
Dream.invalidate_session request >>= fun () ->
57
Added:
redirect_to request Routes.login
58
Added:
59
Added:
let routes t =
60
Added:
(* Public sign-up is disabled by default. The [/register] routes appear
61
Added:
only when [registration_open] is set. Everything else is unconditional. *)
62
Added:
let register_routes =
63
Added:
if t.registration_open then
64
Added:
[
65
Added:
Dream_html.get Routes.register (register_page t);
66
Added:
Dream_html.post Routes.register (register t);
67
Added:
]
68
Added:
else []
69
Added:
in
70
Added:
[
71
Added:
Dream_html.get Routes.login (login_page t);
72
Added:
Dream_html.post Routes.login (login t);
73
Added:
Dream_html.post Routes.logout (logout t);
74
Added:
]
75
Added:
@ register_routes
76
Added:
end
lib/web/handlers_current_workout.ml
@@ -0,0 +1,158 @@
1
Added:
open Lwt.Infix
2
Added:
open Hito_app
3
Added:
open Hito_presenter
4
Added:
5
Added:
module Make
6
Added:
(R : Repository.S)
7
Added:
(H : Password_hash.S)
8
Added:
(Kit : module type of Handlers_kit.Make (R) (H)) =
9
Added:
struct
10
Added:
open Kit
11
Added:
12
Added:
let begin_workout t trainee request =
13
Added:
decode_form Decode.override request >>= function
14
Added:
| Error _ ->
15
Added:
redirect_with_flash request
16
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.home)
17
Added:
Present.form_invalid
18
Added:
| Ok override -> (
19
Added:
Service.active_routine t.service trainee.Trainee.id >>= function
20
Added:
| None -> redirect_to request Routes.routines
21
Added:
| Some (routine, _) -> (
22
Added:
let override = if override then Some () else None in
23
Added:
Service.begin_workout t.service trainee.Trainee.id ~routine
24
Added:
~now:(t.now ()) ?override ()
25
Added:
>>= function
26
Added:
| Ok _ ->
27
Added:
redirect_with_flash request
28
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
29
Added:
"Workout started."
30
Added:
| Error (Service.Not_recovered _) ->
31
Added:
redirect_with_flash request
32
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.home)
33
Added:
"The workout needs an explicit recovery override."
34
Added:
| Error Service.Unknown_routine -> not_found Present.unknown_routine
35
Added:
))
36
Added:
37
Added:
let show t trainee request =
38
Added:
let viewer =
39
Added:
{
40
Added:
View_model.Viewer.username =
41
Added:
Trainee.username_to_string trainee.Trainee.username;
42
Added:
}
43
Added:
in
44
Added:
Service.in_progress t.service trainee.Trainee.id >>= function
45
Added:
| Some workout ->
46
Added:
let active_slot = active_slot request workout in
47
Added:
html
48
Added:
(Pages.workout request ~viewer ~record_id:None ~active_slot
49
Added:
(workout_view ~active_slot workout))
50
Added:
| None -> redirect_to request Routes.home
51
Added:
52
Added:
let log t trainee request slot =
53
Added:
Service.in_progress t.service trainee.Trainee.id >>= function
54
Added:
| None -> not_found Present.no_workout
55
Added:
| Some workout -> (
56
Added:
match outstanding workout slot with
57
Added:
| None -> not_found Present.slot_not_awaiting
58
Added:
| Some prescription -> (
59
Added:
decode_form (Decode.stimulus prescription) request >>= function
60
Added:
| Error (`Invalid errors) ->
61
Added:
redirect_with_flash request
62
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
63
Added:
(Decode.errors_to_text errors)
64
Added:
| Error `Bad_request ->
65
Added:
redirect_with_flash request
66
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
67
Added:
Present.form_invalid
68
Added:
| Ok stimulus -> (
69
Added:
save_current t trainee.Trainee.id stimulus >>= function
70
Added:
| Ok () ->
71
Added:
redirect_with_flash request
72
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
73
Added:
"Record saved."
74
Added:
| Error detail ->
75
Added:
redirect_with_flash request
76
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
77
Added:
detail)))
78
Added:
79
Added:
(* Correct a recorded slot of the workout in progress. The slot may be
80
Added:
filled, so its prescription comes from the workout, not [outstanding].
81
Added:
[replace_current] targets the slot and never adds volume. *)
82
Added:
let edit t trainee request slot =
83
Added:
Service.in_progress t.service trainee.Trainee.id >>= function
84
Added:
| None -> not_found Present.no_workout
85
Added:
| Some workout -> (
86
Added:
match prescription_at workout slot with
87
Added:
| None -> not_found Present.slot_not_awaiting
88
Added:
| Some prescription -> (
89
Added:
decode_form (Decode.stimulus prescription) request >>= function
90
Added:
| Error (`Invalid errors) ->
91
Added:
redirect_with_flash request
92
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
93
Added:
(Decode.errors_to_text errors)
94
Added:
| Error `Bad_request ->
95
Added:
redirect_with_flash request
96
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
97
Added:
Present.form_invalid
98
Added:
| Ok stimulus -> (
99
Added:
replace_current t trainee.Trainee.id ~slot stimulus >>= function
100
Added:
| Ok () ->
101
Added:
redirect_with_flash request
102
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
103
Added:
"Record saved."
104
Added:
| Error detail ->
105
Added:
redirect_with_flash request
106
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
107
Added:
detail)))
108
Added:
109
Added:
let finish t trainee request =
110
Added:
guard_csrf request >>= function
111
Added:
| Error _ ->
112
Added:
redirect_with_flash request
113
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.home)
114
Added:
Present.form_invalid
115
Added:
| Ok () -> (
116
Added:
Service.finish t.service trainee.Trainee.id ~ended_at:(t.now ())
117
Added:
>>= function
118
Added:
| Some _ ->
119
Added:
redirect_with_flash request
120
Added:
(Dream_html.string_attr "href" "/logbook?prompt=feedback")
121
Added:
"Workout finished."
122
Added:
| None ->
123
Added:
redirect_with_flash request
124
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.home)
125
Added:
Present.no_workout)
126
Added:
127
Added:
(* Cancelling discards the current workout and returns Home. An abandoned
128
Added:
session is not evidence, so it leaves no record. A forged or missing
129
Added:
CSRF token skips the discard but still leaves the workout view. *)
130
Added:
let cancel t trainee request =
131
Added:
guard_csrf request >>= function
132
Added:
| Error _ ->
133
Added:
redirect_with_flash request
134
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.home)
135
Added:
"Workout cancellation was not confirmed."
136
Added:
| Ok () ->
137
Added:
Service.cancel t.service trainee.Trainee.id >>= fun _ ->
138
Added:
redirect_with_flash request
139
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.home)
140
Added:
"Workout cancelled."
141
Added:
142
Added:
let routes t =
143
Added:
[
144
Added:
Dream_html.get Routes.workout (fun request ->
145
Added:
authenticated t request (fun trainee -> show t trainee request));
146
Added:
Dream_html.post Routes.workout (fun request ->
147
Added:
authenticated t request (fun trainee ->
148
Added:
begin_workout t trainee request));
149
Added:
Dream_html.post Routes.workout_slot (fun request slot ->
150
Added:
authenticated t request (fun trainee -> log t trainee request slot));
151
Added:
Dream_html.post Routes.workout_slot_edit (fun request slot ->
152
Added:
authenticated t request (fun trainee -> edit t trainee request slot));
153
Added:
Dream_html.post Routes.finish_workout (fun request ->
154
Added:
authenticated t request (fun trainee -> finish t trainee request));
155
Added:
Dream_html.post Routes.cancel_workout (fun request ->
156
Added:
authenticated t request (fun trainee -> cancel t trainee request));
157
Added:
]
158
Added:
end
lib/web/handlers_import.ml
@@ -0,0 +1,299 @@
1
Added:
open Lwt.Infix
2
Added:
open Hito_app
3
Added:
open Hito_presenter
4
Added:
5
Added:
module Make
6
Added:
(R : Repository.S)
7
Added:
(H : Password_hash.S)
8
Added:
(Kit : module type of Handlers_kit.Make (R) (H)) =
9
Added:
struct
10
Added:
open Kit
11
Added:
12
Added:
let max_source_bytes = 10 * 1024 * 1024
13
Added:
14
Added:
(* Phrase an adapter warning for the view. The controller owns the wording,
15
Added:
so no warning variant crosses into the presenter. *)
16
Added:
let warning_view (w : Workout_import.warning) : View_model.Import_warning.t =
17
Added:
let detail =
18
Added:
match w.Workout_import.kind with
19
Added:
| Workout_import.Warmup_dropped -> "warmup set dropped"
20
Added:
| Workout_import.Unsupported_row reason -> reason
21
Added:
in
22
Added:
{ row = w.Workout_import.row; detail }
23
Added:
24
Added:
let set_type_string : Workout_import.source_set_type -> string = function
25
Added:
| Workout_import.Normal -> "normal"
26
Added:
| Workout_import.Failure -> "failure"
27
Added:
| Workout_import.Dropset -> "dropset"
28
Added:
29
Added:
(* Phrase one promotion blocker for the view. *)
30
Added:
let blocker_string : Workout_import.blocker -> string = function
31
Added:
| Workout_import.No_sets -> "The workout has no promotable sets."
32
Added:
| Workout_import.Dropset_present rows ->
33
Added:
Printf.sprintf "Drop sets cannot be promoted (rows %s)."
34
Added:
(String.concat ", " (List.map string_of_int rows))
35
Added:
| Workout_import.Unmapped_exercise name ->
36
Added:
Printf.sprintf "The exercise %S is not mapped to a catalog entry." name
37
Added:
| Workout_import.Normal_sets_unconfirmed ->
38
Added:
"The normal sets need a confirmation acknowledgement."
39
Added:
40
Added:
let set_view workout (s : Workout_import.source_set) : View_model.Import_set.t
41
Added:
=
42
Added:
let mapping =
43
Added:
Workout_import.workout_mapping workout
44
Added:
~source_name:s.Workout_import.exercise_name
45
Added:
|> Option.map Exercise.name
46
Added:
in
47
Added:
{
48
Added:
row = s.Workout_import.row;
49
Added:
exercise_name = s.Workout_import.exercise_name;
50
Added:
set_type = set_type_string s.Workout_import.set_type;
51
Added:
weight = Printf.sprintf "%g" s.Workout_import.weight_kg;
52
Added:
reps = string_of_int s.Workout_import.reps;
53
Added:
mapping;
54
Added:
}
55
Added:
56
Added:
let workout_view (workout : Workout_import.workout) :
57
Added:
View_model.Import_workout.t =
58
Added:
{
59
Added:
id =
60
Added:
Workout_import.workout_id_to_string
61
Added:
(Workout_import.workout_identity workout);
62
Added:
title = Workout_import.workout_title workout;
63
Added:
sets = List.map (set_view workout) (Workout_import.workout_sets workout);
64
Added:
blockers = List.map blocker_string (Workout_import.blockers workout);
65
Added:
acknowledgement = Workout_import.workout_acknowledgement workout;
66
Added:
revision = Workout_import.workout_revision workout;
67
Added:
}
68
Added:
69
Added:
let review_view (batch : Workout_import.batch) : View_model.Import_review.t =
70
Added:
{
71
Added:
batch_id =
72
Added:
Workout_import.batch_id_to_string (Workout_import.batch_identity batch);
73
Added:
warnings = List.map warning_view (Workout_import.batch_warnings batch);
74
Added:
workouts = List.map workout_view (Workout_import.batch_workouts batch);
75
Added:
}
76
Added:
77
Added:
let viewer_of (trainee : Trainee.t) =
78
Added:
{ View_model.Viewer.username = Trainee.username_to_string trainee.username }
79
Added:
80
Added:
(* A distinct batch id even when a duplicate override re-imports the same
81
Added:
source: the fingerprint prefix, the import time in seconds, and a random
82
Added:
suffix keep two imports of one export apart, so an override never
83
Added:
overwrites the original batch. *)
84
Added:
let generate_batch_id ~fingerprint ~imported_at =
85
Added:
let prefix = String.sub fingerprint 0 (min 8 (String.length fingerprint)) in
86
Added:
let seconds = Recovery.timestamp_to_unix_seconds imported_at in
87
Added:
let suffix = Dream.to_base64url (Dream.random 6) in
88
Added:
Printf.sprintf "%s-%d-%s" prefix seconds suffix
89
Added:
90
Added:
(* Extract the single CSV file and the offset from a verified multipart
91
Added:
form. Dream verifies the CSRF token, so a bad token never reaches here. *)
92
Added:
let read_upload request =
93
Added:
Dream.multipart ~csrf:true request >|= function
94
Added:
| `Ok fields -> (
95
Added:
let csv =
96
Added:
match List.assoc_opt "csv" fields with
97
Added:
| Some ((_, content) :: _) -> Some content
98
Added:
| _ -> None
99
Added:
in
100
Added:
let offset =
101
Added:
match List.assoc_opt "utc_offset_seconds" fields with
102
Added:
| Some ((_, raw) :: _) -> int_of_string_opt (String.trim raw)
103
Added:
| _ -> None
104
Added:
in
105
Added:
let allow_duplicate =
106
Added:
match List.assoc_opt "allow_duplicate" fields with
107
Added:
| Some ((_, "true") :: _) -> true
108
Added:
| _ -> false
109
Added:
in
110
Added:
match (csv, offset) with
111
Added:
| Some source, Some offset -> Ok (source, offset, allow_duplicate)
112
Added:
| _ -> Error `Bad_request)
113
Added:
| _ -> Error `Bad_request
114
Added:
115
Added:
let upload t trainee request =
116
Added:
read_upload request >>= function
117
Added:
| Error `Bad_request ->
118
Added:
redirect_with_flash request
119
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.profile)
120
Added:
"The import upload is missing its file or offset."
121
Added:
| Ok (source, _, _) when String.length source > max_source_bytes ->
122
Added:
redirect_with_flash request
123
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.profile)
124
Added:
"The import file exceeds the 10 MiB limit."
125
Added:
| Ok (source, utc_offset_seconds, allow_duplicate) -> (
126
Added:
let fingerprint = Digest.to_hex (Digest.string source) in
127
Added:
let imported_at = t.now () in
128
Added:
let batch_id =
129
Added:
Workout_import.batch_id (generate_batch_id ~fingerprint ~imported_at)
130
Added:
in
131
Added:
match
132
Added:
Hevy_csv.parse ~batch_id ~fingerprint ~imported_at ~utc_offset_seconds
133
Added:
source
134
Added:
with
135
Added:
| Error e ->
136
Added:
redirect_with_flash request
137
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.profile)
138
Added:
(Format.asprintf "%a" Hevy_csv.pp_error e)
139
Added:
| Ok batch -> (
140
Added:
let allow_duplicate = if allow_duplicate then Some () else None in
141
Added:
Service.store_import_batch t.service trainee.Trainee.id
142
Added:
?allow_duplicate batch
143
Added:
>>= function
144
Added:
| Ok () ->
145
Added:
redirect_with_flash request
146
Added:
(Dream_html.path_attr Dream_html.HTML.href
147
Added:
Routes.import_review
148
Added:
(Workout_import.batch_id_to_string batch_id))
149
Added:
"Import stored. Review it below."
150
Added:
| Error `Duplicate_source ->
151
Added:
redirect_with_flash request
152
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.profile)
153
Added:
"This export was already imported. Re-submit with the \
154
Added:
duplicate override to import it again."
155
Added:
| Error _ ->
156
Added:
redirect_with_flash request
157
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.profile)
158
Added:
"The import could not be stored."))
159
Added:
160
Added:
let review_target t trainee id =
161
Added:
Service.find_import_batch t.service trainee (Workout_import.batch_id id)
162
Added:
163
Added:
let review_url id =
164
Added:
Dream_html.path_attr Dream_html.HTML.href Routes.import_review id
165
Added:
166
Added:
let review t trainee request id =
167
Added:
review_target t trainee.Trainee.id id >>= function
168
Added:
| None -> not_found "That import batch no longer exists."
169
Added:
| Some batch ->
170
Added:
html
171
Added:
(Pages.import_review request ~viewer:(viewer_of trainee)
172
Added:
(review_view batch))
173
Added:
174
Added:
let map t trainee request batch_id workout_id =
175
Added:
Dream.form request >>= function
176
Added:
| `Ok fields -> (
177
Added:
match
178
Added:
( List.assoc_opt "source_name" fields,
179
Added:
List.assoc_opt "exercise_id" fields )
180
Added:
with
181
Added:
| Some source_name, Some exercise_id -> (
182
Added:
match Exercise.find_id (String.trim exercise_id) with
183
Added:
| None ->
184
Added:
redirect_with_flash request (review_url batch_id)
185
Added:
"That exercise id is not in the catalogue."
186
Added:
| Some exercise -> (
187
Added:
Service.map_import_exercise t.service trainee.Trainee.id
188
Added:
~batch:(Workout_import.batch_id batch_id)
189
Added:
~workout:(Workout_import.workout_id workout_id)
190
Added:
~source_name exercise
191
Added:
>>= function
192
Added:
| Ok _ ->
193
Added:
redirect_with_flash request (review_url batch_id)
194
Added:
"Exercise mapped."
195
Added:
| Error `Unknown_batch ->
196
Added:
not_found "That import batch no longer exists."
197
Added:
| Error _ ->
198
Added:
redirect_with_flash request (review_url batch_id)
199
Added:
"That mapping could not be applied."))
200
Added:
| _ ->
201
Added:
redirect_with_flash request (review_url batch_id)
202
Added:
Present.form_invalid)
203
Added:
| _ ->
204
Added:
redirect_with_flash request (review_url batch_id) Present.form_invalid
205
Added:
206
Added:
let confirm t trainee request batch_id workout_id =
207
Added:
Dream.form request >>= function
208
Added:
| `Ok fields -> (
209
Added:
match List.assoc_opt "acknowledgement" fields with
210
Added:
| Some acknowledgement -> (
211
Added:
Service.confirm_import_normal_sets t.service trainee.Trainee.id
212
Added:
~batch:(Workout_import.batch_id batch_id)
213
Added:
~workout:(Workout_import.workout_id workout_id)
214
Added:
~acknowledgement
215
Added:
>>= function
216
Added:
| Ok _ ->
217
Added:
redirect_with_flash request (review_url batch_id)
218
Added:
"Normal sets confirmed."
219
Added:
| Error `Unknown_batch ->
220
Added:
not_found "That import batch no longer exists."
221
Added:
| Error (`Import Workout_import.Empty_acknowledgement) ->
222
Added:
redirect_with_flash request (review_url batch_id)
223
Added:
"Enter an acknowledgement before confirming."
224
Added:
| Error _ ->
225
Added:
redirect_with_flash request (review_url batch_id)
226
Added:
"That confirmation could not be applied.")
227
Added:
| None ->
228
Added:
redirect_with_flash request (review_url batch_id)
229
Added:
Present.form_invalid)
230
Added:
| _ ->
231
Added:
redirect_with_flash request (review_url batch_id) Present.form_invalid
232
Added:
233
Added:
let promote_workout t trainee request batch_id workout_id =
234
Added:
guard_csrf request >>= function
235
Added:
| Error _ ->
236
Added:
redirect_with_flash request (review_url batch_id) Present.form_invalid
237
Added:
| Ok () -> (
238
Added:
Service.promote_import_workout t.service trainee.Trainee.id
239
Added:
~batch:(Workout_import.batch_id batch_id)
240
Added:
~workout:(Workout_import.workout_id workout_id)
241
Added:
>>= function
242
Added:
| Ok (Workout_import.Promoted _) ->
243
Added:
redirect_with_flash request (review_url batch_id)
244
Added:
"Workout promoted."
245
Added:
| Ok (Workout_import.Already_promoted _) ->
246
Added:
redirect_with_flash request (review_url batch_id)
247
Added:
"Workout was already promoted."
248
Added:
| Ok (Workout_import.Blocked blockers) ->
249
Added:
redirect_with_flash request (review_url batch_id)
250
Added:
(Printf.sprintf "Workout blocked: %s"
251
Added:
(String.concat " " (List.map blocker_string blockers)))
252
Added:
| Error `Unknown_batch ->
253
Added:
not_found "That import batch no longer exists."
254
Added:
| Error _ ->
255
Added:
redirect_with_flash request (review_url batch_id)
256
Added:
"That promotion could not be applied.")
257
Added:
258
Added:
let promote_batch t trainee request batch_id =
259
Added:
guard_csrf request >>= function
260
Added:
| Error _ ->
261
Added:
redirect_with_flash request (review_url batch_id) Present.form_invalid
262
Added:
| Ok () -> (
263
Added:
Service.promote_import_batch t.service trainee.Trainee.id
264
Added:
~batch:(Workout_import.batch_id batch_id)
265
Added:
>>= function
266
Added:
| Ok result ->
267
Added:
let promoted = List.length result.Workout_import.promoted in
268
Added:
let already = List.length result.Workout_import.already_promoted in
269
Added:
let blocked = List.length result.Workout_import.blocked in
270
Added:
redirect_with_flash request (review_url batch_id)
271
Added:
(Printf.sprintf "Promoted %d, already promoted %d, blocked %d."
272
Added:
promoted already blocked)
273
Added:
| Error `Unknown_batch ->
274
Added:
not_found "That import batch no longer exists."
275
Added:
| Error _ ->
276
Added:
redirect_with_flash request (review_url batch_id)
277
Added:
"That promotion could not be applied.")
278
Added:
279
Added:
let routes t =
280
Added:
[
281
Added:
Dream_html.post Routes.import_upload (fun request ->
282
Added:
authenticated t request (fun trainee -> upload t trainee request));
283
Added:
Dream_html.get Routes.import_review (fun request id ->
284
Added:
authenticated t request (fun trainee -> review t trainee request id));
285
Added:
Dream_html.post Routes.import_map (fun request batch_id workout_id ->
286
Added:
authenticated t request (fun trainee ->
287
Added:
map t trainee request batch_id workout_id));
288
Added:
Dream_html.post Routes.import_confirm (fun request batch_id workout_id ->
289
Added:
authenticated t request (fun trainee ->
290
Added:
confirm t trainee request batch_id workout_id));
291
Added:
Dream_html.post Routes.import_promote_workout
292
Added:
(fun request batch_id workout_id ->
293
Added:
authenticated t request (fun trainee ->
294
Added:
promote_workout t trainee request batch_id workout_id));
295
Added:
Dream_html.post Routes.import_promote_batch (fun request batch_id ->
296
Added:
authenticated t request (fun trainee ->
297
Added:
promote_batch t trainee request batch_id));
298
Added:
]
299
Added:
end
lib/web/handlers_kit.ml
@@ -0,0 +1,336 @@
1
Added:
open Lwt.Infix
2
Added:
open Hito_app
3
Added:
open Hito_presenter
4
Added:
5
Added:
(* The controller kit: the functor-shared context every feature controller
6
Added:
builds on. [Handlers.Make] instantiates it once and passes the result to
7
Added:
each feature module. It holds the service instance type, error phrasing
8
Added:
([Present]), session and CSRF plumbing, and the service-to-view-model
9
Added:
projections. Feature modules [open] the applied kit to see the [t] record
10
Added:
fields and these helpers. *)
11
Added:
12
Added:
module Make (R : Repository.S) (H : Password_hash.S) = struct
13
Added:
module Service = Service.Make (R) (H)
14
Added:
15
Added:
type t = {
16
Added:
service : Service.t;
17
Added:
now : unit -> Recovery.timestamp;
18
Added:
registration_open : bool;
19
Added:
}
20
Added:
21
Added:
let default_now () =
22
Added:
Recovery.timestamp_of_unix_seconds (int_of_float (Unix.gettimeofday ()))
23
Added:
24
Added:
let make ~repo ?(now = default_now) ?(registration_open = false) () =
25
Added:
{ service = Service.make ~repo; now; registration_open }
26
Added:
27
Added:
let flash_key = "hito.flash"
28
Added:
let html ?status page = Dream_html.respond ?status page
29
Added:
let redirect request path = Dream_html.redirect request path
30
Added:
31
Added:
let redirect_to request path =
32
Added:
redirect request (Dream_html.path_attr Dream_html.HTML.href path)
33
Added:
34
Added:
(* Set the transient flash message, then redirect to [href]. [href] is a
35
Added:
dream-html [href] attribute, so callers pass a typed route path built with
36
Added:
[path_attr] or a literal [string_attr "href" ...]. One helper covers every
37
Added:
redirect-with-flash: route paths, captured paths, and query-string URLs. *)
38
Added:
let redirect_with_flash request href message =
39
Added:
Dream.set_session_field request flash_key message >>= fun () ->
40
Added:
Dream_html.redirect request href
41
Added:
42
Added:
let not_found detail =
43
Added:
html (Pages.problem ~title:"Not found" ~detail) ~status:`Not_Found
44
Added:
45
Added:
let bad_request detail =
46
Added:
html (Pages.problem ~title:"Invalid request" ~detail) ~status:`Bad_Request
47
Added:
48
Added:
(* --- presentation of errors ---
49
Added:
50
Added:
Every domain and service error becomes a user-facing sentence here, so a
51
Added:
handler renders a message rather than deciding its wording. One module owns
52
Added:
the phrasing, and adding an error variant surfaces as a missing case. *)
53
Added:
module Present = struct
54
Added:
let form_invalid = "The submitted form is not valid."
55
Added:
56
Added:
let registration : Service.register_error -> string = function
57
Added:
| `Username e -> Format.asprintf "%a" Trainee.pp_username_error e
58
Added:
| `Username_taken -> "That username is already registered."
59
Added:
60
Added:
let sign_in_failed = "That username and password do not match."
61
Added:
let routine = Format.asprintf "%a" Service.pp_error
62
Added:
63
Added:
let log_error : Service.log_error -> string = function
64
Added:
| Service.No_workout_in_progress -> "No workout is in progress."
65
Added:
| Service.Rejected error ->
66
Added:
Format.asprintf "%a" Evidence.Workout.pp_error error
67
Added:
68
Added:
let edit_error : Service.edit_error -> string = function
69
Added:
| Service.Unknown_workout -> "That saved workout no longer exists."
70
Added:
| Service.Rejected_edit error ->
71
Added:
Format.asprintf "%a" Evidence.Workout.pp_error error
72
Added:
73
Added:
let unknown_routine = "That routine is not in the catalogue."
74
Added:
let unknown_record = "That saved workout no longer exists."
75
Added:
let no_workout = "No workout is in progress."
76
Added:
let slot_not_awaiting = "That slot is not awaiting a record."
77
Added:
78
Added:
let change_username : Service.change_username_error -> string = function
79
Added:
| `Username e -> Format.asprintf "%a" Trainee.pp_username_error e
80
Added:
| `Username_taken -> "That username is already registered."
81
Added:
| `Unknown -> "That account no longer exists."
82
Added:
83
Added:
let change_password : Service.change_password_error -> string = function
84
Added:
| `Incorrect_password -> "The current password is not correct."
85
Added:
| `Unknown -> "That account no longer exists."
86
Added:
87
Added:
let app_feedback_empty = "Enter feedback before submitting."
88
Added:
let username_changed = "Username changed."
89
Added:
let password_changed = "Password changed."
90
Added:
end
91
Added:
92
Added:
(* --- sessions and authentication --- *)
93
Added:
94
Added:
let session_key = "trainee"
95
Added:
96
Added:
let current_trainee t request =
97
Added:
match Dream.session_field request session_key with
98
Added:
| None -> Lwt.return None
99
Added:
| Some id -> Service.find_trainee t.service (Trainee.id id)
100
Added:
101
Added:
(* Resolve the authenticated trainee, or send an unauthenticated request to
102
Added:
the sign-in page. [handler] receives the trainee. The request and any path
103
Added:
captures stay in the caller's scope, so this one combinator serves every
104
Added:
route regardless of how many captures Dream passes. *)
105
Added:
let authenticated t request handler =
106
Added:
current_trainee t request >>= function
107
Added:
| Some trainee -> (
108
Added:
handler trainee >>= fun response ->
109
Added:
match Dream.method_ request with
110
Added:
| `GET ->
111
Added:
Dream.drop_session_field request flash_key >|= fun () -> response
112
Added:
| _ -> Lwt.return response)
113
Added:
| None -> redirect_to request Routes.login
114
Added:
115
Added:
let decode_form decoder request =
116
Added:
Dream_html.form decoder ~csrf:true request >|= function
117
Added:
| `Ok value -> Ok value
118
Added:
| `Invalid errors -> Error (`Invalid errors)
119
Added:
| _ -> Error `Bad_request
120
Added:
121
Added:
(* Plain (non-dream-html) form read with CSRF, for auth forms. *)
122
Added:
let read_credentials request =
123
Added:
Dream.form request >|= function
124
Added:
| `Ok fields -> (
125
Added:
let get k = List.assoc_opt k fields in
126
Added:
match (get "username", get "password") with
127
Added:
| Some username, Some password -> Ok (username, password)
128
Added:
| _ -> Error `Bad_request)
129
Added:
| _ -> Error `Bad_request
130
Added:
131
Added:
(* A CSRF guard for state-changing POSTs whose body carries no fields other
132
Added:
than the token. [Dream.form] verifies the token and returns [`Ok] only
133
Added:
when it is valid, so this rejects a forged or missing token. *)
134
Added:
let guard_csrf request =
135
Added:
Dream.form request >|= function `Ok _ -> Ok () | _ -> Error `Bad_request
136
Added:
137
Added:
(* --- helpers over the service --- *)
138
Added:
139
Added:
let record_target t trainee id =
140
Added:
Service.find_record t.service trainee (Repository.workout_id id)
141
Added:
>|= Option.map (fun record ->
142
Added:
(record.Repository.id, record.Repository.workout))
143
Added:
144
Added:
let outstanding workout slot =
145
Added:
List.assoc_opt slot (Evidence.Workout.outstanding workout)
146
Added:
147
Added:
(* The prescription at any valid slot, filled or not — the edit handlers
148
Added:
correct filled slots, which [outstanding] does not list. *)
149
Added:
let prescription_at workout slot =
150
Added:
List.nth_opt
151
Added:
(Prescription.Workout.stimuli (Evidence.Workout.prescription workout))
152
Added:
slot
153
Added:
154
Added:
(* The slot a workout view should open on: the first slot still awaiting a
155
Added:
record, or the first slot when every slot is filled. A caller clamps a
156
Added:
requested slot against the prescription. This supplies the default. *)
157
Added:
let default_slot workout =
158
Added:
match Evidence.Workout.outstanding workout with
159
Added:
| (slot, _) :: _ -> slot
160
Added:
| [] -> 0
161
Added:
162
Added:
(* The slot a workout view should open on. An explicit [?slot=] query
163
Added:
wins when it names a real slot. Otherwise the view defaults to the first
164
Added:
incomplete slot. A [?slot=] out of range, or absent, falls back to the
165
Added:
default, so a bookmarked or hand-edited URL never renders an empty view. *)
166
Added:
let active_slot request workout =
167
Added:
let slot_count =
168
Added:
List.length
169
Added:
(Prescription.Workout.stimuli (Evidence.Workout.prescription workout))
170
Added:
in
171
Added:
match Dream.query request "slot" with
172
Added:
| Some raw -> (
173
Added:
match int_of_string_opt raw with
174
Added:
| Some slot when slot >= 0 && slot < slot_count -> slot
175
Added:
| _ -> default_slot workout)
176
Added:
| None -> default_slot workout
177
Added:
178
Added:
(* Map an [Evidence.Workout.t] into the view-model DTO the presenter renders,
179
Added:
so no Evidence or Prescription type crosses the boundary into Pages. The
180
Added:
same mapping serves the live workout and a saved-record view. The caller
181
Added:
supplies [record_id]/[editing]/[errors] separately. *)
182
Added:
183
Added:
(* The ending code a single-choice form uses, taken from an effort's outcome.
184
Added:
The form offers one ending, so the first extension stands for it. *)
185
Added:
let extension_code_of_effort effort =
186
Added:
match Evidence.Stimulus.Effort.outcome effort with
187
Added:
| Evidence.Stimulus.Positive_failure -> ""
188
Added:
| Evidence.Stimulus.Beyond_failure (first, _) -> (
189
Added:
match first with
190
Added:
| Evidence.Stimulus.Forced_reps -> "forced"
191
Added:
| Evidence.Stimulus.Negatives -> "negatives"
192
Added:
| Evidence.Stimulus.Rest_pause -> "rest-pause"
193
Added:
| Evidence.Stimulus.Static_hold -> "static")
194
Added:
195
Added:
(* One line describing a recorded stimulus: the efforts joined by "into", then
196
Added:
any extensions appended. *)
197
Added:
let describe_stimulus stimulus =
198
Added:
let effort effort =
199
Added:
Format.asprintf "%s %g kg x %d"
200
Added:
(Exercise.name (Evidence.Stimulus.Effort.exercise effort))
201
Added:
(Evidence.Stimulus.Effort.load effort)
202
Added:
(Evidence.Stimulus.Effort.reps effort)
203
Added:
in
204
Added:
let body =
205
Added:
String.concat " into "
206
Added:
(List.map effort (Evidence.Stimulus.efforts stimulus))
207
Added:
in
208
Added:
match Evidence.Stimulus.extensions stimulus with
209
Added:
| [] -> body
210
Added:
| extensions ->
211
Added:
body ^ ", "
212
Added:
^ String.concat " then "
213
Added:
(List.map
214
Added:
(Format.asprintf "%a" Evidence.Stimulus.pp_extension)
215
Added:
extensions)
216
Added:
217
Added:
let workout_view ~active_slot workout : View_model.Workout.t =
218
Added:
let prescription = Evidence.Workout.prescription workout in
219
Added:
let prescribed_slots = Prescription.Workout.stimuli prescription in
220
Added:
(* One entry per filled slot, the first fill in performance order — the fill
221
Added:
[replace_stimulus] keeps in place when a correction lands. *)
222
Added:
let filled =
223
Added:
List.fold_left
224
Added:
(fun acc (slot, stimulus) ->
225
Added:
if List.mem_assoc slot acc then acc else acc @ [ (slot, stimulus) ])
226
Added:
[]
227
Added:
(Evidence.Workout.performed workout)
228
Added:
in
229
Added:
let load_string load = Printf.sprintf "%g" load in
230
Added:
let reps_string reps = string_of_int reps in
231
Added:
let label p =
232
Added:
match Prescription.Stimulus.delivery p with
233
Added:
| Prescription.Stimulus.Single e -> Exercise.name e
234
Added:
| Prescription.Stimulus.Pre_exhaust { isolation; compound } ->
235
Added:
Printf.sprintf "%s + %s" (Exercise.name isolation)
236
Added:
(Exercise.name compound)
237
Added:
in
238
Added:
let slot_view index p : View_model.Workout.slot =
239
Added:
let recorded = List.assoc_opt index filled in
240
Added:
let efforts = Option.map Evidence.Stimulus.efforts recorded in
241
Added:
let nth n = Option.bind efforts (fun es -> List.nth_opt es n) in
242
Added:
let load_of n =
243
Added:
Option.map
244
Added:
(fun e -> load_string (Evidence.Stimulus.Effort.load e))
245
Added:
(nth n)
246
Added:
in
247
Added:
let reps_of n =
248
Added:
Option.map
249
Added:
(fun e -> reps_string (Evidence.Stimulus.Effort.reps e))
250
Added:
(nth n)
251
Added:
in
252
Added:
let movements : View_model.Workout.movement list =
253
Added:
match Prescription.Stimulus.delivery p with
254
Added:
| Prescription.Stimulus.Single exercise ->
255
Added:
[
256
Added:
{
257
Added:
name = Exercise.name exercise;
258
Added:
load_field = "load";
259
Added:
reps_field = "reps";
260
Added:
reps_label = "Reps to failure";
261
Added:
load_value = load_of 0;
262
Added:
reps_value = reps_of 0;
263
Added:
};
264
Added:
]
265
Added:
| Prescription.Stimulus.Pre_exhaust { isolation; compound } ->
266
Added:
[
267
Added:
{
268
Added:
name = Exercise.name isolation;
269
Added:
load_field = "iso_load";
270
Added:
reps_field = "iso_reps";
271
Added:
reps_label = "Reps";
272
Added:
load_value = load_of 0;
273
Added:
reps_value = reps_of 0;
274
Added:
};
275
Added:
{
276
Added:
name = Exercise.name compound;
277
Added:
load_field = "comp_load";
278
Added:
reps_field = "comp_reps";
279
Added:
reps_label = "Reps";
280
Added:
load_value = load_of 1;
281
Added:
reps_value = reps_of 1;
282
Added:
};
283
Added:
]
284
Added:
in
285
Added:
let selected_extension =
286
Added:
match recorded with
287
Added:
| None -> ""
288
Added:
| Some s -> (
289
Added:
(* The ending lives on the last effort (the compound of a pair). *)
290
Added:
match List.rev (Evidence.Stimulus.efforts s) with
291
Added:
| last :: _ -> extension_code_of_effort last
292
Added:
| [] -> "")
293
Added:
in
294
Added:
{
295
Added:
index;
296
Added:
label = label p;
297
Added:
movements;
298
Added:
recorded_summary = Option.map describe_stimulus recorded;
299
Added:
selected_extension;
300
Added:
}
301
Added:
in
302
Added:
let overridden =
303
Added:
match Recovery.basis (Evidence.Workout.clearance workout) with
304
Added:
| Recovery.Overridden _ -> true
305
Added:
| Recovery.Recovered -> false
306
Added:
in
307
Added:
{
308
Added:
name = Prescription.Workout.name prescription;
309
Added:
slots = List.mapi slot_view prescribed_slots;
310
Added:
active_slot;
311
Added:
started_at_unix =
312
Added:
Recovery.timestamp_to_unix_seconds (Evidence.Workout.started_at workout);
313
Added:
overridden;
314
Added:
all_recorded = Evidence.Workout.outstanding workout = [];
315
Added:
}
316
Added:
317
Added:
let save_current t trainee stimulus =
318
Added:
Service.log t.service trainee stimulus >|= function
319
Added:
| Ok _ -> Ok ()
320
Added:
| Error e -> Error (Present.log_error e)
321
Added:
322
Added:
let replace_current t trainee ~slot stimulus =
323
Added:
Service.replace_current t.service trainee ~slot stimulus >|= function
324
Added:
| Ok _ -> Ok ()
325
Added:
| Error e -> Error (Present.log_error e)
326
Added:
327
Added:
let save_record t trainee id stimulus =
328
Added:
Service.add_to_record t.service trainee id stimulus >|= function
329
Added:
| Ok _ -> Ok ()
330
Added:
| Error e -> Error (Present.edit_error e)
331
Added:
332
Added:
let replace_record t trainee id ~slot stimulus =
333
Added:
Service.replace_in_record t.service trainee id ~slot stimulus >|= function
334
Added:
| Ok _ -> Ok ()
335
Added:
| Error e -> Error (Present.edit_error e)
336
Added:
end
lib/web/handlers_logbook.ml
@@ -0,0 +1,377 @@
1
Added:
open Lwt.Infix
2
Added:
open Hito_app
3
Added:
open Hito_presenter
4
Added:
5
Added:
module Make
6
Added:
(R : Repository.S)
7
Added:
(H : Password_hash.S)
8
Added:
(Kit : module type of Handlers_kit.Make (R) (H)) =
9
Added:
struct
10
Added:
open Kit
11
Added:
12
Added:
let feedback_session_key = "hito.feedback.flow"
13
Added:
let feedback_factors = List.map fst Pages.feedback_factors
14
Added:
15
Added:
let valid_choice = function
16
Added:
| ("1" | "2" | "3" | "4" | "5") as choice -> Some choice
17
Added:
| _ -> None
18
Added:
19
Added:
let valid_factor field = List.mem field feedback_factors
20
Added:
21
Added:
let encode_feedback_flow (flow : Pages.feedback_flow) =
22
Added:
let answers =
23
Added:
List.map (fun (field, choice) -> field ^ ":" ^ choice) flow.answers
24
Added:
in
25
Added:
Printf.sprintf "%d|%s" flow.step (String.concat ";" answers)
26
Added:
27
Added:
let decode_feedback_flow raw =
28
Added:
match String.split_on_char '|' raw with
29
Added:
| [ step; answers ] -> (
30
Added:
match int_of_string_opt step with
31
Added:
| None -> None
32
Added:
| Some step when step < 0 || step > 5 -> None
33
Added:
| Some step ->
34
Added:
let answers =
35
Added:
answers |> String.split_on_char ';'
36
Added:
|> List.filter_map (fun answer ->
37
Added:
match String.split_on_char ':' answer with
38
Added:
| [ field; choice ]
39
Added:
when valid_factor field
40
Added:
&& Option.is_some (valid_choice choice) ->
41
Added:
Some (field, choice)
42
Added:
| _ -> None)
43
Added:
in
44
Added:
Some Pages.{ step; answers })
45
Added:
| _ -> None
46
Added:
47
Added:
let feedback_flow request =
48
Added:
Dream.session_field request feedback_session_key |> fun raw ->
49
Added:
Option.bind raw decode_feedback_flow
50
Added:
51
Added:
let initial_feedback_flow = Pages.{ step = 0; answers = [] }
52
Added:
53
Added:
let set_feedback_flow request flow =
54
Added:
Dream.set_session_field request feedback_session_key
55
Added:
(encode_feedback_flow flow)
56
Added:
57
Added:
let clear_feedback_flow request =
58
Added:
Dream.drop_session_field request feedback_session_key
59
Added:
60
Added:
let field name fields = List.assoc_opt name fields
61
Added:
62
Added:
let feedback_signals answers flags =
63
Added:
let level choice =
64
Added:
match int_of_string_opt choice with
65
Added:
| Some n -> (
66
Added:
match Evidence.Feedback.level_of_score n with
67
Added:
| Some l -> l
68
Added:
| None -> Evidence.Feedback.Fair)
69
Added:
| None -> Evidence.Feedback.Fair
70
Added:
in
71
Added:
let leveled field make =
72
Added:
List.find_map
73
Added:
(fun (answer_field, choice) ->
74
Added:
if String.equal field answer_field then
75
Added:
Option.map (fun choice -> make (level choice)) (valid_choice choice)
76
Added:
else None)
77
Added:
answers
78
Added:
in
79
Added:
let optional_flag name signal =
80
Added:
match field name flags with Some "true" -> Some signal | _ -> None
81
Added:
in
82
Added:
List.filter_map Fun.id
83
Added:
[
84
Added:
leveled "sleep" (fun l -> Evidence.Feedback.Sleep l);
85
Added:
leveled "appetite" (fun l -> Evidence.Feedback.Appetite l);
86
Added:
leveled "readiness" (fun l -> Evidence.Feedback.Readiness l);
87
Added:
leveled "motivation" (fun l -> Evidence.Feedback.Motivation l);
88
Added:
leveled "difficulty" (fun l -> Evidence.Feedback.Difficulty l);
89
Added:
optional_flag "pain" Evidence.Feedback.Pain;
90
Added:
optional_flag "injury" Evidence.Feedback.Injury;
91
Added:
optional_flag "preparation" Evidence.Feedback.Preparation_insufficient;
92
Added:
]
93
Added:
94
Added:
(* Describe one signal for the list, and compute a factor's score for the
95
Added:
graph. These read the Evidence.Feedback entity here in the controller, so
96
Added:
the presenter receives only strings and scores. *)
97
Added:
let describe_signal (signal : Evidence.Feedback.signal) =
98
Added:
let level l =
99
Added:
let score = Evidence.Feedback.level_to_score l in
100
Added:
match l with
101
Added:
| Evidence.Feedback.Very_poor -> Printf.sprintf "%d (very poor)" score
102
Added:
| Very_good -> Printf.sprintf "%d (very good)" score
103
Added:
| _ -> string_of_int score
104
Added:
in
105
Added:
match signal with
106
Added:
| Sleep l -> Printf.sprintf "Sleep %s" (level l)
107
Added:
| Appetite l -> Printf.sprintf "Appetite %s" (level l)
108
Added:
| Readiness l -> Printf.sprintf "Readiness %s" (level l)
109
Added:
| Motivation l -> Printf.sprintf "Motivation %s" (level l)
110
Added:
| Difficulty l -> Printf.sprintf "Difficulty %s" (level l)
111
Added:
| Pain -> "Pain"
112
Added:
| Injury -> "Injury"
113
Added:
| Preparation_insufficient -> "Preparation insufficient"
114
Added:
115
Added:
let factor_fields =
116
Added:
[ "sleep"; "appetite"; "readiness"; "motivation"; "difficulty" ]
117
Added:
118
Added:
let factor_score field (report : Evidence.Feedback.t) =
119
Added:
let of_signal (signal : Evidence.Feedback.signal) =
120
Added:
match (field, signal) with
121
Added:
| "sleep", Sleep l
122
Added:
| "appetite", Appetite l
123
Added:
| "readiness", Readiness l
124
Added:
| "motivation", Motivation l
125
Added:
| "difficulty", Difficulty l ->
126
Added:
Some (Evidence.Feedback.level_to_score l)
127
Added:
| _ -> None
128
Added:
in
129
Added:
List.find_map of_signal (Evidence.Feedback.signals report)
130
Added:
131
Added:
let entry_view (record : Repository.record) : View_model.Logbook_entry.t =
132
Added:
let workout = record.Repository.workout in
133
Added:
{
134
Added:
id = (record.Repository.id :> string);
135
Added:
workout_name =
136
Added:
Prescription.Workout.name (Evidence.Workout.prescription workout);
137
Added:
stimuli_count = List.length (Evidence.Workout.stimuli workout);
138
Added:
complete =
139
Added:
(match Evidence.Workout.completeness workout with
140
Added:
| Evidence.Workout.Complete -> true
141
Added:
| Incomplete -> false);
142
Added:
}
143
Added:
144
Added:
let feedback_view (report : Evidence.Feedback.t) : View_model.Feedback.report
145
Added:
=
146
Added:
{
147
Added:
at_unix =
148
Added:
Recovery.timestamp_to_unix_seconds
149
Added:
(Evidence.Feedback.reported_at report);
150
Added:
signals = List.map describe_signal (Evidence.Feedback.signals report);
151
Added:
factor_scores =
152
Added:
List.map (fun f -> (f, factor_score f report)) factor_fields;
153
Added:
}
154
Added:
155
Added:
let index t trainee request =
156
Added:
let viewer =
157
Added:
{
158
Added:
View_model.Viewer.username =
159
Added:
Trainee.username_to_string trainee.Trainee.username;
160
Added:
}
161
Added:
in
162
Added:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
163
Added:
Service.history t.service trainee.Trainee.id >>= fun records ->
164
Added:
Service.feedback t.service trainee.Trainee.id >>= fun feedback ->
165
Added:
let feedback = List.map feedback_view feedback in
166
Added:
let records = List.map entry_view records in
167
Added:
let saved_flow = feedback_flow request in
168
Added:
let feedback_open =
169
Added:
match (Dream.query request "feedback", Dream.query request "prompt") with
170
Added:
| Some "start", _ | _, Some "feedback" -> true
171
Added:
| _ -> Option.is_some saved_flow
172
Added:
in
173
Added:
html
174
Added:
(Pages.logbook request
175
Added:
~logging:(Option.is_some in_progress)
176
Added:
~viewer ~feedback
177
Added:
~suggest_feedback:
178
Added:
(match Dream.query request "prompt" with
179
Added:
| Some "feedback" -> true
180
Added:
| _ -> false)
181
Added:
~feedback_flow:(Option.value saved_flow ~default:initial_feedback_flow)
182
Added:
~feedback_open records)
183
Added:
184
Added:
let finish_feedback t trainee request flow flags =
185
Added:
let signals = feedback_signals flow.Pages.answers flags in
186
Added:
Service.record_feedback t.service trainee.Trainee.id ~reported_at:(t.now ())
187
Added:
signals
188
Added:
>>= function
189
Added:
| Ok _ ->
190
Added:
clear_feedback_flow request >>= fun () ->
191
Added:
redirect_with_flash request
192
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.logbook)
193
Added:
"Feedback saved."
194
Added:
| Error _ ->
195
Added:
clear_feedback_flow request >>= fun () ->
196
Added:
redirect_with_flash request
197
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.logbook)
198
Added:
Present.form_invalid
199
Added:
200
Added:
(* Advance one factor. The answer map stays in the session until the final
201
Added:
optional-observations step, so refreshes never lose earlier choices. *)
202
Added:
let record_feedback t trainee request =
203
Added:
Dream.form request >>= function
204
Added:
| `Ok fields -> (
205
Added:
let flow =
206
Added:
Option.value (feedback_flow request) ~default:initial_feedback_flow
207
Added:
in
208
Added:
match
209
Added:
field "step" fields |> fun raw ->
210
Added:
(Option.bind raw int_of_string_opt, flow.step)
211
Added:
with
212
Added:
| Some step, expected when step = expected ->
213
Added:
let action =
214
Added:
match field "action" fields with
215
Added:
| Some ("next" | "Next") -> Some "next"
216
Added:
| Some ("back" | "Back") -> Some "back"
217
Added:
| Some ("skip" | "Skip this factor" | "Skip this step") ->
218
Added:
Some "skip"
219
Added:
| Some ("save" | "Record feedback") -> Some "save"
220
Added:
| _ -> None
221
Added:
in
222
Added:
(* Back steps to the previous factor and keeps every answer, so a
223
Added:
trainee can revise an earlier report without losing the rest. *)
224
Added:
if action = Some "back" then
225
Added:
if step = 0 then redirect_to request Routes.logbook
226
Added:
else
227
Added:
let previous = Pages.{ flow with step = step - 1 } in
228
Added:
set_feedback_flow request previous >>= fun () ->
229
Added:
redirect_to request Routes.logbook
230
Added:
else if step = 5 then
231
Added:
if action = Some "skip" then
232
Added:
finish_feedback t trainee request flow []
233
Added:
else if action = Some "save" then
234
Added:
finish_feedback t trainee request flow fields
235
Added:
else
236
Added:
redirect_with_flash request
237
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.logbook)
238
Added:
Present.form_invalid
239
Added:
else
240
Added:
let factor = List.nth feedback_factors step in
241
Added:
let answers =
242
Added:
match
243
Added:
( action,
244
Added:
field "choice" fields |> fun raw ->
245
Added:
Option.bind raw valid_choice )
246
Added:
with
247
Added:
| Some "next", Some choice -> (factor, choice) :: flow.answers
248
Added:
| Some "skip", _ -> flow.answers
249
Added:
| _ -> flow.answers
250
Added:
in
251
Added:
if action <> Some "next" && action <> Some "skip" then
252
Added:
redirect_with_flash request
253
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.logbook)
254
Added:
Present.form_invalid
255
Added:
else
256
Added:
let next = Pages.{ step = step + 1; answers } in
257
Added:
set_feedback_flow request next >>= fun () ->
258
Added:
redirect_to request Routes.logbook
259
Added:
| _ ->
260
Added:
redirect_with_flash request
261
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.logbook)
262
Added:
Present.form_invalid)
263
Added:
| _ ->
264
Added:
redirect_with_flash request
265
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.logbook)
266
Added:
Present.form_invalid
267
Added:
268
Added:
let cancel_feedback _t _trainee request =
269
Added:
guard_csrf request >>= function
270
Added:
| Error _ ->
271
Added:
redirect_with_flash request
272
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.logbook)
273
Added:
Present.form_invalid
274
Added:
| Ok () ->
275
Added:
clear_feedback_flow request >>= fun () ->
276
Added:
redirect_with_flash request
277
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.logbook)
278
Added:
"Feedback skipped."
279
Added:
280
Added:
let show t trainee request id =
281
Added:
let viewer =
282
Added:
{
283
Added:
View_model.Viewer.username =
284
Added:
Trainee.username_to_string trainee.Trainee.username;
285
Added:
}
286
Added:
in
287
Added:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
288
Added:
record_target t trainee.Trainee.id id >>= function
289
Added:
| None -> not_found Present.unknown_record
290
Added:
| Some (_, workout) ->
291
Added:
let active_slot = active_slot request workout in
292
Added:
html
293
Added:
(Pages.workout request ~viewer
294
Added:
~logging:(Option.is_some in_progress)
295
Added:
~record_id:(Some id) ~active_slot
296
Added:
(workout_view ~active_slot workout))
297
Added:
298
Added:
let log t trainee request id slot =
299
Added:
record_target t trainee.Trainee.id id >>= function
300
Added:
| None -> not_found Present.unknown_record
301
Added:
| Some (record_id, workout) -> (
302
Added:
match outstanding workout slot with
303
Added:
| None -> not_found Present.slot_not_awaiting
304
Added:
| Some prescription -> (
305
Added:
decode_form (Decode.stimulus prescription) request >>= function
306
Added:
| Error (`Invalid errors) ->
307
Added:
redirect_with_flash request
308
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record id)
309
Added:
(Decode.errors_to_text errors)
310
Added:
| Error `Bad_request ->
311
Added:
redirect_with_flash request
312
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record id)
313
Added:
Present.form_invalid
314
Added:
| Ok stimulus -> (
315
Added:
save_record t trainee.Trainee.id record_id stimulus >>= function
316
Added:
| Ok () ->
317
Added:
redirect_with_flash request
318
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
319
Added:
id)
320
Added:
"Record saved."
321
Added:
| Error detail ->
322
Added:
redirect_with_flash request
323
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
324
Added:
id)
325
Added:
detail)))
326
Added:
327
Added:
(* Correct a recorded slot of a saved workout. [replace_record] targets the
328
Added:
slot, replacing its record rather than appending volume. *)
329
Added:
let edit t trainee request id slot =
330
Added:
record_target t trainee.Trainee.id id >>= function
331
Added:
| None -> not_found Present.unknown_record
332
Added:
| Some (record_id, workout) -> (
333
Added:
match prescription_at workout slot with
334
Added:
| None -> not_found Present.slot_not_awaiting
335
Added:
| Some prescription -> (
336
Added:
decode_form (Decode.stimulus prescription) request >>= function
337
Added:
| Error (`Invalid errors) ->
338
Added:
redirect_with_flash request
339
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record id)
340
Added:
(Decode.errors_to_text errors)
341
Added:
| Error `Bad_request ->
342
Added:
redirect_with_flash request
343
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record id)
344
Added:
Present.form_invalid
345
Added:
| Ok stimulus -> (
346
Added:
replace_record t trainee.Trainee.id record_id ~slot stimulus
347
Added:
>>= function
348
Added:
| Ok () ->
349
Added:
redirect_with_flash request
350
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
351
Added:
id)
352
Added:
"Record saved."
353
Added:
| Error detail ->
354
Added:
redirect_with_flash request
355
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
356
Added:
id)
357
Added:
detail)))
358
Added:
359
Added:
let routes t =
360
Added:
[
361
Added:
Dream_html.get Routes.logbook (fun request ->
362
Added:
authenticated t request (fun trainee -> index t trainee request));
363
Added:
Dream_html.post Routes.feedback (fun request ->
364
Added:
authenticated t request (fun trainee ->
365
Added:
record_feedback t trainee request));
366
Added:
Dream_html.post Routes.cancel_feedback (fun request ->
367
Added:
authenticated t request (fun trainee ->
368
Added:
cancel_feedback t trainee request));
369
Added:
Dream_html.get Routes.record (fun request id ->
370
Added:
authenticated t request (fun trainee -> show t trainee request id));
371
Added:
Dream_html.post Routes.record_slot (fun request id slot ->
372
Added:
authenticated t request (fun trainee -> log t trainee request id slot));
373
Added:
Dream_html.post Routes.record_slot_edit (fun request id slot ->
374
Added:
authenticated t request (fun trainee ->
375
Added:
edit t trainee request id slot));
376
Added:
]
377
Added:
end
lib/web/handlers_overview.ml
@@ -0,0 +1,177 @@
1
Added:
open Lwt.Infix
2
Added:
open Hito_app
3
Added:
open Hito_presenter
4
Added:
5
Added:
module Make
6
Added:
(R : Repository.S)
7
Added:
(H : Password_hash.S)
8
Added:
(Kit : module type of Handlers_kit.Make (R) (H)) =
9
Added:
struct
10
Added:
open Kit
11
Added:
12
Added:
(* Map service entities into the view-model DTOs the presenter renders, so
13
Added:
no Prescription or Recovery type crosses the boundary into Pages. These
14
Added:
replicate the phrasing the shared presenter formatters use. *)
15
Added:
let routine_choice_view
16
Added:
((rid, r) : Repository.routine_id * Prescription.Routine.t) :
17
Added:
View_model.Routine_choice.t =
18
Added:
{
19
Added:
id = (rid :> string);
20
Added:
name = Prescription.Routine.name r;
21
Added:
workout_count = List.length (Prescription.Routine.workouts r);
22
Added:
}
23
Added:
24
Added:
let exercise_string prescription =
25
Added:
match Prescription.Stimulus.delivery prescription with
26
Added:
| Prescription.Stimulus.Single exercise -> Exercise.name exercise
27
Added:
| Prescription.Stimulus.Pre_exhaust { isolation; compound } ->
28
Added:
Printf.sprintf "%s into %s, no pause" (Exercise.name isolation)
29
Added:
(Exercise.name compound)
30
Added:
31
Added:
let reps_string prescription =
32
Added:
let min_reps, max_reps =
33
Added:
Prescription.Rep_range.bounds
34
Added:
(Prescription.Stimulus.rep_range prescription)
35
Added:
in
36
Added:
Printf.sprintf "%d-%d" min_reps max_reps
37
Added:
38
Added:
let routine_view r : View_model.Routine.t =
39
Added:
{
40
Added:
name = Prescription.Routine.name r;
41
Added:
workouts =
42
Added:
List.map
43
Added:
(fun w : View_model.Routine.workout ->
44
Added:
{
45
Added:
name = Prescription.Workout.name w;
46
Added:
exercises =
47
Added:
List.map
48
Added:
(fun s : View_model.Routine.exercise ->
49
Added:
{ name = exercise_string s; reps = reps_string s })
50
Added:
(Prescription.Workout.stimuli w);
51
Added:
})
52
Added:
(Prescription.Routine.workouts r);
53
Added:
}
54
Added:
55
Added:
let duration_hours duration =
56
Added:
let hours = float_of_int (Recovery.duration_to_seconds duration) /. 3600. in
57
Added:
if Float.equal hours (Float.round hours) then Printf.sprintf "%.0fh" hours
58
Added:
else Printf.sprintf "%.1fh" hours
59
Added:
60
Added:
let home_view ~(routine : Repository.routine_id) ~routine_name ~next
61
Added:
~readiness : View_model.Home.t =
62
Added:
{
63
Added:
routine_id = (routine :> string);
64
Added:
routine_name;
65
Added:
next_workout = Prescription.Workout.name next;
66
Added:
gate =
67
Added:
(match readiness with
68
Added:
| Recovery.Ready -> View_model.Home.Ready
69
Added:
| Recovery.Recovering { rested; recommended } ->
70
Added:
View_model.Home.Recovering
71
Added:
{
72
Added:
status =
73
Added:
Printf.sprintf "Recovery: %s of %s." (duration_hours rested)
74
Added:
(duration_hours recommended);
75
Added:
});
76
Added:
}
77
Added:
78
Added:
let page t trainee request =
79
Added:
let viewer =
80
Added:
{
81
Added:
View_model.Viewer.username =
82
Added:
Trainee.username_to_string trainee.Trainee.username;
83
Added:
}
84
Added:
in
85
Added:
Service.in_progress t.service trainee.Trainee.id >>= function
86
Added:
| Some workout ->
87
Added:
let workout_name =
88
Added:
Prescription.Workout.name (Evidence.Workout.prescription workout)
89
Added:
in
90
Added:
Lwt.return (Pages.workout_in_progress request ~viewer ~workout_name)
91
Added:
| None -> (
92
Added:
Service.active_routine t.service trainee.Trainee.id >>= function
93
Added:
| None ->
94
Added:
Lwt.return
95
Added:
(Pages.choose_routine request ~logging:false ~viewer
96
Added:
~routines:
97
Added:
(List.map routine_choice_view
98
Added:
(Service.list_routines t.service)))
99
Added:
| Some (routine, selected) -> (
100
Added:
Service.next_workout t.service trainee.Trainee.id ~routine
101
Added:
>>= fun next ->
102
Added:
Service.readiness t.service trainee.Trainee.id ~routine
103
Added:
~now:(t.now ())
104
Added:
>|= fun readiness ->
105
Added:
match (next, readiness) with
106
Added:
| Ok next, Ok readiness ->
107
Added:
Pages.home request ~viewer
108
Added:
~home:
109
Added:
(home_view ~routine
110
Added:
~routine_name:(Prescription.Routine.name selected)
111
Added:
~next ~readiness)
112
Added:
| Error error, _ | _, Error error ->
113
Added:
Pages.problem ~title:"Routine unavailable"
114
Added:
~detail:(Present.routine error)))
115
Added:
116
Added:
let home t trainee request = page t trainee request >>= html
117
Added:
118
Added:
let routines t trainee request =
119
Added:
let viewer =
120
Added:
{
121
Added:
View_model.Viewer.username =
122
Added:
Trainee.username_to_string trainee.Trainee.username;
123
Added:
}
124
Added:
in
125
Added:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
126
Added:
html
127
Added:
(Pages.choose_routine request
128
Added:
~logging:(Option.is_some in_progress)
129
Added:
~viewer
130
Added:
~routines:
131
Added:
(List.map routine_choice_view (Service.list_routines t.service)))
132
Added:
133
Added:
let select_routine t trainee request id =
134
Added:
guard_csrf request >>= function
135
Added:
| Error _ ->
136
Added:
redirect_with_flash request
137
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.home)
138
Added:
Present.form_invalid
139
Added:
| Ok () -> (
140
Added:
Service.select_routine t.service trainee.Trainee.id
141
Added:
(Repository.routine_id id)
142
Added:
>>= function
143
Added:
| Ok () ->
144
Added:
redirect_with_flash request
145
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.home)
146
Added:
"Routine selected."
147
Added:
| Error _ -> not_found Present.unknown_routine)
148
Added:
149
Added:
let routine t trainee request =
150
Added:
let viewer =
151
Added:
{
152
Added:
View_model.Viewer.username =
153
Added:
Trainee.username_to_string trainee.Trainee.username;
154
Added:
}
155
Added:
in
156
Added:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
157
Added:
Service.active_routine t.service trainee.Trainee.id >>= function
158
Added:
| Some (_, routine) ->
159
Added:
html
160
Added:
(Pages.routine request
161
Added:
~logging:(Option.is_some in_progress)
162
Added:
~viewer (routine_view routine))
163
Added:
| None -> redirect_to request Routes.routines
164
Added:
165
Added:
let routes t =
166
Added:
[
167
Added:
Dream_html.get Routes.home (fun request ->
168
Added:
authenticated t request (fun trainee -> home t trainee request));
169
Added:
Dream_html.get Routes.routines (fun request ->
170
Added:
authenticated t request (fun trainee -> routines t trainee request));
171
Added:
Dream_html.post Routes.select_routine (fun request id ->
172
Added:
authenticated t request (fun trainee ->
173
Added:
select_routine t trainee request id));
174
Added:
Dream_html.get Routes.routine (fun request ->
175
Added:
authenticated t request (fun trainee -> routine t trainee request));
176
Added:
]
177
Added:
end
lib/web/handlers_profile.ml
@@ -0,0 +1,81 @@
1
Added:
open Lwt.Infix
2
Added:
open Hito_app
3
Added:
open Hito_presenter
4
Added:
5
Added:
module Make
6
Added:
(R : Repository.S)
7
Added:
(H : Password_hash.S)
8
Added:
(Kit : module type of Handlers_kit.Make (R) (H)) =
9
Added:
struct
10
Added:
open Kit
11
Added:
12
Added:
(* The profile page. A [?changed=] query set by a successful redirect shows
13
Added:
a confirmation notice, so a refresh never re-posts a change. *)
14
Added:
let show t trainee request =
15
Added:
let viewer =
16
Added:
{
17
Added:
View_model.Viewer.username =
18
Added:
Trainee.username_to_string trainee.Trainee.username;
19
Added:
}
20
Added:
in
21
Added:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
22
Added:
let notice =
23
Added:
match Dream.query request "changed" with
24
Added:
| Some "username" -> Some Present.username_changed
25
Added:
| Some "password" -> Some Present.password_changed
26
Added:
| _ -> None
27
Added:
in
28
Added:
html
29
Added:
(Pages.profile request
30
Added:
~logging:(Option.is_some in_progress)
31
Added:
~viewer ?notice ())
32
Added:
33
Added:
let render_error t trainee request ?username_error ?password_error () =
34
Added:
let viewer =
35
Added:
{
36
Added:
View_model.Viewer.username =
37
Added:
Trainee.username_to_string trainee.Trainee.username;
38
Added:
}
39
Added:
in
40
Added:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
41
Added:
html ~status:`Bad_Request
42
Added:
(Pages.profile request
43
Added:
~logging:(Option.is_some in_progress)
44
Added:
~viewer ?username_error ?password_error ())
45
Added:
46
Added:
let change_username t trainee request =
47
Added:
decode_form Decode.profile_username request >>= function
48
Added:
| Error _ -> bad_request Present.form_invalid
49
Added:
| Ok username -> (
50
Added:
Service.change_username t.service trainee.Trainee.id ~username
51
Added:
>>= function
52
Added:
| Ok _ -> Dream.redirect request "/profile?changed=username"
53
Added:
| Error error ->
54
Added:
render_error t trainee request
55
Added:
~username_error:(Present.change_username error)
56
Added:
())
57
Added:
58
Added:
let change_password t trainee request =
59
Added:
decode_form Decode.profile_password request >>= function
60
Added:
| Error _ -> bad_request Present.form_invalid
61
Added:
| Ok (current, next) -> (
62
Added:
Service.change_password t.service trainee.Trainee.id ~current ~next
63
Added:
>>= function
64
Added:
| Ok _ -> Dream.redirect request "/profile?changed=password"
65
Added:
| Error error ->
66
Added:
render_error t trainee request
67
Added:
~password_error:(Present.change_password error)
68
Added:
())
69
Added:
70
Added:
let routes t =
71
Added:
[
72
Added:
Dream_html.get Routes.profile (fun request ->
73
Added:
authenticated t request (fun trainee -> show t trainee request));
74
Added:
Dream_html.post Routes.profile_username (fun request ->
75
Added:
authenticated t request (fun trainee ->
76
Added:
change_username t trainee request));
77
Added:
Dream_html.post Routes.profile_password (fun request ->
78
Added:
authenticated t request (fun trainee ->
79
Added:
change_password t trainee request));
80
Added:
]
81
Added:
end
lib/web/handlers_settings.ml
@@ -0,0 +1,61 @@
1
Added:
open Lwt.Infix
2
Added:
open Hito_app
3
Added:
open Hito_presenter
4
Added:
5
Added:
module Make
6
Added:
(R : Repository.S)
7
Added:
(H : Password_hash.S)
8
Added:
(Kit : module type of Handlers_kit.Make (R) (H)) =
9
Added:
struct
10
Added:
open Kit
11
Added:
12
Added:
let theme_session_key = "hito.theme"
13
Added:
14
Added:
let theme request =
15
Added:
match Dream.session_field request theme_session_key with
16
Added:
| Some "dark" -> "dark"
17
Added:
| _ -> "light"
18
Added:
19
Added:
let show t trainee request =
20
Added:
let viewer =
21
Added:
{
22
Added:
View_model.Viewer.username =
23
Added:
Trainee.username_to_string trainee.Trainee.username;
24
Added:
}
25
Added:
in
26
Added:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
27
Added:
html
28
Added:
(Pages.settings request
29
Added:
~logging:(Option.is_some in_progress)
30
Added:
~viewer ~theme:(theme request) ())
31
Added:
32
Added:
let update _trainee request =
33
Added:
guard_csrf request >>= function
34
Added:
| Error _ ->
35
Added:
redirect_with_flash request
36
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.settings)
37
Added:
Present.form_invalid
38
Added:
| Ok () -> (
39
Added:
Dream.form request >>= function
40
Added:
| `Ok fields -> (
41
Added:
match List.assoc_opt "theme" fields with
42
Added:
| Some (("light" | "dark") as value) ->
43
Added:
Dream.set_session_field request theme_session_key value
44
Added:
>>= fun () -> Dream.redirect request "/settings"
45
Added:
| _ ->
46
Added:
redirect_with_flash request
47
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.settings)
48
Added:
Present.form_invalid)
49
Added:
| _ ->
50
Added:
redirect_with_flash request
51
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.settings)
52
Added:
Present.form_invalid)
53
Added:
54
Added:
let routes t =
55
Added:
[
56
Added:
Dream_html.get Routes.settings (fun request ->
57
Added:
authenticated t request (fun trainee -> show t trainee request));
58
Added:
Dream_html.post Routes.settings_theme (fun request ->
59
Added:
authenticated t request (fun trainee -> update trainee request));
60
Added:
]
61
Added:
end
test/dune
@@ -2,7 +2,7 @@
2
2
(name test_hito)
3
3
(modules
4
4
test_hito
5
Removed:
test_architecture
5
Added:
memory_repo
6
6
test_exercise
7
7
test_recovery
8
8
test_prescription
@@ -25,6 +25,7 @@
25
25
hito.app
26
26
hito.persistence
27
27
hito.web
28
Added:
hito.presenter
28
29
alcotest
29
30
dream
30
31
dream-html
test/memory_repo.ml
@@ -0,0 +1,495 @@
1
Added:
open Hito_app
2
Added:
3
Added:
(* Per-trainee mutable state, held in a hashtable keyed by trainee id. *)
4
Added:
type trainee_state = {
5
Added:
mutable active : Repository.routine_id option;
6
Added:
mutable current : Evidence.Workout.t option;
7
Added:
mutable stored : Repository.record list; (* most recent first *)
8
Added:
mutable feedback : Evidence.Feedback.t list; (* most recent first *)
9
Added:
mutable batches : Workout_import.batch list;
10
Added:
(* insertion order, newest first *)
11
Added:
mutable records : Repository.imported_record list; (* newest ended_at first *)
12
Added:
mutable next_id : int;
13
Added:
mutable next_app_feedback : int;
14
Added:
}
15
Added:
16
Added:
type t = {
17
Added:
mutable trainees : Trainee.t list;
18
Added:
states : (string, trainee_state) Hashtbl.t;
19
Added:
mutable app_feedback : (Trainee.id * Repository.app_feedback) list;
20
Added:
mutable app_feedback_votes : (Repository.app_feedback_id * Trainee.id) list;
21
Added:
mutable next_trainee : int;
22
Added:
}
23
Added:
24
Added:
let create () =
25
Added:
{
26
Added:
trainees = [];
27
Added:
states = Hashtbl.create 16;
28
Added:
app_feedback = [];
29
Added:
app_feedback_votes = [];
30
Added:
next_trainee = 1;
31
Added:
}
32
Added:
33
Added:
let state t id =
34
Added:
let key = Trainee.id_to_string id in
35
Added:
match Hashtbl.find_opt t.states key with
36
Added:
| Some s -> s
37
Added:
| None ->
38
Added:
let s =
39
Added:
{
40
Added:
active = None;
41
Added:
current = None;
42
Added:
stored = [];
43
Added:
feedback = [];
44
Added:
batches = [];
45
Added:
records = [];
46
Added:
next_id = 1;
47
Added:
next_app_feedback = 1;
48
Added:
}
49
Added:
in
50
Added:
Hashtbl.replace t.states key s;
51
Added:
s
52
Added:
53
Added:
let create_trainee t ~(username : Trainee.username) ~credential =
54
Added:
match
55
Added:
List.find_opt
56
Added:
(fun (tr : Trainee.t) ->
57
Added:
String.equal
58
Added:
(Trainee.username_to_string tr.username)
59
Added:
(Trainee.username_to_string username))
60
Added:
t.trainees
61
Added:
with
62
Added:
| Some _ -> Lwt.return (Error `Username_taken)
63
Added:
| None ->
64
Added:
let id = Trainee.id (Printf.sprintf "t%d" t.next_trainee) in
65
Added:
t.next_trainee <- t.next_trainee + 1;
66
Added:
let trainee = { Trainee.id; username; credential } in
67
Added:
t.trainees <- trainee :: t.trainees;
68
Added:
Lwt.return (Ok trainee)
69
Added:
70
Added:
let find_trainee_by_username t (username : Trainee.username) =
71
Added:
Lwt.return
72
Added:
(List.find_opt
73
Added:
(fun (tr : Trainee.t) ->
74
Added:
String.equal
75
Added:
(Trainee.username_to_string tr.username)
76
Added:
(Trainee.username_to_string username))
77
Added:
t.trainees)
78
Added:
79
Added:
let find_trainee t id =
80
Added:
Lwt.return
81
Added:
(List.find_opt
82
Added:
(fun (tr : Trainee.t) ->
83
Added:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
84
Added:
t.trainees)
85
Added:
86
Added:
let replace_trainee t (updated : Trainee.t) =
87
Added:
t.trainees <-
88
Added:
List.map
89
Added:
(fun (tr : Trainee.t) ->
90
Added:
if
91
Added:
String.equal
92
Added:
(Trainee.id_to_string tr.id)
93
Added:
(Trainee.id_to_string updated.id)
94
Added:
then updated
95
Added:
else tr)
96
Added:
t.trainees
97
Added:
98
Added:
let update_username t id (username : Trainee.username) =
99
Added:
match
100
Added:
List.find_opt
101
Added:
(fun (tr : Trainee.t) ->
102
Added:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
103
Added:
t.trainees
104
Added:
with
105
Added:
| None -> Lwt.return (Error `Username_taken)
106
Added:
| Some current ->
107
Added:
let taken =
108
Added:
List.exists
109
Added:
(fun (tr : Trainee.t) ->
110
Added:
(not
111
Added:
(String.equal
112
Added:
(Trainee.id_to_string tr.id)
113
Added:
(Trainee.id_to_string id)))
114
Added:
&& String.equal
115
Added:
(Trainee.username_to_string tr.username)
116
Added:
(Trainee.username_to_string username))
117
Added:
t.trainees
118
Added:
in
119
Added:
if taken then Lwt.return (Error `Username_taken)
120
Added:
else begin
121
Added:
let updated = { current with Trainee.username } in
122
Added:
replace_trainee t updated;
123
Added:
Lwt.return (Ok updated)
124
Added:
end
125
Added:
126
Added:
let update_credential t id credential =
127
Added:
match
128
Added:
List.find_opt
129
Added:
(fun (tr : Trainee.t) ->
130
Added:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
131
Added:
t.trainees
132
Added:
with
133
Added:
| None -> Lwt.return None
134
Added:
| Some current ->
135
Added:
let updated = { current with Trainee.credential } in
136
Added:
replace_trainee t updated;
137
Added:
Lwt.return (Some updated)
138
Added:
139
Added:
let list_routines _ = Catalog.routines
140
Added:
let find_routine _ id = Catalog.find id
141
Added:
let active_routine t id = Lwt.return (state t id).active
142
Added:
143
Added:
let set_active_routine t id routine =
144
Added:
(state t id).active <- Some routine;
145
Added:
Lwt.return_unit
146
Added:
147
Added:
let in_progress t id = Lwt.return (state t id).current
148
Added:
149
Added:
let set_in_progress t id workout =
150
Added:
(state t id).current <- workout;
151
Added:
Lwt.return_unit
152
Added:
153
Added:
(* Store the finished workout and clear the in-progress slot together. In
154
Added:
memory this is a single synchronous update, so it cannot tear. *)
155
Added:
let finish_workout t id workout =
156
Added:
let s = state t id in
157
Added:
let wid = Repository.workout_id (Printf.sprintf "w%d" s.next_id) in
158
Added:
let record = { Repository.id = wid; workout } in
159
Added:
s.next_id <- s.next_id + 1;
160
Added:
s.stored <- record :: s.stored;
161
Added:
s.current <- None;
162
Added:
Lwt.return record
163
Added:
164
Added:
let equal_id (a : Repository.workout_id) (b : Repository.workout_id) =
165
Added:
String.equal (a :> string) (b :> string)
166
Added:
167
Added:
let find t id wid =
168
Added:
let s = state t id in
169
Added:
Lwt.return (List.find_opt (fun r -> equal_id r.Repository.id wid) s.stored)
170
Added:
171
Added:
let replace t id record =
172
Added:
let s = state t id in
173
Added:
if
174
Added:
not
175
Added:
(List.exists
176
Added:
(fun r -> equal_id r.Repository.id record.Repository.id)
177
Added:
s.stored)
178
Added:
then Lwt.return false
179
Added:
else begin
180
Added:
s.stored <-
181
Added:
List.map
182
Added:
(fun existing ->
183
Added:
if equal_id existing.Repository.id record.Repository.id then record
184
Added:
else existing)
185
Added:
s.stored;
186
Added:
Lwt.return true
187
Added:
end
188
Added:
189
Added:
let log t id =
190
Added:
let s = state t id in
191
Added:
Lwt.return
192
Added:
(List.fold_left
193
Added:
(fun log record -> Evidence.Log.add log record.Repository.workout)
194
Added:
Evidence.Log.empty (List.rev s.stored))
195
Added:
196
Added:
let history t id = Lwt.return (state t id).stored
197
Added:
198
Added:
let save_feedback t id report =
199
Added:
let s = state t id in
200
Added:
s.feedback <- report :: s.feedback;
201
Added:
Lwt.return_unit
202
Added:
203
Added:
let feedback t id = Lwt.return (state t id).feedback
204
Added:
205
Added:
let save_app_feedback t id ~submitted_at ~message =
206
Added:
let author =
207
Added:
match
208
Added:
List.find_opt
209
Added:
(fun (trainee : Trainee.t) ->
210
Added:
String.equal
211
Added:
(Trainee.id_to_string trainee.id)
212
Added:
(Trainee.id_to_string id))
213
Added:
t.trainees
214
Added:
with
215
Added:
| Some trainee -> Trainee.username_to_string trainee.username
216
Added:
| None -> ""
217
Added:
in
218
Added:
let contributions =
219
Added:
1
220
Added:
+ List.fold_left
221
Added:
(fun count (owner, _) ->
222
Added:
if String.equal (Trainee.id_to_string owner) (Trainee.id_to_string id)
223
Added:
then count + 1
224
Added:
else count)
225
Added:
0 t.app_feedback
226
Added:
in
227
Added:
let s = state t id in
228
Added:
let feedback_id =
229
Added:
Repository.app_feedback_id
230
Added:
(Printf.sprintf "%s:%d" (Trainee.id_to_string id) s.next_app_feedback)
231
Added:
in
232
Added:
s.next_app_feedback <- s.next_app_feedback + 1;
233
Added:
let report =
234
Added:
Repository.
235
Added:
{
236
Added:
feedback_id;
237
Added:
author;
238
Added:
contributions;
239
Added:
submitted_at;
240
Added:
message;
241
Added:
upvotes = 0;
242
Added:
viewer_upvoted = false;
243
Added:
viewer_owns = true;
244
Added:
}
245
Added:
in
246
Added:
t.app_feedback <- (id, report) :: t.app_feedback;
247
Added:
Lwt.return report
248
Added:
249
Added:
let app_feedback_id_parts report =
250
Added:
let raw =
251
Added:
Repository.app_feedback_id_to_string report.Repository.feedback_id
252
Added:
in
253
Added:
match String.rindex_opt raw ':' with
254
Added:
| None -> (raw, 0)
255
Added:
| Some separator ->
256
Added:
let owner = String.sub raw 0 separator in
257
Added:
let sequence =
258
Added:
String.sub raw (separator + 1) (String.length raw - separator - 1)
259
Added:
|> int_of_string_opt |> Option.value ~default:0
260
Added:
in
261
Added:
(owner, sequence)
262
Added:
263
Added:
let app_feedback t ~viewer =
264
Added:
let reports =
265
Added:
List.map
266
Added:
(fun (owner, report) ->
267
Added:
let owner_id = Trainee.id_to_string owner in
268
Added:
let contributions =
269
Added:
List.fold_left
270
Added:
(fun count (candidate, _) ->
271
Added:
if String.equal owner_id (Trainee.id_to_string candidate) then
272
Added:
count + 1
273
Added:
else count)
274
Added:
0 t.app_feedback
275
Added:
in
276
Added:
let author =
277
Added:
match
278
Added:
List.find_opt
279
Added:
(fun (trainee : Trainee.t) ->
280
Added:
String.equal owner_id (Trainee.id_to_string trainee.id))
281
Added:
t.trainees
282
Added:
with
283
Added:
| Some trainee -> Trainee.username_to_string trainee.username
284
Added:
| None -> report.Repository.author
285
Added:
in
286
Added:
let viewer_upvoted =
287
Added:
List.exists
288
Added:
(fun (feedback_id, voter) ->
289
Added:
String.equal
290
Added:
(Repository.app_feedback_id_to_string feedback_id)
291
Added:
(Repository.app_feedback_id_to_string
292
Added:
report.Repository.feedback_id)
293
Added:
&& String.equal
294
Added:
(Trainee.id_to_string voter)
295
Added:
(Trainee.id_to_string viewer))
296
Added:
t.app_feedback_votes
297
Added:
in
298
Added:
let viewer_owns = String.equal owner_id (Trainee.id_to_string viewer) in
299
Added:
{ report with author; contributions; viewer_upvoted; viewer_owns })
300
Added:
t.app_feedback
301
Added:
in
302
Added:
let compare left right =
303
Added:
let by_votes =
304
Added:
Int.compare right.Repository.upvotes left.Repository.upvotes
305
Added:
in
306
Added:
if by_votes <> 0 then by_votes
307
Added:
else
308
Added:
let by_time =
309
Added:
Int.compare
310
Added:
(Recovery.timestamp_to_unix_seconds right.submitted_at)
311
Added:
(Recovery.timestamp_to_unix_seconds left.submitted_at)
312
Added:
in
313
Added:
if by_time <> 0 then by_time
314
Added:
else
315
Added:
let left_owner, left_sequence = app_feedback_id_parts left in
316
Added:
let right_owner, right_sequence = app_feedback_id_parts right in
317
Added:
let by_owner = String.compare left_owner right_owner in
318
Added:
if by_owner <> 0 then by_owner
319
Added:
else Int.compare right_sequence left_sequence
320
Added:
in
321
Added:
Lwt.return (List.sort compare reports)
322
Added:
323
Added:
let upvote_app_feedback t ~voter feedback_id =
324
Added:
match
325
Added:
List.find_opt
326
Added:
(fun (_, report) ->
327
Added:
String.equal
328
Added:
(Repository.app_feedback_id_to_string report.Repository.feedback_id)
329
Added:
(Repository.app_feedback_id_to_string feedback_id))
330
Added:
t.app_feedback
331
Added:
with
332
Added:
| None -> Lwt.return false
333
Added:
| Some (owner, _)
334
Added:
when String.equal (Trainee.id_to_string owner) (Trainee.id_to_string voter)
335
Added:
->
336
Added:
Lwt.return false
337
Added:
| Some (_, report) ->
338
Added:
if
339
Added:
List.exists
340
Added:
(fun (voted_feedback, existing_voter) ->
341
Added:
String.equal
342
Added:
(Repository.app_feedback_id_to_string voted_feedback)
343
Added:
(Repository.app_feedback_id_to_string feedback_id)
344
Added:
&& String.equal
345
Added:
(Trainee.id_to_string existing_voter)
346
Added:
(Trainee.id_to_string voter))
347
Added:
t.app_feedback_votes
348
Added:
then Lwt.return false
349
Added:
else begin
350
Added:
t.app_feedback_votes <- (feedback_id, voter) :: t.app_feedback_votes;
351
Added:
t.app_feedback <-
352
Added:
List.map
353
Added:
(fun (owner, current) ->
354
Added:
if
355
Added:
String.equal
356
Added:
(Repository.app_feedback_id_to_string
357
Added:
current.Repository.feedback_id)
358
Added:
(Repository.app_feedback_id_to_string
359
Added:
report.Repository.feedback_id)
360
Added:
then (owner, { current with upvotes = current.upvotes + 1 })
361
Added:
else (owner, current))
362
Added:
t.app_feedback;
363
Added:
Lwt.return true
364
Added:
end
365
Added:
366
Added:
let update_app_feedback t ~author id ~message =
367
Added:
let author_id = Trainee.id_to_string author in
368
Added:
let updated = ref false in
369
Added:
t.app_feedback <-
370
Added:
List.map
371
Added:
(fun (owner, report) ->
372
Added:
if
373
Added:
String.equal (Trainee.id_to_string owner) author_id
374
Added:
&& String.equal
375
Added:
(Repository.app_feedback_id_to_string
376
Added:
report.Repository.feedback_id)
377
Added:
(Repository.app_feedback_id_to_string id)
378
Added:
then begin
379
Added:
updated := true;
380
Added:
(owner, { report with message })
381
Added:
end
382
Added:
else (owner, report))
383
Added:
t.app_feedback;
384
Added:
Lwt.return !updated
385
Added:
386
Added:
let delete_app_feedback t ~author id =
387
Added:
let author_id = Trainee.id_to_string author in
388
Added:
let owned (owner, report) =
389
Added:
String.equal (Trainee.id_to_string owner) author_id
390
Added:
&& String.equal
391
Added:
(Repository.app_feedback_id_to_string report.Repository.feedback_id)
392
Added:
(Repository.app_feedback_id_to_string id)
393
Added:
in
394
Added:
let removed = List.exists owned t.app_feedback in
395
Added:
if removed then begin
396
Added:
t.app_feedback <- List.filter (fun item -> not (owned item)) t.app_feedback;
397
Added:
t.app_feedback_votes <-
398
Added:
List.filter
399
Added:
(fun (feedback_id, _) ->
400
Added:
not
401
Added:
(String.equal
402
Added:
(Repository.app_feedback_id_to_string feedback_id)
403
Added:
(Repository.app_feedback_id_to_string id)))
404
Added:
t.app_feedback_votes
405
Added:
end;
406
Added:
Lwt.return removed
407
Added:
408
Added:
(* --- workout import --- *)
409
Added:
410
Added:
let batch_id_eq a b =
411
Added:
String.equal
412
Added:
(Workout_import.batch_id_to_string a)
413
Added:
(Workout_import.batch_id_to_string b)
414
Added:
415
Added:
(* Upsert a batch by its identity, dropping any earlier version and prepending
416
Added:
the new one so the list stays newest-first by insertion. *)
417
Added:
let save_import_batch t id batch =
418
Added:
let s = state t id in
419
Added:
let identity = Workout_import.batch_identity batch in
420
Added:
s.batches <-
421
Added:
batch
422
Added:
:: List.filter
423
Added:
(fun b -> not (batch_id_eq (Workout_import.batch_identity b) identity))
424
Added:
s.batches;
425
Added:
Lwt.return_unit
426
Added:
427
Added:
let find_import_batch t id batch_id =
428
Added:
let s = state t id in
429
Added:
Lwt.return
430
Added:
(List.find_opt
431
Added:
(fun b -> batch_id_eq (Workout_import.batch_identity b) batch_id)
432
Added:
s.batches)
433
Added:
434
Added:
(* Most recent [imported_at] first; ties broken by batch id descending, for a
435
Added:
deterministic order that does not depend on insertion. *)
436
Added:
let import_batches t id =
437
Added:
let s = state t id in
438
Added:
let compare a b =
439
Added:
let by_time =
440
Added:
Int.compare
441
Added:
(Recovery.timestamp_to_unix_seconds
442
Added:
(Workout_import.batch_imported_at b))
443
Added:
(Recovery.timestamp_to_unix_seconds
444
Added:
(Workout_import.batch_imported_at a))
445
Added:
in
446
Added:
if by_time <> 0 then by_time
447
Added:
else
448
Added:
String.compare
449
Added:
(Workout_import.batch_id_to_string (Workout_import.batch_identity b))
450
Added:
(Workout_import.batch_id_to_string (Workout_import.batch_identity a))
451
Added:
in
452
Added:
Lwt.return (List.stable_sort compare s.batches)
453
Added:
454
Added:
(* Deleting a provisional batch never touches promoted records: their lifecycle
455
Added:
is independent. *)
456
Added:
let delete_import_batch t id batch_id =
457
Added:
let s = state t id in
458
Added:
let present =
459
Added:
List.exists
460
Added:
(fun b -> batch_id_eq (Workout_import.batch_identity b) batch_id)
461
Added:
s.batches
462
Added:
in
463
Added:
if present then
464
Added:
s.batches <-
465
Added:
List.filter
466
Added:
(fun b -> not (batch_id_eq (Workout_import.batch_identity b) batch_id))
467
Added:
s.batches;
468
Added:
Lwt.return present
469
Added:
470
Added:
let workout_id_eq a b =
471
Added:
String.equal
472
Added:
(Workout_import.workout_id_to_string a)
473
Added:
(Workout_import.workout_id_to_string b)
474
Added:
475
Added:
(* Atomic upsert keyed by workout id: a re-promotion replaces the observations
476
Added:
and revision of the prior record for the same workout. *)
477
Added:
let replace_imported_record t id record =
478
Added:
let s = state t id in
479
Added:
s.records <-
480
Added:
record
481
Added:
:: List.filter
482
Added:
(fun r ->
483
Added:
not
484
Added:
(workout_id_eq r.Repository.workout_id record.Repository.workout_id))
485
Added:
s.records;
486
Added:
Lwt.return_unit
487
Added:
488
Added:
let imported_records t id =
489
Added:
let s = state t id in
490
Added:
let compare a b =
491
Added:
Int.compare
492
Added:
(Recovery.timestamp_to_unix_seconds b.Repository.ended_at)
493
Added:
(Recovery.timestamp_to_unix_seconds a.Repository.ended_at)
494
Added:
in
495
Added:
Lwt.return (List.stable_sort compare s.records)
test/memory_repo.mli
@@ -0,0 +1,8 @@
1
Added:
(** In-memory {!Repository.S} for tests. Nothing survives a restart, and it is
2
Added:
never used in production — durable storage is {!Sqlite_repo}. *)
3
Added:
4
Added:
open Hito_app
5
Added:
include Repository.S
6
Added:
7
Added:
val create : unit -> t
8
Added:
(** Seeded with the shared routine catalog. *)
test/test_architecture.ml
@@ -1,270 +0,0 @@
1
Removed:
(** Architecture guard. Encodes the Clean Architecture Dependency Rule as an
2
Removed:
executable invariant over [lib/], so a future change that points a
3
Removed:
dependency outward fails the build rather than eroding the design silently.
4
Removed:
5
Removed:
The four concentric circles, innermost first:
6
Removed:
7
Removed:
- [lib/core] — entities. Enterprise business rules. No framework.
8
Removed:
- [lib/app] — use cases and ports (Repository, Password_hash). Depends on
9
Removed:
the entities only.
10
Removed:
- [lib/persistence] — interface adapters. Implements the ports over Caqti,
11
Removed:
the SQLite driver, and safepass.
12
Removed:
- [lib/web] — frameworks and drivers. Dream and dream-html.
13
Removed:
14
Removed:
The Dependency Rule: source dependencies point inward only. An inner circle
15
Removed:
names nothing from an outer circle — no module, no framework. *)
16
Removed:
17
Removed:
(* Resolve the project root by walking up from the test's run directory until a
18
Removed:
[dune-project] file appears. Dune runs the test from deep inside [_build], so
19
Removed:
the sources sit some ancestors up. *)
20
Removed:
let project_root () =
21
Removed:
let rec up dir depth =
22
Removed:
if depth = 0 then Alcotest.fail "could not locate dune-project"
23
Removed:
else if Sys.file_exists (Filename.concat dir "dune-project") then dir
24
Removed:
else up (Filename.dirname dir) (depth - 1)
25
Removed:
in
26
Removed:
up (Sys.getcwd ()) 12
27
Removed:
28
Removed:
let read_file path =
29
Removed:
let ic = open_in path in
30
Removed:
Fun.protect
31
Removed:
~finally:(fun () -> close_in ic)
32
Removed:
(fun () -> really_input_string ic (in_channel_length ic))
33
Removed:
34
Removed:
(* Every [.ml] and [.mli] under [dir]. *)
35
Removed:
let sources dir =
36
Removed:
Sys.readdir dir |> Array.to_list
37
Removed:
|> List.filter (fun f ->
38
Removed:
Filename.check_suffix f ".ml" || Filename.check_suffix f ".mli")
39
Removed:
|> List.map (Filename.concat dir)
40
Removed:
41
Removed:
let contains ~needle haystack =
42
Removed:
let n = String.length needle and h = String.length haystack in
43
Removed:
let rec at i =
44
Removed:
if i + n > h then false
45
Removed:
else if String.sub haystack i n = needle then true
46
Removed:
else at (i + 1)
47
Removed:
in
48
Removed:
at 0
49
Removed:
50
Removed:
(* Assert that no source under [layer_dir] mentions any of [forbidden] as a
51
Removed:
word. A word boundary keeps [Recovery] from matching inside [RecoveryFoo] and
52
Removed:
avoids matching substrings of unrelated identifiers. *)
53
Removed:
let assert_no_reference ~layer ~layer_dir ~forbidden =
54
Removed:
let is_word_char c =
55
Removed:
(c >= 'A' && c <= 'Z')
56
Removed:
|| (c >= 'a' && c <= 'z')
57
Removed:
|| (c >= '0' && c <= '9')
58
Removed:
|| c = '_'
59
Removed:
in
60
Removed:
let mentions_word name text =
61
Removed:
let n = String.length name and h = String.length text in
62
Removed:
let rec scan i =
63
Removed:
if i + n > h then false
64
Removed:
else if String.sub text i n = name then
65
Removed:
let before = i = 0 || not (is_word_char text.[i - 1]) in
66
Removed:
let after = i + n >= h || not (is_word_char text.[i + n]) in
67
Removed:
if before && after then true else scan (i + 1)
68
Removed:
else scan (i + 1)
69
Removed:
in
70
Removed:
scan 0
71
Removed:
in
72
Removed:
List.iter
73
Removed:
(fun path ->
74
Removed:
let text = read_file path in
75
Removed:
List.iter
76
Removed:
(fun name ->
77
Removed:
if mentions_word name text then
78
Removed:
Alcotest.failf "%s layer (%s) names outer-circle %S" layer
79
Removed:
(Filename.basename path) name)
80
Removed:
forbidden)
81
Removed:
(sources layer_dir)
82
Removed:
83
Removed:
(* The union of every [(libraries ...)] form in a dune file, as a flat token
84
Removed:
list. A dune file may hold several stanzas (an executable and a library, say),
85
Removed:
so we gather them all: for the Dependency Rule it is enough to know the full
86
Removed:
set a file's build can see. *)
87
Removed:
let declared_libraries dune_path =
88
Removed:
let text = read_file dune_path in
89
Removed:
let key = "(libraries" in
90
Removed:
let klen = String.length key in
91
Removed:
let acc = Buffer.create 128 in
92
Removed:
let rec find_all i =
93
Removed:
if i + klen > String.length text then ()
94
Removed:
else if String.sub text i klen = key then begin
95
Removed:
let buf = Buffer.create 64 in
96
Removed:
let rec take j depth =
97
Removed:
if j >= String.length text then j
98
Removed:
else
99
Removed:
match text.[j] with
100
Removed:
| ')' when depth = 0 -> j + 1
101
Removed:
| '(' ->
102
Removed:
Buffer.add_char buf ' ';
103
Removed:
take (j + 1) (depth + 1)
104
Removed:
| ')' ->
105
Removed:
Buffer.add_char buf ' ';
106
Removed:
take (j + 1) (depth - 1)
107
Removed:
| c ->
108
Removed:
Buffer.add_char buf c;
109
Removed:
take (j + 1) depth
110
Removed:
in
111
Removed:
let next = take (i + klen) 0 in
112
Removed:
Buffer.add_char acc ' ';
113
Removed:
Buffer.add_string acc (Buffer.contents buf);
114
Removed:
find_all next
115
Removed:
end
116
Removed:
else find_all (i + 1)
117
Removed:
in
118
Removed:
find_all 0;
119
Removed:
Buffer.contents acc |> String.split_on_char ' '
120
Removed:
|> List.filter_map (fun s ->
121
Removed:
let s = String.trim s in
122
Removed:
if s = "" then None else Some s)
123
Removed:
124
Removed:
let root = project_root ()
125
Removed:
let lib name = Filename.concat (Filename.concat root "lib") name
126
Removed:
127
Removed:
let dependency_rule =
128
Removed:
[
129
Removed:
( "core is pure entities: no outer module, no framework",
130
Removed:
`Quick,
131
Removed:
fun () ->
132
Removed:
assert_no_reference ~layer:"core" ~layer_dir:(lib "core")
133
Removed:
~forbidden:
134
Removed:
[
135
Removed:
"Repository";
136
Removed:
"Service";
137
Removed:
"Trainee";
138
Removed:
"Catalog";
139
Removed:
"Password_hash";
140
Removed:
"Sqlite_repo";
141
Removed:
"Memory_repo";
142
Removed:
"Codec";
143
Removed:
"Migrations";
144
Removed:
"Bcrypt";
145
Removed:
"Bcrypt_hash";
146
Removed:
"Caqti";
147
Removed:
"Dream";
148
Removed:
"Dream_html";
149
Removed:
"Handlers";
150
Removed:
"Pages";
151
Removed:
"Routes";
152
Removed:
"Lwt";
153
Removed:
"Uri";
154
Removed:
"Unix";
155
Removed:
] );
156
Removed:
( "app use cases name no adapter and no framework",
157
Removed:
`Quick,
158
Removed:
fun () ->
159
Removed:
assert_no_reference ~layer:"app" ~layer_dir:(lib "app")
160
Removed:
~forbidden:
161
Removed:
[
162
Removed:
"Sqlite_repo";
163
Removed:
"Memory_repo";
164
Removed:
"Codec";
165
Removed:
"Migrations";
166
Removed:
"Bcrypt_hash";
167
Removed:
"Caqti";
168
Removed:
"Dream";
169
Removed:
"Dream_html";
170
Removed:
"Handlers";
171
Removed:
"Pages";
172
Removed:
"Routes";
173
Removed:
] );
174
Removed:
( "core declares no library dependency",
175
Removed:
`Quick,
176
Removed:
fun () ->
177
Removed:
Alcotest.(check (list string))
178
Removed:
"core libraries" []
179
Removed:
(declared_libraries (Filename.concat (lib "core") "dune")) );
180
Removed:
( "app depends inward on core and lwt only",
181
Removed:
`Quick,
182
Removed:
fun () ->
183
Removed:
Alcotest.(check (list string))
184
Removed:
"app libraries" [ "hito.core"; "lwt" ]
185
Removed:
(declared_libraries (Filename.concat (lib "app") "dune")) );
186
Removed:
( "persistence depends inward, never on web",
187
Removed:
`Quick,
188
Removed:
fun () ->
189
Removed:
let libs =
190
Removed:
declared_libraries (Filename.concat (lib "persistence") "dune")
191
Removed:
in
192
Removed:
Alcotest.(check bool)
193
Removed:
"declares hito.core" true
194
Removed:
(List.mem "hito.core" libs);
195
Removed:
Alcotest.(check bool)
196
Removed:
"declares hito.app" true (List.mem "hito.app" libs);
197
Removed:
Alcotest.(check bool)
198
Removed:
"does not depend on hito.web" false (List.mem "hito.web" libs) );
199
Removed:
( "web depends inward, never on the concrete persistence adapter",
200
Removed:
`Quick,
201
Removed:
fun () ->
202
Removed:
let libs = declared_libraries (Filename.concat (lib "web") "dune") in
203
Removed:
Alcotest.(check bool)
204
Removed:
"declares hito.core" true
205
Removed:
(List.mem "hito.core" libs);
206
Removed:
Alcotest.(check bool)
207
Removed:
"declares hito.app" true (List.mem "hito.app" libs);
208
Removed:
Alcotest.(check bool)
209
Removed:
"does not depend on hito.persistence" false
210
Removed:
(List.mem "hito.persistence" libs) );
211
Removed:
]
212
Removed:
213
Removed:
(* The presenter (Pages) is an interface adapter: only view models cross into
214
Removed:
it. It must name no core entity and no repository type — those reach it as
215
Removed:
plain DTOs from the controller (Handlers). This guard scans the two presenter
216
Removed:
files directly, since Handlers in the same layer legitimately names
217
Removed:
entities to build the DTOs. *)
218
Removed:
let presenter_boundary =
219
Removed:
let forbidden =
220
Removed:
[
221
Removed:
"Evidence";
222
Removed:
"Prescription";
223
Removed:
"Exercise";
224
Removed:
"Recovery";
225
Removed:
"Progression";
226
Removed:
"Repository";
227
Removed:
"Trainee";
228
Removed:
"Catalog";
229
Removed:
"Service";
230
Removed:
]
231
Removed:
in
232
Removed:
let is_word_char c =
233
Removed:
(c >= 'A' && c <= 'Z')
234
Removed:
|| (c >= 'a' && c <= 'z')
235
Removed:
|| (c >= '0' && c <= '9')
236
Removed:
|| c = '_'
237
Removed:
in
238
Removed:
let mentions name text =
239
Removed:
(* Match a module reference: the name followed by '.', with no identifier
240
Removed:
char before it. This flags [Evidence.Workout] but not the label string
241
Removed:
"Exercise". *)
242
Removed:
let n = String.length name and h = String.length text in
243
Removed:
let rec scan i =
244
Removed:
if i + n >= h then false
245
Removed:
else if String.sub text i n = name && text.[i + n] = '.' then
246
Removed:
let before = i = 0 || not (is_word_char text.[i - 1]) in
247
Removed:
if before then true else scan (i + 1)
248
Removed:
else scan (i + 1)
249
Removed:
in
250
Removed:
scan 0
251
Removed:
in
252
Removed:
let check file =
253
Removed:
( Printf.sprintf "the presenter (%s) names no inner-circle entity"
254
Removed:
(Filename.basename file),
255
Removed:
`Quick,
256
Removed:
fun () ->
257
Removed:
let text = read_file (Filename.concat (lib "web") file) in
258
Removed:
List.iter
259
Removed:
(fun name ->
260
Removed:
if mentions name text then
261
Removed:
Alcotest.failf "%s names inner-circle %S" file name)
262
Removed:
forbidden )
263
Removed:
in
264
Removed:
[ check "pages.ml"; check "pages.mli" ]
265
Removed:
266
Removed:
let suite =
267
Removed:
[
268
Removed:
("architecture.dependency_rule", dependency_rule);
269
Removed:
("architecture.presenter_boundary", presenter_boundary);
270
Removed:
]
test/test_hito.ml
@@ -7,9 +7,9 @@
7
7
8
8
let () =
9
9
Alcotest.run "hito"
10
Removed:
(Test_architecture.suite @ Test_exercise.suite @ Test_recovery.suite
11
Removed:
@ Test_prescription.suite @ Test_evidence.suite @ Test_progression.suite
12
Removed:
@ Test_service.suite @ Test_workout_import.suite @ Test_import_service.suite
13
Removed:
@ Test_codec.suite @ Test_import_codec.suite @ Test_import_repo.suite
14
Removed:
@ Test_import_sqlite.suite @ Test_bcrypt_hash.suite @ Test_sqlite_repo.suite
15
Removed:
@ Test_decode.suite @ Test_hevy_csv.suite @ Test_web.suite)
10
Added:
(Test_exercise.suite @ Test_recovery.suite @ Test_prescription.suite
11
Added:
@ Test_evidence.suite @ Test_progression.suite @ Test_service.suite
12
Added:
@ Test_workout_import.suite @ Test_import_service.suite @ Test_codec.suite
13
Added:
@ Test_import_codec.suite @ Test_import_repo.suite @ Test_import_sqlite.suite
14
Added:
@ Test_bcrypt_hash.suite @ Test_sqlite_repo.suite @ Test_decode.suite
15
Added:
@ Test_hevy_csv.suite @ Test_web.suite)
test/test_import_repo.ml
@@ -4,7 +4,6 @@
4
4
workout id. *)
5
5
6
6
open Hito_app
7
Removed:
open Hito_persistence
8
7
module WI = Workout_import
9
8
10
9
let run = Lwt_main.run