1 open Lwt.Infix 2 module Repo = Hito_persistence.Sqlite_repo 3 module WI = Hito_app.Workout_import 4 5 module Service = 6 Hito_app.Service.Make 7 (Hito_persistence.Sqlite_repo) 8 (Hito_persistence.Bcrypt_hash) 9 10 module Development_seed = 11 Hito_app.Development_seed.Make 12 (Hito_persistence.Sqlite_repo) 13 (Hito_persistence.Bcrypt_hash) 14 15 (* The trainee's real Hevy export, imported as personal history through the 16 Workout_import use case rather than fabricated. The use case gates what the 17 core ever sees: only a set whose source exercise maps to the curated catalog 18 promotes to canonical evidence. The parser drops warmups, cardio, and 19 bodyweight rows without a load as warnings. The parser discards a drop set 20 the way it discards a warmup, because HD1 keeps only the drive to failure, 21 never the strip rounds. A drop set therefore neither promotes nor blocks. An 22 unmapped exercise blocks only itself. All of that is doctrine, not loss: HD1 23 favours a curated catalog over novelty, and the app retains a deviation 24 rather than guessing at it. *) 25 26 (* Hevy datetimes are local wall time. The export was recorded at UTC+2. *) 27 let utc_offset_seconds = 7200 28 29 (* Maps a Hevy export exercise name to a curated catalog id. Only names with a 30 defensible HD1 equivalent appear here. A name absent from this table stays 31 unmapped, so its workout blocks on [Unmapped_exercise] rather than promoting 32 a guess — "focus over novelty" (HD1, "The Routine"). Trap-bar and Romanian 33 deadlifts, the machine squat, machine chest and shoulder presses, and the 34 flat barbell bench have no Standard catalog entry, so the table leaves them 35 unmapped on purpose. *) 36 let catalog_of_source name = 37 let id = 38 match name with 39 | "Deadlift (Barbell)" -> Some "deadlifts" 40 | "Squat (Barbell)" -> Some "squats" 41 | "Leg Press (Machine)" -> Some "leg-presses" 42 | "Leg Extension (Machine)" | "Single Leg Extensions" -> 43 Some "leg-extensions" 44 | "Lateral Raise (Dumbbell)" | "Lateral Raise (Machine)" -> Some "laterals" 45 | "Bicep Curl (Barbell)" -> Some "curls" 46 | "Preacher Curl (Barbell)" -> Some "preacher-curls" 47 | "Bent Over Row (Barbell)" -> Some "bent-over-rows" 48 | "Pullover (Dumbbell)" | "Pullover (Machine)" -> Some "pullovers" 49 (* A reverse (underhand) grip pulldown is HD1's close-grip, palms-up 50 pulldown. *) 51 | "Reverse Grip Lat Pulldown (Cable)" -> Some "close-grip-pulldowns" 52 | "Triceps Pushdown" -> Some "pressdowns" 53 | "Calf Extension (Machine)" | "Seated Calf Raise" 54 | "Standing Calf Raise (Machine)" -> 55 Some "calf-raises" 56 | _ -> None 57 in 58 Option.bind id Exercise.find_id 59 60 (* The acknowledgement retained for a workout whose normal sets promote. A 61 normal set is a working set the export did not mark as taken to failure, so 62 promoting it as failure-defined evidence is a deviation. It must be possible 63 but never silent (domain.md, "Encoding rules"). *) 64 let normal_ack = "Imported from Hevy: recorded as a working set to failure." 65 66 let read_file path = 67 let ic = open_in_bin path in 68 Fun.protect 69 ~finally:(fun () -> close_in ic) 70 (fun () -> 71 let n = in_channel_length ic in 72 really_input_string ic n) 73 74 (* Distinct source exercise names in a workout, in first-appearance order. *) 75 let source_names workout = 76 List.fold_left 77 (fun acc (s : WI.source_set) -> 78 if List.mem s.WI.exercise_name acc then acc else s.WI.exercise_name :: acc) 79 [] (WI.workout_sets workout) 80 |> List.rev 81 82 let has_normal_set workout = 83 List.exists 84 (fun (s : WI.source_set) -> s.WI.set_type = WI.Normal) 85 (WI.workout_sets workout) 86 87 (* Import [csv_path] for [trainee_id] as one batch: store it, map every source 88 name that has a catalog equivalent, acknowledge the normal sets of any 89 workout that has one, then promote the whole batch. Promotion is partial. The 90 batch keeps a blocked workout for later review and never forces it. *) 91 let import_csv repo trainee_id ~csv_path = 92 let source = read_file csv_path in 93 let fingerprint = Digest.to_hex (Digest.string source) in 94 let imported_at = 95 Recovery.timestamp_of_unix_seconds (int_of_float (Unix.gettimeofday ())) 96 in 97 let batch_id = WI.batch_id ("hevy-" ^ String.sub fingerprint 0 12) in 98 match 99 Hito_import.Hevy_csv.parse ~batch_id ~fingerprint ~imported_at 100 ~utc_offset_seconds source 101 with 102 | Error e -> 103 Format.eprintf "hito: cannot parse %s: %a@." csv_path 104 Hito_import.Hevy_csv.pp_error e; 105 exit 1 106 | Ok batch -> 107 let service = Service.make ~repo in 108 let unwrap step = function 109 | Ok v -> Lwt.return v 110 | Error _ -> 111 Format.eprintf "hito: import step %s failed@." step; 112 exit 1 113 in 114 Service.store_import_batch service trainee_id batch >>= unwrap "store" 115 >>= fun () -> 116 (* Map and confirm each workout, then promote the batch once. *) 117 Lwt_list.iter_s 118 (fun workout -> 119 let wid = WI.workout_identity workout in 120 Lwt_list.iter_s 121 (fun name -> 122 match catalog_of_source name with 123 | None -> Lwt.return_unit 124 | Some exercise -> 125 Service.map_import_exercise service trainee_id ~batch:batch_id 126 ~workout:wid ~source_name:name exercise 127 >>= unwrap "map" >|= ignore) 128 (source_names workout) 129 >>= fun () -> 130 if has_normal_set workout then 131 Service.confirm_import_normal_sets service trainee_id 132 ~batch:batch_id ~workout:wid ~acknowledgement:normal_ack 133 >>= unwrap "confirm" >|= ignore 134 else Lwt.return_unit) 135 (WI.batch_workouts batch) 136 >>= fun () -> 137 Service.promote_import_batch service trainee_id ~batch:batch_id 138 >>= unwrap "promote" 139 >|= fun result -> 140 Printf.eprintf 141 "hito: imported Hevy export: promoted %d, already promoted %d, blocked \ 142 %d\n\ 143 %!" 144 (List.length result.WI.promoted) 145 (List.length result.WI.already_promoted) 146 (List.length result.WI.blocked) 147 148 (* Idempotent. The function skips the import when the trainee already has 149 promoted records. *) 150 let seed_history repo trainee_id ~csv_path = 151 Service.make ~repo |> fun service -> 152 Service.imported_records service trainee_id >>= fun records -> 153 if records <> [] then Lwt.return_unit 154 else if not (Sys.file_exists csv_path) then ( 155 (* The Hevy export is a local, uncommitted convenience. A deployment ships 156 no CSV, so its absence is normal: seed the account and routine, and skip 157 the import rather than crashing on a missing file. *) 158 Printf.eprintf "hito: seed CSV %s not found; skipping import\n%!" csv_path; 159 Lwt.return_unit) 160 else import_csv repo trainee_id ~csv_path 161 162 let single_user repo ~password ~csv_path = 163 let service = Service.make ~repo in 164 Service.register service ~username:"blendux" ~password >>= function 165 | Ok trainee -> 166 Repo.set_active_routine repo trainee.Hito_app.Trainee.id 167 (Hito_app.Repository.routine_id "ideal") 168 >>= fun () -> seed_history repo trainee.Hito_app.Trainee.id ~csv_path 169 | Error Service.Username_taken -> ( 170 match Hito_app.Trainee.username "blendux" with 171 | Error _ -> Lwt.return_unit 172 | Ok username -> ( 173 Repo.find_trainee_by_username repo username >>= fun trainee_opt -> 174 match trainee_opt with 175 | None -> Lwt.return_unit 176 | Some trainee -> 177 seed_history repo trainee.Hito_app.Trainee.id ~csv_path)) 178 | Error (Service.Username_invalid e) -> 179 Format.eprintf "hito: cannot seed user: %a@." 180 Hito_app.Trainee.pp_username_error e; 181 exit 1 182 183 let development_user repo = 184 let now = 185 Recovery.timestamp_of_unix_seconds (int_of_float (Unix.gettimeofday ())) 186 in 187 Development_seed.seed repo ~now 188