[OCaml] High Intensity Training Online
refactor Extract Hevy_csv into a hito.import library
The Hevy CSV parser is an interface adapter for an external agency. It lived inside hito.web, so any non-web importer would have had to link Dream to reach it. Move it to its own library that depends only on hito.app and csv, and drop csv from the web library's dependencies. Nothing about the adapter changes. The web controller and the tests now name it as Hito_import.Hevy_csv.
Changed files
lib/import/dune
@@ -0,0 +1,9 @@
1
Added:
; Interface adapters for third-party training exports. Each adapter turns an
2
Added:
; untrusted external format into the application's Workout_import use case. It
3
Added:
; depends inward on hito.app and the parsing library it needs, and on no web
4
Added:
; framework, so a CLI or another client can import without linking Dream.
5
Added:
6
Added:
(library
7
Added:
(name hito_import)
8
Added:
(public_name hito.import)
9
Added:
(libraries hito.core hito.app csv))
lib/import/hevy_csv.ml
@@ -0,0 +1,381 @@
1
Added:
(** See {!module:Hevy_csv} for the contract.
2
Added:
3
Added:
The parse runs in two stages. First it maps the header to column indices,
4
Added:
failing early on a missing column. Then it walks the data rows once: each
5
Added:
row becomes a set for some workout, or a batch warning. Rows group into
6
Added:
workouts by their exact [(title, start_time, end_time)] triple in
7
Added:
first-appearance order, and warnings stay in source order. The source text
8
Added:
is never rebuilt — it flows verbatim into the batch. *)
9
Added:
10
Added:
open Hito_app
11
Added:
module WI = Workout_import
12
Added:
13
Added:
type error =
14
Added:
| Malformed_csv of { record : int; field : int; detail : string }
15
Added:
| Missing_column of string
16
Added:
| Empty_file
17
Added:
18
Added:
let pp_error ppf = function
19
Added:
| Malformed_csv { record; field; detail } ->
20
Added:
Format.fprintf ppf "malformed CSV at record %d, field %d: %s" record field
21
Added:
detail
22
Added:
| Missing_column name -> Format.fprintf ppf "missing column %S" name
23
Added:
| Empty_file -> Format.pp_print_string ppf "empty file"
24
Added:
25
Added:
(* The strict native schema. Every column must be present. The order here is
26
Added:
canonical: a missing-column error names the first absent column in this
27
Added:
order, not the order the header happens to use. *)
28
Added:
let canonical_columns =
29
Added:
[
30
Added:
"title";
31
Added:
"start_time";
32
Added:
"end_time";
33
Added:
"description";
34
Added:
"exercise_title";
35
Added:
"superset_id";
36
Added:
"exercise_notes";
37
Added:
"set_index";
38
Added:
"set_type";
39
Added:
"weight_kg";
40
Added:
"reps";
41
Added:
"distance_km";
42
Added:
"duration_seconds";
43
Added:
"rpe";
44
Added:
]
45
Added:
46
Added:
(* Column indices resolved from the header, keyed by canonical name. Built once,
47
Added:
then read for every row. *)
48
Added:
type columns = (string * int) list
49
Added:
50
Added:
(* Maps the header row to column indices. The header order may vary, so each
51
Added:
name is looked up by value. The first canonical column absent from the header
52
Added:
fails the whole parse. *)
53
Added:
let resolve_columns (header : string list) : (columns, error) result =
54
Added:
let indexed = List.mapi (fun i name -> (name, i)) header in
55
Added:
let rec go acc = function
56
Added:
| [] -> Ok (List.rev acc)
57
Added:
| name :: rest -> (
58
Added:
match List.assoc_opt name indexed with
59
Added:
| Some i -> go ((name, i) :: acc) rest
60
Added:
| None -> Error (Missing_column name))
61
Added:
in
62
Added:
go [] canonical_columns
63
Added:
64
Added:
(* A row is a plain string list. This reads one column by canonical name,
65
Added:
returning [""] for a short row rather than raising. The column is guaranteed
66
Added:
present in [cols] once [resolve_columns] succeeds. *)
67
Added:
let field (cols : columns) (row : string list) name =
68
Added:
match List.assoc_opt name cols with
69
Added:
| None -> ""
70
Added:
| Some i -> ( match List.nth_opt row i with Some v -> v | None -> "")
71
Added:
72
Added:
(* {1 Datetime}
73
Added:
74
Added:
Hevy writes local wall time as [DD Mon YYYY, HH:MM] with an English month
75
Added:
abbreviation. The adapter converts to UTC seconds using the caller's fixed
76
Added:
offset: UTC = civil - offset. The calendar date is validated by a round-trip
77
Added:
through [days_from_civil], so an impossible date such as 31 Feb is rejected
78
Added:
rather than normalised. *)
79
Added:
80
Added:
let months =
81
Added:
[|
82
Added:
"Jan";
83
Added:
"Feb";
84
Added:
"Mar";
85
Added:
"Apr";
86
Added:
"May";
87
Added:
"Jun";
88
Added:
"Jul";
89
Added:
"Aug";
90
Added:
"Sep";
91
Added:
"Oct";
92
Added:
"Nov";
93
Added:
"Dec";
94
Added:
|]
95
Added:
96
Added:
let month_index abbrev =
97
Added:
let rec go i =
98
Added:
if i >= Array.length months then None
99
Added:
else if String.equal months.(i) abbrev then Some (i + 1)
100
Added:
else go (i + 1)
101
Added:
in
102
Added:
go 0
103
Added:
104
Added:
(* Days from the civil date 1970-01-01 to [y]-[m]-[d]. Howard Hinnant's
105
Added:
algorithm, valid for the proleptic Gregorian calendar. Used both to compute
106
Added:
the timestamp and, by round-trip, to confirm the date is real. *)
107
Added:
let days_from_civil y m d =
108
Added:
let y = if m <= 2 then y - 1 else y in
109
Added:
let era = (if y >= 0 then y else y - 399) / 400 in
110
Added:
let yoe = y - (era * 400) in
111
Added:
let doy = (((153 * if m > 2 then m - 3 else m + 9) + 2) / 5) + d - 1 in
112
Added:
let doe = (yoe * 365) + (yoe / 4) - (yoe / 100) + doy in
113
Added:
(era * 146097) + doe - 719468
114
Added:
115
Added:
(* The inverse of [days_from_civil], for the round-trip check. *)
116
Added:
let civil_from_days z =
117
Added:
let z = z + 719468 in
118
Added:
let era = (if z >= 0 then z else z - 146096) / 146097 in
119
Added:
let doe = z - (era * 146097) in
120
Added:
let yoe = (doe - (doe / 1460) + (doe / 36524) - (doe / 146096)) / 365 in
121
Added:
let y = yoe + (era * 400) in
122
Added:
let doy = doe - ((365 * yoe) + (yoe / 4) - (yoe / 100)) in
123
Added:
let mp = ((5 * doy) + 2) / 153 in
124
Added:
let d = doy - (((153 * mp) + 2) / 5) + 1 in
125
Added:
let m = if mp < 10 then mp + 3 else mp - 9 in
126
Added:
((if m <= 2 then y + 1 else y), m, d)
127
Added:
128
Added:
let is_digits s =
129
Added:
String.length s > 0 && String.for_all (fun c -> c >= '0' && c <= '9') s
130
Added:
131
Added:
(* Parses one Hevy datetime to UTC seconds at the given offset. Returns [None]
132
Added:
on any deviation from the exact [DD Mon YYYY, HH:MM] shape, an unknown month,
133
Added:
or a date that fails the calendar round-trip. *)
134
Added:
let parse_datetime ~utc_offset_seconds s =
135
Added:
match String.split_on_char ',' s with
136
Added:
| [ date_part; time_part ] -> (
137
Added:
let date_fields = String.split_on_char ' ' (String.trim date_part) in
138
Added:
let time_fields = String.split_on_char ':' (String.trim time_part) in
139
Added:
match (date_fields, time_fields) with
140
Added:
| [ dd; mon; yyyy ], [ hh; mm ]
141
Added:
when is_digits dd && is_digits yyyy && is_digits hh && is_digits mm -> (
142
Added:
match month_index mon with
143
Added:
| None -> None
144
Added:
| Some month ->
145
Added:
let day = int_of_string dd in
146
Added:
let year = int_of_string yyyy in
147
Added:
let hour = int_of_string hh in
148
Added:
let minute = int_of_string mm in
149
Added:
if
150
Added:
day < 1 || day > 31 || hour > 23 || minute > 59
151
Added:
|| String.length yyyy <> 4
152
Added:
then None
153
Added:
else
154
Added:
let days = days_from_civil year month day in
155
Added:
(* Reject impossible calendar dates by round-trip. *)
156
Added:
if civil_from_days days <> (year, month, day) then None
157
Added:
else
158
Added:
let civil_seconds =
159
Added:
(days * 86_400) + (hour * 3_600) + (minute * 60)
160
Added:
in
161
Added:
Some (civil_seconds - utc_offset_seconds))
162
Added:
| _ -> None)
163
Added:
| _ -> None
164
Added:
165
Added:
(* {1 Set types} *)
166
Added:
167
Added:
(* Hevy set types the adapter understands. [Warmup] never reaches a set: it
168
Added:
becomes a [Warmup_dropped] warning. Any other value is an unsupported row. *)
169
Added:
type parsed_set_type = Warmup | Working of WI.source_set_type
170
Added:
171
Added:
let parse_set_type s =
172
Added:
match String.lowercase_ascii (String.trim s) with
173
Added:
| "warmup" -> Some Warmup
174
Added:
| "normal" -> Some (Working WI.Normal)
175
Added:
| "failure" -> Some (Working WI.Failure)
176
Added:
| "dropset" -> Some (Working WI.Dropset)
177
Added:
| _ -> None
178
Added:
179
Added:
(* {1 Row outcome}
180
Added:
181
Added:
Each data row resolves to exactly one of: a set belonging to a workout keyed
182
Added:
by its datetime triple, a warning, or — when the datetimes are invalid and
183
Added:
the row cannot be grouped — a batch-level warning with no workout. *)
184
Added:
185
Added:
(* A parsed superset id: absent, present, or malformed. *)
186
Added:
type superset = Absent | Present of int | Invalid
187
Added:
188
Added:
let parse_superset s =
189
Added:
let s = String.trim s in
190
Added:
if String.equal s "" then Absent
191
Added:
else match int_of_string_opt s with Some i -> Present i | None -> Invalid
192
Added:
193
Added:
(* A finite float, rejecting NaN and the infinities that [float_of_string]
194
Added:
otherwise accepts. *)
195
Added:
let finite_float_opt s =
196
Added:
match float_of_string_opt (String.trim s) with
197
Added:
| Some f when Float.is_finite f -> Some f
198
Added:
| _ -> None
199
Added:
200
Added:
let nonneg_int_opt s =
201
Added:
match int_of_string_opt (String.trim s) with
202
Added:
| Some i when i >= 0 -> Some i
203
Added:
| _ -> None
204
Added:
205
Added:
(* The grouping key: the exact triple that identifies a workout. *)
206
Added:
type key = string * string * string
207
Added:
208
Added:
(* One classified row, before workouts are assembled. *)
209
Added:
type row_outcome =
210
Added:
| Set of { key : key; started : int; ended : int; set : WI.source_set }
211
Added:
| Warning of WI.warning
212
Added:
213
Added:
(* Classifies one data row at 1-based source [row]. The header is row 1, so the
214
Added:
first data row is row 2. The datetime triple keys the workout; invalid or
215
Added:
reversed datetimes drop the row. A warmup is dropped with its own warning.
216
Added:
Any field the strict schema needs but the row lacks turns the row into an
217
Added:
[Unsupported_row] warning, with a concise reason, never a guessed set. *)
218
Added:
let classify_row ~utc_offset_seconds cols ~row (fields : string list) :
219
Added:
row_outcome =
220
Added:
let get = field cols fields in
221
Added:
let title = get "title" in
222
Added:
let start_time = get "start_time" in
223
Added:
let end_time = get "end_time" in
224
Added:
let exercise_title = get "exercise_title" in
225
Added:
let exercise_name =
226
Added:
if String.equal (String.trim exercise_title) "" then None
227
Added:
else Some exercise_title
228
Added:
in
229
Added:
let warn reason =
230
Added:
Warning { row; exercise_name; kind = WI.Unsupported_row reason }
231
Added:
in
232
Added:
match parse_set_type (get "set_type") with
233
Added:
| None -> warn ("unknown set type " ^ get "set_type")
234
Added:
| Some Warmup -> Warning { row; exercise_name; kind = WI.Warmup_dropped }
235
Added:
| Some (Working set_type) -> (
236
Added:
match
237
Added:
( parse_datetime ~utc_offset_seconds start_time,
238
Added:
parse_datetime ~utc_offset_seconds end_time )
239
Added:
with
240
Added:
| None, _ -> warn "invalid start_time"
241
Added:
| _, None -> warn "invalid end_time"
242
Added:
| Some started, Some ended -> (
243
Added:
if ended < started then warn "end_time precedes start_time"
244
Added:
else if String.equal (String.trim exercise_title) "" then
245
Added:
warn "missing exercise_title"
246
Added:
else
247
Added:
match parse_superset (get "superset_id") with
248
Added:
| Invalid -> warn ("invalid superset_id " ^ get "superset_id")
249
Added:
| superset_id -> (
250
Added:
let superset_id =
251
Added:
match superset_id with
252
Added:
| Present i -> Some i
253
Added:
| Absent -> None
254
Added:
| Invalid -> None (* unreachable, handled above *)
255
Added:
in
256
Added:
match
257
Added:
( nonneg_int_opt (get "set_index"),
258
Added:
finite_float_opt (get "weight_kg"),
259
Added:
nonneg_int_opt (get "reps") )
260
Added:
with
261
Added:
| None, _, _ -> warn "invalid set_index"
262
Added:
| _, None, _ -> warn "missing or non-finite weight_kg"
263
Added:
| _, _, None -> warn "missing or negative reps"
264
Added:
| Some set_index, Some weight_kg, Some reps ->
265
Added:
let set : WI.source_set =
266
Added:
{
267
Added:
row;
268
Added:
exercise_name = exercise_title;
269
Added:
set_index;
270
Added:
set_type;
271
Added:
weight_kg;
272
Added:
reps;
273
Added:
superset_id;
274
Added:
}
275
Added:
in
276
Added:
Set
277
Added:
{
278
Added:
key = (title, start_time, end_time);
279
Added:
started;
280
Added:
ended;
281
Added:
set;
282
Added:
})))
283
Added:
284
Added:
(* {1 Grouping}
285
Added:
286
Added:
Sets group into workouts by their key, in first-appearance order. A row whose
287
Added:
datetimes were valid contributes its set here; the workout keeps the first
288
Added:
[started]/[ended] it saw for that key. Warnings never group — they are
289
Added:
collected separately in source order. *)
290
Added:
291
Added:
type group = {
292
Added:
title : string;
293
Added:
started : int;
294
Added:
ended : int;
295
Added:
mutable sets_rev : WI.source_set list;
296
Added:
}
297
Added:
298
Added:
(* Folds classified rows into ordered groups and an ordered warning list. Groups
299
Added:
keep first-appearance order; within a group, sets keep source order. *)
300
Added:
let assemble outcomes =
301
Added:
let groups_rev = ref [] in
302
Added:
let table : (key, group) Hashtbl.t = Hashtbl.create 16 in
303
Added:
let warnings_rev = ref [] in
304
Added:
List.iter
305
Added:
(fun outcome ->
306
Added:
match outcome with
307
Added:
| Warning w -> warnings_rev := w :: !warnings_rev
308
Added:
| Set { key; started; ended; set } -> (
309
Added:
match Hashtbl.find_opt table key with
310
Added:
| Some g -> g.sets_rev <- set :: g.sets_rev
311
Added:
| None ->
312
Added:
let title, _, _ = key in
313
Added:
let g = { title; started; ended; sets_rev = [ set ] } in
314
Added:
Hashtbl.add table key g;
315
Added:
groups_rev := g :: !groups_rev))
316
Added:
outcomes;
317
Added:
(List.rev !groups_rev, List.rev !warnings_rev)
318
Added:
319
Added:
(* Builds one imported workout from a group. [make_workout] can still reject the
320
Added:
times with [Invalid_time]; the classifier already dropped reversed rows, so a
321
Added:
surviving group should not hit it, but the adapter converts any such rejection
322
Added:
into a batch warning rather than raising. *)
323
Added:
let build_workout ~batch_id ~index (g : group) : (WI.workout, WI.warning) result
324
Added:
=
325
Added:
let id =
326
Added:
WI.workout_id (WI.batch_id_to_string batch_id ^ ":w" ^ string_of_int index)
327
Added:
in
328
Added:
let sets = List.rev g.sets_rev in
329
Added:
match
330
Added:
WI.make_workout ~id ~title:g.title
331
Added:
~started_at:(Recovery.timestamp_of_unix_seconds g.started)
332
Added:
~ended_at:(Recovery.timestamp_of_unix_seconds g.ended)
333
Added:
~sets
334
Added:
with
335
Added:
| Ok w -> Ok w
336
Added:
| Error _ ->
337
Added:
(* A whole group with reversed times; report at batch level. *)
338
Added:
Error
339
Added:
{
340
Added:
WI.row = 0;
341
Added:
exercise_name = None;
342
Added:
kind = WI.Unsupported_row ("workout " ^ g.title ^ " has invalid time");
343
Added:
}
344
Added:
345
Added:
let parse ~batch_id ~fingerprint ~imported_at ~utc_offset_seconds source =
346
Added:
(* Parse the CSV text. [strip:false] keeps RFC4180 fidelity; quoted commas and
347
Added:
newlines are preserved. A malformed export raises [Csv.Failure]. *)
348
Added:
match
349
Added:
try Ok (Csv.input_all (Csv.of_string ~strip:false source))
350
Added:
with Csv.Failure (record, field, detail) ->
351
Added:
Error (Malformed_csv { record; field; detail })
352
Added:
with
353
Added:
| Error _ as e -> e
354
Added:
| Ok [] -> Error Empty_file
355
Added:
| Ok (header :: data_rows) -> (
356
Added:
match resolve_columns header with
357
Added:
| Error _ as e -> e
358
Added:
| Ok cols ->
359
Added:
(* Row 1 is the header, so the first data row is row 2. *)
360
Added:
let outcomes =
361
Added:
List.mapi
362
Added:
(fun i fields ->
363
Added:
classify_row ~utc_offset_seconds cols ~row:(i + 2) fields)
364
Added:
data_rows
365
Added:
in
366
Added:
let groups, row_warnings = assemble outcomes in
367
Added:
let workouts_rev, workout_warnings_rev, _ =
368
Added:
List.fold_left
369
Added:
(fun (workouts, warnings, index) g ->
370
Added:
match build_workout ~batch_id ~index g with
371
Added:
| Ok w -> (w :: workouts, warnings, index + 1)
372
Added:
| Error warning -> (workouts, warning :: warnings, index + 1))
373
Added:
([], [], 1) groups
374
Added:
in
375
Added:
let workouts = List.rev workouts_rev in
376
Added:
(* Batch warnings stay in source order: the row warnings, then any
377
Added:
workout-level rejections in group order. *)
378
Added:
let warnings = row_warnings @ List.rev workout_warnings_rev in
379
Added:
Ok
380
Added:
(WI.make_batch ~id:batch_id ~source ~fingerprint ~imported_at
381
Added:
~workouts ~warnings))
lib/import/hevy_csv.mli
@@ -0,0 +1,45 @@
1
Added:
(** Parses a native Hevy CSV export into a {!Workout_import.batch}.
2
Added:
3
Added:
This is an import adapter: it turns untrusted export text into the
4
Added:
application's import use case. It does not construct canonical evidence or
5
Added:
apply Heavy Duty judgment. It depends on neither [hito.persistence] nor
6
Added:
[hito.web], so any client can import without linking a web framework. The
7
Added:
whole export text is retained verbatim through
8
Added:
{!Hito_app.Workout_import.make_batch}, so provenance survives the parse.
9
Added:
10
Added:
The adapter enforces the strict native schema. The header must carry all 14
11
Added:
verified columns, in any order. Rows the adapter cannot promote — warmups,
12
Added:
non-strength data, unknown set types, malformed fields — become
13
Added:
{!Workout_import.warning} values, not sets. A row is dropped, never guessed
14
Added:
at. Rows group into workouts by the exact [(title, start_time, end_time)]
15
Added:
triple, in first-appearance order. *)
16
Added:
17
Added:
type error =
18
Added:
| Malformed_csv of { record : int; field : int; detail : string }
19
Added:
(** The CSV text does not conform to RFC4180. [record] and [field] are
20
Added:
1-based, as {!Csv.Failure} reports them. *)
21
Added:
| Missing_column of string
22
Added:
(** A required column is absent from the header. The first missing column
23
Added:
in canonical order is reported. *)
24
Added:
| Empty_file (** The export has no rows at all, not even a header. *)
25
Added:
26
Added:
val pp_error : Format.formatter -> error -> unit
27
Added:
28
Added:
val parse :
29
Added:
batch_id:Hito_app.Workout_import.batch_id ->
30
Added:
fingerprint:string ->
31
Added:
imported_at:Recovery.timestamp ->
32
Added:
utc_offset_seconds:int ->
33
Added:
string ->
34
Added:
(Hito_app.Workout_import.batch, error) result
35
Added:
(** [parse ~batch_id ~fingerprint ~imported_at ~utc_offset_seconds source]
36
Added:
parses [source] as a native Hevy export.
37
Added:
38
Added:
[utc_offset_seconds] is the offset of the wall-clock times in the export.
39
Added:
Hevy datetimes are local wall time, so UTC seconds = civil seconds - offset.
40
Added:
41
Added:
Returns [Error Empty_file] for empty input, [Error (Missing_column _)] when
42
Added:
the header lacks a required column, and [Error (Malformed_csv _)] when the
43
Added:
CSV text is not well formed. On success the batch retains [source] exactly.
44
Added:
Rows the adapter cannot use appear in {!Workout_import.batch_warnings} in
45
Added:
source order. *)
lib/web/dune
@@ -30,7 +30,6 @@
30
30
(public_name hito.web)
31
31
(modules
32
32
decode
33
Removed:
hevy_csv
34
33
handlers_assets
35
34
handlers_kit
36
35
handlers_auth
@@ -46,4 +45,12 @@
46
45
workout_client_asset)
47
46
(preprocess
48
47
(pps dream-html.ppx))
49
Removed:
(libraries hito.core hito.app hito.presenter dream dream-html lwt unix csv))
48
Added:
(libraries
49
Added:
hito.core
50
Added:
hito.app
51
Added:
hito.import
52
Added:
hito.presenter
53
Added:
dream
54
Added:
dream-html
55
Added:
lwt
56
Added:
unix))
lib/web/handlers_import.ml
@@ -129,13 +129,13 @@
129
129
Workout_import.batch_id (generate_batch_id ~fingerprint ~imported_at)
130
130
in
131
131
match
132
Removed:
Hevy_csv.parse ~batch_id ~fingerprint ~imported_at ~utc_offset_seconds
133
Removed:
source
132
Added:
Hito_import.Hevy_csv.parse ~batch_id ~fingerprint ~imported_at
133
Added:
~utc_offset_seconds source
134
134
with
135
135
| Error e ->
136
136
redirect_with_flash request
137
137
(Dream_html.path_attr Dream_html.HTML.href Routes.profile)
138
Removed:
(Format.asprintf "%a" Hevy_csv.pp_error e)
138
Added:
(Format.asprintf "%a" Hito_import.Hevy_csv.pp_error e)
139
139
| Ok batch -> (
140
140
let allow_duplicate = if allow_duplicate then Some () else None in
141
141
Service.store_import_batch t.service trainee.Trainee.id
lib/web/hevy_csv.ml
@@ -1,381 +0,0 @@
1
Removed:
(** See {!module:Hevy_csv} for the contract.
2
Removed:
3
Removed:
The parse runs in two stages. First it maps the header to column indices,
4
Removed:
failing early on a missing column. Then it walks the data rows once: each
5
Removed:
row becomes a set for some workout, or a batch warning. Rows group into
6
Removed:
workouts by their exact [(title, start_time, end_time)] triple in
7
Removed:
first-appearance order, and warnings stay in source order. The source text
8
Removed:
is never rebuilt — it flows verbatim into the batch. *)
9
Removed:
10
Removed:
open Hito_app
11
Removed:
module WI = Workout_import
12
Removed:
13
Removed:
type error =
14
Removed:
| Malformed_csv of { record : int; field : int; detail : string }
15
Removed:
| Missing_column of string
16
Removed:
| Empty_file
17
Removed:
18
Removed:
let pp_error ppf = function
19
Removed:
| Malformed_csv { record; field; detail } ->
20
Removed:
Format.fprintf ppf "malformed CSV at record %d, field %d: %s" record field
21
Removed:
detail
22
Removed:
| Missing_column name -> Format.fprintf ppf "missing column %S" name
23
Removed:
| Empty_file -> Format.pp_print_string ppf "empty file"
24
Removed:
25
Removed:
(* The strict native schema. Every column must be present. The order here is
26
Removed:
canonical: a missing-column error names the first absent column in this
27
Removed:
order, not the order the header happens to use. *)
28
Removed:
let canonical_columns =
29
Removed:
[
30
Removed:
"title";
31
Removed:
"start_time";
32
Removed:
"end_time";
33
Removed:
"description";
34
Removed:
"exercise_title";
35
Removed:
"superset_id";
36
Removed:
"exercise_notes";
37
Removed:
"set_index";
38
Removed:
"set_type";
39
Removed:
"weight_kg";
40
Removed:
"reps";
41
Removed:
"distance_km";
42
Removed:
"duration_seconds";
43
Removed:
"rpe";
44
Removed:
]
45
Removed:
46
Removed:
(* Column indices resolved from the header, keyed by canonical name. Built once,
47
Removed:
then read for every row. *)
48
Removed:
type columns = (string * int) list
49
Removed:
50
Removed:
(* Maps the header row to column indices. The header order may vary, so each
51
Removed:
name is looked up by value. The first canonical column absent from the header
52
Removed:
fails the whole parse. *)
53
Removed:
let resolve_columns (header : string list) : (columns, error) result =
54
Removed:
let indexed = List.mapi (fun i name -> (name, i)) header in
55
Removed:
let rec go acc = function
56
Removed:
| [] -> Ok (List.rev acc)
57
Removed:
| name :: rest -> (
58
Removed:
match List.assoc_opt name indexed with
59
Removed:
| Some i -> go ((name, i) :: acc) rest
60
Removed:
| None -> Error (Missing_column name))
61
Removed:
in
62
Removed:
go [] canonical_columns
63
Removed:
64
Removed:
(* A row is a plain string list. This reads one column by canonical name,
65
Removed:
returning [""] for a short row rather than raising. The column is guaranteed
66
Removed:
present in [cols] once [resolve_columns] succeeds. *)
67
Removed:
let field (cols : columns) (row : string list) name =
68
Removed:
match List.assoc_opt name cols with
69
Removed:
| None -> ""
70
Removed:
| Some i -> ( match List.nth_opt row i with Some v -> v | None -> "")
71
Removed:
72
Removed:
(* {1 Datetime}
73
Removed:
74
Removed:
Hevy writes local wall time as [DD Mon YYYY, HH:MM] with an English month
75
Removed:
abbreviation. The adapter converts to UTC seconds using the caller's fixed
76
Removed:
offset: UTC = civil - offset. The calendar date is validated by a round-trip
77
Removed:
through [days_from_civil], so an impossible date such as 31 Feb is rejected
78
Removed:
rather than normalised. *)
79
Removed:
80
Removed:
let months =
81
Removed:
[|
82
Removed:
"Jan";
83
Removed:
"Feb";
84
Removed:
"Mar";
85
Removed:
"Apr";
86
Removed:
"May";
87
Removed:
"Jun";
88
Removed:
"Jul";
89
Removed:
"Aug";
90
Removed:
"Sep";
91
Removed:
"Oct";
92
Removed:
"Nov";
93
Removed:
"Dec";
94
Removed:
|]
95
Removed:
96
Removed:
let month_index abbrev =
97
Removed:
let rec go i =
98
Removed:
if i >= Array.length months then None
99
Removed:
else if String.equal months.(i) abbrev then Some (i + 1)
100
Removed:
else go (i + 1)
101
Removed:
in
102
Removed:
go 0
103
Removed:
104
Removed:
(* Days from the civil date 1970-01-01 to [y]-[m]-[d]. Howard Hinnant's
105
Removed:
algorithm, valid for the proleptic Gregorian calendar. Used both to compute
106
Removed:
the timestamp and, by round-trip, to confirm the date is real. *)
107
Removed:
let days_from_civil y m d =
108
Removed:
let y = if m <= 2 then y - 1 else y in
109
Removed:
let era = (if y >= 0 then y else y - 399) / 400 in
110
Removed:
let yoe = y - (era * 400) in
111
Removed:
let doy = (((153 * if m > 2 then m - 3 else m + 9) + 2) / 5) + d - 1 in
112
Removed:
let doe = (yoe * 365) + (yoe / 4) - (yoe / 100) + doy in
113
Removed:
(era * 146097) + doe - 719468
114
Removed:
115
Removed:
(* The inverse of [days_from_civil], for the round-trip check. *)
116
Removed:
let civil_from_days z =
117
Removed:
let z = z + 719468 in
118
Removed:
let era = (if z >= 0 then z else z - 146096) / 146097 in
119
Removed:
let doe = z - (era * 146097) in
120
Removed:
let yoe = (doe - (doe / 1460) + (doe / 36524) - (doe / 146096)) / 365 in
121
Removed:
let y = yoe + (era * 400) in
122
Removed:
let doy = doe - ((365 * yoe) + (yoe / 4) - (yoe / 100)) in
123
Removed:
let mp = ((5 * doy) + 2) / 153 in
124
Removed:
let d = doy - (((153 * mp) + 2) / 5) + 1 in
125
Removed:
let m = if mp < 10 then mp + 3 else mp - 9 in
126
Removed:
((if m <= 2 then y + 1 else y), m, d)
127
Removed:
128
Removed:
let is_digits s =
129
Removed:
String.length s > 0 && String.for_all (fun c -> c >= '0' && c <= '9') s
130
Removed:
131
Removed:
(* Parses one Hevy datetime to UTC seconds at the given offset. Returns [None]
132
Removed:
on any deviation from the exact [DD Mon YYYY, HH:MM] shape, an unknown month,
133
Removed:
or a date that fails the calendar round-trip. *)
134
Removed:
let parse_datetime ~utc_offset_seconds s =
135
Removed:
match String.split_on_char ',' s with
136
Removed:
| [ date_part; time_part ] -> (
137
Removed:
let date_fields = String.split_on_char ' ' (String.trim date_part) in
138
Removed:
let time_fields = String.split_on_char ':' (String.trim time_part) in
139
Removed:
match (date_fields, time_fields) with
140
Removed:
| [ dd; mon; yyyy ], [ hh; mm ]
141
Removed:
when is_digits dd && is_digits yyyy && is_digits hh && is_digits mm -> (
142
Removed:
match month_index mon with
143
Removed:
| None -> None
144
Removed:
| Some month ->
145
Removed:
let day = int_of_string dd in
146
Removed:
let year = int_of_string yyyy in
147
Removed:
let hour = int_of_string hh in
148
Removed:
let minute = int_of_string mm in
149
Removed:
if
150
Removed:
day < 1 || day > 31 || hour > 23 || minute > 59
151
Removed:
|| String.length yyyy <> 4
152
Removed:
then None
153
Removed:
else
154
Removed:
let days = days_from_civil year month day in
155
Removed:
(* Reject impossible calendar dates by round-trip. *)
156
Removed:
if civil_from_days days <> (year, month, day) then None
157
Removed:
else
158
Removed:
let civil_seconds =
159
Removed:
(days * 86_400) + (hour * 3_600) + (minute * 60)
160
Removed:
in
161
Removed:
Some (civil_seconds - utc_offset_seconds))
162
Removed:
| _ -> None)
163
Removed:
| _ -> None
164
Removed:
165
Removed:
(* {1 Set types} *)
166
Removed:
167
Removed:
(* Hevy set types the adapter understands. [Warmup] never reaches a set: it
168
Removed:
becomes a [Warmup_dropped] warning. Any other value is an unsupported row. *)
169
Removed:
type parsed_set_type = Warmup | Working of WI.source_set_type
170
Removed:
171
Removed:
let parse_set_type s =
172
Removed:
match String.lowercase_ascii (String.trim s) with
173
Removed:
| "warmup" -> Some Warmup
174
Removed:
| "normal" -> Some (Working WI.Normal)
175
Removed:
| "failure" -> Some (Working WI.Failure)
176
Removed:
| "dropset" -> Some (Working WI.Dropset)
177
Removed:
| _ -> None
178
Removed:
179
Removed:
(* {1 Row outcome}
180
Removed:
181
Removed:
Each data row resolves to exactly one of: a set belonging to a workout keyed
182
Removed:
by its datetime triple, a warning, or — when the datetimes are invalid and
183
Removed:
the row cannot be grouped — a batch-level warning with no workout. *)
184
Removed:
185
Removed:
(* A parsed superset id: absent, present, or malformed. *)
186
Removed:
type superset = Absent | Present of int | Invalid
187
Removed:
188
Removed:
let parse_superset s =
189
Removed:
let s = String.trim s in
190
Removed:
if String.equal s "" then Absent
191
Removed:
else match int_of_string_opt s with Some i -> Present i | None -> Invalid
192
Removed:
193
Removed:
(* A finite float, rejecting NaN and the infinities that [float_of_string]
194
Removed:
otherwise accepts. *)
195
Removed:
let finite_float_opt s =
196
Removed:
match float_of_string_opt (String.trim s) with
197
Removed:
| Some f when Float.is_finite f -> Some f
198
Removed:
| _ -> None
199
Removed:
200
Removed:
let nonneg_int_opt s =
201
Removed:
match int_of_string_opt (String.trim s) with
202
Removed:
| Some i when i >= 0 -> Some i
203
Removed:
| _ -> None
204
Removed:
205
Removed:
(* The grouping key: the exact triple that identifies a workout. *)
206
Removed:
type key = string * string * string
207
Removed:
208
Removed:
(* One classified row, before workouts are assembled. *)
209
Removed:
type row_outcome =
210
Removed:
| Set of { key : key; started : int; ended : int; set : WI.source_set }
211
Removed:
| Warning of WI.warning
212
Removed:
213
Removed:
(* Classifies one data row at 1-based source [row]. The header is row 1, so the
214
Removed:
first data row is row 2. The datetime triple keys the workout; invalid or
215
Removed:
reversed datetimes drop the row. A warmup is dropped with its own warning.
216
Removed:
Any field the strict schema needs but the row lacks turns the row into an
217
Removed:
[Unsupported_row] warning, with a concise reason, never a guessed set. *)
218
Removed:
let classify_row ~utc_offset_seconds cols ~row (fields : string list) :
219
Removed:
row_outcome =
220
Removed:
let get = field cols fields in
221
Removed:
let title = get "title" in
222
Removed:
let start_time = get "start_time" in
223
Removed:
let end_time = get "end_time" in
224
Removed:
let exercise_title = get "exercise_title" in
225
Removed:
let exercise_name =
226
Removed:
if String.equal (String.trim exercise_title) "" then None
227
Removed:
else Some exercise_title
228
Removed:
in
229
Removed:
let warn reason =
230
Removed:
Warning { row; exercise_name; kind = WI.Unsupported_row reason }
231
Removed:
in
232
Removed:
match parse_set_type (get "set_type") with
233
Removed:
| None -> warn ("unknown set type " ^ get "set_type")
234
Removed:
| Some Warmup -> Warning { row; exercise_name; kind = WI.Warmup_dropped }
235
Removed:
| Some (Working set_type) -> (
236
Removed:
match
237
Removed:
( parse_datetime ~utc_offset_seconds start_time,
238
Removed:
parse_datetime ~utc_offset_seconds end_time )
239
Removed:
with
240
Removed:
| None, _ -> warn "invalid start_time"
241
Removed:
| _, None -> warn "invalid end_time"
242
Removed:
| Some started, Some ended -> (
243
Removed:
if ended < started then warn "end_time precedes start_time"
244
Removed:
else if String.equal (String.trim exercise_title) "" then
245
Removed:
warn "missing exercise_title"
246
Removed:
else
247
Removed:
match parse_superset (get "superset_id") with
248
Removed:
| Invalid -> warn ("invalid superset_id " ^ get "superset_id")
249
Removed:
| superset_id -> (
250
Removed:
let superset_id =
251
Removed:
match superset_id with
252
Removed:
| Present i -> Some i
253
Removed:
| Absent -> None
254
Removed:
| Invalid -> None (* unreachable, handled above *)
255
Removed:
in
256
Removed:
match
257
Removed:
( nonneg_int_opt (get "set_index"),
258
Removed:
finite_float_opt (get "weight_kg"),
259
Removed:
nonneg_int_opt (get "reps") )
260
Removed:
with
261
Removed:
| None, _, _ -> warn "invalid set_index"
262
Removed:
| _, None, _ -> warn "missing or non-finite weight_kg"
263
Removed:
| _, _, None -> warn "missing or negative reps"
264
Removed:
| Some set_index, Some weight_kg, Some reps ->
265
Removed:
let set : WI.source_set =
266
Removed:
{
267
Removed:
row;
268
Removed:
exercise_name = exercise_title;
269
Removed:
set_index;
270
Removed:
set_type;
271
Removed:
weight_kg;
272
Removed:
reps;
273
Removed:
superset_id;
274
Removed:
}
275
Removed:
in
276
Removed:
Set
277
Removed:
{
278
Removed:
key = (title, start_time, end_time);
279
Removed:
started;
280
Removed:
ended;
281
Removed:
set;
282
Removed:
})))
283
Removed:
284
Removed:
(* {1 Grouping}
285
Removed:
286
Removed:
Sets group into workouts by their key, in first-appearance order. A row whose
287
Removed:
datetimes were valid contributes its set here; the workout keeps the first
288
Removed:
[started]/[ended] it saw for that key. Warnings never group — they are
289
Removed:
collected separately in source order. *)
290
Removed:
291
Removed:
type group = {
292
Removed:
title : string;
293
Removed:
started : int;
294
Removed:
ended : int;
295
Removed:
mutable sets_rev : WI.source_set list;
296
Removed:
}
297
Removed:
298
Removed:
(* Folds classified rows into ordered groups and an ordered warning list. Groups
299
Removed:
keep first-appearance order; within a group, sets keep source order. *)
300
Removed:
let assemble outcomes =
301
Removed:
let groups_rev = ref [] in
302
Removed:
let table : (key, group) Hashtbl.t = Hashtbl.create 16 in
303
Removed:
let warnings_rev = ref [] in
304
Removed:
List.iter
305
Removed:
(fun outcome ->
306
Removed:
match outcome with
307
Removed:
| Warning w -> warnings_rev := w :: !warnings_rev
308
Removed:
| Set { key; started; ended; set } -> (
309
Removed:
match Hashtbl.find_opt table key with
310
Removed:
| Some g -> g.sets_rev <- set :: g.sets_rev
311
Removed:
| None ->
312
Removed:
let title, _, _ = key in
313
Removed:
let g = { title; started; ended; sets_rev = [ set ] } in
314
Removed:
Hashtbl.add table key g;
315
Removed:
groups_rev := g :: !groups_rev))
316
Removed:
outcomes;
317
Removed:
(List.rev !groups_rev, List.rev !warnings_rev)
318
Removed:
319
Removed:
(* Builds one imported workout from a group. [make_workout] can still reject the
320
Removed:
times with [Invalid_time]; the classifier already dropped reversed rows, so a
321
Removed:
surviving group should not hit it, but the adapter converts any such rejection
322
Removed:
into a batch warning rather than raising. *)
323
Removed:
let build_workout ~batch_id ~index (g : group) : (WI.workout, WI.warning) result
324
Removed:
=
325
Removed:
let id =
326
Removed:
WI.workout_id (WI.batch_id_to_string batch_id ^ ":w" ^ string_of_int index)
327
Removed:
in
328
Removed:
let sets = List.rev g.sets_rev in
329
Removed:
match
330
Removed:
WI.make_workout ~id ~title:g.title
331
Removed:
~started_at:(Recovery.timestamp_of_unix_seconds g.started)
332
Removed:
~ended_at:(Recovery.timestamp_of_unix_seconds g.ended)
333
Removed:
~sets
334
Removed:
with
335
Removed:
| Ok w -> Ok w
336
Removed:
| Error _ ->
337
Removed:
(* A whole group with reversed times; report at batch level. *)
338
Removed:
Error
339
Removed:
{
340
Removed:
WI.row = 0;
341
Removed:
exercise_name = None;
342
Removed:
kind = WI.Unsupported_row ("workout " ^ g.title ^ " has invalid time");
343
Removed:
}
344
Removed:
345
Removed:
let parse ~batch_id ~fingerprint ~imported_at ~utc_offset_seconds source =
346
Removed:
(* Parse the CSV text. [strip:false] keeps RFC4180 fidelity; quoted commas and
347
Removed:
newlines are preserved. A malformed export raises [Csv.Failure]. *)
348
Removed:
match
349
Removed:
try Ok (Csv.input_all (Csv.of_string ~strip:false source))
350
Removed:
with Csv.Failure (record, field, detail) ->
351
Removed:
Error (Malformed_csv { record; field; detail })
352
Removed:
with
353
Removed:
| Error _ as e -> e
354
Removed:
| Ok [] -> Error Empty_file
355
Removed:
| Ok (header :: data_rows) -> (
356
Removed:
match resolve_columns header with
357
Removed:
| Error _ as e -> e
358
Removed:
| Ok cols ->
359
Removed:
(* Row 1 is the header, so the first data row is row 2. *)
360
Removed:
let outcomes =
361
Removed:
List.mapi
362
Removed:
(fun i fields ->
363
Removed:
classify_row ~utc_offset_seconds cols ~row:(i + 2) fields)
364
Removed:
data_rows
365
Removed:
in
366
Removed:
let groups, row_warnings = assemble outcomes in
367
Removed:
let workouts_rev, workout_warnings_rev, _ =
368
Removed:
List.fold_left
369
Removed:
(fun (workouts, warnings, index) g ->
370
Removed:
match build_workout ~batch_id ~index g with
371
Removed:
| Ok w -> (w :: workouts, warnings, index + 1)
372
Removed:
| Error warning -> (workouts, warning :: warnings, index + 1))
373
Removed:
([], [], 1) groups
374
Removed:
in
375
Removed:
let workouts = List.rev workouts_rev in
376
Removed:
(* Batch warnings stay in source order: the row warnings, then any
377
Removed:
workout-level rejections in group order. *)
378
Removed:
let warnings = row_warnings @ List.rev workout_warnings_rev in
379
Removed:
Ok
380
Removed:
(WI.make_batch ~id:batch_id ~source ~fingerprint ~imported_at
381
Removed:
~workouts ~warnings))
lib/web/hevy_csv.mli
@@ -1,44 +0,0 @@
1
Removed:
(** Parses a native Hevy CSV export into a {!Workout_import.batch}.
2
Removed:
3
Removed:
This is a web-layer adapter: it turns untrusted export text into the
4
Removed:
application's import use case. It does not construct canonical evidence or
5
Removed:
apply Heavy Duty judgment. It never depends on [hito.persistence]. The whole
6
Removed:
export text is retained verbatim through
7
Removed:
{!Hito_app.Workout_import.make_batch}, so provenance survives the parse.
8
Removed:
9
Removed:
The adapter enforces the strict native schema. The header must carry all 14
10
Removed:
verified columns, in any order. Rows the adapter cannot promote — warmups,
11
Removed:
non-strength data, unknown set types, malformed fields — become
12
Removed:
{!Workout_import.warning} values, not sets. A row is dropped, never guessed
13
Removed:
at. Rows group into workouts by the exact [(title, start_time, end_time)]
14
Removed:
triple, in first-appearance order. *)
15
Removed:
16
Removed:
type error =
17
Removed:
| Malformed_csv of { record : int; field : int; detail : string }
18
Removed:
(** The CSV text does not conform to RFC4180. [record] and [field] are
19
Removed:
1-based, as {!Csv.Failure} reports them. *)
20
Removed:
| Missing_column of string
21
Removed:
(** A required column is absent from the header. The first missing column
22
Removed:
in canonical order is reported. *)
23
Removed:
| Empty_file (** The export has no rows at all, not even a header. *)
24
Removed:
25
Removed:
val pp_error : Format.formatter -> error -> unit
26
Removed:
27
Removed:
val parse :
28
Removed:
batch_id:Hito_app.Workout_import.batch_id ->
29
Removed:
fingerprint:string ->
30
Removed:
imported_at:Recovery.timestamp ->
31
Removed:
utc_offset_seconds:int ->
32
Removed:
string ->
33
Removed:
(Hito_app.Workout_import.batch, error) result
34
Removed:
(** [parse ~batch_id ~fingerprint ~imported_at ~utc_offset_seconds source]
35
Removed:
parses [source] as a native Hevy export.
36
Removed:
37
Removed:
[utc_offset_seconds] is the offset of the wall-clock times in the export.
38
Removed:
Hevy datetimes are local wall time, so UTC seconds = civil seconds - offset.
39
Removed:
40
Removed:
Returns [Error Empty_file] for empty input, [Error (Missing_column _)] when
41
Removed:
the header lacks a required column, and [Error (Malformed_csv _)] when the
42
Removed:
CSV text is not well formed. On success the batch retains [source] exactly.
43
Removed:
Rows the adapter cannot use appear in {!Workout_import.batch_warnings} in
44
Removed:
source order. *)
test/dune
@@ -23,6 +23,7 @@
23
23
(libraries
24
24
hito.core
25
25
hito.app
26
Added:
hito.import
26
27
hito.persistence
27
28
hito.web
28
29
hito.presenter
test/test_hevy_csv.ml
@@ -10,7 +10,7 @@
10
10
11
11
open Hito_app
12
12
module WI = Workout_import
13
Removed:
module Hevy_csv = Hito_web.Hevy_csv
13
Added:
module Hevy_csv = Hito_import.Hevy_csv
14
14
15
15
(* The verified native header, 14 columns in canonical order. *)
16
16
let header =