1 (** Tests for {!Hito_app.Sqlite_repo} — the durable store. Proves that state 2 survives reconnecting to the same file, and that trainees stay isolated. *) 3 4 open Hito_app 5 module S = Service.Make (Sqlite_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 at s = Recovery.timestamp_of_unix_seconds s 18 let day n = at (n * 86_400) 19 let ideal = Repository.routine_id "ideal" 20 21 let single id load reps = 22 Stimulus.make 23 (Stimulus.Single 24 (Stimulus.Effort.make ~exercise:(get id) ~load ~reps 25 ~outcome:Stimulus.Positive_failure)) 26 27 (* A unique temp database file per test; SQLite is a plain file. *) 28 let temp_uri () = 29 let path = Filename.temp_file "hito-test-" ".sqlite" in 30 Sys.remove path; 31 (path, "sqlite3:" ^ path) 32 33 let connect uri = ok (run (Sqlite_repo.connect uri)) 34 35 let cleanup path = 36 List.iter 37 (fun suffix -> try Sys.remove (path ^ suffix) with Sys_error _ -> ()) 38 [ ""; "-wal"; "-shm" ] 39 40 let durability_tests = 41 [ 42 ( "a finished workout survives a reconnect to the same file", 43 `Quick, 44 fun () -> 45 let path, uri = temp_uri () in 46 Fun.protect 47 ~finally:(fun () -> cleanup path) 48 (fun () -> 49 let trainee_id = 50 let repo = connect uri in 51 let s = S.make ~repo in 52 let trainee = 53 ok (run (S.register s ~username:"alice" ~password:"heavyduty1")) 54 in 55 let id = trainee.Trainee.id in 56 let _ = 57 ok (run (S.begin_workout s id ~routine:ideal ~now:(day 1) ())) 58 in 59 let _ = ok (run (S.log s id (single "laterals" 12. 8))) in 60 let _ = run (S.finish s id ~ended_at:(day 1)) in 61 id 62 in 63 (* Reconnect with a fresh repo value to the same file. *) 64 let repo = connect uri in 65 let s = S.make ~repo in 66 let found = 67 run (S.authenticate s ~username:"alice" ~password:"heavyduty1") 68 in 69 Alcotest.(check bool) 70 "account persisted" true (Option.is_some found); 71 Alcotest.(check string) 72 "same trainee id" 73 (Trainee.id_to_string trainee_id) 74 (Trainee.id_to_string (Option.get found).Trainee.id); 75 Alcotest.(check int) 76 "history persisted" 1 77 (List.length (run (S.history s trainee_id)))) ); 78 ( "a new trainee gets a fresh identity after reconnect", 79 `Quick, 80 fun () -> 81 let path, uri = temp_uri () in 82 Fun.protect 83 ~finally:(fun () -> cleanup path) 84 (fun () -> 85 let first_id = 86 let repo = connect uri in 87 let s = S.make ~repo in 88 let trainee = 89 ok (run (S.register s ~username:"alice" ~password:"first")) 90 in 91 Trainee.id_to_string trainee.Trainee.id 92 in 93 let repo = connect uri in 94 let s = S.make ~repo in 95 let second = 96 ok (run (S.register s ~username:"bobby" ~password:"second")) 97 in 98 let second_id = Trainee.id_to_string second.Trainee.id in 99 Alcotest.(check bool) 100 "identity is not reused" false 101 (String.equal first_id second_id); 102 Alcotest.(check string) "sequence continues" "t2" second_id) ); 103 ( "the workout in progress is durable and per-trainee", 104 `Quick, 105 fun () -> 106 let path, uri = temp_uri () in 107 Fun.protect 108 ~finally:(fun () -> cleanup path) 109 (fun () -> 110 let repo = connect uri in 111 let s = S.make ~repo in 112 let a = 113 (ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 114 .Trainee.id 115 in 116 let b = 117 (ok (run (S.register s ~username:"bobby" ~password:"heavyduty1"))) 118 .Trainee.id 119 in 120 let _ = 121 ok (run (S.begin_workout s a ~routine:ideal ~now:(day 1) ())) 122 in 123 (* Reconnect and confirm a's slot survives while b's stays empty. *) 124 let repo = connect uri in 125 let s = S.make ~repo in 126 Alcotest.(check bool) 127 "a has a workout in progress" true 128 (Option.is_some (run (S.in_progress s a))); 129 Alcotest.(check bool) 130 "b does not" true 131 (Option.is_none (run (S.in_progress s b)))) ); 132 ( "a saved record can be completed later and stays complete", 133 `Quick, 134 fun () -> 135 let path, uri = temp_uri () in 136 Fun.protect 137 ~finally:(fun () -> cleanup path) 138 (fun () -> 139 let repo = connect uri in 140 let s = S.make ~repo in 141 let t = 142 (ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 143 .Trainee.id 144 in 145 let _ = 146 ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) 147 in 148 let record = Option.get (run (S.finish s t ~ended_at:(at 120))) in 149 let record = 150 ok 151 (run 152 (S.add_to_record s t record.Repository.id 153 (single "laterals" 12. 8))) 154 in 155 (* Reconnect and read it back. *) 156 let repo = connect uri in 157 let s = S.make ~repo in 158 let reread = 159 Option.get (run (S.find_record s t record.Repository.id)) 160 in 161 Alcotest.(check int) 162 "one stimulus survived" 1 163 (List.length (Workout.stimuli reread.Repository.workout))) ); 164 ( "a corrected slot survives a reconnect without adding volume", 165 `Quick, 166 fun () -> 167 let path, uri = temp_uri () in 168 Fun.protect 169 ~finally:(fun () -> cleanup path) 170 (fun () -> 171 let repo = connect uri in 172 let s = S.make ~repo in 173 let t = 174 (ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 175 .Trainee.id 176 in 177 let _ = 178 ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) 179 in 180 let _ = ok (run (S.log s t (single "laterals" 12. 8))) in 181 let record = Option.get (run (S.finish s t ~ended_at:(at 120))) in 182 let _ = 183 ok 184 (run 185 (S.replace_in_record s t record.Repository.id ~slot:1 186 (single "laterals" 15. 6))) 187 in 188 let repo = connect uri in 189 let s = S.make ~repo in 190 let reread = 191 Option.get (run (S.find_record s t record.Repository.id)) 192 in 193 Alcotest.(check int) 194 "still one stimulus" 1 195 (List.length (Workout.stimuli reread.Repository.workout)); 196 Alcotest.(check (float 0.001)) 197 "corrected load persisted" 15. 198 (Stimulus.Effort.load 199 (List.hd 200 (Stimulus.efforts 201 (List.hd (Workout.stimuli reread.Repository.workout)))))) 202 ); 203 ( "a short password persists and authenticates after a reconnect", 204 `Quick, 205 fun () -> 206 let path, uri = temp_uri () in 207 Fun.protect 208 ~finally:(fun () -> cleanup path) 209 (fun () -> 210 let repo = connect uri in 211 let s = S.make ~repo in 212 (* No password policy: a one-character password is stored and later 213 verifies against its persisted hash. *) 214 let _ = ok (run (S.register s ~username:"alice" ~password:"x")) in 215 let repo = connect uri in 216 let s = S.make ~repo in 217 Alcotest.(check bool) 218 "short password authenticates after reconnect" true 219 (Option.is_some 220 (run (S.authenticate s ~username:"alice" ~password:"x")))) ); 221 ] 222 223 let migration_tests = 224 [ 225 ( "applying migrations twice to one file is idempotent", 226 `Quick, 227 fun () -> 228 let path, uri = temp_uri () in 229 Fun.protect 230 ~finally:(fun () -> cleanup path) 231 (fun () -> 232 (* First connect creates and records the schema. *) 233 let _ = connect uri in 234 (* A second connect on the same file must not fail re-applying an 235 already-recorded migration. *) 236 let repo = connect uri in 237 let s = S.make ~repo in 238 let trainee = 239 ok (run (S.register s ~username:"alice" ~password:"heavyduty1")) 240 in 241 Alcotest.(check bool) 242 "usable after reconnect" true 243 (Option.is_some 244 (run 245 (S.authenticate s ~username:"alice" ~password:"heavyduty1"))); 246 ignore trainee) ); 247 ( "finishing is atomic: the record is saved and the slot cleared", 248 `Quick, 249 fun () -> 250 let path, uri = temp_uri () in 251 Fun.protect 252 ~finally:(fun () -> cleanup path) 253 (fun () -> 254 let repo = connect uri in 255 let s = S.make ~repo in 256 let t = 257 (ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 258 .Trainee.id 259 in 260 let _ = 261 ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) 262 in 263 let _ = run (S.finish s t ~ended_at:(day 1)) in 264 (* After a reconnect both effects of finish are visible together: 265 the workout is in history and no slot remains in progress. *) 266 let repo = connect uri in 267 let s = S.make ~repo in 268 Alcotest.(check int) 269 "one workout in history" 1 270 (List.length (run (S.history s t))); 271 Alcotest.(check bool) 272 "slot cleared" true 273 (Option.is_none (run (S.in_progress s t)))) ); 274 ( "subjective feedback survives a reconnect", 275 `Quick, 276 fun () -> 277 let path, uri = temp_uri () in 278 Fun.protect 279 ~finally:(fun () -> cleanup path) 280 (fun () -> 281 let t = 282 let repo = connect uri in 283 let s = S.make ~repo in 284 let id = 285 (ok 286 (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 287 .Trainee.id 288 in 289 let _ = 290 ok 291 (run 292 (S.record_feedback s id ~reported_at:(day 1) 293 [ 294 Evidence.Feedback.Sleep Evidence.Feedback.Poor; 295 Evidence.Feedback.Pain; 296 ])) 297 in 298 id 299 in 300 (* Reconnect: the feedback report is still there, with its 301 signals. *) 302 let repo = connect uri in 303 let s = S.make ~repo in 304 let reports = run (S.feedback s t) in 305 Alcotest.(check int) "one feedback report" 1 (List.length reports); 306 let signals = Evidence.Feedback.signals (List.hd reports) in 307 Alcotest.(check int) "two signals" 2 (List.length signals); 308 Alcotest.(check bool) 309 "sleep signal preserved" true 310 (List.mem (Evidence.Feedback.Sleep Evidence.Feedback.Poor) signals); 311 Alcotest.(check bool) 312 "pain signal preserved" true 313 (List.mem Evidence.Feedback.Pain signals)) ); 314 ( "application feedback survives a reconnect", 315 `Quick, 316 fun () -> 317 let path, uri = temp_uri () in 318 Fun.protect 319 ~finally:(fun () -> cleanup path) 320 (fun () -> 321 let id = 322 let repo = connect uri in 323 let s = S.make ~repo in 324 let id = 325 (ok 326 (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 327 .Trainee.id 328 in 329 let _ = 330 ok 331 (run 332 (S.record_app_feedback s id ~submitted_at:(day 2) 333 ~message:"The app feels clear.")) 334 in 335 id 336 in 337 let repo = connect uri in 338 let s = S.make ~repo in 339 match run (S.app_feedback s id) with 340 | [ report ] -> 341 Alcotest.(check string) 342 "message persisted" "The app feels clear." 343 report.Repository.message; 344 Alcotest.(check int) 345 "timestamp persisted" (2 * 86_400) 346 (Recovery.timestamp_to_unix_seconds report.submitted_at) 347 | reports -> 348 Alcotest.failf "expected one report, got %d" 349 (List.length reports)) ); 350 ( "application feedback ranking and votes survive a reconnect", 351 `Quick, 352 fun () -> 353 let path, uri = temp_uri () in 354 Fun.protect 355 ~finally:(fun () -> cleanup path) 356 (fun () -> 357 let bob_feedback_id = 358 let repo = connect uri in 359 let s = S.make ~repo in 360 let alice = 361 (ok 362 (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 363 .Trainee.id 364 in 365 let bob = 366 (ok 367 (run (S.register s ~username:"bobby" ~password:"heavyduty1"))) 368 .Trainee.id 369 in 370 let _ = 371 ok 372 (run 373 (S.record_app_feedback s alice ~submitted_at:(day 1) 374 ~message:"From Alice")) 375 in 376 let bob_report = 377 ok 378 (run 379 (S.record_app_feedback s bob ~submitted_at:(day 2) 380 ~message:"From Bob")) 381 in 382 Alcotest.(check bool) 383 "vote is accepted" true 384 (run 385 (S.upvote_app_feedback s alice 386 bob_report.Repository.feedback_id)); 387 bob_report.Repository.feedback_id 388 in 389 let repo = connect uri in 390 let s = S.make ~repo in 391 let alice = 392 Option.get 393 (run 394 (S.authenticate s ~username:"alice" ~password:"heavyduty1")) 395 in 396 let bob = 397 Option.get 398 (run 399 (S.authenticate s ~username:"bobby" ~password:"heavyduty1")) 400 in 401 let reports = run (S.app_feedback s alice.Trainee.id) in 402 let bob_report = 403 List.find 404 (fun report -> String.equal report.Repository.author "bobby") 405 reports 406 in 407 Alcotest.(check string) 408 "feedback identity" 409 (Repository.app_feedback_id_to_string bob_feedback_id) 410 (Repository.app_feedback_id_to_string 411 bob_report.Repository.feedback_id); 412 Alcotest.(check int) 413 "vote persisted" 1 bob_report.Repository.upvotes; 414 Alcotest.(check bool) 415 "viewer vote persisted" true bob_report.Repository.viewer_upvoted; 416 let own_view = 417 List.find 418 (fun report -> String.equal report.Repository.author "bobby") 419 (run (S.app_feedback s bob.Trainee.id)) 420 in 421 Alcotest.(check bool) 422 "owner does not see a self vote" false 423 own_view.Repository.viewer_upvoted) ); 424 ( "application feedback CRUD survives and enforces ownership", 425 `Quick, 426 fun () -> 427 let path, uri = temp_uri () in 428 Fun.protect 429 ~finally:(fun () -> cleanup path) 430 (fun () -> 431 let report_id = 432 let repo = connect uri in 433 let s = S.make ~repo in 434 let alice = 435 (ok 436 (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 437 .Trainee.id 438 in 439 let bob = 440 (ok 441 (run (S.register s ~username:"bobby" ~password:"heavyduty1"))) 442 .Trainee.id 443 in 444 let report = 445 ok 446 (run 447 (S.record_app_feedback s alice ~submitted_at:(day 1) 448 ~message:"Original")) 449 in 450 (match 451 run 452 (S.edit_app_feedback s bob report.Repository.feedback_id 453 ~message:"Not yours") 454 with 455 | Error `Unknown_feedback -> () 456 | _ -> Alcotest.fail "another trainee edited the report"); 457 (match 458 run 459 (S.edit_app_feedback s alice report.Repository.feedback_id 460 ~message:"Edited") 461 with 462 | Ok () -> () 463 | _ -> Alcotest.fail "owner edit failed"); 464 report.Repository.feedback_id 465 in 466 let repo = connect uri in 467 let s = S.make ~repo in 468 let alice = 469 Option.get 470 (run 471 (S.authenticate s ~username:"alice" ~password:"heavyduty1")) 472 in 473 let edited = 474 List.find 475 (fun report -> 476 String.equal 477 (Repository.app_feedback_id_to_string 478 report.Repository.feedback_id) 479 (Repository.app_feedback_id_to_string report_id)) 480 (run (S.app_feedback s alice.Trainee.id)) 481 in 482 Alcotest.(check string) 483 "edited message persists" "Edited" edited.Repository.message; 484 Alcotest.(check bool) 485 "owner remove succeeds" true 486 (run (S.remove_app_feedback s alice.Trainee.id report_id)); 487 Alcotest.(check int) 488 "removed report is absent" 0 489 (List.length (run (S.app_feedback s alice.Trainee.id)))) ); 490 ( "a username and password change survive a reconnect", 491 `Quick, 492 fun () -> 493 let path, uri = temp_uri () in 494 Fun.protect 495 ~finally:(fun () -> cleanup path) 496 (fun () -> 497 let id = 498 let repo = connect uri in 499 let s = S.make ~repo in 500 let id = 501 (ok 502 (run (S.register s ~username:"alice" ~password:"heavyduty1"))) 503 .Trainee.id 504 in 505 let _ = ok (run (S.change_username s id ~username:"alicia")) in 506 let _ = 507 ok 508 (run 509 (S.change_password s id ~current:"heavyduty1" 510 ~next:"newsecret1")) 511 in 512 id 513 in 514 (* Reconnect: the new name and password must be the ones stored. *) 515 let repo = connect uri in 516 let s = S.make ~repo in 517 (match run (S.find_trainee s id) with 518 | Some found -> 519 Alcotest.(check string) 520 "renamed account persisted" "alicia" 521 (Trainee.username_to_string found.Trainee.username) 522 | None -> Alcotest.fail "account vanished"); 523 Alcotest.(check bool) 524 "the old password no longer authenticates" true 525 (Option.is_none 526 (run 527 (S.authenticate s ~username:"alicia" ~password:"heavyduty1"))); 528 Alcotest.(check bool) 529 "the new password authenticates" true 530 (Option.is_some 531 (run 532 (S.authenticate s ~username:"alicia" ~password:"newsecret1")))) 533 ); 534 ] 535 536 let suite = 537 [ 538 ("sqlite_repo", durability_tests); 539 ("sqlite_repo.migrations", migration_tests); 540 ] 541