open Lwt.Infix open Hito_app module Make (R : Repository.S) (H : Password_hash.S) = struct module Service = Service.Make (R) (H) type t = { service : Service.t; now : unit -> Recovery.timestamp; registration_open : bool; } let default_now () = Recovery.timestamp_of_unix_seconds (int_of_float (Unix.gettimeofday ())) let make ~repo ?(now = default_now) ?(registration_open = false) () = { service = Service.make ~repo; now; registration_open } let flash_key = "hito.flash" let html ?status page = Dream_html.respond ?status page let redirect request path = Dream_html.redirect request path let redirect_to request path = redirect request (Dream_html.path_attr Dream_html.HTML.href path) let redirect_with_flash request path message = Dream.set_session_field request flash_key message >>= fun () -> redirect_to request path let redirect_with_flash_attr request path message = Dream.set_session_field request flash_key message >>= fun () -> redirect request path let redirect_with_flash_raw request path message = Dream.set_session_field request flash_key message >>= fun () -> Dream.redirect request path let not_found detail = html (Pages.problem ~title:"Not found" ~detail) ~status:`Not_Found let bad_request detail = html (Pages.problem ~title:"Invalid request" ~detail) ~status:`Bad_Request (* --- presentation of errors --- Every domain and service error becomes a user-facing sentence here, so a handler renders a message rather than deciding its wording. One module owns the phrasing, and adding an error variant surfaces as a missing case. *) module Present = struct let form_invalid = "The submitted form is not valid." let registration : Service.register_error -> string = function | `Username e -> Format.asprintf "%a" Trainee.pp_username_error e | `Username_taken -> "That username is already registered." let sign_in_failed = "That username and password do not match." let routine = Format.asprintf "%a" Service.pp_error let log_error : Service.log_error -> string = function | Service.No_workout_in_progress -> "No workout is in progress." | Service.Rejected error -> Format.asprintf "%a" Evidence.Workout.pp_error error let edit_error : Service.edit_error -> string = function | Service.Unknown_workout -> "That saved workout no longer exists." | Service.Rejected_edit error -> Format.asprintf "%a" Evidence.Workout.pp_error error let unknown_routine = "That routine is not in the catalogue." let unknown_record = "That saved workout no longer exists." let no_workout = "No workout is in progress." let slot_not_awaiting = "That slot is not awaiting a record." let change_username : Service.change_username_error -> string = function | `Username e -> Format.asprintf "%a" Trainee.pp_username_error e | `Username_taken -> "That username is already registered." | `Unknown -> "That account no longer exists." let change_password : Service.change_password_error -> string = function | `Incorrect_password -> "The current password is not correct." | `Unknown -> "That account no longer exists." let app_feedback_empty = "Enter feedback before submitting." let username_changed = "Username changed." let password_changed = "Password changed." end (* --- sessions and authentication --- *) let session_key = "trainee" let current_trainee t request = match Dream.session_field request session_key with | None -> Lwt.return None | Some id -> Service.find_trainee t.service (Trainee.id id) (* Resolve the authenticated trainee, or send an unauthenticated request to the sign-in page. [handler] receives the trainee. The request and any path captures stay in the caller's scope, so this one combinator serves every route regardless of how many captures Dream passes. *) let authenticated t request handler = current_trainee t request >>= function | Some trainee -> ( handler trainee >>= fun response -> match Dream.method_ request with | `GET -> Dream.drop_session_field request flash_key >|= fun () -> response | _ -> Lwt.return response) | None -> redirect_to request Routes.login let decode_form decoder request = Dream_html.form decoder ~csrf:true request >|= function | `Ok value -> Ok value | `Invalid errors -> Error (`Invalid errors) | _ -> Error `Bad_request (* Plain (non-dream-html) form read with CSRF, for auth forms. *) let read_credentials request = Dream.form request >|= function | `Ok fields -> ( let get k = List.assoc_opt k fields in match (get "username", get "password") with | Some username, Some password -> Ok (username, password) | _ -> Error `Bad_request) | _ -> Error `Bad_request (* A CSRF guard for state-changing POSTs whose body carries no fields other than the token. [Dream.form] verifies the token and returns [`Ok] only when it is valid, so this rejects a forged or missing token. *) let guard_csrf request = Dream.form request >|= function `Ok _ -> Ok () | _ -> Error `Bad_request module Auth = struct let login_page t request = current_trainee t request >>= function | Some _ -> redirect_to request Routes.home | None -> html (Pages.login request ~registration_open:t.registration_open ()) let register_page t request = current_trainee t request >>= function | Some _ -> redirect_to request Routes.home | None -> html (Pages.register request ()) let establish request (trainee : Trainee.t) = Dream.set_session_field request session_key (Trainee.id_to_string trainee.id) >>= fun () -> redirect_to request Routes.home let register t request = read_credentials request >>= function | Error _ -> html ~status:`Bad_Request (Pages.register request ~error:Present.form_invalid ()) | Ok (username, password) -> ( Service.register t.service ~username ~password >>= function | Ok trainee -> establish request trainee | Error err -> html ~status:`Bad_Request (Pages.register request ~error:(Present.registration err) ())) let login t request = read_credentials request >>= function | Error _ -> html ~status:`Bad_Request (Pages.login request ~error:Present.form_invalid ()) | Ok (username, password) -> ( Service.authenticate t.service ~username ~password >>= function | Some trainee -> establish request trainee | None -> html ~status:`Unauthorized (Pages.login request ~error:Present.sign_in_failed ())) let logout _t request = guard_csrf request >>= function | Error _ -> bad_request Present.form_invalid | Ok () -> Dream.invalidate_session request >>= fun () -> redirect_to request Routes.login let routes t = (* Public sign-up is disabled by default. The [/register] routes appear only when [registration_open] is set. Everything else is unconditional. *) let register_routes = if t.registration_open then [ Dream_html.get Routes.register (register_page t); Dream_html.post Routes.register (register t); ] else [] in [ Dream_html.get Routes.login (login_page t); Dream_html.post Routes.login (login t); Dream_html.post Routes.logout (logout t); ] @ register_routes end (* --- helpers over the service --- *) let record_target t trainee id = Service.find_record t.service trainee (Repository.workout_id id) >|= Option.map (fun record -> (record.Repository.id, record.Repository.workout)) let outstanding workout slot = List.assoc_opt slot (Evidence.Workout.outstanding workout) (* The prescription at any valid slot, filled or not — the edit handlers correct filled slots, which [outstanding] does not list. *) let prescription_at workout slot = List.nth_opt (Prescription.Workout.stimuli (Evidence.Workout.prescription workout)) slot (* The slot a workout view should open on: the first slot still awaiting a record, or the first slot when every slot is filled. A caller clamps a requested slot against the prescription. This supplies the default. *) let default_slot workout = match Evidence.Workout.outstanding workout with | (slot, _) :: _ -> slot | [] -> 0 (* The slot a workout view should open on. An explicit [?slot=] query wins when it names a real slot. Otherwise the view defaults to the first incomplete slot. A [?slot=] out of range, or absent, falls back to the default, so a bookmarked or hand-edited URL never renders an empty view. *) let active_slot request workout = let slot_count = List.length (Prescription.Workout.stimuli (Evidence.Workout.prescription workout)) in match Dream.query request "slot" with | Some raw -> ( match int_of_string_opt raw with | Some slot when slot >= 0 && slot < slot_count -> slot | _ -> default_slot workout) | None -> default_slot workout (* Map an [Evidence.Workout.t] into the view-model DTO the presenter renders, so no Evidence or Prescription type crosses the boundary into Pages. The same mapping serves the live workout and a saved-record view. The caller supplies [record_id]/[editing]/[errors] separately. *) (* The ending code a single-choice form uses, taken from an effort's outcome. The form offers one ending, so the first extension stands for it. *) let extension_code_of_effort effort = match Evidence.Stimulus.Effort.outcome effort with | Evidence.Stimulus.Positive_failure -> "" | Evidence.Stimulus.Beyond_failure (first, _) -> ( match first with | Evidence.Stimulus.Forced_reps -> "forced" | Evidence.Stimulus.Negatives -> "negatives" | Evidence.Stimulus.Rest_pause -> "rest-pause" | Evidence.Stimulus.Static_hold -> "static") (* One line describing a recorded stimulus: the efforts joined by "into", then any extensions appended. *) let describe_stimulus stimulus = let effort effort = Format.asprintf "%s %g kg x %d" (Exercise.name (Evidence.Stimulus.Effort.exercise effort)) (Evidence.Stimulus.Effort.load effort) (Evidence.Stimulus.Effort.reps effort) in let body = String.concat " into " (List.map effort (Evidence.Stimulus.efforts stimulus)) in match Evidence.Stimulus.extensions stimulus with | [] -> body | extensions -> body ^ ", " ^ String.concat " then " (List.map (Format.asprintf "%a" Evidence.Stimulus.pp_extension) extensions) let workout_view ~active_slot workout : View_model.Workout.t = let prescription = Evidence.Workout.prescription workout in let prescribed_slots = Prescription.Workout.stimuli prescription in (* One entry per filled slot, the first fill in performance order — the fill [replace_stimulus] keeps in place when a correction lands. *) let filled = List.fold_left (fun acc (slot, stimulus) -> if List.mem_assoc slot acc then acc else acc @ [ (slot, stimulus) ]) [] (Evidence.Workout.performed workout) in let load_string load = Printf.sprintf "%g" load in let reps_string reps = string_of_int reps in let label p = match Prescription.Stimulus.delivery p with | Prescription.Stimulus.Single e -> Exercise.name e | Prescription.Stimulus.Pre_exhaust { isolation; compound } -> Printf.sprintf "%s + %s" (Exercise.name isolation) (Exercise.name compound) in let slot_view index p : View_model.Workout.slot = let recorded = List.assoc_opt index filled in let efforts = Option.map Evidence.Stimulus.efforts recorded in let nth n = Option.bind efforts (fun es -> List.nth_opt es n) in let load_of n = Option.map (fun e -> load_string (Evidence.Stimulus.Effort.load e)) (nth n) in let reps_of n = Option.map (fun e -> reps_string (Evidence.Stimulus.Effort.reps e)) (nth n) in let movements : View_model.Workout.movement list = match Prescription.Stimulus.delivery p with | Prescription.Stimulus.Single exercise -> [ { name = Exercise.name exercise; load_field = "load"; reps_field = "reps"; reps_label = "Reps to failure"; load_value = load_of 0; reps_value = reps_of 0; }; ] | Prescription.Stimulus.Pre_exhaust { isolation; compound } -> [ { name = Exercise.name isolation; load_field = "iso_load"; reps_field = "iso_reps"; reps_label = "Reps"; load_value = load_of 0; reps_value = reps_of 0; }; { name = Exercise.name compound; load_field = "comp_load"; reps_field = "comp_reps"; reps_label = "Reps"; load_value = load_of 1; reps_value = reps_of 1; }; ] in let selected_extension = match recorded with | None -> "" | Some s -> ( (* The ending lives on the last effort (the compound of a pair). *) match List.rev (Evidence.Stimulus.efforts s) with | last :: _ -> extension_code_of_effort last | [] -> "") in { index; label = label p; movements; recorded_summary = Option.map describe_stimulus recorded; selected_extension; } in let overridden = match Recovery.basis (Evidence.Workout.clearance workout) with | Recovery.Overridden _ -> true | Recovery.Recovered -> false in { name = Prescription.Workout.name prescription; slots = List.mapi slot_view prescribed_slots; active_slot; started_at_unix = Recovery.timestamp_to_unix_seconds (Evidence.Workout.started_at workout); overridden; all_recorded = Evidence.Workout.outstanding workout = []; } let save_current t trainee stimulus = Service.log t.service trainee stimulus >|= function | Ok _ -> Ok () | Error e -> Error (Present.log_error e) let replace_current t trainee ~slot stimulus = Service.replace_current t.service trainee ~slot stimulus >|= function | Ok _ -> Ok () | Error e -> Error (Present.log_error e) let save_record t trainee id stimulus = Service.add_to_record t.service trainee id stimulus >|= function | Ok _ -> Ok () | Error e -> Error (Present.edit_error e) let replace_record t trainee id ~slot stimulus = Service.replace_in_record t.service trainee id ~slot stimulus >|= function | Ok _ -> Ok () | Error e -> Error (Present.edit_error e) module Overview = struct (* Map service entities into the view-model DTOs the presenter renders, so no Prescription or Recovery type crosses the boundary into Pages. These replicate the phrasing the shared presenter formatters use. *) let routine_choice_view ((rid, r) : Repository.routine_id * Prescription.Routine.t) : View_model.Routine_choice.t = { id = (rid :> string); name = Prescription.Routine.name r; workout_count = List.length (Prescription.Routine.workouts r); } let exercise_string prescription = match Prescription.Stimulus.delivery prescription with | Prescription.Stimulus.Single exercise -> Exercise.name exercise | Prescription.Stimulus.Pre_exhaust { isolation; compound } -> Printf.sprintf "%s into %s, no pause" (Exercise.name isolation) (Exercise.name compound) let reps_string prescription = let min_reps, max_reps = Prescription.Rep_range.bounds (Prescription.Stimulus.rep_range prescription) in Printf.sprintf "%d-%d" min_reps max_reps let routine_view r : View_model.Routine.t = { name = Prescription.Routine.name r; workouts = List.map (fun w : View_model.Routine.workout -> { name = Prescription.Workout.name w; exercises = List.map (fun s : View_model.Routine.exercise -> { name = exercise_string s; reps = reps_string s }) (Prescription.Workout.stimuli w); }) (Prescription.Routine.workouts r); } let duration_hours duration = let hours = float_of_int (Recovery.duration_to_seconds duration) /. 3600. in if Float.equal hours (Float.round hours) then Printf.sprintf "%.0fh" hours else Printf.sprintf "%.1fh" hours let home_view ~(routine : Repository.routine_id) ~routine_name ~next ~readiness : View_model.Home.t = { routine_id = (routine :> string); routine_name; next_workout = Prescription.Workout.name next; gate = (match readiness with | Recovery.Ready -> View_model.Home.Ready | Recovery.Recovering { rested; recommended } -> View_model.Home.Recovering { status = Printf.sprintf "Recovery: %s of %s." (duration_hours rested) (duration_hours recommended); }); } let page t trainee request = let viewer = { View_model.Viewer.username = Trainee.username_to_string trainee.Trainee.username; } in Service.in_progress t.service trainee.Trainee.id >>= function | Some workout -> let workout_name = Prescription.Workout.name (Evidence.Workout.prescription workout) in Lwt.return (Pages.workout_in_progress request ~viewer ~workout_name) | None -> ( Service.active_routine t.service trainee.Trainee.id >>= function | None -> Lwt.return (Pages.choose_routine request ~logging:false ~viewer ~routines: (List.map routine_choice_view (Service.list_routines t.service))) | Some (routine, selected) -> ( Service.next_workout t.service trainee.Trainee.id ~routine >>= fun next -> Service.readiness t.service trainee.Trainee.id ~routine ~now:(t.now ()) >|= fun readiness -> match (next, readiness) with | Ok next, Ok readiness -> Pages.home request ~viewer ~home: (home_view ~routine ~routine_name:(Prescription.Routine.name selected) ~next ~readiness) | Error error, _ | _, Error error -> Pages.problem ~title:"Routine unavailable" ~detail:(Present.routine error))) let home t trainee request = page t trainee request >>= html let routines t trainee request = let viewer = { View_model.Viewer.username = Trainee.username_to_string trainee.Trainee.username; } in Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> html (Pages.choose_routine request ~logging:(Option.is_some in_progress) ~viewer ~routines: (List.map routine_choice_view (Service.list_routines t.service))) let select_routine t trainee request id = guard_csrf request >>= function | Error _ -> redirect_with_flash request Routes.home Present.form_invalid | Ok () -> ( Service.select_routine t.service trainee.Trainee.id (Repository.routine_id id) >>= function | Ok () -> redirect_with_flash request Routes.home "Routine selected." | Error _ -> not_found Present.unknown_routine) let routine t trainee request = let viewer = { View_model.Viewer.username = Trainee.username_to_string trainee.Trainee.username; } in Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> Service.active_routine t.service trainee.Trainee.id >>= function | Some (_, routine) -> html (Pages.routine request ~logging:(Option.is_some in_progress) ~viewer (routine_view routine)) | None -> redirect_to request Routes.routines let routes t = [ Dream_html.get Routes.home (fun request -> authenticated t request (fun trainee -> home t trainee request)); Dream_html.get Routes.routines (fun request -> authenticated t request (fun trainee -> routines t trainee request)); Dream_html.post Routes.select_routine (fun request id -> authenticated t request (fun trainee -> select_routine t trainee request id)); Dream_html.get Routes.routine (fun request -> authenticated t request (fun trainee -> routine t trainee request)); ] end module Current_workout = struct let begin_workout t trainee request = decode_form Decode.override request >>= function | Error _ -> redirect_with_flash request Routes.home Present.form_invalid | Ok override -> ( Service.active_routine t.service trainee.Trainee.id >>= function | None -> redirect_to request Routes.routines | Some (routine, _) -> ( let override = if override then Some () else None in Service.begin_workout t.service trainee.Trainee.id ~routine ~now:(t.now ()) ?override () >>= function | Ok _ -> redirect_with_flash request Routes.workout "Workout started." | Error (Service.Not_recovered _) -> redirect_with_flash request Routes.home "The workout needs an explicit recovery override." | Error Service.Unknown_routine -> not_found Present.unknown_routine)) let show t trainee request = let viewer = { View_model.Viewer.username = Trainee.username_to_string trainee.Trainee.username; } in Service.in_progress t.service trainee.Trainee.id >>= function | Some workout -> let active_slot = active_slot request workout in html (Pages.workout request ~viewer ~record_id:None ~active_slot (workout_view ~active_slot workout)) | None -> redirect_to request Routes.home let log t trainee request slot = Service.in_progress t.service trainee.Trainee.id >>= function | None -> not_found Present.no_workout | Some workout -> ( match outstanding workout slot with | None -> not_found Present.slot_not_awaiting | Some prescription -> ( decode_form (Decode.stimulus prescription) request >>= function | Error (`Invalid errors) -> redirect_with_flash request Routes.workout (Decode.errors_to_text errors) | Error `Bad_request -> redirect_with_flash request Routes.workout Present.form_invalid | Ok stimulus -> ( save_current t trainee.Trainee.id stimulus >>= function | Ok () -> redirect_with_flash request Routes.workout "Record saved." | Error detail -> redirect_with_flash request Routes.workout detail))) (* Correct a recorded slot of the workout in progress. The slot may be filled, so its prescription comes from the workout, not [outstanding]. [replace_current] targets the slot and never adds volume. *) let edit t trainee request slot = Service.in_progress t.service trainee.Trainee.id >>= function | None -> not_found Present.no_workout | Some workout -> ( match prescription_at workout slot with | None -> not_found Present.slot_not_awaiting | Some prescription -> ( decode_form (Decode.stimulus prescription) request >>= function | Error (`Invalid errors) -> redirect_with_flash request Routes.workout (Decode.errors_to_text errors) | Error `Bad_request -> redirect_with_flash request Routes.workout Present.form_invalid | Ok stimulus -> ( replace_current t trainee.Trainee.id ~slot stimulus >>= function | Ok () -> redirect_with_flash request Routes.workout "Record saved." | Error detail -> redirect_with_flash request Routes.workout detail))) let finish t trainee request = guard_csrf request >>= function | Error _ -> redirect_with_flash request Routes.home Present.form_invalid | Ok () -> ( Service.finish t.service trainee.Trainee.id ~ended_at:(t.now ()) >>= function | Some _ -> redirect_with_flash_raw request "/logbook?prompt=feedback" "Workout finished." | None -> redirect_with_flash request Routes.home Present.no_workout) (* Cancelling discards the current workout and returns Home. An abandoned session is not evidence, so it leaves no record. A forged or missing CSRF token skips the discard but still leaves the workout view. *) let cancel t trainee request = guard_csrf request >>= function | Error _ -> redirect_with_flash request Routes.home "Workout cancellation was not confirmed." | Ok () -> Service.cancel t.service trainee.Trainee.id >>= fun _ -> redirect_with_flash request Routes.home "Workout cancelled." let routes t = [ Dream_html.get Routes.workout (fun request -> authenticated t request (fun trainee -> show t trainee request)); Dream_html.post Routes.workout (fun request -> authenticated t request (fun trainee -> begin_workout t trainee request)); Dream_html.post Routes.workout_slot (fun request slot -> authenticated t request (fun trainee -> log t trainee request slot)); Dream_html.post Routes.workout_slot_edit (fun request slot -> authenticated t request (fun trainee -> edit t trainee request slot)); Dream_html.post Routes.finish_workout (fun request -> authenticated t request (fun trainee -> finish t trainee request)); Dream_html.post Routes.cancel_workout (fun request -> authenticated t request (fun trainee -> cancel t trainee request)); ] end module Logbook = struct let feedback_session_key = "hito.feedback.flow" let feedback_factors = List.map fst Pages.feedback_factors let valid_choice = function | ("1" | "2" | "3" | "4" | "5") as choice -> Some choice | _ -> None let valid_factor field = List.mem field feedback_factors let encode_feedback_flow (flow : Pages.feedback_flow) = let answers = List.map (fun (field, choice) -> field ^ ":" ^ choice) flow.answers in Printf.sprintf "%d|%s" flow.step (String.concat ";" answers) let decode_feedback_flow raw = match String.split_on_char '|' raw with | [ step; answers ] -> ( match int_of_string_opt step with | None -> None | Some step when step < 0 || step > 5 -> None | Some step -> let answers = answers |> String.split_on_char ';' |> List.filter_map (fun answer -> match String.split_on_char ':' answer with | [ field; choice ] when valid_factor field && Option.is_some (valid_choice choice) -> Some (field, choice) | _ -> None) in Some Pages.{ step; answers }) | _ -> None let feedback_flow request = Dream.session_field request feedback_session_key |> fun raw -> Option.bind raw decode_feedback_flow let initial_feedback_flow = Pages.{ step = 0; answers = [] } let set_feedback_flow request flow = Dream.set_session_field request feedback_session_key (encode_feedback_flow flow) let clear_feedback_flow request = Dream.drop_session_field request feedback_session_key let field name fields = List.assoc_opt name fields let feedback_signals answers flags = let level choice = match int_of_string_opt choice with | Some n -> ( match Evidence.Feedback.level_of_score n with | Some l -> l | None -> Evidence.Feedback.Fair) | None -> Evidence.Feedback.Fair in let leveled field make = List.find_map (fun (answer_field, choice) -> if String.equal field answer_field then Option.map (fun choice -> make (level choice)) (valid_choice choice) else None) answers in let optional_flag name signal = match field name flags with Some "true" -> Some signal | _ -> None in List.filter_map Fun.id [ leveled "sleep" (fun l -> Evidence.Feedback.Sleep l); leveled "appetite" (fun l -> Evidence.Feedback.Appetite l); leveled "readiness" (fun l -> Evidence.Feedback.Readiness l); leveled "motivation" (fun l -> Evidence.Feedback.Motivation l); leveled "difficulty" (fun l -> Evidence.Feedback.Difficulty l); optional_flag "pain" Evidence.Feedback.Pain; optional_flag "injury" Evidence.Feedback.Injury; optional_flag "preparation" Evidence.Feedback.Preparation_insufficient; ] (* Describe one signal for the list, and compute a factor's score for the graph. These read the Evidence.Feedback entity here in the controller, so the presenter receives only strings and scores. *) let describe_signal (signal : Evidence.Feedback.signal) = let level l = let score = Evidence.Feedback.level_to_score l in match l with | Evidence.Feedback.Very_poor -> Printf.sprintf "%d (very poor)" score | Very_good -> Printf.sprintf "%d (very good)" score | _ -> string_of_int score in match signal with | Sleep l -> Printf.sprintf "Sleep %s" (level l) | Appetite l -> Printf.sprintf "Appetite %s" (level l) | Readiness l -> Printf.sprintf "Readiness %s" (level l) | Motivation l -> Printf.sprintf "Motivation %s" (level l) | Difficulty l -> Printf.sprintf "Difficulty %s" (level l) | Pain -> "Pain" | Injury -> "Injury" | Preparation_insufficient -> "Preparation insufficient" let factor_fields = [ "sleep"; "appetite"; "readiness"; "motivation"; "difficulty" ] let factor_score field (report : Evidence.Feedback.t) = let of_signal (signal : Evidence.Feedback.signal) = match (field, signal) with | "sleep", Sleep l | "appetite", Appetite l | "readiness", Readiness l | "motivation", Motivation l | "difficulty", Difficulty l -> Some (Evidence.Feedback.level_to_score l) | _ -> None in List.find_map of_signal (Evidence.Feedback.signals report) let entry_view (record : Repository.record) : View_model.Logbook_entry.t = let workout = record.Repository.workout in { id = (record.Repository.id :> string); workout_name = Prescription.Workout.name (Evidence.Workout.prescription workout); stimuli_count = List.length (Evidence.Workout.stimuli workout); complete = (match Evidence.Workout.completeness workout with | Evidence.Workout.Complete -> true | Incomplete -> false); } let feedback_view (report : Evidence.Feedback.t) : View_model.Feedback.report = { at_unix = Recovery.timestamp_to_unix_seconds (Evidence.Feedback.reported_at report); signals = List.map describe_signal (Evidence.Feedback.signals report); factor_scores = List.map (fun f -> (f, factor_score f report)) factor_fields; } let index t trainee request = let viewer = { View_model.Viewer.username = Trainee.username_to_string trainee.Trainee.username; } in Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> Service.history t.service trainee.Trainee.id >>= fun records -> Service.feedback t.service trainee.Trainee.id >>= fun feedback -> let feedback = List.map feedback_view feedback in let records = List.map entry_view records in let saved_flow = feedback_flow request in let feedback_open = match (Dream.query request "feedback", Dream.query request "prompt") with | Some "start", _ | _, Some "feedback" -> true | _ -> Option.is_some saved_flow in html (Pages.logbook request ~logging:(Option.is_some in_progress) ~viewer ~feedback ~suggest_feedback: (match Dream.query request "prompt" with | Some "feedback" -> true | _ -> false) ~feedback_flow: (Option.value saved_flow ~default:initial_feedback_flow) ~feedback_open records) let finish_feedback t trainee request flow flags = let signals = feedback_signals flow.Pages.answers flags in Service.record_feedback t.service trainee.Trainee.id ~reported_at:(t.now ()) signals >>= function | Ok _ -> clear_feedback_flow request >>= fun () -> redirect_with_flash request Routes.logbook "Feedback saved." | Error _ -> clear_feedback_flow request >>= fun () -> redirect_with_flash request Routes.logbook Present.form_invalid (* Advance one factor. The answer map stays in the session until the final optional-observations step, so refreshes never lose earlier choices. *) let record_feedback t trainee request = Dream.form request >>= function | `Ok fields -> ( let flow = Option.value (feedback_flow request) ~default:initial_feedback_flow in match field "step" fields |> fun raw -> (Option.bind raw int_of_string_opt, flow.step) with | Some step, expected when step = expected -> let action = match field "action" fields with | Some ("next" | "Next") -> Some "next" | Some ("back" | "Back") -> Some "back" | Some ("skip" | "Skip this factor" | "Skip this step") -> Some "skip" | Some ("save" | "Record feedback") -> Some "save" | _ -> None in (* Back steps to the previous factor and keeps every answer, so a trainee can revise an earlier report without losing the rest. *) if action = Some "back" then if step = 0 then redirect_to request Routes.logbook else let previous = Pages.{ flow with step = step - 1 } in set_feedback_flow request previous >>= fun () -> redirect_to request Routes.logbook else if step = 5 then if action = Some "skip" then finish_feedback t trainee request flow [] else if action = Some "save" then finish_feedback t trainee request flow fields else redirect_with_flash request Routes.logbook Present.form_invalid else let factor = List.nth feedback_factors step in let answers = match ( action, field "choice" fields |> fun raw -> Option.bind raw valid_choice ) with | Some "next", Some choice -> (factor, choice) :: flow.answers | Some "skip", _ -> flow.answers | _ -> flow.answers in if action <> Some "next" && action <> Some "skip" then redirect_with_flash request Routes.logbook Present.form_invalid else let next = Pages.{ step = step + 1; answers } in set_feedback_flow request next >>= fun () -> redirect_to request Routes.logbook | _ -> redirect_with_flash request Routes.logbook Present.form_invalid ) | _ -> redirect_with_flash request Routes.logbook Present.form_invalid let cancel_feedback _t _trainee request = guard_csrf request >>= function | Error _ -> redirect_with_flash request Routes.logbook Present.form_invalid | Ok () -> clear_feedback_flow request >>= fun () -> redirect_with_flash request Routes.logbook "Feedback skipped." let show t trainee request id = let viewer = { View_model.Viewer.username = Trainee.username_to_string trainee.Trainee.username; } in Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> record_target t trainee.Trainee.id id >>= function | None -> not_found Present.unknown_record | Some (_, workout) -> let active_slot = active_slot request workout in html (Pages.workout request ~viewer ~logging:(Option.is_some in_progress) ~record_id:(Some id) ~active_slot (workout_view ~active_slot workout)) let log t trainee request id slot = record_target t trainee.Trainee.id id >>= function | None -> not_found Present.unknown_record | Some (record_id, workout) -> ( match outstanding workout slot with | None -> not_found Present.slot_not_awaiting | Some prescription -> ( decode_form (Decode.stimulus prescription) request >>= function | Error (`Invalid errors) -> redirect_with_flash_attr request (Dream_html.path_attr Dream_html.HTML.href Routes.record id) (Decode.errors_to_text errors) | Error `Bad_request -> redirect_with_flash_attr request (Dream_html.path_attr Dream_html.HTML.href Routes.record id) Present.form_invalid | Ok stimulus -> ( save_record t trainee.Trainee.id record_id stimulus >>= function | Ok () -> redirect_with_flash_attr request (Dream_html.path_attr Dream_html.HTML.href Routes.record id) "Record saved." | Error detail -> redirect_with_flash_attr request (Dream_html.path_attr Dream_html.HTML.href Routes.record id) detail))) (* Correct a recorded slot of a saved workout. [replace_record] targets the slot, replacing its record rather than appending volume. *) let edit t trainee request id slot = record_target t trainee.Trainee.id id >>= function | None -> not_found Present.unknown_record | Some (record_id, workout) -> ( match prescription_at workout slot with | None -> not_found Present.slot_not_awaiting | Some prescription -> ( decode_form (Decode.stimulus prescription) request >>= function | Error (`Invalid errors) -> redirect_with_flash_attr request (Dream_html.path_attr Dream_html.HTML.href Routes.record id) (Decode.errors_to_text errors) | Error `Bad_request -> redirect_with_flash_attr request (Dream_html.path_attr Dream_html.HTML.href Routes.record id) Present.form_invalid | Ok stimulus -> ( replace_record t trainee.Trainee.id record_id ~slot stimulus >>= function | Ok () -> redirect_with_flash_attr request (Dream_html.path_attr Dream_html.HTML.href Routes.record id) "Record saved." | Error detail -> redirect_with_flash_attr request (Dream_html.path_attr Dream_html.HTML.href Routes.record id) detail))) let routes t = [ Dream_html.get Routes.logbook (fun request -> authenticated t request (fun trainee -> index t trainee request)); Dream_html.post Routes.feedback (fun request -> authenticated t request (fun trainee -> record_feedback t trainee request)); Dream_html.post Routes.cancel_feedback (fun request -> authenticated t request (fun trainee -> cancel_feedback t trainee request)); Dream_html.get Routes.record (fun request id -> authenticated t request (fun trainee -> show t trainee request id)); Dream_html.post Routes.record_slot (fun request id slot -> authenticated t request (fun trainee -> log t trainee request id slot)); Dream_html.post Routes.record_slot_edit (fun request id slot -> authenticated t request (fun trainee -> edit t trainee request id slot)); ] end module App_feedback = struct let tab request = match Dream.query request "tab" with | Some "submitted" -> `Submitted | _ -> `Write let time_to_string timestamp = let tm = Unix.gmtime (float_of_int (Recovery.timestamp_to_unix_seconds timestamp)) in Printf.sprintf "%04d-%02d-%02d %02d:%02d" (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min (* Map a repository record into the view model the presenter renders, so no entity or record crosses the boundary into Pages. *) let view_of (report : Repository.app_feedback) : View_model.App_feedback.t = { id = Repository.app_feedback_id_to_string report.Repository.feedback_id; author = report.Repository.author; contributions = report.Repository.contributions; submitted_at = time_to_string report.Repository.submitted_at; message = report.Repository.message; upvotes = report.Repository.upvotes; viewer_upvoted = report.Repository.viewer_upvoted; viewer_owns = report.Repository.viewer_owns; } let show t trainee request = let viewer = { View_model.Viewer.username = Trainee.username_to_string trainee.Trainee.username; } in Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> Service.app_feedback t.service trainee.Trainee.id >>= fun reports -> html (Pages.app_feedback request ~logging:(Option.is_some in_progress) ~viewer ~tab:(tab request) (List.map view_of reports)) let submit t trainee request = decode_form Decode.app_feedback request >>= function | Error _ -> redirect_with_flash_raw request "/app-feedback?tab=write" Present.form_invalid | Ok message -> ( Service.record_app_feedback t.service trainee.Trainee.id ~submitted_at:(t.now ()) ~message >>= function | Ok _ -> redirect_with_flash_raw request "/app-feedback?tab=submitted" "Feedback submitted." | Error `Empty_message -> redirect_with_flash_raw request "/app-feedback?tab=write" Present.app_feedback_empty | Error `Unknown_feedback -> redirect_with_flash_raw request "/app-feedback?tab=submitted" "That feedback is no longer available.") let upvote t trainee request id = guard_csrf request >>= function | Error _ -> redirect_with_flash_raw request "/app-feedback?tab=submitted" Present.form_invalid | Ok () -> Service.upvote_app_feedback t.service trainee.Trainee.id (Repository.app_feedback_id id) >>= fun added -> redirect_with_flash_raw request "/app-feedback?tab=submitted" (if added then "Vote recorded." else "Vote was not added.") let edit t trainee request id = decode_form Decode.app_feedback request >>= function | Error _ -> redirect_with_flash_raw request "/app-feedback?tab=submitted" Present.form_invalid | Ok message -> ( Service.edit_app_feedback t.service trainee.Trainee.id (Repository.app_feedback_id id) ~message >>= function | Ok () -> redirect_with_flash_raw request "/app-feedback?tab=submitted" "Feedback updated." | Error `Empty_message -> redirect_with_flash_raw request "/app-feedback?tab=submitted" Present.app_feedback_empty | Error `Unknown_feedback -> redirect_with_flash_raw request "/app-feedback?tab=submitted" "That feedback is no longer available.") let remove t trainee request id = guard_csrf request >>= function | Error _ -> redirect_with_flash_raw request "/app-feedback?tab=submitted" Present.form_invalid | Ok () -> Service.remove_app_feedback t.service trainee.Trainee.id (Repository.app_feedback_id id) >>= fun removed -> redirect_with_flash_raw request "/app-feedback?tab=submitted" (if removed then "Feedback removed." else "That feedback is no longer available.") let routes t = [ Dream_html.get Routes.app_feedback (fun request -> authenticated t request (fun trainee -> show t trainee request)); Dream_html.post Routes.submit_app_feedback (fun request -> authenticated t request (fun trainee -> submit t trainee request)); Dream_html.post Routes.upvote_app_feedback (fun request id -> authenticated t request (fun trainee -> upvote t trainee request id)); Dream_html.post Routes.edit_app_feedback (fun request id -> authenticated t request (fun trainee -> edit t trainee request id)); Dream_html.post Routes.remove_app_feedback (fun request id -> authenticated t request (fun trainee -> remove t trainee request id)); ] end module Profile = struct (* The profile page. A [?changed=] query set by a successful redirect shows a confirmation notice, so a refresh never re-posts a change. *) let show t trainee request = let viewer = { View_model.Viewer.username = Trainee.username_to_string trainee.Trainee.username; } in Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> let notice = match Dream.query request "changed" with | Some "username" -> Some Present.username_changed | Some "password" -> Some Present.password_changed | _ -> None in html (Pages.profile request ~logging:(Option.is_some in_progress) ~viewer ?notice ()) let render_error t trainee request ?username_error ?password_error () = let viewer = { View_model.Viewer.username = Trainee.username_to_string trainee.Trainee.username; } in Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> html ~status:`Bad_Request (Pages.profile request ~logging:(Option.is_some in_progress) ~viewer ?username_error ?password_error ()) let change_username t trainee request = decode_form Decode.profile_username request >>= function | Error _ -> bad_request Present.form_invalid | Ok username -> ( Service.change_username t.service trainee.Trainee.id ~username >>= function | Ok _ -> Dream.redirect request "/profile?changed=username" | Error error -> render_error t trainee request ~username_error:(Present.change_username error) ()) let change_password t trainee request = decode_form Decode.profile_password request >>= function | Error _ -> bad_request Present.form_invalid | Ok (current, next) -> ( Service.change_password t.service trainee.Trainee.id ~current ~next >>= function | Ok _ -> Dream.redirect request "/profile?changed=password" | Error error -> render_error t trainee request ~password_error:(Present.change_password error) ()) let routes t = [ Dream_html.get Routes.profile (fun request -> authenticated t request (fun trainee -> show t trainee request)); Dream_html.post Routes.profile_username (fun request -> authenticated t request (fun trainee -> change_username t trainee request)); Dream_html.post Routes.profile_password (fun request -> authenticated t request (fun trainee -> change_password t trainee request)); ] end module Settings = struct let theme_session_key = "hito.theme" let theme request = match Dream.session_field request theme_session_key with | Some "dark" -> "dark" | _ -> "light" let show t trainee request = let viewer = { View_model.Viewer.username = Trainee.username_to_string trainee.Trainee.username; } in Service.in_progress t.service trainee.Trainee.id >>= fun in_progress -> html (Pages.settings request ~logging:(Option.is_some in_progress) ~viewer ~theme:(theme request) ()) let update _trainee request = guard_csrf request >>= function | Error _ -> redirect_with_flash request Routes.settings Present.form_invalid | Ok () -> ( Dream.form request >>= function | `Ok fields -> ( match List.assoc_opt "theme" fields with | Some (("light" | "dark") as value) -> Dream.set_session_field request theme_session_key value >>= fun () -> Dream.redirect request "/settings" | _ -> redirect_with_flash request Routes.settings Present.form_invalid) | _ -> redirect_with_flash request Routes.settings Present.form_invalid) let routes t = [ Dream_html.get Routes.settings (fun request -> authenticated t request (fun trainee -> show t trainee request)); Dream_html.post Routes.settings_theme (fun request -> authenticated t request (fun trainee -> update trainee request)); ] end module Import = struct let max_source_bytes = 10 * 1024 * 1024 (* Phrase an adapter warning for the view. The controller owns the wording, so no warning variant crosses into the presenter. *) let warning_view (w : Workout_import.warning) : View_model.Import_warning.t = let detail = match w.Workout_import.kind with | Workout_import.Warmup_dropped -> "warmup set dropped" | Workout_import.Unsupported_row reason -> reason in { row = w.Workout_import.row; detail } let set_type_string : Workout_import.source_set_type -> string = function | Workout_import.Normal -> "normal" | Workout_import.Failure -> "failure" | Workout_import.Dropset -> "dropset" (* Phrase one promotion blocker for the view. *) let blocker_string : Workout_import.blocker -> string = function | Workout_import.No_sets -> "The workout has no promotable sets." | Workout_import.Dropset_present rows -> Printf.sprintf "Drop sets cannot be promoted (rows %s)." (String.concat ", " (List.map string_of_int rows)) | Workout_import.Unmapped_exercise name -> Printf.sprintf "The exercise %S is not mapped to a catalog entry." name | Workout_import.Normal_sets_unconfirmed -> "The normal sets need a confirmation acknowledgement." let set_view workout (s : Workout_import.source_set) : View_model.Import_set.t = let mapping = Workout_import.workout_mapping workout ~source_name:s.Workout_import.exercise_name |> Option.map Exercise.name in { row = s.Workout_import.row; exercise_name = s.Workout_import.exercise_name; set_type = set_type_string s.Workout_import.set_type; weight = Printf.sprintf "%g" s.Workout_import.weight_kg; reps = string_of_int s.Workout_import.reps; mapping; } let workout_view (workout : Workout_import.workout) : View_model.Import_workout.t = { id = Workout_import.workout_id_to_string (Workout_import.workout_identity workout); title = Workout_import.workout_title workout; sets = List.map (set_view workout) (Workout_import.workout_sets workout); blockers = List.map blocker_string (Workout_import.blockers workout); acknowledgement = Workout_import.workout_acknowledgement workout; revision = Workout_import.workout_revision workout; } let review_view (batch : Workout_import.batch) : View_model.Import_review.t = { batch_id = Workout_import.batch_id_to_string (Workout_import.batch_identity batch); warnings = List.map warning_view (Workout_import.batch_warnings batch); workouts = List.map workout_view (Workout_import.batch_workouts batch); } let viewer_of (trainee : Trainee.t) = { View_model.Viewer.username = Trainee.username_to_string trainee.username; } (* A distinct batch id even when a duplicate override re-imports the same source: the fingerprint prefix, the import time in seconds, and a random suffix keep two imports of one export apart, so an override never overwrites the original batch. *) let generate_batch_id ~fingerprint ~imported_at = let prefix = String.sub fingerprint 0 (min 8 (String.length fingerprint)) in let seconds = Recovery.timestamp_to_unix_seconds imported_at in let suffix = Dream.to_base64url (Dream.random 6) in Printf.sprintf "%s-%d-%s" prefix seconds suffix (* Extract the single CSV file and the offset from a verified multipart form. Dream verifies the CSRF token, so a bad token never reaches here. *) let read_upload request = Dream.multipart ~csrf:true request >|= function | `Ok fields -> ( let csv = match List.assoc_opt "csv" fields with | Some ((_, content) :: _) -> Some content | _ -> None in let offset = match List.assoc_opt "utc_offset_seconds" fields with | Some ((_, raw) :: _) -> int_of_string_opt (String.trim raw) | _ -> None in let allow_duplicate = match List.assoc_opt "allow_duplicate" fields with | Some ((_, "true") :: _) -> true | _ -> false in match (csv, offset) with | Some source, Some offset -> Ok (source, offset, allow_duplicate) | _ -> Error `Bad_request) | _ -> Error `Bad_request let upload t trainee request = read_upload request >>= function | Error `Bad_request -> redirect_with_flash request Routes.profile "The import upload is missing its file or offset." | Ok (source, _, _) when String.length source > max_source_bytes -> redirect_with_flash request Routes.profile "The import file exceeds the 10 MiB limit." | Ok (source, utc_offset_seconds, allow_duplicate) -> ( let fingerprint = Digest.to_hex (Digest.string source) in let imported_at = t.now () in let batch_id = Workout_import.batch_id (generate_batch_id ~fingerprint ~imported_at) in match Hevy_csv.parse ~batch_id ~fingerprint ~imported_at ~utc_offset_seconds source with | Error e -> redirect_with_flash request Routes.profile (Format.asprintf "%a" Hevy_csv.pp_error e) | Ok batch -> ( let allow_duplicate = if allow_duplicate then Some () else None in Service.store_import_batch t.service trainee.Trainee.id ?allow_duplicate batch >>= function | Ok () -> redirect_with_flash_attr request (Dream_html.path_attr Dream_html.HTML.href Routes.import_review (Workout_import.batch_id_to_string batch_id)) "Import stored. Review it below." | Error `Duplicate_source -> redirect_with_flash request Routes.profile "This export was already imported. Re-submit with the \ duplicate override to import it again." | Error _ -> redirect_with_flash request Routes.profile "The import could not be stored.")) let review_target t trainee id = Service.find_import_batch t.service trainee (Workout_import.batch_id id) let review_url id = Dream_html.path_attr Dream_html.HTML.href Routes.import_review id let review t trainee request id = review_target t trainee.Trainee.id id >>= function | None -> not_found "That import batch no longer exists." | Some batch -> html (Pages.import_review request ~viewer:(viewer_of trainee) (review_view batch)) let map t trainee request batch_id workout_id = Dream.form request >>= function | `Ok fields -> ( match ( List.assoc_opt "source_name" fields, List.assoc_opt "exercise_id" fields ) with | Some source_name, Some exercise_id -> ( match Exercise.find_id (String.trim exercise_id) with | None -> redirect_with_flash_attr request (review_url batch_id) "That exercise id is not in the catalogue." | Some exercise -> ( Service.map_import_exercise t.service trainee.Trainee.id ~batch:(Workout_import.batch_id batch_id) ~workout:(Workout_import.workout_id workout_id) ~source_name exercise >>= function | Ok _ -> redirect_with_flash_attr request (review_url batch_id) "Exercise mapped." | Error `Unknown_batch -> not_found "That import batch no longer exists." | Error _ -> redirect_with_flash_attr request (review_url batch_id) "That mapping could not be applied.")) | _ -> redirect_with_flash_attr request (review_url batch_id) Present.form_invalid) | _ -> redirect_with_flash_attr request (review_url batch_id) Present.form_invalid let confirm t trainee request batch_id workout_id = Dream.form request >>= function | `Ok fields -> ( match List.assoc_opt "acknowledgement" fields with | Some acknowledgement -> ( Service.confirm_import_normal_sets t.service trainee.Trainee.id ~batch:(Workout_import.batch_id batch_id) ~workout:(Workout_import.workout_id workout_id) ~acknowledgement >>= function | Ok _ -> redirect_with_flash_attr request (review_url batch_id) "Normal sets confirmed." | Error `Unknown_batch -> not_found "That import batch no longer exists." | Error (`Import Workout_import.Empty_acknowledgement) -> redirect_with_flash_attr request (review_url batch_id) "Enter an acknowledgement before confirming." | Error _ -> redirect_with_flash_attr request (review_url batch_id) "That confirmation could not be applied.") | None -> redirect_with_flash_attr request (review_url batch_id) Present.form_invalid) | _ -> redirect_with_flash_attr request (review_url batch_id) Present.form_invalid let promote_workout t trainee request batch_id workout_id = guard_csrf request >>= function | Error _ -> redirect_with_flash_attr request (review_url batch_id) Present.form_invalid | Ok () -> ( Service.promote_import_workout t.service trainee.Trainee.id ~batch:(Workout_import.batch_id batch_id) ~workout:(Workout_import.workout_id workout_id) >>= function | Ok (Workout_import.Promoted _) -> redirect_with_flash_attr request (review_url batch_id) "Workout promoted." | Ok (Workout_import.Already_promoted _) -> redirect_with_flash_attr request (review_url batch_id) "Workout was already promoted." | Ok (Workout_import.Blocked blockers) -> redirect_with_flash_attr request (review_url batch_id) (Printf.sprintf "Workout blocked: %s" (String.concat " " (List.map blocker_string blockers))) | Error `Unknown_batch -> not_found "That import batch no longer exists." | Error _ -> redirect_with_flash_attr request (review_url batch_id) "That promotion could not be applied.") let promote_batch t trainee request batch_id = guard_csrf request >>= function | Error _ -> redirect_with_flash_attr request (review_url batch_id) Present.form_invalid | Ok () -> ( Service.promote_import_batch t.service trainee.Trainee.id ~batch:(Workout_import.batch_id batch_id) >>= function | Ok result -> let promoted = List.length result.Workout_import.promoted in let already = List.length result.Workout_import.already_promoted in let blocked = List.length result.Workout_import.blocked in redirect_with_flash_attr request (review_url batch_id) (Printf.sprintf "Promoted %d, already promoted %d, blocked %d." promoted already blocked) | Error `Unknown_batch -> not_found "That import batch no longer exists." | Error _ -> redirect_with_flash_attr request (review_url batch_id) "That promotion could not be applied.") let routes t = [ Dream_html.post Routes.import_upload (fun request -> authenticated t request (fun trainee -> upload t trainee request)); Dream_html.get Routes.import_review (fun request id -> authenticated t request (fun trainee -> review t trainee request id)); Dream_html.post Routes.import_map (fun request batch_id workout_id -> authenticated t request (fun trainee -> map t trainee request batch_id workout_id)); Dream_html.post Routes.import_confirm (fun request batch_id workout_id -> authenticated t request (fun trainee -> confirm t trainee request batch_id workout_id)); Dream_html.post Routes.import_promote_workout (fun request batch_id workout_id -> authenticated t request (fun trainee -> promote_workout t trainee request batch_id workout_id)); Dream_html.post Routes.import_promote_batch (fun request batch_id -> authenticated t request (fun trainee -> promote_batch t trainee request batch_id)); ] end module Assets = struct let stylesheet = match Stylesheet.read "hito.css" with | Some stylesheet -> stylesheet | None -> failwith "Embedded stylesheet hito.css is missing" let workout_client = match Workout_client_asset.read "workout_client.js" with | Some script -> script | None -> failwith "Embedded workout client is missing" let routes = [ Dream_html.get Routes.stylesheet (fun _ -> Dream.respond ~headers:[ ("Content-Type", "text/css; charset=utf-8") ] stylesheet); Dream_html.get Routes.workout_client (fun _ -> Dream.respond ~headers: [ ("Content-Type", "application/javascript; charset=utf-8") ] workout_client); ] end (* A catch-all for any path no route claims. It renders the branded 404 so an unknown URL keeps the navigation and leaks nothing, rather than the empty body Dream's router would return. Kept last so it never shadows a real route. The production [error_handler] covers the rest: [5xx] responses and uncaught exceptions. *) let catch_all t = Dream.any "/**" (fun request -> current_trainee t request >>= function | Some trainee -> let viewer = { View_model.Viewer.username = Trainee.username_to_string trainee.Trainee.username; } in html ~status:`Not_Found (Pages.error_page ~viewer ~request ~status:404 ()) | None -> html ~status:`Not_Found (Pages.error_page ~status:404 ())) let routes t = Auth.routes t @ Overview.routes t @ Current_workout.routes t @ Logbook.routes t @ App_feedback.routes t @ Profile.routes t @ Settings.routes t @ Import.routes t @ Assets.routes @ [ catch_all t ] (* A branded error page for every failure Dream routes here: unmatched paths, [4xx] and [5xx] responses, and uncaught exceptions. The page names only the status class, never a server string, so nothing internal leaks. The status of the suggested response is preserved. *) let error_handler = Dream.error_template (fun _error _message suggested -> let status = Dream.status suggested |> Dream.status_to_int in Dream_html.set_body suggested (Pages.error_page ~status ()); Lwt.return suggested) end