[OCaml] High Intensity Training Online
refactor Move the startup seed out of the composition root
main.ml carried about 150 lines of fixture data and seeding logic beside the wiring. The composition root should be glue: read the environment, build the adapters, apply the functors, run the server. Move the seed to bin/seed.ml with the Service instance only it needs. The fixture is unchanged. It stays in bin rather than becoming a library: it names a concrete adapter, has no second consumer, and is temporary until public registration returns.
Changed files
bin/dune
@@ -1,4 +1,5 @@
1
1
(executable
2
2
(public_name hito)
3
3
(name main)
4
Added:
(modules main seed)
4
5
(libraries hito.web hito.app hito.persistence dream lwt caqti))
bin/main.ml
@@ -29,158 +29,9 @@
29
29
(Hito_persistence.Sqlite_repo)
30
30
(Hito_persistence.Bcrypt_hash)
31
31
32
Removed:
module Service =
33
Removed:
Hito_app.Service.Make
34
Removed:
(Hito_persistence.Sqlite_repo)
35
Removed:
(Hito_persistence.Bcrypt_hash)
36
Removed:
37
32
let getenv name default =
38
33
match Sys.getenv_opt name with Some v when v <> "" -> v | _ -> default
39
34
40
Removed:
(* Seed two full rotations of the Ideal Routine as workout history, so the
41
Removed:
logbook and progression view have meaningful data from the start. Idempotent:
42
Removed:
skipped when the trainee already has history. Each rotation uses slightly
43
Removed:
higher loads so progression is visible. Workouts are spaced by HD1's
44
Removed:
recovery intervals: 48h between days, 72h after the final day. *)
45
Removed:
let seed_workout_history repo trainee_id =
46
Removed:
Hito_persistence.Sqlite_repo.history repo trainee_id >|= List.length
47
Removed:
>>= fun count ->
48
Removed:
if count > 0 then Lwt.return_unit
49
Removed:
else
50
Removed:
let routine = Prescription.Routine.ideal in
51
Removed:
let workouts = Prescription.Routine.workouts routine in
52
Removed:
let clearance = Recovery.override Recovery.Ready in
53
Removed:
let get id =
54
Removed:
match Exercise.find_id id with Some e -> e | None -> failwith id
55
Removed:
in
56
Removed:
let effort ?(outcome = Evidence.Stimulus.Positive_failure) id load reps =
57
Removed:
Evidence.Stimulus.Effort.make ~exercise:(get id) ~load ~reps ~outcome
58
Removed:
in
59
Removed:
let single id load reps =
60
Removed:
Evidence.Stimulus.make (Evidence.Stimulus.Single (effort id load reps))
61
Removed:
in
62
Removed:
let pair iso_id iso_load iso_reps comp_id comp_load comp_reps =
63
Removed:
Evidence.Stimulus.make
64
Removed:
(Evidence.Stimulus.Pair
65
Removed:
{
66
Removed:
first = effort iso_id iso_load iso_reps;
67
Removed:
second = effort comp_id comp_load comp_reps;
68
Removed:
})
69
Removed:
in
70
Removed:
(* Two rotations of Day 1, 2, 3. The second rotation's loads are 5-10%
71
Removed:
higher so the progression judge counts exercises that beat their prior. *)
72
Removed:
let rotation_stimuli =
73
Removed:
[|
74
Removed:
(* Rotation 1 *)
75
Removed:
[
76
Removed:
(* Day 1 *)
77
Removed:
[
78
Removed:
pair "dumbbell-flyes" 18. 8 "incline-press" 55. 7;
79
Removed:
single "laterals" 10. 8;
80
Removed:
single "bent-over-laterals" 8. 9;
81
Removed:
pair "lying-french-press" 25. 8 "dips" 0. 7;
82
Removed:
];
83
Removed:
(* Day 2 *)
84
Removed:
[
85
Removed:
pair "pullovers" 20. 8 "close-grip-pulldowns" 50. 7;
86
Removed:
single "bent-over-rows" 50. 8;
87
Removed:
single "shrugs" 40. 10;
88
Removed:
single "hyperextensions" 0. 10;
89
Removed:
single "curls" 30. 8;
90
Removed:
];
91
Removed:
(* Day 3 *)
92
Removed:
[
93
Removed:
pair "leg-extensions" 40. 9 "leg-presses" 100. 8;
94
Removed:
single "leg-curls" 30. 9;
95
Removed:
single "calf-raises" 50. 12;
96
Removed:
single "sit-ups" 0. 15;
97
Removed:
];
98
Removed:
];
99
Removed:
(* Rotation 2: higher loads or reps so progress is visible *)
100
Removed:
[
101
Removed:
[
102
Removed:
pair "dumbbell-flyes" 20. 9 "incline-press" 60. 7;
103
Removed:
single "laterals" 12. 8;
104
Removed:
single "bent-over-laterals" 10. 9;
105
Removed:
pair "lying-french-press" 28. 8 "dips" 0. 8;
106
Removed:
];
107
Removed:
[
108
Removed:
pair "pullovers" 22. 8 "close-grip-pulldowns" 55. 7;
109
Removed:
single "bent-over-rows" 55. 8;
110
Removed:
single "shrugs" 45. 10;
111
Removed:
single "hyperextensions" 0. 12;
112
Removed:
single "curls" 32. 9;
113
Removed:
];
114
Removed:
[
115
Removed:
pair "leg-extensions" 45. 9 "leg-presses" 110. 8;
116
Removed:
single "leg-curls" 32. 10;
117
Removed:
single "calf-raises" 55. 12;
118
Removed:
single "sit-ups" 0. 18;
119
Removed:
];
120
Removed:
];
121
Removed:
|]
122
Removed:
in
123
Removed:
(* Space workouts: 48h between days, 72h after the last day of a rotation.
124
Removed:
Start the first workout 14 days ago so the seed feels recent. Precompute
125
Removed:
each workout's start time, then persist the sequence in Lwt — the seeder
126
Removed:
already runs under Lwt_main.run, so it must not nest another. *)
127
Removed:
let last_day = List.length workouts - 1 in
128
Removed:
let base = int_of_float (Unix.gettimeofday ()) - (14 * 86_400) in
129
Removed:
let planned, _ =
130
Removed:
Array.to_list rotation_stimuli
131
Removed:
|> List.concat_map (fun rotation ->
132
Removed:
List.mapi (fun day_idx stimuli -> (day_idx, stimuli)) rotation)
133
Removed:
|> List.fold_left
134
Removed:
(fun (acc, time) (day_idx, stimuli) ->
135
Removed:
let rest =
136
Removed:
if day_idx = last_day then
137
Removed:
Recovery.duration_to_seconds Prescription.Routine.cycle_rest
138
Removed:
else
139
Removed:
Recovery.duration_to_seconds
140
Removed:
Prescription.Routine.training_interval
141
Removed:
in
142
Removed:
(acc @ [ (day_idx, stimuli, time) ], time + 2400 + rest))
143
Removed:
([], base)
144
Removed:
in
145
Removed:
Lwt_list.iter_s
146
Removed:
(fun (day_idx, stimuli, time) ->
147
Removed:
let prescription = List.nth workouts day_idx in
148
Removed:
let started_at = Recovery.timestamp_of_unix_seconds time in
149
Removed:
let workout =
150
Removed:
Evidence.Workout.start prescription ~clearance ~started_at
151
Removed:
in
152
Removed:
let workout =
153
Removed:
List.fold_left Evidence.Workout.add_stimulus workout stimuli
154
Removed:
in
155
Removed:
let ended_at = Recovery.timestamp_of_unix_seconds (time + 2400) in
156
Removed:
let workout = Evidence.Workout.finish workout ~ended_at in
157
Removed:
Hito_persistence.Sqlite_repo.finish_workout repo trainee_id workout
158
Removed:
>|= ignore)
159
Removed:
planned
160
Removed:
161
Removed:
let seed_single_user repo ~password =
162
Removed:
let service = Service.make ~repo in
163
Removed:
Service.register service ~username:"blendux" ~password >>= function
164
Removed:
| Ok trainee ->
165
Removed:
Hito_persistence.Sqlite_repo.set_active_routine repo
166
Removed:
trainee.Hito_app.Trainee.id
167
Removed:
(Hito_app.Repository.routine_id "ideal")
168
Removed:
>>= fun () -> seed_workout_history repo trainee.Hito_app.Trainee.id
169
Removed:
| Error `Username_taken -> (
170
Removed:
match Hito_app.Trainee.username "blendux" with
171
Removed:
| Error _ -> Lwt.return_unit
172
Removed:
| Ok username -> (
173
Removed:
Hito_persistence.Sqlite_repo.find_trainee_by_username repo username
174
Removed:
>>= fun trainee_opt ->
175
Removed:
match trainee_opt with
176
Removed:
| None -> Lwt.return_unit
177
Removed:
| Some trainee ->
178
Removed:
seed_workout_history repo trainee.Hito_app.Trainee.id))
179
Removed:
| Error (`Username e) ->
180
Removed:
Format.eprintf "hito: cannot seed user: %a@."
181
Removed:
Hito_app.Trainee.pp_username_error e;
182
Removed:
exit 1
183
Removed:
184
35
let clf_month = function
185
36
| 1 -> "Jan"
186
37
| 2 -> "Feb"
@@ -247,7 +98,7 @@
247
98
248
99
exit 1
249
100
in
250
Removed:
Lwt_main.run (seed_single_user repo ~password:seed_password);
101
Added:
Lwt_main.run (Seed.single_user repo ~password:seed_password);
251
102
let handlers = Handlers.make ~repo () in
252
103
Dream.run ~interface:"localhost" ~port
253
104
~error_handler:Handlers.error_handler
bin/seed.ml
@@ -0,0 +1,146 @@
1
Added:
open Lwt.Infix
2
Added:
module Repo = Hito_persistence.Sqlite_repo
3
Added:
4
Added:
module Service =
5
Added:
Hito_app.Service.Make
6
Added:
(Hito_persistence.Sqlite_repo)
7
Added:
(Hito_persistence.Bcrypt_hash)
8
Added:
9
Added:
(* Seed two full rotations of the Ideal Routine as workout history, so the
10
Added:
logbook and progress view have meaningful data from the start. Idempotent:
11
Added:
skipped when the trainee already has history. Each rotation uses slightly
12
Added:
higher loads so progress is visible. Workouts are spaced by HD1's recovery
13
Added:
intervals: 48h between days, 72h after the final day. *)
14
Added:
let workout_history repo trainee_id =
15
Added:
Repo.history repo trainee_id >|= List.length >>= fun count ->
16
Added:
if count > 0 then Lwt.return_unit
17
Added:
else
18
Added:
let routine = Prescription.Routine.ideal in
19
Added:
let workouts = Prescription.Routine.workouts routine in
20
Added:
let clearance = Recovery.override Recovery.Ready in
21
Added:
let get id =
22
Added:
match Exercise.find_id id with Some e -> e | None -> failwith id
23
Added:
in
24
Added:
let effort ?(outcome = Evidence.Stimulus.Positive_failure) id load reps =
25
Added:
Evidence.Stimulus.Effort.make ~exercise:(get id) ~load ~reps ~outcome
26
Added:
in
27
Added:
let single id load reps =
28
Added:
Evidence.Stimulus.make (Evidence.Stimulus.Single (effort id load reps))
29
Added:
in
30
Added:
let pair iso_id iso_load iso_reps comp_id comp_load comp_reps =
31
Added:
Evidence.Stimulus.make
32
Added:
(Evidence.Stimulus.Pair
33
Added:
{
34
Added:
first = effort iso_id iso_load iso_reps;
35
Added:
second = effort comp_id comp_load comp_reps;
36
Added:
})
37
Added:
in
38
Added:
(* Two rotations of Day 1, 2, 3. The second rotation's loads are 5-10%
39
Added:
higher so the progress judge counts exercises that beat their prior. *)
40
Added:
let rotation_stimuli =
41
Added:
[|
42
Added:
(* Rotation 1 *)
43
Added:
[
44
Added:
(* Day 1 *)
45
Added:
[
46
Added:
pair "dumbbell-flyes" 18. 8 "incline-press" 55. 7;
47
Added:
single "laterals" 10. 8;
48
Added:
single "bent-over-laterals" 8. 9;
49
Added:
pair "lying-french-press" 25. 8 "dips" 0. 7;
50
Added:
];
51
Added:
(* Day 2 *)
52
Added:
[
53
Added:
pair "pullovers" 20. 8 "close-grip-pulldowns" 50. 7;
54
Added:
single "bent-over-rows" 50. 8;
55
Added:
single "shrugs" 40. 10;
56
Added:
single "hyperextensions" 0. 10;
57
Added:
single "curls" 30. 8;
58
Added:
];
59
Added:
(* Day 3 *)
60
Added:
[
61
Added:
pair "leg-extensions" 40. 9 "leg-presses" 100. 8;
62
Added:
single "leg-curls" 30. 9;
63
Added:
single "calf-raises" 50. 12;
64
Added:
single "sit-ups" 0. 15;
65
Added:
];
66
Added:
];
67
Added:
(* Rotation 2: higher loads or reps so progress is visible *)
68
Added:
[
69
Added:
[
70
Added:
pair "dumbbell-flyes" 20. 9 "incline-press" 60. 7;
71
Added:
single "laterals" 12. 8;
72
Added:
single "bent-over-laterals" 10. 9;
73
Added:
pair "lying-french-press" 28. 8 "dips" 0. 8;
74
Added:
];
75
Added:
[
76
Added:
pair "pullovers" 22. 8 "close-grip-pulldowns" 55. 7;
77
Added:
single "bent-over-rows" 55. 8;
78
Added:
single "shrugs" 45. 10;
79
Added:
single "hyperextensions" 0. 12;
80
Added:
single "curls" 32. 9;
81
Added:
];
82
Added:
[
83
Added:
pair "leg-extensions" 45. 9 "leg-presses" 110. 8;
84
Added:
single "leg-curls" 32. 10;
85
Added:
single "calf-raises" 55. 12;
86
Added:
single "sit-ups" 0. 18;
87
Added:
];
88
Added:
];
89
Added:
|]
90
Added:
in
91
Added:
(* Space workouts: 48h between days, 72h after the last day of a rotation.
92
Added:
Start the first workout 14 days ago so the seed feels recent. Precompute
93
Added:
each workout's start time, then persist the sequence in Lwt — the seeder
94
Added:
already runs under Lwt_main.run, so it must not nest another. *)
95
Added:
let last_day = List.length workouts - 1 in
96
Added:
let base = int_of_float (Unix.gettimeofday ()) - (14 * 86_400) in
97
Added:
let planned, _ =
98
Added:
Array.to_list rotation_stimuli
99
Added:
|> List.concat_map (fun rotation ->
100
Added:
List.mapi (fun day_idx stimuli -> (day_idx, stimuli)) rotation)
101
Added:
|> List.fold_left
102
Added:
(fun (acc, time) (day_idx, stimuli) ->
103
Added:
let rest =
104
Added:
if day_idx = last_day then
105
Added:
Recovery.duration_to_seconds Prescription.Routine.cycle_rest
106
Added:
else
107
Added:
Recovery.duration_to_seconds
108
Added:
Prescription.Routine.training_interval
109
Added:
in
110
Added:
(acc @ [ (day_idx, stimuli, time) ], time + 2400 + rest))
111
Added:
([], base)
112
Added:
in
113
Added:
Lwt_list.iter_s
114
Added:
(fun (day_idx, stimuli, time) ->
115
Added:
let prescription = List.nth workouts day_idx in
116
Added:
let started_at = Recovery.timestamp_of_unix_seconds time in
117
Added:
let workout =
118
Added:
Evidence.Workout.start prescription ~clearance ~started_at
119
Added:
in
120
Added:
let workout =
121
Added:
List.fold_left Evidence.Workout.add_stimulus workout stimuli
122
Added:
in
123
Added:
let ended_at = Recovery.timestamp_of_unix_seconds (time + 2400) in
124
Added:
let workout = Evidence.Workout.finish workout ~ended_at in
125
Added:
Repo.finish_workout repo trainee_id workout >|= ignore)
126
Added:
planned
127
Added:
128
Added:
let single_user repo ~password =
129
Added:
let service = Service.make ~repo in
130
Added:
Service.register service ~username:"blendux" ~password >>= function
131
Added:
| Ok trainee ->
132
Added:
Repo.set_active_routine repo trainee.Hito_app.Trainee.id
133
Added:
(Hito_app.Repository.routine_id "ideal")
134
Added:
>>= fun () -> workout_history repo trainee.Hito_app.Trainee.id
135
Added:
| Error `Username_taken -> (
136
Added:
match Hito_app.Trainee.username "blendux" with
137
Added:
| Error _ -> Lwt.return_unit
138
Added:
| Ok username -> (
139
Added:
Repo.find_trainee_by_username repo username >>= fun trainee_opt ->
140
Added:
match trainee_opt with
141
Added:
| None -> Lwt.return_unit
142
Added:
| Some trainee -> workout_history repo trainee.Hito_app.Trainee.id))
143
Added:
| Error (`Username e) ->
144
Added:
Format.eprintf "hito: cannot seed user: %a@."
145
Added:
Hito_app.Trainee.pp_username_error e;
146
Added:
exit 1
bin/seed.mli
@@ -0,0 +1,9 @@
1
Added:
(** Startup fixture for the single pre-seeded account. Temporary until public
2
Added:
registration returns; then this module goes with it. *)
3
Added:
4
Added:
val single_user :
5
Added:
Hito_persistence.Sqlite_repo.t -> password:string -> unit Lwt.t
6
Added:
(** Register [blendux] with [password] and select the Ideal Routine, or reuse
7
Added:
the existing account. Then seed two rotations of the routine as workout
8
Added:
history when the account has none. Exits the process on a malformed seed
9
Added:
username. *)