1 module Form = Dream_html.Form 2 3 type fields = 4 | Single of { 5 load : float; 6 reps : int; 7 extension : Evidence.Stimulus.extension option; 8 } 9 | Pair of { 10 iso_load : float; 11 iso_reps : int; 12 comp_load : float; 13 comp_reps : int; 14 extension : Evidence.Stimulus.extension option; 15 } 16 17 let extension = function 18 | "" -> Ok None 19 | "forced" -> Ok (Some Evidence.Stimulus.Forced_reps) 20 | "negatives" -> Ok (Some Evidence.Stimulus.Negatives) 21 | "rest-pause" -> Ok (Some Evidence.Stimulus.Rest_pause) 22 | "static" -> Ok (Some Evidence.Stimulus.Static_hold) 23 | _ -> Error "error.extension" 24 25 let load value = 26 match Form.float ~min:0. value with 27 | Ok value -> Ok value 28 | Error "error.expected.int" -> Error "error.expected.number" 29 | Error _ -> Error "error.load" 30 31 let reps value = 32 match Form.int value with 33 | Error error -> Error error 34 | Ok value when value > 0 -> Ok value 35 | Ok _ -> Error "error.reps" 36 37 let fields prescription = 38 let open Form in 39 match Prescription.Stimulus.delivery prescription with 40 | Prescription.Stimulus.Single _ -> 41 let+ load = required load "load" 42 and+ reps = required reps "reps" 43 and+ extension = required extension "extension" in 44 Single { load; reps; extension } 45 | Prescription.Stimulus.Pre_exhaust _ -> 46 let+ iso_load = required load "iso_load" 47 and+ iso_reps = required reps "iso_reps" 48 and+ comp_load = required load "comp_load" 49 and+ comp_reps = required reps "comp_reps" 50 and+ extension = required extension "extension" in 51 Pair { iso_load; iso_reps; comp_load; comp_reps; extension } 52 53 let stimulus prescription = 54 let open Form in 55 let* values = fields prescription in 56 match (Prescription.Stimulus.delivery prescription, values) with 57 | Prescription.Stimulus.Single exercise, Single { load; reps; extension } -> 58 let outcome = 59 match extension with 60 | None -> Evidence.Stimulus.Positive_failure 61 | Some extension -> Evidence.Stimulus.Beyond_failure (extension, []) 62 in 63 ok 64 (Evidence.Stimulus.make 65 (Evidence.Stimulus.Single 66 (Evidence.Stimulus.Effort.make ~exercise ~load ~reps ~outcome))) 67 | ( Prescription.Stimulus.Pre_exhaust { isolation; compound }, 68 Pair { iso_load; iso_reps; comp_load; comp_reps; extension } ) -> 69 let second_outcome = 70 match extension with 71 | None -> Evidence.Stimulus.Positive_failure 72 | Some extension -> Evidence.Stimulus.Beyond_failure (extension, []) 73 in 74 let first = 75 Evidence.Stimulus.Effort.make ~exercise:isolation ~load:iso_load 76 ~reps:iso_reps ~outcome:Evidence.Stimulus.Positive_failure 77 in 78 let second = 79 Evidence.Stimulus.Effort.make ~exercise:compound ~load:comp_load 80 ~reps:comp_reps ~outcome:second_outcome 81 in 82 ok (Evidence.Stimulus.make (Evidence.Stimulus.Pair { first; second })) 83 | _ -> assert false 84 85 let override = Form.required Form.bool "override" 86 87 (* --- profile --- *) 88 89 (* The raw username string; the domain normalizes and validates it downstream. *) 90 let profile_username = Form.required Form.string "username" 91 92 (* Current and new password, both required. Passwords carry no policy here; the 93 service verifies the current one before storing the new one. *) 94 let profile_password = 95 let open Form in 96 let+ current = required string "current" and+ next = required string "next" in 97 (current, next) 98 99 (* --- application feedback --- *) 100 101 let app_feedback = Form.required Form.string "message" 102 103 (* --- error presentation --- *) 104 105 let message = function 106 | "error.required" -> "Enter a value." 107 | "error.expected.number" -> "Enter a valid number." 108 | "error.expected.int" -> "Enter a valid whole number." 109 | "error.reps" -> "Enter at least one repetition." 110 | "error.load" -> "Enter a finite, nonnegative load." 111 | "error.extension" -> "Select one of the offered endings." 112 | key -> key 113 114 let errors_to_text errors = 115 errors |> List.map (fun (_, key) -> message key) |> String.concat " " 116