1 open Lwt.Infix 2 open Hito_app 3 4 exception Corrupt of Codec.error 5 exception Import_corrupt of Import_codec.error 6 7 type t = { pool : (Caqti_lwt.connection, Caqti_error.t) Caqti_lwt_unix.Pool.t } 8 9 (* --- request definitions --- *) 10 11 module Q = struct 12 open Caqti_request.Infix 13 open Caqti_type.Std 14 15 let insert_trainee = 16 (t3 string string string ->. unit) 17 "INSERT INTO trainee (id, username, credential) VALUES (?, ?, ?)" 18 19 let trainee_by_username = 20 (string ->? t3 string string string) 21 "SELECT id, username, credential FROM trainee WHERE username = ?" 22 23 let trainee_by_id = 24 (string ->? t3 string string string) 25 "SELECT id, username, credential FROM trainee WHERE id = ?" 26 27 let next_trainee = 28 (unit ->! int) 29 "SELECT COALESCE(MAX(CAST(SUBSTR(id, 2) AS INTEGER)), 0) + 1 FROM \ 30 trainee WHERE id GLOB 't[0-9]*'" 31 32 let update_username = 33 (t2 string string ->. unit) "UPDATE trainee SET username = ? WHERE id = ?" 34 35 let update_credential = 36 (t2 string string ->. unit) "UPDATE trainee SET credential = ? WHERE id = ?" 37 38 let get_active = 39 (string ->? string) 40 "SELECT routine_id FROM active_routine WHERE trainee_id = ?" 41 42 let set_active = 43 (t2 string string ->. unit) 44 "INSERT INTO active_routine (trainee_id, routine_id) VALUES (?, ?) ON \ 45 CONFLICT (trainee_id) DO UPDATE SET routine_id = excluded.routine_id" 46 47 let get_in_progress = 48 (string ->? string) "SELECT encoded FROM in_progress WHERE trainee_id = ?" 49 50 let set_in_progress = 51 (t2 string string ->. unit) 52 "INSERT INTO in_progress (trainee_id, encoded) VALUES (?, ?) ON CONFLICT \ 53 (trainee_id) DO UPDATE SET encoded = excluded.encoded" 54 55 let clear_in_progress = 56 (string ->. unit) "DELETE FROM in_progress WHERE trainee_id = ?" 57 58 let next_seq = 59 (string ->! int) 60 "SELECT COALESCE(MAX(seq), 0) + 1 FROM workout WHERE trainee_id = ?" 61 62 let insert_workout = 63 (t4 string string int string ->. unit) 64 "INSERT INTO workout (id, trainee_id, seq, encoded) VALUES (?, ?, ?, ?)" 65 66 let workout_by_id = 67 (t2 string string ->? string) 68 "SELECT encoded FROM workout WHERE trainee_id = ? AND id = ?" 69 70 let update_workout = 71 (t3 string string string ->. unit) 72 "UPDATE workout SET encoded = ? WHERE trainee_id = ? AND id = ?" 73 74 let delete_workout = 75 (t2 string string ->. unit) 76 "DELETE FROM workout WHERE trainee_id = ? AND id = ?" 77 78 let history = 79 (string ->* t2 string string) 80 "SELECT id, encoded FROM workout WHERE trainee_id = ? ORDER BY seq DESC" 81 82 let next_feedback_seq = 83 (string ->! int) 84 "SELECT COALESCE(MAX(seq), 0) + 1 FROM feedback WHERE trainee_id = ?" 85 86 let insert_feedback = 87 (t3 string int string ->. unit) 88 "INSERT INTO feedback (trainee_id, seq, encoded) VALUES (?, ?, ?)" 89 90 let feedback = 91 (string ->* string) 92 "SELECT encoded FROM feedback WHERE trainee_id = ? ORDER BY seq DESC" 93 94 let next_app_feedback_seq = 95 (string ->! int) 96 "SELECT COALESCE(MAX(seq), 0) + 1 FROM app_feedback WHERE trainee_id = ?" 97 98 let insert_app_feedback = 99 (t4 string int string string ->. unit) 100 "INSERT INTO app_feedback (trainee_id, seq, submitted_at, message) \ 101 VALUES (?, ?, ?, ?)" 102 103 let app_feedback = 104 (unit ->* t7 string int string string string int int) 105 "SELECT f.trainee_id, f.seq, t.username, f.submitted_at, f.message, \ 106 (SELECT COUNT(*) FROM app_feedback c WHERE c.trainee_id = \ 107 f.trainee_id), (SELECT COUNT(*) FROM app_feedback_vote v WHERE \ 108 v.feedback_trainee_id = f.trainee_id AND v.feedback_seq = f.seq) FROM \ 109 app_feedback f JOIN trainee t ON t.id = f.trainee_id ORDER BY 7 DESC, \ 110 f.submitted_at DESC, f.trainee_id, f.seq DESC" 111 112 let viewer_votes = 113 (string ->* t2 string int) 114 "SELECT feedback_trainee_id, feedback_seq FROM app_feedback_vote WHERE \ 115 voter_id = ?" 116 117 let feedback_owner = 118 (t2 string int ->? string) 119 "SELECT trainee_id FROM app_feedback WHERE trainee_id = ? AND seq = ?" 120 121 let vote_exists = 122 (t3 string int string ->? int) 123 "SELECT 1 FROM app_feedback_vote WHERE feedback_trainee_id = ? AND \ 124 feedback_seq = ? AND voter_id = ?" 125 126 let insert_vote = 127 (t3 string int string ->. unit) 128 "INSERT INTO app_feedback_vote (feedback_trainee_id, feedback_seq, \ 129 voter_id) VALUES (?, ?, ?)" 130 131 let update_app_feedback = 132 (t3 string string int ->. unit) 133 "UPDATE app_feedback SET message = ? WHERE trainee_id = ? AND seq = ?" 134 135 let delete_feedback_votes = 136 (t2 string int ->. unit) 137 "DELETE FROM app_feedback_vote WHERE feedback_trainee_id = ? AND \ 138 feedback_seq = ?" 139 140 let delete_app_feedback = 141 (t2 string int ->. unit) 142 "DELETE FROM app_feedback WHERE trainee_id = ? AND seq = ?" 143 144 (* --- workout import --- *) 145 146 let upsert_import_batch = 147 (t6 string string string string string string ->. unit) 148 "INSERT INTO import_batch (trainee_id, batch_id, imported_at, source, \ 149 fingerprint, snapshot) VALUES (?, ?, ?, ?, ?, ?) ON CONFLICT \ 150 (trainee_id, batch_id) DO UPDATE SET imported_at = \ 151 excluded.imported_at, source = excluded.source, fingerprint = \ 152 excluded.fingerprint, snapshot = excluded.snapshot" 153 154 let import_batch_by_id = 155 (t2 string string ->? string) 156 "SELECT snapshot FROM import_batch WHERE trainee_id = ? AND batch_id = ?" 157 158 let import_batches = 159 (string ->* string) 160 "SELECT snapshot FROM import_batch WHERE trainee_id = ? ORDER BY \ 161 imported_at DESC, batch_id DESC" 162 163 let delete_import_batch = 164 (t2 string string ->. unit) 165 "DELETE FROM import_batch WHERE trainee_id = ? AND batch_id = ?" 166 167 let import_batch_exists = 168 (t2 string string ->? int) 169 "SELECT 1 FROM import_batch WHERE trainee_id = ? AND batch_id = ?" 170 171 let upsert_imported_record = 172 (t2 (t4 string string string int) (t4 string string string string) ->. unit) 173 "INSERT INTO imported_record (trainee_id, workout_id, batch_id, \ 174 revision, title, started_at, ended_at, snapshot) VALUES (?, ?, ?, ?, ?, \ 175 ?, ?, ?) ON CONFLICT (trainee_id, workout_id) DO UPDATE SET batch_id = \ 176 excluded.batch_id, revision = excluded.revision, title = \ 177 excluded.title, started_at = excluded.started_at, ended_at = \ 178 excluded.ended_at, snapshot = excluded.snapshot" 179 180 let imported_records = 181 (string ->* string) 182 "SELECT snapshot FROM imported_record WHERE trainee_id = ? ORDER BY \ 183 ended_at DESC" 184 end 185 186 (* --- pool helper --- *) 187 188 let run t f = Caqti_lwt_unix.Pool.use f t.pool >>= Caqti_lwt.or_fail 189 190 let q_exec t query data = 191 run t (fun (module Db : Caqti_lwt.CONNECTION) -> Db.exec query data) 192 193 let q_find t query data = 194 run t (fun (module Db : Caqti_lwt.CONNECTION) -> Db.find query data) 195 196 let q_find_opt t query data = 197 run t (fun (module Db : Caqti_lwt.CONNECTION) -> Db.find_opt query data) 198 199 let q_collect_list t query data = 200 run t (fun (module Db : Caqti_lwt.CONNECTION) -> Db.collect_list query data) 201 202 (* SQLite admits one writer at a time. Without a busy timeout a second writer 203 fails at once with SQLITE_BUSY; with one it waits its turn. The driver reads 204 [busy_timeout] (milliseconds) from the URI, so a caller who sets it keeps 205 their value and everyone else gets a five-second wait, which serialises 206 overlapping transactions instead of failing them. *) 207 let default_busy_timeout_ms = 5_000 208 209 let with_busy_timeout uri = 210 match Uri.get_query_param uri "busy_timeout" with 211 | Some _ -> uri 212 | None -> 213 Uri.add_query_param' uri 214 ("busy_timeout", string_of_int default_busy_timeout_ms) 215 216 let connect ?pool_config uri = 217 match 218 Caqti_lwt_unix.connect_pool ?pool_config 219 (with_busy_timeout (Uri.of_string uri)) 220 with 221 | Error e -> Lwt.return (Error (e :> Caqti_error.t)) 222 | Ok pool -> 223 let open Lwt_result.Syntax in 224 let* () = Caqti_lwt_unix.Pool.use Migrations.apply pool in 225 Lwt_result.return { pool } 226 227 (* --- decoding stored workouts --- *) 228 229 let find_routine_by_name = Catalog.find_by_name 230 231 (* A stored row the codec refuses is corrupt: a storage invariant failed, not a 232 user error. A targeted read of one record raises [Corrupt], because the caller 233 asked for that record and silently answering "not found" would lose it. A 234 list read quarantines the row instead: it is skipped and reported here, so 235 one bad row never hides a trainee's whole history. *) 236 let warn_corrupt ~what ~id detail = 237 Printf.eprintf "hito: corrupt %s %S skipped: %s\n%!" what id detail 238 239 let decode encoded = 240 match Codec.decode_workout ~find_routine:find_routine_by_name encoded with 241 | Ok workout -> workout 242 | Error e -> raise (Corrupt e) 243 244 (* Decode one history row, or quarantine it. *) 245 let decode_history_row (wid, encoded) = 246 match Codec.decode_workout ~find_routine:find_routine_by_name encoded with 247 | Ok workout -> Some { Repository.id = Repository.workout_id wid; workout } 248 | Error e -> 249 warn_corrupt ~what:"workout" ~id:wid 250 (Format.asprintf "%a" Codec.pp_error e); 251 None 252 253 (* --- accounts --- *) 254 255 (* Create the account in one transaction: check the name is free, take the next 256 id, and insert, all under SQLite's write lock. The id comes from the table 257 itself on every call, never from a process-local counter, so two concurrent 258 registrations cannot mint the same id and a file edited outside this process 259 cannot drift from an in-memory count. The UNIQUE constraint on username is 260 the final arbiter; the transaction makes the check-then-insert atomic. *) 261 let create_trainee t ~username ~credential = 262 let username_s = Trainee.username_to_string username in 263 let credential_s = Trainee.credential_to_hash credential in 264 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 265 let open Lwt_result.Syntax in 266 Db.with_transaction (fun () -> 267 let* existing = Db.find_opt Q.trainee_by_username username_s in 268 match existing with 269 | Some _ -> Lwt_result.return (Error Repository.Username_taken) 270 | None -> 271 let* next = Db.find Q.next_trainee () in 272 let id = Printf.sprintf "t%d" next in 273 let* () = 274 Db.exec Q.insert_trainee (id, username_s, credential_s) 275 in 276 Lwt_result.return 277 (Ok { Trainee.id = Trainee.id id; username; credential }))) 278 279 let trainee_of_row (id, username, credential) = 280 match Trainee.username username with 281 | Ok username -> 282 Some 283 { 284 Trainee.id = Trainee.id id; 285 username; 286 credential = Trainee.credential_of_hash credential; 287 } 288 | Error _ -> None 289 290 let find_trainee_by_username t username = 291 q_find_opt t Q.trainee_by_username (Trainee.username_to_string username) 292 >|= function 293 | Some row -> trainee_of_row row 294 | None -> None 295 296 let find_trainee t id = 297 q_find_opt t Q.trainee_by_id (Trainee.id_to_string id) >|= function 298 | Some row -> trainee_of_row row 299 | None -> None 300 301 (* Rename in one transaction: check the name is free for anyone else, then 302 update. Both statements run on the same connection, so the check and the 303 write cannot race another rename. The trainee's own current name is a no-op. 304 *) 305 let update_username t id (username : Trainee.username) = 306 let trainee = Trainee.id_to_string id in 307 let username_s = Trainee.username_to_string username in 308 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 309 let open Lwt_result.Syntax in 310 Db.with_transaction (fun () -> 311 let* holder = Db.find_opt Q.trainee_by_username username_s in 312 match holder with 313 | Some (holder_id, _, _) when not (String.equal holder_id trainee) -> 314 Lwt_result.return (Error Repository.Username_taken) 315 | _ -> 316 let* () = Db.exec Q.update_username (username_s, trainee) in 317 let* row = Db.find_opt Q.trainee_by_id trainee in 318 Lwt_result.return 319 (match Option.bind row trainee_of_row with 320 | Some updated -> Ok updated 321 | None -> Error Repository.Username_taken))) 322 323 let update_credential t id credential = 324 let trainee = Trainee.id_to_string id in 325 q_exec t Q.update_credential (Trainee.credential_to_hash credential, trainee) 326 >>= fun () -> find_trainee t id 327 328 (* --- catalog --- *) 329 330 let list_routines _ = Catalog.routines 331 let find_routine _ id = Catalog.find id 332 333 (* The routine name a workout's prescription belongs to, for encoding. Only the 334 ideal routine exists, but resolve it honestly rather than hard-code. *) 335 let routine_name_of workout = 336 let workout_name = 337 Prescription.Workout.name (Evidence.Workout.prescription workout) 338 in 339 List.find_map 340 (fun (_, routine) -> 341 if 342 List.exists 343 (fun w -> String.equal (Prescription.Workout.name w) workout_name) 344 (Prescription.Routine.workouts routine) 345 then Some (Prescription.Routine.name routine) 346 else None) 347 Catalog.routines 348 |> Option.value ~default:"" 349 350 let encode workout = 351 Codec.encode_workout ~routine_name:(routine_name_of workout) workout 352 353 (* --- per-trainee selection and workout in progress --- *) 354 355 let active_routine t id = 356 q_find_opt t Q.get_active (Trainee.id_to_string id) 357 >|= Option.map Repository.routine_id 358 359 let set_active_routine t id (routine : Repository.routine_id) = 360 q_exec t Q.set_active (Trainee.id_to_string id, (routine :> string)) 361 362 let in_progress t id = 363 q_find_opt t Q.get_in_progress (Trainee.id_to_string id) >|= function 364 | None -> None 365 | Some encoded -> Some (decode encoded) 366 367 let set_in_progress t id workout = 368 let trainee = Trainee.id_to_string id in 369 match workout with 370 | None -> q_exec t Q.clear_in_progress trainee 371 | Some workout -> q_exec t Q.set_in_progress (trainee, encode workout) 372 373 (* --- history --- *) 374 375 (* Save a finished workout and clear the in-progress slot in one transaction, 376 so the two rows never disagree after a crash. Both statements run on the same 377 connection, checked out once, inside [with_transaction]. *) 378 let finish_workout t id workout = 379 let trainee = Trainee.id_to_string id in 380 let encoded = encode workout in 381 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 382 let open Lwt_result.Syntax in 383 Db.with_transaction (fun () -> 384 let* seq = Db.find Q.next_seq trainee in 385 let wid = Printf.sprintf "%s:w%d" trainee seq in 386 let* () = Db.exec Q.insert_workout (wid, trainee, seq, encoded) in 387 let* () = Db.exec Q.clear_in_progress trainee in 388 Lwt_result.return 389 { Repository.id = Repository.workout_id wid; workout })) 390 391 let find t id (wid : Repository.workout_id) = 392 q_find_opt t Q.workout_by_id (Trainee.id_to_string id, (wid :> string)) 393 >|= function 394 | None -> None 395 | Some encoded -> Some { Repository.id = wid; workout = decode encoded } 396 397 let replace t id record = 398 let trainee = Trainee.id_to_string id in 399 q_find_opt t Q.workout_by_id (trainee, (record.Repository.id :> string)) 400 >>= function 401 | None -> Lwt.return false 402 | Some _ -> 403 q_exec t Q.update_workout 404 ( encode record.Repository.workout, 405 trainee, 406 (record.Repository.id :> string) ) 407 >|= fun () -> true 408 409 let delete_workout t id (wid : Repository.workout_id) = 410 let trainee = Trainee.id_to_string id in 411 q_find_opt t Q.workout_by_id (trainee, (wid :> string)) >>= function 412 | None -> Lwt.return false 413 | Some _ -> 414 q_exec t Q.delete_workout (trainee, (wid :> string)) >|= fun () -> true 415 416 let history t id = 417 q_collect_list t Q.history (Trainee.id_to_string id) 418 >|= List.filter_map decode_history_row 419 420 let log t id = 421 history t id >|= fun records -> 422 List.fold_left 423 (fun log record -> Evidence.Log.add log record.Repository.workout) 424 Evidence.Log.empty (List.rev records) 425 426 (* --- subjective feedback --- *) 427 428 let save_feedback t id report = 429 let trainee = Trainee.id_to_string id in 430 let encoded = Codec.encode_feedback report in 431 q_find t Q.next_feedback_seq trainee >>= fun seq -> 432 q_exec t Q.insert_feedback (trainee, seq, encoded) 433 434 (* Quarantine a corrupt row in a list read, naming its position. *) 435 let quarantine ~what ~pp_error decode rows = 436 List.mapi (fun i encoded -> (i + 1, decode encoded)) rows 437 |> List.filter_map (fun (position, decoded) -> 438 match decoded with 439 | Ok v -> Some v 440 | Error e -> 441 warn_corrupt ~what ~id:(string_of_int position) 442 (Format.asprintf "%a" pp_error e); 443 None) 444 445 let feedback t id = 446 q_collect_list t Q.feedback (Trainee.id_to_string id) 447 >|= quarantine ~what:"feedback report" ~pp_error:Codec.pp_error 448 Codec.decode_feedback 449 450 let save_app_feedback t id ~submitted_at ~message = 451 let trainee = Trainee.id_to_string id in 452 find_trainee t id >>= function 453 | None -> 454 Lwt.fail_with "cannot save application feedback for an unknown trainee" 455 | Some author -> 456 q_find t Q.next_app_feedback_seq trainee >>= fun seq -> 457 q_exec t Q.insert_app_feedback 458 (trainee, seq, Timestamp.encode submitted_at, message) 459 >|= fun () -> 460 Repository. 461 { 462 feedback_id = app_feedback_id (Printf.sprintf "%s:%d" trainee seq); 463 author = Trainee.username_to_string author.Trainee.username; 464 contributions = seq; 465 submitted_at; 466 message; 467 upvotes = 0; 468 viewer_upvoted = false; 469 viewer_owns = true; 470 } 471 472 let app_feedback t ~viewer = 473 q_collect_list t Q.app_feedback () >>= fun rows -> 474 q_collect_list t Q.viewer_votes (Trainee.id_to_string viewer) >|= fun voted -> 475 List.map 476 (fun (trainee, seq, author, submitted_at, message, contributions, upvotes) 477 -> 478 let submitted_at = 479 match Timestamp.decode submitted_at with 480 | Ok timestamp -> timestamp 481 | Error _ -> 482 raise (Corrupt (Codec.Malformed "application feedback timestamp")) 483 in 484 Repository. 485 { 486 feedback_id = app_feedback_id (Printf.sprintf "%s:%d" trainee seq); 487 author; 488 contributions; 489 submitted_at; 490 message; 491 upvotes; 492 viewer_upvoted = List.mem (trainee, seq) voted; 493 viewer_owns = String.equal trainee (Trainee.id_to_string viewer); 494 }) 495 rows 496 497 let split_app_feedback_id id = 498 let raw = Repository.app_feedback_id_to_string id in 499 match String.rindex_opt raw ':' with 500 | None -> None 501 | Some separator -> 502 let trainee = String.sub raw 0 separator in 503 let seq_start = separator + 1 in 504 let seq_length = String.length raw - seq_start in 505 Option.map 506 (fun seq -> (trainee, seq)) 507 (int_of_string_opt (String.sub raw seq_start seq_length)) 508 509 let upvote_app_feedback t ~voter id = 510 match split_app_feedback_id id with 511 | None -> Lwt.return false 512 | Some (trainee, seq) -> ( 513 let voter = Trainee.id_to_string voter in 514 q_find_opt t Q.feedback_owner (trainee, seq) >>= function 515 | None -> Lwt.return false 516 | Some owner when String.equal owner voter -> Lwt.return false 517 | Some _ -> ( 518 q_find_opt t Q.vote_exists (trainee, seq, voter) >>= function 519 | Some _ -> Lwt.return false 520 | None -> 521 q_exec t Q.insert_vote (trainee, seq, voter) >|= fun () -> true)) 522 523 let update_app_feedback t ~author id ~message = 524 match split_app_feedback_id id with 525 | None -> Lwt.return false 526 | Some (trainee, seq) -> ( 527 q_find_opt t Q.feedback_owner (trainee, seq) >>= function 528 | Some owner when String.equal owner (Trainee.id_to_string author) -> 529 q_exec t Q.update_app_feedback (message, trainee, seq) >|= fun () -> 530 true 531 | _ -> Lwt.return false) 532 533 let delete_app_feedback t ~author id = 534 match split_app_feedback_id id with 535 | None -> Lwt.return false 536 | Some (trainee, seq) -> ( 537 q_find_opt t Q.feedback_owner (trainee, seq) >>= function 538 | Some owner when String.equal owner (Trainee.id_to_string author) -> 539 q_exec t Q.delete_feedback_votes (trainee, seq) >>= fun () -> 540 q_exec t Q.delete_app_feedback (trainee, seq) >|= fun () -> true 541 | _ -> Lwt.return false) 542 543 (* --- workout import --- *) 544 545 (* Snapshots resolve their exercise ids through the catalog. The id type is 546 private, so the lookup goes through the raw string. *) 547 let find_exercise (id : Exercise.id) = Exercise.find_id (id :> string) 548 549 let decode_batch encoded = 550 match Import_codec.decode_snapshot ~find_exercise encoded with 551 | Ok batch -> batch 552 | Error e -> raise (Import_corrupt e) 553 554 let save_import_batch t id batch = 555 let trainee = Trainee.id_to_string id in 556 let batch_id = 557 Workout_import.batch_id_to_string (Workout_import.batch_identity batch) 558 in 559 let imported_at = Timestamp.encode (Workout_import.batch_imported_at batch) in 560 let source = Workout_import.batch_source batch in 561 let fingerprint = Workout_import.batch_fingerprint batch in 562 let snapshot = Import_codec.encode_snapshot (Workout_import.snapshot batch) in 563 q_exec t Q.upsert_import_batch 564 (trainee, batch_id, imported_at, source, fingerprint, snapshot) 565 566 let find_import_batch t id batch_id = 567 q_find_opt t Q.import_batch_by_id 568 (Trainee.id_to_string id, Workout_import.batch_id_to_string batch_id) 569 >|= function 570 | None -> None 571 | Some encoded -> Some (decode_batch encoded) 572 573 let import_batches t id = 574 q_collect_list t Q.import_batches (Trainee.id_to_string id) 575 >|= quarantine ~what:"import batch" ~pp_error:Import_codec.pp_error 576 (Import_codec.decode_snapshot ~find_exercise) 577 578 (* Deleting a provisional batch leaves its promoted records: there is no foreign 579 key, so no cascade can reach them. *) 580 let delete_import_batch t id batch_id = 581 let trainee = Trainee.id_to_string id in 582 let batch_id = Workout_import.batch_id_to_string batch_id in 583 q_find_opt t Q.import_batch_exists (trainee, batch_id) >>= function 584 | None -> Lwt.return false 585 | Some _ -> 586 q_exec t Q.delete_import_batch (trainee, batch_id) >|= fun () -> true 587 588 let replace_imported_record t id (record : Repository.imported_record) = 589 let trainee = Trainee.id_to_string id in 590 let workout_id = Workout_import.workout_id_to_string record.workout_id in 591 let batch_id = Workout_import.batch_id_to_string record.batch_id in 592 let title = record.title in 593 let started_at = Timestamp.encode record.started_at in 594 let ended_at = Timestamp.encode record.ended_at in 595 let snapshot = Import_codec.encode_record record in 596 q_exec t Q.upsert_imported_record 597 ( (trainee, workout_id, batch_id, record.revision), 598 (title, started_at, ended_at, snapshot) ) 599 600 let imported_records t id = 601 q_collect_list t Q.imported_records (Trainee.id_to_string id) 602 >|= quarantine ~what:"imported record" ~pp_error:Import_codec.pp_error 603 Import_codec.decode_record 604