[OCaml] High Intensity Training Online
feat enhance current workout logging
Keep workout logging responsive without moving recovery, volume, or\nvalidation decisions into the browser. The js_of_ocaml client swaps only\nserver-rendered current-workout content, while ordinary links and\nCSRF-protected forms remain the no-JavaScript fallback.
Changed files
ARCHITECTURE.md
@@ -70,11 +70,16 @@
70
70
first. Every `Repository` and `Service` operation is scoped to a
71
71
`Trainee.id`. There is no server-wide state: a trainee's active routine and
72
72
workout in progress are stored, not held in a slot.
73
Removed:
- **`hito.web`** — `Routes`, `Decode`, `Pages`, `Handlers`. Dream and
74
Removed:
dream-html live only here. The server renders HTML and uses no client-side
75
Removed:
OCaml or js_of_ocaml. Wall-clock time enters here, never in the core.
73
Added:
- **`hito.web`** — `Routes`, `Decode`, `Pages`, `Handlers`, and a
74
Added:
workout-only `js_of_ocaml` client. Dream and dream-html live only here.
75
Added:
Wall-clock time enters here, never in the core.
76
76
`Handlers` is a functor over `Repository.S`, so production runs on
77
Removed:
`Sqlite_repo` while tests run on `Memory_repo`. Authentication uses one
77
Added:
`Sqlite_repo` while tests run on `Memory_repo`. The current workout page ships
78
Added:
a small `js_of_ocaml` enhancement client: it replaces only marked exercise
79
Added:
panels and record/correction responses in place. Its server-rendered links
80
Added:
and CSRF-protected forms remain the fallback, so Home, Routine, Logbook,
81
Added:
saved history, finish/cancel, and every JavaScript-disabled workflow keep
82
Added:
ordinary browser navigation. Authentication uses one
78
83
`authenticated` combinator: it resolves the signed-in trainee and passes it
79
84
to a continuation, so a route with any number of path captures shares one
80
85
gate. Every domain and service error becomes a user-facing sentence in one
dune-project
@@ -46,6 +46,10 @@
46
46
(and
47
47
(= 4.1.0)
48
48
:build))
49
Added:
(js_of_ocaml
50
Added:
(= 6.4.1))
51
Added:
(js_of_ocaml-lwt
52
Added:
(= 6.4.1))
49
53
(ocamlformat
50
54
(and
51
55
(= 0.29.0)
hito.opam
@@ -22,6 +22,8 @@
22
22
"safepass" {= "3.1"}
23
23
"uri" {= "4.4.0"}
24
24
"crunch" {= "4.1.0" & build}
25
Added:
"js_of_ocaml" {= "6.4.1"}
26
Added:
"js_of_ocaml-lwt" {= "6.4.1"}
25
27
"ocamlformat" {= "0.29.0" & with-dev-setup}
26
28
"odoc" {with-doc}
27
29
]
lib/web/dune
@@ -1,3 +1,11 @@
1
Added:
(executable
2
Added:
(name workout_client)
3
Added:
(modules workout_client)
4
Added:
(modes js)
5
Added:
(preprocess
6
Added:
(pps js_of_ocaml-ppx))
7
Added:
(libraries js_of_ocaml js_of_ocaml-lwt lwt))
8
Added:
1
9
(rule
2
10
(targets stylesheet.ml)
3
11
(deps
@@ -5,10 +13,22 @@
5
13
(action
6
14
(run %{bin:ocaml-crunch} --silent --mode plain --output %{targets} assets)))
7
15
16
Added:
(rule
17
Added:
(target workout_client_asset.ml)
18
Added:
(deps workout_client.bc.js)
19
Added:
(action
20
Added:
(run
21
Added:
bash
22
Added:
-c
23
Added:
"tmp=$(mktemp -d); cp \"$1\" \"$tmp/workout_client.js\"; %{bin:ocaml-crunch} --silent --mode plain --output \"$2\" \"$tmp\"; rm -rf \"$tmp\""
24
Added:
--
25
Added:
%{dep:workout_client.bc.js}
26
Added:
%{target})))
27
Added:
8
28
(library
9
29
(name hito_web)
10
30
(public_name hito.web)
11
Removed:
(modules routes decode pages handlers stylesheet)
31
Added:
(modules routes decode pages handlers stylesheet workout_client_asset)
12
32
(preprocess
13
33
(pps dream-html.ppx))
14
34
(libraries hito.core hito.app dream dream-html lwt unix))
lib/web/handlers.ml
@@ -470,12 +470,22 @@
470
470
| Some stylesheet -> stylesheet
471
471
| None -> failwith "Embedded stylesheet hito.css is missing"
472
472
473
Added:
let workout_client =
474
Added:
match Workout_client_asset.read "workout_client.js" with
475
Added:
| Some script -> script
476
Added:
| None -> failwith "Embedded workout client is missing"
477
Added:
473
478
let routes =
474
479
[
475
480
Dream_html.get Routes.stylesheet (fun _ ->
476
481
Dream.respond
477
482
~headers:[ ("Content-Type", "text/css; charset=utf-8") ]
478
483
stylesheet);
484
Added:
Dream_html.get Routes.workout_client (fun _ ->
485
Added:
Dream.respond
486
Added:
~headers:
487
Added:
[ ("Content-Type", "application/javascript; charset=utf-8") ]
488
Added:
workout_client);
479
489
]
480
490
end
481
491
lib/web/pages.ml
@@ -13,13 +13,15 @@
13
13
let step = Dream_html.string_attr "step"
14
14
let required = Dream_html.attr "required"
15
15
let href path = Dream_html.path_attr (Dream_html.uri_attr "href") path
16
Added:
let src path = Dream_html.path_attr (Dream_html.uri_attr "src") path
16
17
let action path = Dream_html.path_attr (Dream_html.uri_attr "action") path
17
18
let post_form = Dream_html.string_attr "method" "post"
18
19
19
20
(* The shell. [trainee] and [request] are present on authenticated pages, which
20
21
then show a logout control and the username on the history link. Auth pages
21
22
omit both. *)
22
Removed:
let html_page ?trainee ?request ?(active = "") title content =
23
Added:
let html_page ?trainee ?request ?(active = "") ?(workout_client = false) title
24
Added:
content =
23
25
let nav_link path label = tag "a" [ href path ] [ txt "%s" label ] in
24
26
let navigation_links username =
25
27
[
@@ -147,7 +149,15 @@
147
149
tag "main" [] [ tag "div" [ class_ "page-surface" ] content ];
148
150
];
149
151
]
150
Removed:
@ bottom_nav);
152
Added:
@ bottom_nav
153
Added:
@
154
Added:
if workout_client then
155
Added:
[
156
Added:
tag "script"
157
Added:
[ src Routes.workout_client; Dream_html.attr "defer" ]
158
Added:
[];
159
Added:
]
160
Added:
else []);
151
161
]
152
162
153
163
let problem ~title ~detail =
@@ -451,7 +461,7 @@
451
461
(* [recorded] pre-fills the form when correcting a slot; [submit] names the
452
462
action. Load and reps of each movement are laid out side by side. *)
453
463
let form_for_stimulus request ~action_path ~slot ~prescription ?recorded
454
Removed:
?(submit = "Record") ~errors () =
464
Added:
?(enhanced = false) ?(submit = "Record") ~errors () =
455
465
let field_id field = Printf.sprintf "slot-%d-%s" slot field in
456
466
let efforts = Option.map Evidence.Stimulus.efforts recorded in
457
467
let nth n = Option.bind efforts (fun es -> List.nth_opt es n) in
@@ -493,7 +503,9 @@
493
503
();
494
504
]
495
505
in
496
Removed:
tag "form" [ action_path; post_form ]
506
Added:
tag "form"
507
Added:
([ action_path; post_form ]
508
Added:
@ if enhanced then [ Dream_html.attr "data-hito-workout-form" ] else [])
497
509
[
498
510
Dream_html.csrf_tag request;
499
511
tag "fieldset" []
@@ -565,6 +577,7 @@
565
577
566
578
let workout request ~trainee ?(errors = []) ?editing ~record_id ~active_slot
567
579
workout =
580
Added:
let enhanced = Option.is_none record_id in
568
581
let prescription = Evidence.Workout.prescription workout in
569
582
let performed = Evidence.Workout.performed workout in
570
583
let prescribed_slots = Prescription.Workout.stimuli prescription in
@@ -629,6 +642,10 @@
629
642
]
630
643
in
631
644
let attrs =
645
Added:
if enhanced then Dream_html.attr "data-hito-workout-link" :: attrs
646
Added:
else attrs
647
Added:
in
648
Added:
let attrs =
632
649
if current then
633
650
Dream_html.string_attr "aria-current" "page" :: attrs
634
651
else attrs
@@ -675,7 +692,7 @@
675
692
volume; the logbook states one fact per slot.";
676
693
];
677
694
form_for_stimulus request ~action_path:(edit_action active_slot)
678
Removed:
~slot:active_slot ~prescription ~recorded:stimulus
695
Added:
~slot:active_slot ~prescription ~enhanced ~recorded:stimulus
679
696
~submit:"Save correction" ~errors ();
680
697
]
681
698
| None ->
@@ -689,7 +706,7 @@
689
706
];
690
707
form_for_stimulus request
691
708
~action_path:(record_action active_slot)
692
Removed:
~slot:active_slot ~prescription ~errors ();
709
Added:
~slot:active_slot ~prescription ~enhanced ~errors ();
693
710
]
694
711
in
695
712
[ tag "section" [ class_ "slot-panel" ] (heading :: body) ]
@@ -736,21 +753,41 @@
736
753
];
737
754
]
738
755
in
739
Removed:
html_page ~trainee ~request ~active:"workout"
756
Added:
html_page ~trainee ~request ~active:"workout" ~workout_client:enhanced
740
757
(Prescription.Workout.name prescription)
741
Removed:
(override_note
742
Removed:
@ [
743
Removed:
tag "h1" [] [ txt "%s" (Prescription.Workout.name prescription) ];
744
Removed:
tag "p"
745
Removed:
[ class_ "ledger-meta" ]
758
Added:
[
759
Added:
tag "div"
760
Added:
(if enhanced then
761
Added:
[
762
Added:
Dream_html.attr "data-hito-workout";
763
Added:
Dream_html.attr "data-hito-workout-content";
764
Added:
]
765
Added:
else [])
766
Added:
(override_note
767
Added:
@ [
768
Added:
tag "h1" [] [ txt "%s" (Prescription.Workout.name prescription) ];
769
Added:
tag "p"
770
Added:
[ class_ "ledger-meta" ]
771
Added:
[
772
Added:
txt "%d of %d recorded."
773
Added:
(Evidence.Workout.filled_slots workout)
774
Added:
slot_count;
775
Added:
];
776
Added:
exercise_group;
777
Added:
]
778
Added:
@ active_panel @ complete_note @ finish_section
779
Added:
@
780
Added:
if enhanced then
746
781
[
747
Removed:
txt "%d of %d recorded."
748
Removed:
(Evidence.Workout.filled_slots workout)
749
Removed:
slot_count;
750
Removed:
];
751
Removed:
exercise_group;
752
Removed:
]
753
Removed:
@ active_panel @ complete_note @ finish_section)
782
Added:
tag "p"
783
Added:
[
784
Added:
Dream_html.string_attr "aria-live" "polite";
785
Added:
Dream_html.attr "data-hito-workout-status";
786
Added:
]
787
Added:
[];
788
Added:
]
789
Added:
else []);
790
Added:
]
754
791
755
792
(* The slot a workout view should open on: the first slot still awaiting
756
793
a record, or the first slot when every slot is filled. A caller clamps a
lib/web/pages.mli
@@ -36,9 +36,11 @@
36
36
Evidence.Workout.t ->
37
37
page
38
38
(** Renders one prescribed slot at a time under a vertical group of named
39
Removed:
exercise buttons. [active_slot] selects the visible button; a handler clamps
40
Removed:
a requested slot and falls back to {!default_slot}. [record_id] is [None]
41
Removed:
for the workout in progress and [Some id] for a saved history record. *)
39
Added:
exercise buttons. Current workouts carry progressive-enhancement markers for
40
Added:
the js_of_ocaml client, while saved records always use ordinary links and
41
Added:
forms. [active_slot] selects the visible button; a handler clamps a
42
Added:
requested slot and falls back to {!default_slot}. [record_id] is [None] for
43
Added:
the workout in progress and [Some id] for a saved history record. *)
42
44
43
45
val default_slot : Evidence.Workout.t -> int
44
46
(** The slot a workout view opens on: the first slot still awaiting a record, or
lib/web/routes.ml
@@ -18,3 +18,4 @@
18
18
let%path record_slot = "/history/%s/slots/%d"
19
19
let%path record_slot_edit = "/history/%s/slots/%d/edit"
20
20
let%path stylesheet = "/assets/hito.css"
21
Added:
let%path workout_client = "/assets/workout-client.js"
lib/web/workout_client.ml
@@ -0,0 +1,149 @@
1
Added:
open Js_of_ocaml
2
Added:
open Lwt.Infix
3
Added:
4
Added:
let selector = "[data-hito-workout-content]"
5
Added:
let enhanced_link = "a[data-hito-workout-link]"
6
Added:
let enhanced_form = "form[data-hito-workout-form]"
7
Added:
let document = Dom_html.document
8
Added:
let request_number = ref 0
9
Added:
10
Added:
let query_one root selector =
11
Added:
match Js.Opt.to_option (root##querySelector (Js.string selector)) with
12
Added:
| None -> None
13
Added:
| Some node -> Js.Opt.to_option (Dom_html.CoerceTo.element node)
14
Added:
15
Added:
let closest selector element =
16
Added:
match Js.Opt.to_option (element##closest (Js.string selector)) with
17
Added:
| None -> None
18
Added:
| Some node -> Js.Opt.to_option (Dom_html.CoerceTo.element node)
19
Added:
20
Added:
let announce message =
21
Added:
match query_one document "[data-hito-workout-status]" with
22
Added:
| Some status -> status##.textContent := Js.some (Js.string message)
23
Added:
| None -> ()
24
Added:
25
Added:
let fallback url = Dom_html.window##.location##assign (Js.string url)
26
Added:
27
Added:
let replace_from_html html =
28
Added:
let next = Dom_html.createDiv document in
29
Added:
next##.innerHTML := Js.string html;
30
Added:
match (query_one document selector, query_one next selector) with
31
Added:
| Some current, Some replacement ->
32
Added:
let parent = Js.Opt.get current##.parentNode (fun () -> assert false) in
33
Added:
Dom.replaceChild parent replacement current;
34
Added:
(match query_one document "[data-hito-workout-content] h1" with
35
Added:
| Some heading ->
36
Added:
heading##setAttribute (Js.string "tabindex") (Js.string "-1");
37
Added:
heading##focus
38
Added:
| None -> ());
39
Added:
announce "Workout updated";
40
Added:
true
41
Added:
| _ -> false
42
Added:
43
Added:
let get ?(push = false) url =
44
Added:
incr request_number;
45
Added:
let request = !request_number in
46
Added:
announce "Loading workout";
47
Added:
Js_of_ocaml_lwt.XmlHttpRequest.perform_raw_url ~with_credentials:true
48
Added:
~headers:[ ("X-Hito-Workout", "1") ]
49
Added:
url
50
Added:
>>= fun response ->
51
Added:
if request <> !request_number then Lwt.return_unit
52
Added:
else if
53
Added:
response.code >= 200 && response.code < 300
54
Added:
&& replace_from_html response.content
55
Added:
then (
56
Added:
if push then
57
Added:
Dom_html.window##.history##pushState
58
Added:
Js.null (Js.string "")
59
Added:
(Js.some (Js.string url));
60
Added:
Lwt.return_unit)
61
Added:
else (
62
Added:
fallback url;
63
Added:
Lwt.return_unit)
64
Added:
65
Added:
let modified event =
66
Added:
Js.to_bool event##.metaKey
67
Added:
|| Js.to_bool event##.ctrlKey
68
Added:
|| Js.to_bool event##.shiftKey
69
Added:
|| Js.to_bool event##.altKey
70
Added:
71
Added:
let link_click event =
72
Added:
if event##.button <> 0 || modified event then Js._true
73
Added:
else
74
Added:
match closest enhanced_link (Dom_html.eventTarget event) with
75
Added:
| None -> Js._true
76
Added:
| Some link -> (
77
Added:
match Js.Opt.to_option (link##getAttribute (Js.string "href")) with
78
Added:
| None -> Js._true
79
Added:
| Some href ->
80
Added:
let url = Js.to_string href in
81
Added:
Dom.preventDefault event;
82
Added:
Lwt.async (fun () -> get ~push:true url);
83
Added:
Js._false)
84
Added:
85
Added:
let slot_from_action action =
86
Added:
match List.rev (String.split_on_char '/' action) with
87
Added:
| "edit" :: slot :: _ | slot :: _ -> slot
88
Added:
| [] -> ""
89
Added:
90
Added:
let form_submit event =
91
Added:
match closest enhanced_form (Dom_html.eventTarget event) with
92
Added:
| None -> Js._true
93
Added:
| Some element -> (
94
Added:
match Js.Opt.to_option (Dom_html.CoerceTo.form element) with
95
Added:
| None -> Js._true
96
Added:
| Some form when not (Js.to_bool form##checkValidity) -> Js._true
97
Added:
| Some form ->
98
Added:
let action =
99
Added:
match
100
Added:
Js.Opt.to_option (form##getAttribute (Js.string "action"))
101
Added:
with
102
Added:
| Some action -> Js.to_string action
103
Added:
| None -> "/workout"
104
Added:
in
105
Added:
let slot = slot_from_action action in
106
Added:
let submit =
107
Added:
match
108
Added:
Js.Opt.to_option
109
Added:
(form##querySelector (Js.string "input[type=submit]"))
110
Added:
with
111
Added:
| None -> None
112
Added:
| Some input -> Js.Opt.to_option (Dom_html.CoerceTo.input input)
113
Added:
in
114
Added:
Dom.preventDefault event;
115
Added:
Option.iter (fun input -> input##.disabled := Js._true) submit;
116
Added:
announce "Saving workout";
117
Added:
Lwt.async (fun () ->
118
Added:
Js_of_ocaml_lwt.XmlHttpRequest.perform_raw_url
119
Added:
~with_credentials:true ~override_method:`POST
120
Added:
~contents:(`Form_contents (Form.post_form_contents form))
121
Added:
action
122
Added:
>>= fun response ->
123
Added:
Option.iter (fun input -> input##.disabled := Js._false) submit;
124
Added:
if response.code = 400 && replace_from_html response.content then
125
Added:
Lwt.return_unit
126
Added:
else if response.code >= 200 && response.code < 300 then
127
Added:
get ("/workout?slot=" ^ slot)
128
Added:
else (
129
Added:
fallback action;
130
Added:
Lwt.return_unit));
131
Added:
Js._false)
132
Added:
133
Added:
let popstate _ =
134
Added:
Lwt.async (fun () -> get (Js.to_string Dom_html.window##.location##.href));
135
Added:
Js._true
136
Added:
137
Added:
let () =
138
Added:
Dom_html.addEventListener document Dom_html.Event.click
139
Added:
(Dom_html.handler link_click)
140
Added:
Js._false
141
Added:
|> ignore;
142
Added:
Dom_html.addEventListener document Dom_html.Event.submit
143
Added:
(Dom_html.handler form_submit)
144
Added:
Js._false
145
Added:
|> ignore;
146
Added:
Dom_html.addEventListener Dom_html.window Dom_html.Event.popstate
147
Added:
(Dom_html.handler popstate)
148
Added:
Js._false
149
Added:
|> ignore
test/test_web.ml
@@ -363,7 +363,29 @@
363
363
(contains ~substring:"?slot=1" workout_page);
364
364
Alcotest.(check bool)
365
365
"opens on the first slot's record form" true
366
Removed:
(contains ~substring:"/workout/slots/0" workout_page) );
366
Added:
(contains ~substring:"/workout/slots/0" workout_page);
367
Added:
Alcotest.(check bool)
368
Added:
"marks the current workout as progressively enhanced" true
369
Added:
(contains ~substring:"data-hito-workout" workout_page);
370
Added:
Alcotest.(check bool)
371
Added:
"marks the replaceable workout content" true
372
Added:
(contains ~substring:"data-hito-workout-content" workout_page);
373
Added:
Alcotest.(check bool)
374
Added:
"marks exercise links for enhancement" true
375
Added:
(contains ~substring:"data-hito-workout-link" workout_page);
376
Added:
Alcotest.(check bool)
377
Added:
"marks record forms while retaining their CSRF field" true
378
Added:
(contains ~substring:"data-hito-workout-form" workout_page
379
Added:
&& contains ~substring:"dream.csrf" workout_page);
380
Added:
Alcotest.(check bool)
381
Added:
"loads only the workout client" true
382
Added:
(contains ~substring:"/assets/workout-client.js" workout_page);
383
Added:
let asset = get c "/assets/workout-client.js" in
384
Added:
Alcotest.(check int) "serves the workout client" 200 (status asset);
385
Added:
Alcotest.(check bool)
386
Added:
"client has JavaScript content type" true
387
Added:
(List.mem "application/javascript; charset=utf-8"
388
Added:
(Dream.headers asset "Content-Type")) );
367
389
( "the routine page uses workout description accordions",
368
390
`Quick,
369
391
fun () ->
@@ -505,6 +527,15 @@
505
527
Alcotest.(check bool)
506
528
"does not use the old tab strip class" false
507
529
(contains ~substring:"slot-tab" record_page);
530
Added:
Alcotest.(check bool)
531
Added:
"does not enhance saved workout links" false
532
Added:
(contains ~substring:"data-hito-workout-link" record_page);
533
Added:
Alcotest.(check bool)
534
Added:
"does not mark saved history as replaceable workout content" false
535
Added:
(contains ~substring:"data-hito-workout-content" record_page);
536
Added:
Alcotest.(check bool)
537
Added:
"does not load the workout client for saved history" false
538
Added:
(contains ~substring:"/assets/workout-client.js" record_page);
508
539
Alcotest.(check bool)
509
540
"offers a saved-slot correction form" true
510
541
(contains ~substring:"/history/w1/slots/1/edit" record_page);