1 module Make (R : Repository.S) = struct 2 open Lwt.Infix 3 4 type t = { repo : R.t } 5 6 let make ~repo = { repo } 7 8 (* Error types are part of the flat public interface, so they live at the top 9 level of the functor. The implementation below is grouped into focused 10 use-case modules over the shared [t]; the public names are re-exported at 11 the end, so callers and {!Service.mli} see one flat service. *) 12 13 type register_error = [ `Username of Trainee.username_error | `Username_taken ] 14 15 type change_username_error = 16 [ `Username of Trainee.username_error | `Username_taken | `Unknown ] 17 18 type change_password_error = [ `Incorrect_password | `Unknown ] 19 type error = Unknown_routine | Not_recovered of Recovery.readiness 20 21 let pp_error ppf = function 22 | Unknown_routine -> Format.pp_print_string ppf "no such routine" 23 | Not_recovered readiness -> 24 Format.fprintf ppf "not recovered: %a" Recovery.pp_readiness readiness 25 26 type log_error = No_workout_in_progress | Rejected of Evidence.Workout.error 27 28 let pp_log_error ppf = function 29 | No_workout_in_progress -> 30 Format.pp_print_string ppf "no workout in progress" 31 | Rejected e -> Evidence.Workout.pp_error ppf e 32 33 type edit_error = Unknown_workout | Rejected_edit of Evidence.Workout.error 34 type app_feedback_error = [ `Empty_message | `Unknown_feedback ] 35 36 (* Shared helpers over a routine and a log, used by more than one use case. *) 37 38 let routine t id = 39 match R.find_routine t.repo id with 40 | Some r -> Ok r 41 | None -> Error Unknown_routine 42 43 (* Where the cycle stands. With nothing logged, start at the beginning. *) 44 let next_of routine log = 45 match Evidence.Log.last_prescription log with 46 | Some last -> Prescription.Routine.workout_after routine last 47 | None -> List.hd (Prescription.Routine.workouts routine) 48 49 (* How long HD1 asks you to rest depends on where in the cycle you are, so 50 the recommendation comes from the last workout performed. *) 51 let recommended routine log = 52 match Evidence.Log.last_prescription log with 53 | Some last -> Prescription.Routine.recovery_after routine last 54 | None -> Prescription.Routine.training_interval 55 56 (* --- accounts --- *) 57 module Accounts = struct 58 let register t ~username ~password = 59 let open Lwt_result.Syntax in 60 (* Validate the username, hash the password, then create the account. 61 Username validation short-circuits into [register_error]; the password 62 carries no policy, so hashing always succeeds. *) 63 let* username = 64 Lwt.return 65 (Result.map_error (fun e -> `Username e) (Trainee.username username)) 66 in 67 let credential = Trainee.hash_password password in 68 Lwt_result.map_error 69 (fun `Username_taken -> `Username_taken) 70 (R.create_trainee t.repo ~username ~credential) 71 72 let authenticate t ~username ~password = 73 match Trainee.username username with 74 | Error _ -> Lwt.return None 75 | Ok username -> ( 76 R.find_trainee_by_username t.repo username >|= function 77 | Some trainee 78 when Trainee.verify_password trainee.Trainee.credential password -> 79 Some trainee 80 | _ -> None) 81 82 let find_trainee t id = R.find_trainee t.repo id 83 84 (* Rename the account. Validate the new name, then let the repository check 85 it is free. The trainee's own current name is accepted as a no-op. *) 86 let change_username t id ~username = 87 let open Lwt_result.Syntax in 88 let* username = 89 Lwt.return 90 (Result.map_error (fun e -> `Username e) (Trainee.username username)) 91 in 92 Lwt_result.map_error 93 (fun `Username_taken -> `Username_taken) 94 (R.update_username t.repo id username) 95 96 (* Change the password. The current password must verify first, so a 97 hijacked session cannot silently reset it. Passwords carry no policy, so 98 any new password is accepted once the current one checks out. *) 99 let change_password t id ~current ~next = 100 R.find_trainee t.repo id >>= function 101 | None -> Lwt.return (Error `Unknown) 102 | Some trainee -> 103 if not (Trainee.verify_password trainee.Trainee.credential current) 104 then Lwt.return (Error `Incorrect_password) 105 else 106 R.update_credential t.repo id (Trainee.hash_password next) 107 >|= fun updated -> Option.to_result ~none:`Unknown updated 108 end 109 110 (* --- routines and selection --- *) 111 module Routines = struct 112 let list_routines t = R.list_routines t.repo 113 114 let select_routine t trainee id = 115 match R.find_routine t.repo id with 116 | None -> Lwt.return (Error Unknown_routine) 117 | Some _ -> R.set_active_routine t.repo trainee id >|= fun () -> Ok () 118 119 let active_routine t trainee = 120 R.active_routine t.repo trainee >|= function 121 | None -> None 122 | Some id -> 123 Option.map (fun routine -> (id, routine)) (R.find_routine t.repo id) 124 125 let next_workout t trainee ~routine:id = 126 let open Lwt_result.Syntax in 127 let* r = Lwt.return (routine t id) in 128 let+ log = Lwt_result.ok (R.log t.repo trainee) in 129 next_of r log 130 131 let readiness t trainee ~routine:id ~now = 132 let open Lwt_result.Syntax in 133 let* r = Lwt.return (routine t id) in 134 let+ log = Lwt_result.ok (R.log t.repo trainee) in 135 Evidence.Log.readiness log ~now ~recommended:(recommended r log) 136 end 137 138 (* --- the workout in progress --- *) 139 module Workouts = struct 140 let begin_workout t trainee ~routine:id ~now ?override () = 141 let open Lwt_result.Syntax in 142 let* r = Lwt.return (routine t id) in 143 let* log = Lwt_result.ok (R.log t.repo trainee) in 144 let readiness = 145 Evidence.Log.readiness log ~now ~recommended:(recommended r log) 146 in 147 let clearance = 148 match (Recovery.clear readiness, override) with 149 | Some c, _ -> Some c 150 | None, Some () -> Some (Recovery.override readiness) 151 | None, None -> None 152 in 153 match clearance with 154 | None -> Lwt.return (Error (Not_recovered readiness)) 155 | Some clearance -> 156 let workout = 157 Evidence.Workout.start (next_of r log) ~clearance ~started_at:now 158 in 159 let+ () = 160 Lwt_result.ok (R.set_in_progress t.repo trainee (Some workout)) 161 in 162 workout 163 164 let in_progress t trainee = R.in_progress t.repo trainee 165 166 let log t trainee stimulus = 167 R.in_progress t.repo trainee >>= function 168 | None -> Lwt.return (Error No_workout_in_progress) 169 | Some workout -> ( 170 match Evidence.Workout.add_stimulus workout stimulus with 171 | updated -> 172 R.set_in_progress t.repo trainee (Some updated) >|= fun () -> 173 Ok updated 174 | exception Evidence.Workout.Invalid error -> 175 Lwt.return (Error (Rejected error))) 176 177 let replace_current t trainee ~slot stimulus = 178 R.in_progress t.repo trainee >>= function 179 | None -> Lwt.return (Error No_workout_in_progress) 180 | Some workout -> ( 181 match Evidence.Workout.replace_stimulus workout ~slot stimulus with 182 | updated -> 183 R.set_in_progress t.repo trainee (Some updated) >|= fun () -> 184 Ok updated 185 | exception Evidence.Workout.Invalid error -> 186 Lwt.return (Error (Rejected error))) 187 188 let finish t trainee ~ended_at = 189 R.in_progress t.repo trainee >>= function 190 | None -> Lwt.return None 191 | Some workout -> 192 let finished = Evidence.Workout.finish workout ~ended_at in 193 R.finish_workout t.repo trainee finished >|= fun record -> Some record 194 195 (* Discard the workout in progress. This clears the slot only; it never 196 writes to history, so a cancelled workout leaves no record. The doctrine 197 keeps plan and record distinct — an abandoned session is not evidence. *) 198 let cancel t trainee = 199 R.in_progress t.repo trainee >>= function 200 | None -> Lwt.return false 201 | Some _ -> R.set_in_progress t.repo trainee None >|= fun () -> true 202 end 203 204 (* --- saved records --- *) 205 module Records = struct 206 let find_record t trainee id = R.find t.repo trainee id 207 208 (* Apply every saved-record edit through the same lookup, validation, and 209 replacement path. This keeps add and correction operations consistent. *) 210 let update_record t trainee id ~edit = 211 R.find t.repo trainee id >>= function 212 | None -> Lwt.return (Error Unknown_workout) 213 | Some record -> ( 214 match edit record.Repository.workout with 215 | Error error -> Lwt.return (Error (Rejected_edit error)) 216 | Ok workout -> 217 R.replace t.repo trainee { record with Repository.workout } 218 >|= fun replaced -> 219 if replaced then Ok { record with Repository.workout } 220 else Error Unknown_workout) 221 222 let add_to_record t trainee id stimulus = 223 update_record t trainee id ~edit:(fun workout -> 224 try Ok (Evidence.Workout.add_stimulus workout stimulus) 225 with Evidence.Workout.Invalid error -> Error error) 226 227 let replace_in_record t trainee id ~slot stimulus = 228 update_record t trainee id ~edit:(fun workout -> 229 try Ok (Evidence.Workout.replace_stimulus workout ~slot stimulus) 230 with Evidence.Workout.Invalid error -> Error error) 231 232 let history t trainee = R.history t.repo trainee 233 end 234 235 (* --- what the record means --- *) 236 module Assessment = struct 237 let progress t trainee exercise = 238 R.log t.repo trainee >|= fun log -> 239 match Progression.assess (Evidence.Log.observations log exercise) with 240 | assessment -> Ok assessment 241 | exception Progression.Invalid error -> Error error 242 243 let diagnostics t trainee = 244 R.log t.repo trainee >|= fun log -> Progression.diagnose log 245 end 246 247 (* --- subjective feedback --- *) 248 module Feedback = struct 249 let record t trainee ~reported_at signals = 250 match Evidence.Feedback.make ~reported_at signals with 251 | report -> R.save_feedback t.repo trainee report >|= fun () -> Ok report 252 | exception Evidence.Feedback.Invalid error -> Lwt.return (Error error) 253 254 let list t trainee = R.feedback t.repo trainee 255 end 256 257 (* --- application feedback --- *) 258 module App_feedback = struct 259 let record t trainee ~submitted_at ~message = 260 if String.trim message = "" then Lwt.return (Error `Empty_message) 261 else 262 R.save_app_feedback t.repo trainee ~submitted_at ~message 263 >|= fun report -> Ok report 264 265 let list t trainee = R.app_feedback t.repo ~viewer:trainee 266 let upvote t trainee id = R.upvote_app_feedback t.repo ~voter:trainee id 267 268 let edit t trainee id ~message = 269 if String.trim message = "" then Lwt.return (Error `Empty_message) 270 else 271 R.update_app_feedback t.repo ~author:trainee id ~message >|= function 272 | true -> Ok () 273 | false -> Error `Unknown_feedback 274 275 let remove t trainee id = R.delete_app_feedback t.repo ~author:trainee id 276 end 277 278 (* Re-export the use cases as one flat service, matching Service.mli. *) 279 280 let register = Accounts.register 281 let authenticate = Accounts.authenticate 282 let find_trainee = Accounts.find_trainee 283 let change_username = Accounts.change_username 284 let change_password = Accounts.change_password 285 let list_routines = Routines.list_routines 286 let select_routine = Routines.select_routine 287 let active_routine = Routines.active_routine 288 let next_workout = Routines.next_workout 289 let readiness = Routines.readiness 290 let begin_workout = Workouts.begin_workout 291 let in_progress = Workouts.in_progress 292 let log = Workouts.log 293 let replace_current = Workouts.replace_current 294 let finish = Workouts.finish 295 let cancel = Workouts.cancel 296 let find_record = Records.find_record 297 let add_to_record = Records.add_to_record 298 let replace_in_record = Records.replace_in_record 299 let history = Records.history 300 let progress = Assessment.progress 301 let diagnostics = Assessment.diagnostics 302 let record_feedback = Feedback.record 303 let feedback = Feedback.list 304 let record_app_feedback = App_feedback.record 305 let app_feedback = App_feedback.list 306 let upvote_app_feedback = App_feedback.upvote 307 let edit_app_feedback = App_feedback.edit 308 let remove_app_feedback = App_feedback.remove 309 end 310