1 (** Deterministic native history for the local development account. 2 3 The fixture uses the application repository port, so it exercises the same 4 stored-workout path as a real trainee. It does not belong in production. *) 5 6 open Lwt.Infix 7 8 module Make (R : Repository.S) (H : Password_hash.S) = struct 9 module App_service = Service.Make (R) (H) 10 module Stimulus = Evidence.Stimulus 11 12 let day = 86_400 13 let fixture_days = 90 14 let cycle_days = 7 15 let session_offsets = [ 0; 2; 4 ] 16 17 let load_for exercise = 18 match (Exercise.id exercise :> string) with 19 | "dumbbell-flyes" -> 18. 20 | "incline-press" -> 55. 21 | "laterals" -> 10. 22 | "bent-over-laterals" -> 8. 23 | "lying-french-press" -> 25. 24 | "dips" -> 0. 25 | "pullovers" -> 20. 26 | "close-grip-pulldowns" -> 50. 27 | "bent-over-rows" -> 50. 28 | "shrugs" -> 60. 29 | "hyperextensions" -> 0. 30 | "curls" -> 30. 31 | "preacher-curls" -> 25. 32 | "leg-extensions" -> 40. 33 | "leg-presses" -> 120. 34 | "squats" -> 70. 35 | "leg-curls" -> 35. 36 | "calf-raises" -> 60. 37 | "sit-ups" -> 0. 38 | "straight-arm-pulldowns" -> 35. 39 | "reverse-pec-deck" -> 30. 40 | "pressdowns" -> 30. 41 | "triceps-machine" -> 35. 42 | "deadlifts" -> 90. 43 | _ -> 10. 44 45 let effort ~cycle exercise = 46 let load = load_for exercise in 47 let load = if Float.equal load 0. then 0. else load +. float_of_int cycle in 48 let reps = 6 + (cycle mod 5) in 49 match 50 Stimulus.Effort.make ~exercise ~load ~reps 51 ~outcome:Stimulus.Positive_failure 52 with 53 | Ok effort -> effort 54 | Error error -> 55 invalid_arg 56 (Format.asprintf "invalid development fixture effort: %a" 57 Stimulus.Effort.pp_error error) 58 59 let stimulus ~cycle prescription = 60 let single exercise = 61 Stimulus.make (Stimulus.Single (effort ~cycle exercise)) 62 in 63 match Prescription.Stimulus.delivery prescription with 64 | Prescription.Stimulus.Single exercise -> single exercise 65 | Prescription.Stimulus.Pre_exhaust { isolation; compound } -> 66 Stimulus.make 67 (Stimulus.Pair 68 { 69 first = effort ~cycle isolation; 70 second = effort ~cycle compound; 71 }) 72 73 let complete_workout ~cycle ~started_at prescription = 74 let clearance = Option.get (Recovery.clear Recovery.Ready) in 75 let workout = Evidence.Workout.start prescription ~clearance ~started_at in 76 let workout = 77 Prescription.Workout.stimuli prescription 78 |> List.mapi (fun slot prescription -> (slot, prescription)) 79 |> List.fold_left 80 (fun workout (slot, prescription) -> 81 Evidence.Workout.record_at workout ~slot 82 (stimulus ~cycle prescription)) 83 workout 84 in 85 Evidence.Workout.finish workout 86 ~ended_at: 87 (Recovery.timestamp_to_unix_seconds started_at + (45 * 60) 88 |> Recovery.timestamp_of_unix_seconds) 89 90 let seed_history repo trainee_id ~now routine = 91 let first = 92 Recovery.timestamp_to_unix_seconds now - (fixture_days * day) 93 |> Recovery.timestamp_of_unix_seconds 94 in 95 let sessions = 96 List.init 13 (fun cycle -> 97 List.map 98 (fun offset -> (cycle, (cycle * cycle_days) + offset, offset / 2)) 99 session_offsets) 100 |> List.concat 101 in 102 Lwt_list.iter_s 103 (fun (cycle, offset_days, workout_index) -> 104 let started_at = 105 Recovery.timestamp_to_unix_seconds first + (offset_days * day) 106 |> Recovery.timestamp_of_unix_seconds 107 in 108 let prescription = 109 List.nth (Prescription.Routine.workouts routine) workout_index 110 in 111 let workout = complete_workout ~cycle ~started_at prescription in 112 R.finish_workout repo trainee_id workout >|= ignore) 113 sessions 114 115 let find_or_register service repo = 116 App_service.register service ~username:"test" ~password:"test" >>= function 117 | Ok trainee -> Lwt.return_some trainee 118 | Error App_service.Username_taken -> ( 119 match Trainee.username "test" with 120 | Error _ -> Lwt.return_none 121 | Ok username -> R.find_trainee_by_username repo username) 122 | Error (App_service.Username_invalid error) -> 123 Lwt.fail_with 124 (Format.asprintf "cannot seed development user: %a" 125 Trainee.pp_username_error error) 126 127 let seed repo ~now = 128 let service = App_service.make ~repo in 129 find_or_register service repo >>= function 130 | None -> Lwt.return_unit 131 | Some trainee -> ( 132 let trainee_id = trainee.Trainee.id in 133 R.set_active_routine repo trainee_id (Repository.routine_id "ideal") 134 >>= fun () -> 135 R.history repo trainee_id >>= function 136 | _ :: _ -> Lwt.return_unit 137 | [] -> ( 138 match R.find_routine repo (Repository.routine_id "ideal") with 139 | None -> 140 Lwt.fail_with 141 "cannot seed development user: Ideal Routine missing" 142 | Some routine -> seed_history repo trainee_id ~now routine)) 143 end 144