[OCaml] High Intensity Training Online
feat Promote imports into insights and recovery
Add import storage, cleaning, duplicate override, and promotion use cases to Service. Promoted observations merge with native evidence for Progression. Promoted workout times gate recovery at the 48-hour baseline, while routine rotation remains based only on canonical hito workouts. Promotion persists one atomic record per workout and recovers idempotently after interrupted saves.
Changed files
lib/app/service.ml
@@ -33,6 +33,9 @@
33
33
type edit_error = Unknown_workout | Rejected_edit of Evidence.Workout.error
34
34
type app_feedback_error = [ `Empty_message | `Unknown_feedback ]
35
35
36
Added:
type import_error =
37
Added:
[ `Unknown_batch | `Duplicate_source | `Import of Workout_import.error ]
38
Added:
36
39
(* Shared helpers over a routine and a log, used by more than one use case. *)
37
40
38
41
let routine t id =
@@ -53,6 +56,55 @@
53
56
| Some last -> Prescription.Routine.recovery_after routine last
54
57
| None -> Prescription.Routine.training_interval
55
58
59
Added:
(* The latest finished native workout's [ended_at], if any. *)
60
Added:
let latest_native_ended log =
61
Added:
Evidence.Log.workouts log
62
Added:
|> List.filter_map Evidence.Workout.ended_at
63
Added:
|> List.fold_left
64
Added:
(fun acc ended ->
65
Added:
match acc with
66
Added:
| Some latest
67
Added:
when Recovery.timestamp_to_unix_seconds latest
68
Added:
>= Recovery.timestamp_to_unix_seconds ended ->
69
Added:
acc
70
Added:
| _ -> Some ended)
71
Added:
None
72
Added:
73
Added:
(* The latest imported record's [ended_at], if any. Imported records arrive
74
Added:
newest-[ended_at]-first, so the head carries the maximum. *)
75
Added:
let latest_imported_ended records =
76
Added:
match records with
77
Added:
| [] -> None
78
Added:
| record :: _ -> Some record.Repository.ended_at
79
Added:
80
Added:
(* Recovery gating merges native history and promoted imports. Whichever
81
Added:
finished later governs, so an imported workout gates rest exactly as a
82
Added:
native one does. A tie favours the import: it is the more recent evidence
83
Added:
the trainee entered. When the import governs, HD1's baseline 48h interval
84
Added:
applies, because a bare import carries no cycle position to compute a
85
Added:
tail rest from — the routine's [recovery_after] needs a prescription an
86
Added:
import does not have. Provenance never affects the judgment.
87
Added:
88
Added:
[recommended] is the native recommendation, already computed from the
89
Added:
routine and log by the caller. *)
90
Added:
let merged_readiness ~log ~records ~recommended ~now =
91
Added:
match (latest_native_ended log, latest_imported_ended records) with
92
Added:
| None, None -> Recovery.Ready
93
Added:
| Some _, None -> Evidence.Log.readiness log ~now ~recommended
94
Added:
| None, Some imported ->
95
Added:
Recovery.evaluate_readiness
96
Added:
~elapsed:(Recovery.elapsed ~since:imported ~now)
97
Added:
~recommended:Prescription.Routine.training_interval
98
Added:
| Some native, Some imported ->
99
Added:
if
100
Added:
Recovery.timestamp_to_unix_seconds imported
101
Added:
>= Recovery.timestamp_to_unix_seconds native
102
Added:
then
103
Added:
Recovery.evaluate_readiness
104
Added:
~elapsed:(Recovery.elapsed ~since:imported ~now)
105
Added:
~recommended:Prescription.Routine.training_interval
106
Added:
else Evidence.Log.readiness log ~now ~recommended
107
Added:
56
108
(* --- accounts --- *)
57
109
module Accounts = struct
58
110
let register t ~username ~password =
@@ -138,8 +190,9 @@
138
190
let readiness t trainee ~routine:id ~now =
139
191
let open Lwt_result.Syntax in
140
192
let* r = Lwt.return (routine t id) in
141
Removed:
let+ log = Lwt_result.ok (R.log t.repo trainee) in
142
Removed:
Evidence.Log.readiness log ~now ~recommended:(recommended r log)
193
Added:
let* log = Lwt_result.ok (R.log t.repo trainee) in
194
Added:
let+ records = Lwt_result.ok (R.imported_records t.repo trainee) in
195
Added:
merged_readiness ~log ~records ~recommended:(recommended r log) ~now
143
196
end
144
197
145
198
(* --- the workout in progress --- *)
@@ -148,8 +201,12 @@
148
201
let open Lwt_result.Syntax in
149
202
let* r = Lwt.return (routine t id) in
150
203
let* log = Lwt_result.ok (R.log t.repo trainee) in
204
Added:
let* records = Lwt_result.ok (R.imported_records t.repo trainee) in
205
Added:
(* Recovery gating merges native and imported evidence, so an import
206
Added:
gates rest. Rotation, however, advances from the native log only: an
207
Added:
import never moves the cycle forward. *)
151
208
let readiness =
152
Removed:
Evidence.Log.readiness log ~now ~recommended:(recommended r log)
209
Added:
merged_readiness ~log ~records ~recommended:(recommended r log) ~now
153
210
in
154
211
let clearance =
155
212
match (Recovery.clear readiness, override) with
@@ -241,12 +298,44 @@
241
298
242
299
(* --- what the record means --- *)
243
300
module Assessment = struct
301
Added:
(* Progression judges one exercise across all evidence, native and
302
Added:
imported alike. Provenance never changes the verdict: an observation is
303
Added:
an observation. Merge the two sources, keep only the requested exercise,
304
Added:
and order oldest-first by [performed_at] so {!Progression.assess} sees a
305
Added:
chronological series. Ties order native before imported — an arbitrary
306
Added:
but fixed rule that keeps the merge deterministic. *)
307
Added:
let merged_observations ~log ~records exercise =
308
Added:
let native =
309
Added:
Evidence.Log.observations log exercise |> List.map (fun o -> (0, o))
310
Added:
in
311
Added:
let imported =
312
Added:
List.concat_map (fun r -> r.Repository.observations) records
313
Added:
|> List.filter (fun o ->
314
Added:
Exercise.equal (Evidence.Observation.exercise o) exercise)
315
Added:
|> List.map (fun o -> (1, o))
316
Added:
in
317
Added:
let at o =
318
Added:
Recovery.timestamp_to_unix_seconds (Evidence.Observation.performed_at o)
319
Added:
in
320
Added:
native @ imported
321
Added:
|> List.stable_sort (fun (src_a, a) (src_b, b) ->
322
Added:
let by_time = Int.compare (at a) (at b) in
323
Added:
if by_time <> 0 then by_time else Int.compare src_a src_b)
324
Added:
|> List.map snd
325
Added:
244
326
let progress t trainee exercise =
245
Removed:
R.log t.repo trainee >|= fun log ->
246
Removed:
match Progression.assess (Evidence.Log.observations log exercise) with
327
Added:
R.log t.repo trainee >>= fun log ->
328
Added:
R.imported_records t.repo trainee >|= fun records ->
329
Added:
match Progression.assess (merged_observations ~log ~records exercise) with
247
330
| assessment -> Ok assessment
248
331
| exception Progression.Invalid error -> Error error
249
332
333
Added:
(* Diagnostics stay native-only. They name overtraining habits from a
334
Added:
workout's prescription, its volume, its clearance, and its extensions.
335
Added:
A promoted import carries none of that structure: it is a bare series of
336
Added:
failure observations with no prescription volume or recovery clearance
337
Added:
to measure against. Folding imports in would fabricate habits the record
338
Added:
cannot support. *)
250
339
let diagnostics t trainee =
251
340
R.log t.repo trainee >|= fun log -> Progression.diagnose log
252
341
end
@@ -282,6 +371,118 @@
282
371
let remove t trainee id = R.delete_app_feedback t.repo ~author:trainee id
283
372
end
284
373
374
Added:
(* --- workout import --- *)
375
Added:
module Import = struct
376
Added:
module WI = Workout_import
377
Added:
378
Added:
let batch_id_eq a b =
379
Added:
String.equal (WI.batch_id_to_string a) (WI.batch_id_to_string b)
380
Added:
381
Added:
(* Turn a promoted workout into the canonical record the repository stores.
382
Added:
One record carries every observation of the workout, so a re-promotion
383
Added:
replaces it wholesale rather than appending. *)
384
Added:
let record_of_promoted (p : WI.promoted) : Repository.imported_record =
385
Added:
{
386
Added:
Repository.batch_id = p.provenance.batch_id;
387
Added:
workout_id = p.provenance.workout_id;
388
Added:
revision = p.provenance.revision;
389
Added:
title = p.title;
390
Added:
started_at = p.started_at;
391
Added:
ended_at = p.ended_at;
392
Added:
observations = p.observations;
393
Added:
provenance = p.provenance;
394
Added:
}
395
Added:
396
Added:
(* Store or replace a batch. Without [allow_duplicate], refuse when another
397
Added:
stored batch (a different identity) already carries the same
398
Added:
fingerprint: that is the same export imported twice. Re-saving a batch
399
Added:
with the same identity is an edit, never a duplicate, so it is always
400
Added:
allowed. *)
401
Added:
let store_import_batch t trainee ?allow_duplicate batch =
402
Added:
let identity = WI.batch_identity batch in
403
Added:
let fingerprint = WI.batch_fingerprint batch in
404
Added:
R.import_batches t.repo trainee >>= fun existing ->
405
Added:
let duplicate =
406
Added:
allow_duplicate = None
407
Added:
&& List.exists
408
Added:
(fun b ->
409
Added:
(not (batch_id_eq (WI.batch_identity b) identity))
410
Added:
&& String.equal (WI.batch_fingerprint b) fingerprint)
411
Added:
existing
412
Added:
in
413
Added:
if duplicate then Lwt.return (Error `Duplicate_source)
414
Added:
else R.save_import_batch t.repo trainee batch >|= fun () -> Ok ()
415
Added:
416
Added:
let import_batches t trainee = R.import_batches t.repo trainee
417
Added:
let find_import_batch t trainee id = R.find_import_batch t.repo trainee id
418
Added:
419
Added:
let delete_import_batch t trainee id =
420
Added:
R.delete_import_batch t.repo trainee id
421
Added:
422
Added:
(* Load a batch, apply a pure cleaning step, and save the revised batch.
423
Added:
An unknown batch is [`Unknown_batch]; a cleaning error is [`Import]. *)
424
Added:
let with_batch t trainee ~batch ~f =
425
Added:
R.find_import_batch t.repo trainee batch >>= function
426
Added:
| None -> Lwt.return (Error `Unknown_batch)
427
Added:
| Some b -> (
428
Added:
match f b with
429
Added:
| Error e -> Lwt.return (Error (`Import e))
430
Added:
| Ok updated ->
431
Added:
R.save_import_batch t.repo trainee updated >|= fun () ->
432
Added:
Ok updated)
433
Added:
434
Added:
let map_import_exercise t trainee ~batch ~workout ~source_name exercise =
435
Added:
with_batch t trainee ~batch ~f:(fun b ->
436
Added:
WI.map_exercise b ~workout ~source_name exercise)
437
Added:
438
Added:
let confirm_import_normal_sets t trainee ~batch ~workout ~acknowledgement =
439
Added:
with_batch t trainee ~batch ~f:(fun b ->
440
Added:
WI.confirm_normal_sets b ~workout ~acknowledgement)
441
Added:
442
Added:
(* Promote one workout. On [Promoted], write the canonical record first,
443
Added:
then save the batch that now remembers the promotion. The record upsert
444
Added:
is atomic and carries every observation, so a crash between the two
445
Added:
writes is harmless: re-running promotion is deterministic and replaces
446
Added:
the same record keyed by [(trainee, workout_id)], never duplicating
447
Added:
observations. [Already_promoted] and [Blocked] leave the record store
448
Added:
untouched; the batch is saved only when [promote_workout] revised it. *)
449
Added:
let promote_import_workout t trainee ~batch ~workout =
450
Added:
R.find_import_batch t.repo trainee batch >>= function
451
Added:
| None -> Lwt.return (Error `Unknown_batch)
452
Added:
| Some b -> (
453
Added:
match WI.promote_workout b workout with
454
Added:
| Error e -> Lwt.return (Error (`Import e))
455
Added:
| Ok (updated, (WI.Promoted p as result)) ->
456
Added:
R.replace_imported_record t.repo trainee (record_of_promoted p)
457
Added:
>>= fun () ->
458
Added:
R.save_import_batch t.repo trainee updated >|= fun () -> Ok result
459
Added:
| Ok (updated, ((WI.Already_promoted _ | WI.Blocked _) as result)) ->
460
Added:
(* No new evidence to write. Save the batch only if promotion
461
Added:
revised it; [promote_workout] returns the same batch when it
462
Added:
did not, so an unconditional save is a harmless idempotent
463
Added:
write. *)
464
Added:
R.save_import_batch t.repo trainee updated >|= fun () -> Ok result
465
Added:
)
466
Added:
467
Added:
(* Promote every workout in a batch. Promotion is partial across workouts:
468
Added:
each result.promoted record is written, blocked workouts remain in the
469
Added:
batch, and already-promoted workouts need no rewrite. Save the batch
470
Added:
once, after all records, so its remembered promotions match the store. *)
471
Added:
let promote_import_batch t trainee ~batch =
472
Added:
R.find_import_batch t.repo trainee batch >>= function
473
Added:
| None -> Lwt.return (Error `Unknown_batch)
474
Added:
| Some b ->
475
Added:
let updated, result = WI.promote_batch b in
476
Added:
Lwt_list.iter_s
477
Added:
(fun (_, p) ->
478
Added:
R.replace_imported_record t.repo trainee (record_of_promoted p))
479
Added:
result.WI.promoted
480
Added:
>>= fun () ->
481
Added:
R.save_import_batch t.repo trainee updated >|= fun () -> Ok result
482
Added:
483
Added:
let imported_records t trainee = R.imported_records t.repo trainee
484
Added:
end
485
Added:
285
486
(* Re-export the use cases as one flat service, matching Service.mli. *)
286
487
287
488
let register = Accounts.register
@@ -313,4 +514,13 @@
313
514
let upvote_app_feedback = App_feedback.upvote
314
515
let edit_app_feedback = App_feedback.edit
315
516
let remove_app_feedback = App_feedback.remove
517
Added:
let store_import_batch = Import.store_import_batch
518
Added:
let import_batches = Import.import_batches
519
Added:
let find_import_batch = Import.find_import_batch
520
Added:
let delete_import_batch = Import.delete_import_batch
521
Added:
let map_import_exercise = Import.map_import_exercise
522
Added:
let confirm_import_normal_sets = Import.confirm_import_normal_sets
523
Added:
let promote_import_workout = Import.promote_import_workout
524
Added:
let promote_import_batch = Import.promote_import_batch
525
Added:
let imported_records = Import.imported_records
316
526
end
lib/app/service.mli
@@ -225,4 +225,95 @@
225
225
val remove_app_feedback :
226
226
t -> Trainee.id -> Repository.app_feedback_id -> bool Lwt.t
227
227
(** Remove one of the trainee's own messages. *)
228
Added:
229
Added:
(** {2 Workout import}
230
Added:
231
Added:
Bringing a third-party export into hito is a two-stage flow. A batch is
232
Added:
cleaned — exercises mapped, normal sets acknowledged — then promoted.
233
Added:
Promotion turns a cleaned workout into canonical evidence stored as an
234
Added:
{!Repository.imported_record}, independent of the provisional batch it
235
Added:
came from. Import evidence gates recovery and feeds progression, but never
236
Added:
advances the routine cycle. *)
237
Added:
238
Added:
type import_error =
239
Added:
[ `Unknown_batch | `Duplicate_source | `Import of Workout_import.error ]
240
Added:
(** Why an import operation was refused: no such stored batch, another stored
241
Added:
batch already carries the same source fingerprint, or the cleaning or
242
Added:
promotion step itself failed. *)
243
Added:
244
Added:
val store_import_batch :
245
Added:
t ->
246
Added:
Trainee.id ->
247
Added:
?allow_duplicate:unit ->
248
Added:
Workout_import.batch ->
249
Added:
(unit, import_error) result Lwt.t
250
Added:
(** Store or replace a provisional batch. Without [allow_duplicate], refuse
251
Added:
with [`Duplicate_source] when a different stored batch already carries the
252
Added:
same fingerprint, so the same export is not imported twice by accident.
253
Added:
[allow_duplicate] overrides that check and stores the batch anyway.
254
Added:
Re-storing a batch with the same identity is always an edit, never a
255
Added:
duplicate. *)
256
Added:
257
Added:
val import_batches : t -> Trainee.id -> Workout_import.batch list Lwt.t
258
Added:
(** Every stored batch for the trainee, most recent first. *)
259
Added:
260
Added:
val find_import_batch :
261
Added:
t ->
262
Added:
Trainee.id ->
263
Added:
Workout_import.batch_id ->
264
Added:
Workout_import.batch option Lwt.t
265
Added:
(** The stored batch with the given identity, or [None]. *)
266
Added:
267
Added:
val delete_import_batch :
268
Added:
t -> Trainee.id -> Workout_import.batch_id -> bool Lwt.t
269
Added:
(** Remove a provisional batch. [false] when no such batch exists. Promoted
270
Added:
records outlive the batch and are never removed by this call. *)
271
Added:
272
Added:
val map_import_exercise :
273
Added:
t ->
274
Added:
Trainee.id ->
275
Added:
batch:Workout_import.batch_id ->
276
Added:
workout:Workout_import.workout_id ->
277
Added:
source_name:string ->
278
Added:
Exercise.t ->
279
Added:
(Workout_import.batch, import_error) result Lwt.t
280
Added:
(** Confirm the catalog entry a source exercise name denotes, then store the
281
Added:
revised batch. *)
282
Added:
283
Added:
val confirm_import_normal_sets :
284
Added:
t ->
285
Added:
Trainee.id ->
286
Added:
batch:Workout_import.batch_id ->
287
Added:
workout:Workout_import.workout_id ->
288
Added:
acknowledgement:string ->
289
Added:
(Workout_import.batch, import_error) result Lwt.t
290
Added:
(** Record the workout-level acknowledgement that promotes its normal sets,
291
Added:
then store the revised batch. *)
292
Added:
293
Added:
val promote_import_workout :
294
Added:
t ->
295
Added:
Trainee.id ->
296
Added:
batch:Workout_import.batch_id ->
297
Added:
workout:Workout_import.workout_id ->
298
Added:
(Workout_import.workout_result, import_error) result Lwt.t
299
Added:
(** Promote one cleaned workout. On success, one {!Repository.imported_record}
300
Added:
is written carrying every observation of the workout, and the batch is
301
Added:
saved so it remembers the promotion. The record upsert is atomic and keyed
302
Added:
by [(trainee, workout_id)], so re-running promotion after a crash between
303
Added:
the record write and the batch save replaces the same record
304
Added:
deterministically and never duplicates observations. An already-promoted
305
Added:
or blocked workout writes no evidence. *)
306
Added:
307
Added:
val promote_import_batch :
308
Added:
t ->
309
Added:
Trainee.id ->
310
Added:
batch:Workout_import.batch_id ->
311
Added:
(Workout_import.batch_result, import_error) result Lwt.t
312
Added:
(** Promote every workout in a batch. Promotion is partial across workouts:
313
Added:
each promoted workout's record is written, blocked workouts stay in the
314
Added:
batch, and already-promoted workouts need no rewrite. *)
315
Added:
316
Added:
val imported_records :
317
Added:
t -> Trainee.id -> Repository.imported_record list Lwt.t
318
Added:
(** Every promoted record for the trainee, most recent [ended_at] first. *)
228
319
end
test/dune
@@ -10,6 +10,7 @@
10
10
test_progression
11
11
test_service
12
12
test_workout_import
13
Added:
test_import_service
13
14
test_codec
14
15
test_import_codec
15
16
test_import_repo
test/test_hito.ml
@@ -9,7 +9,7 @@
9
9
Alcotest.run "hito"
10
10
(Test_architecture.suite @ Test_exercise.suite @ Test_recovery.suite
11
11
@ Test_prescription.suite @ Test_evidence.suite @ Test_progression.suite
12
Removed:
@ Test_service.suite @ Test_workout_import.suite @ Test_codec.suite
13
Removed:
@ Test_import_codec.suite @ Test_import_repo.suite @ Test_import_sqlite.suite
14
Removed:
@ Test_bcrypt_hash.suite @ Test_sqlite_repo.suite @ Test_decode.suite
15
Removed:
@ Test_hevy_csv.suite @ Test_web.suite)
12
Added:
@ Test_service.suite @ Test_workout_import.suite @ Test_import_service.suite
13
Added:
@ Test_codec.suite @ Test_import_codec.suite @ Test_import_repo.suite
14
Added:
@ Test_import_sqlite.suite @ Test_bcrypt_hash.suite @ Test_sqlite_repo.suite
15
Added:
@ Test_decode.suite @ Test_hevy_csv.suite @ Test_web.suite)
test/test_import_service.ml
@@ -0,0 +1,412 @@
1
Added:
(** Tests for {!Hito_app.Service}'s workout-import integration: storing and
2
Added:
cleaning batches, promoting them into canonical
3
Added:
{!Repository.imported_record} evidence, and how that evidence feeds
4
Added:
progression and recovery without ever advancing the routine cycle. Authored
5
Added:
against service.mli. *)
6
Added:
7
Added:
open Hito_app
8
Added:
open Hito_persistence
9
Added:
module S = Service.Make (Memory_repo) (Bcrypt_hash)
10
Added:
module WI = Workout_import
11
Added:
12
Added:
let run = Lwt_main.run
13
Added:
let ok = function Ok v -> v | Error _ -> Alcotest.fail "expected Ok"
14
Added:
15
Added:
let get id =
16
Added:
match Exercise.find_id id with
17
Added:
| Some e -> e
18
Added:
| None -> Alcotest.failf "catalog is missing %S" id
19
Added:
20
Added:
let at s = Recovery.timestamp_of_unix_seconds s
21
Added:
let day n = at (n * 86_400)
22
Added:
let hours n = n * 3_600
23
Added:
let ideal = Repository.routine_id "ideal"
24
Added:
25
Added:
let fixture () =
26
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
27
Added:
let trainee =
28
Added:
ok (run (S.register s ~username:"lifter" ~password:"heavyduty1"))
29
Added:
in
30
Added:
(s, trainee.Trainee.id)
31
Added:
32
Added:
(* An imported source set. Defaults to a failure set so promotion needs no
33
Added:
acknowledgement unless a test asks for a normal set. *)
34
Added:
let set ?(row = 0) ?(set_index = 1) ?(kind = WI.Failure) ~name ~kg ~reps () :
35
Added:
WI.source_set =
36
Added:
{
37
Added:
row;
38
Added:
exercise_name = name;
39
Added:
set_index;
40
Added:
set_type = kind;
41
Added:
weight_kg = kg;
42
Added:
reps;
43
Added:
superset_id = None;
44
Added:
}
45
Added:
46
Added:
let workout ~id ~title ~started_at ~ended_at ~sets =
47
Added:
ok (WI.make_workout ~id:(WI.workout_id id) ~title ~started_at ~ended_at ~sets)
48
Added:
49
Added:
(* A batch whose identity, fingerprint, and imported time are all explicit, so
50
Added:
duplicate detection can be exercised precisely. *)
51
Added:
let batch ?(source = "raw,csv") ?(fingerprint = "fp") ?(imported_at = at 5_000)
52
Added:
~id workouts =
53
Added:
WI.make_batch ~id:(WI.batch_id id) ~source ~fingerprint ~imported_at ~workouts
54
Added:
~warnings:[]
55
Added:
56
Added:
(* Map [source_name] to [exercise] for a workout in a stored batch. *)
57
Added:
let map s t ~batch:bid ~workout:wid ~name exercise =
58
Added:
ok
59
Added:
(run
60
Added:
(S.map_import_exercise s t ~batch:(WI.batch_id bid)
61
Added:
~workout:(WI.workout_id wid) ~source_name:name exercise))
62
Added:
63
Added:
(* Store a batch with a single mapped squats failure set, ready to promote. *)
64
Added:
let ready_batch s t ~id ~ended_at =
65
Added:
let w =
66
Added:
workout ~id:(id ^ "-w") ~title:"Legs" ~started_at:(at 0) ~ended_at
67
Added:
~sets:[ set ~row:1 ~name:"Barbell Squat" ~kg:100. ~reps:8 () ]
68
Added:
in
69
Added:
ok (run (S.store_import_batch s t (batch ~id [ w ])));
70
Added:
ignore
71
Added:
(map s t ~batch:id ~workout:(id ^ "-w") ~name:"Barbell Squat" (get "squats"));
72
Added:
id
73
Added:
74
Added:
let store_tests =
75
Added:
[
76
Added:
( "a duplicate fingerprint is refused, override accepts it",
77
Added:
`Quick,
78
Added:
fun () ->
79
Added:
let s, t = fixture () in
80
Added:
let w id =
81
Added:
workout ~id ~title:"Legs" ~started_at:(at 0) ~ended_at:(at 3_600)
82
Added:
~sets:[ set ~name:"Barbell Squat" ~kg:100. ~reps:8 () ]
83
Added:
in
84
Added:
ok
85
Added:
(run
86
Added:
(S.store_import_batch s t
87
Added:
(batch ~id:"b1" ~fingerprint:"same" [ w "w1" ])));
88
Added:
(match
89
Added:
run
90
Added:
(S.store_import_batch s t
91
Added:
(batch ~id:"b2" ~fingerprint:"same" [ w "w2" ]))
92
Added:
with
93
Added:
| Error `Duplicate_source -> ()
94
Added:
| _ -> Alcotest.fail "expected Duplicate_source");
95
Added:
ok
96
Added:
(run
97
Added:
(S.store_import_batch s t ~allow_duplicate:()
98
Added:
(batch ~id:"b2" ~fingerprint:"same" [ w "w2" ])));
99
Added:
Alcotest.(check int)
100
Added:
"both batches stored" 2
101
Added:
(List.length (run (S.import_batches s t))) );
102
Added:
( "re-storing the same batch id is a replacement, not a duplicate",
103
Added:
`Quick,
104
Added:
fun () ->
105
Added:
let s, t = fixture () in
106
Added:
let w =
107
Added:
workout ~id:"w1" ~title:"Legs" ~started_at:(at 0) ~ended_at:(at 3_600)
108
Added:
~sets:[ set ~name:"Barbell Squat" ~kg:100. ~reps:8 () ]
109
Added:
in
110
Added:
ok
111
Added:
(run
112
Added:
(S.store_import_batch s t
113
Added:
(batch ~id:"b1" ~fingerprint:"same" [ w ])));
114
Added:
ok
115
Added:
(run
116
Added:
(S.store_import_batch s t
117
Added:
(batch ~id:"b1" ~fingerprint:"same" [ w ])));
118
Added:
Alcotest.(check int)
119
Added:
"still one batch" 1
120
Added:
(List.length (run (S.import_batches s t))) );
121
Added:
( "mapping and confirmation persist on the stored batch",
122
Added:
`Quick,
123
Added:
fun () ->
124
Added:
let s, t = fixture () in
125
Added:
let w =
126
Added:
workout ~id:"w1" ~title:"Legs" ~started_at:(at 0) ~ended_at:(at 3_600)
127
Added:
~sets:
128
Added:
[
129
Added:
set ~row:1 ~name:"Barbell Squat" ~kind:WI.Normal ~kg:100.
130
Added:
~reps:8 ();
131
Added:
]
132
Added:
in
133
Added:
ok (run (S.store_import_batch s t (batch ~id:"b1" [ w ])));
134
Added:
ignore
135
Added:
(map s t ~batch:"b1" ~workout:"w1" ~name:"Barbell Squat"
136
Added:
(get "squats"));
137
Added:
ignore
138
Added:
(ok
139
Added:
(run
140
Added:
(S.confirm_import_normal_sets s t ~batch:(WI.batch_id "b1")
141
Added:
~workout:(WI.workout_id "w1") ~acknowledgement:"to failure")));
142
Added:
let reloaded =
143
Added:
Option.get (run (S.find_import_batch s t (WI.batch_id "b1")))
144
Added:
in
145
Added:
let w' = Option.get (WI.find_workout reloaded (WI.workout_id "w1")) in
146
Added:
Alcotest.(check bool)
147
Added:
"mapping persisted" true
148
Added:
(Option.is_some (WI.workout_mapping w' ~source_name:"Barbell Squat"));
149
Added:
Alcotest.(check (option string))
150
Added:
"acknowledgement persisted" (Some "to failure")
151
Added:
(WI.workout_acknowledgement w');
152
Added:
Alcotest.(check int)
153
Added:
"no blockers remain" 0
154
Added:
(List.length (WI.blockers w')) );
155
Added:
]
156
Added:
157
Added:
let promotion_tests =
158
Added:
[
159
Added:
( "a blocked workout stays stored; an eligible sibling promotes via batch",
160
Added:
`Quick,
161
Added:
fun () ->
162
Added:
let s, t = fixture () in
163
Added:
let w1 =
164
Added:
workout ~id:"w1" ~title:"Legs" ~started_at:(at 0) ~ended_at:(at 3_600)
165
Added:
~sets:[ set ~row:1 ~name:"Barbell Squat" ~kg:100. ~reps:8 () ]
166
Added:
in
167
Added:
let w2 =
168
Added:
workout ~id:"w2" ~title:"Delts" ~started_at:(at 0)
169
Added:
~ended_at:(at 3_600)
170
Added:
~sets:[ set ~row:2 ~name:"Side Raise" ~kg:12. ~reps:9 () ]
171
Added:
in
172
Added:
ok (run (S.store_import_batch s t (batch ~id:"b1" [ w1; w2 ])));
173
Added:
ignore
174
Added:
(map s t ~batch:"b1" ~workout:"w1" ~name:"Barbell Squat"
175
Added:
(get "squats"));
176
Added:
let result =
177
Added:
ok (run (S.promote_import_batch s t ~batch:(WI.batch_id "b1")))
178
Added:
in
179
Added:
Alcotest.(check int)
180
Added:
"one workout promoted" 1
181
Added:
(List.length result.WI.promoted);
182
Added:
Alcotest.(check int)
183
Added:
"one workout blocked" 1
184
Added:
(List.length result.WI.blocked);
185
Added:
Alcotest.(check int)
186
Added:
"one imported record written" 1
187
Added:
(List.length (run (S.imported_records s t)));
188
Added:
let reloaded =
189
Added:
Option.get (run (S.find_import_batch s t (WI.batch_id "b1")))
190
Added:
in
191
Added:
Alcotest.(check bool)
192
Added:
"blocked workout retained" true
193
Added:
(Option.is_some (WI.find_workout reloaded (WI.workout_id "w2"))) );
194
Added:
( "promoting a workout writes one record with all its observations",
195
Added:
`Quick,
196
Added:
fun () ->
197
Added:
let s, t = fixture () in
198
Added:
let w =
199
Added:
workout ~id:"w1" ~title:"Legs" ~started_at:(at 0) ~ended_at:(at 3_600)
200
Added:
~sets:
201
Added:
[
202
Added:
set ~row:1 ~name:"Barbell Squat" ~kg:100. ~reps:8 ();
203
Added:
set ~row:2 ~set_index:2 ~name:"Barbell Squat" ~kg:100. ~reps:6
204
Added:
();
205
Added:
]
206
Added:
in
207
Added:
ok (run (S.store_import_batch s t (batch ~id:"b1" [ w ])));
208
Added:
ignore
209
Added:
(map s t ~batch:"b1" ~workout:"w1" ~name:"Barbell Squat"
210
Added:
(get "squats"));
211
Added:
let _ =
212
Added:
ok
213
Added:
(run
214
Added:
(S.promote_import_workout s t ~batch:(WI.batch_id "b1")
215
Added:
~workout:(WI.workout_id "w1")))
216
Added:
in
217
Added:
(match run (S.imported_records s t) with
218
Added:
| [ record ] ->
219
Added:
Alcotest.(check int)
220
Added:
"both observations in one record" 2
221
Added:
(List.length record.Repository.observations)
222
Added:
| records ->
223
Added:
Alcotest.failf "expected one record, got %d" (List.length records));
224
Added:
let again =
225
Added:
ok
226
Added:
(run
227
Added:
(S.promote_import_workout s t ~batch:(WI.batch_id "b1")
228
Added:
~workout:(WI.workout_id "w1")))
229
Added:
in
230
Added:
(match again with
231
Added:
| WI.Already_promoted _ -> ()
232
Added:
| _ -> Alcotest.fail "expected Already_promoted on repeat");
233
Added:
Alcotest.(check int)
234
Added:
"still one record, no duplication" 1
235
Added:
(List.length (run (S.imported_records s t)));
236
Added:
match run (S.imported_records s t) with
237
Added:
| [ record ] ->
238
Added:
Alcotest.(check int)
239
Added:
"still two observations" 2
240
Added:
(List.length record.Repository.observations)
241
Added:
| _ -> Alcotest.fail "expected one record" );
242
Added:
( "deleting a batch leaves its promoted record",
243
Added:
`Quick,
244
Added:
fun () ->
245
Added:
let s, t = fixture () in
246
Added:
let _ = ready_batch s t ~id:"b1" ~ended_at:(at 3_600) in
247
Added:
let _ =
248
Added:
ok
249
Added:
(run
250
Added:
(S.promote_import_workout s t ~batch:(WI.batch_id "b1")
251
Added:
~workout:(WI.workout_id "b1-w")))
252
Added:
in
253
Added:
Alcotest.(check bool)
254
Added:
"batch deleted" true
255
Added:
(run (S.delete_import_batch s t (WI.batch_id "b1")));
256
Added:
Alcotest.(check bool)
257
Added:
"batch gone" true
258
Added:
(Option.is_none (run (S.find_import_batch s t (WI.batch_id "b1"))));
259
Added:
Alcotest.(check int)
260
Added:
"record survives" 1
261
Added:
(List.length (run (S.imported_records s t))) );
262
Added:
]
263
Added:
264
Added:
(* Build, map, and promote a one-set squats workout at [ended_at]. *)
265
Added:
let promote_squats s t ~id ~ended_at ~kg ~reps =
266
Added:
let w =
267
Added:
workout ~id:(id ^ "-w") ~title:"Legs" ~started_at:ended_at ~ended_at
268
Added:
~sets:[ set ~row:1 ~name:"Barbell Squat" ~kg ~reps () ]
269
Added:
in
270
Added:
ok (run (S.store_import_batch s t (batch ~id ~fingerprint:id [ w ])));
271
Added:
ignore
272
Added:
(map s t ~batch:id ~workout:(id ^ "-w") ~name:"Barbell Squat" (get "squats"));
273
Added:
ignore
274
Added:
(run
275
Added:
(S.promote_import_workout s t ~batch:(WI.batch_id id)
276
Added:
~workout:(WI.workout_id (id ^ "-w"))))
277
Added:
278
Added:
let progression_tests =
279
Added:
[
280
Added:
( "two imported observations turn insufficient data into a verdict",
281
Added:
`Quick,
282
Added:
fun () ->
283
Added:
let s, t = fixture () in
284
Added:
promote_squats s t ~id:"b1" ~ended_at:(day 1) ~kg:100. ~reps:8;
285
Added:
(match run (S.progress s t (get "squats")) with
286
Added:
| Error Progression.Insufficient_data -> ()
287
Added:
| _ -> Alcotest.fail "one observation should be insufficient");
288
Added:
promote_squats s t ~id:"b2" ~ended_at:(day 3) ~kg:105. ~reps:8;
289
Added:
Alcotest.(check bool)
290
Added:
"progressing on two imports" true
291
Added:
(run (S.progress s t (get "squats")) = Ok Progression.Progressing) );
292
Added:
( "a flat fortnight of imports reads as a stall",
293
Added:
`Quick,
294
Added:
fun () ->
295
Added:
let s, t = fixture () in
296
Added:
promote_squats s t ~id:"b1" ~ended_at:(day 10) ~kg:110. ~reps:8;
297
Added:
(match run (S.progress s t (get "squats")) with
298
Added:
| Error Progression.Insufficient_data -> ()
299
Added:
| _ -> Alcotest.fail "one observation should be insufficient");
300
Added:
promote_squats s t ~id:"b2" ~ended_at:(day 25) ~kg:110. ~reps:8;
301
Added:
Alcotest.(check bool)
302
Added:
"stalled after a flat fortnight" true
303
Added:
(run (S.progress s t (get "squats")) = Ok Progression.Stalled) );
304
Added:
( "imported records for another exercise are excluded",
305
Added:
`Quick,
306
Added:
fun () ->
307
Added:
let s, t = fixture () in
308
Added:
promote_squats s t ~id:"b1" ~ended_at:(day 1) ~kg:100. ~reps:8;
309
Added:
promote_squats s t ~id:"b2" ~ended_at:(day 3) ~kg:105. ~reps:8;
310
Added:
match run (S.progress s t (get "laterals")) with
311
Added:
| Error Progression.Insufficient_data -> ()
312
Added:
| _ -> Alcotest.fail "laterals should have no evidence" );
313
Added:
]
314
Added:
315
Added:
let recovery_tests =
316
Added:
[
317
Added:
( "the latest promoted import gates recovery for 48h, then ready",
318
Added:
`Quick,
319
Added:
fun () ->
320
Added:
let s, t = fixture () in
321
Added:
promote_squats s t ~id:"b1" ~ended_at:(day 10) ~kg:100. ~reps:8;
322
Added:
let early =
323
Added:
ok
324
Added:
(run
325
Added:
(S.readiness s t ~routine:ideal
326
Added:
~now:(at ((10 * 86_400) + hours 24))))
327
Added:
in
328
Added:
Alcotest.(check bool)
329
Added:
"recovering at 24h" false (Recovery.is_ready early);
330
Added:
let late =
331
Added:
ok
332
Added:
(run
333
Added:
(S.readiness s t ~routine:ideal
334
Added:
~now:(at ((10 * 86_400) + hours 48))))
335
Added:
in
336
Added:
Alcotest.(check bool) "ready at 48h" true (Recovery.is_ready late) );
337
Added:
( "an imported promotion never advances the routine cycle",
338
Added:
`Quick,
339
Added:
fun () ->
340
Added:
let s, t = fixture () in
341
Added:
let before = ok (run (S.next_workout s t ~routine:ideal)) in
342
Added:
promote_squats s t ~id:"b1" ~ended_at:(day 1) ~kg:100. ~reps:8;
343
Added:
let after = ok (run (S.next_workout s t ~routine:ideal)) in
344
Added:
Alcotest.(check string)
345
Added:
"next workout unchanged by an import"
346
Added:
(Prescription.Workout.name before)
347
Added:
(Prescription.Workout.name after) );
348
Added:
( "native later than imported controls recovery",
349
Added:
`Quick,
350
Added:
fun () ->
351
Added:
let s, t = fixture () in
352
Added:
promote_squats s t ~id:"b1" ~ended_at:(day 1) ~kg:100. ~reps:8;
353
Added:
let _ =
354
Added:
ok (run (S.begin_workout s t ~routine:ideal ~now:(day 10) ()))
355
Added:
in
356
Added:
let _ = run (S.finish s t ~ended_at:(day 10)) in
357
Added:
let r =
358
Added:
ok
359
Added:
(run
360
Added:
(S.readiness s t ~routine:ideal
361
Added:
~now:(at ((10 * 86_400) + hours 24))))
362
Added:
in
363
Added:
Alcotest.(check bool)
364
Added:
"native end governs, still recovering" false (Recovery.is_ready r) );
365
Added:
( "imported later than native controls recovery",
366
Added:
`Quick,
367
Added:
fun () ->
368
Added:
let s, t = fixture () in
369
Added:
let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in
370
Added:
let _ = run (S.finish s t ~ended_at:(day 1)) in
371
Added:
promote_squats s t ~id:"b1" ~ended_at:(day 10) ~kg:100. ~reps:8;
372
Added:
let recovering =
373
Added:
ok
374
Added:
(run
375
Added:
(S.readiness s t ~routine:ideal
376
Added:
~now:(at ((10 * 86_400) + hours 24))))
377
Added:
in
378
Added:
Alcotest.(check bool)
379
Added:
"import end governs, still recovering" false
380
Added:
(Recovery.is_ready recovering);
381
Added:
let ready =
382
Added:
ok
383
Added:
(run
384
Added:
(S.readiness s t ~routine:ideal
385
Added:
~now:(at ((10 * 86_400) + hours 48))))
386
Added:
in
387
Added:
Alcotest.(check bool)
388
Added:
"ready 48h after the governing import" true (Recovery.is_ready ready)
389
Added:
);
390
Added:
]
391
Added:
392
Added:
let diagnostics_tests =
393
Added:
[
394
Added:
( "diagnostics exclude imports",
395
Added:
`Quick,
396
Added:
fun () ->
397
Added:
let s, t = fixture () in
398
Added:
promote_squats s t ~id:"b1" ~ended_at:(day 1) ~kg:100. ~reps:8;
399
Added:
promote_squats s t ~id:"b2" ~ended_at:(day 3) ~kg:105. ~reps:8;
400
Added:
Alcotest.(check int)
401
Added:
"no diagnostics from imports alone" 0
402
Added:
(List.length (run (S.diagnostics s t))) );
403
Added:
]
404
Added:
405
Added:
let suite =
406
Added:
[
407
Added:
("import_service.store", store_tests);
408
Added:
("import_service.promotion", promotion_tests);
409
Added:
("import_service.progression", progression_tests);
410
Added:
("import_service.recovery", recovery_tests);
411
Added:
("import_service.diagnostics", diagnostics_tests);
412
Added:
]