1 open Lwt.Infix 2 open Hito_app 3 4 module Make (R : Repository.S) (H : Password_hash.S) = struct 5 module Service = Service.Make (R) (H) 6 7 type t = { 8 service : Service.t; 9 now : unit -> Recovery.timestamp; 10 registration_open : bool; 11 } 12 13 let default_now () = 14 Recovery.timestamp_of_unix_seconds (int_of_float (Unix.gettimeofday ())) 15 16 let make ~repo ?(now = default_now) ?(registration_open = false) () = 17 { service = Service.make ~repo; now; registration_open } 18 19 let flash_key = "hito.flash" 20 let html ?status page = Dream_html.respond ?status page 21 let redirect request path = Dream_html.redirect request path 22 23 let redirect_to request path = 24 redirect request (Dream_html.path_attr Dream_html.HTML.href path) 25 26 let redirect_with_flash request path message = 27 Dream.set_session_field request flash_key message >>= fun () -> 28 redirect_to request path 29 30 let redirect_with_flash_attr request path message = 31 Dream.set_session_field request flash_key message >>= fun () -> 32 redirect request path 33 34 let redirect_with_flash_raw request path message = 35 Dream.set_session_field request flash_key message >>= fun () -> 36 Dream.redirect request path 37 38 let not_found detail = 39 html (Pages.problem ~title:"Not found" ~detail) ~status:`Not_Found 40 41 let bad_request detail = 42 html (Pages.problem ~title:"Invalid request" ~detail) ~status:`Bad_Request 43 44 (* --- presentation of errors --- 45 46 Every domain and service error becomes a user-facing sentence here, so a 47 handler renders a message rather than deciding its wording. One module owns 48 the phrasing, and adding an error variant surfaces as a missing case. *) 49 module Present = struct 50 let form_invalid = "The submitted form is not valid." 51 52 let registration : Service.register_error -> string = function 53 | `Username e -> Format.asprintf "%a" Trainee.pp_username_error e 54 | `Username_taken -> "That username is already registered." 55 56 let sign_in_failed = "That username and password do not match." 57 let routine = Format.asprintf "%a" Service.pp_error 58 59 let log_error : Service.log_error -> string = function 60 | Service.No_workout_in_progress -> "No workout is in progress." 61 | Service.Rejected error -> 62 Format.asprintf "%a" Evidence.Workout.pp_error error 63 64 let edit_error : Service.edit_error -> string = function 65 | Service.Unknown_workout -> "That saved workout no longer exists." 66 | Service.Rejected_edit error -> 67 Format.asprintf "%a" Evidence.Workout.pp_error error 68 69 let unknown_routine = "That routine is not in the catalogue." 70 let unknown_record = "That saved workout no longer exists." 71 let no_workout = "No workout is in progress." 72 let slot_not_awaiting = "That slot is not awaiting a record." 73 74 let change_username : Service.change_username_error -> string = function 75 | `Username e -> Format.asprintf "%a" Trainee.pp_username_error e 76 | `Username_taken -> "That username is already registered." 77 | `Unknown -> "That account no longer exists." 78 79 let change_password : Service.change_password_error -> string = function 80 | `Incorrect_password -> "The current password is not correct." 81 | `Unknown -> "That account no longer exists." 82 83 let app_feedback_empty = "Enter feedback before submitting." 84 let username_changed = "Username changed." 85 let password_changed = "Password changed." 86 end 87 88 (* --- sessions and authentication --- *) 89 90 let session_key = "trainee" 91 92 let current_trainee t request = 93 match Dream.session_field request session_key with 94 | None -> Lwt.return None 95 | Some id -> Service.find_trainee t.service (Trainee.id id) 96 97 (* Resolve the authenticated trainee, or send an unauthenticated request to 98 the sign-in page. [handler] receives the trainee. The request and any path 99 captures stay in the caller's scope, so this one combinator serves every 100 route regardless of how many captures Dream passes. *) 101 let authenticated t request handler = 102 current_trainee t request >>= function 103 | Some trainee -> ( 104 handler trainee >>= fun response -> 105 match Dream.method_ request with 106 | `GET -> 107 Dream.drop_session_field request flash_key >|= fun () -> response 108 | _ -> Lwt.return response) 109 | None -> redirect_to request Routes.login 110 111 let decode_form decoder request = 112 Dream_html.form decoder ~csrf:true request >|= function 113 | `Ok value -> Ok value 114 | `Invalid errors -> Error (`Invalid errors) 115 | _ -> Error `Bad_request 116 117 (* Plain (non-dream-html) form read with CSRF, for auth forms. *) 118 let read_credentials request = 119 Dream.form request >|= function 120 | `Ok fields -> ( 121 let get k = List.assoc_opt k fields in 122 match (get "username", get "password") with 123 | Some username, Some password -> Ok (username, password) 124 | _ -> Error `Bad_request) 125 | _ -> Error `Bad_request 126 127 (* A CSRF guard for state-changing POSTs whose body carries no fields other 128 than the token. [Dream.form] verifies the token and returns [`Ok] only 129 when it is valid, so this rejects a forged or missing token. *) 130 let guard_csrf request = 131 Dream.form request >|= function `Ok _ -> Ok () | _ -> Error `Bad_request 132 133 module Auth = struct 134 let login_page t request = 135 current_trainee t request >>= function 136 | Some _ -> redirect_to request Routes.home 137 | None -> 138 html (Pages.login request ~registration_open:t.registration_open ()) 139 140 let register_page t request = 141 current_trainee t request >>= function 142 | Some _ -> redirect_to request Routes.home 143 | None -> html (Pages.register request ()) 144 145 let establish request (trainee : Trainee.t) = 146 Dream.set_session_field request session_key 147 (Trainee.id_to_string trainee.id) 148 >>= fun () -> redirect_to request Routes.home 149 150 let register t request = 151 read_credentials request >>= function 152 | Error _ -> 153 html ~status:`Bad_Request 154 (Pages.register request ~error:Present.form_invalid ()) 155 | Ok (username, password) -> ( 156 Service.register t.service ~username ~password >>= function 157 | Ok trainee -> establish request trainee 158 | Error err -> 159 html ~status:`Bad_Request 160 (Pages.register request ~error:(Present.registration err) ())) 161 162 let login t request = 163 read_credentials request >>= function 164 | Error _ -> 165 html ~status:`Bad_Request 166 (Pages.login request ~error:Present.form_invalid ()) 167 | Ok (username, password) -> ( 168 Service.authenticate t.service ~username ~password >>= function 169 | Some trainee -> establish request trainee 170 | None -> 171 html ~status:`Unauthorized 172 (Pages.login request ~error:Present.sign_in_failed ())) 173 174 let logout _t request = 175 guard_csrf request >>= function 176 | Error _ -> bad_request Present.form_invalid 177 | Ok () -> 178 Dream.invalidate_session request >>= fun () -> 179 redirect_to request Routes.login 180 181 let routes t = 182 (* Public sign-up is disabled by default. The [/register] routes appear 183 only when [registration_open] is set. Everything else is unconditional. *) 184 let register_routes = 185 if t.registration_open then 186 [ 187 Dream_html.get Routes.register (register_page t); 188 Dream_html.post Routes.register (register t); 189 ] 190 else [] 191 in 192 [ 193 Dream_html.get Routes.login (login_page t); 194 Dream_html.post Routes.login (login t); 195 Dream_html.post Routes.logout (logout t); 196 ] 197 @ register_routes 198 end 199 200 (* --- helpers over the service --- *) 201 202 let record_target t trainee id = 203 Service.find_record t.service trainee (Repository.workout_id id) 204 >|= Option.map (fun record -> 205 (record.Repository.id, record.Repository.workout)) 206 207 let outstanding workout slot = 208 List.assoc_opt slot (Evidence.Workout.outstanding workout) 209 210 (* The prescription at any valid slot, filled or not — the edit handlers 211 correct filled slots, which [outstanding] does not list. *) 212 let prescription_at workout slot = 213 List.nth_opt 214 (Prescription.Workout.stimuli (Evidence.Workout.prescription workout)) 215 slot 216 217 (* The slot a workout view should open on: the first slot still awaiting a 218 record, or the first slot when every slot is filled. A caller clamps a 219 requested slot against the prescription. This supplies the default. *) 220 let default_slot workout = 221 match Evidence.Workout.outstanding workout with 222 | (slot, _) :: _ -> slot 223 | [] -> 0 224 225 (* The slot a workout view should open on. An explicit [?slot=] query 226 wins when it names a real slot. Otherwise the view defaults to the first 227 incomplete slot. A [?slot=] out of range, or absent, falls back to the 228 default, so a bookmarked or hand-edited URL never renders an empty view. *) 229 let active_slot request workout = 230 let slot_count = 231 List.length 232 (Prescription.Workout.stimuli (Evidence.Workout.prescription workout)) 233 in 234 match Dream.query request "slot" with 235 | Some raw -> ( 236 match int_of_string_opt raw with 237 | Some slot when slot >= 0 && slot < slot_count -> slot 238 | _ -> default_slot workout) 239 | None -> default_slot workout 240 241 (* Map an [Evidence.Workout.t] into the view-model DTO the presenter renders, 242 so no Evidence or Prescription type crosses the boundary into Pages. The 243 same mapping serves the live workout and a saved-record view. The caller 244 supplies [record_id]/[editing]/[errors] separately. *) 245 246 (* The ending code a single-choice form uses, taken from an effort's outcome. 247 The form offers one ending, so the first extension stands for it. *) 248 let extension_code_of_effort effort = 249 match Evidence.Stimulus.Effort.outcome effort with 250 | Evidence.Stimulus.Positive_failure -> "" 251 | Evidence.Stimulus.Beyond_failure (first, _) -> ( 252 match first with 253 | Evidence.Stimulus.Forced_reps -> "forced" 254 | Evidence.Stimulus.Negatives -> "negatives" 255 | Evidence.Stimulus.Rest_pause -> "rest-pause" 256 | Evidence.Stimulus.Static_hold -> "static") 257 258 (* One line describing a recorded stimulus: the efforts joined by "into", then 259 any extensions appended. *) 260 let describe_stimulus stimulus = 261 let effort effort = 262 Format.asprintf "%s %g kg x %d" 263 (Exercise.name (Evidence.Stimulus.Effort.exercise effort)) 264 (Evidence.Stimulus.Effort.load effort) 265 (Evidence.Stimulus.Effort.reps effort) 266 in 267 let body = 268 String.concat " into " 269 (List.map effort (Evidence.Stimulus.efforts stimulus)) 270 in 271 match Evidence.Stimulus.extensions stimulus with 272 | [] -> body 273 | extensions -> 274 body ^ ", " 275 ^ String.concat " then " 276 (List.map 277 (Format.asprintf "%a" Evidence.Stimulus.pp_extension) 278 extensions) 279 280 let workout_view ~active_slot workout : View_model.Workout.t = 281 let prescription = Evidence.Workout.prescription workout in 282 let prescribed_slots = Prescription.Workout.stimuli prescription in 283 (* One entry per filled slot, the first fill in performance order — the fill 284 [replace_stimulus] keeps in place when a correction lands. *) 285 let filled = 286 List.fold_left 287 (fun acc (slot, stimulus) -> 288 if List.mem_assoc slot acc then acc else acc @ [ (slot, stimulus) ]) 289 [] 290 (Evidence.Workout.performed workout) 291 in 292 let load_string load = Printf.sprintf "%g" load in 293 let reps_string reps = string_of_int reps in 294 let label p = 295 match Prescription.Stimulus.delivery p with 296 | Prescription.Stimulus.Single e -> Exercise.name e 297 | Prescription.Stimulus.Pre_exhaust { isolation; compound } -> 298 Printf.sprintf "%s + %s" (Exercise.name isolation) 299 (Exercise.name compound) 300 in 301 let slot_view index p : View_model.Workout.slot = 302 let recorded = List.assoc_opt index filled in 303 let efforts = Option.map Evidence.Stimulus.efforts recorded in 304 let nth n = Option.bind efforts (fun es -> List.nth_opt es n) in 305 let load_of n = 306 Option.map 307 (fun e -> load_string (Evidence.Stimulus.Effort.load e)) 308 (nth n) 309 in 310 let reps_of n = 311 Option.map 312 (fun e -> reps_string (Evidence.Stimulus.Effort.reps e)) 313 (nth n) 314 in 315 let movements : View_model.Workout.movement list = 316 match Prescription.Stimulus.delivery p with 317 | Prescription.Stimulus.Single exercise -> 318 [ 319 { 320 name = Exercise.name exercise; 321 load_field = "load"; 322 reps_field = "reps"; 323 reps_label = "Reps to failure"; 324 load_value = load_of 0; 325 reps_value = reps_of 0; 326 }; 327 ] 328 | Prescription.Stimulus.Pre_exhaust { isolation; compound } -> 329 [ 330 { 331 name = Exercise.name isolation; 332 load_field = "iso_load"; 333 reps_field = "iso_reps"; 334 reps_label = "Reps"; 335 load_value = load_of 0; 336 reps_value = reps_of 0; 337 }; 338 { 339 name = Exercise.name compound; 340 load_field = "comp_load"; 341 reps_field = "comp_reps"; 342 reps_label = "Reps"; 343 load_value = load_of 1; 344 reps_value = reps_of 1; 345 }; 346 ] 347 in 348 let selected_extension = 349 match recorded with 350 | None -> "" 351 | Some s -> ( 352 (* The ending lives on the last effort (the compound of a pair). *) 353 match List.rev (Evidence.Stimulus.efforts s) with 354 | last :: _ -> extension_code_of_effort last 355 | [] -> "") 356 in 357 { 358 index; 359 label = label p; 360 movements; 361 recorded_summary = Option.map describe_stimulus recorded; 362 selected_extension; 363 } 364 in 365 let overridden = 366 match Recovery.basis (Evidence.Workout.clearance workout) with 367 | Recovery.Overridden _ -> true 368 | Recovery.Recovered -> false 369 in 370 { 371 name = Prescription.Workout.name prescription; 372 slots = List.mapi slot_view prescribed_slots; 373 active_slot; 374 started_at_unix = 375 Recovery.timestamp_to_unix_seconds (Evidence.Workout.started_at workout); 376 overridden; 377 all_recorded = Evidence.Workout.outstanding workout = []; 378 } 379 380 let save_current t trainee stimulus = 381 Service.log t.service trainee stimulus >|= function 382 | Ok _ -> Ok () 383 | Error e -> Error (Present.log_error e) 384 385 let replace_current t trainee ~slot stimulus = 386 Service.replace_current t.service trainee ~slot stimulus >|= function 387 | Ok _ -> Ok () 388 | Error e -> Error (Present.log_error e) 389 390 let save_record t trainee id stimulus = 391 Service.add_to_record t.service trainee id stimulus >|= function 392 | Ok _ -> Ok () 393 | Error e -> Error (Present.edit_error e) 394 395 let replace_record t trainee id ~slot stimulus = 396 Service.replace_in_record t.service trainee id ~slot stimulus >|= function 397 | Ok _ -> Ok () 398 | Error e -> Error (Present.edit_error e) 399 400 module Overview = struct 401 (* Map service entities into the view-model DTOs the presenter renders, so 402 no Prescription or Recovery type crosses the boundary into Pages. These 403 replicate the phrasing the shared presenter formatters use. *) 404 let routine_choice_view 405 ((rid, r) : Repository.routine_id * Prescription.Routine.t) : 406 View_model.Routine_choice.t = 407 { 408 id = (rid :> string); 409 name = Prescription.Routine.name r; 410 workout_count = List.length (Prescription.Routine.workouts r); 411 } 412 413 let exercise_string prescription = 414 match Prescription.Stimulus.delivery prescription with 415 | Prescription.Stimulus.Single exercise -> Exercise.name exercise 416 | Prescription.Stimulus.Pre_exhaust { isolation; compound } -> 417 Printf.sprintf "%s into %s, no pause" (Exercise.name isolation) 418 (Exercise.name compound) 419 420 let reps_string prescription = 421 let min_reps, max_reps = 422 Prescription.Rep_range.bounds 423 (Prescription.Stimulus.rep_range prescription) 424 in 425 Printf.sprintf "%d-%d" min_reps max_reps 426 427 let routine_view r : View_model.Routine.t = 428 { 429 name = Prescription.Routine.name r; 430 workouts = 431 List.map 432 (fun w : View_model.Routine.workout -> 433 { 434 name = Prescription.Workout.name w; 435 exercises = 436 List.map 437 (fun s : View_model.Routine.exercise -> 438 { name = exercise_string s; reps = reps_string s }) 439 (Prescription.Workout.stimuli w); 440 }) 441 (Prescription.Routine.workouts r); 442 } 443 444 let duration_hours duration = 445 let hours = 446 float_of_int (Recovery.duration_to_seconds duration) /. 3600. 447 in 448 if Float.equal hours (Float.round hours) then Printf.sprintf "%.0fh" hours 449 else Printf.sprintf "%.1fh" hours 450 451 let home_view ~(routine : Repository.routine_id) ~routine_name ~next 452 ~readiness : View_model.Home.t = 453 { 454 routine_id = (routine :> string); 455 routine_name; 456 next_workout = Prescription.Workout.name next; 457 gate = 458 (match readiness with 459 | Recovery.Ready -> View_model.Home.Ready 460 | Recovery.Recovering { rested; recommended } -> 461 View_model.Home.Recovering 462 { 463 status = 464 Printf.sprintf "Recovery: %s of %s." (duration_hours rested) 465 (duration_hours recommended); 466 }); 467 } 468 469 let page t trainee request = 470 let viewer = 471 { 472 View_model.Viewer.username = 473 Trainee.username_to_string trainee.Trainee.username; 474 } 475 in 476 Service.in_progress t.service trainee.Trainee.id >>= function 477 | Some workout -> 478 let workout_name = 479 Prescription.Workout.name (Evidence.Workout.prescription workout) 480 in 481 Lwt.return (Pages.workout_in_progress request ~viewer ~workout_name) 482 | None -> ( 483 Service.active_routine t.service trainee.Trainee.id >>= function 484 | None -> 485 Lwt.return 486 (Pages.choose_routine request ~logging:false ~viewer 487 ~routines: 488 (List.map routine_choice_view 489 (Service.list_routines t.service))) 490 | Some (routine, selected) -> ( 491 Service.next_workout t.service trainee.Trainee.id ~routine 492 >>= fun next -> 493 Service.readiness t.service trainee.Trainee.id ~routine 494 ~now:(t.now ()) 495 >|= fun readiness -> 496 match (next, readiness) with 497 | Ok next, Ok readiness -> 498 Pages.home request ~viewer 499 ~home: 500 (home_view ~routine 501 ~routine_name:(Prescription.Routine.name selected) 502 ~next ~readiness) 503 | Error error, _ | _, Error error -> 504 Pages.problem ~title:"Routine unavailable" 505 ~detail:(Present.routine error))) 506 507 let home t trainee request = page t trainee request >>= html 508 509 let routines t trainee request = 510 let viewer = 511 { 512 View_model.Viewer.username = 513 Trainee.username_to_string trainee.Trainee.username; 514 } 515 in 516 Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> 517 html 518 (Pages.choose_routine request 519 ~logging:(Option.is_some in_progress) 520 ~viewer 521 ~routines: 522 (List.map routine_choice_view (Service.list_routines t.service))) 523 524 let select_routine t trainee request id = 525 guard_csrf request >>= function 526 | Error _ -> redirect_with_flash request Routes.home Present.form_invalid 527 | Ok () -> ( 528 Service.select_routine t.service trainee.Trainee.id 529 (Repository.routine_id id) 530 >>= function 531 | Ok () -> redirect_with_flash request Routes.home "Routine selected." 532 | Error _ -> not_found Present.unknown_routine) 533 534 let routine t trainee request = 535 let viewer = 536 { 537 View_model.Viewer.username = 538 Trainee.username_to_string trainee.Trainee.username; 539 } 540 in 541 Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> 542 Service.active_routine t.service trainee.Trainee.id >>= function 543 | Some (_, routine) -> 544 html 545 (Pages.routine request 546 ~logging:(Option.is_some in_progress) 547 ~viewer (routine_view routine)) 548 | None -> redirect_to request Routes.routines 549 550 let routes t = 551 [ 552 Dream_html.get Routes.home (fun request -> 553 authenticated t request (fun trainee -> home t trainee request)); 554 Dream_html.get Routes.routines (fun request -> 555 authenticated t request (fun trainee -> routines t trainee request)); 556 Dream_html.post Routes.select_routine (fun request id -> 557 authenticated t request (fun trainee -> 558 select_routine t trainee request id)); 559 Dream_html.get Routes.routine (fun request -> 560 authenticated t request (fun trainee -> routine t trainee request)); 561 ] 562 end 563 564 module Current_workout = struct 565 let begin_workout t trainee request = 566 decode_form Decode.override request >>= function 567 | Error _ -> redirect_with_flash request Routes.home Present.form_invalid 568 | Ok override -> ( 569 Service.active_routine t.service trainee.Trainee.id >>= function 570 | None -> redirect_to request Routes.routines 571 | Some (routine, _) -> ( 572 let override = if override then Some () else None in 573 Service.begin_workout t.service trainee.Trainee.id ~routine 574 ~now:(t.now ()) ?override () 575 >>= function 576 | Ok _ -> 577 redirect_with_flash request Routes.workout "Workout started." 578 | Error (Service.Not_recovered _) -> 579 redirect_with_flash request Routes.home 580 "The workout needs an explicit recovery override." 581 | Error Service.Unknown_routine -> 582 not_found Present.unknown_routine)) 583 584 let show t trainee request = 585 let viewer = 586 { 587 View_model.Viewer.username = 588 Trainee.username_to_string trainee.Trainee.username; 589 } 590 in 591 Service.in_progress t.service trainee.Trainee.id >>= function 592 | Some workout -> 593 let active_slot = active_slot request workout in 594 html 595 (Pages.workout request ~viewer ~record_id:None ~active_slot 596 (workout_view ~active_slot workout)) 597 | None -> redirect_to request Routes.home 598 599 let log t trainee request slot = 600 Service.in_progress t.service trainee.Trainee.id >>= function 601 | None -> not_found Present.no_workout 602 | Some workout -> ( 603 match outstanding workout slot with 604 | None -> not_found Present.slot_not_awaiting 605 | Some prescription -> ( 606 decode_form (Decode.stimulus prescription) request >>= function 607 | Error (`Invalid errors) -> 608 redirect_with_flash request Routes.workout 609 (Decode.errors_to_text errors) 610 | Error `Bad_request -> 611 redirect_with_flash request Routes.workout 612 Present.form_invalid 613 | Ok stimulus -> ( 614 save_current t trainee.Trainee.id stimulus >>= function 615 | Ok () -> 616 redirect_with_flash request Routes.workout "Record saved." 617 | Error detail -> 618 redirect_with_flash request Routes.workout detail))) 619 620 (* Correct a recorded slot of the workout in progress. The slot may be 621 filled, so its prescription comes from the workout, not [outstanding]. 622 [replace_current] targets the slot and never adds volume. *) 623 let edit t trainee request slot = 624 Service.in_progress t.service trainee.Trainee.id >>= function 625 | None -> not_found Present.no_workout 626 | Some workout -> ( 627 match prescription_at workout slot with 628 | None -> not_found Present.slot_not_awaiting 629 | Some prescription -> ( 630 decode_form (Decode.stimulus prescription) request >>= function 631 | Error (`Invalid errors) -> 632 redirect_with_flash request Routes.workout 633 (Decode.errors_to_text errors) 634 | Error `Bad_request -> 635 redirect_with_flash request Routes.workout 636 Present.form_invalid 637 | Ok stimulus -> ( 638 replace_current t trainee.Trainee.id ~slot stimulus 639 >>= function 640 | Ok () -> 641 redirect_with_flash request Routes.workout "Record saved." 642 | Error detail -> 643 redirect_with_flash request Routes.workout detail))) 644 645 let finish t trainee request = 646 guard_csrf request >>= function 647 | Error _ -> redirect_with_flash request Routes.home Present.form_invalid 648 | Ok () -> ( 649 Service.finish t.service trainee.Trainee.id ~ended_at:(t.now ()) 650 >>= function 651 | Some _ -> 652 redirect_with_flash_raw request "/logbook?prompt=feedback" 653 "Workout finished." 654 | None -> redirect_with_flash request Routes.home Present.no_workout) 655 656 (* Cancelling discards the current workout and returns Home. An abandoned 657 session is not evidence, so it leaves no record. A forged or missing 658 CSRF token skips the discard but still leaves the workout view. *) 659 let cancel t trainee request = 660 guard_csrf request >>= function 661 | Error _ -> 662 redirect_with_flash request Routes.home 663 "Workout cancellation was not confirmed." 664 | Ok () -> 665 Service.cancel t.service trainee.Trainee.id >>= fun _ -> 666 redirect_with_flash request Routes.home "Workout cancelled." 667 668 let routes t = 669 [ 670 Dream_html.get Routes.workout (fun request -> 671 authenticated t request (fun trainee -> show t trainee request)); 672 Dream_html.post Routes.workout (fun request -> 673 authenticated t request (fun trainee -> 674 begin_workout t trainee request)); 675 Dream_html.post Routes.workout_slot (fun request slot -> 676 authenticated t request (fun trainee -> log t trainee request slot)); 677 Dream_html.post Routes.workout_slot_edit (fun request slot -> 678 authenticated t request (fun trainee -> edit t trainee request slot)); 679 Dream_html.post Routes.finish_workout (fun request -> 680 authenticated t request (fun trainee -> finish t trainee request)); 681 Dream_html.post Routes.cancel_workout (fun request -> 682 authenticated t request (fun trainee -> cancel t trainee request)); 683 ] 684 end 685 686 module Logbook = struct 687 let feedback_session_key = "hito.feedback.flow" 688 let feedback_factors = List.map fst Pages.feedback_factors 689 690 let valid_choice = function 691 | ("1" | "2" | "3" | "4" | "5") as choice -> Some choice 692 | _ -> None 693 694 let valid_factor field = List.mem field feedback_factors 695 696 let encode_feedback_flow (flow : Pages.feedback_flow) = 697 let answers = 698 List.map (fun (field, choice) -> field ^ ":" ^ choice) flow.answers 699 in 700 Printf.sprintf "%d|%s" flow.step (String.concat ";" answers) 701 702 let decode_feedback_flow raw = 703 match String.split_on_char '|' raw with 704 | [ step; answers ] -> ( 705 match int_of_string_opt step with 706 | None -> None 707 | Some step when step < 0 || step > 5 -> None 708 | Some step -> 709 let answers = 710 answers |> String.split_on_char ';' 711 |> List.filter_map (fun answer -> 712 match String.split_on_char ':' answer with 713 | [ field; choice ] 714 when valid_factor field 715 && Option.is_some (valid_choice choice) -> 716 Some (field, choice) 717 | _ -> None) 718 in 719 Some Pages.{ step; answers }) 720 | _ -> None 721 722 let feedback_flow request = 723 Dream.session_field request feedback_session_key |> fun raw -> 724 Option.bind raw decode_feedback_flow 725 726 let initial_feedback_flow = Pages.{ step = 0; answers = [] } 727 728 let set_feedback_flow request flow = 729 Dream.set_session_field request feedback_session_key 730 (encode_feedback_flow flow) 731 732 let clear_feedback_flow request = 733 Dream.drop_session_field request feedback_session_key 734 735 let field name fields = List.assoc_opt name fields 736 737 let feedback_signals answers flags = 738 let level choice = 739 match int_of_string_opt choice with 740 | Some n -> ( 741 match Evidence.Feedback.level_of_score n with 742 | Some l -> l 743 | None -> Evidence.Feedback.Fair) 744 | None -> Evidence.Feedback.Fair 745 in 746 let leveled field make = 747 List.find_map 748 (fun (answer_field, choice) -> 749 if String.equal field answer_field then 750 Option.map 751 (fun choice -> make (level choice)) 752 (valid_choice choice) 753 else None) 754 answers 755 in 756 let optional_flag name signal = 757 match field name flags with Some "true" -> Some signal | _ -> None 758 in 759 List.filter_map Fun.id 760 [ 761 leveled "sleep" (fun l -> Evidence.Feedback.Sleep l); 762 leveled "appetite" (fun l -> Evidence.Feedback.Appetite l); 763 leveled "readiness" (fun l -> Evidence.Feedback.Readiness l); 764 leveled "motivation" (fun l -> Evidence.Feedback.Motivation l); 765 leveled "difficulty" (fun l -> Evidence.Feedback.Difficulty l); 766 optional_flag "pain" Evidence.Feedback.Pain; 767 optional_flag "injury" Evidence.Feedback.Injury; 768 optional_flag "preparation" Evidence.Feedback.Preparation_insufficient; 769 ] 770 771 (* Describe one signal for the list, and compute a factor's score for the 772 graph. These read the Evidence.Feedback entity here in the controller, so 773 the presenter receives only strings and scores. *) 774 let describe_signal (signal : Evidence.Feedback.signal) = 775 let level l = 776 let score = Evidence.Feedback.level_to_score l in 777 match l with 778 | Evidence.Feedback.Very_poor -> Printf.sprintf "%d (very poor)" score 779 | Very_good -> Printf.sprintf "%d (very good)" score 780 | _ -> string_of_int score 781 in 782 match signal with 783 | Sleep l -> Printf.sprintf "Sleep %s" (level l) 784 | Appetite l -> Printf.sprintf "Appetite %s" (level l) 785 | Readiness l -> Printf.sprintf "Readiness %s" (level l) 786 | Motivation l -> Printf.sprintf "Motivation %s" (level l) 787 | Difficulty l -> Printf.sprintf "Difficulty %s" (level l) 788 | Pain -> "Pain" 789 | Injury -> "Injury" 790 | Preparation_insufficient -> "Preparation insufficient" 791 792 let factor_fields = 793 [ "sleep"; "appetite"; "readiness"; "motivation"; "difficulty" ] 794 795 let factor_score field (report : Evidence.Feedback.t) = 796 let of_signal (signal : Evidence.Feedback.signal) = 797 match (field, signal) with 798 | "sleep", Sleep l 799 | "appetite", Appetite l 800 | "readiness", Readiness l 801 | "motivation", Motivation l 802 | "difficulty", Difficulty l -> 803 Some (Evidence.Feedback.level_to_score l) 804 | _ -> None 805 in 806 List.find_map of_signal (Evidence.Feedback.signals report) 807 808 let entry_view (record : Repository.record) : View_model.Logbook_entry.t = 809 let workout = record.Repository.workout in 810 { 811 id = (record.Repository.id :> string); 812 workout_name = 813 Prescription.Workout.name (Evidence.Workout.prescription workout); 814 stimuli_count = List.length (Evidence.Workout.stimuli workout); 815 complete = 816 (match Evidence.Workout.completeness workout with 817 | Evidence.Workout.Complete -> true 818 | Incomplete -> false); 819 } 820 821 let feedback_view (report : Evidence.Feedback.t) : 822 View_model.Feedback.report = 823 { 824 at_unix = 825 Recovery.timestamp_to_unix_seconds 826 (Evidence.Feedback.reported_at report); 827 signals = List.map describe_signal (Evidence.Feedback.signals report); 828 factor_scores = 829 List.map (fun f -> (f, factor_score f report)) factor_fields; 830 } 831 832 let index t trainee request = 833 let viewer = 834 { 835 View_model.Viewer.username = 836 Trainee.username_to_string trainee.Trainee.username; 837 } 838 in 839 Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> 840 Service.history t.service trainee.Trainee.id >>= fun records -> 841 Service.feedback t.service trainee.Trainee.id >>= fun feedback -> 842 let feedback = List.map feedback_view feedback in 843 let records = List.map entry_view records in 844 let saved_flow = feedback_flow request in 845 let feedback_open = 846 match 847 (Dream.query request "feedback", Dream.query request "prompt") 848 with 849 | Some "start", _ | _, Some "feedback" -> true 850 | _ -> Option.is_some saved_flow 851 in 852 html 853 (Pages.logbook request 854 ~logging:(Option.is_some in_progress) 855 ~viewer ~feedback 856 ~suggest_feedback: 857 (match Dream.query request "prompt" with 858 | Some "feedback" -> true 859 | _ -> false) 860 ~feedback_flow: 861 (Option.value saved_flow ~default:initial_feedback_flow) 862 ~feedback_open records) 863 864 let finish_feedback t trainee request flow flags = 865 let signals = feedback_signals flow.Pages.answers flags in 866 Service.record_feedback t.service trainee.Trainee.id 867 ~reported_at:(t.now ()) signals 868 >>= function 869 | Ok _ -> 870 clear_feedback_flow request >>= fun () -> 871 redirect_with_flash request Routes.logbook "Feedback saved." 872 | Error _ -> 873 clear_feedback_flow request >>= fun () -> 874 redirect_with_flash request Routes.logbook Present.form_invalid 875 876 (* Advance one factor. The answer map stays in the session until the final 877 optional-observations step, so refreshes never lose earlier choices. *) 878 let record_feedback t trainee request = 879 Dream.form request >>= function 880 | `Ok fields -> ( 881 let flow = 882 Option.value (feedback_flow request) ~default:initial_feedback_flow 883 in 884 match 885 field "step" fields |> fun raw -> 886 (Option.bind raw int_of_string_opt, flow.step) 887 with 888 | Some step, expected when step = expected -> 889 let action = 890 match field "action" fields with 891 | Some ("next" | "Next") -> Some "next" 892 | Some ("back" | "Back") -> Some "back" 893 | Some ("skip" | "Skip this factor" | "Skip this step") -> 894 Some "skip" 895 | Some ("save" | "Record feedback") -> Some "save" 896 | _ -> None 897 in 898 (* Back steps to the previous factor and keeps every answer, so a 899 trainee can revise an earlier report without losing the rest. *) 900 if action = Some "back" then 901 if step = 0 then redirect_to request Routes.logbook 902 else 903 let previous = Pages.{ flow with step = step - 1 } in 904 set_feedback_flow request previous >>= fun () -> 905 redirect_to request Routes.logbook 906 else if step = 5 then 907 if action = Some "skip" then 908 finish_feedback t trainee request flow [] 909 else if action = Some "save" then 910 finish_feedback t trainee request flow fields 911 else 912 redirect_with_flash request Routes.logbook 913 Present.form_invalid 914 else 915 let factor = List.nth feedback_factors step in 916 let answers = 917 match 918 ( action, 919 field "choice" fields |> fun raw -> 920 Option.bind raw valid_choice ) 921 with 922 | Some "next", Some choice -> (factor, choice) :: flow.answers 923 | Some "skip", _ -> flow.answers 924 | _ -> flow.answers 925 in 926 if action <> Some "next" && action <> Some "skip" then 927 redirect_with_flash request Routes.logbook 928 Present.form_invalid 929 else 930 let next = Pages.{ step = step + 1; answers } in 931 set_feedback_flow request next >>= fun () -> 932 redirect_to request Routes.logbook 933 | _ -> redirect_with_flash request Routes.logbook Present.form_invalid 934 ) 935 | _ -> redirect_with_flash request Routes.logbook Present.form_invalid 936 937 let cancel_feedback _t _trainee request = 938 guard_csrf request >>= function 939 | Error _ -> 940 redirect_with_flash request Routes.logbook Present.form_invalid 941 | Ok () -> 942 clear_feedback_flow request >>= fun () -> 943 redirect_with_flash request Routes.logbook "Feedback skipped." 944 945 let show t trainee request id = 946 let viewer = 947 { 948 View_model.Viewer.username = 949 Trainee.username_to_string trainee.Trainee.username; 950 } 951 in 952 Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> 953 record_target t trainee.Trainee.id id >>= function 954 | None -> not_found Present.unknown_record 955 | Some (_, workout) -> 956 let active_slot = active_slot request workout in 957 html 958 (Pages.workout request ~viewer 959 ~logging:(Option.is_some in_progress) 960 ~record_id:(Some id) ~active_slot 961 (workout_view ~active_slot workout)) 962 963 let log t trainee request id slot = 964 record_target t trainee.Trainee.id id >>= function 965 | None -> not_found Present.unknown_record 966 | Some (record_id, workout) -> ( 967 match outstanding workout slot with 968 | None -> not_found Present.slot_not_awaiting 969 | Some prescription -> ( 970 decode_form (Decode.stimulus prescription) request >>= function 971 | Error (`Invalid errors) -> 972 redirect_with_flash_attr request 973 (Dream_html.path_attr Dream_html.HTML.href Routes.record id) 974 (Decode.errors_to_text errors) 975 | Error `Bad_request -> 976 redirect_with_flash_attr request 977 (Dream_html.path_attr Dream_html.HTML.href Routes.record id) 978 Present.form_invalid 979 | Ok stimulus -> ( 980 save_record t trainee.Trainee.id record_id stimulus 981 >>= function 982 | Ok () -> 983 redirect_with_flash_attr request 984 (Dream_html.path_attr Dream_html.HTML.href Routes.record 985 id) 986 "Record saved." 987 | Error detail -> 988 redirect_with_flash_attr request 989 (Dream_html.path_attr Dream_html.HTML.href Routes.record 990 id) 991 detail))) 992 993 (* Correct a recorded slot of a saved workout. [replace_record] targets the 994 slot, replacing its record rather than appending volume. *) 995 let edit t trainee request id slot = 996 record_target t trainee.Trainee.id id >>= function 997 | None -> not_found Present.unknown_record 998 | Some (record_id, workout) -> ( 999 match prescription_at workout slot with 1000 | None -> not_found Present.slot_not_awaiting 1001 | Some prescription -> ( 1002 decode_form (Decode.stimulus prescription) request >>= function 1003 | Error (`Invalid errors) -> 1004 redirect_with_flash_attr request 1005 (Dream_html.path_attr Dream_html.HTML.href Routes.record id) 1006 (Decode.errors_to_text errors) 1007 | Error `Bad_request -> 1008 redirect_with_flash_attr request 1009 (Dream_html.path_attr Dream_html.HTML.href Routes.record id) 1010 Present.form_invalid 1011 | Ok stimulus -> ( 1012 replace_record t trainee.Trainee.id record_id ~slot stimulus 1013 >>= function 1014 | Ok () -> 1015 redirect_with_flash_attr request 1016 (Dream_html.path_attr Dream_html.HTML.href Routes.record 1017 id) 1018 "Record saved." 1019 | Error detail -> 1020 redirect_with_flash_attr request 1021 (Dream_html.path_attr Dream_html.HTML.href Routes.record 1022 id) 1023 detail))) 1024 1025 let routes t = 1026 [ 1027 Dream_html.get Routes.logbook (fun request -> 1028 authenticated t request (fun trainee -> index t trainee request)); 1029 Dream_html.post Routes.feedback (fun request -> 1030 authenticated t request (fun trainee -> 1031 record_feedback t trainee request)); 1032 Dream_html.post Routes.cancel_feedback (fun request -> 1033 authenticated t request (fun trainee -> 1034 cancel_feedback t trainee request)); 1035 Dream_html.get Routes.record (fun request id -> 1036 authenticated t request (fun trainee -> show t trainee request id)); 1037 Dream_html.post Routes.record_slot (fun request id slot -> 1038 authenticated t request (fun trainee -> 1039 log t trainee request id slot)); 1040 Dream_html.post Routes.record_slot_edit (fun request id slot -> 1041 authenticated t request (fun trainee -> 1042 edit t trainee request id slot)); 1043 ] 1044 end 1045 1046 module App_feedback = struct 1047 let tab request = 1048 match Dream.query request "tab" with 1049 | Some "submitted" -> `Submitted 1050 | _ -> `Write 1051 1052 let time_to_string timestamp = 1053 let tm = 1054 Unix.gmtime 1055 (float_of_int (Recovery.timestamp_to_unix_seconds timestamp)) 1056 in 1057 Printf.sprintf "%04d-%02d-%02d %02d:%02d" (tm.Unix.tm_year + 1900) 1058 (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min 1059 1060 (* Map a repository record into the view model the presenter renders, so no 1061 entity or record crosses the boundary into Pages. *) 1062 let view_of (report : Repository.app_feedback) : View_model.App_feedback.t = 1063 { 1064 id = Repository.app_feedback_id_to_string report.Repository.feedback_id; 1065 author = report.Repository.author; 1066 contributions = report.Repository.contributions; 1067 submitted_at = time_to_string report.Repository.submitted_at; 1068 message = report.Repository.message; 1069 upvotes = report.Repository.upvotes; 1070 viewer_upvoted = report.Repository.viewer_upvoted; 1071 viewer_owns = report.Repository.viewer_owns; 1072 } 1073 1074 let show t trainee request = 1075 let viewer = 1076 { 1077 View_model.Viewer.username = 1078 Trainee.username_to_string trainee.Trainee.username; 1079 } 1080 in 1081 Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> 1082 Service.app_feedback t.service trainee.Trainee.id >>= fun reports -> 1083 html 1084 (Pages.app_feedback request 1085 ~logging:(Option.is_some in_progress) 1086 ~viewer ~tab:(tab request) (List.map view_of reports)) 1087 1088 let submit t trainee request = 1089 decode_form Decode.app_feedback request >>= function 1090 | Error _ -> 1091 redirect_with_flash_raw request "/app-feedback?tab=write" 1092 Present.form_invalid 1093 | Ok message -> ( 1094 Service.record_app_feedback t.service trainee.Trainee.id 1095 ~submitted_at:(t.now ()) ~message 1096 >>= function 1097 | Ok _ -> 1098 redirect_with_flash_raw request "/app-feedback?tab=submitted" 1099 "Feedback submitted." 1100 | Error `Empty_message -> 1101 redirect_with_flash_raw request "/app-feedback?tab=write" 1102 Present.app_feedback_empty 1103 | Error `Unknown_feedback -> 1104 redirect_with_flash_raw request "/app-feedback?tab=submitted" 1105 "That feedback is no longer available.") 1106 1107 let upvote t trainee request id = 1108 guard_csrf request >>= function 1109 | Error _ -> 1110 redirect_with_flash_raw request "/app-feedback?tab=submitted" 1111 Present.form_invalid 1112 | Ok () -> 1113 Service.upvote_app_feedback t.service trainee.Trainee.id 1114 (Repository.app_feedback_id id) 1115 >>= fun added -> 1116 redirect_with_flash_raw request "/app-feedback?tab=submitted" 1117 (if added then "Vote recorded." else "Vote was not added.") 1118 1119 let edit t trainee request id = 1120 decode_form Decode.app_feedback request >>= function 1121 | Error _ -> 1122 redirect_with_flash_raw request "/app-feedback?tab=submitted" 1123 Present.form_invalid 1124 | Ok message -> ( 1125 Service.edit_app_feedback t.service trainee.Trainee.id 1126 (Repository.app_feedback_id id) 1127 ~message 1128 >>= function 1129 | Ok () -> 1130 redirect_with_flash_raw request "/app-feedback?tab=submitted" 1131 "Feedback updated." 1132 | Error `Empty_message -> 1133 redirect_with_flash_raw request "/app-feedback?tab=submitted" 1134 Present.app_feedback_empty 1135 | Error `Unknown_feedback -> 1136 redirect_with_flash_raw request "/app-feedback?tab=submitted" 1137 "That feedback is no longer available.") 1138 1139 let remove t trainee request id = 1140 guard_csrf request >>= function 1141 | Error _ -> 1142 redirect_with_flash_raw request "/app-feedback?tab=submitted" 1143 Present.form_invalid 1144 | Ok () -> 1145 Service.remove_app_feedback t.service trainee.Trainee.id 1146 (Repository.app_feedback_id id) 1147 >>= fun removed -> 1148 redirect_with_flash_raw request "/app-feedback?tab=submitted" 1149 (if removed then "Feedback removed." 1150 else "That feedback is no longer available.") 1151 1152 let routes t = 1153 [ 1154 Dream_html.get Routes.app_feedback (fun request -> 1155 authenticated t request (fun trainee -> show t trainee request)); 1156 Dream_html.post Routes.submit_app_feedback (fun request -> 1157 authenticated t request (fun trainee -> submit t trainee request)); 1158 Dream_html.post Routes.upvote_app_feedback (fun request id -> 1159 authenticated t request (fun trainee -> upvote t trainee request id)); 1160 Dream_html.post Routes.edit_app_feedback (fun request id -> 1161 authenticated t request (fun trainee -> edit t trainee request id)); 1162 Dream_html.post Routes.remove_app_feedback (fun request id -> 1163 authenticated t request (fun trainee -> remove t trainee request id)); 1164 ] 1165 end 1166 1167 module Profile = struct 1168 (* The profile page. A [?changed=] query set by a successful redirect shows 1169 a confirmation notice, so a refresh never re-posts a change. *) 1170 let show t trainee request = 1171 let viewer = 1172 { 1173 View_model.Viewer.username = 1174 Trainee.username_to_string trainee.Trainee.username; 1175 } 1176 in 1177 Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> 1178 let notice = 1179 match Dream.query request "changed" with 1180 | Some "username" -> Some Present.username_changed 1181 | Some "password" -> Some Present.password_changed 1182 | _ -> None 1183 in 1184 html 1185 (Pages.profile request 1186 ~logging:(Option.is_some in_progress) 1187 ~viewer ?notice ()) 1188 1189 let render_error t trainee request ?username_error ?password_error () = 1190 let viewer = 1191 { 1192 View_model.Viewer.username = 1193 Trainee.username_to_string trainee.Trainee.username; 1194 } 1195 in 1196 Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> 1197 html ~status:`Bad_Request 1198 (Pages.profile request 1199 ~logging:(Option.is_some in_progress) 1200 ~viewer ?username_error ?password_error ()) 1201 1202 let change_username t trainee request = 1203 decode_form Decode.profile_username request >>= function 1204 | Error _ -> bad_request Present.form_invalid 1205 | Ok username -> ( 1206 Service.change_username t.service trainee.Trainee.id ~username 1207 >>= function 1208 | Ok _ -> Dream.redirect request "/profile?changed=username" 1209 | Error error -> 1210 render_error t trainee request 1211 ~username_error:(Present.change_username error) 1212 ()) 1213 1214 let change_password t trainee request = 1215 decode_form Decode.profile_password request >>= function 1216 | Error _ -> bad_request Present.form_invalid 1217 | Ok (current, next) -> ( 1218 Service.change_password t.service trainee.Trainee.id ~current ~next 1219 >>= function 1220 | Ok _ -> Dream.redirect request "/profile?changed=password" 1221 | Error error -> 1222 render_error t trainee request 1223 ~password_error:(Present.change_password error) 1224 ()) 1225 1226 let routes t = 1227 [ 1228 Dream_html.get Routes.profile (fun request -> 1229 authenticated t request (fun trainee -> show t trainee request)); 1230 Dream_html.post Routes.profile_username (fun request -> 1231 authenticated t request (fun trainee -> 1232 change_username t trainee request)); 1233 Dream_html.post Routes.profile_password (fun request -> 1234 authenticated t request (fun trainee -> 1235 change_password t trainee request)); 1236 ] 1237 end 1238 1239 module Settings = struct 1240 let theme_session_key = "hito.theme" 1241 1242 let theme request = 1243 match Dream.session_field request theme_session_key with 1244 | Some "dark" -> "dark" 1245 | _ -> "light" 1246 1247 let show t trainee request = 1248 let viewer = 1249 { 1250 View_model.Viewer.username = 1251 Trainee.username_to_string trainee.Trainee.username; 1252 } 1253 in 1254 Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> 1255 html 1256 (Pages.settings request 1257 ~logging:(Option.is_some in_progress) 1258 ~viewer ~theme:(theme request) ()) 1259 1260 let update _trainee request = 1261 guard_csrf request >>= function 1262 | Error _ -> 1263 redirect_with_flash request Routes.settings Present.form_invalid 1264 | Ok () -> ( 1265 Dream.form request >>= function 1266 | `Ok fields -> ( 1267 match List.assoc_opt "theme" fields with 1268 | Some (("light" | "dark") as value) -> 1269 Dream.set_session_field request theme_session_key value 1270 >>= fun () -> Dream.redirect request "/settings" 1271 | _ -> 1272 redirect_with_flash request Routes.settings 1273 Present.form_invalid) 1274 | _ -> 1275 redirect_with_flash request Routes.settings Present.form_invalid) 1276 1277 let routes t = 1278 [ 1279 Dream_html.get Routes.settings (fun request -> 1280 authenticated t request (fun trainee -> show t trainee request)); 1281 Dream_html.post Routes.settings_theme (fun request -> 1282 authenticated t request (fun trainee -> update trainee request)); 1283 ] 1284 end 1285 1286 module Import = struct 1287 let max_source_bytes = 10 * 1024 * 1024 1288 1289 (* Phrase an adapter warning for the view. The controller owns the wording, 1290 so no warning variant crosses into the presenter. *) 1291 let warning_view (w : Workout_import.warning) : View_model.Import_warning.t 1292 = 1293 let detail = 1294 match w.Workout_import.kind with 1295 | Workout_import.Warmup_dropped -> "warmup set dropped" 1296 | Workout_import.Unsupported_row reason -> reason 1297 in 1298 { row = w.Workout_import.row; detail } 1299 1300 let set_type_string : Workout_import.source_set_type -> string = function 1301 | Workout_import.Normal -> "normal" 1302 | Workout_import.Failure -> "failure" 1303 | Workout_import.Dropset -> "dropset" 1304 1305 (* Phrase one promotion blocker for the view. *) 1306 let blocker_string : Workout_import.blocker -> string = function 1307 | Workout_import.No_sets -> "The workout has no promotable sets." 1308 | Workout_import.Dropset_present rows -> 1309 Printf.sprintf "Drop sets cannot be promoted (rows %s)." 1310 (String.concat ", " (List.map string_of_int rows)) 1311 | Workout_import.Unmapped_exercise name -> 1312 Printf.sprintf "The exercise %S is not mapped to a catalog entry." 1313 name 1314 | Workout_import.Normal_sets_unconfirmed -> 1315 "The normal sets need a confirmation acknowledgement." 1316 1317 let set_view workout (s : Workout_import.source_set) : 1318 View_model.Import_set.t = 1319 let mapping = 1320 Workout_import.workout_mapping workout 1321 ~source_name:s.Workout_import.exercise_name 1322 |> Option.map Exercise.name 1323 in 1324 { 1325 row = s.Workout_import.row; 1326 exercise_name = s.Workout_import.exercise_name; 1327 set_type = set_type_string s.Workout_import.set_type; 1328 weight = Printf.sprintf "%g" s.Workout_import.weight_kg; 1329 reps = string_of_int s.Workout_import.reps; 1330 mapping; 1331 } 1332 1333 let workout_view (workout : Workout_import.workout) : 1334 View_model.Import_workout.t = 1335 { 1336 id = 1337 Workout_import.workout_id_to_string 1338 (Workout_import.workout_identity workout); 1339 title = Workout_import.workout_title workout; 1340 sets = List.map (set_view workout) (Workout_import.workout_sets workout); 1341 blockers = List.map blocker_string (Workout_import.blockers workout); 1342 acknowledgement = Workout_import.workout_acknowledgement workout; 1343 revision = Workout_import.workout_revision workout; 1344 } 1345 1346 let review_view (batch : Workout_import.batch) : View_model.Import_review.t 1347 = 1348 { 1349 batch_id = 1350 Workout_import.batch_id_to_string 1351 (Workout_import.batch_identity batch); 1352 warnings = List.map warning_view (Workout_import.batch_warnings batch); 1353 workouts = List.map workout_view (Workout_import.batch_workouts batch); 1354 } 1355 1356 let viewer_of (trainee : Trainee.t) = 1357 { 1358 View_model.Viewer.username = Trainee.username_to_string trainee.username; 1359 } 1360 1361 (* A distinct batch id even when a duplicate override re-imports the same 1362 source: the fingerprint prefix, the import time in seconds, and a random 1363 suffix keep two imports of one export apart, so an override never 1364 overwrites the original batch. *) 1365 let generate_batch_id ~fingerprint ~imported_at = 1366 let prefix = 1367 String.sub fingerprint 0 (min 8 (String.length fingerprint)) 1368 in 1369 let seconds = Recovery.timestamp_to_unix_seconds imported_at in 1370 let suffix = Dream.to_base64url (Dream.random 6) in 1371 Printf.sprintf "%s-%d-%s" prefix seconds suffix 1372 1373 (* Extract the single CSV file and the offset from a verified multipart 1374 form. Dream verifies the CSRF token, so a bad token never reaches here. *) 1375 let read_upload request = 1376 Dream.multipart ~csrf:true request >|= function 1377 | `Ok fields -> ( 1378 let csv = 1379 match List.assoc_opt "csv" fields with 1380 | Some ((_, content) :: _) -> Some content 1381 | _ -> None 1382 in 1383 let offset = 1384 match List.assoc_opt "utc_offset_seconds" fields with 1385 | Some ((_, raw) :: _) -> int_of_string_opt (String.trim raw) 1386 | _ -> None 1387 in 1388 let allow_duplicate = 1389 match List.assoc_opt "allow_duplicate" fields with 1390 | Some ((_, "true") :: _) -> true 1391 | _ -> false 1392 in 1393 match (csv, offset) with 1394 | Some source, Some offset -> Ok (source, offset, allow_duplicate) 1395 | _ -> Error `Bad_request) 1396 | _ -> Error `Bad_request 1397 1398 let upload t trainee request = 1399 read_upload request >>= function 1400 | Error `Bad_request -> 1401 redirect_with_flash request Routes.profile 1402 "The import upload is missing its file or offset." 1403 | Ok (source, _, _) when String.length source > max_source_bytes -> 1404 redirect_with_flash request Routes.profile 1405 "The import file exceeds the 10 MiB limit." 1406 | Ok (source, utc_offset_seconds, allow_duplicate) -> ( 1407 let fingerprint = Digest.to_hex (Digest.string source) in 1408 let imported_at = t.now () in 1409 let batch_id = 1410 Workout_import.batch_id 1411 (generate_batch_id ~fingerprint ~imported_at) 1412 in 1413 match 1414 Hevy_csv.parse ~batch_id ~fingerprint ~imported_at 1415 ~utc_offset_seconds source 1416 with 1417 | Error e -> 1418 redirect_with_flash request Routes.profile 1419 (Format.asprintf "%a" Hevy_csv.pp_error e) 1420 | Ok batch -> ( 1421 let allow_duplicate = if allow_duplicate then Some () else None in 1422 Service.store_import_batch t.service trainee.Trainee.id 1423 ?allow_duplicate batch 1424 >>= function 1425 | Ok () -> 1426 redirect_with_flash_attr request 1427 (Dream_html.path_attr Dream_html.HTML.href 1428 Routes.import_review 1429 (Workout_import.batch_id_to_string batch_id)) 1430 "Import stored. Review it below." 1431 | Error `Duplicate_source -> 1432 redirect_with_flash request Routes.profile 1433 "This export was already imported. Re-submit with the \ 1434 duplicate override to import it again." 1435 | Error _ -> 1436 redirect_with_flash request Routes.profile 1437 "The import could not be stored.")) 1438 1439 let review_target t trainee id = 1440 Service.find_import_batch t.service trainee (Workout_import.batch_id id) 1441 1442 let review_url id = 1443 Dream_html.path_attr Dream_html.HTML.href Routes.import_review id 1444 1445 let review t trainee request id = 1446 review_target t trainee.Trainee.id id >>= function 1447 | None -> not_found "That import batch no longer exists." 1448 | Some batch -> 1449 html 1450 (Pages.import_review request ~viewer:(viewer_of trainee) 1451 (review_view batch)) 1452 1453 let map t trainee request batch_id workout_id = 1454 Dream.form request >>= function 1455 | `Ok fields -> ( 1456 match 1457 ( List.assoc_opt "source_name" fields, 1458 List.assoc_opt "exercise_id" fields ) 1459 with 1460 | Some source_name, Some exercise_id -> ( 1461 match Exercise.find_id (String.trim exercise_id) with 1462 | None -> 1463 redirect_with_flash_attr request (review_url batch_id) 1464 "That exercise id is not in the catalogue." 1465 | Some exercise -> ( 1466 Service.map_import_exercise t.service trainee.Trainee.id 1467 ~batch:(Workout_import.batch_id batch_id) 1468 ~workout:(Workout_import.workout_id workout_id) 1469 ~source_name exercise 1470 >>= function 1471 | Ok _ -> 1472 redirect_with_flash_attr request (review_url batch_id) 1473 "Exercise mapped." 1474 | Error `Unknown_batch -> 1475 not_found "That import batch no longer exists." 1476 | Error _ -> 1477 redirect_with_flash_attr request (review_url batch_id) 1478 "That mapping could not be applied.")) 1479 | _ -> 1480 redirect_with_flash_attr request (review_url batch_id) 1481 Present.form_invalid) 1482 | _ -> 1483 redirect_with_flash_attr request (review_url batch_id) 1484 Present.form_invalid 1485 1486 let confirm t trainee request batch_id workout_id = 1487 Dream.form request >>= function 1488 | `Ok fields -> ( 1489 match List.assoc_opt "acknowledgement" fields with 1490 | Some acknowledgement -> ( 1491 Service.confirm_import_normal_sets t.service trainee.Trainee.id 1492 ~batch:(Workout_import.batch_id batch_id) 1493 ~workout:(Workout_import.workout_id workout_id) 1494 ~acknowledgement 1495 >>= function 1496 | Ok _ -> 1497 redirect_with_flash_attr request (review_url batch_id) 1498 "Normal sets confirmed." 1499 | Error `Unknown_batch -> 1500 not_found "That import batch no longer exists." 1501 | Error (`Import Workout_import.Empty_acknowledgement) -> 1502 redirect_with_flash_attr request (review_url batch_id) 1503 "Enter an acknowledgement before confirming." 1504 | Error _ -> 1505 redirect_with_flash_attr request (review_url batch_id) 1506 "That confirmation could not be applied.") 1507 | None -> 1508 redirect_with_flash_attr request (review_url batch_id) 1509 Present.form_invalid) 1510 | _ -> 1511 redirect_with_flash_attr request (review_url batch_id) 1512 Present.form_invalid 1513 1514 let promote_workout t trainee request batch_id workout_id = 1515 guard_csrf request >>= function 1516 | Error _ -> 1517 redirect_with_flash_attr request (review_url batch_id) 1518 Present.form_invalid 1519 | Ok () -> ( 1520 Service.promote_import_workout t.service trainee.Trainee.id 1521 ~batch:(Workout_import.batch_id batch_id) 1522 ~workout:(Workout_import.workout_id workout_id) 1523 >>= function 1524 | Ok (Workout_import.Promoted _) -> 1525 redirect_with_flash_attr request (review_url batch_id) 1526 "Workout promoted." 1527 | Ok (Workout_import.Already_promoted _) -> 1528 redirect_with_flash_attr request (review_url batch_id) 1529 "Workout was already promoted." 1530 | Ok (Workout_import.Blocked blockers) -> 1531 redirect_with_flash_attr request (review_url batch_id) 1532 (Printf.sprintf "Workout blocked: %s" 1533 (String.concat " " (List.map blocker_string blockers))) 1534 | Error `Unknown_batch -> 1535 not_found "That import batch no longer exists." 1536 | Error _ -> 1537 redirect_with_flash_attr request (review_url batch_id) 1538 "That promotion could not be applied.") 1539 1540 let promote_batch t trainee request batch_id = 1541 guard_csrf request >>= function 1542 | Error _ -> 1543 redirect_with_flash_attr request (review_url batch_id) 1544 Present.form_invalid 1545 | Ok () -> ( 1546 Service.promote_import_batch t.service trainee.Trainee.id 1547 ~batch:(Workout_import.batch_id batch_id) 1548 >>= function 1549 | Ok result -> 1550 let promoted = List.length result.Workout_import.promoted in 1551 let already = 1552 List.length result.Workout_import.already_promoted 1553 in 1554 let blocked = List.length result.Workout_import.blocked in 1555 redirect_with_flash_attr request (review_url batch_id) 1556 (Printf.sprintf "Promoted %d, already promoted %d, blocked %d." 1557 promoted already blocked) 1558 | Error `Unknown_batch -> 1559 not_found "That import batch no longer exists." 1560 | Error _ -> 1561 redirect_with_flash_attr request (review_url batch_id) 1562 "That promotion could not be applied.") 1563 1564 let routes t = 1565 [ 1566 Dream_html.post Routes.import_upload (fun request -> 1567 authenticated t request (fun trainee -> upload t trainee request)); 1568 Dream_html.get Routes.import_review (fun request id -> 1569 authenticated t request (fun trainee -> review t trainee request id)); 1570 Dream_html.post Routes.import_map (fun request batch_id workout_id -> 1571 authenticated t request (fun trainee -> 1572 map t trainee request batch_id workout_id)); 1573 Dream_html.post Routes.import_confirm 1574 (fun request batch_id workout_id -> 1575 authenticated t request (fun trainee -> 1576 confirm t trainee request batch_id workout_id)); 1577 Dream_html.post Routes.import_promote_workout 1578 (fun request batch_id workout_id -> 1579 authenticated t request (fun trainee -> 1580 promote_workout t trainee request batch_id workout_id)); 1581 Dream_html.post Routes.import_promote_batch (fun request batch_id -> 1582 authenticated t request (fun trainee -> 1583 promote_batch t trainee request batch_id)); 1584 ] 1585 end 1586 1587 module Assets = struct 1588 let stylesheet = 1589 match Stylesheet.read "hito.css" with 1590 | Some stylesheet -> stylesheet 1591 | None -> failwith "Embedded stylesheet hito.css is missing" 1592 1593 let workout_client = 1594 match Workout_client_asset.read "workout_client.js" with 1595 | Some script -> script 1596 | None -> failwith "Embedded workout client is missing" 1597 1598 let routes = 1599 [ 1600 Dream_html.get Routes.stylesheet (fun _ -> 1601 Dream.respond 1602 ~headers:[ ("Content-Type", "text/css; charset=utf-8") ] 1603 stylesheet); 1604 Dream_html.get Routes.workout_client (fun _ -> 1605 Dream.respond 1606 ~headers: 1607 [ ("Content-Type", "application/javascript; charset=utf-8") ] 1608 workout_client); 1609 ] 1610 end 1611 1612 (* A catch-all for any path no route claims. It renders the branded 404 so an 1613 unknown URL keeps the navigation and leaks nothing, rather than the empty 1614 body Dream's router would return. Kept last so it never shadows a real 1615 route. The production [error_handler] covers the rest: [5xx] responses and 1616 uncaught exceptions. *) 1617 let catch_all t = 1618 Dream.any "/**" (fun request -> 1619 current_trainee t request >>= function 1620 | Some trainee -> 1621 let viewer = 1622 { 1623 View_model.Viewer.username = 1624 Trainee.username_to_string trainee.Trainee.username; 1625 } 1626 in 1627 html ~status:`Not_Found 1628 (Pages.error_page ~viewer ~request ~status:404 ()) 1629 | None -> html ~status:`Not_Found (Pages.error_page ~status:404 ())) 1630 1631 let routes t = 1632 Auth.routes t @ Overview.routes t @ Current_workout.routes t 1633 @ Logbook.routes t @ App_feedback.routes t @ Profile.routes t 1634 @ Settings.routes t @ Import.routes t @ Assets.routes 1635 @ [ catch_all t ] 1636 1637 (* A branded error page for every failure Dream routes here: unmatched paths, 1638 [4xx] and [5xx] responses, and uncaught exceptions. The page names only the 1639 status class, never a server string, so nothing internal leaks. The status 1640 of the suggested response is preserved. *) 1641 let error_handler = 1642 Dream.error_template (fun _error _message suggested -> 1643 let status = Dream.status suggested |> Dream.status_to_int in 1644 Dream_html.set_body suggested (Pages.error_page ~status ()); 1645 Lwt.return suggested) 1646 end 1647