[OCaml] High Intensity Training Online
fix tighten feedback and workout form handling
Accept zero-load bodyweight efforts, remove duplicate feedback decoding, and derive factor order from one definition. Preserve feedback ownership across renames, enhance feedback mutations, prevent raw decoder errors, and cover the flows end to end.
Changed files
lib/web/decode.ml
@@ -23,10 +23,10 @@
23
23
| _ -> Error "error.extension"
24
24
25
25
let load value =
26
Removed:
match Form.float value with
27
Removed:
| Error error -> Error error
28
Removed:
| Ok value when Float.is_finite value && value >= 0. -> Ok value
29
Removed:
| Ok _ -> Error "error.load"
26
Added:
match Form.float ~min:0. value with
27
Added:
| Ok value -> Ok value
28
Added:
| Error "error.expected.int" -> Error "error.expected.number"
29
Added:
| Error _ -> Error "error.load"
30
30
31
31
let reps value =
32
32
match Form.int value with
@@ -100,56 +100,7 @@
100
100
101
101
let app_feedback = Form.required Form.string "message"
102
102
103
Removed:
(* --- subjective feedback --- *)
104
Removed:
105
Removed:
let level = function
106
Removed:
| "below" -> Ok Evidence.Feedback.Below_usual
107
Removed:
| "usual" -> Ok Evidence.Feedback.Usual
108
Removed:
| "above" -> Ok Evidence.Feedback.Above_usual
109
Removed:
| _ -> Error "error.level"
110
Removed:
111
Removed:
(* A leveled signal field: the select omits the signal when left blank, and
112
Removed:
otherwise carries below/usual/above. [make] wraps the level in its category. *)
113
Removed:
let leveled field make =
114
Removed:
let open Form in
115
Removed:
let+ raw = optional string field in
116
Removed:
match raw with
117
Removed:
| None | Some "" -> None
118
Removed:
| Some value -> (
119
Removed:
match level value with Ok l -> Some (make l) | Error _ -> None)
120
Removed:
121
Removed:
(* A boolean flag field: a checked box reports the signal, an unchecked one is
122
Removed:
absent. *)
123
Removed:
let flag field signal =
124
Removed:
let open Form in
125
Removed:
let+ checked = optional bool field in
126
Removed:
match checked with Some true -> Some signal | _ -> None
127
Removed:
128
Removed:
let feedback =
129
Removed:
let open Form in
130
Removed:
let+ sleep = leveled "sleep" (fun l -> Evidence.Feedback.Sleep l)
131
Removed:
and+ appetite = leveled "appetite" (fun l -> Evidence.Feedback.Appetite l)
132
Removed:
and+ readiness = leveled "readiness" (fun l -> Evidence.Feedback.Readiness l)
133
Removed:
and+ motivation =
134
Removed:
leveled "motivation" (fun l -> Evidence.Feedback.Motivation l)
135
Removed:
and+ difficulty =
136
Removed:
leveled "difficulty" (fun l -> Evidence.Feedback.Difficulty l)
137
Removed:
and+ pain = flag "pain" Evidence.Feedback.Pain
138
Removed:
and+ injury = flag "injury" Evidence.Feedback.Injury
139
Removed:
and+ preparation =
140
Removed:
flag "preparation" Evidence.Feedback.Preparation_insufficient
141
Removed:
in
142
Removed:
List.filter_map Fun.id
143
Removed:
[
144
Removed:
sleep;
145
Removed:
appetite;
146
Removed:
readiness;
147
Removed:
motivation;
148
Removed:
difficulty;
149
Removed:
pain;
150
Removed:
injury;
151
Removed:
preparation;
152
Removed:
]
103
Added:
(* --- error presentation --- *)
153
104
154
105
let message = function
155
106
| "error.required" -> "Enter a value."
lib/web/decode.mli
@@ -3,10 +3,6 @@
3
3
val override : bool Dream_html.Form.t
4
4
val stimulus : Prescription.Stimulus.t -> Evidence.Stimulus.t Dream_html.Form.t
5
5
6
Removed:
val feedback : Evidence.Feedback.signal list Dream_html.Form.t
7
Removed:
(** Decodes the subjective feedback form: leveled selects and boolean flags,
8
Removed:
dropping any signal left unreported. *)
9
Removed:
10
6
val profile_username : string Dream_html.Form.t
11
7
(** The raw username from the rename form; the domain validates it. *)
12
8
lib/web/handlers.ml
@@ -441,9 +441,7 @@
441
441
442
442
module Logbook = struct
443
443
let feedback_session_key = "hito.feedback.flow"
444
Removed:
445
Removed:
let feedback_factors =
446
Removed:
[ "sleep"; "appetite"; "readiness"; "motivation"; "difficulty" ]
444
Added:
let feedback_factors = List.map fst Pages.feedback_factors
447
445
448
446
let valid_choice = function
449
447
| ("below" | "usual" | "above") as choice -> Some choice
lib/web/pages.ml
@@ -1468,11 +1468,9 @@
1468
1468
:: error_block
1469
1469
@ [ void "input" [ type_ "submit"; value "Submit feedback" ] ])
1470
1470
1471
Removed:
let app_feedback_vote_form request ~trainee report =
1472
Removed:
if
1473
Removed:
String.equal report.Repository.author
1474
Removed:
(Trainee.username_to_string trainee.Trainee.username)
1475
Removed:
then tag "p" [ class_ "app-feedback-own" ] [ txt "Your feedback" ]
1471
Added:
let app_feedback_vote_form request report =
1472
Added:
if report.Repository.viewer_owns then
1473
Added:
tag "p" [ class_ "app-feedback-own" ] [ txt "Your feedback" ]
1476
1474
else
1477
1475
let label =
1478
1476
if report.Repository.viewer_upvoted then "Upvoted"
@@ -1484,6 +1482,7 @@
1484
1482
(Repository.app_feedback_id_to_string report.Repository.feedback_id);
1485
1483
post_form;
1486
1484
class_ "app-feedback-vote";
1485
Added:
Dream_html.attr "data-hito-app-form";
1487
1486
]
1488
1487
in
1489
1488
let attrs =
@@ -1505,6 +1504,7 @@
1505
1504
(Repository.app_feedback_id_to_string report.Repository.feedback_id);
1506
1505
post_form;
1507
1506
class_ "app-feedback-edit-form";
1507
Added:
Dream_html.attr "data-hito-app-form";
1508
1508
]
1509
1509
[
1510
1510
Dream_html.csrf_tag request;
@@ -1533,18 +1533,15 @@
1533
1533
(Repository.app_feedback_id_to_string report.Repository.feedback_id);
1534
1534
post_form;
1535
1535
class_ "app-feedback-remove-form";
1536
Added:
Dream_html.attr "data-hito-app-form";
1536
1537
]
1537
1538
[
1538
1539
Dream_html.csrf_tag request;
1539
1540
void "input" [ type_ "submit"; value "Remove feedback" ];
1540
1541
]
1541
1542
1542
Removed:
let app_feedback_actions request ~trainee report =
1543
Removed:
let own =
1544
Removed:
String.equal report.Repository.author
1545
Removed:
(Trainee.username_to_string trainee.Trainee.username)
1546
Removed:
in
1547
Removed:
if own then
1543
Added:
let app_feedback_actions request report =
1544
Added:
if report.Repository.viewer_owns then
1548
1545
tag "div"
1549
1546
[ class_ "app-feedback-actions" ]
1550
1547
[
@@ -1554,7 +1551,7 @@
1554
1551
else
1555
1552
tag "div"
1556
1553
[ class_ "app-feedback-actions" ]
1557
Removed:
[ app_feedback_vote_form request ~trainee report ]
1554
Added:
[ app_feedback_vote_form request report ]
1558
1555
1559
1556
let app_feedback request ?(logging = false) ~trainee ?(tab = `Write) ?error
1560
1557
reports =
@@ -1599,7 +1596,7 @@
1599
1596
tag "p"
1600
1597
[ class_ "app-feedback-upvotes" ]
1601
1598
[ txt "Upvotes: %d" report.upvotes ];
1602
Removed:
app_feedback_actions request ~trainee report;
1599
Added:
app_feedback_actions request report;
1603
1600
])
1604
1601
reports));
1605
1602
]
lib/web/pages.mli
@@ -61,6 +61,9 @@
61
61
62
62
type feedback_flow = { step : int; answers : (string * string) list }
63
63
64
Added:
val feedback_factors : (string * string) list
65
Added:
(** Ordered factor codes and labels used by the sequential feedback flow. *)
66
Added:
64
67
val logbook :
65
68
Dream.request ->
66
69
?logging:bool ->
test/test_decode.ml
@@ -38,6 +38,21 @@
38
38
| Error errors ->
39
39
Alcotest.failf "unexpected errors: %a" Form.pp_error errors
40
40
| Ok _ -> Alcotest.fail "expected extension validation failure" );
41
Added:
( "accepts a zero load for bodyweight effort",
42
Added:
`Quick,
43
Added:
fun () ->
44
Added:
match
45
Added:
Form.validate (Decode.stimulus single)
46
Added:
[ ("load", "0"); ("reps", "8"); ("extension", "") ]
47
Added:
with
48
Added:
| Ok stimulus ->
49
Added:
let effort = List.hd (Evidence.Stimulus.efforts stimulus) in
50
Added:
Alcotest.(check (float 0.001))
51
Added:
"zero load" 0.
52
Added:
(Evidence.Stimulus.Effort.load effort)
53
Added:
| Error errors ->
54
Added:
Alcotest.failf "unexpected validation errors: %a" Form.pp_error
55
Added:
errors );
41
56
( "rejects a negative load",
42
57
`Quick,
43
58
fun () ->
@@ -45,7 +60,7 @@
45
60
Form.validate (Decode.stimulus single)
46
61
[ ("load", "-1"); ("reps", "8"); ("extension", "") ]
47
62
with
48
Removed:
| Error [ ("load", "error.range") ] -> ()
63
Added:
| Error [ ("load", "error.load") ] -> ()
49
64
| Error errors ->
50
65
Alcotest.failf "unexpected errors: %a" Form.pp_error errors
51
66
| Ok _ -> Alcotest.fail "expected load validation failure" );
test/test_web.ml
@@ -162,7 +162,7 @@
162
162
by [?slot=]. Slot 0 is the flyes/incline-press pair; slot 3 is the
163
163
french-press/dips pair; slots 1 and 2 are single lateral movements. *)
164
164
let record_all_day_one_slots c =
165
Removed:
let record_pair slot =
165
Added:
let record_pair slot comp_load =
166
166
let token =
167
167
Option.get (csrf_token (body (get c ("/workout?slot=" ^ slot))))
168
168
in
@@ -171,7 +171,7 @@
171
171
("dream.csrf", token);
172
172
("iso_load", "20");
173
173
("iso_reps", "9");
174
Removed:
("comp_load", "60");
174
Added:
("comp_load", comp_load);
175
175
("comp_reps", "7");
176
176
("extension", "");
177
177
]
@@ -185,10 +185,10 @@
185
185
("dream.csrf", token); ("load", load); ("reps", reps); ("extension", "");
186
186
]
187
187
in
188
Removed:
let _ = record_pair "0" in
188
Added:
let _ = record_pair "0" "60" in
189
189
let _ = record_single "1" "12" "8" in
190
190
let _ = record_single "2" "10" "9" in
191
Removed:
let _ = record_pair "3" in
191
Added:
let _ = record_pair "3" "0" in
192
192
()
193
193
194
194
let route_tests =
@@ -797,9 +797,11 @@
797
797
Alcotest.(check int) "invalid field redirects" 303 (status invalid);
798
798
let invalid_page = body (get c "/workout") in
799
799
Alcotest.(check bool)
800
Removed:
"preserves the invalid-input error as a toast" true
800
Added:
"preserves a useful invalid-input error as a toast" true
801
801
(contains ~substring:"data-hito-toast" invalid_page
802
Removed:
&& contains ~substring:"role=\"status\"" invalid_page) );
802
Added:
&& contains ~substring:"role=\"status\"" invalid_page
803
Added:
&& contains ~substring:"Enter a valid number." invalid_page
804
Added:
&& not (contains ~substring:"error." invalid_page)) );
803
805
( "the workout view shows one slot at a time and defaults to the first \
804
806
incomplete slot",
805
807
`Quick,
@@ -1435,7 +1437,24 @@
1435
1437
(contains ~substring:"action=\"/app-feedback/t2:1/edit\"" bob_page
1436
1438
&& contains ~substring:"action=\"/app-feedback/t2:1/remove\""
1437
1439
bob_page);
1440
Added:
Alcotest.(check bool)
1441
Added:
"enhances owner actions through the app form path" true
1442
Added:
(contains ~substring:"app-feedback-edit-form" bob_page
1443
Added:
&& contains ~substring:"app-feedback-remove-form" bob_page
1444
Added:
&& contains ~substring:"data-hito-app-form" bob_page);
1438
1445
let edit_token = Option.get (csrf_token bob_page) in
1446
Added:
let blank =
1447
Added:
post bob "/app-feedback/t2:1/edit"
1448
Added:
[ ("dream.csrf", edit_token); ("message", " ") ]
1449
Added:
in
1450
Added:
Alcotest.(check int) "blank edit redirects" 303 (status blank);
1451
Added:
let blank_page = body (get bob "/app-feedback?tab=submitted") in
1452
Added:
Alcotest.(check bool)
1453
Added:
"blank edit is refused" true
1454
Added:
(contains ~substring:"Enter feedback before submitting."
1455
Added:
blank_page
1456
Added:
&& contains ~substring:"Bob report" blank_page);
1457
Added:
let edit_token = Option.get (csrf_token blank_page) in
1439
1458
let edited =
1440
1459
post bob "/app-feedback/t2:1/edit"
1441
1460
[ ("dream.csrf", edit_token); ("message", "Edited report") ]
@@ -1455,6 +1474,41 @@
1455
1474
Alcotest.(check bool)
1456
1475
"removes the owner's feedback" false
1457
1476
(contains ~substring:"Edited report" after_remove) );
1477
Added:
( "another trainee cannot edit or remove app feedback",
1478
Added:
`Quick,
1479
Added:
fun () ->
1480
Added:
let alice = client () in
1481
Added:
let _ = register alice ~username:"alice" ~password:"heavyduty1" in
1482
Added:
let bob = { alice with jar = [] } in
1483
Added:
let _ = register bob ~username:"bobby" ~password:"heavyduty1" in
1484
Added:
let bob_page = body (get bob "/app-feedback") in
1485
Added:
let token = Option.get (csrf_token bob_page) in
1486
Added:
let _ =
1487
Added:
post bob "/app-feedback/submit"
1488
Added:
[ ("dream.csrf", token); ("message", "Bob owns this") ]
1489
Added:
in
1490
Added:
let alice_page = body (get alice "/app-feedback?tab=submitted") in
1491
Added:
let token = Option.get (csrf_token alice_page) in
1492
Added:
let edited =
1493
Added:
post alice "/app-feedback/t2:1/edit"
1494
Added:
[ ("dream.csrf", token); ("message", "Taken over") ]
1495
Added:
in
1496
Added:
Alcotest.(check int) "cross-user edit redirects" 303 (status edited);
1497
Added:
let after_edit = body (get alice "/app-feedback?tab=submitted") in
1498
Added:
Alcotest.(check bool)
1499
Added:
"cross-user edit changes nothing" true
1500
Added:
(contains ~substring:"Bob owns this" after_edit
1501
Added:
&& not (contains ~substring:"Taken over" after_edit));
1502
Added:
let token = Option.get (csrf_token after_edit) in
1503
Added:
let removed =
1504
Added:
post alice "/app-feedback/t2:1/remove" [ ("dream.csrf", token) ]
1505
Added:
in
1506
Added:
Alcotest.(check int)
1507
Added:
"cross-user remove redirects" 303 (status removed);
1508
Added:
let after_remove = body (get alice "/app-feedback?tab=submitted") in
1509
Added:
Alcotest.(check bool)
1510
Added:
"cross-user remove changes nothing" true
1511
Added:
(contains ~substring:"Bob owns this" after_remove) );
1458
1512
] );
1459
1513
( "web.profile",
1460
1514
[