1 (** Tests for {!Hito_app.Service} — the whole HD flow with no web tier, now 2 scoped to a trainee and driven over Lwt against the in-memory repository. *) 3 4 open Hito_app 5 module S = Service.Make (Memory_repo) 6 module Stimulus = Evidence.Stimulus 7 module Workout = Evidence.Workout 8 9 let run = Lwt_main.run 10 let ok = function Ok v -> v | Error _ -> Alcotest.fail "expected Ok" 11 12 let get id = 13 match Exercise.find_id id with 14 | Some e -> e 15 | None -> Alcotest.failf "catalog is missing %S" id 16 17 let load n = n 18 let reps n = n 19 let at s = Recovery.timestamp_of_unix_seconds s 20 let day n = at (n * 86_400) 21 let ideal = Repository.routine_id "ideal" 22 23 (* A fresh service and a registered trainee to own everything. *) 24 let fixture () = 25 let s = S.make ~repo:(Memory_repo.create ()) in 26 let trainee = 27 ok (run (S.register s ~username:"lifter" ~password:"heavyduty1")) 28 in 29 (s, trainee.Trainee.id) 30 31 let move id load_kg rep_count = 32 Stimulus.Effort.make ~exercise:(get id) ~load:(load load_kg) 33 ~reps:(reps rep_count) ~outcome:Stimulus.Positive_failure 34 35 let single id load r = Stimulus.make (Stimulus.Single (move id load r)) 36 let pair ~first ~second = Stimulus.make (Stimulus.Pair { first; second }) 37 38 (* HD1's Day 1 as performed. *) 39 let day_one_stimuli = 40 [ 41 pair 42 ~first:(move "dumbbell-flyes" 20. 9) 43 ~second:(move "incline-press" 60. 7); 44 single "laterals" 12. 8; 45 single "bent-over-laterals" 10. 9; 46 pair ~first:(move "lying-french-press" 30. 8) ~second:(move "dips" 0. 6); 47 ] 48 49 let account_tests = 50 [ 51 ( "registration then authentication with the same password", 52 `Quick, 53 fun () -> 54 let s = S.make ~repo:(Memory_repo.create ()) in 55 let trainee = 56 ok (run (S.register s ~username:"alice" ~password:"heavyduty1")) 57 in 58 match 59 run (S.authenticate s ~username:"alice" ~password:"heavyduty1") 60 with 61 | Some found -> 62 Alcotest.(check string) 63 "same id" 64 (Trainee.id_to_string trainee.Trainee.id) 65 (Trainee.id_to_string found.Trainee.id) 66 | None -> Alcotest.fail "expected authentication to succeed" ); 67 ( "the wrong password does not authenticate", 68 `Quick, 69 fun () -> 70 let s = S.make ~repo:(Memory_repo.create ()) in 71 let _ = 72 ok (run (S.register s ~username:"alice" ~password:"heavyduty1")) 73 in 74 Alcotest.(check bool) 75 "rejected" true 76 (Option.is_none 77 (run (S.authenticate s ~username:"alice" ~password:"wrong"))) ); 78 ( "a duplicate username is refused after normalization", 79 `Quick, 80 fun () -> 81 let s = S.make ~repo:(Memory_repo.create ()) in 82 let _ = 83 ok (run (S.register s ~username:"alice" ~password:"heavyduty1")) 84 in 85 (* Trimming and lowercasing make " ALICE " the same username. *) 86 match 87 run (S.register s ~username:" ALICE " ~password:"another11") 88 with 89 | Error `Username_taken -> () 90 | _ -> Alcotest.fail "expected Username_taken" ); 91 ( "a normalized username authenticates regardless of case or spacing", 92 `Quick, 93 fun () -> 94 let s = S.make ~repo:(Memory_repo.create ()) in 95 let _ = 96 ok (run (S.register s ~username:"alice" ~password:"heavyduty1")) 97 in 98 Alcotest.(check bool) 99 "case- and space-insensitive login" true 100 (Option.is_some 101 (run 102 (S.authenticate s ~username:" Alice " ~password:"heavyduty1"))) 103 ); 104 ( "a username under four characters is refused", 105 `Quick, 106 fun () -> 107 let s = S.make ~repo:(Memory_repo.create ()) in 108 match run (S.register s ~username:"abc" ~password:"heavyduty1") with 109 | Error (`Username Trainee.Too_short) -> () 110 | _ -> Alcotest.fail "expected Too_short" ); 111 ( "a four-character username is accepted", 112 `Quick, 113 fun () -> 114 let s = S.make ~repo:(Memory_repo.create ()) in 115 match run (S.register s ~username:"abcd" ~password:"heavyduty1") with 116 | Ok _ -> () 117 | Error _ -> 118 Alcotest.fail "expected the boundary username to be accepted" ); 119 ( "a twenty-character username is accepted", 120 `Quick, 121 fun () -> 122 let s = S.make ~repo:(Memory_repo.create ()) in 123 match 124 run (S.register s ~username:"abcdefghijklmnopqrst" ~password:"pw") 125 with 126 | Ok _ -> () 127 | Error _ -> 128 Alcotest.fail "expected the boundary username to be accepted" ); 129 ( "a username over twenty characters is refused", 130 `Quick, 131 fun () -> 132 let s = S.make ~repo:(Memory_repo.create ()) in 133 match 134 run (S.register s ~username:"abcdefghijklmnopqrstu" ~password:"pw") 135 with 136 | Error (`Username Trainee.Too_long) -> () 137 | _ -> Alcotest.fail "expected Too_long" ); 138 ( "surrounding whitespace does not count toward the length bounds", 139 `Quick, 140 fun () -> 141 let s = S.make ~repo:(Memory_repo.create ()) in 142 (* " abcd " normalizes to the four-character "abcd". *) 143 match run (S.register s ~username:" abcd " ~password:"pw") with 144 | Ok trainee -> 145 Alcotest.(check string) 146 "trimmed and lowercased" "abcd" 147 (Trainee.username_to_string trainee.Trainee.username) 148 | Error _ -> 149 Alcotest.fail "expected the trimmed username to be accepted" ); 150 ( "a short password is accepted", 151 `Quick, 152 fun () -> 153 let s = S.make ~repo:(Memory_repo.create ()) in 154 match run (S.register s ~username:"alice" ~password:"x") with 155 | Ok _ -> () 156 | Error _ -> Alcotest.fail "expected a short password to be accepted" ); 157 ( "an empty password is accepted", 158 `Quick, 159 fun () -> 160 let s = S.make ~repo:(Memory_repo.create ()) in 161 match run (S.register s ~username:"bobby" ~password:"") with 162 | Ok _ -> () 163 | Error _ -> Alcotest.fail "expected an empty password to be accepted" 164 ); 165 ( "a short password still authenticates", 166 `Quick, 167 fun () -> 168 let s = S.make ~repo:(Memory_repo.create ()) in 169 let _ = ok (run (S.register s ~username:"carol" ~password:"x")) in 170 Alcotest.(check bool) 171 "signs in" true 172 (Option.is_some 173 (run (S.authenticate s ~username:"carol" ~password:"x"))) ); 174 ( "two trainees keep separate logs", 175 `Quick, 176 fun () -> 177 let s = S.make ~repo:(Memory_repo.create ()) in 178 let a = 179 (ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 180 .Trainee.id 181 in 182 let b = 183 (ok (run (S.register s ~username:"bobby" ~password:"heavyduty1"))) 184 .Trainee.id 185 in 186 let _ = ok (run (S.begin_workout s a ~routine:ideal ~now:(day 1) ())) in 187 let _ = run (S.finish s a ~ended_at:(day 1)) in 188 Alcotest.(check int) "a has one" 1 (List.length (run (S.history s a))); 189 Alcotest.(check int) "b has none" 0 (List.length (run (S.history s b))) 190 ); 191 ( "changing the username renames the account", 192 `Quick, 193 fun () -> 194 let s = S.make ~repo:(Memory_repo.create ()) in 195 let id = 196 (ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 197 .Trainee.id 198 in 199 (match run (S.change_username s id ~username:"alicia") with 200 | Ok updated -> 201 Alcotest.(check string) 202 "renamed" "alicia" 203 (Trainee.username_to_string updated.Trainee.username) 204 | Error _ -> Alcotest.fail "expected the rename to succeed"); 205 (* The old name is free; the new name resolves the same account. *) 206 match run (S.find_trainee s id) with 207 | Some found -> 208 Alcotest.(check string) 209 "persisted new name" "alicia" 210 (Trainee.username_to_string found.Trainee.username) 211 | None -> Alcotest.fail "account vanished" ); 212 ( "renaming to the account's own name is a no-op success", 213 `Quick, 214 fun () -> 215 let s = S.make ~repo:(Memory_repo.create ()) in 216 let id = 217 (ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 218 .Trainee.id 219 in 220 match run (S.change_username s id ~username:" ALICE ") with 221 | Ok updated -> 222 Alcotest.(check string) 223 "kept the normalized name" "alice" 224 (Trainee.username_to_string updated.Trainee.username) 225 | Error _ -> Alcotest.fail "expected a no-op rename to succeed" ); 226 ( "renaming to another trainee's name is refused", 227 `Quick, 228 fun () -> 229 let s = S.make ~repo:(Memory_repo.create ()) in 230 let a = 231 (ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 232 .Trainee.id 233 in 234 let _ = 235 ok (run (S.register s ~username:"bobby" ~password:"heavyduty1")) 236 in 237 match run (S.change_username s a ~username:"bobby") with 238 | Error `Username_taken -> () 239 | _ -> Alcotest.fail "expected Username_taken" ); 240 ( "an invalid new username is refused", 241 `Quick, 242 fun () -> 243 let s = S.make ~repo:(Memory_repo.create ()) in 244 let id = 245 (ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 246 .Trainee.id 247 in 248 match run (S.change_username s id ~username:"ab") with 249 | Error (`Username Trainee.Too_short) -> () 250 | _ -> Alcotest.fail "expected Too_short" ); 251 ( "changing the password requires the current one", 252 `Quick, 253 fun () -> 254 let s = S.make ~repo:(Memory_repo.create ()) in 255 let id = 256 (ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 257 .Trainee.id 258 in 259 (match 260 run (S.change_password s id ~current:"wrong" ~next:"newsecret1") 261 with 262 | Error `Incorrect_password -> () 263 | _ -> Alcotest.fail "expected Incorrect_password"); 264 (* The old password still works after a refused change. *) 265 Alcotest.(check bool) 266 "old password still valid" true 267 (Option.is_some 268 (run (S.authenticate s ~username:"alice" ~password:"heavyduty1"))) 269 ); 270 ( "a correct current password changes the password", 271 `Quick, 272 fun () -> 273 let s = S.make ~repo:(Memory_repo.create ()) in 274 let id = 275 (ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 276 .Trainee.id 277 in 278 (match 279 run (S.change_password s id ~current:"heavyduty1" ~next:"newsecret1") 280 with 281 | Ok _ -> () 282 | Error _ -> Alcotest.fail "expected the change to succeed"); 283 Alcotest.(check bool) 284 "the old password no longer works" true 285 (Option.is_none 286 (run (S.authenticate s ~username:"alice" ~password:"heavyduty1"))); 287 Alcotest.(check bool) 288 "the new password works" true 289 (Option.is_some 290 (run (S.authenticate s ~username:"alice" ~password:"newsecret1"))) 291 ); 292 ] 293 294 let routine_tests = 295 [ 296 ( "the seeded repository offers HD1's Ideal Routine", 297 `Quick, 298 fun () -> 299 let s, _ = fixture () in 300 match S.list_routines s with 301 | [ (_, r) ] -> 302 Alcotest.(check string) 303 "name" "Ideal Routine" 304 (Prescription.Routine.name r) 305 | rs -> Alcotest.failf "expected one routine, got %d" (List.length rs) 306 ); 307 ( "an unknown routine is refused", 308 `Quick, 309 fun () -> 310 let s, t = fixture () in 311 match 312 run (S.next_workout s t ~routine:(Repository.routine_id "nope")) 313 with 314 | Error S.Unknown_routine -> () 315 | _ -> Alcotest.fail "expected Unknown_routine" ); 316 ( "with nothing logged the cycle starts at Day 1", 317 `Quick, 318 fun () -> 319 let s, t = fixture () in 320 let w = ok (run (S.next_workout s t ~routine:ideal)) in 321 Alcotest.(check string) "Day 1" "Day 1" (Prescription.Workout.name w) ); 322 ] 323 324 let clearance_tests = 325 [ 326 ( "a first workout needs no recovery: nothing has been done yet", 327 `Quick, 328 fun () -> 329 let s, t = fixture () in 330 Alcotest.(check bool) 331 "ready" true 332 (Recovery.is_ready 333 (ok (run (S.readiness s t ~routine:ideal ~now:(day 1))))); 334 Alcotest.(check bool) 335 "starts" true 336 (Result.is_ok 337 (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ()))) ); 338 ( "training too soon after a workout is refused", 339 `Quick, 340 fun () -> 341 let s, t = fixture () in 342 let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in 343 let _ = run (S.finish s t ~ended_at:(day 1)) in 344 match run (S.begin_workout s t ~routine:ideal ~now:(day 2) ()) with 345 | Error (S.Not_recovered readiness) -> 346 Alcotest.(check bool) 347 "and says so" false 348 (Recovery.is_ready readiness) 349 | _ -> Alcotest.fail "expected Not_recovered" ); 350 ( "once rested, the next workout starts and the cycle has advanced", 351 `Quick, 352 fun () -> 353 let s, t = fixture () in 354 let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in 355 let _ = run (S.finish s t ~ended_at:(day 1)) in 356 let w = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 3) ())) in 357 Alcotest.(check string) 358 "Day 2" "Day 2" 359 (Prescription.Workout.name (Workout.prescription w)) ); 360 ( "an override is accepted and recorded", 361 `Quick, 362 fun () -> 363 let s, t = fixture () in 364 let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in 365 let _ = run (S.finish s t ~ended_at:(day 1)) in 366 let w = 367 ok 368 (run 369 (S.begin_workout s t ~routine:ideal ~now:(day 2) ~override:() ())) 370 in 371 match Recovery.basis (Workout.clearance w) with 372 | Recovery.Overridden _ -> () 373 | Recovery.Recovered -> Alcotest.fail "expected Overridden" ); 374 ( "an override while genuinely rested is not recorded as one", 375 `Quick, 376 fun () -> 377 let s, t = fixture () in 378 let w = 379 ok 380 (run 381 (S.begin_workout s t ~routine:ideal ~now:(day 1) ~override:() ())) 382 in 383 match Recovery.basis (Workout.clearance w) with 384 | Recovery.Recovered -> () 385 | Recovery.Overridden _ -> 386 Alcotest.fail "nothing was outstanding to override" ); 387 ] 388 389 let logging_tests = 390 [ 391 ( "logging without a workout in progress is refused", 392 `Quick, 393 fun () -> 394 let s, t = fixture () in 395 match run (S.log s t (single "laterals" 12. 8)) with 396 | Error S.No_workout_in_progress -> () 397 | _ -> Alcotest.fail "expected No_workout_in_progress" ); 398 ( "a stimulus the prescription does not call for is refused", 399 `Quick, 400 fun () -> 401 let s, t = fixture () in 402 let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in 403 match run (S.log s t (single "shrugs" 80. 10)) with 404 | Error (S.Rejected (Workout.Not_prescribed _)) -> () 405 | _ -> Alcotest.fail "expected Rejected Not_prescribed" ); 406 ( "Day 1 can be logged in full and finished", 407 `Quick, 408 fun () -> 409 let s, t = fixture () in 410 let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in 411 List.iter (fun st -> ignore (ok (run (S.log s t st)))) day_one_stimuli; 412 let w = Option.get (run (S.in_progress s t)) in 413 Alcotest.(check int) "four stimuli" 4 (List.length (Workout.stimuli w)); 414 Alcotest.(check int) 415 "nothing outstanding" 0 416 (List.length (Workout.unperformed w)); 417 let record = Option.get (run (S.finish s t ~ended_at:(at 3600))) in 418 Alcotest.(check bool) 419 "persisted as finished" true 420 (Workout.is_finished record.Repository.workout); 421 Alcotest.(check bool) 422 "slot cleared" true 423 (Option.is_none (run (S.in_progress s t))) ); 424 ( "history returns the finished workout", 425 `Quick, 426 fun () -> 427 let s, t = fixture () in 428 let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in 429 let _ = ok (run (S.log s t (single "laterals" 12. 8))) in 430 let _ = run (S.finish s t ~ended_at:(at 3600)) in 431 Alcotest.(check int) "one workout" 1 (List.length (run (S.history s t))) 432 ); 433 ( "cancelling after recording a set discards it and saves no history", 434 `Quick, 435 fun () -> 436 let s, t = fixture () in 437 let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in 438 let _ = ok (run (S.log s t (single "laterals" 12. 8))) in 439 Alcotest.(check bool) 440 "a workout was discarded" true 441 (run (S.cancel s t)); 442 Alcotest.(check bool) 443 "no workout in progress" true 444 (Option.is_none (run (S.in_progress s t))); 445 Alcotest.(check int) 446 "no history record" 0 447 (List.length (run (S.history s t))) ); 448 ( "cancelling preserves saved history", 449 `Quick, 450 fun () -> 451 let s, t = fixture () in 452 (* Finish one workout so history is non-empty. *) 453 let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in 454 let _ = run (S.finish s t ~ended_at:(day 1)) in 455 (* Begin and cancel a second. The saved first workout must remain. *) 456 let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 3) ())) in 457 Alcotest.(check bool) "discarded" true (run (S.cancel s t)); 458 Alcotest.(check int) 459 "saved history kept" 1 460 (List.length (run (S.history s t))); 461 Alcotest.(check bool) 462 "no workout in progress" true 463 (Option.is_none (run (S.in_progress s t))) ); 464 ( "cancelling with nothing in progress is a no-op", 465 `Quick, 466 fun () -> 467 let s, t = fixture () in 468 Alcotest.(check bool) "nothing to discard" false (run (S.cancel s t)) ); 469 ] 470 471 let active_and_edit_tests = 472 [ 473 ( "routine selection is explicit and rejects unknown IDs", 474 `Quick, 475 fun () -> 476 let s, t = fixture () in 477 Alcotest.(check bool) 478 "no initial selection" true 479 (Option.is_none (run (S.active_routine s t))); 480 ignore (ok (run (S.select_routine s t ideal))); 481 Alcotest.(check string) 482 "selected ideal" "Ideal Routine" 483 (Prescription.Routine.name 484 (snd (Option.get (run (S.active_routine s t))))); 485 match run (S.select_routine s t (Repository.routine_id "missing")) with 486 | Error S.Unknown_routine -> () 487 | _ -> Alcotest.fail "expected Unknown_routine" ); 488 ( "a finished record can be completed later without changing its end", 489 `Quick, 490 fun () -> 491 let s, t = fixture () in 492 ignore (ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ()))); 493 let record = Option.get (run (S.finish s t ~ended_at:(at 120))) in 494 let record = 495 List.fold_left 496 (fun record stimulus -> 497 ok (run (S.add_to_record s t record.Repository.id stimulus))) 498 record day_one_stimuli 499 in 500 Alcotest.(check bool) 501 "complete" true 502 (match Workout.completeness record.Repository.workout with 503 | Workout.Complete -> true 504 | Incomplete -> false); 505 Alcotest.(check int) 506 "original end" 120 507 (Recovery.timestamp_to_unix_seconds 508 (Option.get (Workout.ended_at record.Repository.workout))) ); 509 ( "replace_current corrects a recorded slot without adding volume", 510 `Quick, 511 fun () -> 512 let s, t = fixture () in 513 ignore (ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ()))); 514 ignore (ok (run (S.log s t (single "laterals" 12. 8)))); 515 let w = 516 ok (run (S.replace_current s t ~slot:1 (single "laterals" 14. 7))) 517 in 518 Alcotest.(check int) 519 "still one stimulus" 1 520 (List.length (Workout.stimuli w)); 521 Alcotest.(check int) "one filled slot" 1 (Workout.filled_slots w); 522 Alcotest.(check (float 0.001)) 523 "corrected load" 14. 524 (Stimulus.Effort.load 525 (List.hd (Stimulus.efforts (List.hd (Workout.stimuli w))))) ); 526 ( "replace_current rejects a stimulus the slot does not call for", 527 `Quick, 528 fun () -> 529 let s, t = fixture () in 530 ignore (ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ()))); 531 match run (S.replace_current s t ~slot:1 (single "shrugs" 80. 10)) with 532 | Error (S.Rejected _) -> () 533 | _ -> Alcotest.fail "expected Rejected" ); 534 ( "replace_in_record corrects a saved slot without adding volume", 535 `Quick, 536 fun () -> 537 let s, t = fixture () in 538 ignore (ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ()))); 539 ignore (ok (run (S.log s t (single "laterals" 12. 8)))); 540 let record = Option.get (run (S.finish s t ~ended_at:(at 120))) in 541 let record = 542 ok 543 (run 544 (S.replace_in_record s t record.Repository.id ~slot:1 545 (single "laterals" 16. 6))) 546 in 547 Alcotest.(check int) 548 "still one stimulus" 1 549 (List.length (Workout.stimuli record.Repository.workout)); 550 Alcotest.(check (float 0.001)) 551 "corrected load" 16. 552 (Stimulus.Effort.load 553 (List.hd 554 (Stimulus.efforts 555 (List.hd (Workout.stimuli record.Repository.workout))))) ); 556 ( "replace_in_record rejects an unknown slot", 557 `Quick, 558 fun () -> 559 let s, t = fixture () in 560 ignore (ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ()))); 561 let record = Option.get (run (S.finish s t ~ended_at:(at 120))) in 562 match 563 run 564 (S.replace_in_record s t record.Repository.id ~slot:99 565 (single "laterals" 12. 8)) 566 with 567 | Error (S.Rejected_edit (Workout.No_such_slot 99)) -> () 568 | _ -> Alcotest.fail "expected Rejected_edit No_such_slot" ); 569 ] 570 571 let assessment_tests = 572 [ 573 ( "evidence accumulates across cycles and feeds progression", 574 `Quick, 575 fun () -> 576 let s, t = fixture () in 577 let run_workout ~on ~load = 578 let w = 579 ok 580 (run (S.begin_workout s t ~routine:ideal ~now:on ~override:() ())) 581 in 582 if 583 String.equal "Day 1" 584 (Prescription.Workout.name (Workout.prescription w)) 585 then ignore (ok (run (S.log s t (single "laterals" load 8)))); 586 ignore (run (S.finish s t ~ended_at:on)) 587 in 588 List.iter 589 (fun on -> run_workout ~on ~load:12.) 590 [ day 1; day 3; day 5; day 8; day 10; day 12; day 16 ]; 591 Alcotest.(check int) 592 "seven workouts logged" 7 593 (List.length (run (S.history s t))); 594 Alcotest.(check bool) 595 "stalled" true 596 (run (S.progress s t (get "laterals")) = Ok Progression.Stalled) ); 597 ( "training on overrides shows up as a diagnostic", 598 `Quick, 599 fun () -> 600 let s, t = fixture () in 601 let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in 602 let _ = run (S.finish s t ~ended_at:(day 1)) in 603 let _ = 604 ok 605 (run 606 (S.begin_workout s t ~routine:ideal ~now:(day 2) ~override:() ())) 607 in 608 let _ = run (S.finish s t ~ended_at:(day 2)) in 609 match 610 List.filter 611 (function 612 | Progression.Trained_under_recovered _ -> true | _ -> false) 613 (run (S.diagnostics s t)) 614 with 615 | [ Progression.Trained_under_recovered n ] -> 616 Alcotest.(check int) "one such workout" 1 n 617 | _ -> Alcotest.fail "expected the under-recovery diagnostic" ); 618 ] 619 620 let app_feedback_tests = 621 [ 622 ( "app feedback rejects a blank message", 623 `Quick, 624 fun () -> 625 let s, t = fixture () in 626 match 627 run 628 (S.record_app_feedback s t ~submitted_at:(day 1) ~message:" \n ") 629 with 630 | Error `Empty_message -> () 631 | Error `Unknown_feedback -> 632 Alcotest.fail "unexpected unknown feedback error" 633 | Ok _ -> Alcotest.fail "expected a blank message to be refused" ); 634 ( "app feedback is stored newest first and visible globally", 635 `Quick, 636 fun () -> 637 let s, alice = fixture () in 638 let bob = 639 (ok (run (S.register s ~username:"bobby" ~password:"heavyduty1"))) 640 .Trainee.id 641 in 642 let _ = 643 ok 644 (run 645 (S.record_app_feedback s alice ~submitted_at:(day 1) 646 ~message:"First")) 647 in 648 let _ = 649 ok 650 (run 651 (S.record_app_feedback s alice ~submitted_at:(day 2) 652 ~message:"Second")) 653 in 654 let alice_reports = run (S.app_feedback s alice) in 655 Alcotest.(check int) "two reports" 2 (List.length alice_reports); 656 Alcotest.(check string) 657 "newest first" "Second" (List.hd alice_reports).Repository.message; 658 Alcotest.(check int) 659 "bob sees the same reports" 2 660 (List.length (run (S.app_feedback s bob))) ); 661 ( "application feedback ownership survives an author rename", 662 `Quick, 663 fun () -> 664 let s, alice = fixture () in 665 let _ = 666 ok 667 (run 668 (S.record_app_feedback s alice ~submitted_at:(day 1) 669 ~message:"Before rename")) 670 in 671 let _ = ok (run (S.change_username s alice ~username:"athlete")) in 672 match run (S.app_feedback s alice) with 673 | [ report ] -> 674 Alcotest.(check string) 675 "current author name" "athlete" report.author; 676 Alcotest.(check bool) 677 "viewer still owns report" true report.viewer_owns 678 | reports -> 679 Alcotest.failf "expected one report, got %d" (List.length reports) 680 ); 681 ( "application feedback is ranked and supports cross-user votes", 682 `Quick, 683 fun () -> 684 let s, alice = fixture () in 685 let bob = 686 (ok (run (S.register s ~username:"bobby" ~password:"heavyduty1"))) 687 .Trainee.id 688 in 689 let _ = 690 ok 691 (run 692 (S.record_app_feedback s alice ~submitted_at:(day 1) 693 ~message:"First")) 694 in 695 let _ = 696 ok 697 (run 698 (S.record_app_feedback s alice ~submitted_at:(day 2) 699 ~message:"Second")) 700 in 701 let _ = 702 ok 703 (run 704 (S.record_app_feedback s bob ~submitted_at:(day 3) 705 ~message:"From Bob")) 706 in 707 let before_vote = run (S.app_feedback s alice) in 708 let alice_report = 709 List.find 710 (fun report -> String.equal report.Repository.author "lifter") 711 before_vote 712 in 713 let bob_report = 714 List.find 715 (fun report -> String.equal report.Repository.author "bobby") 716 before_vote 717 in 718 Alcotest.(check int) 719 "alice contribution count" 2 alice_report.Repository.contributions; 720 Alcotest.(check int) 721 "bob contribution count" 1 bob_report.Repository.contributions; 722 Alcotest.(check bool) 723 "newest report starts first" true 724 (String.equal (List.hd before_vote).Repository.message "From Bob"); 725 Alcotest.(check bool) 726 "cross-user vote is added" true 727 (run 728 (S.upvote_app_feedback s alice bob_report.Repository.feedback_id)); 729 Alcotest.(check bool) 730 "own vote is refused" false 731 (run (S.upvote_app_feedback s bob bob_report.Repository.feedback_id)); 732 let after_vote = run (S.app_feedback s alice) in 733 let voted_bob = 734 List.find 735 (fun report -> String.equal report.Repository.author "bobby") 736 after_vote 737 in 738 Alcotest.(check int) "upvote count" 1 voted_bob.Repository.upvotes; 739 Alcotest.(check bool) 740 "viewer vote state" true voted_bob.Repository.viewer_upvoted ); 741 ( "editing application feedback to a blank message is refused", 742 `Quick, 743 fun () -> 744 let s, alice = fixture () in 745 let report = 746 ok 747 (run 748 (S.record_app_feedback s alice ~submitted_at:(day 1) 749 ~message:"Original")) 750 in 751 match 752 run 753 (S.edit_app_feedback s alice report.Repository.feedback_id 754 ~message:" ") 755 with 756 | Error `Empty_message -> () 757 | Error `Unknown_feedback -> Alcotest.fail "feedback must still exist" 758 | Ok () -> Alcotest.fail "expected a blank edit to be refused" ); 759 ( "removed application feedback identities are not reused", 760 `Quick, 761 fun () -> 762 let s, alice = fixture () in 763 let first = 764 ok 765 (run 766 (S.record_app_feedback s alice ~submitted_at:(day 1) 767 ~message:"First")) 768 in 769 let second = 770 ok 771 (run 772 (S.record_app_feedback s alice ~submitted_at:(day 2) 773 ~message:"Second")) 774 in 775 Alcotest.(check bool) 776 "first removal succeeds" true 777 (run (S.remove_app_feedback s alice first.Repository.feedback_id)); 778 let third = 779 ok 780 (run 781 (S.record_app_feedback s alice ~submitted_at:(day 3) 782 ~message:"Third")) 783 in 784 Alcotest.(check bool) 785 "new identity differs from the surviving identity" false 786 (String.equal 787 (Repository.app_feedback_id_to_string second.feedback_id) 788 (Repository.app_feedback_id_to_string third.feedback_id)); 789 Alcotest.(check string) 790 "sequence does not rewind" "t1:3" 791 (Repository.app_feedback_id_to_string third.feedback_id) ); 792 ( "application feedback CRUD is owner-scoped", 793 `Quick, 794 fun () -> 795 let s, alice = fixture () in 796 let bob = 797 (ok (run (S.register s ~username:"bobby" ~password:"heavyduty1"))) 798 .Trainee.id 799 in 800 let report = 801 ok 802 (run 803 (S.record_app_feedback s alice ~submitted_at:(day 1) 804 ~message:"Original")) 805 in 806 (match 807 run 808 (S.edit_app_feedback s bob report.Repository.feedback_id 809 ~message:"Not yours") 810 with 811 | Error `Unknown_feedback -> () 812 | _ -> Alcotest.fail "another trainee edited the report"); 813 (match 814 run 815 (S.edit_app_feedback s alice report.Repository.feedback_id 816 ~message:"Edited") 817 with 818 | Ok () -> () 819 | _ -> Alcotest.fail "owner edit failed"); 820 let edited = 821 List.find 822 (fun current -> 823 String.equal 824 (Repository.app_feedback_id_to_string 825 current.Repository.feedback_id) 826 (Repository.app_feedback_id_to_string 827 report.Repository.feedback_id)) 828 (run (S.app_feedback s bob)) 829 in 830 Alcotest.(check string) "edited message" "Edited" edited.message; 831 Alcotest.(check bool) 832 "owner remove succeeds" true 833 (run (S.remove_app_feedback s alice report.Repository.feedback_id)); 834 Alcotest.(check int) 835 "removed from the list" 0 836 (List.length (run (S.app_feedback s bob))) ); 837 ] 838 839 let suite = 840 [ 841 ("service.accounts", account_tests); 842 ("service.routines", routine_tests); 843 ("service.clearance", clearance_tests); 844 ("service.logging", logging_tests); 845 ("service.app_feedback", app_feedback_tests); 846 ("service.active_and_edit", active_and_edit_tests); 847 ("service.assessment", assessment_tests); 848 ] 849