[OCaml] High Intensity Training Online
feat seed blendux's Hevy history; server config
Seed the [blendux] account's real Hevy export as personal history through the Workout_import use case rather than fabricating it. The seed parses the CSV, maps each exercise the curated catalog names, acknowledges normal sets, and promotes the batch, once, when the account has no promoted records. Off-catalog exercises and cardio stay out by doctrine; drop sets are discarded. Path comes from HITO_SEED_CSV (default workout_data.csv), which is the trainee's own export and is not committed. Server config, entangled in the same composition root: - Default HITO_DB moves to sqlite3:local_db/hito.sqlite. local_db/ is excluded from the dune build and watch tree, so the database and its journal never retrigger dune -w. - Replace the hand-rolled CLF middleware with Dream.logger: one sink, one format, shared log levels, and request timing for free. - Link hito.import into the executable for the seed.
Changed files
bin/dune
@@ -2,4 +2,4 @@
2
2
(public_name hito)
3
3
(name main)
4
4
(modules main seed)
5
Removed:
(libraries hito.web hito.app hito.persistence dream lwt caqti))
5
Added:
(libraries hito.web hito.app hito.persistence hito.import dream lwt caqti))
bin/main.ml
@@ -1,11 +1,11 @@
1
Removed:
open Lwt.Infix
2
Removed:
3
1
(* The production server. State is durable: trainees, their active routine,
4
2
the workout in progress, and history all live in SQLite. There is no
5
3
server-wide in-memory state.
6
4
7
5
Configuration comes from the environment:
8
Removed:
- HITO_DB Caqti database URI. Default: sqlite3:hito.sqlite
6
Added:
- HITO_DB Caqti database URI. Default: sqlite3:local_db/hito.sqlite.
7
Added:
[local_db/] is excluded from the dune build and watch tree, so
8
Added:
the database and its journal never retrigger [dune -w].
9
9
- HITO_SECRET Secret for signing session cookies and CSRF tokens. When
10
10
unset, a random secret is generated for this run only, so
11
11
sessions do not survive a restart. Set it in production.
@@ -15,6 +15,9 @@
15
15
- HITO_SEED_PASSWORD Password for the seeded [blendux] account. Required.
16
16
The server refuses to start when unset. Temporary, until
17
17
public registration returns.
18
Added:
- HITO_SEED_CSV Path to the Hevy export imported as the seeded account's
19
Added:
history. Default: workout_data.csv. Imported once, when the
20
Added:
account has no promoted records. Temporary, with the seed.
18
21
19
22
The socket binds loopback only. Authentication is local username and
20
23
password. Sessions and CSRF tokens are signed with the secret.
@@ -32,46 +35,8 @@
32
35
let getenv name default =
33
36
match Sys.getenv_opt name with Some v when v <> "" -> v | _ -> default
34
37
35
Removed:
let clf_month = function
36
Removed:
| 1 -> "Jan"
37
Removed:
| 2 -> "Feb"
38
Removed:
| 3 -> "Mar"
39
Removed:
| 4 -> "Apr"
40
Removed:
| 5 -> "May"
41
Removed:
| 6 -> "Jun"
42
Removed:
| 7 -> "Jul"
43
Removed:
| 8 -> "Aug"
44
Removed:
| 9 -> "Sep"
45
Removed:
| 10 -> "Oct"
46
Removed:
| 11 -> "Nov"
47
Removed:
| 12 -> "Dec"
48
Removed:
| _ -> "???"
49
Removed:
50
Removed:
let clf_escape text =
51
Removed:
String.map (function '"' -> '\'' | '\n' | '\r' | '\t' -> ' ' | c -> c) text
52
Removed:
53
Removed:
let clf_time () =
54
Removed:
let tm = Unix.gmtime (Unix.gettimeofday ()) in
55
Removed:
Printf.sprintf "%02d/%s/%04d:%02d:%02d:%02d +0000" tm.Unix.tm_mday
56
Removed:
(clf_month (tm.Unix.tm_mon + 1))
57
Removed:
(tm.Unix.tm_year + 1900) tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
58
Removed:
59
Removed:
let common_log_format inner request =
60
Removed:
inner request >|= fun response ->
61
Removed:
let bytes =
62
Removed:
Option.value (Dream.header response "Content-Length") ~default:"-"
63
Removed:
in
64
Removed:
Printf.eprintf "%s - - [%s] \"%s %s HTTP/1.1\" %d %s\n%!"
65
Removed:
(clf_escape (Dream.client request))
66
Removed:
(clf_time ())
67
Removed:
(Dream.method_to_string (Dream.method_ request))
68
Removed:
(clf_escape (Dream.target request))
69
Removed:
(Dream.status_to_int (Dream.status response))
70
Removed:
bytes;
71
Removed:
response
72
Removed:
73
38
let () =
74
Removed:
let db_uri = getenv "HITO_DB" "sqlite3:hito.sqlite" in
39
Added:
let db_uri = getenv "HITO_DB" "sqlite3:local_db/hito.sqlite" in
75
40
let port = int_of_string (getenv "HITO_PORT" "8080") in
76
41
let secret =
77
42
match Sys.getenv_opt "HITO_SECRET" with
@@ -98,10 +63,12 @@
98
63
99
64
exit 1
100
65
in
101
Removed:
Lwt_main.run (Seed.single_user repo ~password:seed_password);
66
Added:
let seed_csv = getenv "HITO_SEED_CSV" "workout_data.csv" in
67
Added:
Lwt_main.run
68
Added:
(Seed.single_user repo ~password:seed_password ~csv_path:seed_csv);
102
69
let handlers = Handlers.make ~repo () in
103
70
Dream.run ~interface:"localhost" ~port
104
71
~error_handler:Handlers.error_handler
105
Removed:
@@ common_log_format @@ Dream.set_secret secret @@ Dream.sql_pool db_uri
72
Added:
@@ Dream.logger @@ Dream.set_secret secret @@ Dream.sql_pool db_uri
106
73
@@ Dream.sql_sessions
107
74
@@ Dream.router (Handlers.routes handlers)
bin/seed.ml
@@ -1,137 +1,158 @@
1
1
open Lwt.Infix
2
2
module Repo = Hito_persistence.Sqlite_repo
3
Added:
module WI = Hito_app.Workout_import
3
4
4
5
module Service =
5
6
Hito_app.Service.Make
6
7
(Hito_persistence.Sqlite_repo)
7
8
(Hito_persistence.Bcrypt_hash)
8
9
9
Removed:
(* Seed two full rotations of the Ideal Routine as workout history, so the
10
Removed:
logbook and progress view have meaningful data from the start. Idempotent:
11
Removed:
skipped when the trainee already has history. Each rotation uses slightly
12
Removed:
higher loads so progress is visible. Workouts are spaced by HD1's recovery
13
Removed:
intervals: 48h between days, 72h after the final day. *)
14
Removed:
let workout_history repo trainee_id =
15
Removed:
Repo.history repo trainee_id >|= List.length >>= fun count ->
16
Removed:
if count > 0 then Lwt.return_unit
17
Removed:
else
18
Removed:
let routine = Routines.ideal in
19
Removed:
let workouts = Prescription.Routine.workouts routine in
20
Removed:
let clearance = Recovery.override Recovery.Ready in
21
Removed:
let get id =
22
Removed:
match Exercise.find_id id with Some e -> e | None -> failwith id
23
Removed:
in
24
Removed:
let effort ?(outcome = Evidence.Stimulus.Positive_failure) id load reps =
25
Removed:
Evidence.Stimulus.Effort.make ~exercise:(get id) ~load ~reps ~outcome
26
Removed:
in
27
Removed:
let single id load reps =
28
Removed:
Evidence.Stimulus.make (Evidence.Stimulus.Single (effort id load reps))
29
Removed:
in
30
Removed:
let pair iso_id iso_load iso_reps comp_id comp_load comp_reps =
31
Removed:
Evidence.Stimulus.make
32
Removed:
(Evidence.Stimulus.Pair
33
Removed:
{
34
Removed:
first = effort iso_id iso_load iso_reps;
35
Removed:
second = effort comp_id comp_load comp_reps;
36
Removed:
})
37
Removed:
in
38
Removed:
(* Two rotations of Day 1, 2, 3. The second rotation's loads are 5-10%
39
Removed:
higher so the progress judge counts exercises that beat their prior. *)
40
Removed:
let rotation_stimuli =
41
Removed:
[|
42
Removed:
(* Rotation 1 *)
43
Removed:
[
44
Removed:
(* Day 1 *)
45
Removed:
[
46
Removed:
pair "dumbbell-flyes" 18. 8 "incline-press" 55. 7;
47
Removed:
single "laterals" 10. 8;
48
Removed:
single "bent-over-laterals" 8. 9;
49
Removed:
pair "lying-french-press" 25. 8 "dips" 0. 7;
50
Removed:
];
51
Removed:
(* Day 2 *)
52
Removed:
[
53
Removed:
pair "pullovers" 20. 8 "close-grip-pulldowns" 50. 7;
54
Removed:
single "bent-over-rows" 50. 8;
55
Removed:
single "shrugs" 40. 10;
56
Removed:
single "hyperextensions" 0. 10;
57
Removed:
single "curls" 30. 8;
58
Removed:
];
59
Removed:
(* Day 3 *)
60
Removed:
[
61
Removed:
pair "leg-extensions" 40. 9 "leg-presses" 100. 8;
62
Removed:
single "leg-curls" 30. 9;
63
Removed:
single "calf-raises" 50. 12;
64
Removed:
single "sit-ups" 0. 15;
65
Removed:
];
66
Removed:
];
67
Removed:
(* Rotation 2: higher loads or reps so progress is visible *)
68
Removed:
[
69
Removed:
[
70
Removed:
pair "dumbbell-flyes" 20. 9 "incline-press" 60. 7;
71
Removed:
single "laterals" 12. 8;
72
Removed:
single "bent-over-laterals" 10. 9;
73
Removed:
pair "lying-french-press" 28. 8 "dips" 0. 8;
74
Removed:
];
75
Removed:
[
76
Removed:
pair "pullovers" 22. 8 "close-grip-pulldowns" 55. 7;
77
Removed:
single "bent-over-rows" 55. 8;
78
Removed:
single "shrugs" 45. 10;
79
Removed:
single "hyperextensions" 0. 12;
80
Removed:
single "curls" 32. 9;
81
Removed:
];
82
Removed:
[
83
Removed:
pair "leg-extensions" 45. 9 "leg-presses" 110. 8;
84
Removed:
single "leg-curls" 32. 10;
85
Removed:
single "calf-raises" 55. 12;
86
Removed:
single "sit-ups" 0. 18;
87
Removed:
];
88
Removed:
];
89
Removed:
|]
90
Removed:
in
91
Removed:
(* Space workouts: 48h between days, 72h after the last day of a rotation.
92
Removed:
Start the first workout 14 days ago so the seed feels recent. Precompute
93
Removed:
each workout's start time, then persist the sequence in Lwt — the seeder
94
Removed:
already runs under Lwt_main.run, so it must not nest another. *)
95
Removed:
let last_day = List.length workouts - 1 in
96
Removed:
let base = int_of_float (Unix.gettimeofday ()) - (14 * 86_400) in
97
Removed:
let planned, _ =
98
Removed:
Array.to_list rotation_stimuli
99
Removed:
|> List.concat_map (fun rotation ->
100
Removed:
List.mapi (fun day_idx stimuli -> (day_idx, stimuli)) rotation)
101
Removed:
|> List.fold_left
102
Removed:
(fun (acc, time) (day_idx, stimuli) ->
103
Removed:
let rest =
104
Removed:
if day_idx = last_day then
105
Removed:
Recovery.duration_to_seconds Prescription.Routine.cycle_rest
106
Removed:
else
107
Removed:
Recovery.duration_to_seconds
108
Removed:
Prescription.Routine.training_interval
109
Removed:
in
110
Removed:
(acc @ [ (day_idx, stimuli, time) ], time + 2400 + rest))
111
Removed:
([], base)
112
Removed:
in
113
Removed:
Lwt_list.iter_s
114
Removed:
(fun (day_idx, stimuli, time) ->
115
Removed:
let prescription = List.nth workouts day_idx in
116
Removed:
let started_at = Recovery.timestamp_of_unix_seconds time in
117
Removed:
let workout =
118
Removed:
Evidence.Workout.start prescription ~clearance ~started_at
119
Removed:
in
120
Removed:
let workout =
121
Removed:
List.fold_left Evidence.Workout.add_stimulus workout stimuli
122
Removed:
in
123
Removed:
let ended_at = Recovery.timestamp_of_unix_seconds (time + 2400) in
124
Removed:
let workout = Evidence.Workout.finish workout ~ended_at in
125
Removed:
Repo.finish_workout repo trainee_id workout >|= ignore)
126
Removed:
planned
10
Added:
(* The trainee's real Hevy export, imported as personal history through the
11
Added:
Workout_import use case rather than fabricated. The use case gates what the
12
Added:
core ever sees: only a set whose source exercise maps to the curated catalog
13
Added:
promotes to canonical evidence. Warmups, cardio, and bodyweight rows without
14
Added:
a load are dropped by the parser as warnings. A drop set is discarded the way
15
Added:
a warmup is — HD1 keeps only the drive to failure, never the strip rounds —
16
Added:
so it neither promotes nor blocks. An unmapped exercise blocks only itself.
17
Added:
All of that is doctrine, not loss: HD1 favours a curated catalog over
18
Added:
novelty, and a deviation is retained, never guessed at. *)
127
19
128
Removed:
let single_user repo ~password =
20
Added:
(* Hevy datetimes are local wall time. The export was recorded at UTC+2. *)
21
Added:
let utc_offset_seconds = 7200
22
Added:
23
Added:
(* Maps a Hevy export exercise name to a curated catalog id. Only names with a
24
Added:
defensible HD1 equivalent appear here. A name absent from this table stays
25
Added:
unmapped, so its workout blocks on [Unmapped_exercise] rather than promoting
26
Added:
a guess — "focus over novelty" (HD1, "The Routine"). Trap-bar and Romanian
27
Added:
deadlifts, the machine squat, machine chest and shoulder presses, and the
28
Added:
flat barbell bench have no Standard catalog entry, so they are left unmapped
29
Added:
on purpose. *)
30
Added:
let catalog_of_source name =
31
Added:
let id =
32
Added:
match name with
33
Added:
| "Deadlift (Barbell)" -> Some "deadlifts"
34
Added:
| "Squat (Barbell)" -> Some "squats"
35
Added:
| "Leg Press (Machine)" -> Some "leg-presses"
36
Added:
| "Leg Extension (Machine)" | "Single Leg Extensions" ->
37
Added:
Some "leg-extensions"
38
Added:
| "Lateral Raise (Dumbbell)" | "Lateral Raise (Machine)" -> Some "laterals"
39
Added:
| "Bicep Curl (Barbell)" -> Some "curls"
40
Added:
| "Preacher Curl (Barbell)" -> Some "preacher-curls"
41
Added:
| "Bent Over Row (Barbell)" -> Some "bent-over-rows"
42
Added:
| "Pullover (Dumbbell)" | "Pullover (Machine)" -> Some "pullovers"
43
Added:
(* A reverse (underhand) grip pulldown is HD1's close-grip, palms-up
44
Added:
pulldown. *)
45
Added:
| "Reverse Grip Lat Pulldown (Cable)" -> Some "close-grip-pulldowns"
46
Added:
| "Triceps Pushdown" -> Some "pressdowns"
47
Added:
| "Calf Extension (Machine)" | "Seated Calf Raise"
48
Added:
| "Standing Calf Raise (Machine)" ->
49
Added:
Some "calf-raises"
50
Added:
| _ -> None
51
Added:
in
52
Added:
Option.bind id Exercise.find_id
53
Added:
54
Added:
(* The acknowledgement retained for a workout whose normal sets promote. A
55
Added:
normal set is a working set the export did not mark as taken to failure, so
56
Added:
promoting it as failure-defined evidence is a deviation. It must be possible
57
Added:
but never silent (domain.md, "Encoding rules"). *)
58
Added:
let normal_ack = "Imported from Hevy: recorded as a working set to failure."
59
Added:
60
Added:
let read_file path =
61
Added:
let ic = open_in_bin path in
62
Added:
Fun.protect
63
Added:
~finally:(fun () -> close_in ic)
64
Added:
(fun () ->
65
Added:
let n = in_channel_length ic in
66
Added:
really_input_string ic n)
67
Added:
68
Added:
(* Distinct source exercise names in a workout, in first-appearance order. *)
69
Added:
let source_names workout =
70
Added:
List.fold_left
71
Added:
(fun acc (s : WI.source_set) ->
72
Added:
if List.mem s.WI.exercise_name acc then acc else s.WI.exercise_name :: acc)
73
Added:
[] (WI.workout_sets workout)
74
Added:
|> List.rev
75
Added:
76
Added:
let has_normal_set workout =
77
Added:
List.exists
78
Added:
(fun (s : WI.source_set) -> s.WI.set_type = WI.Normal)
79
Added:
(WI.workout_sets workout)
80
Added:
81
Added:
(* Import [csv_path] for [trainee_id] as one batch: store it, map every source
82
Added:
name that has a catalog equivalent, acknowledge the normal sets of any
83
Added:
workout that has one, then promote the whole batch. Promotion is partial —
84
Added:
a blocked workout is left in the batch for later review, never forced. *)
85
Added:
let import_csv repo trainee_id ~csv_path =
86
Added:
let source = read_file csv_path in
87
Added:
let fingerprint = Digest.to_hex (Digest.string source) in
88
Added:
let imported_at =
89
Added:
Recovery.timestamp_of_unix_seconds (int_of_float (Unix.gettimeofday ()))
90
Added:
in
91
Added:
let batch_id = WI.batch_id ("hevy-" ^ String.sub fingerprint 0 12) in
92
Added:
match
93
Added:
Hito_import.Hevy_csv.parse ~batch_id ~fingerprint ~imported_at
94
Added:
~utc_offset_seconds source
95
Added:
with
96
Added:
| Error e ->
97
Added:
Format.eprintf "hito: cannot parse %s: %a@." csv_path
98
Added:
Hito_import.Hevy_csv.pp_error e;
99
Added:
exit 1
100
Added:
| Ok batch ->
101
Added:
let service = Service.make ~repo in
102
Added:
let unwrap step = function
103
Added:
| Ok v -> Lwt.return v
104
Added:
| Error _ ->
105
Added:
Format.eprintf "hito: import step %s failed@." step;
106
Added:
exit 1
107
Added:
in
108
Added:
Service.store_import_batch service trainee_id batch >>= unwrap "store"
109
Added:
>>= fun () ->
110
Added:
(* Map and confirm each workout, then promote the batch once. *)
111
Added:
Lwt_list.iter_s
112
Added:
(fun workout ->
113
Added:
let wid = WI.workout_identity workout in
114
Added:
Lwt_list.iter_s
115
Added:
(fun name ->
116
Added:
match catalog_of_source name with
117
Added:
| None -> Lwt.return_unit
118
Added:
| Some exercise ->
119
Added:
Service.map_import_exercise service trainee_id ~batch:batch_id
120
Added:
~workout:wid ~source_name:name exercise
121
Added:
>>= unwrap "map" >|= ignore)
122
Added:
(source_names workout)
123
Added:
>>= fun () ->
124
Added:
if has_normal_set workout then
125
Added:
Service.confirm_import_normal_sets service trainee_id
126
Added:
~batch:batch_id ~workout:wid ~acknowledgement:normal_ack
127
Added:
>>= unwrap "confirm" >|= ignore
128
Added:
else Lwt.return_unit)
129
Added:
(WI.batch_workouts batch)
130
Added:
>>= fun () ->
131
Added:
Service.promote_import_batch service trainee_id ~batch:batch_id
132
Added:
>>= unwrap "promote"
133
Added:
>|= fun result ->
134
Added:
Printf.eprintf
135
Added:
"hito: imported Hevy export: promoted %d, already promoted %d, blocked \
136
Added:
%d\n\
137
Added:
%!"
138
Added:
(List.length result.WI.promoted)
139
Added:
(List.length result.WI.already_promoted)
140
Added:
(List.length result.WI.blocked)
141
Added:
142
Added:
(* Idempotent: skip the import when the trainee already has promoted records. *)
143
Added:
let seed_history repo trainee_id ~csv_path =
144
Added:
Service.make ~repo |> fun service ->
145
Added:
Service.imported_records service trainee_id >>= fun records ->
146
Added:
if records <> [] then Lwt.return_unit
147
Added:
else import_csv repo trainee_id ~csv_path
148
Added:
149
Added:
let single_user repo ~password ~csv_path =
129
150
let service = Service.make ~repo in
130
151
Service.register service ~username:"blendux" ~password >>= function
131
152
| Ok trainee ->
132
153
Repo.set_active_routine repo trainee.Hito_app.Trainee.id
133
154
(Hito_app.Repository.routine_id "ideal")
134
Removed:
>>= fun () -> workout_history repo trainee.Hito_app.Trainee.id
155
Added:
>>= fun () -> seed_history repo trainee.Hito_app.Trainee.id ~csv_path
135
156
| Error `Username_taken -> (
136
157
match Hito_app.Trainee.username "blendux" with
137
158
| Error _ -> Lwt.return_unit
@@ -139,7 +160,8 @@
139
160
Repo.find_trainee_by_username repo username >>= fun trainee_opt ->
140
161
match trainee_opt with
141
162
| None -> Lwt.return_unit
142
Removed:
| Some trainee -> workout_history repo trainee.Hito_app.Trainee.id))
163
Added:
| Some trainee ->
164
Added:
seed_history repo trainee.Hito_app.Trainee.id ~csv_path))
143
165
| Error (`Username e) ->
144
166
Format.eprintf "hito: cannot seed user: %a@."
145
167
Hito_app.Trainee.pp_username_error e;
bin/seed.mli
@@ -2,8 +2,14 @@
2
2
registration returns; then this module goes with it. *)
3
3
4
4
val single_user :
5
Removed:
Hito_persistence.Sqlite_repo.t -> password:string -> unit Lwt.t
5
Added:
Hito_persistence.Sqlite_repo.t ->
6
Added:
password:string ->
7
Added:
csv_path:string ->
8
Added:
unit Lwt.t
6
9
(** Register [blendux] with [password] and select the Ideal Routine, or reuse
7
Removed:
the existing account. Then seed two rotations of the routine as workout
8
Removed:
history when the account has none. Exits the process on a malformed seed
9
Removed:
username. *)
10
Added:
the existing account. Then, when the account has no promoted import records,
11
Added:
import the Hevy export at [csv_path] as personal history: parse it, map each
12
Added:
exercise the curated catalog names, acknowledge normal sets, and promote the
13
Added:
batch. Blocked workouts — drop sets, or exercises outside the catalog — are
14
Added:
left in the batch for review, never forced. Exits the process on a malformed
15
Added:
seed username or an import failure. *)