[OCaml] High Intensity Training Online
feat add a month calendar highlighting workout days
Show the current month above the logbook table as a week grid, centered on the page. Days on which a workout was performed -- native or imported -- are filled in the primary colour; today is ringed. The handler does the UTC date arithmetic (Monday-first weekday via a day-count, leap-aware month length) and passes a ready grid; the presenter only renders it. One month, no navigation yet.
Changed files
lib/presenter/pages.mli
@@ -58,6 +58,7 @@
58
58
?logging:bool ->
59
59
viewer:View_model.Viewer.t ->
60
60
?feedback:View_model.Feedback.report list ->
61
Added:
?calendar:View_model.Calendar.t ->
61
62
?suggest_feedback:bool ->
62
63
?feedback_open:bool ->
63
64
?delete_record:View_model.Logbook_entry.t ->
@@ -67,8 +68,10 @@
67
68
(** The logbook: recorded workouts and a modal subjective feedback form that
68
69
shows every factor at once, each optionally rated against the trainee's
69
70
usual, with one submit. [feedback] lists past reports, most recent first.
70
Removed:
[suggest_feedback] shows a prompt inviting feedback, set after a workout
71
Removed:
finishes. [feedback_open] renders the modal open for no-script clients. *)
71
Added:
[calendar] is the current month above the table, highlighting days a workout
72
Added:
was performed. [suggest_feedback] shows a prompt inviting feedback, set
73
Added:
after a workout finishes. [feedback_open] renders the modal open for
74
Added:
no-script clients. *)
72
75
73
76
val progress :
74
77
Dream.request ->
lib/presenter/pages_logbook.ml
@@ -275,127 +275,170 @@
275
275
[ txt "Delete" ];
276
276
])
277
277
278
Removed:
let logbook request ?(logging = false) ~viewer ?(feedback = [])
278
Added:
(* A single month as a week grid. Days that carry a workout are highlighted;
279
Added:
today is marked. Rendered above the logbook table. *)
280
Added:
let calendar_grid (cal : View_model.Calendar.t) =
281
Added:
let cell = function
282
Added:
| View_model.Calendar.Blank -> tag "td" [ class_ "calendar-blank" ] []
283
Added:
| View_model.Calendar.Day d ->
284
Added:
let classes =
285
Added:
"calendar-day"
286
Added:
^ (if d.workout then " calendar-workout" else "")
287
Added:
^ if d.today then " calendar-today" else ""
288
Added:
in
289
Added:
tag "td"
290
Added:
([ Dream_html.string_attr "class" "%s" classes ]
291
Added:
@
292
Added:
if d.workout then
293
Added:
[ Dream_html.string_attr "aria-label" "%d: workout" d.day_of_month ]
294
Added:
else [])
295
Added:
[ txt "%d" d.day_of_month ]
296
Added:
in
297
Added:
tag "table"
298
Added:
[ class_ "calendar" ]
299
Added:
[
300
Added:
tag "caption" [ class_ "calendar-caption" ] [ txt "%s" cal.month_label ];
301
Added:
tag "thead" []
302
Added:
[
303
Added:
tag "tr" []
304
Added:
(List.map
305
Added:
(fun h ->
306
Added:
tag "th"
307
Added:
[ Dream_html.string_attr "scope" "col" ]
308
Added:
[ txt "%s" h ])
309
Added:
cal.weekday_headings);
310
Added:
];
311
Added:
tag "tbody" []
312
Added:
(List.map (fun week -> tag "tr" [] (List.map cell week)) cal.weeks);
313
Added:
]
314
Added:
315
Added:
let logbook request ?(logging = false) ~viewer ?(feedback = []) ?calendar
279
316
?(suggest_feedback = false) ?(feedback_open = false) ?delete_record
280
317
?expanded_record records =
281
318
ignore expanded_record;
282
319
html_page ~viewer ~request ~active:"logbook" ~logging "Logbook"
283
Removed:
[
284
Removed:
tag "h1" [] [ txt "Logbook" ];
285
Removed:
(* Actions above the ledger. View progress opens the per-exercise chart. *)
286
Removed:
tag "div"
287
Removed:
[ class_ "button-group logbook-actions-bar" ]
288
Removed:
[
289
Removed:
tag "a"
290
Removed:
[
291
Removed:
href Routes.progress;
292
Removed:
class_ "button";
293
Removed:
Dream_html.attr "data-hito-app-link";
294
Removed:
]
295
Removed:
[ txt "View progress" ];
296
Removed:
];
297
Removed:
(if records = [] then tag "p" [] [ txt "Nothing logged yet." ]
298
Removed:
else
299
Removed:
let has_imports =
300
Removed:
List.exists
301
Removed:
(fun (e : View_model.Logbook_entry.t) -> e.imported)
302
Removed:
records
303
Removed:
in
304
Removed:
tag "div" []
305
Removed:
((if has_imports then
306
Removed:
[
307
Removed:
tag "p"
308
Removed:
[ class_ "logbook-caption" ]
309
Removed:
[
310
Removed:
tag "em" [] [ txt "Italic" ]; txt " titles were imported.";
311
Removed:
];
312
Removed:
]
313
Removed:
else [])
314
Removed:
@ [
315
Removed:
tag "table"
316
Removed:
[ class_ "logbook-table" ]
320
Added:
([
321
Added:
tag "h1" [] [ txt "Logbook" ];
322
Added:
(* Actions above the ledger. View progress opens the per-exercise chart. *)
323
Added:
tag "div"
324
Added:
[ class_ "button-group logbook-actions-bar" ]
325
Added:
[
326
Added:
tag "a"
327
Added:
[
328
Added:
href Routes.progress;
329
Added:
class_ "button";
330
Added:
Dream_html.attr "data-hito-app-link";
331
Added:
]
332
Added:
[ txt "View progress" ];
333
Added:
];
334
Added:
]
335
Added:
@ (match calendar with Some cal -> [ calendar_grid cal ] | None -> [])
336
Added:
@ [
337
Added:
(if records = [] then tag "p" [] [ txt "Nothing logged yet." ]
338
Added:
else
339
Added:
let has_imports =
340
Added:
List.exists
341
Added:
(fun (e : View_model.Logbook_entry.t) -> e.imported)
342
Added:
records
343
Added:
in
344
Added:
tag "div" []
345
Added:
((if has_imports then
317
346
[
318
Removed:
tag "thead" []
347
Added:
tag "p"
348
Added:
[ class_ "logbook-caption" ]
319
349
[
320
Removed:
tag "tr" []
321
Removed:
[
322
Removed:
tag "th"
323
Removed:
[ Dream_html.string_attr "scope" "col" ]
324
Removed:
[ txt "Date" ];
325
Removed:
tag "th"
326
Removed:
[ Dream_html.string_attr "scope" "col" ]
327
Removed:
[ txt "Workout" ];
328
Removed:
tag "th"
329
Removed:
[ Dream_html.string_attr "scope" "col" ]
330
Removed:
[ txt "Duration" ];
331
Removed:
tag "th"
332
Removed:
([ class_ "logbook-actions-heading" ]
333
Removed:
@ [ Dream_html.string_attr "scope" "col" ])
334
Removed:
[
335
Removed:
tag "span" [ class_ "sr-only" ] [ txt "Actions" ];
336
Removed:
];
337
Removed:
];
350
Added:
tag "em" [] [ txt "Italic" ];
351
Added:
txt " titles were imported.";
338
352
];
339
Removed:
tag "tbody" []
340
Removed:
(List.map
341
Removed:
(fun (entry : View_model.Logbook_entry.t) ->
342
Removed:
(* An imported workout's name is set in italics; the caption
353
Added:
]
354
Added:
else [])
355
Added:
@ [
356
Added:
tag "table"
357
Added:
[ class_ "logbook-table" ]
358
Added:
[
359
Added:
tag "thead" []
360
Added:
[
361
Added:
tag "tr" []
362
Added:
[
363
Added:
tag "th"
364
Added:
[ Dream_html.string_attr "scope" "col" ]
365
Added:
[ txt "Date" ];
366
Added:
tag "th"
367
Added:
[ Dream_html.string_attr "scope" "col" ]
368
Added:
[ txt "Workout" ];
369
Added:
tag "th"
370
Added:
[ Dream_html.string_attr "scope" "col" ]
371
Added:
[ txt "Duration" ];
372
Added:
tag "th"
373
Added:
([ class_ "logbook-actions-heading" ]
374
Added:
@ [ Dream_html.string_attr "scope" "col" ])
375
Added:
[
376
Added:
tag "span"
377
Added:
[ class_ "sr-only" ]
378
Added:
[ txt "Actions" ];
379
Added:
];
380
Added:
];
381
Added:
];
382
Added:
tag "tbody" []
383
Added:
(List.map
384
Added:
(fun (entry : View_model.Logbook_entry.t) ->
385
Added:
(* An imported workout's name is set in italics; the caption
343
386
explains that. The three-dot menu carries the colour-coded
344
387
per-exercise progress, plus Edit/Delete for a native
345
388
record. *)
346
Removed:
let name_cell =
347
Removed:
if entry.imported then
348
Removed:
tag "td" []
349
Removed:
[
350
Removed:
tag "em"
351
Removed:
[ class_ "logbook-imported-title" ]
352
Removed:
[ txt "%s" entry.workout_name ];
353
Removed:
]
354
Removed:
else tag "td" [] [ txt "%s" entry.workout_name ]
355
Removed:
in
356
Removed:
let menu =
357
Removed:
if entry.imported then imported_menu entry
358
Removed:
else native_menu request entry
359
Removed:
in
360
Removed:
tag "tr" []
361
Removed:
[
362
Removed:
tag "td" [] [ txt "%s" entry.date ];
363
Removed:
name_cell;
364
Removed:
tag "td"
365
Removed:
[ class_ "logbook-duration" ]
366
Removed:
[ txt "%s" entry.duration ];
367
Removed:
tag "td" [ class_ "logbook-actions" ] [ menu ];
368
Removed:
])
369
Removed:
records);
370
Removed:
];
371
Removed:
]));
372
Removed:
tag "section"
373
Removed:
[ class_ "feedback-section" ]
374
Removed:
([
375
Removed:
tag "h2" [] [ txt "How are you feeling?" ];
376
Removed:
(if suggest_feedback then
377
Removed:
tag "p"
378
Removed:
[ class_ "eyebrow" ]
379
Removed:
[ txt "Workout saved — add feedback while it is fresh." ]
380
Removed:
else txt "");
381
Removed:
tag "p" []
382
Removed:
[
383
Removed:
txt
384
Removed:
"Rate any factor against your usual. Leave the rest \
385
Removed:
unselected.";
386
Removed:
];
387
Removed:
tag "a"
388
Removed:
[
389
Removed:
class_ "feedback-toggle";
390
Removed:
Dream_html.string_attr "href" "/logbook?feedback=start";
391
Removed:
Dream_html.attr "data-hito-feedback-open";
392
Removed:
]
393
Removed:
[ txt "Record feedback" ];
394
Removed:
feedback_modal request ~open_:feedback_open;
395
Removed:
]
396
Removed:
@ feedback_list feedback
397
Removed:
@
398
Removed:
match delete_record with
399
Removed:
| Some record -> [ delete_record_dialog request record ]
400
Removed:
| None -> []);
401
Removed:
]
389
Added:
let name_cell =
390
Added:
if entry.imported then
391
Added:
tag "td" []
392
Added:
[
393
Added:
tag "em"
394
Added:
[ class_ "logbook-imported-title" ]
395
Added:
[ txt "%s" entry.workout_name ];
396
Added:
]
397
Added:
else tag "td" [] [ txt "%s" entry.workout_name ]
398
Added:
in
399
Added:
let menu =
400
Added:
if entry.imported then imported_menu entry
401
Added:
else native_menu request entry
402
Added:
in
403
Added:
tag "tr" []
404
Added:
[
405
Added:
tag "td" [] [ txt "%s" entry.date ];
406
Added:
name_cell;
407
Added:
tag "td"
408
Added:
[ class_ "logbook-duration" ]
409
Added:
[ txt "%s" entry.duration ];
410
Added:
tag "td" [ class_ "logbook-actions" ] [ menu ];
411
Added:
])
412
Added:
records);
413
Added:
];
414
Added:
]));
415
Added:
tag "section"
416
Added:
[ class_ "feedback-section" ]
417
Added:
([
418
Added:
tag "h2" [] [ txt "How are you feeling?" ];
419
Added:
(if suggest_feedback then
420
Added:
tag "p"
421
Added:
[ class_ "eyebrow" ]
422
Added:
[ txt "Workout saved — add feedback while it is fresh." ]
423
Added:
else txt "");
424
Added:
tag "p" []
425
Added:
[
426
Added:
txt
427
Added:
"Rate any factor against your usual. Leave the rest \
428
Added:
unselected.";
429
Added:
];
430
Added:
tag "a"
431
Added:
[
432
Added:
class_ "feedback-toggle";
433
Added:
Dream_html.string_attr "href" "/logbook?feedback=start";
434
Added:
Dream_html.attr "data-hito-feedback-open";
435
Added:
]
436
Added:
[ txt "Record feedback" ];
437
Added:
feedback_modal request ~open_:feedback_open;
438
Added:
]
439
Added:
@ feedback_list feedback
440
Added:
@
441
Added:
match delete_record with
442
Added:
| Some record -> [ delete_record_dialog request record ]
443
Added:
| None -> []);
444
Added:
])
lib/presenter/view_model.ml
@@ -181,6 +181,25 @@
181
181
no Evidence.Workout entity. *)
182
182
end
183
183
184
Added:
module Calendar = struct
185
Added:
type day = { day_of_month : int; workout : bool; today : bool }
186
Added:
(** One dated cell. [workout] highlights a day a workout was performed. *)
187
Added:
188
Added:
type cell =
189
Added:
| Blank
190
Added:
| Day of day
191
Added:
(** [Blank] pads the leading and trailing days of the grid that fall
192
Added:
outside the month. *)
193
Added:
194
Added:
type t = {
195
Added:
month_label : string; (** "September 2026", already formatted. *)
196
Added:
weekday_headings : string list; (** Seven short labels, Monday first. *)
197
Added:
weeks : cell list list; (** Rows of seven cells, Monday first. *)
198
Added:
}
199
Added:
(** A single month laid out as a week grid, shown above the logbook. The
200
Added:
handler does the date arithmetic; the presenter only renders the grid. *)
201
Added:
end
202
Added:
184
203
module Progress_page = struct
185
204
type point = {
186
205
date : string; (** Pre-formatted "YYYY-MM-DD" in UTC. *)
lib/web/assets/hito.css
@@ -737,6 +737,57 @@
737
737
/* The action bar under the logbook heading. */
738
738
.logbook-actions-bar { margin: 0.5rem 0 1rem; }
739
739
740
Added:
/* The month calendar above the logbook. A fixed seven-column grid; days with a
741
Added:
workout are filled oxblood, today is ringed. */
742
Added:
.calendar {
743
Added:
width: 100%;
744
Added:
max-width: 22rem;
745
Added:
margin: 0 auto 1.5rem;
746
Added:
border-collapse: collapse;
747
Added:
table-layout: fixed;
748
Added:
}
749
Added:
.calendar-caption {
750
Added:
caption-side: top;
751
Added:
margin-bottom: 0.5rem;
752
Added:
color: var(--ink);
753
Added:
font: 700 var(--font-size-lead)/1.2 var(--sans);
754
Added:
text-align: left;
755
Added:
}
756
Added:
.calendar th {
757
Added:
padding: 0.25rem 0;
758
Added:
color: var(--muted-ink);
759
Added:
font: 700 var(--font-size-small)/1 var(--sans);
760
Added:
text-align: center;
761
Added:
}
762
Added:
.calendar td {
763
Added:
padding: 0.15rem;
764
Added:
text-align: center;
765
Added:
vertical-align: middle;
766
Added:
}
767
Added:
.calendar-day,
768
Added:
.calendar-blank {
769
Added:
height: 2.25rem;
770
Added:
line-height: 2.25rem;
771
Added:
}
772
Added:
.calendar-day {
773
Added:
font-family: var(--mono);
774
Added:
font-size: var(--font-size-small);
775
Added:
color: var(--ink);
776
Added:
}
777
Added:
/* A day a workout was performed: filled in the primary colour. */
778
Added:
.calendar-workout {
779
Added:
color: var(--on-primary);
780
Added:
background: var(--oxblood);
781
Added:
border-radius: var(--radius);
782
Added:
font-weight: 700;
783
Added:
}
784
Added:
/* Today: a quiet ring, so it reads even on a plain or a highlighted day. */
785
Added:
.calendar-today {
786
Added:
outline: 2px solid var(--brass);
787
Added:
outline-offset: -2px;
788
Added:
border-radius: var(--radius);
789
Added:
}
790
Added:
740
791
/* The progress page: one dual-axis line chart per chartable exercise. Each
741
792
block binds its heading, legend, and chart into one group with a clear gap
742
793
to the next. */
lib/web/handlers_logbook.ml
@@ -37,6 +37,99 @@
37
37
Printf.sprintf "%04d-%02d-%02d" (tm.Unix.tm_year + 1900)
38
38
(tm.Unix.tm_mon + 1) tm.Unix.tm_mday
39
39
40
Added:
(* {1 Calendar} *)
41
Added:
42
Added:
let month_name = function
43
Added:
| 1 -> "January"
44
Added:
| 2 -> "February"
45
Added:
| 3 -> "March"
46
Added:
| 4 -> "April"
47
Added:
| 5 -> "May"
48
Added:
| 6 -> "June"
49
Added:
| 7 -> "July"
50
Added:
| 8 -> "August"
51
Added:
| 9 -> "September"
52
Added:
| 10 -> "October"
53
Added:
| 11 -> "November"
54
Added:
| 12 -> "December"
55
Added:
| _ -> "?"
56
Added:
57
Added:
let is_leap y = (y mod 4 = 0 && y mod 100 <> 0) || y mod 400 = 0
58
Added:
59
Added:
let days_in_month ~year ~month =
60
Added:
match month with
61
Added:
| 1 | 3 | 5 | 7 | 8 | 10 | 12 -> 31
62
Added:
| 4 | 6 | 9 | 11 -> 30
63
Added:
| 2 -> if is_leap year then 29 else 28
64
Added:
| _ -> 30
65
Added:
66
Added:
(* The weekday of a given UTC date, 0 = Monday .. 6 = Sunday. Uses Howard
67
Added:
Hinnant's day-count from the epoch, so it needs no timezone-aware libc call
68
Added:
([timegm] is not in the stdlib). *)
69
Added:
let monday_first_weekday ~year ~month ~day =
70
Added:
let y = if month <= 2 then year - 1 else year in
71
Added:
let era = (if y >= 0 then y else y - 399) / 400 in
72
Added:
let yoe = y - (era * 400) in
73
Added:
let doy =
74
Added:
(((153 * if month > 2 then month - 3 else month + 9) + 2) / 5) + day - 1
75
Added:
in
76
Added:
let doe = (yoe * 365) + (yoe / 4) - (yoe / 100) + doy in
77
Added:
let days = (era * 146097) + doe - 719468 in
78
Added:
(* 1970-01-01 is a Thursday = 3 in Monday-first indexing. *)
79
Added:
((((days mod 7) + 3) mod 7) + 7) mod 7
80
Added:
81
Added:
(* Build the current month's calendar, highlighting the days that carry at
82
Added:
least one workout. [now] and each entry are read in UTC, matching how dates
83
Added:
are shown elsewhere. *)
84
Added:
let calendar_view ~now (entries : View_model.Logbook_entry.t list) :
85
Added:
View_model.Calendar.t =
86
Added:
let now_tm = Unix.gmtime (float_of_int now) in
87
Added:
let year = now_tm.Unix.tm_year + 1900 in
88
Added:
let month = now_tm.Unix.tm_mon + 1 in
89
Added:
let today = now_tm.Unix.tm_mday in
90
Added:
let workout_days =
91
Added:
List.filter_map
92
Added:
(fun (e : View_model.Logbook_entry.t) ->
93
Added:
let tm = Unix.gmtime (float_of_int e.at_unix) in
94
Added:
if tm.Unix.tm_year + 1900 = year && tm.Unix.tm_mon + 1 = month then
95
Added:
Some tm.Unix.tm_mday
96
Added:
else None)
97
Added:
entries
98
Added:
in
99
Added:
let has_workout d = List.mem d workout_days in
100
Added:
let total = days_in_month ~year ~month in
101
Added:
let lead = monday_first_weekday ~year ~month ~day:1 in
102
Added:
(* The full sequence of cells: leading blanks, the days, trailing blanks to
103
Added:
complete the final week. *)
104
Added:
let cells =
105
Added:
List.init lead (fun _ -> View_model.Calendar.Blank)
106
Added:
@ List.init total (fun i ->
107
Added:
let d = i + 1 in
108
Added:
View_model.Calendar.Day
109
Added:
{ day_of_month = d; workout = has_workout d; today = d = today })
110
Added:
in
111
Added:
let trailing = (7 - (List.length cells mod 7)) mod 7 in
112
Added:
let cells =
113
Added:
cells @ List.init trailing (fun _ -> View_model.Calendar.Blank)
114
Added:
in
115
Added:
let rec weeks = function
116
Added:
| [] -> []
117
Added:
| cs ->
118
Added:
let rec take n = function
119
Added:
| x :: tl when n > 0 ->
120
Added:
let hd, rest = take (n - 1) tl in
121
Added:
(x :: hd, rest)
122
Added:
| rest -> ([], rest)
123
Added:
in
124
Added:
let row, rest = take 7 cs in
125
Added:
row :: weeks rest
126
Added:
in
127
Added:
{
128
Added:
month_label = Printf.sprintf "%s %d" (month_name month) year;
129
Added:
weekday_headings = [ "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"; "Sun" ];
130
Added:
weeks = weeks cells;
131
Added:
}
132
Added:
40
133
(* One exercise's outcome versus its prior effort: load leads, then reps,
41
134
matching the Heavy Duty progress rule. Progress is an increase, regress a
42
135
decrease, stagnation a flat repeat. *)
@@ -217,10 +310,13 @@
217
310
| Some "start", _ | _, Some "feedback" -> true
218
311
| _ -> false
219
312
in
313
Added:
let calendar =
314
Added:
calendar_view ~now:(Recovery.timestamp_to_unix_seconds (t.now ())) records
315
Added:
in
220
316
html
221
317
(Pages.logbook request
222
318
~logging:(Option.is_some in_progress)
223
Removed:
~viewer ~feedback
319
Added:
~viewer ~feedback ~calendar
224
320
~suggest_feedback:
225
321
(match Dream.query request "prompt" with
226
322
| Some "feedback" -> true
test/web/logbook.ml
@@ -739,5 +739,28 @@
739
739
(Option.is_some
740
740
(index_from ~needle:"No exercise has enough history" page 0))
741
741
);
742
Added:
( "the logbook shows a month calendar highlighting the workout day",
743
Added:
`Quick,
744
Added:
fun () ->
745
Added:
(* Drive the clock to a fixed day so the current-month calendar is
746
Added:
deterministic: day 10 from the epoch is 1970-01-11. A finished
747
Added:
workout that day must appear highlighted. *)
748
Added:
let c, now, _repo = clocked_client () in
749
Added:
now := day 10;
750
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
751
Added:
let _ = start_day_one c in
752
Added:
record_all_day_one_slots c;
753
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
754
Added:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
755
Added:
let page = body (get c "/logbook") in
756
Added:
Alcotest.(check bool)
757
Added:
"the calendar is present" true
758
Added:
(Option.is_some (index_from ~needle:"class=\"calendar\"" page 0));
759
Added:
Alcotest.(check bool)
760
Added:
"the calendar names the current month" true
761
Added:
(Option.is_some (index_from ~needle:"January 1970" page 0));
762
Added:
Alcotest.(check bool)
763
Added:
"a workout day is highlighted" true
764
Added:
(Option.is_some (index_from ~needle:"calendar-workout" page 0)) );
742
765
] );
743
766
]