1 open Hito_app 2 module WI = Workout_import 3 4 type error = Malformed of string | Unknown_exercise of string | Invalid_time 5 6 let pp_error ppf = function 7 | Malformed detail -> Format.fprintf ppf "malformed import record: %s" detail 8 | Unknown_exercise id -> Format.fprintf ppf "unknown exercise %S" id 9 | Invalid_time -> Format.fprintf ppf "ended_at precedes started_at" 10 11 (* --- length-prefixed writer --- 12 13 The writer emits every field as its byte length in decimal, a colon, then 14 its raw bytes. The length frames the bytes exactly. A field may therefore 15 hold any byte, including newlines, commas, and colons, and the reader never 16 has to escape or guess where a field ends. *) 17 18 module Writer = struct 19 let create () = Buffer.create 256 20 21 let field buf (s : string) = 22 Buffer.add_string buf (string_of_int (String.length s)); 23 Buffer.add_char buf ':'; 24 Buffer.add_string buf s 25 26 let string = field 27 let int buf n = field buf (string_of_int n) 28 29 (* [%h] renders a float as a round-trippable hexadecimal literal. *) 30 let float buf x = field buf (Printf.sprintf "%h" x) 31 let timestamp buf ts = field buf (Timestamp.encode ts) 32 33 (* An option is one field carrying its presence, then the value when present. 34 A one-field option lead keeps the framing regular. *) 35 let option write buf = function 36 | None -> field buf "0" 37 | Some v -> 38 field buf "1"; 39 write buf v 40 41 (* A list is a count field followed by that many encoded elements. *) 42 let list write buf xs = 43 int buf (List.length xs); 44 List.iter (write buf) xs 45 46 let contents = Buffer.contents 47 end 48 49 (* --- length-prefixed reader --- *) 50 51 module Reader = struct 52 type t = { text : string; mutable pos : int } 53 54 exception Bad of string 55 exception Unknown of string (* an exercise id not in the catalog *) 56 57 let create text = { text; pos = 0 } 58 59 let field r = 60 let len = String.length r.text in 61 (* Read the decimal length up to the colon. *) 62 let start = r.pos in 63 let rec scan i = 64 if i >= len then raise (Bad "truncated field length") 65 else if r.text.[i] = ':' then i 66 else scan (i + 1) 67 in 68 let colon = scan start in 69 let n = 70 match int_of_string_opt (String.sub r.text start (colon - start)) with 71 | Some n when n >= 0 -> n 72 | _ -> raise (Bad "bad field length") 73 in 74 let value_start = colon + 1 in 75 if value_start + n > len then raise (Bad "field overruns input"); 76 r.pos <- value_start + n; 77 String.sub r.text value_start n 78 79 let string = field 80 81 let int r = 82 match int_of_string_opt (field r) with 83 | Some n -> n 84 | None -> raise (Bad "expected int") 85 86 let float r = 87 match float_of_string_opt (field r) with 88 | Some x -> x 89 | None -> raise (Bad "expected float") 90 91 let timestamp r = 92 match Timestamp.decode (field r) with 93 | Ok ts -> ts 94 | Error _ -> raise (Bad "bad timestamp") 95 96 let option read r = 97 match field r with 98 | "0" -> None 99 | "1" -> Some (read r) 100 | _ -> raise (Bad "bad option lead") 101 102 let list read r = 103 let n = int r in 104 if n < 0 then raise (Bad "negative list length"); 105 let rec go acc i = 106 if i = 0 then List.rev acc else go (read r :: acc) (i - 1) 107 in 108 go [] n 109 110 (* Resolve an exercise id string into an [Exercise.id]. The id type is 111 private, so a valid id can only come from the catalog. The reader reports a 112 stored id the catalog no longer names as [Unknown]. *) 113 let exercise_id r = 114 let raw = field r in 115 match Exercise.find_id raw with 116 | Some e -> Exercise.id e 117 | None -> raise (Unknown raw) 118 119 (* Resolve an exercise id string into the catalog entry itself. *) 120 let exercise r = 121 let raw = field r in 122 match Exercise.find_id raw with Some e -> e | None -> raise (Unknown raw) 123 124 let ensure_consumed r = 125 if r.pos <> String.length r.text then raise (Bad "trailing bytes") 126 127 (* Run a reader, turning framing faults and unknown ids into typed errors. *) 128 let run text f = 129 let r = create text in 130 match f r with 131 | v -> 132 ensure_consumed r; 133 Ok v 134 | exception Bad detail -> Error (Malformed detail) 135 | exception Unknown id -> Error (Unknown_exercise id) 136 end 137 138 (* --- observation wire fields --- 139 140 A promoted observation always serializes as the same four fields, in the same 141 order: an exercise id, a load, a rep count, and a performed time. The snapshot 142 path keeps the id as a raw [Exercise.id]. The record path resolves it to a 143 catalog [Exercise.t] and rebuilds the effort at [Positive_failure]. Both share 144 this framing, so the byte layout lives here once. *) 145 146 module Observation_wire = struct 147 (* Write the four fields from already-extracted primitive parts. *) 148 let write buf ~exercise_id ~load ~reps ~performed_at = 149 Writer.string buf exercise_id; 150 Writer.float buf load; 151 Writer.int buf reps; 152 Writer.timestamp buf performed_at 153 154 (* Read the four fields in order, resolving the leading exercise id with 155 [resolve]. The snapshot path resolves to an [Exercise.id]. The record path 156 resolves to a catalog [Exercise.t]. The remaining three fields are shared. *) 157 let read r ~resolve ~build = 158 let exercise = resolve r in 159 let load = Reader.float r in 160 let reps = Reader.int r in 161 let performed_at = Reader.timestamp r in 162 build ~exercise ~load ~reps ~performed_at 163 end 164 165 (* --- source set --- *) 166 167 let set_type_code : WI.source_set_type -> string = function 168 | Normal -> "N" 169 | Failure -> "F" 170 | Dropset -> "D" 171 172 let set_type_of_code = function 173 | "N" -> WI.Normal 174 | "F" -> WI.Failure 175 | "D" -> WI.Dropset 176 | other -> raise (Reader.Bad (Printf.sprintf "set type %S" other)) 177 178 let write_source_set buf (s : WI.source_set) = 179 Writer.int buf s.row; 180 Writer.string buf s.exercise_name; 181 Writer.int buf s.set_index; 182 Writer.string buf (set_type_code s.set_type); 183 Writer.float buf s.weight_kg; 184 Writer.int buf s.reps; 185 Writer.option Writer.int buf s.superset_id 186 187 let read_source_set r : WI.source_set = 188 let row = Reader.int r in 189 let exercise_name = Reader.string r in 190 let set_index = Reader.int r in 191 let set_type = set_type_of_code (Reader.string r) in 192 let weight_kg = Reader.float r in 193 let reps = Reader.int r in 194 let superset_id = Reader.option Reader.int r in 195 { row; exercise_name; set_index; set_type; weight_kg; reps; superset_id } 196 197 (* --- warning --- *) 198 199 let write_warning buf (w : WI.warning) = 200 Writer.int buf w.row; 201 Writer.option Writer.string buf w.exercise_name; 202 match w.kind with 203 | Warmup_dropped -> Writer.string buf "warmup" 204 | Unsupported_row detail -> 205 Writer.string buf "unsupported"; 206 Writer.string buf detail 207 208 let read_warning r : WI.warning = 209 let row = Reader.int r in 210 let exercise_name = Reader.option Reader.string r in 211 let kind = 212 match Reader.string r with 213 | "warmup" -> WI.Warmup_dropped 214 | "unsupported" -> WI.Unsupported_row (Reader.string r) 215 | other -> raise (Reader.Bad (Printf.sprintf "warning kind %S" other)) 216 in 217 { row; exercise_name; kind } 218 219 (* --- mapping --- *) 220 221 let write_mapping buf ((name, id) : string * Exercise.id) = 222 Writer.string buf name; 223 Writer.string buf (id :> string) 224 225 let read_mapping r = 226 let name = Reader.string r in 227 let id = Reader.exercise_id r in 228 (name, id) 229 230 (* --- observation snapshot --- *) 231 232 let write_observation buf (o : WI.observation_snapshot) = 233 Observation_wire.write buf 234 ~exercise_id:(o.exercise_id :> string) 235 ~load:o.load ~reps:o.reps ~performed_at:o.performed_at 236 237 (* Read one observation snapshot, resolving its exercise id to an [Exercise.id] 238 through the catalog. *) 239 let read_observation_snapshot r : WI.observation_snapshot = 240 Observation_wire.read r ~resolve:Reader.exercise_id 241 ~build:(fun ~exercise ~load ~reps ~performed_at -> 242 { WI.exercise_id = exercise; load; reps; performed_at }) 243 244 (* --- promotion snapshot --- *) 245 246 let write_promotion buf (p : WI.promoted_snapshot) = 247 Writer.string buf p.title; 248 Writer.timestamp buf p.started_at; 249 Writer.timestamp buf p.ended_at; 250 Writer.list write_observation buf p.observations; 251 Writer.list Writer.int buf p.source_rows; 252 Writer.option Writer.string buf p.normal_confirmation; 253 Writer.int buf p.revision 254 255 (* --- workout snapshot --- *) 256 257 let write_workout buf (w : WI.workout_snapshot) = 258 Writer.string buf (WI.workout_id_to_string w.id); 259 Writer.string buf w.title; 260 Writer.timestamp buf w.started_at; 261 Writer.timestamp buf w.ended_at; 262 Writer.list write_source_set buf w.sets; 263 Writer.list write_mapping buf w.mappings; 264 Writer.option Writer.string buf w.acknowledgement; 265 Writer.int buf w.revision; 266 Writer.option write_promotion buf w.promotion 267 268 (* --- snapshot --- *) 269 270 let encode_snapshot (s : WI.snapshot) = 271 let buf = Writer.create () in 272 Writer.string buf (WI.batch_id_to_string s.batch_id); 273 Writer.string buf s.source; 274 Writer.string buf s.fingerprint; 275 Writer.timestamp buf s.imported_at; 276 Writer.list write_workout buf s.workouts; 277 Writer.list write_warning buf s.warnings; 278 Writer.contents buf 279 280 (* The reader builds the parser-free {!WI.snapshot}, keeping every exercise id 281 as a raw string. Restoration through {!WI.restore} resolves the ids and 282 rebuilds the opaque batch. The use case therefore reports an unknown id or an 283 invalid time once. *) 284 let read_promotion r : WI.promoted_snapshot = 285 let title = Reader.string r in 286 let started_at = Reader.timestamp r in 287 let ended_at = Reader.timestamp r in 288 let observations = Reader.list read_observation_snapshot r in 289 let source_rows = Reader.list Reader.int r in 290 let normal_confirmation = Reader.option Reader.string r in 291 let revision = Reader.int r in 292 { 293 WI.title; 294 started_at; 295 ended_at; 296 observations; 297 source_rows; 298 normal_confirmation; 299 revision; 300 } 301 302 let read_workout r : WI.workout_snapshot = 303 let id = WI.workout_id (Reader.string r) in 304 let title = Reader.string r in 305 let started_at = Reader.timestamp r in 306 let ended_at = Reader.timestamp r in 307 let sets = Reader.list read_source_set r in 308 let mappings = Reader.list read_mapping r in 309 let acknowledgement = Reader.option Reader.string r in 310 let revision = Reader.int r in 311 let promotion = Reader.option read_promotion r in 312 { 313 WI.id; 314 title; 315 started_at; 316 ended_at; 317 sets; 318 mappings; 319 acknowledgement; 320 revision; 321 promotion; 322 } 323 324 let read_snapshot r : WI.snapshot = 325 let batch_id = WI.batch_id (Reader.string r) in 326 let source = Reader.string r in 327 let fingerprint = Reader.string r in 328 let imported_at = Reader.timestamp r in 329 let workouts = Reader.list read_workout r in 330 let warnings = Reader.list read_warning r in 331 { WI.batch_id; source; fingerprint; imported_at; workouts; warnings } 332 333 let restore_error : WI.restore_error -> error = function 334 | WI.Unknown_exercise id -> Unknown_exercise id 335 | WI.Invalid_time -> Invalid_time 336 | WI.Invalid_effort e -> 337 Malformed 338 (Format.asprintf "observation %a" Evidence.Stimulus.Effort.pp_error e) 339 340 let decode_snapshot ~find_exercise text = 341 match Reader.run text read_snapshot with 342 | Error _ as e -> e 343 | Ok snapshot -> ( 344 match WI.restore ~find_exercise snapshot with 345 | Ok batch -> Ok batch 346 | Error e -> Error (restore_error e)) 347 348 (* --- imported record --- *) 349 350 let encode_record (rec_ : Repository.imported_record) = 351 let buf = Writer.create () in 352 Writer.string buf (WI.batch_id_to_string rec_.batch_id); 353 Writer.string buf (WI.workout_id_to_string rec_.workout_id); 354 Writer.int buf rec_.revision; 355 Writer.string buf rec_.title; 356 Writer.timestamp buf rec_.started_at; 357 Writer.timestamp buf rec_.ended_at; 358 (* An observation is exercise id, load, reps, performed time: a promoted 359 outcome is always Positive_failure, so the outcome is implicit. *) 360 Writer.list 361 (fun buf obs -> 362 let effort = Evidence.Observation.effort obs in 363 Observation_wire.write buf 364 ~exercise_id: 365 (Exercise.id (Evidence.Stimulus.Effort.exercise effort) :> string) 366 ~load:(Evidence.Stimulus.Effort.load effort) 367 ~reps:(Evidence.Stimulus.Effort.reps effort) 368 ~performed_at:(Evidence.Observation.performed_at obs)) 369 buf rec_.observations; 370 (* Provenance. The batch and workout ids repeat the record's own; storing them 371 keeps the provenance self-contained after a decode. *) 372 Writer.string buf (WI.batch_id_to_string rec_.provenance.batch_id); 373 Writer.string buf (WI.workout_id_to_string rec_.provenance.workout_id); 374 Writer.list Writer.int buf rec_.provenance.source_rows; 375 Writer.option Writer.string buf rec_.provenance.normal_confirmation; 376 Writer.int buf rec_.provenance.revision; 377 Writer.contents buf 378 379 (* Read the record's framing. Observations resolve their exercise through the 380 catalog during the read, so an unknown id surfaces as [Unknown_exercise]. *) 381 let read_record r : Repository.imported_record = 382 let batch_id = Reader.string r in 383 let workout_id = Reader.string r in 384 let revision = Reader.int r in 385 let title = Reader.string r in 386 let started_at = Reader.timestamp r in 387 let ended_at = Reader.timestamp r in 388 let observations = 389 Reader.list 390 (fun r -> 391 Observation_wire.read r ~resolve:Reader.exercise 392 ~build:(fun ~exercise ~load ~reps ~performed_at -> 393 let effort = 394 match 395 Evidence.Stimulus.Effort.make ~exercise ~load ~reps 396 ~outcome:Evidence.Stimulus.Positive_failure 397 with 398 | Ok effort -> effort 399 | Error e -> 400 raise 401 (Reader.Bad 402 (Format.asprintf "observation %a" 403 Evidence.Stimulus.Effort.pp_error e)) 404 in 405 Evidence.Observation.make ~exercise ~effort ~performed_at)) 406 r 407 in 408 let prov_batch_id = Reader.string r in 409 let prov_workout_id = Reader.string r in 410 let source_rows = Reader.list Reader.int r in 411 let normal_confirmation = Reader.option Reader.string r in 412 let prov_revision = Reader.int r in 413 { 414 Repository.batch_id = WI.batch_id batch_id; 415 workout_id = WI.workout_id workout_id; 416 revision; 417 title; 418 started_at; 419 ended_at; 420 observations; 421 provenance = 422 { 423 WI.batch_id = WI.batch_id prov_batch_id; 424 workout_id = WI.workout_id prov_workout_id; 425 source_rows; 426 normal_confirmation; 427 revision = prov_revision; 428 }; 429 } 430 431 let decode_record text = 432 match Reader.run text read_record with 433 | Error _ as e -> e 434 | Ok record -> 435 if 436 Recovery.timestamp_to_unix_seconds record.Repository.ended_at 437 < Recovery.timestamp_to_unix_seconds record.Repository.started_at 438 then Error Invalid_time 439 else Ok record 440