1 (** Tests for {!Hito_persistence.Import_codec} — the length-prefixed framing for 2 import batches and promoted records. The framing must preserve arbitrary 3 bytes in every free-text field, and a decode must rebuild the batch and its 4 promotion exactly, so {!Already_promoted} and edited re-promotion survive a 5 reconnect. *) 6 7 open Hito_app 8 open Hito_persistence 9 module WI = Workout_import 10 11 let get id = 12 match Exercise.find_id id with 13 | Some e -> e 14 | None -> Alcotest.failf "catalog is missing %S" id 15 16 let at s = Recovery.timestamp_of_unix_seconds s 17 let ok = function Ok v -> v | Error _ -> Alcotest.fail "expected Ok" 18 let find_exercise (id : Exercise.id) = Exercise.find_id (id :> string) 19 let wid = WI.workout_id 20 21 (* Awkward text: commas, newlines, colons, and non-ASCII UTF-8. A length-prefixed 22 field must carry every byte verbatim. *) 23 let nasty = "a,b\nc:d\t\"quote\" — café 🏋️, 12:corrupt\n99:end" 24 25 let set ?(row = 0) ?(set_index = 1) ?(superset_id = None) ~name ~kind ~kg ~reps 26 () : WI.source_set = 27 { 28 row; 29 exercise_name = name; 30 set_index; 31 set_type = kind; 32 weight_kg = kg; 33 reps; 34 superset_id; 35 } 36 37 (* A batch with a failure set and a normal set, both under one awkward exercise 38 name, plus an awkward warning and awkward source text. *) 39 let sample_batch () = 40 let sets = 41 [ 42 set ~row:1 ~name:nasty ~kind:WI.Failure ~kg:102.5 ~reps:8 (); 43 set ~row:2 ~name:nasty ~kind:WI.Normal ~kg:60.0 ~reps:10 44 ~superset_id:(Some 3) (); 45 ] 46 in 47 let w = 48 ok 49 (WI.make_workout ~id:(wid "w1") ~title:nasty ~started_at:(at 1_000) 50 ~ended_at:(at 4_600) ~sets) 51 in 52 let warnings = 53 [ 54 { 55 WI.row = 7; 56 exercise_name = Some nasty; 57 kind = WI.Unsupported_row nasty; 58 }; 59 ] 60 in 61 WI.make_batch ~id:(WI.batch_id "b1") ~source:nasty ~fingerprint:"fp-🔒" 62 ~imported_at:(at 5_000) ~workouts:[ w ] ~warnings 63 64 (* Map, acknowledge, and promote, so the snapshot carries a promotion. *) 65 let promoted_batch () = 66 let b = sample_batch () in 67 let b = 68 ok (WI.map_exercise b ~workout:(wid "w1") ~source_name:nasty (get "squats")) 69 in 70 let b = 71 ok (WI.confirm_normal_sets b ~workout:(wid "w1") ~acknowledgement:nasty) 72 in 73 let b, _ = ok (WI.promote_workout b (wid "w1")) in 74 b 75 76 let roundtrip_batch b = 77 let encoded = Import_codec.encode_snapshot (WI.snapshot b) in 78 match Import_codec.decode_snapshot ~find_exercise encoded with 79 | Ok b' -> b' 80 | Error e -> Alcotest.failf "decode failed: %a" Import_codec.pp_error e 81 82 let codec_tests = 83 [ 84 ( "an unpromoted batch round-trips, preserving special characters", 85 `Quick, 86 fun () -> 87 let b = sample_batch () in 88 let d = roundtrip_batch b in 89 Alcotest.(check string) 90 "source verbatim" (WI.batch_source b) (WI.batch_source d); 91 Alcotest.(check string) 92 "fingerprint verbatim" (WI.batch_fingerprint b) 93 (WI.batch_fingerprint d); 94 Alcotest.(check int) 95 "imported_at seconds" 96 (Recovery.timestamp_to_unix_seconds (WI.batch_imported_at b)) 97 (Recovery.timestamp_to_unix_seconds (WI.batch_imported_at d)); 98 let w = Option.get (WI.find_workout d (wid "w1")) in 99 Alcotest.(check string) "title verbatim" nasty (WI.workout_title w); 100 Alcotest.(check int) "two sets" 2 (List.length (WI.workout_sets w)); 101 match WI.batch_warnings d with 102 | [ { kind = WI.Unsupported_row detail; exercise_name = Some name; _ } ] 103 -> 104 Alcotest.(check string) "warning detail verbatim" nasty detail; 105 Alcotest.(check string) "warning name verbatim" nasty name 106 | _ -> Alcotest.fail "expected one unsupported-row warning" ); 107 ( "a mapping round-trips and stays confirmed", 108 `Quick, 109 fun () -> 110 let b = sample_batch () in 111 let b = 112 ok 113 (WI.map_exercise b ~workout:(wid "w1") ~source_name:nasty 114 (get "squats")) 115 in 116 let d = roundtrip_batch b in 117 let w = Option.get (WI.find_workout d (wid "w1")) in 118 match WI.workout_mapping w ~source_name:nasty with 119 | Some e -> 120 Alcotest.(check bool) 121 "mapped to squats" true 122 (Exercise.equal e (get "squats")) 123 | None -> Alcotest.fail "expected the mapping to survive" ); 124 ( "a promotion round-trips, preserving acknowledgement and revision", 125 `Quick, 126 fun () -> 127 let b = promoted_batch () in 128 let d = roundtrip_batch b in 129 let w = Option.get (WI.find_workout d (wid "w1")) in 130 Alcotest.(check string) 131 "acknowledgement verbatim" nasty 132 (Option.get (WI.workout_acknowledgement w)); 133 (* Re-promoting the decoded batch at the same revision is idempotent: 134 the promotion survived the round-trip. *) 135 let _, result = ok (WI.promote_workout d (wid "w1")) in 136 match result with 137 | WI.Already_promoted p -> 138 Alcotest.(check int) 139 "two observations" 2 140 (List.length p.observations); 141 Alcotest.(check (option string)) 142 "normal confirmation verbatim" (Some nasty) 143 p.provenance.normal_confirmation 144 | WI.Promoted _ -> 145 Alcotest.fail "expected Already_promoted, not a fresh promotion" 146 | WI.Blocked _ -> Alcotest.fail "expected Already_promoted, not Blocked" 147 ); 148 ( "an unknown exercise id in a snapshot is reported, not raised", 149 `Quick, 150 fun () -> 151 let b = promoted_batch () in 152 let encoded = Import_codec.encode_snapshot (WI.snapshot b) in 153 (* Resolve nothing: every id is unknown to this catalog view. *) 154 match 155 Import_codec.decode_snapshot ~find_exercise:(fun _ -> None) encoded 156 with 157 | Error (Import_codec.Unknown_exercise _) -> () 158 | _ -> Alcotest.fail "expected Unknown_exercise" ); 159 ( "truncated framing is reported as malformed", 160 `Quick, 161 fun () -> 162 match 163 Import_codec.decode_snapshot ~find_exercise "100:not-that-long" 164 with 165 | Error (Import_codec.Malformed _) -> () 166 | _ -> Alcotest.fail "expected Malformed" ); 167 ] 168 169 (* A promoted record built straight from a promotion, for the record codec. *) 170 let sample_record () : Repository.imported_record = 171 let b = promoted_batch () in 172 match WI.snapshot b with 173 | { workouts = [ { promotion = Some p; id; _ } ]; batch_id; _ } -> 174 let observations = 175 List.map 176 (fun (o : WI.observation_snapshot) -> 177 let exercise = get (o.exercise_id :> string) in 178 let effort = 179 Result.get_ok 180 (Evidence.Stimulus.Effort.make ~exercise ~load:o.load 181 ~reps:o.reps ~outcome:Evidence.Stimulus.Positive_failure) 182 in 183 Evidence.Observation.make ~exercise ~effort 184 ~performed_at:o.performed_at) 185 p.observations 186 in 187 { 188 batch_id; 189 workout_id = id; 190 revision = p.revision; 191 title = p.title; 192 started_at = p.started_at; 193 ended_at = p.ended_at; 194 observations; 195 provenance = 196 { 197 WI.batch_id; 198 workout_id = id; 199 source_rows = p.source_rows; 200 normal_confirmation = p.normal_confirmation; 201 revision = p.revision; 202 }; 203 } 204 | _ -> Alcotest.fail "expected one promoted workout in the snapshot" 205 206 let record_tests = 207 [ 208 ( "a promoted record round-trips, preserving special characters", 209 `Quick, 210 fun () -> 211 let r = sample_record () in 212 let encoded = Import_codec.encode_record r in 213 match Import_codec.decode_record encoded with 214 | Ok d -> 215 Alcotest.(check string) "title verbatim" nasty d.Repository.title; 216 Alcotest.(check int) "revision" r.revision d.revision; 217 Alcotest.(check int) 218 "same observation count" 219 (List.length r.observations) 220 (List.length d.observations); 221 Alcotest.(check (option string)) 222 "normal confirmation verbatim" (Some nasty) 223 d.provenance.normal_confirmation; 224 Alcotest.(check (list int)) 225 "source rows" r.provenance.source_rows d.provenance.source_rows 226 | Error e -> Alcotest.failf "decode failed: %a" Import_codec.pp_error e 227 ); 228 ( "truncated record framing is reported, not raised", 229 `Quick, 230 fun () -> 231 let r = sample_record () in 232 let encoded = Import_codec.encode_record r in 233 (* Drop the final byte: the framing no longer lines up. *) 234 let truncated = String.sub encoded 0 (String.length encoded - 1) in 235 match Import_codec.decode_record truncated with 236 | Error _ -> () 237 | Ok _ -> Alcotest.fail "expected a decode error on truncated text" ); 238 ] 239 240 let suite = [ ("import_codec", codec_tests); ("import_record", record_tests) ] 241