[OCaml] High Intensity Training Online

feat allow spontaneous logbook feedback

Persist subjective feedback and let a trainee report it at any time from the Logbook. Feedback is standalone — not tied to a workout — matching the domain's typed Feedback signals reported at a point in time. Adds a repository port for saving and listing feedback, memory and SQLite adapters, a version-2 migration for a feedback table, a codec for the signals, and a service API that rejects a repeated signal category. The Logbook renders a feedback form and past reports, and finishing a workout redirects there with a prompt suggesting feedback while it is fresh, keeping the flow available independently.

Commit
0fcd7df24cf9af477d6d0c806db49b1d34ece26b
Author
Marius Peter <dev@marius-peter.com>
Author date
Committer
Marius Peter <dev@marius-peter.com>
Committer date
Changed files
ENHANCEMENTS.org
index 82ec91d6..2605fc70 100644..100644
@@ -58,7 +58,7 @@
58 58 Show a modal menu that confirms workout logging cancellation before cancelling.
59 59 ** DONE Make workout logging fields compact on mobile
60 60 Use a grid layout so the exercise name, load input, and reps input appear on one row on mobile.
61 Removed: ** TODO Allow spontaneous logbook feedback
61 Added: ** DONE Allow spontaneous logbook feedback
62 62 Allow users to submit subjective feedback at any time from the Logbook. Suggest this feedback flow at the end of each workout, while keeping it available independently.
63 63 ** DONE Style the cancellation modal to match the UI
64 64 Style the modal cancellation menu so it matches the overall UI aesthetic.
@@ -68,3 +68,7 @@
68 68 Style form dropdown menus so they match the overall UI aesthetic.
69 69 ** TODO Standardize Logbook navigation and add a mobile profile button
70 70 Always label the logbook tab `Logbook`. Add a dedicated profile button for the user name in the mobile top navigation bar.
71 Added: ** TODO Use shared load and reps column headings
72 Added: In exercise logging fieldsets, show Load and Reps as column headings instead of repeating them above every input in a multi-exercise group.
73 Added: ** TODO Hide exercise-selector submit buttons in SPA mode
74 Added: When JavaScript progressive enhancement is active, do not show the submit button for exercise selection.
lib/app/codec.ml
index 8318e7eb..2d0deab7 100644..100644
@@ -315,3 +315,74 @@
315 315 let* parsed = parse text in
316 316 let* prescription = resolve_prescription ~find_routine parsed in
317 317 replay ~prescription parsed
318 Added:
319 Added: (* --- subjective feedback --- *)
320 Added:
321 Added: let level_code : Evidence.Feedback.level -> string = function
322 Added: | Below_usual -> "below"
323 Added: | Usual -> "usual"
324 Added: | Above_usual -> "above"
325 Added:
326 Added: let level_of_code = function
327 Added: | "below" -> Ok Evidence.Feedback.Below_usual
328 Added: | "usual" -> Ok Evidence.Feedback.Usual
329 Added: | "above" -> Ok Evidence.Feedback.Above_usual
330 Added: | other -> Error (Malformed (Printf.sprintf "level %S" other))
331 Added:
332 Added: let signal_code : Evidence.Feedback.signal -> string = function
333 Added: | Sleep l -> "sleep:" ^ level_code l
334 Added: | Appetite l -> "appetite:" ^ level_code l
335 Added: | Readiness l -> "readiness:" ^ level_code l
336 Added: | Motivation l -> "motivation:" ^ level_code l
337 Added: | Difficulty l -> "difficulty:" ^ level_code l
338 Added: | Pain -> "pain"
339 Added: | Injury -> "injury"
340 Added: | Preparation_insufficient -> "preparation-insufficient"
341 Added:
342 Added: let signal_of_code code =
343 Added: let leveled make rest =
344 Added: let* l = level_of_code rest in
345 Added: Ok (make l)
346 Added: in
347 Added: match String.split_on_char ':' code with
348 Added: | [ "sleep"; l ] -> leveled (fun l -> Evidence.Feedback.Sleep l) l
349 Added: | [ "appetite"; l ] -> leveled (fun l -> Evidence.Feedback.Appetite l) l
350 Added: | [ "readiness"; l ] -> leveled (fun l -> Evidence.Feedback.Readiness l) l
351 Added: | [ "motivation"; l ] -> leveled (fun l -> Evidence.Feedback.Motivation l) l
352 Added: | [ "difficulty"; l ] -> leveled (fun l -> Evidence.Feedback.Difficulty l) l
353 Added: | [ "pain" ] -> Ok Evidence.Feedback.Pain
354 Added: | [ "injury" ] -> Ok Evidence.Feedback.Injury
355 Added: | [ "preparation-insufficient" ] ->
356 Added: Ok Evidence.Feedback.Preparation_insufficient
357 Added: | _ -> Error (Malformed (Printf.sprintf "signal %S" code))
358 Added:
359 Added: let encode_feedback report =
360 Added: let reported_at =
361 Added: Recovery.timestamp_to_unix_seconds (Evidence.Feedback.reported_at report)
362 Added: in
363 Added: let signals =
364 Added: String.concat "," (List.map signal_code (Evidence.Feedback.signals report))
365 Added: in
366 Added: Printf.sprintf "%d\t%s" reported_at signals
367 Added:
368 Added: let decode_feedback text =
369 Added: match String.split_on_char '\t' text with
370 Added: | [ secs; signals ] -> (
371 Added: match int_of_string_opt secs with
372 Added: | None -> Error (Malformed "feedback timestamp")
373 Added: | Some secs ->
374 Added: let codes =
375 Added: String.split_on_char ',' signals
376 Added: |> List.filter (fun s -> String.length s > 0)
377 Added: in
378 Added: let rec go acc = function
379 Added: | [] -> Ok (List.rev acc)
380 Added: | code :: tl -> (
381 Added: match signal_of_code code with
382 Added: | Ok s -> go (s :: acc) tl
383 Added: | Error _ as e -> e)
384 Added: in
385 Added: let* signals = go [] codes in
386 Added: let reported_at = Recovery.timestamp_of_unix_seconds secs in
387 Added: Ok (Evidence.Feedback.make ~reported_at signals))
388 Added: | _ -> Error (Malformed "feedback arity")
lib/app/codec.mli
index be7aaaf2..be568bab 100644..100644
@@ -30,3 +30,9 @@
30 30 string ->
31 31 (Evidence.Workout.t, error) result
32 32 (** Rebuilds a workout, resolving its prescription through [find_routine]. *)
33 Added:
34 Added: val encode_feedback : Evidence.Feedback.t -> string
35 Added: (** A stable, single-string encoding of a subjective feedback report. *)
36 Added:
37 Added: val decode_feedback : string -> (Evidence.Feedback.t, error) result
38 Added: (** Rebuilds a feedback report from its encoding. *)
lib/app/memory_repo.ml
index f68267d9..fcf40d4e 100644..100644
@@ -3,6 +3,7 @@
3 3 mutable active : Repository.routine_id option;
4 4 mutable current : Evidence.Workout.t option;
5 5 mutable stored : Repository.record list; (* most recent first *)
6 Added: mutable feedback : Evidence.Feedback.t list; (* most recent first *)
6 7 mutable next_id : int;
7 8 }
8 9
@@ -19,7 +20,15 @@
19 20 match Hashtbl.find_opt t.states key with
20 21 | Some s -> s
21 22 | None ->
22 Removed: let s = { active = None; current = None; stored = []; next_id = 1 } in
23 Added: let s =
24 Added: {
25 Added: active = None;
26 Added: current = None;
27 Added: stored = [];
28 Added: feedback = [];
29 Added: next_id = 1;
30 Added: }
31 Added: in
23 32 Hashtbl.replace t.states key s;
24 33 s
25 34
@@ -122,3 +131,10 @@
122 131 Evidence.Log.empty (List.rev s.stored))
123 132
124 133 let history t id = Lwt.return (state t id).stored
134 Added:
135 Added: let save_feedback t id report =
136 Added: let s = state t id in
137 Added: s.feedback <- report :: s.feedback;
138 Added: Lwt.return_unit
139 Added:
140 Added: let feedback t id = Lwt.return (state t id).feedback
lib/app/migrations.ml
index b977ad7c..8fb7401c 100644..100644
@@ -37,6 +37,21 @@
37 37 )|};
38 38 ];
39 39 };
40 Added: {
41 Added: version = 2;
42 Added: name = "subjective feedback";
43 Added: statements =
44 Added: [
45 Added: {|CREATE TABLE IF NOT EXISTS feedback (
46 Added: trainee_id TEXT NOT NULL,
47 Added: seq INTEGER NOT NULL,
48 Added: encoded TEXT NOT NULL,
49 Added: PRIMARY KEY (trainee_id, seq)
50 Added: )|};
51 Added: {|CREATE INDEX IF NOT EXISTS feedback_by_trainee
52 Added: ON feedback (trainee_id, seq DESC)|};
53 Added: ];
54 Added: };
40 55 ]
41 56
42 57 (* The ledger of applied migrations. A row per version, so a reconnect knows
lib/app/repository.ml
index f9b5dbb5..47616078 100644..100644
@@ -34,4 +34,6 @@
34 34 val replace : t -> Trainee.id -> record -> bool Lwt.t
35 35 val log : t -> Trainee.id -> Evidence.Log.t Lwt.t
36 36 val history : t -> Trainee.id -> record list Lwt.t
37 Added: val save_feedback : t -> Trainee.id -> Evidence.Feedback.t -> unit Lwt.t
38 Added: val feedback : t -> Trainee.id -> Evidence.Feedback.t list Lwt.t
37 39 end
lib/app/repository.mli
index e62f41ec..04f0f7b8 100644..100644
@@ -69,4 +69,13 @@
69 69
70 70 val history : t -> Trainee.id -> record list Lwt.t
71 71 (** Most recent first. *)
72 Added:
73 Added: (** {2 Subjective feedback} *)
74 Added:
75 Added: val save_feedback : t -> Trainee.id -> Evidence.Feedback.t -> unit Lwt.t
76 Added: (** Store a subjective feedback report. Feedback is a standalone observation,
77 Added: not tied to a workout: a trainee may report it at any time. *)
78 Added:
79 Added: val feedback : t -> Trainee.id -> Evidence.Feedback.t list Lwt.t
80 Added: (** Stored feedback reports, most recent first. *)
72 81 end
lib/app/service.ml
index 0190fa44..751e7f7a 100644..100644
@@ -220,6 +220,16 @@
220 220 R.log t.repo trainee >|= fun log -> Progression.diagnose log
221 221 end
222 222
223 Added: (* --- subjective feedback --- *)
224 Added: module Feedback = struct
225 Added: let record t trainee ~reported_at signals =
226 Added: match Evidence.Feedback.make ~reported_at signals with
227 Added: | report -> R.save_feedback t.repo trainee report >|= fun () -> Ok report
228 Added: | exception Evidence.Feedback.Invalid error -> Lwt.return (Error error)
229 Added:
230 Added: let list t trainee = R.feedback t.repo trainee
231 Added: end
232 Added:
223 233 (* Re-export the use cases as one flat service, matching Service.mli. *)
224 234
225 235 let register = Accounts.register
@@ -242,4 +252,6 @@
242 252 let history = Records.history
243 253 let progress = Assessment.progress
244 254 let diagnostics = Assessment.diagnostics
255 Added: let record_feedback = Feedback.record
256 Added: let feedback = Feedback.list
245 257 end
lib/app/service.mli
index 1f3d4eb9..2d715494 100644..100644
@@ -152,4 +152,19 @@
152 152
153 153 val diagnostics : t -> Trainee.id -> Progression.diagnostic list Lwt.t
154 154 (** Habits the record shows that HD1 names as causes of overtraining. *)
155 Added:
156 Added: (** {2 Subjective feedback} *)
157 Added:
158 Added: val record_feedback :
159 Added: t ->
160 Added: Trainee.id ->
161 Added: reported_at:Recovery.timestamp ->
162 Added: Evidence.Feedback.signal list ->
163 Added: (Evidence.Feedback.t, Evidence.Feedback.error) result Lwt.t
164 Added: (** Store a subjective feedback report. [Error] when a signal category
165 Added: repeats. Feedback is standalone: a trainee may report it at any time,
166 Added: independent of a workout. *)
167 Added:
168 Added: val feedback : t -> Trainee.id -> Evidence.Feedback.t list Lwt.t
169 Added: (** Stored feedback reports, most recent first. *)
155 170 end
lib/app/sqlite_repo.ml
index 064c7870..60259dd9 100644..100644
@@ -64,6 +64,18 @@
64 64 let history =
65 65 (string ->* t2 string string)
66 66 "SELECT id, encoded FROM workout WHERE trainee_id = ? ORDER BY seq DESC"
67 Added:
68 Added: let next_feedback_seq =
69 Added: (string ->! int)
70 Added: "SELECT COALESCE(MAX(seq), 0) + 1 FROM feedback WHERE trainee_id = ?"
71 Added:
72 Added: let insert_feedback =
73 Added: (t3 string int string ->. unit)
74 Added: "INSERT INTO feedback (trainee_id, seq, encoded) VALUES (?, ?, ?)"
75 Added:
76 Added: let feedback =
77 Added: (string ->* string)
78 Added: "SELECT encoded FROM feedback WHERE trainee_id = ? ORDER BY seq DESC"
67 79 end
68 80
69 81 (* --- pool helper --- *)
@@ -243,3 +255,24 @@
243 255 List.fold_left
244 256 (fun log record -> Evidence.Log.add log record.Repository.workout)
245 257 Evidence.Log.empty (List.rev records)
258 Added:
259 Added: (* --- subjective feedback --- *)
260 Added:
261 Added: let save_feedback t id report =
262 Added: let trainee = Trainee.id_to_string id in
263 Added: let encoded = Codec.encode_feedback report in
264 Added: run t (fun (module Db : Caqti_lwt.CONNECTION) ->
265 Added: Db.find Q.next_feedback_seq trainee)
266 Added: >>= fun seq ->
267 Added: run t (fun (module Db : Caqti_lwt.CONNECTION) ->
268 Added: Db.exec Q.insert_feedback (trainee, seq, encoded))
269 Added:
270 Added: let decode_feedback encoded =
271 Added: match Codec.decode_feedback encoded with
272 Added: | Ok report -> report
273 Added: | Error e -> raise (Corrupt e)
274 Added:
275 Added: let feedback t id =
276 Added: run t (fun (module Db : Caqti_lwt.CONNECTION) ->
277 Added: Db.collect_list Q.feedback (Trainee.id_to_string id))
278 Added: >|= List.map decode_feedback
lib/web/assets/hito.css
index e24cf682..2b89417e 100644..100644
@@ -454,6 +454,31 @@
454 454 .recorded-slot { margin: 1rem 0; }
455 455 .recorded-slot .done { margin-bottom: 0.35rem; }
456 456
457 Added: /* The subjective feedback section on the Logbook. A bordered block separating
458 Added: the standalone feedback form from the workout list. The flags stack as
459 Added: inline checkbox rows; past reports read as a plain list. */
460 Added: .feedback-section {
461 Added: margin-top: 2rem;
462 Added: border-top: 1px solid var(--rule);
463 Added: padding-top: 1rem;
464 Added: }
465 Added: .feedback-flag {
466 Added: display: flex;
467 Added: align-items: center;
468 Added: gap: 0.5rem;
469 Added: margin: 0.4rem 0;
470 Added: font-weight: 500;
471 Added: }
472 Added: .feedback-flag input {
473 Added: width: auto;
474 Added: min-height: 0;
475 Added: margin: 0;
476 Added: }
477 Added: .feedback-list {
478 Added: margin-top: 1rem;
479 Added: list-style: disc;
480 Added: }
481 Added:
457 482 .warn {
458 483 max-width: 47rem;
459 484 margin: 1rem 0;
lib/web/decode.ml
index 5e55c9ab..7de711fc 100644..100644
@@ -84,6 +84,57 @@
84 84
85 85 let override = Form.required Form.bool "override"
86 86
87 Added: (* --- subjective feedback --- *)
88 Added:
89 Added: let level = function
90 Added: | "below" -> Ok Evidence.Feedback.Below_usual
91 Added: | "usual" -> Ok Evidence.Feedback.Usual
92 Added: | "above" -> Ok Evidence.Feedback.Above_usual
93 Added: | _ -> Error "error.level"
94 Added:
95 Added: (* A leveled signal field: the select omits the signal when left blank, and
96 Added: otherwise carries below/usual/above. [make] wraps the level in its category. *)
97 Added: let leveled field make =
98 Added: let open Form in
99 Added: let+ raw = optional string field in
100 Added: match raw with
101 Added: | None | Some "" -> None
102 Added: | Some value -> (
103 Added: match level value with Ok l -> Some (make l) | Error _ -> None)
104 Added:
105 Added: (* A boolean flag field: a checked box reports the signal, an unchecked one is
106 Added: absent. *)
107 Added: let flag field signal =
108 Added: let open Form in
109 Added: let+ checked = optional bool field in
110 Added: match checked with Some true -> Some signal | _ -> None
111 Added:
112 Added: let feedback =
113 Added: let open Form in
114 Added: let+ sleep = leveled "sleep" (fun l -> Evidence.Feedback.Sleep l)
115 Added: and+ appetite = leveled "appetite" (fun l -> Evidence.Feedback.Appetite l)
116 Added: and+ readiness = leveled "readiness" (fun l -> Evidence.Feedback.Readiness l)
117 Added: and+ motivation =
118 Added: leveled "motivation" (fun l -> Evidence.Feedback.Motivation l)
119 Added: and+ difficulty =
120 Added: leveled "difficulty" (fun l -> Evidence.Feedback.Difficulty l)
121 Added: and+ pain = flag "pain" Evidence.Feedback.Pain
122 Added: and+ injury = flag "injury" Evidence.Feedback.Injury
123 Added: and+ preparation =
124 Added: flag "preparation" Evidence.Feedback.Preparation_insufficient
125 Added: in
126 Added: List.filter_map Fun.id
127 Added: [
128 Added: sleep;
129 Added: appetite;
130 Added: readiness;
131 Added: motivation;
132 Added: difficulty;
133 Added: pain;
134 Added: injury;
135 Added: preparation;
136 Added: ]
137 Added:
87 138 let message = function
88 139 | "error.required" -> "Enter a value."
89 140 | "error.expected.number" -> "Enter a valid number."
lib/web/decode.mli
index f03309ac..8bd83faf 100644..100644
@@ -2,4 +2,9 @@
2 2
3 3 val override : bool Dream_html.Form.t
4 4 val stimulus : Prescription.Stimulus.t -> Evidence.Stimulus.t Dream_html.Form.t
5 Added:
6 Added: val feedback : Evidence.Feedback.signal list Dream_html.Form.t
7 Added: (** Decodes the subjective feedback form: leveled selects and boolean flags,
8 Added: dropping any signal left unreported. *)
9 Added:
5 10 val errors_to_text : (string * string) list -> string
lib/web/handlers.ml
index 0b3ba033..67b35a40 100644..100644
@@ -365,7 +365,7 @@
365 365 | Ok () -> (
366 366 Service.finish t.service trainee.Trainee.id ~ended_at:(t.now ())
367 367 >>= function
368 Removed: | Some _ -> redirect_to request Routes.logbook
368 Added: | Some _ -> Dream.redirect request "/logbook?prompt=feedback"
369 369 | None -> not_found Present.no_workout)
370 370
371 371 (* Leave the current workout unconditionally. Cancelling never shows an
@@ -403,11 +403,31 @@
403 403 let index t trainee request =
404 404 Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
405 405 Service.history t.service trainee.Trainee.id >>= fun records ->
406 Added: Service.feedback t.service trainee.Trainee.id >>= fun feedback ->
407 Added: let suggest_feedback =
408 Added: match Dream.query request "prompt" with
409 Added: | Some "feedback" -> true
410 Added: | _ -> false
411 Added: in
406 412 html
407 413 (Pages.logbook request
408 414 ~logging:(Option.is_some in_progress)
409 Removed: ~trainee records)
415 Added: ~trainee ~feedback ~suggest_feedback records)
410 416
417 Added: (* Record subjective feedback. Standalone: it needs no workout, so it is
418 Added: available from the Logbook at any time. An empty submission (no signal
419 Added: chosen) is accepted and simply stores nothing meaningful; a repeated
420 Added: signal category is rejected by the domain. *)
421 Added: let record_feedback t trainee request =
422 Added: decode_form Decode.feedback request >>= function
423 Added: | Error _ -> bad_request Present.form_invalid
424 Added: | Ok signals -> (
425 Added: Service.record_feedback t.service trainee.Trainee.id
426 Added: ~reported_at:(t.now ()) signals
427 Added: >>= function
428 Added: | Ok _ -> redirect_to request Routes.logbook
429 Added: | Error _ -> bad_request Present.form_invalid)
430 Added:
411 431 let show t trainee request id =
412 432 Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
413 433 record_target t trainee.Trainee.id id >>= function
@@ -470,6 +490,9 @@
470 490 [
471 491 Dream_html.get Routes.logbook (fun request ->
472 492 authenticated t request (fun trainee -> index t trainee request));
493 Added: Dream_html.post Routes.feedback (fun request ->
494 Added: authenticated t request (fun trainee ->
495 Added: record_feedback t trainee request));
473 496 Dream_html.get Routes.record (fun request id ->
474 497 authenticated t request (fun trainee -> show t trainee request id));
475 498 Dream_html.post Routes.record_slot (fun request id slot ->
lib/web/pages.ml
index 792f838f..0487c548 100644..100644
@@ -915,7 +915,105 @@
915 915 | (slot, _) :: _ -> slot
916 916 | [] -> 0
917 917
918 Removed: let logbook request ?(logging = false) ~trainee records =
918 Added: (* The subjective feedback form. Leveled selects report sleep, appetite,
919 Added: readiness, motivation, and difficulty against a personal baseline; flags
920 Added: report pain, injury, and insufficient preparation. A field left blank reports
921 Added: nothing, so the trainee submits only what they mean to. Feedback is
922 Added: standalone — recorded from the Logbook at any time. *)
923 Added: let feedback_level_select field label =
924 Added: tag "div"
925 Added: [ class_ "field" ]
926 Added: [
927 Added: tag "label" [ Dream_html.string_attr "for" "%s" field ] [ txt "%s" label ];
928 Added: tag "select"
929 Added: [
930 Added: Dream_html.string_attr "name" "%s" field;
931 Added: Dream_html.string_attr "id" "%s" field;
932 Added: ]
933 Added: [
934 Added: tag "option" [ value "" ] [ txt "Not reported" ];
935 Added: tag "option" [ value "below" ] [ txt "Below usual" ];
936 Added: tag "option" [ value "usual" ] [ txt "Usual" ];
937 Added: tag "option" [ value "above" ] [ txt "Above usual" ];
938 Added: ];
939 Added: ]
940 Added:
941 Added: let feedback_flag field label =
942 Added: tag "label"
943 Added: [ class_ "feedback-flag" ]
944 Added: [
945 Added: void "input"
946 Added: [
947 Added: type_ "checkbox";
948 Added: Dream_html.string_attr "name" "%s" field;
949 Added: value "true";
950 Added: ];
951 Added: txt " %s" label;
952 Added: ]
953 Added:
954 Added: let feedback_form request =
955 Added: tag "form"
956 Added: [
957 Added: action Routes.feedback;
958 Added: post_form;
959 Added: class_ "feedback-form";
960 Added: Dream_html.attr "data-hito-app-form";
961 Added: ]
962 Added: [
963 Added: Dream_html.csrf_tag request;
964 Added: tag "fieldset" []
965 Added: [
966 Added: feedback_level_select "sleep" "Sleep";
967 Added: feedback_level_select "appetite" "Appetite";
968 Added: feedback_level_select "readiness" "Readiness";
969 Added: feedback_level_select "motivation" "Motivation";
970 Added: feedback_level_select "difficulty" "Perceived difficulty";
971 Added: tag "div"
972 Added: [ class_ "field" ]
973 Added: [
974 Added: feedback_flag "pain" "Pain";
975 Added: feedback_flag "injury" "Injury";
976 Added: feedback_flag "preparation" "Preparation was insufficient";
977 Added: ];
978 Added: void "input" [ type_ "submit"; value "Record feedback" ];
979 Added: ];
980 Added: ]
981 Added:
982 Added: let describe_signal (signal : Evidence.Feedback.signal) =
983 Added: let level = function
984 Added: | Evidence.Feedback.Below_usual -> "below usual"
985 Added: | Usual -> "usual"
986 Added: | Above_usual -> "above usual"
987 Added: in
988 Added: match signal with
989 Added: | Sleep l -> Printf.sprintf "Sleep %s" (level l)
990 Added: | Appetite l -> Printf.sprintf "Appetite %s" (level l)
991 Added: | Readiness l -> Printf.sprintf "Readiness %s" (level l)
992 Added: | Motivation l -> Printf.sprintf "Motivation %s" (level l)
993 Added: | Difficulty l -> Printf.sprintf "Difficulty %s" (level l)
994 Added: | Pain -> "Pain"
995 Added: | Injury -> "Injury"
996 Added: | Preparation_insufficient -> "Preparation insufficient"
997 Added:
998 Added: let feedback_list reports =
999 Added: if reports = [] then []
1000 Added: else
1001 Added: [
1002 Added: tag "ul"
1003 Added: [ class_ "feedback-list" ]
1004 Added: (List.map
1005 Added: (fun report ->
1006 Added: let signals =
1007 Added: String.concat ", "
1008 Added: (List.map describe_signal (Evidence.Feedback.signals report))
1009 Added: in
1010 Added: tag "li" []
1011 Added: [ txt "%s" (if signals = "" then "No signals" else signals) ])
1012 Added: reports);
1013 Added: ]
1014 Added:
1015 Added: let logbook request ?(logging = false) ~trainee ?(feedback = [])
1016 Added: ?(suggest_feedback = false) records =
919 1017 html_page ~trainee ~request ~active:"logbook" ~logging "Logbook"
920 1018 [
921 1019 tag "h1" [] [ txt "Logbook" ];
@@ -946,4 +1044,22 @@
946 1044 tag "p" [ class_ "done" ] [ txt "%s" status ];
947 1045 ])
948 1046 records));
1047 Added: tag "section"
1048 Added: [ class_ "feedback-section" ]
1049 Added: ([
1050 Added: tag "h2" [] [ txt "How are you feeling?" ];
1051 Added: (if suggest_feedback then
1052 Added: tag "p"
1053 Added: [ class_ "eyebrow" ]
1054 Added: [ txt "Workout saved — add feedback while it is fresh." ]
1055 Added: else txt "");
1056 Added: tag "p" []
1057 Added: [
1058 Added: txt
1059 Added: "Record subjective feedback at any time. Report only what you \
1060 Added: mean to; leave the rest blank.";
1061 Added: ];
1062 Added: feedback_form request;
1063 Added: ]
1064 Added: @ feedback_list feedback);
949 1065 ]
lib/web/pages.mli
index d6c28221..21fe0d30 100644..100644
@@ -63,7 +63,12 @@
63 63 Dream.request ->
64 64 ?logging:bool ->
65 65 trainee:Trainee.t ->
66 Added: ?feedback:Evidence.Feedback.t list ->
67 Added: ?suggest_feedback:bool ->
66 68 Repository.record list ->
67 69 page
70 Added: (** The logbook: recorded workouts and a standalone subjective feedback form.
71 Added: [feedback] lists past reports, most recent first. [suggest_feedback] shows a
72 Added: prompt inviting feedback, set after a workout finishes. *)
68 73
69 74 val problem : title:string -> detail:string -> page
lib/web/routes.ml
index f182f90f..53fa62ee 100644..100644
@@ -14,6 +14,7 @@
14 14 let%path finish_workout = "/workout/finish"
15 15 let%path cancel_workout = "/workout/cancel"
16 16 let%path logbook = "/logbook"
17 Added: let%path feedback = "/feedback"
17 18 let%path record = "/logbook/%s"
18 19 let%path record_slot = "/logbook/%s/slots/%d"
19 20 let%path record_slot_edit = "/logbook/%s/slots/%d/edit"
test/test_sqlite_repo.ml
index 3196a9a7..58c7db3f 100644..100644
@@ -246,6 +246,47 @@
246 246 Alcotest.(check bool)
247 247 "slot cleared" true
248 248 (Option.is_none (run (S.in_progress s t)))) );
249 Added: ( "subjective feedback survives a reconnect",
250 Added: `Quick,
251 Added: fun () ->
252 Added: let path, uri = temp_uri () in
253 Added: Fun.protect
254 Added: ~finally:(fun () -> cleanup path)
255 Added: (fun () ->
256 Added: let t =
257 Added: let repo = connect uri in
258 Added: let s = S.make ~repo in
259 Added: let id =
260 Added: (ok
261 Added: (run (S.register s ~username:"alice" ~password:"heavyduty1")))
262 Added: .Trainee.id
263 Added: in
264 Added: let _ =
265 Added: ok
266 Added: (run
267 Added: (S.record_feedback s id ~reported_at:(day 1)
268 Added: [
269 Added: Evidence.Feedback.Sleep Evidence.Feedback.Below_usual;
270 Added: Evidence.Feedback.Pain;
271 Added: ]))
272 Added: in
273 Added: id
274 Added: in
275 Added: (* Reconnect: the feedback report is still there, with its
276 Added: signals. *)
277 Added: let repo = connect uri in
278 Added: let s = S.make ~repo in
279 Added: let reports = run (S.feedback s t) in
280 Added: Alcotest.(check int) "one feedback report" 1 (List.length reports);
281 Added: let signals = Evidence.Feedback.signals (List.hd reports) in
282 Added: Alcotest.(check int) "two signals" 2 (List.length signals);
283 Added: Alcotest.(check bool)
284 Added: "sleep signal preserved" true
285 Added: (List.mem (Evidence.Feedback.Sleep Evidence.Feedback.Below_usual)
286 Added: signals);
287 Added: Alcotest.(check bool)
288 Added: "pain signal preserved" true
289 Added: (List.mem Evidence.Feedback.Pain signals)) );
249 290 ]
250 291
251 292 let suite =
test/test_web.ml
index a37b758c..10a2cc6a 100644..100644
@@ -896,6 +896,58 @@
896 896 Alcotest.(check bool)
897 897 "shows bottom navigation" true
898 898 (contains ~substring:"bottom-nav" record_page) );
899 Added: ( "the logbook offers a standalone feedback form",
900 Added: `Quick,
901 Added: fun () ->
902 Added: let c = client () in
903 Added: let _ = sign_in_new c in
904 Added: let logbook_page = body (get c "/logbook") in
905 Added: Alcotest.(check bool)
906 Added: "renders the feedback form" true
907 Added: (contains ~substring:"feedback-form" logbook_page);
908 Added: Alcotest.(check bool)
909 Added: "posts feedback to its own route" true
910 Added: (contains ~substring:"action=\"/feedback\"" logbook_page) );
911 Added: ( "submitting feedback stores it and it appears on the logbook",
912 Added: `Quick,
913 Added: fun () ->
914 Added: let c = client () in
915 Added: let _ = sign_in_new c in
916 Added: let token = Option.get (csrf_token (body (get c "/logbook"))) in
917 Added: let stored =
918 Added: post c "/feedback"
919 Added: [ ("dream.csrf", token); ("sleep", "below"); ("pain", "true") ]
920 Added: in
921 Added: Alcotest.(check int) "feedback stored" 303 (status stored);
922 Added: let logbook_page = body (get c "/logbook") in
923 Added: Alcotest.(check bool)
924 Added: "shows the reported sleep signal" true
925 Added: (contains ~substring:"Sleep below usual" logbook_page);
926 Added: Alcotest.(check bool)
927 Added: "shows the reported pain signal" true
928 Added: (contains ~substring:"Pain" logbook_page) );
929 Added: ( "finishing a workout suggests feedback on the logbook",
930 Added: `Quick,
931 Added: fun () ->
932 Added: let c = client () in
933 Added: let _ = sign_in_new c in
934 Added: let token = Option.get (csrf_token (body (get c "/"))) in
935 Added: let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
936 Added: let token = Option.get (csrf_token (body (get c "/"))) in
937 Added: let _ =
938 Added: post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
939 Added: in
940 Added: let token = Option.get (csrf_token (body (get c "/workout"))) in
941 Added: let finished = post c "/workout/finish" [ ("dream.csrf", token) ] in
942 Added: Alcotest.(check int) "finish redirects" 303 (status finished);
943 Added: Alcotest.(check bool)
944 Added: "redirects to the logbook with a feedback prompt" true
945 Added: (List.mem "/logbook?prompt=feedback"
946 Added: (Dream.headers finished "Location"));
947 Added: let prompted = body (get c "/logbook?prompt=feedback") in
948 Added: Alcotest.(check bool)
949 Added: "shows the feedback suggestion" true
950 Added: (contains ~substring:"add feedback while it is fresh" prompted) );
899 951 ] );
900 952 ]
901 953