1 open Lwt.Infix 2 3 exception Corrupt of Codec.error 4 5 type t = { 6 pool : (Caqti_lwt.connection, Caqti_error.t) Caqti_lwt_unix.Pool.t; 7 mutable next_trainee : int; 8 } 9 10 (* --- request definitions --- *) 11 12 module Q = struct 13 open Caqti_request.Infix 14 open Caqti_type.Std 15 16 let insert_trainee = 17 (t3 string string string ->. unit) 18 "INSERT INTO trainee (id, username, credential) VALUES (?, ?, ?)" 19 20 let trainee_by_username = 21 (string ->? t3 string string string) 22 "SELECT id, username, credential FROM trainee WHERE username = ?" 23 24 let trainee_by_id = 25 (string ->? t3 string string string) 26 "SELECT id, username, credential FROM trainee WHERE id = ?" 27 28 let next_trainee = 29 (unit ->! int) 30 "SELECT COALESCE(MAX(CAST(SUBSTR(id, 2) AS INTEGER)), 0) + 1 FROM \ 31 trainee WHERE id GLOB 't[0-9]*'" 32 33 let update_username = 34 (t2 string string ->. unit) "UPDATE trainee SET username = ? WHERE id = ?" 35 36 let update_credential = 37 (t2 string string ->. unit) "UPDATE trainee SET credential = ? WHERE id = ?" 38 39 let get_active = 40 (string ->? string) 41 "SELECT routine_id FROM active_routine WHERE trainee_id = ?" 42 43 let set_active = 44 (t2 string string ->. unit) 45 "INSERT INTO active_routine (trainee_id, routine_id) VALUES (?, ?) ON \ 46 CONFLICT (trainee_id) DO UPDATE SET routine_id = excluded.routine_id" 47 48 let get_in_progress = 49 (string ->? string) "SELECT encoded FROM in_progress WHERE trainee_id = ?" 50 51 let set_in_progress = 52 (t2 string string ->. unit) 53 "INSERT INTO in_progress (trainee_id, encoded) VALUES (?, ?) ON CONFLICT \ 54 (trainee_id) DO UPDATE SET encoded = excluded.encoded" 55 56 let clear_in_progress = 57 (string ->. unit) "DELETE FROM in_progress WHERE trainee_id = ?" 58 59 let next_seq = 60 (string ->! int) 61 "SELECT COALESCE(MAX(seq), 0) + 1 FROM workout WHERE trainee_id = ?" 62 63 let insert_workout = 64 (t4 string string int string ->. unit) 65 "INSERT INTO workout (id, trainee_id, seq, encoded) VALUES (?, ?, ?, ?)" 66 67 let workout_by_id = 68 (t2 string string ->? string) 69 "SELECT encoded FROM workout WHERE trainee_id = ? AND id = ?" 70 71 let update_workout = 72 (t3 string string string ->. unit) 73 "UPDATE workout SET encoded = ? WHERE trainee_id = ? AND id = ?" 74 75 let history = 76 (string ->* t2 string string) 77 "SELECT id, encoded FROM workout WHERE trainee_id = ? ORDER BY seq DESC" 78 79 let next_feedback_seq = 80 (string ->! int) 81 "SELECT COALESCE(MAX(seq), 0) + 1 FROM feedback WHERE trainee_id = ?" 82 83 let insert_feedback = 84 (t3 string int string ->. unit) 85 "INSERT INTO feedback (trainee_id, seq, encoded) VALUES (?, ?, ?)" 86 87 let feedback = 88 (string ->* string) 89 "SELECT encoded FROM feedback WHERE trainee_id = ? ORDER BY seq DESC" 90 91 let next_app_feedback_seq = 92 (string ->! int) 93 "SELECT COALESCE(MAX(seq), 0) + 1 FROM app_feedback WHERE trainee_id = ?" 94 95 let insert_app_feedback = 96 (t4 string int string string ->. unit) 97 "INSERT INTO app_feedback (trainee_id, seq, submitted_at, message) \ 98 VALUES (?, ?, ?, ?)" 99 100 let app_feedback = 101 (unit ->* t7 string int string string string int int) 102 "SELECT f.trainee_id, f.seq, t.username, f.submitted_at, f.message, \ 103 (SELECT COUNT(*) FROM app_feedback c WHERE c.trainee_id = \ 104 f.trainee_id), (SELECT COUNT(*) FROM app_feedback_vote v WHERE \ 105 v.feedback_trainee_id = f.trainee_id AND v.feedback_seq = f.seq) FROM \ 106 app_feedback f JOIN trainee t ON t.id = f.trainee_id ORDER BY 7 DESC, \ 107 f.submitted_at DESC, f.trainee_id, f.seq DESC" 108 109 let viewer_votes = 110 (string ->* t2 string int) 111 "SELECT feedback_trainee_id, feedback_seq FROM app_feedback_vote WHERE \ 112 voter_id = ?" 113 114 let feedback_owner = 115 (t2 string int ->? string) 116 "SELECT trainee_id FROM app_feedback WHERE trainee_id = ? AND seq = ?" 117 118 let vote_exists = 119 (t3 string int string ->? int) 120 "SELECT 1 FROM app_feedback_vote WHERE feedback_trainee_id = ? AND \ 121 feedback_seq = ? AND voter_id = ?" 122 123 let insert_vote = 124 (t3 string int string ->. unit) 125 "INSERT INTO app_feedback_vote (feedback_trainee_id, feedback_seq, \ 126 voter_id) VALUES (?, ?, ?)" 127 128 let update_app_feedback = 129 (t3 string string int ->. unit) 130 "UPDATE app_feedback SET message = ? WHERE trainee_id = ? AND seq = ?" 131 132 let delete_feedback_votes = 133 (t2 string int ->. unit) 134 "DELETE FROM app_feedback_vote WHERE feedback_trainee_id = ? AND \ 135 feedback_seq = ?" 136 137 let delete_app_feedback = 138 (t2 string int ->. unit) 139 "DELETE FROM app_feedback WHERE trainee_id = ? AND seq = ?" 140 end 141 142 (* --- pool helper --- *) 143 144 let run t f = Caqti_lwt_unix.Pool.use f t.pool >>= Caqti_lwt.or_fail 145 146 let connect uri = 147 match Caqti_lwt_unix.connect_pool (Uri.of_string uri) with 148 | Error e -> Lwt.return (Error (e :> Caqti_error.t)) 149 | Ok pool -> 150 let open Lwt_result.Syntax in 151 let* () = Caqti_lwt_unix.Pool.use Migrations.apply pool in 152 let* next_trainee = 153 Caqti_lwt_unix.Pool.use 154 (fun (module Db : Caqti_lwt.CONNECTION) -> Db.find Q.next_trainee ()) 155 pool 156 in 157 Lwt_result.return { pool; next_trainee } 158 159 (* --- decoding stored workouts --- *) 160 161 let find_routine_by_name = Catalog.find_by_name 162 163 let decode encoded = 164 match Codec.decode_workout ~find_routine:find_routine_by_name encoded with 165 | Ok workout -> workout 166 | Error e -> raise (Corrupt e) 167 168 (* --- accounts --- *) 169 170 let create_trainee t ~username ~credential = 171 let username_s = Trainee.username_to_string username in 172 let credential_s = Trainee.credential_to_hash credential in 173 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 174 Db.find_opt Q.trainee_by_username username_s) 175 >>= function 176 | Some _ -> Lwt.return (Error `Username_taken) 177 | None -> 178 let id = Printf.sprintf "t%d" t.next_trainee in 179 t.next_trainee <- t.next_trainee + 1; 180 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 181 Db.exec Q.insert_trainee (id, username_s, credential_s)) 182 >|= fun () -> Ok { Trainee.id = Trainee.id id; username; credential } 183 184 let trainee_of_row (id, username, credential) = 185 match Trainee.username username with 186 | Ok username -> 187 Some 188 { 189 Trainee.id = Trainee.id id; 190 username; 191 credential = Trainee.credential_of_hash credential; 192 } 193 | Error _ -> None 194 195 let find_trainee_by_username t username = 196 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 197 Db.find_opt Q.trainee_by_username (Trainee.username_to_string username)) 198 >|= function 199 | Some row -> trainee_of_row row 200 | None -> None 201 202 let find_trainee t id = 203 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 204 Db.find_opt Q.trainee_by_id (Trainee.id_to_string id)) 205 >|= function 206 | Some row -> trainee_of_row row 207 | None -> None 208 209 (* Rename in one transaction: check the name is free for anyone else, then 210 update. Running both on the same connection keeps the check and the write 211 from racing another rename. The trainee's own current name is a no-op. *) 212 let update_username t id (username : Trainee.username) = 213 let trainee = Trainee.id_to_string id in 214 let username_s = Trainee.username_to_string username in 215 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 216 let open Lwt_result.Syntax in 217 Db.with_transaction (fun () -> 218 let* holder = Db.find_opt Q.trainee_by_username username_s in 219 match holder with 220 | Some (holder_id, _, _) when not (String.equal holder_id trainee) -> 221 Lwt_result.return (Error `Username_taken) 222 | _ -> 223 let* () = Db.exec Q.update_username (username_s, trainee) in 224 let* row = Db.find_opt Q.trainee_by_id trainee in 225 Lwt_result.return 226 (match Option.bind row trainee_of_row with 227 | Some updated -> Ok updated 228 | None -> Error `Username_taken))) 229 230 let update_credential t id credential = 231 let trainee = Trainee.id_to_string id in 232 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 233 Db.exec Q.update_credential 234 (Trainee.credential_to_hash credential, trainee)) 235 >>= fun () -> find_trainee t id 236 237 (* --- catalog --- *) 238 239 let list_routines _ = Catalog.routines 240 let find_routine _ id = Catalog.find id 241 242 (* The routine name a workout's prescription belongs to, for encoding. Only the 243 ideal routine exists, but resolve it honestly rather than hard-code. *) 244 let routine_name_of workout = 245 let workout_name = 246 Prescription.Workout.name (Evidence.Workout.prescription workout) 247 in 248 List.find_map 249 (fun (_, routine) -> 250 if 251 List.exists 252 (fun w -> String.equal (Prescription.Workout.name w) workout_name) 253 (Prescription.Routine.workouts routine) 254 then Some (Prescription.Routine.name routine) 255 else None) 256 Catalog.routines 257 |> Option.value ~default:"" 258 259 let encode workout = 260 Codec.encode_workout ~routine_name:(routine_name_of workout) workout 261 262 (* --- per-trainee selection and workout in progress --- *) 263 264 let active_routine t id = 265 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 266 Db.find_opt Q.get_active (Trainee.id_to_string id)) 267 >|= Option.map Repository.routine_id 268 269 let set_active_routine t id (routine : Repository.routine_id) = 270 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 271 Db.exec Q.set_active (Trainee.id_to_string id, (routine :> string))) 272 273 let in_progress t id = 274 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 275 Db.find_opt Q.get_in_progress (Trainee.id_to_string id)) 276 >|= function 277 | None -> None 278 | Some encoded -> Some (decode encoded) 279 280 let set_in_progress t id workout = 281 let trainee = Trainee.id_to_string id in 282 match workout with 283 | None -> 284 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 285 Db.exec Q.clear_in_progress trainee) 286 | Some workout -> 287 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 288 Db.exec Q.set_in_progress (trainee, encode workout)) 289 290 (* --- history --- *) 291 292 (* Save a finished workout and clear the in-progress slot in one transaction, 293 so the two rows never disagree after a crash. Both statements run on the same 294 connection, checked out once, inside [with_transaction]. *) 295 let finish_workout t id workout = 296 let trainee = Trainee.id_to_string id in 297 let encoded = encode workout in 298 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 299 let open Lwt_result.Syntax in 300 Db.with_transaction (fun () -> 301 let* seq = Db.find Q.next_seq trainee in 302 let wid = Printf.sprintf "%s:w%d" trainee seq in 303 let* () = Db.exec Q.insert_workout (wid, trainee, seq, encoded) in 304 let* () = Db.exec Q.clear_in_progress trainee in 305 Lwt_result.return 306 { Repository.id = Repository.workout_id wid; workout })) 307 308 let find t id (wid : Repository.workout_id) = 309 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 310 Db.find_opt Q.workout_by_id (Trainee.id_to_string id, (wid :> string))) 311 >|= function 312 | None -> None 313 | Some encoded -> Some { Repository.id = wid; workout = decode encoded } 314 315 let replace t id record = 316 let trainee = Trainee.id_to_string id in 317 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 318 Db.find_opt Q.workout_by_id (trainee, (record.Repository.id :> string))) 319 >>= function 320 | None -> Lwt.return false 321 | Some _ -> 322 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 323 Db.exec Q.update_workout 324 ( encode record.Repository.workout, 325 trainee, 326 (record.Repository.id :> string) )) 327 >|= fun () -> true 328 329 let history t id = 330 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 331 Db.collect_list Q.history (Trainee.id_to_string id)) 332 >|= fun rows -> 333 List.map 334 (fun (wid, encoded) -> 335 { Repository.id = Repository.workout_id wid; workout = decode encoded }) 336 rows 337 338 let log t id = 339 history t id >|= fun records -> 340 List.fold_left 341 (fun log record -> Evidence.Log.add log record.Repository.workout) 342 Evidence.Log.empty (List.rev records) 343 344 (* --- subjective feedback --- *) 345 346 let save_feedback t id report = 347 let trainee = Trainee.id_to_string id in 348 let encoded = Codec.encode_feedback report in 349 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 350 Db.find Q.next_feedback_seq trainee) 351 >>= fun seq -> 352 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 353 Db.exec Q.insert_feedback (trainee, seq, encoded)) 354 355 let decode_feedback encoded = 356 match Codec.decode_feedback encoded with 357 | Ok report -> report 358 | Error e -> raise (Corrupt e) 359 360 let feedback t id = 361 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 362 Db.collect_list Q.feedback (Trainee.id_to_string id)) 363 >|= List.map decode_feedback 364 365 let save_app_feedback t id ~submitted_at ~message = 366 let trainee = Trainee.id_to_string id in 367 find_trainee t id >>= function 368 | None -> 369 Lwt.fail_with "cannot save application feedback for an unknown trainee" 370 | Some author -> 371 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 372 Db.find Q.next_app_feedback_seq trainee) 373 >>= fun seq -> 374 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 375 Db.exec Q.insert_app_feedback 376 (trainee, seq, Timestamp.encode submitted_at, message)) 377 >|= fun () -> 378 Repository. 379 { 380 feedback_id = app_feedback_id (Printf.sprintf "%s:%d" trainee seq); 381 author = Trainee.username_to_string author.Trainee.username; 382 contributions = seq; 383 submitted_at; 384 message; 385 upvotes = 0; 386 viewer_upvoted = false; 387 viewer_owns = true; 388 } 389 390 let app_feedback t ~viewer = 391 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 392 Db.collect_list Q.app_feedback ()) 393 >>= fun rows -> 394 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 395 Db.collect_list Q.viewer_votes (Trainee.id_to_string viewer)) 396 >|= fun voted -> 397 List.map 398 (fun (trainee, seq, author, submitted_at, message, contributions, upvotes) 399 -> 400 let submitted_at = 401 match Timestamp.decode submitted_at with 402 | Ok timestamp -> timestamp 403 | Error _ -> 404 raise (Corrupt (Codec.Malformed "application feedback timestamp")) 405 in 406 Repository. 407 { 408 feedback_id = app_feedback_id (Printf.sprintf "%s:%d" trainee seq); 409 author; 410 contributions; 411 submitted_at; 412 message; 413 upvotes; 414 viewer_upvoted = List.mem (trainee, seq) voted; 415 viewer_owns = String.equal trainee (Trainee.id_to_string viewer); 416 }) 417 rows 418 419 let split_app_feedback_id id = 420 let raw = Repository.app_feedback_id_to_string id in 421 match String.rindex_opt raw ':' with 422 | None -> None 423 | Some separator -> 424 let trainee = String.sub raw 0 separator in 425 let seq_start = separator + 1 in 426 let seq_length = String.length raw - seq_start in 427 Option.map 428 (fun seq -> (trainee, seq)) 429 (int_of_string_opt (String.sub raw seq_start seq_length)) 430 431 let upvote_app_feedback t ~voter id = 432 match split_app_feedback_id id with 433 | None -> Lwt.return false 434 | Some (trainee, seq) -> ( 435 let voter = Trainee.id_to_string voter in 436 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 437 Db.find_opt Q.feedback_owner (trainee, seq)) 438 >>= function 439 | None -> Lwt.return false 440 | Some owner when String.equal owner voter -> Lwt.return false 441 | Some _ -> ( 442 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 443 Db.find_opt Q.vote_exists (trainee, seq, voter)) 444 >>= function 445 | Some _ -> Lwt.return false 446 | None -> 447 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 448 Db.exec Q.insert_vote (trainee, seq, voter)) 449 >|= fun () -> true)) 450 451 let update_app_feedback t ~author id ~message = 452 match split_app_feedback_id id with 453 | None -> Lwt.return false 454 | Some (trainee, seq) -> ( 455 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 456 Db.find_opt Q.feedback_owner (trainee, seq)) 457 >>= function 458 | Some owner when String.equal owner (Trainee.id_to_string author) -> 459 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 460 Db.exec Q.update_app_feedback (message, trainee, seq)) 461 >|= fun () -> true 462 | _ -> Lwt.return false) 463 464 let delete_app_feedback t ~author id = 465 match split_app_feedback_id id with 466 | None -> Lwt.return false 467 | Some (trainee, seq) -> ( 468 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 469 Db.find_opt Q.feedback_owner (trainee, seq)) 470 >>= function 471 | Some owner when String.equal owner (Trainee.id_to_string author) -> 472 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 473 Db.exec Q.delete_feedback_votes (trainee, seq)) 474 >>= fun () -> 475 run t (fun (module Db : Caqti_lwt.CONNECTION) -> 476 Db.exec Q.delete_app_feedback (trainee, seq)) 477 >|= fun () -> true 478 | _ -> Lwt.return false) 479