[OCaml] High Intensity Training Online
feat Store workout imports and promoted evidence
Add a serialization-neutral Workout_import snapshot, repository ports, and a safe length-prefixed text codec. Memory and SQLite adapters now persist complete cleaning state and independent promoted records. Batch deletion leaves promoted evidence intact, edits replace records by workout identity, and reconnects preserve idempotent promotion. Add migration 7 and 21 persistence tests.
Changed files
- lib/app/repository.ml
- lib/app/repository.mli
- lib/app/workout_import.ml
- lib/app/workout_import.mli
- lib/persistence/import_codec.ml
- lib/persistence/import_codec.mli
- lib/persistence/memory_repo.ml
- lib/persistence/migrations.ml
- lib/persistence/sqlite_repo.ml
- lib/persistence/sqlite_repo.mli
- test/dune
- test/test_hito.ml
- test/test_import_codec.ml
- test/test_import_repo.ml
- test/test_import_sqlite.ml
lib/app/repository.ml
@@ -24,6 +24,17 @@
24
24
viewer_owns : bool;
25
25
}
26
26
27
Added:
type imported_record = {
28
Added:
batch_id : Workout_import.batch_id;
29
Added:
workout_id : Workout_import.workout_id;
30
Added:
revision : int;
31
Added:
title : string;
32
Added:
started_at : Recovery.timestamp;
33
Added:
ended_at : Recovery.timestamp;
34
Added:
observations : Evidence.Observation.t list;
35
Added:
provenance : Workout_import.provenance;
36
Added:
}
37
Added:
27
38
module type S = sig
28
39
type t
29
40
@@ -79,4 +90,20 @@
79
90
80
91
val delete_app_feedback :
81
92
t -> author:Trainee.id -> app_feedback_id -> bool Lwt.t
93
Added:
94
Added:
val save_import_batch : t -> Trainee.id -> Workout_import.batch -> unit Lwt.t
95
Added:
96
Added:
val find_import_batch :
97
Added:
t ->
98
Added:
Trainee.id ->
99
Added:
Workout_import.batch_id ->
100
Added:
Workout_import.batch option Lwt.t
101
Added:
102
Added:
val import_batches : t -> Trainee.id -> Workout_import.batch list Lwt.t
103
Added:
104
Added:
val delete_import_batch :
105
Added:
t -> Trainee.id -> Workout_import.batch_id -> bool Lwt.t
106
Added:
107
Added:
val replace_imported_record : t -> Trainee.id -> imported_record -> unit Lwt.t
108
Added:
val imported_records : t -> Trainee.id -> imported_record list Lwt.t
82
109
end
lib/app/repository.mli
@@ -36,6 +36,22 @@
36
36
}
37
37
(** A ranked application comment with viewer vote and ownership state. *)
38
38
39
Added:
type imported_record = {
40
Added:
batch_id : Workout_import.batch_id;
41
Added:
workout_id : Workout_import.workout_id;
42
Added:
revision : int;
43
Added:
title : string;
44
Added:
started_at : Recovery.timestamp;
45
Added:
ended_at : Recovery.timestamp;
46
Added:
observations : Evidence.Observation.t list;
47
Added:
provenance : Workout_import.provenance;
48
Added:
}
49
Added:
(** A promoted workout, stored as canonical evidence independent of the batch it
50
Added:
came from. A batch is provisional and may be discarded. Its promoted records
51
Added:
outlive it. The [revision] is the workout revision the promotion reflects,
52
Added:
so a re-promotion after an edit replaces the record rather than duplicating
53
Added:
it. *)
54
Added:
39
55
(** Effects run in Lwt: an adapter may talk to a database. *)
40
56
module type S = sig
41
57
type t
@@ -94,7 +110,8 @@
94
110
(** Replace an existing record by identity. *)
95
111
96
112
val log : t -> Trainee.id -> Evidence.Log.t Lwt.t
97
Removed:
(** The stored log — the only source of evidence. *)
113
Added:
(** Canonical workouts logged through hito. Promoted import observations are
114
Added:
stored separately in {!imported_records}. *)
98
115
99
116
val history : t -> Trainee.id -> record list Lwt.t
100
117
(** Most recent first. *)
@@ -130,4 +147,42 @@
130
147
val delete_app_feedback :
131
148
t -> author:Trainee.id -> app_feedback_id -> bool Lwt.t
132
149
(** Remove a report and its votes only when [author] owns it. *)
150
Added:
151
Added:
(** {2 Workout import}
152
Added:
153
Added:
A provisional import batch and the canonical records promoted from it have
154
Added:
independent lifecycles. A batch is stored so cleaning and promotion
155
Added:
survive a reconnect, and may be deleted once it is no longer needed. A
156
Added:
promoted record is canonical evidence and is never removed by deleting its
157
Added:
batch. *)
158
Added:
159
Added:
val save_import_batch : t -> Trainee.id -> Workout_import.batch -> unit Lwt.t
160
Added:
(** Store or replace a provisional import batch by its identity, including its
161
Added:
mappings, acknowledgements, and any prior promotions, so the batch's full
162
Added:
state survives a reconnect. *)
163
Added:
164
Added:
val find_import_batch :
165
Added:
t ->
166
Added:
Trainee.id ->
167
Added:
Workout_import.batch_id ->
168
Added:
Workout_import.batch option Lwt.t
169
Added:
(** The stored batch with the given identity, or [None]. *)
170
Added:
171
Added:
val import_batches : t -> Trainee.id -> Workout_import.batch list Lwt.t
172
Added:
(** Every stored batch for the trainee, most recent [imported_at] first, with
173
Added:
ties broken by batch id in descending order for a deterministic result. *)
174
Added:
175
Added:
val delete_import_batch :
176
Added:
t -> Trainee.id -> Workout_import.batch_id -> bool Lwt.t
177
Added:
(** Remove the provisional batch with the given identity. [false] when no such
178
Added:
batch exists. This never removes an {!imported_record}: promoted evidence
179
Added:
outlives the batch it came from. *)
180
Added:
181
Added:
val replace_imported_record : t -> Trainee.id -> imported_record -> unit Lwt.t
182
Added:
(** Store a promoted record, replacing any existing record for the same
183
Added:
trainee and [workout_id] with the new observations and revision. An atomic
184
Added:
upsert keyed by [(trainee, workout_id)]. *)
185
Added:
186
Added:
val imported_records : t -> Trainee.id -> imported_record list Lwt.t
187
Added:
(** Every promoted record for the trainee, most recent [ended_at] first. *)
133
188
end
lib/app/workout_import.ml
@@ -305,3 +305,194 @@
305
305
already_promoted = List.rev already_rev;
306
306
blocked = List.rev blocked_rev;
307
307
} )
308
Added:
309
Added:
(* {1 Snapshot} *)
310
Added:
311
Added:
type observation_snapshot = {
312
Added:
exercise_id : Exercise.id;
313
Added:
load : float;
314
Added:
reps : int;
315
Added:
performed_at : Recovery.timestamp;
316
Added:
}
317
Added:
318
Added:
type promoted_snapshot = {
319
Added:
title : string;
320
Added:
started_at : Recovery.timestamp;
321
Added:
ended_at : Recovery.timestamp;
322
Added:
observations : observation_snapshot list;
323
Added:
source_rows : int list;
324
Added:
normal_confirmation : string option;
325
Added:
revision : int;
326
Added:
}
327
Added:
328
Added:
type workout_snapshot = {
329
Added:
id : workout_id;
330
Added:
title : string;
331
Added:
started_at : Recovery.timestamp;
332
Added:
ended_at : Recovery.timestamp;
333
Added:
sets : source_set list;
334
Added:
mappings : (string * Exercise.id) list;
335
Added:
acknowledgement : string option;
336
Added:
revision : int;
337
Added:
promotion : promoted_snapshot option;
338
Added:
}
339
Added:
340
Added:
type snapshot = {
341
Added:
batch_id : batch_id;
342
Added:
source : string;
343
Added:
fingerprint : string;
344
Added:
imported_at : Recovery.timestamp;
345
Added:
workouts : workout_snapshot list;
346
Added:
warnings : warning list;
347
Added:
}
348
Added:
349
Added:
type restore_error = Unknown_exercise of string | Invalid_time
350
Added:
351
Added:
(* A promoted observation is always a single failure effort, so its snapshot
352
Added:
drops the delivery and the outcome. *)
353
Added:
let observation_snapshot obs =
354
Added:
let effort = Evidence.Observation.effort obs in
355
Added:
{
356
Added:
exercise_id = Exercise.id (Evidence.Stimulus.Effort.exercise effort);
357
Added:
load = Evidence.Stimulus.Effort.load effort;
358
Added:
reps = Evidence.Stimulus.Effort.reps effort;
359
Added:
performed_at = Evidence.Observation.performed_at obs;
360
Added:
}
361
Added:
362
Added:
let promoted_snapshot (p : promoted) =
363
Added:
{
364
Added:
title = p.title;
365
Added:
started_at = p.started_at;
366
Added:
ended_at = p.ended_at;
367
Added:
observations = List.map observation_snapshot p.observations;
368
Added:
source_rows = p.provenance.source_rows;
369
Added:
normal_confirmation = p.provenance.normal_confirmation;
370
Added:
revision = p.provenance.revision;
371
Added:
}
372
Added:
373
Added:
let workout_snapshot b (w : workout) =
374
Added:
{
375
Added:
id = w.id;
376
Added:
title = w.title;
377
Added:
started_at = w.started_at;
378
Added:
ended_at = w.ended_at;
379
Added:
sets = w.sets;
380
Added:
mappings = List.map (fun (name, e) -> (name, Exercise.id e)) w.mappings;
381
Added:
acknowledgement = w.acknowledgement;
382
Added:
revision = w.revision;
383
Added:
promotion = Option.map promoted_snapshot (List.assoc_opt w.id b.promotions);
384
Added:
}
385
Added:
386
Added:
let snapshot b =
387
Added:
{
388
Added:
batch_id = b.batch_identity;
389
Added:
source = b.source;
390
Added:
fingerprint = b.fingerprint;
391
Added:
imported_at = b.imported_at;
392
Added:
workouts = List.map (workout_snapshot b) b.workouts;
393
Added:
warnings = b.warnings;
394
Added:
}
395
Added:
396
Added:
let ( let* ) = Result.bind
397
Added:
398
Added:
(* Resolve an exercise id, reporting the raw id string when the catalog no
399
Added:
longer names it. *)
400
Added:
let resolve find_exercise (id : Exercise.id) =
401
Added:
match find_exercise id with
402
Added:
| Some e -> Ok e
403
Added:
| None -> Error (Unknown_exercise (id :> string))
404
Added:
405
Added:
let restore_mappings find_exercise mappings =
406
Added:
let rec go acc = function
407
Added:
| [] -> Ok (List.rev acc)
408
Added:
| (name, id) :: tl ->
409
Added:
let* e = resolve find_exercise id in
410
Added:
go ((name, e) :: acc) tl
411
Added:
in
412
Added:
go [] mappings
413
Added:
414
Added:
(* Rebuild a promotion from its snapshot. Each observation is reconstructed as a
415
Added:
single failure effort, exactly as promotion first minted it. *)
416
Added:
let restore_promotion find_exercise batch_id workout_id (p : promoted_snapshot)
417
Added:
=
418
Added:
let restore_observation (o : observation_snapshot) =
419
Added:
let* exercise = resolve find_exercise o.exercise_id in
420
Added:
let effort =
421
Added:
Evidence.Stimulus.Effort.make ~exercise ~load:o.load ~reps:o.reps
422
Added:
~outcome:Evidence.Stimulus.Positive_failure
423
Added:
in
424
Added:
Ok
425
Added:
(Evidence.Observation.make ~exercise ~effort ~performed_at:o.performed_at)
426
Added:
in
427
Added:
let rec go acc = function
428
Added:
| [] -> Ok (List.rev acc)
429
Added:
| o :: tl ->
430
Added:
let* obs = restore_observation o in
431
Added:
go (obs :: acc) tl
432
Added:
in
433
Added:
let* observations = go [] p.observations in
434
Added:
Ok
435
Added:
{
436
Added:
title = p.title;
437
Added:
started_at = p.started_at;
438
Added:
ended_at = p.ended_at;
439
Added:
observations;
440
Added:
provenance =
441
Added:
{
442
Added:
batch_id;
443
Added:
workout_id;
444
Added:
source_rows = p.source_rows;
445
Added:
normal_confirmation = p.normal_confirmation;
446
Added:
revision = p.revision;
447
Added:
};
448
Added:
}
449
Added:
450
Added:
let restore_workout find_exercise batch_id (ws : workout_snapshot) =
451
Added:
if
452
Added:
Recovery.timestamp_to_unix_seconds ws.ended_at
453
Added:
< Recovery.timestamp_to_unix_seconds ws.started_at
454
Added:
then Error Invalid_time
455
Added:
else
456
Added:
let* mappings = restore_mappings find_exercise ws.mappings in
457
Added:
let* promotion =
458
Added:
match ws.promotion with
459
Added:
| None -> Ok None
460
Added:
| Some p ->
461
Added:
let* p = restore_promotion find_exercise batch_id ws.id p in
462
Added:
Ok (Some p)
463
Added:
in
464
Added:
let w =
465
Added:
{
466
Added:
id = ws.id;
467
Added:
title = ws.title;
468
Added:
started_at = ws.started_at;
469
Added:
ended_at = ws.ended_at;
470
Added:
sets = ws.sets;
471
Added:
mappings;
472
Added:
acknowledgement = ws.acknowledgement;
473
Added:
revision = ws.revision;
474
Added:
}
475
Added:
in
476
Added:
Ok (w, Option.map (fun p -> (ws.id, p)) promotion)
477
Added:
478
Added:
let restore ~find_exercise (s : snapshot) =
479
Added:
let rec go workouts promotions = function
480
Added:
| [] -> Ok (List.rev workouts, List.rev promotions)
481
Added:
| ws :: tl ->
482
Added:
let* w, promo = restore_workout find_exercise s.batch_id ws in
483
Added:
let promotions =
484
Added:
match promo with Some p -> p :: promotions | None -> promotions
485
Added:
in
486
Added:
go (w :: workouts) promotions tl
487
Added:
in
488
Added:
let* workouts, promotions = go [] [] s.workouts in
489
Added:
Ok
490
Added:
{
491
Added:
batch_identity = s.batch_id;
492
Added:
source = s.source;
493
Added:
fingerprint = s.fingerprint;
494
Added:
imported_at = s.imported_at;
495
Added:
workouts;
496
Added:
warnings = s.warnings;
497
Added:
promotions;
498
Added:
}
lib/app/workout_import.mli
@@ -184,3 +184,82 @@
184
184
(** Promotes every workout in the batch. Promotion is partial: each workout is
185
185
promoted, already promoted, or blocked independently, and a blocked workout
186
186
never prevents another from promoting. *)
187
Added:
188
Added:
(** {1 Snapshot}
189
Added:
190
Added:
A serialization-neutral view of a batch, so a repository can store and
191
Added:
restore a batch without the third-party parser. The snapshot exposes plain
192
Added:
records that carry only strings, ints, floats, timestamps, and the public
193
Added:
{!source_set}, {!warning}, {!provenance}, and acknowledgement values. It
194
Added:
never exposes a mutable internal. A restore rebuilds the opaque batch,
195
Added:
resolving each exercise id through a lookup, so a snapshot stays valid only
196
Added:
as long as the catalog still names its exercises.
197
Added:
198
Added:
A prior promotion is preserved exactly, so {!Already_promoted} and the
199
Added:
edited re-promote behaviour survive a reconnect. Because every promoted
200
Added:
outcome is {!Positive_failure}, an observation snapshots as an exercise id,
201
Added:
a load, a rep count, and a performed time. *)
202
Added:
203
Added:
type observation_snapshot = {
204
Added:
exercise_id : Exercise.id;
205
Added:
load : float;
206
Added:
reps : int;
207
Added:
performed_at : Recovery.timestamp;
208
Added:
}
209
Added:
(** One promoted effort: always {!Positive_failure}, so the outcome is implicit.
210
Added:
*)
211
Added:
212
Added:
type promoted_snapshot = {
213
Added:
title : string;
214
Added:
started_at : Recovery.timestamp;
215
Added:
ended_at : Recovery.timestamp;
216
Added:
observations : observation_snapshot list;
217
Added:
source_rows : int list;
218
Added:
normal_confirmation : string option;
219
Added:
revision : int;
220
Added:
}
221
Added:
(** A stored promotion, flattened from {!promoted} and its {!provenance}. The
222
Added:
batch and workout ids are carried by the enclosing {!workout_snapshot}. *)
223
Added:
224
Added:
type workout_snapshot = {
225
Added:
id : workout_id;
226
Added:
title : string;
227
Added:
started_at : Recovery.timestamp;
228
Added:
ended_at : Recovery.timestamp;
229
Added:
sets : source_set list;
230
Added:
mappings : (string * Exercise.id) list;
231
Added:
(** Confirmed source-name-to-exercise mappings. *)
232
Added:
acknowledgement : string option;
233
Added:
revision : int;
234
Added:
promotion : promoted_snapshot option;
235
Added:
(** The prior promotion, when the workout was promoted. *)
236
Added:
}
237
Added:
238
Added:
type snapshot = {
239
Added:
batch_id : batch_id;
240
Added:
source : string;
241
Added:
fingerprint : string;
242
Added:
imported_at : Recovery.timestamp;
243
Added:
workouts : workout_snapshot list;
244
Added:
warnings : warning list;
245
Added:
}
246
Added:
247
Added:
(** Why a snapshot cannot be restored. *)
248
Added:
type restore_error =
249
Added:
| Unknown_exercise of string
250
Added:
(** A stored exercise id is not in the catalog. *)
251
Added:
| Invalid_time (** A stored [ended_at] precedes its [started_at]. *)
252
Added:
253
Added:
val snapshot : batch -> snapshot
254
Added:
(** A serialization-neutral view of the batch, including any prior promotion. *)
255
Added:
256
Added:
val restore :
257
Added:
find_exercise:(Exercise.id -> Exercise.t option) ->
258
Added:
snapshot ->
259
Added:
(batch, restore_error) result
260
Added:
(** Rebuilds the opaque batch, resolving each mapping's exercise id through
261
Added:
[find_exercise]. Returns [Error (Unknown_exercise _)] for a mapping or
262
Added:
observation whose exercise id is not in the catalog, and
263
Added:
[Error Invalid_time] when a workout's [ended_at] precedes its [started_at].
264
Added:
A restored batch reproduces the mappings, acknowledgement, revision, and
265
Added:
prior promotion of the snapshot exactly. *)
lib/persistence/import_codec.ml
@@ -0,0 +1,405 @@
1
Added:
open Hito_app
2
Added:
module WI = Workout_import
3
Added:
4
Added:
type error = Malformed of string | Unknown_exercise of string | Invalid_time
5
Added:
6
Added:
let pp_error ppf = function
7
Added:
| Malformed detail -> Format.fprintf ppf "malformed import record: %s" detail
8
Added:
| Unknown_exercise id -> Format.fprintf ppf "unknown exercise %S" id
9
Added:
| Invalid_time -> Format.fprintf ppf "ended_at precedes started_at"
10
Added:
11
Added:
(* --- length-prefixed writer ---
12
Added:
13
Added:
Every field is written as its byte length in decimal, a colon, then its raw
14
Added:
bytes. The length frames the bytes exactly, so a field may hold any byte,
15
Added:
including newlines, commas, and colons, and the reader never has to escape or
16
Added:
guess where a field ends. *)
17
Added:
18
Added:
module Writer = struct
19
Added:
let create () = Buffer.create 256
20
Added:
21
Added:
let field buf (s : string) =
22
Added:
Buffer.add_string buf (string_of_int (String.length s));
23
Added:
Buffer.add_char buf ':';
24
Added:
Buffer.add_string buf s
25
Added:
26
Added:
let string = field
27
Added:
let int buf n = field buf (string_of_int n)
28
Added:
29
Added:
(* [%h] renders a float as a round-trippable hexadecimal literal. *)
30
Added:
let float buf x = field buf (Printf.sprintf "%h" x)
31
Added:
let timestamp buf ts = field buf (Timestamp.encode ts)
32
Added:
33
Added:
(* An option is one field carrying its presence, then the value when present.
34
Added:
A one-field option lead keeps the framing regular. *)
35
Added:
let option write buf = function
36
Added:
| None -> field buf "0"
37
Added:
| Some v ->
38
Added:
field buf "1";
39
Added:
write buf v
40
Added:
41
Added:
(* A list is a count field followed by that many encoded elements. *)
42
Added:
let list write buf xs =
43
Added:
int buf (List.length xs);
44
Added:
List.iter (write buf) xs
45
Added:
46
Added:
let contents = Buffer.contents
47
Added:
end
48
Added:
49
Added:
(* --- length-prefixed reader --- *)
50
Added:
51
Added:
module Reader = struct
52
Added:
type t = { text : string; mutable pos : int }
53
Added:
54
Added:
exception Bad of string
55
Added:
exception Unknown of string (* an exercise id not in the catalog *)
56
Added:
57
Added:
let create text = { text; pos = 0 }
58
Added:
59
Added:
let field r =
60
Added:
let len = String.length r.text in
61
Added:
(* Read the decimal length up to the colon. *)
62
Added:
let start = r.pos in
63
Added:
let rec scan i =
64
Added:
if i >= len then raise (Bad "truncated field length")
65
Added:
else if r.text.[i] = ':' then i
66
Added:
else scan (i + 1)
67
Added:
in
68
Added:
let colon = scan start in
69
Added:
let n =
70
Added:
match int_of_string_opt (String.sub r.text start (colon - start)) with
71
Added:
| Some n when n >= 0 -> n
72
Added:
| _ -> raise (Bad "bad field length")
73
Added:
in
74
Added:
let value_start = colon + 1 in
75
Added:
if value_start + n > len then raise (Bad "field overruns input");
76
Added:
r.pos <- value_start + n;
77
Added:
String.sub r.text value_start n
78
Added:
79
Added:
let string = field
80
Added:
81
Added:
let int r =
82
Added:
match int_of_string_opt (field r) with
83
Added:
| Some n -> n
84
Added:
| None -> raise (Bad "expected int")
85
Added:
86
Added:
let float r =
87
Added:
match float_of_string_opt (field r) with
88
Added:
| Some x -> x
89
Added:
| None -> raise (Bad "expected float")
90
Added:
91
Added:
let timestamp r =
92
Added:
match Timestamp.decode (field r) with
93
Added:
| Ok ts -> ts
94
Added:
| Error _ -> raise (Bad "bad timestamp")
95
Added:
96
Added:
let option read r =
97
Added:
match field r with
98
Added:
| "0" -> None
99
Added:
| "1" -> Some (read r)
100
Added:
| _ -> raise (Bad "bad option lead")
101
Added:
102
Added:
let list read r =
103
Added:
let n = int r in
104
Added:
if n < 0 then raise (Bad "negative list length");
105
Added:
let rec go acc i =
106
Added:
if i = 0 then List.rev acc else go (read r :: acc) (i - 1)
107
Added:
in
108
Added:
go [] n
109
Added:
110
Added:
(* Resolve an exercise id string into an [Exercise.id]. The id type is
111
Added:
private, so a valid id can only come from the catalog. A stored id the
112
Added:
catalog no longer names is reported as [Unknown]. *)
113
Added:
let exercise_id r =
114
Added:
let raw = field r in
115
Added:
match Exercise.find_id raw with
116
Added:
| Some e -> Exercise.id e
117
Added:
| None -> raise (Unknown raw)
118
Added:
119
Added:
(* Resolve an exercise id string into the catalog entry itself. *)
120
Added:
let exercise r =
121
Added:
let raw = field r in
122
Added:
match Exercise.find_id raw with Some e -> e | None -> raise (Unknown raw)
123
Added:
124
Added:
let ensure_consumed r =
125
Added:
if r.pos <> String.length r.text then raise (Bad "trailing bytes")
126
Added:
127
Added:
(* Run a reader, turning framing faults and unknown ids into typed errors. *)
128
Added:
let run text f =
129
Added:
let r = create text in
130
Added:
match f r with
131
Added:
| v ->
132
Added:
ensure_consumed r;
133
Added:
Ok v
134
Added:
| exception Bad detail -> Error (Malformed detail)
135
Added:
| exception Unknown id -> Error (Unknown_exercise id)
136
Added:
end
137
Added:
138
Added:
(* --- source set --- *)
139
Added:
140
Added:
let set_type_code : WI.source_set_type -> string = function
141
Added:
| Normal -> "N"
142
Added:
| Failure -> "F"
143
Added:
| Dropset -> "D"
144
Added:
145
Added:
let set_type_of_code = function
146
Added:
| "N" -> WI.Normal
147
Added:
| "F" -> WI.Failure
148
Added:
| "D" -> WI.Dropset
149
Added:
| other -> raise (Reader.Bad (Printf.sprintf "set type %S" other))
150
Added:
151
Added:
let write_source_set buf (s : WI.source_set) =
152
Added:
Writer.int buf s.row;
153
Added:
Writer.string buf s.exercise_name;
154
Added:
Writer.int buf s.set_index;
155
Added:
Writer.string buf (set_type_code s.set_type);
156
Added:
Writer.float buf s.weight_kg;
157
Added:
Writer.int buf s.reps;
158
Added:
Writer.option Writer.int buf s.superset_id
159
Added:
160
Added:
let read_source_set r : WI.source_set =
161
Added:
let row = Reader.int r in
162
Added:
let exercise_name = Reader.string r in
163
Added:
let set_index = Reader.int r in
164
Added:
let set_type = set_type_of_code (Reader.string r) in
165
Added:
let weight_kg = Reader.float r in
166
Added:
let reps = Reader.int r in
167
Added:
let superset_id = Reader.option Reader.int r in
168
Added:
{ row; exercise_name; set_index; set_type; weight_kg; reps; superset_id }
169
Added:
170
Added:
(* --- warning --- *)
171
Added:
172
Added:
let write_warning buf (w : WI.warning) =
173
Added:
Writer.int buf w.row;
174
Added:
Writer.option Writer.string buf w.exercise_name;
175
Added:
match w.kind with
176
Added:
| Warmup_dropped -> Writer.string buf "warmup"
177
Added:
| Unsupported_row detail ->
178
Added:
Writer.string buf "unsupported";
179
Added:
Writer.string buf detail
180
Added:
181
Added:
let read_warning r : WI.warning =
182
Added:
let row = Reader.int r in
183
Added:
let exercise_name = Reader.option Reader.string r in
184
Added:
let kind =
185
Added:
match Reader.string r with
186
Added:
| "warmup" -> WI.Warmup_dropped
187
Added:
| "unsupported" -> WI.Unsupported_row (Reader.string r)
188
Added:
| other -> raise (Reader.Bad (Printf.sprintf "warning kind %S" other))
189
Added:
in
190
Added:
{ row; exercise_name; kind }
191
Added:
192
Added:
(* --- mapping --- *)
193
Added:
194
Added:
let write_mapping buf ((name, id) : string * Exercise.id) =
195
Added:
Writer.string buf name;
196
Added:
Writer.string buf (id :> string)
197
Added:
198
Added:
let read_mapping r =
199
Added:
let name = Reader.string r in
200
Added:
let id = Reader.exercise_id r in
201
Added:
(name, id)
202
Added:
203
Added:
(* --- observation snapshot --- *)
204
Added:
205
Added:
let write_observation buf (o : WI.observation_snapshot) =
206
Added:
Writer.string buf (o.exercise_id :> string);
207
Added:
Writer.float buf o.load;
208
Added:
Writer.int buf o.reps;
209
Added:
Writer.timestamp buf o.performed_at
210
Added:
211
Added:
(* Read one observation snapshot, resolving its exercise id to an [Exercise.id]
212
Added:
through the catalog. *)
213
Added:
let read_observation_snapshot r : WI.observation_snapshot =
214
Added:
let exercise_id = Reader.exercise_id r in
215
Added:
let load = Reader.float r in
216
Added:
let reps = Reader.int r in
217
Added:
let performed_at = Reader.timestamp r in
218
Added:
{ WI.exercise_id; load; reps; performed_at }
219
Added:
220
Added:
(* --- promotion snapshot --- *)
221
Added:
222
Added:
let write_promotion buf (p : WI.promoted_snapshot) =
223
Added:
Writer.string buf p.title;
224
Added:
Writer.timestamp buf p.started_at;
225
Added:
Writer.timestamp buf p.ended_at;
226
Added:
Writer.list write_observation buf p.observations;
227
Added:
Writer.list Writer.int buf p.source_rows;
228
Added:
Writer.option Writer.string buf p.normal_confirmation;
229
Added:
Writer.int buf p.revision
230
Added:
231
Added:
(* --- workout snapshot --- *)
232
Added:
233
Added:
let write_workout buf (w : WI.workout_snapshot) =
234
Added:
Writer.string buf (WI.workout_id_to_string w.id);
235
Added:
Writer.string buf w.title;
236
Added:
Writer.timestamp buf w.started_at;
237
Added:
Writer.timestamp buf w.ended_at;
238
Added:
Writer.list write_source_set buf w.sets;
239
Added:
Writer.list write_mapping buf w.mappings;
240
Added:
Writer.option Writer.string buf w.acknowledgement;
241
Added:
Writer.int buf w.revision;
242
Added:
Writer.option write_promotion buf w.promotion
243
Added:
244
Added:
(* --- snapshot --- *)
245
Added:
246
Added:
let encode_snapshot (s : WI.snapshot) =
247
Added:
let buf = Writer.create () in
248
Added:
Writer.string buf (WI.batch_id_to_string s.batch_id);
249
Added:
Writer.string buf s.source;
250
Added:
Writer.string buf s.fingerprint;
251
Added:
Writer.timestamp buf s.imported_at;
252
Added:
Writer.list write_workout buf s.workouts;
253
Added:
Writer.list write_warning buf s.warnings;
254
Added:
Writer.contents buf
255
Added:
256
Added:
(* Reading a snapshot builds the parser-free {!WI.snapshot}, keeping every
257
Added:
exercise id as a raw string. Restoration through {!WI.restore} resolves the
258
Added:
ids and rebuilds the opaque batch, so an unknown id or an invalid time is
259
Added:
reported once, by the use case. *)
260
Added:
let read_promotion r : WI.promoted_snapshot =
261
Added:
let title = Reader.string r in
262
Added:
let started_at = Reader.timestamp r in
263
Added:
let ended_at = Reader.timestamp r in
264
Added:
let observations = Reader.list read_observation_snapshot r in
265
Added:
let source_rows = Reader.list Reader.int r in
266
Added:
let normal_confirmation = Reader.option Reader.string r in
267
Added:
let revision = Reader.int r in
268
Added:
{
269
Added:
WI.title;
270
Added:
started_at;
271
Added:
ended_at;
272
Added:
observations;
273
Added:
source_rows;
274
Added:
normal_confirmation;
275
Added:
revision;
276
Added:
}
277
Added:
278
Added:
let read_workout r : WI.workout_snapshot =
279
Added:
let id = WI.workout_id (Reader.string r) in
280
Added:
let title = Reader.string r in
281
Added:
let started_at = Reader.timestamp r in
282
Added:
let ended_at = Reader.timestamp r in
283
Added:
let sets = Reader.list read_source_set r in
284
Added:
let mappings = Reader.list read_mapping r in
285
Added:
let acknowledgement = Reader.option Reader.string r in
286
Added:
let revision = Reader.int r in
287
Added:
let promotion = Reader.option read_promotion r in
288
Added:
{
289
Added:
WI.id;
290
Added:
title;
291
Added:
started_at;
292
Added:
ended_at;
293
Added:
sets;
294
Added:
mappings;
295
Added:
acknowledgement;
296
Added:
revision;
297
Added:
promotion;
298
Added:
}
299
Added:
300
Added:
let read_snapshot r : WI.snapshot =
301
Added:
let batch_id = WI.batch_id (Reader.string r) in
302
Added:
let source = Reader.string r in
303
Added:
let fingerprint = Reader.string r in
304
Added:
let imported_at = Reader.timestamp r in
305
Added:
let workouts = Reader.list read_workout r in
306
Added:
let warnings = Reader.list read_warning r in
307
Added:
{ WI.batch_id; source; fingerprint; imported_at; workouts; warnings }
308
Added:
309
Added:
let restore_error : WI.restore_error -> error = function
310
Added:
| WI.Unknown_exercise id -> Unknown_exercise id
311
Added:
| WI.Invalid_time -> Invalid_time
312
Added:
313
Added:
let decode_snapshot ~find_exercise text =
314
Added:
match Reader.run text read_snapshot with
315
Added:
| Error _ as e -> e
316
Added:
| Ok snapshot -> (
317
Added:
match WI.restore ~find_exercise snapshot with
318
Added:
| Ok batch -> Ok batch
319
Added:
| Error e -> Error (restore_error e))
320
Added:
321
Added:
(* --- imported record --- *)
322
Added:
323
Added:
let encode_record (rec_ : Repository.imported_record) =
324
Added:
let buf = Writer.create () in
325
Added:
Writer.string buf (WI.batch_id_to_string rec_.batch_id);
326
Added:
Writer.string buf (WI.workout_id_to_string rec_.workout_id);
327
Added:
Writer.int buf rec_.revision;
328
Added:
Writer.string buf rec_.title;
329
Added:
Writer.timestamp buf rec_.started_at;
330
Added:
Writer.timestamp buf rec_.ended_at;
331
Added:
(* An observation is exercise id, load, reps, performed time: a promoted
332
Added:
outcome is always Positive_failure, so the outcome is implicit. *)
333
Added:
Writer.list
334
Added:
(fun buf obs ->
335
Added:
let effort = Evidence.Observation.effort obs in
336
Added:
Writer.string buf
337
Added:
(Exercise.id (Evidence.Stimulus.Effort.exercise effort) :> string);
338
Added:
Writer.float buf (Evidence.Stimulus.Effort.load effort);
339
Added:
Writer.int buf (Evidence.Stimulus.Effort.reps effort);
340
Added:
Writer.timestamp buf (Evidence.Observation.performed_at obs))
341
Added:
buf rec_.observations;
342
Added:
(* Provenance. The batch and workout ids repeat the record's own; storing them
343
Added:
keeps the provenance self-contained after a decode. *)
344
Added:
Writer.string buf (WI.batch_id_to_string rec_.provenance.batch_id);
345
Added:
Writer.string buf (WI.workout_id_to_string rec_.provenance.workout_id);
346
Added:
Writer.list Writer.int buf rec_.provenance.source_rows;
347
Added:
Writer.option Writer.string buf rec_.provenance.normal_confirmation;
348
Added:
Writer.int buf rec_.provenance.revision;
349
Added:
Writer.contents buf
350
Added:
351
Added:
(* Read the record's framing. Observations resolve their exercise through the
352
Added:
catalog during the read, so an unknown id surfaces as [Unknown_exercise]. *)
353
Added:
let read_record r : Repository.imported_record =
354
Added:
let batch_id = Reader.string r in
355
Added:
let workout_id = Reader.string r in
356
Added:
let revision = Reader.int r in
357
Added:
let title = Reader.string r in
358
Added:
let started_at = Reader.timestamp r in
359
Added:
let ended_at = Reader.timestamp r in
360
Added:
let observations =
361
Added:
Reader.list
362
Added:
(fun r ->
363
Added:
let exercise = Reader.exercise r in
364
Added:
let load = Reader.float r in
365
Added:
let reps = Reader.int r in
366
Added:
let performed_at = Reader.timestamp r in
367
Added:
let effort =
368
Added:
Evidence.Stimulus.Effort.make ~exercise ~load ~reps
369
Added:
~outcome:Evidence.Stimulus.Positive_failure
370
Added:
in
371
Added:
Evidence.Observation.make ~exercise ~effort ~performed_at)
372
Added:
r
373
Added:
in
374
Added:
let prov_batch_id = Reader.string r in
375
Added:
let prov_workout_id = Reader.string r in
376
Added:
let source_rows = Reader.list Reader.int r in
377
Added:
let normal_confirmation = Reader.option Reader.string r in
378
Added:
let prov_revision = Reader.int r in
379
Added:
{
380
Added:
Repository.batch_id = WI.batch_id batch_id;
381
Added:
workout_id = WI.workout_id workout_id;
382
Added:
revision;
383
Added:
title;
384
Added:
started_at;
385
Added:
ended_at;
386
Added:
observations;
387
Added:
provenance =
388
Added:
{
389
Added:
WI.batch_id = WI.batch_id prov_batch_id;
390
Added:
workout_id = WI.workout_id prov_workout_id;
391
Added:
source_rows;
392
Added:
normal_confirmation;
393
Added:
revision = prov_revision;
394
Added:
};
395
Added:
}
396
Added:
397
Added:
let decode_record text =
398
Added:
match Reader.run text read_record with
399
Added:
| Error _ as e -> e
400
Added:
| Ok record ->
401
Added:
if
402
Added:
Recovery.timestamp_to_unix_seconds record.Repository.ended_at
403
Added:
< Recovery.timestamp_to_unix_seconds record.Repository.started_at
404
Added:
then Error Invalid_time
405
Added:
else Ok record
lib/persistence/import_codec.mli
@@ -0,0 +1,46 @@
1
Added:
(** Serialization of import batches and promoted records for durable storage.
2
Added:
3
Added:
The import use case is provisional: a batch holds raw third-party source,
4
Added:
per-workout mappings and acknowledgements, and any promotions made so far. A
5
Added:
repository must store and restore that state without the third-party parser,
6
Added:
so this module encodes {!Hito_app.Workout_import.snapshot} — the parser-free
7
Added:
view — and {!Hito_app.Repository.imported_record}, the canonical promoted
8
Added:
evidence.
9
Added:
10
Added:
The wire format is a length-prefixed field framing: every field is written
11
Added:
as its byte length, a colon, then its raw bytes. Because the length is
12
Added:
counted in bytes and the bytes are copied verbatim, a field may hold
13
Added:
arbitrary UTF-8, newlines, commas, or colons — the export source, an
14
Added:
acknowledgement, a title, or an unsupported-row reason is preserved exactly.
15
Added:
No {!Marshal}, no {!Obj}: the format is textual and self-describing.
16
Added:
17
Added:
Timestamps reuse {!Timestamp}. Exercise ids resolve through
18
Added:
{!Hito_core.Exercise.find_id}. A decode failure is a module-specific
19
Added:
{!error}. A repository turns it into a fault, never a silent loss. *)
20
Added:
21
Added:
open Hito_app
22
Added:
23
Added:
type error =
24
Added:
| Malformed of string (** The stored text does not parse. *)
25
Added:
| Unknown_exercise of string
26
Added:
(** A stored exercise id is not in the catalog. *)
27
Added:
| Invalid_time (** A stored [ended_at] precedes its [started_at]. *)
28
Added:
29
Added:
val pp_error : Format.formatter -> error -> unit
30
Added:
31
Added:
val encode_snapshot : Workout_import.snapshot -> string
32
Added:
(** A stable, single-string encoding of an import batch snapshot. *)
33
Added:
34
Added:
val decode_snapshot :
35
Added:
find_exercise:(Exercise.id -> Exercise.t option) ->
36
Added:
string ->
37
Added:
(Workout_import.batch, error) result
38
Added:
(** Decode a batch snapshot and restore the opaque batch, resolving each
39
Added:
exercise id through [find_exercise]. *)
40
Added:
41
Added:
val encode_record : Repository.imported_record -> string
42
Added:
(** A stable, single-string encoding of a promoted record. *)
43
Added:
44
Added:
val decode_record : string -> (Repository.imported_record, error) result
45
Added:
(** Decode a promoted record, resolving each observation's exercise id through
46
Added:
{!Hito_core.Exercise.find_id}. *)
lib/persistence/memory_repo.ml
@@ -6,6 +6,9 @@
6
6
mutable current : Evidence.Workout.t option;
7
7
mutable stored : Repository.record list; (* most recent first *)
8
8
mutable feedback : Evidence.Feedback.t list; (* most recent first *)
9
Added:
mutable batches : Workout_import.batch list;
10
Added:
(* insertion order, newest first *)
11
Added:
mutable records : Repository.imported_record list; (* newest ended_at first *)
9
12
mutable next_id : int;
10
13
mutable next_app_feedback : int;
11
14
}
@@ -38,6 +41,8 @@
38
41
current = None;
39
42
stored = [];
40
43
feedback = [];
44
Added:
batches = [];
45
Added:
records = [];
41
46
next_id = 1;
42
47
next_app_feedback = 1;
43
48
}
@@ -399,3 +404,92 @@
399
404
t.app_feedback_votes
400
405
end;
401
406
Lwt.return removed
407
Added:
408
Added:
(* --- workout import --- *)
409
Added:
410
Added:
let batch_id_eq a b =
411
Added:
String.equal
412
Added:
(Workout_import.batch_id_to_string a)
413
Added:
(Workout_import.batch_id_to_string b)
414
Added:
415
Added:
(* Upsert a batch by its identity, dropping any earlier version and prepending
416
Added:
the new one so the list stays newest-first by insertion. *)
417
Added:
let save_import_batch t id batch =
418
Added:
let s = state t id in
419
Added:
let identity = Workout_import.batch_identity batch in
420
Added:
s.batches <-
421
Added:
batch
422
Added:
:: List.filter
423
Added:
(fun b -> not (batch_id_eq (Workout_import.batch_identity b) identity))
424
Added:
s.batches;
425
Added:
Lwt.return_unit
426
Added:
427
Added:
let find_import_batch t id batch_id =
428
Added:
let s = state t id in
429
Added:
Lwt.return
430
Added:
(List.find_opt
431
Added:
(fun b -> batch_id_eq (Workout_import.batch_identity b) batch_id)
432
Added:
s.batches)
433
Added:
434
Added:
(* Most recent [imported_at] first; ties broken by batch id descending, for a
435
Added:
deterministic order that does not depend on insertion. *)
436
Added:
let import_batches t id =
437
Added:
let s = state t id in
438
Added:
let compare a b =
439
Added:
let by_time =
440
Added:
Int.compare
441
Added:
(Recovery.timestamp_to_unix_seconds
442
Added:
(Workout_import.batch_imported_at b))
443
Added:
(Recovery.timestamp_to_unix_seconds
444
Added:
(Workout_import.batch_imported_at a))
445
Added:
in
446
Added:
if by_time <> 0 then by_time
447
Added:
else
448
Added:
String.compare
449
Added:
(Workout_import.batch_id_to_string (Workout_import.batch_identity b))
450
Added:
(Workout_import.batch_id_to_string (Workout_import.batch_identity a))
451
Added:
in
452
Added:
Lwt.return (List.stable_sort compare s.batches)
453
Added:
454
Added:
(* Deleting a provisional batch never touches promoted records: their lifecycle
455
Added:
is independent. *)
456
Added:
let delete_import_batch t id batch_id =
457
Added:
let s = state t id in
458
Added:
let present =
459
Added:
List.exists
460
Added:
(fun b -> batch_id_eq (Workout_import.batch_identity b) batch_id)
461
Added:
s.batches
462
Added:
in
463
Added:
if present then
464
Added:
s.batches <-
465
Added:
List.filter
466
Added:
(fun b -> not (batch_id_eq (Workout_import.batch_identity b) batch_id))
467
Added:
s.batches;
468
Added:
Lwt.return present
469
Added:
470
Added:
let workout_id_eq a b =
471
Added:
String.equal
472
Added:
(Workout_import.workout_id_to_string a)
473
Added:
(Workout_import.workout_id_to_string b)
474
Added:
475
Added:
(* Atomic upsert keyed by workout id: a re-promotion replaces the observations
476
Added:
and revision of the prior record for the same workout. *)
477
Added:
let replace_imported_record t id record =
478
Added:
let s = state t id in
479
Added:
s.records <-
480
Added:
record
481
Added:
:: List.filter
482
Added:
(fun r ->
483
Added:
not
484
Added:
(workout_id_eq r.Repository.workout_id record.Repository.workout_id))
485
Added:
s.records;
486
Added:
Lwt.return_unit
487
Added:
488
Added:
let imported_records t id =
489
Added:
let s = state t id in
490
Added:
let compare a b =
491
Added:
Int.compare
492
Added:
(Recovery.timestamp_to_unix_seconds b.Repository.ended_at)
493
Added:
(Recovery.timestamp_to_unix_seconds a.Repository.ended_at)
494
Added:
in
495
Added:
Lwt.return (List.stable_sort compare s.records)
lib/persistence/migrations.ml
@@ -152,6 +152,44 @@
152
152
ON feedback (trainee_id, seq DESC)|};
153
153
];
154
154
};
155
Added:
{
156
Added:
version = 7;
157
Added:
name = "workout import batches and promoted records";
158
Added:
(* An import batch is provisional: it holds the raw export source and the
159
Added:
cleaning done so far, encoded as one snapshot blob. A promoted record
160
Added:
is canonical evidence with an independent lifecycle, so it carries no
161
Added:
foreign key to its batch — deleting the batch must never cascade to the
162
Added:
record. The batch's [imported_at] is stored as a column so listing can
163
Added:
order without decoding every blob. A record is keyed by (trainee,
164
Added:
workout) so a re-promotion replaces it. *)
165
Added:
statements =
166
Added:
[
167
Added:
{|CREATE TABLE IF NOT EXISTS import_batch (
168
Added:
trainee_id TEXT NOT NULL,
169
Added:
batch_id TEXT NOT NULL,
170
Added:
imported_at TEXT NOT NULL,
171
Added:
source TEXT NOT NULL,
172
Added:
fingerprint TEXT NOT NULL,
173
Added:
snapshot TEXT NOT NULL,
174
Added:
PRIMARY KEY (trainee_id, batch_id)
175
Added:
)|};
176
Added:
{|CREATE INDEX IF NOT EXISTS import_batch_by_trainee
177
Added:
ON import_batch (trainee_id, imported_at DESC, batch_id DESC)|};
178
Added:
{|CREATE TABLE IF NOT EXISTS imported_record (
179
Added:
trainee_id TEXT NOT NULL,
180
Added:
workout_id TEXT NOT NULL,
181
Added:
batch_id TEXT NOT NULL,
182
Added:
revision INTEGER NOT NULL,
183
Added:
title TEXT NOT NULL,
184
Added:
started_at TEXT NOT NULL,
185
Added:
ended_at TEXT NOT NULL,
186
Added:
snapshot TEXT NOT NULL,
187
Added:
PRIMARY KEY (trainee_id, workout_id)
188
Added:
)|};
189
Added:
{|CREATE INDEX IF NOT EXISTS imported_record_by_trainee
190
Added:
ON imported_record (trainee_id, ended_at DESC)|};
191
Added:
];
192
Added:
};
155
193
]
156
194
157
195
(* The ledger of applied migrations. A row per version, so a reconnect knows
lib/persistence/sqlite_repo.ml
@@ -2,6 +2,7 @@
2
2
open Hito_app
3
3
4
4
exception Corrupt of Codec.error
5
Added:
exception Import_corrupt of Import_codec.error
5
6
6
7
type t = {
7
8
pool : (Caqti_lwt.connection, Caqti_error.t) Caqti_lwt_unix.Pool.t;
@@ -138,6 +139,47 @@
138
139
let delete_app_feedback =
139
140
(t2 string int ->. unit)
140
141
"DELETE FROM app_feedback WHERE trainee_id = ? AND seq = ?"
142
Added:
143
Added:
(* --- workout import --- *)
144
Added:
145
Added:
let upsert_import_batch =
146
Added:
(t6 string string string string string string ->. unit)
147
Added:
"INSERT INTO import_batch (trainee_id, batch_id, imported_at, source, \
148
Added:
fingerprint, snapshot) VALUES (?, ?, ?, ?, ?, ?) ON CONFLICT \
149
Added:
(trainee_id, batch_id) DO UPDATE SET imported_at = \
150
Added:
excluded.imported_at, source = excluded.source, fingerprint = \
151
Added:
excluded.fingerprint, snapshot = excluded.snapshot"
152
Added:
153
Added:
let import_batch_by_id =
154
Added:
(t2 string string ->? string)
155
Added:
"SELECT snapshot FROM import_batch WHERE trainee_id = ? AND batch_id = ?"
156
Added:
157
Added:
let import_batches =
158
Added:
(string ->* string)
159
Added:
"SELECT snapshot FROM import_batch WHERE trainee_id = ? ORDER BY \
160
Added:
imported_at DESC, batch_id DESC"
161
Added:
162
Added:
let delete_import_batch =
163
Added:
(t2 string string ->. unit)
164
Added:
"DELETE FROM import_batch WHERE trainee_id = ? AND batch_id = ?"
165
Added:
166
Added:
let import_batch_exists =
167
Added:
(t2 string string ->? int)
168
Added:
"SELECT 1 FROM import_batch WHERE trainee_id = ? AND batch_id = ?"
169
Added:
170
Added:
let upsert_imported_record =
171
Added:
(t2 (t4 string string string int) (t4 string string string string) ->. unit)
172
Added:
"INSERT INTO imported_record (trainee_id, workout_id, batch_id, \
173
Added:
revision, title, started_at, ended_at, snapshot) VALUES (?, ?, ?, ?, ?, \
174
Added:
?, ?, ?) ON CONFLICT (trainee_id, workout_id) DO UPDATE SET batch_id = \
175
Added:
excluded.batch_id, revision = excluded.revision, title = \
176
Added:
excluded.title, started_at = excluded.started_at, ended_at = \
177
Added:
excluded.ended_at, snapshot = excluded.snapshot"
178
Added:
179
Added:
let imported_records =
180
Added:
(string ->* string)
181
Added:
"SELECT snapshot FROM imported_record WHERE trainee_id = ? ORDER BY \
182
Added:
ended_at DESC"
141
183
end
142
184
143
185
(* --- pool helper --- *)
@@ -477,3 +519,77 @@
477
519
Db.exec Q.delete_app_feedback (trainee, seq))
478
520
>|= fun () -> true
479
521
| _ -> Lwt.return false)
522
Added:
523
Added:
(* --- workout import --- *)
524
Added:
525
Added:
(* Snapshots resolve their exercise ids through the catalog. The id type is
526
Added:
private, so the lookup goes through the raw string. *)
527
Added:
let find_exercise (id : Exercise.id) = Exercise.find_id (id :> string)
528
Added:
529
Added:
let decode_batch encoded =
530
Added:
match Import_codec.decode_snapshot ~find_exercise encoded with
531
Added:
| Ok batch -> batch
532
Added:
| Error e -> raise (Import_corrupt e)
533
Added:
534
Added:
let decode_record encoded =
535
Added:
match Import_codec.decode_record encoded with
536
Added:
| Ok record -> record
537
Added:
| Error e -> raise (Import_corrupt e)
538
Added:
539
Added:
let save_import_batch t id batch =
540
Added:
let trainee = Trainee.id_to_string id in
541
Added:
let batch_id =
542
Added:
Workout_import.batch_id_to_string (Workout_import.batch_identity batch)
543
Added:
in
544
Added:
let imported_at = Timestamp.encode (Workout_import.batch_imported_at batch) in
545
Added:
let source = Workout_import.batch_source batch in
546
Added:
let fingerprint = Workout_import.batch_fingerprint batch in
547
Added:
let snapshot = Import_codec.encode_snapshot (Workout_import.snapshot batch) in
548
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
549
Added:
Db.exec Q.upsert_import_batch
550
Added:
(trainee, batch_id, imported_at, source, fingerprint, snapshot))
551
Added:
552
Added:
let find_import_batch t id batch_id =
553
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
554
Added:
Db.find_opt Q.import_batch_by_id
555
Added:
(Trainee.id_to_string id, Workout_import.batch_id_to_string batch_id))
556
Added:
>|= function
557
Added:
| None -> None
558
Added:
| Some encoded -> Some (decode_batch encoded)
559
Added:
560
Added:
let import_batches t id =
561
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
562
Added:
Db.collect_list Q.import_batches (Trainee.id_to_string id))
563
Added:
>|= List.map decode_batch
564
Added:
565
Added:
(* Deleting a provisional batch leaves its promoted records: there is no foreign
566
Added:
key, so no cascade can reach them. *)
567
Added:
let delete_import_batch t id batch_id =
568
Added:
let trainee = Trainee.id_to_string id in
569
Added:
let batch_id = Workout_import.batch_id_to_string batch_id in
570
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
571
Added:
Db.find_opt Q.import_batch_exists (trainee, batch_id))
572
Added:
>>= function
573
Added:
| None -> Lwt.return false
574
Added:
| Some _ ->
575
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
576
Added:
Db.exec Q.delete_import_batch (trainee, batch_id))
577
Added:
>|= fun () -> true
578
Added:
579
Added:
let replace_imported_record t id (record : Repository.imported_record) =
580
Added:
let trainee = Trainee.id_to_string id in
581
Added:
let workout_id = Workout_import.workout_id_to_string record.workout_id in
582
Added:
let batch_id = Workout_import.batch_id_to_string record.batch_id in
583
Added:
let title = record.title in
584
Added:
let started_at = Timestamp.encode record.started_at in
585
Added:
let ended_at = Timestamp.encode record.ended_at in
586
Added:
let snapshot = Import_codec.encode_record record in
587
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
588
Added:
Db.exec Q.upsert_imported_record
589
Added:
( (trainee, workout_id, batch_id, record.revision),
590
Added:
(title, started_at, ended_at, snapshot) ))
591
Added:
592
Added:
let imported_records t id =
593
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
594
Added:
Db.collect_list Q.imported_records (Trainee.id_to_string id))
595
Added:
>|= List.map decode_record
lib/persistence/sqlite_repo.mli
@@ -17,6 +17,11 @@
17
17
catalog that no longer names a stored routine or workout. This is a fault,
18
18
not a normal outcome. *)
19
19
20
Added:
exception Import_corrupt of Import_codec.error
21
Added:
(** Raised when a stored import batch or promoted record cannot be decoded — a
22
Added:
corrupted database or a catalog that no longer names a stored exercise. This
23
Added:
is a fault, not a normal outcome. *)
24
Added:
20
25
val connect : string -> (t, Caqti_error.t) result Lwt.t
21
26
(** [connect uri] opens a connection pool and applies {!Migrations}. [uri] is a
22
27
Caqti URI such as ["sqlite3:hito.sqlite"]. *)
test/dune
@@ -11,6 +11,9 @@
11
11
test_service
12
12
test_workout_import
13
13
test_codec
14
Added:
test_import_codec
15
Added:
test_import_repo
16
Added:
test_import_sqlite
14
17
test_bcrypt_hash
15
18
test_sqlite_repo
16
19
test_decode
test/test_hito.ml
@@ -10,5 +10,6 @@
10
10
(Test_architecture.suite @ Test_exercise.suite @ Test_recovery.suite
11
11
@ Test_prescription.suite @ Test_evidence.suite @ Test_progression.suite
12
12
@ Test_service.suite @ Test_workout_import.suite @ Test_codec.suite
13
Added:
@ Test_import_codec.suite @ Test_import_repo.suite @ Test_import_sqlite.suite
13
14
@ Test_bcrypt_hash.suite @ Test_sqlite_repo.suite @ Test_decode.suite
14
15
@ Test_hevy_csv.suite @ Test_web.suite)
test/test_import_codec.ml
@@ -0,0 +1,239 @@
1
Added:
(** Tests for {!Hito_persistence.Import_codec} — the length-prefixed framing for
2
Added:
import batches and promoted records. The framing must preserve arbitrary
3
Added:
bytes in every free-text field, and a decode must rebuild the batch and its
4
Added:
promotion exactly, so {!Already_promoted} and edited re-promotion survive a
5
Added:
reconnect. *)
6
Added:
7
Added:
open Hito_app
8
Added:
open Hito_persistence
9
Added:
module WI = Workout_import
10
Added:
11
Added:
let get id =
12
Added:
match Exercise.find_id id with
13
Added:
| Some e -> e
14
Added:
| None -> Alcotest.failf "catalog is missing %S" id
15
Added:
16
Added:
let at s = Recovery.timestamp_of_unix_seconds s
17
Added:
let ok = function Ok v -> v | Error _ -> Alcotest.fail "expected Ok"
18
Added:
let find_exercise (id : Exercise.id) = Exercise.find_id (id :> string)
19
Added:
let wid = WI.workout_id
20
Added:
21
Added:
(* Awkward text: commas, newlines, colons, and non-ASCII UTF-8. A length-prefixed
22
Added:
field must carry every byte verbatim. *)
23
Added:
let nasty = "a,b\nc:d\t\"quote\" — café 🏋️, 12:corrupt\n99:end"
24
Added:
25
Added:
let set ?(row = 0) ?(set_index = 1) ?(superset_id = None) ~name ~kind ~kg ~reps
26
Added:
() : WI.source_set =
27
Added:
{
28
Added:
row;
29
Added:
exercise_name = name;
30
Added:
set_index;
31
Added:
set_type = kind;
32
Added:
weight_kg = kg;
33
Added:
reps;
34
Added:
superset_id;
35
Added:
}
36
Added:
37
Added:
(* A batch with a failure set and a normal set, both under one awkward exercise
38
Added:
name, plus an awkward warning and awkward source text. *)
39
Added:
let sample_batch () =
40
Added:
let sets =
41
Added:
[
42
Added:
set ~row:1 ~name:nasty ~kind:WI.Failure ~kg:102.5 ~reps:8 ();
43
Added:
set ~row:2 ~name:nasty ~kind:WI.Normal ~kg:60.0 ~reps:10
44
Added:
~superset_id:(Some 3) ();
45
Added:
]
46
Added:
in
47
Added:
let w =
48
Added:
ok
49
Added:
(WI.make_workout ~id:(wid "w1") ~title:nasty ~started_at:(at 1_000)
50
Added:
~ended_at:(at 4_600) ~sets)
51
Added:
in
52
Added:
let warnings =
53
Added:
[
54
Added:
{
55
Added:
WI.row = 7;
56
Added:
exercise_name = Some nasty;
57
Added:
kind = WI.Unsupported_row nasty;
58
Added:
};
59
Added:
]
60
Added:
in
61
Added:
WI.make_batch ~id:(WI.batch_id "b1") ~source:nasty ~fingerprint:"fp-🔒"
62
Added:
~imported_at:(at 5_000) ~workouts:[ w ] ~warnings
63
Added:
64
Added:
(* Map, acknowledge, and promote, so the snapshot carries a promotion. *)
65
Added:
let promoted_batch () =
66
Added:
let b = sample_batch () in
67
Added:
let b =
68
Added:
ok (WI.map_exercise b ~workout:(wid "w1") ~source_name:nasty (get "squats"))
69
Added:
in
70
Added:
let b =
71
Added:
ok (WI.confirm_normal_sets b ~workout:(wid "w1") ~acknowledgement:nasty)
72
Added:
in
73
Added:
let b, _ = ok (WI.promote_workout b (wid "w1")) in
74
Added:
b
75
Added:
76
Added:
let roundtrip_batch b =
77
Added:
let encoded = Import_codec.encode_snapshot (WI.snapshot b) in
78
Added:
match Import_codec.decode_snapshot ~find_exercise encoded with
79
Added:
| Ok b' -> b'
80
Added:
| Error e -> Alcotest.failf "decode failed: %a" Import_codec.pp_error e
81
Added:
82
Added:
let codec_tests =
83
Added:
[
84
Added:
( "an unpromoted batch round-trips, preserving special characters",
85
Added:
`Quick,
86
Added:
fun () ->
87
Added:
let b = sample_batch () in
88
Added:
let d = roundtrip_batch b in
89
Added:
Alcotest.(check string)
90
Added:
"source verbatim" (WI.batch_source b) (WI.batch_source d);
91
Added:
Alcotest.(check string)
92
Added:
"fingerprint verbatim" (WI.batch_fingerprint b)
93
Added:
(WI.batch_fingerprint d);
94
Added:
Alcotest.(check int)
95
Added:
"imported_at seconds"
96
Added:
(Recovery.timestamp_to_unix_seconds (WI.batch_imported_at b))
97
Added:
(Recovery.timestamp_to_unix_seconds (WI.batch_imported_at d));
98
Added:
let w = Option.get (WI.find_workout d (wid "w1")) in
99
Added:
Alcotest.(check string) "title verbatim" nasty (WI.workout_title w);
100
Added:
Alcotest.(check int) "two sets" 2 (List.length (WI.workout_sets w));
101
Added:
match WI.batch_warnings d with
102
Added:
| [ { kind = WI.Unsupported_row detail; exercise_name = Some name; _ } ]
103
Added:
->
104
Added:
Alcotest.(check string) "warning detail verbatim" nasty detail;
105
Added:
Alcotest.(check string) "warning name verbatim" nasty name
106
Added:
| _ -> Alcotest.fail "expected one unsupported-row warning" );
107
Added:
( "a mapping round-trips and stays confirmed",
108
Added:
`Quick,
109
Added:
fun () ->
110
Added:
let b = sample_batch () in
111
Added:
let b =
112
Added:
ok
113
Added:
(WI.map_exercise b ~workout:(wid "w1") ~source_name:nasty
114
Added:
(get "squats"))
115
Added:
in
116
Added:
let d = roundtrip_batch b in
117
Added:
let w = Option.get (WI.find_workout d (wid "w1")) in
118
Added:
match WI.workout_mapping w ~source_name:nasty with
119
Added:
| Some e ->
120
Added:
Alcotest.(check bool)
121
Added:
"mapped to squats" true
122
Added:
(Exercise.equal e (get "squats"))
123
Added:
| None -> Alcotest.fail "expected the mapping to survive" );
124
Added:
( "a promotion round-trips, preserving acknowledgement and revision",
125
Added:
`Quick,
126
Added:
fun () ->
127
Added:
let b = promoted_batch () in
128
Added:
let d = roundtrip_batch b in
129
Added:
let w = Option.get (WI.find_workout d (wid "w1")) in
130
Added:
Alcotest.(check string)
131
Added:
"acknowledgement verbatim" nasty
132
Added:
(Option.get (WI.workout_acknowledgement w));
133
Added:
(* Re-promoting the decoded batch at the same revision is idempotent:
134
Added:
the promotion survived the round-trip. *)
135
Added:
let _, result = ok (WI.promote_workout d (wid "w1")) in
136
Added:
match result with
137
Added:
| WI.Already_promoted p ->
138
Added:
Alcotest.(check int)
139
Added:
"two observations" 2
140
Added:
(List.length p.observations);
141
Added:
Alcotest.(check (option string))
142
Added:
"normal confirmation verbatim" (Some nasty)
143
Added:
p.provenance.normal_confirmation
144
Added:
| WI.Promoted _ ->
145
Added:
Alcotest.fail "expected Already_promoted, not a fresh promotion"
146
Added:
| WI.Blocked _ -> Alcotest.fail "expected Already_promoted, not Blocked"
147
Added:
);
148
Added:
( "an unknown exercise id in a snapshot is reported, not raised",
149
Added:
`Quick,
150
Added:
fun () ->
151
Added:
let b = promoted_batch () in
152
Added:
let encoded = Import_codec.encode_snapshot (WI.snapshot b) in
153
Added:
(* Resolve nothing: every id is unknown to this catalog view. *)
154
Added:
match
155
Added:
Import_codec.decode_snapshot ~find_exercise:(fun _ -> None) encoded
156
Added:
with
157
Added:
| Error (Import_codec.Unknown_exercise _) -> ()
158
Added:
| _ -> Alcotest.fail "expected Unknown_exercise" );
159
Added:
( "truncated framing is reported as malformed",
160
Added:
`Quick,
161
Added:
fun () ->
162
Added:
match
163
Added:
Import_codec.decode_snapshot ~find_exercise "100:not-that-long"
164
Added:
with
165
Added:
| Error (Import_codec.Malformed _) -> ()
166
Added:
| _ -> Alcotest.fail "expected Malformed" );
167
Added:
]
168
Added:
169
Added:
(* A promoted record built straight from a promotion, for the record codec. *)
170
Added:
let sample_record () : Repository.imported_record =
171
Added:
let b = promoted_batch () in
172
Added:
match WI.snapshot b with
173
Added:
| { workouts = [ { promotion = Some p; id; _ } ]; batch_id; _ } ->
174
Added:
let observations =
175
Added:
List.map
176
Added:
(fun (o : WI.observation_snapshot) ->
177
Added:
let exercise = get (o.exercise_id :> string) in
178
Added:
let effort =
179
Added:
Evidence.Stimulus.Effort.make ~exercise ~load:o.load ~reps:o.reps
180
Added:
~outcome:Evidence.Stimulus.Positive_failure
181
Added:
in
182
Added:
Evidence.Observation.make ~exercise ~effort
183
Added:
~performed_at:o.performed_at)
184
Added:
p.observations
185
Added:
in
186
Added:
{
187
Added:
batch_id;
188
Added:
workout_id = id;
189
Added:
revision = p.revision;
190
Added:
title = p.title;
191
Added:
started_at = p.started_at;
192
Added:
ended_at = p.ended_at;
193
Added:
observations;
194
Added:
provenance =
195
Added:
{
196
Added:
WI.batch_id;
197
Added:
workout_id = id;
198
Added:
source_rows = p.source_rows;
199
Added:
normal_confirmation = p.normal_confirmation;
200
Added:
revision = p.revision;
201
Added:
};
202
Added:
}
203
Added:
| _ -> Alcotest.fail "expected one promoted workout in the snapshot"
204
Added:
205
Added:
let record_tests =
206
Added:
[
207
Added:
( "a promoted record round-trips, preserving special characters",
208
Added:
`Quick,
209
Added:
fun () ->
210
Added:
let r = sample_record () in
211
Added:
let encoded = Import_codec.encode_record r in
212
Added:
match Import_codec.decode_record encoded with
213
Added:
| Ok d ->
214
Added:
Alcotest.(check string) "title verbatim" nasty d.Repository.title;
215
Added:
Alcotest.(check int) "revision" r.revision d.revision;
216
Added:
Alcotest.(check int)
217
Added:
"same observation count"
218
Added:
(List.length r.observations)
219
Added:
(List.length d.observations);
220
Added:
Alcotest.(check (option string))
221
Added:
"normal confirmation verbatim" (Some nasty)
222
Added:
d.provenance.normal_confirmation;
223
Added:
Alcotest.(check (list int))
224
Added:
"source rows" r.provenance.source_rows d.provenance.source_rows
225
Added:
| Error e -> Alcotest.failf "decode failed: %a" Import_codec.pp_error e
226
Added:
);
227
Added:
( "truncated record framing is reported, not raised",
228
Added:
`Quick,
229
Added:
fun () ->
230
Added:
let r = sample_record () in
231
Added:
let encoded = Import_codec.encode_record r in
232
Added:
(* Drop the final byte: the framing no longer lines up. *)
233
Added:
let truncated = String.sub encoded 0 (String.length encoded - 1) in
234
Added:
match Import_codec.decode_record truncated with
235
Added:
| Error _ -> ()
236
Added:
| Ok _ -> Alcotest.fail "expected a decode error on truncated text" );
237
Added:
]
238
Added:
239
Added:
let suite = [ ("import_codec", codec_tests); ("import_record", record_tests) ]
test/test_import_repo.ml
@@ -0,0 +1,235 @@
1
Added:
(** Tests for the workout-import persistence operations on {!Memory_repo}:
2
Added:
per-trainee isolation, deterministic ordering, that deleting a provisional
3
Added:
batch leaves promoted records, and that a promoted record is replaced by
4
Added:
workout id. *)
5
Added:
6
Added:
open Hito_app
7
Added:
open Hito_persistence
8
Added:
module WI = Workout_import
9
Added:
10
Added:
let run = Lwt_main.run
11
Added:
12
Added:
let get id =
13
Added:
match Exercise.find_id id with
14
Added:
| Some e -> e
15
Added:
| None -> Alcotest.failf "catalog is missing %S" id
16
Added:
17
Added:
let at s = Recovery.timestamp_of_unix_seconds s
18
Added:
let ok = function Ok v -> v | Error _ -> Alcotest.fail "expected Ok"
19
Added:
let wid = WI.workout_id
20
Added:
21
Added:
(* A trainee id minted directly; the import operations never consult the
22
Added:
account table. *)
23
Added:
let trainee n = Trainee.id (Printf.sprintf "t%d" n)
24
Added:
25
Added:
let set ~name ~kind ~kg ~reps : WI.source_set =
26
Added:
{
27
Added:
row = 1;
28
Added:
exercise_name = name;
29
Added:
set_index = 1;
30
Added:
set_type = kind;
31
Added:
weight_kg = kg;
32
Added:
reps;
33
Added:
superset_id = None;
34
Added:
}
35
Added:
36
Added:
let batch ~id ~imported_at =
37
Added:
let sets = [ set ~name:"Barbell Squat" ~kind:WI.Failure ~kg:100. ~reps:8 ] in
38
Added:
let w =
39
Added:
ok
40
Added:
(WI.make_workout ~id:(wid "w1") ~title:"Legs" ~started_at:(at 10)
41
Added:
~ended_at:(at 3_610) ~sets)
42
Added:
in
43
Added:
WI.make_batch ~id:(WI.batch_id id) ~source:"raw" ~fingerprint:"fp"
44
Added:
~imported_at ~workouts:[ w ] ~warnings:[]
45
Added:
46
Added:
let record ~batch_id ~workout_id ~revision ~ended_at ~load :
47
Added:
Repository.imported_record =
48
Added:
let exercise = get "squats" in
49
Added:
let effort =
50
Added:
Evidence.Stimulus.Effort.make ~exercise ~load ~reps:8
51
Added:
~outcome:Evidence.Stimulus.Positive_failure
52
Added:
in
53
Added:
let obs =
54
Added:
Evidence.Observation.make ~exercise ~effort ~performed_at:ended_at
55
Added:
in
56
Added:
{
57
Added:
batch_id = WI.batch_id batch_id;
58
Added:
workout_id = WI.workout_id workout_id;
59
Added:
revision;
60
Added:
title = "Legs";
61
Added:
started_at = at 10;
62
Added:
ended_at;
63
Added:
observations = [ obs ];
64
Added:
provenance =
65
Added:
{
66
Added:
WI.batch_id = WI.batch_id batch_id;
67
Added:
workout_id = WI.workout_id workout_id;
68
Added:
source_rows = [ 1 ];
69
Added:
normal_confirmation = None;
70
Added:
revision;
71
Added:
};
72
Added:
}
73
Added:
74
Added:
let batch_ids bs =
75
Added:
List.map (fun b -> WI.batch_id_to_string (WI.batch_identity b)) bs
76
Added:
77
Added:
let memory_tests =
78
Added:
[
79
Added:
( "batches and records are isolated per trainee",
80
Added:
`Quick,
81
Added:
fun () ->
82
Added:
let repo = Memory_repo.create () in
83
Added:
let a = trainee 1 and b = trainee 2 in
84
Added:
run
85
Added:
(Memory_repo.save_import_batch repo a
86
Added:
(batch ~id:"ba" ~imported_at:(at 100)));
87
Added:
run
88
Added:
(Memory_repo.replace_imported_record repo a
89
Added:
(record ~batch_id:"ba" ~workout_id:"w1" ~revision:0
90
Added:
~ended_at:(at 3_610) ~load:100.));
91
Added:
Alcotest.(check int)
92
Added:
"b has no batches" 0
93
Added:
(List.length (run (Memory_repo.import_batches repo b)));
94
Added:
Alcotest.(check int)
95
Added:
"b has no records" 0
96
Added:
(List.length (run (Memory_repo.imported_records repo b)));
97
Added:
Alcotest.(check int)
98
Added:
"a has one batch" 1
99
Added:
(List.length (run (Memory_repo.import_batches repo a))) );
100
Added:
( "batches list most recent imported_at first, ties by id descending",
101
Added:
`Quick,
102
Added:
fun () ->
103
Added:
let repo = Memory_repo.create () in
104
Added:
let a = trainee 1 in
105
Added:
run
106
Added:
(Memory_repo.save_import_batch repo a
107
Added:
(batch ~id:"b1" ~imported_at:(at 100)));
108
Added:
run
109
Added:
(Memory_repo.save_import_batch repo a
110
Added:
(batch ~id:"b3" ~imported_at:(at 300)));
111
Added:
run
112
Added:
(Memory_repo.save_import_batch repo a
113
Added:
(batch ~id:"b2a" ~imported_at:(at 200)));
114
Added:
run
115
Added:
(Memory_repo.save_import_batch repo a
116
Added:
(batch ~id:"b2b" ~imported_at:(at 200)));
117
Added:
Alcotest.(check (list string))
118
Added:
"newest first, id tie-break descending"
119
Added:
[ "b3"; "b2b"; "b2a"; "b1" ]
120
Added:
(batch_ids (run (Memory_repo.import_batches repo a))) );
121
Added:
( "saving a batch with the same id replaces it",
122
Added:
`Quick,
123
Added:
fun () ->
124
Added:
let repo = Memory_repo.create () in
125
Added:
let a = trainee 1 in
126
Added:
run
127
Added:
(Memory_repo.save_import_batch repo a
128
Added:
(batch ~id:"b1" ~imported_at:(at 100)));
129
Added:
run
130
Added:
(Memory_repo.save_import_batch repo a
131
Added:
(batch ~id:"b1" ~imported_at:(at 500)));
132
Added:
let bs = run (Memory_repo.import_batches repo a) in
133
Added:
Alcotest.(check int) "still one batch" 1 (List.length bs);
134
Added:
Alcotest.(check int)
135
Added:
"imported_at updated" 500
136
Added:
(Recovery.timestamp_to_unix_seconds
137
Added:
(WI.batch_imported_at (List.hd bs))) );
138
Added:
( "find_import_batch returns the stored batch or none",
139
Added:
`Quick,
140
Added:
fun () ->
141
Added:
let repo = Memory_repo.create () in
142
Added:
let a = trainee 1 in
143
Added:
run
144
Added:
(Memory_repo.save_import_batch repo a
145
Added:
(batch ~id:"b1" ~imported_at:(at 100)));
146
Added:
Alcotest.(check bool)
147
Added:
"found" true
148
Added:
(Option.is_some
149
Added:
(run (Memory_repo.find_import_batch repo a (WI.batch_id "b1"))));
150
Added:
Alcotest.(check bool)
151
Added:
"absent" false
152
Added:
(Option.is_some
153
Added:
(run (Memory_repo.find_import_batch repo a (WI.batch_id "nope"))))
154
Added:
);
155
Added:
( "deleting a batch leaves promoted records untouched",
156
Added:
`Quick,
157
Added:
fun () ->
158
Added:
let repo = Memory_repo.create () in
159
Added:
let a = trainee 1 in
160
Added:
run
161
Added:
(Memory_repo.save_import_batch repo a
162
Added:
(batch ~id:"b1" ~imported_at:(at 100)));
163
Added:
run
164
Added:
(Memory_repo.replace_imported_record repo a
165
Added:
(record ~batch_id:"b1" ~workout_id:"w1" ~revision:0
166
Added:
~ended_at:(at 3_610) ~load:100.));
167
Added:
let deleted =
168
Added:
run (Memory_repo.delete_import_batch repo a (WI.batch_id "b1"))
169
Added:
in
170
Added:
Alcotest.(check bool) "batch deleted" true deleted;
171
Added:
Alcotest.(check int)
172
Added:
"no batches remain" 0
173
Added:
(List.length (run (Memory_repo.import_batches repo a)));
174
Added:
Alcotest.(check int)
175
Added:
"record survives" 1
176
Added:
(List.length (run (Memory_repo.imported_records repo a))) );
177
Added:
( "deleting an absent batch reports false",
178
Added:
`Quick,
179
Added:
fun () ->
180
Added:
let repo = Memory_repo.create () in
181
Added:
let a = trainee 1 in
182
Added:
Alcotest.(check bool)
183
Added:
"nothing to delete" false
184
Added:
(run (Memory_repo.delete_import_batch repo a (WI.batch_id "ghost")))
185
Added:
);
186
Added:
( "a promoted record is replaced by workout id",
187
Added:
`Quick,
188
Added:
fun () ->
189
Added:
let repo = Memory_repo.create () in
190
Added:
let a = trainee 1 in
191
Added:
run
192
Added:
(Memory_repo.replace_imported_record repo a
193
Added:
(record ~batch_id:"b1" ~workout_id:"w1" ~revision:0
194
Added:
~ended_at:(at 3_610) ~load:100.));
195
Added:
run
196
Added:
(Memory_repo.replace_imported_record repo a
197
Added:
(record ~batch_id:"b1" ~workout_id:"w1" ~revision:1
198
Added:
~ended_at:(at 3_610) ~load:110.));
199
Added:
let records = run (Memory_repo.imported_records repo a) in
200
Added:
Alcotest.(check int) "still one record" 1 (List.length records);
201
Added:
Alcotest.(check int)
202
Added:
"revision advanced" 1 (List.hd records).Repository.revision;
203
Added:
let load =
204
Added:
Evidence.Stimulus.Effort.load
205
Added:
(Evidence.Observation.effort
206
Added:
(List.hd (List.hd records).Repository.observations))
207
Added:
in
208
Added:
Alcotest.(check (float 0.001)) "load replaced" 110. load );
209
Added:
( "records list most recent ended_at first",
210
Added:
`Quick,
211
Added:
fun () ->
212
Added:
let repo = Memory_repo.create () in
213
Added:
let a = trainee 1 in
214
Added:
run
215
Added:
(Memory_repo.replace_imported_record repo a
216
Added:
(record ~batch_id:"b1" ~workout_id:"w1" ~revision:0
217
Added:
~ended_at:(at 1_000) ~load:100.));
218
Added:
run
219
Added:
(Memory_repo.replace_imported_record repo a
220
Added:
(record ~batch_id:"b1" ~workout_id:"w2" ~revision:0
221
Added:
~ended_at:(at 9_000) ~load:100.));
222
Added:
run
223
Added:
(Memory_repo.replace_imported_record repo a
224
Added:
(record ~batch_id:"b1" ~workout_id:"w3" ~revision:0
225
Added:
~ended_at:(at 5_000) ~load:100.));
226
Added:
let ended =
227
Added:
List.map
228
Added:
(fun r -> Recovery.timestamp_to_unix_seconds r.Repository.ended_at)
229
Added:
(run (Memory_repo.imported_records repo a))
230
Added:
in
231
Added:
Alcotest.(check (list int))
232
Added:
"newest ended_at first" [ 9_000; 5_000; 1_000 ] ended );
233
Added:
]
234
Added:
235
Added:
let suite = [ ("import_memory_repo", memory_tests) ]
test/test_import_sqlite.ml
@@ -0,0 +1,291 @@
1
Added:
(** Tests for the workout-import operations on {!Sqlite_repo}: a batch's full
2
Added:
state — mappings, acknowledgement, revision, and prior promotion — survives
3
Added:
a reconnect, a re-promotion after reconnect is {!Already_promoted}, edits
4
Added:
persist, promoted records replace by workout id, deleting a batch leaves its
5
Added:
records, and trainees stay isolated. *)
6
Added:
7
Added:
open Hito_app
8
Added:
open Hito_persistence
9
Added:
module WI = Workout_import
10
Added:
11
Added:
let run = Lwt_main.run
12
Added:
let ok = function Ok v -> v | Error _ -> Alcotest.fail "expected Ok"
13
Added:
14
Added:
let get id =
15
Added:
match Exercise.find_id id with
16
Added:
| Some e -> e
17
Added:
| None -> Alcotest.failf "catalog is missing %S" id
18
Added:
19
Added:
let at s = Recovery.timestamp_of_unix_seconds s
20
Added:
let wid = WI.workout_id
21
Added:
let trainee n = Trainee.id (Printf.sprintf "t%d" n)
22
Added:
23
Added:
let temp_uri () =
24
Added:
let path = Filename.temp_file "hito-import-" ".sqlite" in
25
Added:
Sys.remove path;
26
Added:
(path, "sqlite3:" ^ path)
27
Added:
28
Added:
let connect uri = ok (run (Sqlite_repo.connect uri))
29
Added:
30
Added:
let cleanup path =
31
Added:
List.iter
32
Added:
(fun suffix -> try Sys.remove (path ^ suffix) with Sys_error _ -> ())
33
Added:
[ ""; "-wal"; "-shm" ]
34
Added:
35
Added:
let set ~name ~kind ~kg ~reps : WI.source_set =
36
Added:
{
37
Added:
row = 1;
38
Added:
exercise_name = name;
39
Added:
set_index = 1;
40
Added:
set_type = kind;
41
Added:
weight_kg = kg;
42
Added:
reps;
43
Added:
superset_id = None;
44
Added:
}
45
Added:
46
Added:
(* A batch with one failure set and one normal set, so promotion needs both a
47
Added:
mapping and an acknowledgement. *)
48
Added:
let sample_batch () =
49
Added:
let sets =
50
Added:
[
51
Added:
set ~name:"Barbell Squat" ~kind:WI.Failure ~kg:100. ~reps:8;
52
Added:
set ~name:"Barbell Squat" ~kind:WI.Normal ~kg:60. ~reps:10;
53
Added:
]
54
Added:
in
55
Added:
let w =
56
Added:
ok
57
Added:
(WI.make_workout ~id:(wid "w1") ~title:"Legs" ~started_at:(at 10)
58
Added:
~ended_at:(at 3_610) ~sets)
59
Added:
in
60
Added:
WI.make_batch ~id:(WI.batch_id "b1") ~source:"raw,source\ntext"
61
Added:
~fingerprint:"fp" ~imported_at:(at 5_000) ~workouts:[ w ] ~warnings:[]
62
Added:
63
Added:
(* Fully clean and promote the sample batch. *)
64
Added:
let cleaned_and_promoted () =
65
Added:
let b = sample_batch () in
66
Added:
let b =
67
Added:
ok
68
Added:
(WI.map_exercise b ~workout:(wid "w1") ~source_name:"Barbell Squat"
69
Added:
(get "squats"))
70
Added:
in
71
Added:
let b =
72
Added:
ok
73
Added:
(WI.confirm_normal_sets b ~workout:(wid "w1")
74
Added:
~acknowledgement:"all taken to failure")
75
Added:
in
76
Added:
let b, _ = ok (WI.promote_workout b (wid "w1")) in
77
Added:
b
78
Added:
79
Added:
let with_file f =
80
Added:
let path, uri = temp_uri () in
81
Added:
Fun.protect ~finally:(fun () -> cleanup path) (fun () -> f uri)
82
Added:
83
Added:
let tests =
84
Added:
[
85
Added:
( "a full batch state survives a reconnect",
86
Added:
`Quick,
87
Added:
fun () ->
88
Added:
with_file (fun uri ->
89
Added:
(let repo = connect uri in
90
Added:
run
91
Added:
(Sqlite_repo.save_import_batch repo (trainee 1)
92
Added:
(cleaned_and_promoted ())));
93
Added:
(* Reconnect to the same file with a fresh repo value. *)
94
Added:
let repo = connect uri in
95
Added:
let b =
96
Added:
Option.get
97
Added:
(run
98
Added:
(Sqlite_repo.find_import_batch repo (trainee 1)
99
Added:
(WI.batch_id "b1")))
100
Added:
in
101
Added:
let w = Option.get (WI.find_workout b (wid "w1")) in
102
Added:
Alcotest.(check string)
103
Added:
"source survives" "raw,source\ntext" (WI.batch_source b);
104
Added:
Alcotest.(check bool)
105
Added:
"mapping survives" true
106
Added:
(Option.is_some
107
Added:
(WI.workout_mapping w ~source_name:"Barbell Squat"));
108
Added:
Alcotest.(check (option string))
109
Added:
"acknowledgement survives" (Some "all taken to failure")
110
Added:
(WI.workout_acknowledgement w);
111
Added:
Alcotest.(check (list string))
112
Added:
"no blockers" []
113
Added:
(List.map (fun _ -> "blocker") (WI.blockers w))) );
114
Added:
( "a repeated promotion after reconnect is Already_promoted",
115
Added:
`Quick,
116
Added:
fun () ->
117
Added:
with_file (fun uri ->
118
Added:
(let repo = connect uri in
119
Added:
run
120
Added:
(Sqlite_repo.save_import_batch repo (trainee 1)
121
Added:
(cleaned_and_promoted ())));
122
Added:
let repo = connect uri in
123
Added:
let b =
124
Added:
Option.get
125
Added:
(run
126
Added:
(Sqlite_repo.find_import_batch repo (trainee 1)
127
Added:
(WI.batch_id "b1")))
128
Added:
in
129
Added:
let _, result = ok (WI.promote_workout b (wid "w1")) in
130
Added:
match result with
131
Added:
| WI.Already_promoted p ->
132
Added:
Alcotest.(check int)
133
Added:
"two observations" 2
134
Added:
(List.length p.observations)
135
Added:
| WI.Promoted _ -> Alcotest.fail "expected Already_promoted"
136
Added:
| WI.Blocked _ ->
137
Added:
Alcotest.fail "expected Already_promoted, not Blocked") );
138
Added:
( "an edited batch (re-mapped, re-promoted) persists across reconnect",
139
Added:
`Quick,
140
Added:
fun () ->
141
Added:
with_file (fun uri ->
142
Added:
(let repo = connect uri in
143
Added:
let b = cleaned_and_promoted () in
144
Added:
(* Edit: re-map to a different exercise, which bumps the revision
145
Added:
and makes the stored promotion stale. Re-promote at the new
146
Added:
revision, then save. *)
147
Added:
let b =
148
Added:
ok
149
Added:
(WI.map_exercise b ~workout:(wid "w1")
150
Added:
~source_name:"Barbell Squat" (get "leg-presses"))
151
Added:
in
152
Added:
let b, result = ok (WI.promote_workout b (wid "w1")) in
153
Added:
(match result with
154
Added:
| WI.Promoted _ -> ()
155
Added:
| _ -> Alcotest.fail "expected a fresh promotion after the edit");
156
Added:
run (Sqlite_repo.save_import_batch repo (trainee 1) b));
157
Added:
let repo = connect uri in
158
Added:
let b =
159
Added:
Option.get
160
Added:
(run
161
Added:
(Sqlite_repo.find_import_batch repo (trainee 1)
162
Added:
(WI.batch_id "b1")))
163
Added:
in
164
Added:
let w = Option.get (WI.find_workout b (wid "w1")) in
165
Added:
(match WI.workout_mapping w ~source_name:"Barbell Squat" with
166
Added:
| Some e ->
167
Added:
Alcotest.(check bool)
168
Added:
"re-mapped exercise persists" true
169
Added:
(Exercise.equal e (get "leg-presses"))
170
Added:
| None -> Alcotest.fail "expected the edited mapping to survive");
171
Added:
let _, result = ok (WI.promote_workout b (wid "w1")) in
172
Added:
match result with
173
Added:
| WI.Already_promoted _ -> ()
174
Added:
| _ ->
175
Added:
Alcotest.fail
176
Added:
"expected the edited promotion to be Already_promoted") );
177
Added:
( "a promoted record persists and is replaced by workout id",
178
Added:
`Quick,
179
Added:
fun () ->
180
Added:
with_file (fun uri ->
181
Added:
let mk revision load : Repository.imported_record =
182
Added:
let exercise = get "squats" in
183
Added:
let effort =
184
Added:
Evidence.Stimulus.Effort.make ~exercise ~load ~reps:8
185
Added:
~outcome:Evidence.Stimulus.Positive_failure
186
Added:
in
187
Added:
let obs =
188
Added:
Evidence.Observation.make ~exercise ~effort
189
Added:
~performed_at:(at 3_610)
190
Added:
in
191
Added:
{
192
Added:
batch_id = WI.batch_id "b1";
193
Added:
workout_id = wid "w1";
194
Added:
revision;
195
Added:
title = "Legs";
196
Added:
started_at = at 10;
197
Added:
ended_at = at 3_610;
198
Added:
observations = [ obs ];
199
Added:
provenance =
200
Added:
{
201
Added:
WI.batch_id = WI.batch_id "b1";
202
Added:
workout_id = wid "w1";
203
Added:
source_rows = [ 1 ];
204
Added:
normal_confirmation = None;
205
Added:
revision;
206
Added:
};
207
Added:
}
208
Added:
in
209
Added:
(let repo = connect uri in
210
Added:
run
211
Added:
(Sqlite_repo.replace_imported_record repo (trainee 1) (mk 0 100.));
212
Added:
run
213
Added:
(Sqlite_repo.replace_imported_record repo (trainee 1) (mk 1 110.)));
214
Added:
let repo = connect uri in
215
Added:
let records = run (Sqlite_repo.imported_records repo (trainee 1)) in
216
Added:
Alcotest.(check int)
217
Added:
"one record after replace" 1 (List.length records);
218
Added:
Alcotest.(check int)
219
Added:
"revision advanced" 1 (List.hd records).Repository.revision;
220
Added:
let load =
221
Added:
Evidence.Stimulus.Effort.load
222
Added:
(Evidence.Observation.effort
223
Added:
(List.hd (List.hd records).Repository.observations))
224
Added:
in
225
Added:
Alcotest.(check (float 0.001)) "load replaced" 110. load) );
226
Added:
( "deleting a batch leaves its promoted record",
227
Added:
`Quick,
228
Added:
fun () ->
229
Added:
with_file (fun uri ->
230
Added:
let record : Repository.imported_record =
231
Added:
let exercise = get "squats" in
232
Added:
let effort =
233
Added:
Evidence.Stimulus.Effort.make ~exercise ~load:100. ~reps:8
234
Added:
~outcome:Evidence.Stimulus.Positive_failure
235
Added:
in
236
Added:
let obs =
237
Added:
Evidence.Observation.make ~exercise ~effort
238
Added:
~performed_at:(at 3_610)
239
Added:
in
240
Added:
{
241
Added:
batch_id = WI.batch_id "b1";
242
Added:
workout_id = wid "w1";
243
Added:
revision = 0;
244
Added:
title = "Legs";
245
Added:
started_at = at 10;
246
Added:
ended_at = at 3_610;
247
Added:
observations = [ obs ];
248
Added:
provenance =
249
Added:
{
250
Added:
WI.batch_id = WI.batch_id "b1";
251
Added:
workout_id = wid "w1";
252
Added:
source_rows = [ 1 ];
253
Added:
normal_confirmation = None;
254
Added:
revision = 0;
255
Added:
};
256
Added:
}
257
Added:
in
258
Added:
let repo = connect uri in
259
Added:
run
260
Added:
(Sqlite_repo.save_import_batch repo (trainee 1) (sample_batch ()));
261
Added:
run (Sqlite_repo.replace_imported_record repo (trainee 1) record);
262
Added:
let deleted =
263
Added:
run
264
Added:
(Sqlite_repo.delete_import_batch repo (trainee 1)
265
Added:
(WI.batch_id "b1"))
266
Added:
in
267
Added:
Alcotest.(check bool) "batch deleted" true deleted;
268
Added:
Alcotest.(check int)
269
Added:
"no batch remains" 0
270
Added:
(List.length (run (Sqlite_repo.import_batches repo (trainee 1))));
271
Added:
Alcotest.(check int)
272
Added:
"record survives" 1
273
Added:
(List.length
274
Added:
(run (Sqlite_repo.imported_records repo (trainee 1))))) );
275
Added:
( "batches and records stay isolated per trainee",
276
Added:
`Quick,
277
Added:
fun () ->
278
Added:
with_file (fun uri ->
279
Added:
let repo = connect uri in
280
Added:
run
281
Added:
(Sqlite_repo.save_import_batch repo (trainee 1) (sample_batch ()));
282
Added:
Alcotest.(check int)
283
Added:
"other trainee has no batches" 0
284
Added:
(List.length (run (Sqlite_repo.import_batches repo (trainee 2))));
285
Added:
Alcotest.(check int)
286
Added:
"owner has one batch" 1
287
Added:
(List.length (run (Sqlite_repo.import_batches repo (trainee 1)))))
288
Added:
);
289
Added:
]
290
Added:
291
Added:
let suite = [ ("import_sqlite_repo", tests) ]