[OCaml] High Intensity Training Online
feat Replace Eliom with Dream
Replace the Eliom and Ocsigen web tier with Dream and dream-html. Use typed resource routes and validated server-rendered forms while keeping the recovery gate and local-only deployment model.
Changed files
- .gitignore
- .kiro/steering/ocaml.md
- ARCHITECTURE.md
- bin/dune
- bin/main.ml
- dune-project
- hito.opam
- lib/app/repository.mli
- lib/app/service.mli
- lib/core/prescription.mli
- lib/web/assets/hito.css
- lib/web/decode.ml
- lib/web/decode.mli
- lib/web/dune
- lib/web/handlers.ml
- lib/web/handlers.mli
- lib/web/pages.ml
- lib/web/pages.mli
- lib/web/routes.ml
- lib/web/services.ml
- lib/web/services.mli
- ocsidb
- test/dune
- test/test_decode.ml
- test/test_evidence.ml
- test/test_hito.ml
- test/test_web.ml
.gitignore
@@ -15,3 +15,9 @@
15
15
.#*
16
16
\#*#
17
17
.DS_Store
18
Added:
19
Added:
# Local web runtime artifacts
20
Added:
local/
21
Added:
local_db/
22
Added:
static/
23
Added:
ocsidb
.kiro/steering/ocaml.md
@@ -32,8 +32,8 @@
32
32
33
33
- `hito.core` — pure domain. No framework, database, or serialization
34
34
dependencies. Ever.
35
Removed:
- `hito.app` — `Repository` port, `Service`, adapters. Knows nothing of Eliom.
36
Removed:
- `hito.web` — Eliom application. The only place Eliom appears.
35
Added:
- `hito.app` — `Repository` port, `Service`, adapters. Knows nothing of Dream.
36
Added:
- `hito.web` — Dream application. The only place Dream and dream-html appear.
37
37
38
38
Rules:
39
39
ARCHITECTURE.md
@@ -67,9 +67,9 @@
67
67
recovery policy: `Service` is the only thing that decides how a
68
68
`Recovery.clearance` is obtained, so a second client cannot quietly adopt
69
69
looser rules than the first.
70
Removed:
- **`hito.web`** — `Routes`, `Pages`, `Services`. The only place Eliom appears.
71
Removed:
Server-rendered: no client-side OCaml, no ppx, no js_of_ocaml. Wall-clock time
72
Removed:
enters here, never in the core.
70
Added:
- **`hito.web`** — `Routes`, `Decode`, `Pages`, `Handlers`. Dream and
71
Added:
dream-html live only here. The server renders HTML and uses no client-side
72
Added:
OCaml or js_of_ocaml. Wall-clock time enters here, never in the core.
73
73
74
74
## Modules
75
75
@@ -156,10 +156,10 @@
156
156
dune build && ./_build/default/bin/main.exe # http://localhost:8080/
157
157
```
158
158
159
Removed:
`bin/main.ml` starts ocsigenserver programmatically — `Eliom.run` yields an
160
Removed:
`Ocsigen_server.instruction`, so there is no XML configuration to keep in sync
161
Removed:
and no `.cmxs` loaded at runtime. The socket binds **loopback only**, and there
162
Removed:
is **no authentication**: anything beyond local dogfooding needs auth first.
159
Added:
`bin/main.ml` starts Dream directly. Dream binds loopback only by explicit
160
Added:
configuration, so no XML configuration or runtime plug-in exists. The socket
161
Added:
binds **loopback only**, and there is **no authentication**: anything beyond
162
Added:
local dogfooding needs auth first.
163
163
164
164
Storage is in-memory, so a restart wipes the log. The workout in progress is a
165
165
single slot in `Service.t`, not a session reference — it survives a closed tab,
@@ -167,22 +167,24 @@
167
167
168
168
| Route | Method | Purpose |
169
169
|---|---|---|
170
Removed:
| `/` | GET | Choose a routine, or resume one in progress |
171
Removed:
| `/begin` | POST | Start the next workout, or refuse and show the gate |
172
Removed:
| `/log` | GET | The workout in progress |
173
Removed:
| `/log-single` | POST | Record one movement driven to failure |
174
Removed:
| `/log-pair` | POST | Record an isolation carried into a compound |
175
Removed:
| `/finish` | POST | Complete and persist |
170
Added:
| `/routines` | GET | Choose a routine |
171
Added:
| `/routines/:id/select` | POST | Make a routine active |
172
Added:
| `/routine` | GET | Active routine details |
173
Added:
| `/workout` | GET | The workout in progress |
174
Added:
| `/workout` | POST | Start the next workout or refuse at the recovery gate |
175
Added:
| `/workout/slots/:slot` | POST | Record one prescribed stimulus |
176
Added:
| `/workout/finish` | POST | Complete and persist |
176
177
| `/history` | GET | What has been performed |
178
Added:
| `/history/:id` | GET | View a saved workout and its missing records |
179
Added:
| `/history/:id/slots/:slot` | POST | Add a missing saved record |
177
180
178
Removed:
Paths are flat because Eliom treats a path as either a page or a directory: a
179
Removed:
page at `/log` cannot coexist with `/log/single`.
181
Added:
Dream permits nested resource paths, so slot and record identity live in the
182
Added:
path rather than hidden fields or query parameters.
180
183
181
Removed:
The refusal at `/begin` is two steps, not one click. It reports how much of the
182
Removed:
recommended rest remains and starts nothing; training anyway requires stating a
183
Removed:
reason, which is kept with the entry and reaches `Progression.diagnose`. That is
184
Removed:
the clearance invariant made visible — the one place the UI has to express a core
185
Removed:
rule rather than merely display data.
184
Added:
The refusal at `POST /workout` redirects to the overview. The overview reports
185
Added:
the remaining rest and offers an explicit override action. The override keeps
186
Added:
the rested and recommended durations in the entry. The UI therefore makes the
187
Added:
clearance invariant visible instead of silently training early.
186
188
187
189
## Tests
188
190
bin/dune
@@ -1,7 +1,4 @@
1
Removed:
; ocsipersist-sqlite supplies the implementation of eliom's virtual
2
Removed:
; ocsipersist dependency; it is only needed at link time, here.
3
Removed:
4
1
(executable
5
2
(public_name hito)
6
3
(name main)
7
Removed:
(libraries hito.web eliom.server ocsigenserver ocsipersist-sqlite unix))
4
Added:
(libraries hito.web dream))
bin/main.ml
@@ -1,37 +1,7 @@
1
Removed:
(* Launcher. Ocsigenserver is started programmatically rather than through an
2
Removed:
XML configuration file, so there is nothing to keep in sync and no .cmxs to
3
Removed:
load dynamically — see Eliom.run, which exists for exactly this.
1
Added:
(* The server binds only to loopback. There is no authentication, so this is
2
Added:
suitable only for local dogfooding. *)
4
3
5
Removed:
NO AUTHENTICATION. The socket is bound to loopback only, deliberately: any
6
Removed:
process on this machine can read and write the training log, and anything
7
Removed:
beyond localhost dogfooding needs authentication first. *)
8
Removed:
9
Removed:
let port = 8080
10
Removed:
let runtime_dir = Filename.concat (Filename.get_temp_dir_name ()) "hito"
11
Removed:
12
4
let () =
13
Removed:
Hito_web.Services.register ();
14
Removed:
let dir sub =
15
Removed:
let d = Filename.concat runtime_dir sub in
16
Removed:
(try Unix.mkdir runtime_dir 0o700 with Unix.Unix_error _ -> ());
17
Removed:
(try Unix.mkdir d 0o700 with Unix.Unix_error _ -> ());
18
Removed:
d
19
Removed:
in
20
Removed:
Printf.printf "hito listening on http://localhost:%d/ (no authentication)\n%!"
21
Removed:
port;
22
Removed:
Ocsigen_server.start
23
Removed:
~ports:[ (`IPv4 Unix.inet_addr_loopback, port) ]
24
Removed:
(* Without this the Content-Type header carries an empty charset and
25
Removed:
browsers fall back to Latin-1, mangling every non-ASCII character. *)
26
Removed:
~default_charset:(Some "utf-8") ~logdir:(dir "log") ~datadir:(dir "data")
27
Removed:
~command_pipe:(Filename.concat runtime_dir "cmd")
28
Removed:
~veryverbose:()
29
Removed:
[
30
Removed:
Ocsigen_server.host
31
Removed:
[
32
Removed:
(* The site charset is what fills in the Content-Type; without it the
33
Removed:
header reads "charset=" and browsers assume Latin-1, which mangles
34
Removed:
every non-ASCII character. *)
35
Removed:
Ocsigen_server.site ~charset:"utf-8" [] [ Eliom.run () ];
36
Removed:
];
37
Removed:
]
5
Added:
Dream.run ~interface:"localhost" ~port:8080
6
Added:
@@ Dream.logger
7
Added:
@@ Dream.router (Hito_web.Handlers.routes (Hito_web.Handlers.create ()))
dune-project
@@ -26,14 +26,12 @@
26
26
(and
27
27
(>= 1.8)
28
28
:with-test))
29
Removed:
(eliom
30
Removed:
(>= 12.0))
31
Removed:
(ocsigenserver
32
Removed:
(>= 7.0))
33
Removed:
(ocsipersist-sqlite
34
Removed:
(>= 2.1))
35
Removed:
(ocsigen-toolkit
36
Removed:
(= 4.3.0))
29
Added:
(dream
30
Added:
(>= 1.0.0~alpha8))
31
Added:
(dream-html
32
Added:
(>= 3.11.2))
33
Added:
(lwt
34
Added:
(>= 5.0))
37
35
(crunch
38
36
(and
39
37
(= 4.1.0)
hito.opam
@@ -13,10 +13,9 @@
13
13
"dune" {>= "3.20"}
14
14
"ocaml" {>= "5.1"}
15
15
"alcotest" {>= "1.8" & with-test}
16
Removed:
"eliom" {>= "12.0"}
17
Removed:
"ocsigenserver" {>= "7.0"}
18
Removed:
"ocsipersist-sqlite" {>= "2.1"}
19
Removed:
"ocsigen-toolkit" {= "4.3.0"}
16
Added:
"dream" {>= "1.0.0~alpha8"}
17
Added:
"dream-html" {>= "3.11.2"}
18
Added:
"lwt" {>= "5.0"}
20
19
"crunch" {= "4.1.0" & build}
21
20
"ocamlformat" {= "0.29.0" & with-dev-setup}
22
21
"odoc" {with-doc}
lib/app/repository.mli
@@ -1,4 +1,4 @@
1
Removed:
(** Persistence port. A pure module type: no database, no Eliom.
1
Added:
(** Persistence port. A pure module type: no database or web framework.
2
2
3
3
Identity lives here rather than in the core, which carries none — a routine
4
4
or a stored workout needs a name only once something has to remember it. *)
lib/app/service.mli
@@ -1,5 +1,5 @@
1
1
(** Application service: orchestrates the core over a {!Repository.S}. The API a
2
Removed:
client calls — no Eliom, no HTML, no serialization.
2
Added:
client calls — no HTML or serialization.
3
3
4
4
Recovery gating lives here, not in the client. {!Evidence.Workout.start}
5
5
demands a {!Recovery.clearance}, and this module is the only thing that
lib/core/prescription.mli
@@ -82,4 +82,7 @@
82
82
(** 72h after the final workout. *)
83
83
84
84
val recovery_after : t -> Workout.t -> Recovery.duration
85
Added:
86
Added:
val ideal : t
87
Added:
(** The supplied Heavy Duty I routine. *)
85
88
end
lib/web/assets/hito.css
@@ -126,7 +126,7 @@
126
126
display: none;
127
127
}
128
128
129
Removed:
/* Ocsigen Toolkit's CSS-only dropdown: usable without a client OCaml tier. */
129
Added:
/* Compact navigation for small screens. */
130
130
.ot-dropdown {
131
131
position: relative;
132
132
transition: background-color 0.2s ease;
@@ -192,7 +192,7 @@
192
192
color: var(--accent);
193
193
}
194
194
195
Removed:
/* Ocsigen Toolkit icon styles for the settings/navigation glyph. */
195
Added:
/* Navigation icon styling. */
196
196
.ot-icon {
197
197
display: inline-block;
198
198
width: 1em;
lib/web/decode.ml
@@ -0,0 +1,104 @@
1
Added:
module Form = Dream_html.Form
2
Added:
3
Added:
type fields =
4
Added:
| Single of {
5
Added:
load : float;
6
Added:
reps : int;
7
Added:
extension : Evidence.Stimulus.extension option;
8
Added:
}
9
Added:
| Pair of {
10
Added:
iso_load : float;
11
Added:
iso_reps : int;
12
Added:
comp_load : float;
13
Added:
comp_reps : int;
14
Added:
extension : Evidence.Stimulus.extension option;
15
Added:
}
16
Added:
17
Added:
let extension = function
18
Added:
| "" -> Ok None
19
Added:
| "forced" -> Ok (Some Evidence.Stimulus.Forced_reps)
20
Added:
| "negatives" -> Ok (Some Evidence.Stimulus.Negatives)
21
Added:
| "rest-pause" -> Ok (Some Evidence.Stimulus.Rest_pause)
22
Added:
| "static" -> Ok (Some Evidence.Stimulus.Static_hold)
23
Added:
| _ -> Error "error.extension"
24
Added:
25
Added:
let load =
26
Added:
Form.ensure "error.load"
27
Added:
(fun value -> Float.is_finite value && value >= 0.)
28
Added:
Form.required Form.float
29
Added:
30
Added:
let reps = Form.required (Form.int ~min:1)
31
Added:
32
Added:
let fields prescription =
33
Added:
let open Form in
34
Added:
match Prescription.Stimulus.delivery prescription with
35
Added:
| Prescription.Stimulus.Single _ ->
36
Added:
let+ load = load "load"
37
Added:
and+ reps = reps "reps"
38
Added:
and+ extension = required extension "extension" in
39
Added:
Single { load; reps; extension }
40
Added:
| Prescription.Stimulus.Pre_exhaust _ ->
41
Added:
let+ iso_load = load "iso_load"
42
Added:
and+ iso_reps = reps "iso_reps"
43
Added:
and+ comp_load = load "comp_load"
44
Added:
and+ comp_reps = reps "comp_reps"
45
Added:
and+ extension = required extension "extension" in
46
Added:
Pair { iso_load; iso_reps; comp_load; comp_reps; extension }
47
Added:
48
Added:
let movement ~exercise ~load_kg ~reps ~outcome =
49
Added:
try
50
Added:
Ok (Evidence.Stimulus.Movement.make ~exercise ~load_kg ~reps ~outcome)
51
Added:
with
52
Added:
| Evidence.Stimulus.Movement.Invalid Evidence.Stimulus.Movement.Invalid_load
53
Added:
->
54
Added:
Error "error.load"
55
Added:
| Evidence.Stimulus.Movement.Invalid Evidence.Stimulus.Movement.Invalid_reps
56
Added:
->
57
Added:
Error "error.reps"
58
Added:
59
Added:
let stimulus prescription =
60
Added:
let open Form in
61
Added:
let* values = fields prescription in
62
Added:
match (Prescription.Stimulus.delivery prescription, values) with
63
Added:
| Prescription.Stimulus.Single exercise, Single { load; reps; extension } -> (
64
Added:
match
65
Added:
movement ~exercise ~load_kg:load ~reps
66
Added:
~outcome:
67
Added:
(match extension with
68
Added:
| None -> Evidence.Stimulus.Positive_failure
69
Added:
| Some extension -> Evidence.Stimulus.Beyond_failure (extension, []))
70
Added:
with
71
Added:
| Ok movement ->
72
Added:
ok (Evidence.Stimulus.make (Evidence.Stimulus.Single movement))
73
Added:
| Error key -> Form.error "load" key)
74
Added:
| ( Prescription.Stimulus.Pre_exhaust { isolation; compound },
75
Added:
Pair { iso_load; iso_reps; comp_load; comp_reps; extension } ) -> (
76
Added:
match
77
Added:
( movement ~exercise:isolation ~load_kg:iso_load ~reps:iso_reps
78
Added:
~outcome:Evidence.Stimulus.Positive_failure,
79
Added:
movement ~exercise:compound ~load_kg:comp_load ~reps:comp_reps
80
Added:
~outcome:
81
Added:
(match extension with
82
Added:
| None -> Evidence.Stimulus.Positive_failure
83
Added:
| Some extension ->
84
Added:
Evidence.Stimulus.Beyond_failure (extension, [])) )
85
Added:
with
86
Added:
| Ok first, Ok second ->
87
Added:
ok (Evidence.Stimulus.make (Evidence.Stimulus.Pair { first; second }))
88
Added:
| Error key, _ -> Form.error "iso_load" key
89
Added:
| _, Error key -> Form.error "comp_load" key)
90
Added:
| _ -> assert false
91
Added:
92
Added:
let override = Form.required Form.bool "override"
93
Added:
94
Added:
let message = function
95
Added:
| "error.required" -> "Enter a value."
96
Added:
| "error.expected.number" -> "Enter a valid number."
97
Added:
| "error.expected.int" -> "Enter a valid whole number."
98
Added:
| "error.range" | "error.reps" -> "Enter at least one repetition."
99
Added:
| "error.load" -> "Enter a finite, nonnegative load."
100
Added:
| "error.extension" -> "Select one of the offered endings."
101
Added:
| key -> key
102
Added:
103
Added:
let errors_to_text errors =
104
Added:
errors |> List.map (fun (_, key) -> message key) |> String.concat " "
lib/web/decode.mli
@@ -0,0 +1,5 @@
1
Added:
type fields
2
Added:
3
Added:
val override : bool Dream_html.Form.t
4
Added:
val stimulus : Prescription.Stimulus.t -> Evidence.Stimulus.t Dream_html.Form.t
5
Added:
val errors_to_text : (string * string) list -> string
lib/web/dune
@@ -1,6 +1,3 @@
1
Removed:
; Server-rendered only: no client-side OCaml, so no eliom ppx and no
2
Removed:
; js_of_ocaml. Pages are plain HTML from Eliom_registration.Html.
3
Removed:
4
1
(rule
5
2
(targets stylesheet.ml)
6
3
(deps
@@ -11,5 +8,7 @@
11
8
(library
12
9
(name hito_web)
13
10
(public_name hito.web)
14
Removed:
(modules routes pages services stylesheet)
15
Removed:
(libraries hito.core hito.app eliom.server ocsigen-toolkit.server))
11
Added:
(modules routes decode pages handlers stylesheet)
12
Added:
(preprocess
13
Added:
(pps dream-html.ppx))
14
Added:
(libraries hito.core hito.app dream dream-html unix))
lib/web/handlers.ml
@@ -0,0 +1,192 @@
1
Added:
open Lwt.Infix
2
Added:
open Hito_app
3
Added:
module Service = Service.Make (Memory_repo)
4
Added:
5
Added:
type t = { service : Service.t; now : unit -> Recovery.timestamp }
6
Added:
7
Added:
let default_now () =
8
Added:
Recovery.timestamp_of_unix_seconds (int_of_float (Unix.gettimeofday ()))
9
Added:
10
Added:
let create ?(now = default_now) () =
11
Added:
{ service = Service.make ~repo:(Memory_repo.create ()); now }
12
Added:
13
Added:
let stylesheet =
14
Added:
match Stylesheet.read "hito.css" with
15
Added:
| Some stylesheet -> stylesheet
16
Added:
| None -> failwith "Embedded stylesheet hito.css is missing"
17
Added:
18
Added:
let html ?status page = Dream_html.respond ?status page
19
Added:
let redirect request path = Dream_html.redirect request path
20
Added:
21
Added:
let not_found detail =
22
Added:
html (Pages.problem ~title:"Not found" ~detail) ~status:`Not_Found
23
Added:
24
Added:
let bad_request detail =
25
Added:
html (Pages.problem ~title:"Invalid request" ~detail) ~status:`Bad_Request
26
Added:
27
Added:
let home_page t =
28
Added:
match Service.in_progress t.service with
29
Added:
| Some workout -> Pages.workout ~record_id:None workout
30
Added:
| None -> (
31
Added:
match Service.active_routine t.service with
32
Added:
| None -> Pages.choose_routine ~routines:(Service.list_routines t.service)
33
Added:
| Some (routine, selected) -> (
34
Added:
match
35
Added:
( Service.next_workout t.service ~routine,
36
Added:
Service.readiness t.service ~routine ~now:(t.now ()) )
37
Added:
with
38
Added:
| Ok next, Ok readiness ->
39
Added:
Pages.home ~routine
40
Added:
~routine_name:(Prescription.Routine.name selected)
41
Added:
~next ~readiness
42
Added:
| Error error, _ | _, Error error ->
43
Added:
Pages.problem ~title:"Routine unavailable"
44
Added:
~detail:(Format.asprintf "%a" Service.pp_error error)))
45
Added:
46
Added:
let decode_form decoder request =
47
Added:
Dream_html.form decoder ~csrf:false request >|= function
48
Added:
| `Ok value -> Ok value
49
Added:
| `Invalid errors -> Error (`Invalid errors)
50
Added:
| _ -> Error `Bad_request
51
Added:
52
Added:
let record_target t id =
53
Added:
Service.find_record t.service (Repository.workout_id id)
54
Added:
|> Option.map (fun record ->
55
Added:
(record.Repository.id, record.Repository.workout))
56
Added:
57
Added:
let outstanding target slot =
58
Added:
List.assoc_opt slot (Evidence.Workout.outstanding target)
59
Added:
60
Added:
let save_current t stimulus =
61
Added:
match Service.log t.service stimulus with
62
Added:
| Ok _ -> Ok ()
63
Added:
| Error Service.No_workout_in_progress -> Error "No workout is in progress."
64
Added:
| Error (Service.Rejected error) ->
65
Added:
Error (Format.asprintf "%a" Evidence.Workout.pp_error error)
66
Added:
67
Added:
let save_record t id stimulus =
68
Added:
match Service.add_to_record t.service id stimulus with
69
Added:
| Ok _ -> Ok ()
70
Added:
| Error Service.Unknown_workout ->
71
Added:
Error "That saved workout no longer exists."
72
Added:
| Error (Service.Rejected_edit error) ->
73
Added:
Error (Format.asprintf "%a" Evidence.Workout.pp_error error)
74
Added:
75
Added:
let routes t =
76
Added:
let home _request = html (home_page t) in
77
Added:
let routines _request =
78
Added:
html (Pages.choose_routine ~routines:(Service.list_routines t.service))
79
Added:
in
80
Added:
let select_routine request id =
81
Added:
match Service.select_routine t.service (Repository.routine_id id) with
82
Added:
| Ok () ->
83
Added:
redirect request (Dream_html.path_attr Dream_html.HTML.href Routes.home)
84
Added:
| Error _ -> not_found "That routine is not in the catalogue."
85
Added:
in
86
Added:
let routine request =
87
Added:
match Service.active_routine t.service with
88
Added:
| Some (_, routine) -> html (Pages.routine routine)
89
Added:
| None ->
90
Added:
redirect request
91
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.routines)
92
Added:
in
93
Added:
let begin_workout request =
94
Added:
decode_form Decode.override request >>= function
95
Added:
| Error _ -> bad_request "The submitted form is not valid."
96
Added:
| Ok override -> (
97
Added:
match Service.active_routine t.service with
98
Added:
| None ->
99
Added:
redirect request
100
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.routines)
101
Added:
| Some (routine, _) -> (
102
Added:
let override = if override then Some () else None in
103
Added:
match
104
Added:
Service.begin_workout t.service ~routine ~now:(t.now ()) ?override
105
Added:
()
106
Added:
with
107
Added:
| Ok _ ->
108
Added:
redirect request
109
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
110
Added:
| Error (Service.Not_recovered _) ->
111
Added:
redirect request
112
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.home)
113
Added:
| Error Service.Unknown_routine ->
114
Added:
not_found "That routine is not in the catalogue."))
115
Added:
in
116
Added:
let current_workout request =
117
Added:
match Service.in_progress t.service with
118
Added:
| Some workout -> html (Pages.workout ~record_id:None workout)
119
Added:
| None ->
120
Added:
redirect request (Dream_html.path_attr Dream_html.HTML.href Routes.home)
121
Added:
in
122
Added:
let log_current request slot =
123
Added:
match Service.in_progress t.service with
124
Added:
| None -> not_found "No workout is in progress."
125
Added:
| Some workout -> (
126
Added:
match outstanding workout slot with
127
Added:
| None -> not_found "That slot is not awaiting a record."
128
Added:
| Some prescription -> (
129
Added:
decode_form (Decode.stimulus prescription) request >>= function
130
Added:
| Error (`Invalid errors) ->
131
Added:
html ~status:`Bad_Request
132
Added:
(Pages.workout ~errors ~record_id:None workout)
133
Added:
| Error `Bad_request ->
134
Added:
bad_request "The submitted form is not valid."
135
Added:
| Ok stimulus -> (
136
Added:
match save_current t stimulus with
137
Added:
| Ok () ->
138
Added:
redirect request
139
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
140
Added:
| Error detail -> bad_request detail)))
141
Added:
in
142
Added:
let finish request =
143
Added:
match Service.finish t.service ~ended_at:(t.now ()) with
144
Added:
| Some _ ->
145
Added:
redirect request
146
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.history)
147
Added:
| None -> not_found "No workout is in progress."
148
Added:
in
149
Added:
let history _request = html (Pages.history (Service.history t.service)) in
150
Added:
let record _request id =
151
Added:
match record_target t id with
152
Added:
| None -> not_found "That saved workout no longer exists."
153
Added:
| Some (_, workout) -> html (Pages.workout ~record_id:(Some id) workout)
154
Added:
in
155
Added:
let log_record request id slot =
156
Added:
match record_target t id with
157
Added:
| None -> not_found "That saved workout no longer exists."
158
Added:
| Some (record_id, workout) -> (
159
Added:
match outstanding workout slot with
160
Added:
| None -> not_found "That slot is not awaiting a record."
161
Added:
| Some prescription -> (
162
Added:
decode_form (Decode.stimulus prescription) request >>= function
163
Added:
| Error (`Invalid errors) ->
164
Added:
html ~status:`Bad_Request
165
Added:
(Pages.workout ~errors ~record_id:(Some id) workout)
166
Added:
| Error `Bad_request ->
167
Added:
bad_request "The submitted form is not valid."
168
Added:
| Ok stimulus -> (
169
Added:
match save_record t record_id stimulus with
170
Added:
| Ok () ->
171
Added:
redirect request
172
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
173
Added:
id)
174
Added:
| Error detail -> bad_request detail)))
175
Added:
in
176
Added:
[
177
Added:
Dream_html.get Routes.home home;
178
Added:
Dream_html.get Routes.routines routines;
179
Added:
Dream_html.post Routes.select_routine select_routine;
180
Added:
Dream_html.get Routes.routine routine;
181
Added:
Dream_html.get Routes.workout current_workout;
182
Added:
Dream_html.post Routes.workout begin_workout;
183
Added:
Dream_html.post Routes.workout_slot log_current;
184
Added:
Dream_html.post Routes.finish_workout finish;
185
Added:
Dream_html.get Routes.history history;
186
Added:
Dream_html.get Routes.record record;
187
Added:
Dream_html.post Routes.record_slot log_record;
188
Added:
Dream_html.get Routes.stylesheet (fun _ ->
189
Added:
Dream.respond
190
Added:
~headers:[ ("Content-Type", "text/css; charset=utf-8") ]
191
Added:
stylesheet);
192
Added:
]
lib/web/handlers.mli
@@ -0,0 +1,4 @@
1
Added:
type t
2
Added:
3
Added:
val create : ?now:(unit -> Recovery.timestamp) -> unit -> t
4
Added:
val routes : t -> Dream.route list
lib/web/pages.ml
@@ -1,446 +1,408 @@
1
Removed:
open Eliom_content.Html.F
1
Added:
open Dream_html
2
2
open Hito_app
3
3
4
Removed:
type page = Html_types.html Eliom_content.Html.elt
4
Added:
type page = Dream_html.node
5
5
6
Removed:
(* Named so that inference cannot mistake a routine_id for a plain string at the
7
Removed:
use sites. *)
8
Removed:
let id_string (id : Repository.routine_id) = (id :> string)
6
Added:
let tag = Dream_html.std_tag
7
Added:
let void = Dream_html.void_tag
8
Added:
let class_ = Dream_html.string_attr "class"
9
Added:
let name = Dream_html.string_attr "name"
10
Added:
let value = Dream_html.string_attr "value"
11
Added:
let rel = Dream_html.string_attr "rel"
12
Added:
let type_ = Dream_html.string_attr "type"
13
Added:
let step = Dream_html.string_attr "step"
14
Added:
let required = Dream_html.attr "required"
9
15
10
Removed:
(* The stylesheet is a separately authored CSS asset. Dune embeds it in the
11
Removed:
executable and the explicit Eliom CSS service serves it at runtime. *)
12
Removed:
13
Removed:
let nav_link service label = a ~service [ txt label ] ()
14
Removed:
15
Removed:
let navigation () =
16
Removed:
let menu =
17
Removed:
Ot_buttons.dropdown
18
Removed:
~a:[ a_class [ "nav-menu" ] ]
19
Removed:
~menu:
20
Removed:
[
21
Removed:
nav_link Routes.home "Overview";
22
Removed:
nav_link Routes.routine "Routine";
23
Removed:
nav_link Routes.log "Current workout";
24
Removed:
nav_link Routes.history "History";
25
Removed:
]
26
Removed:
[ span [ txt "Menu" ]; Ot_icons.F.config () ]
27
Removed:
in
28
Removed:
nav
29
Removed:
~a:[ a_class [ "primary-nav" ] ]
16
Added:
let html_page title content =
17
Added:
tag "html" []
30
18
[
31
Removed:
nav_link Routes.home "Overview";
32
Removed:
nav_link Routes.routine "Routine";
33
Removed:
nav_link Routes.log "Current workout";
34
Removed:
nav_link Routes.history "History";
35
Removed:
menu;
19
Added:
tag "head" []
20
Added:
[
21
Added:
tag "title" [] [ txt "%s — hito" title ];
22
Added:
void "meta" [ Dream_html.string_attr "charset" "utf-8" ];
23
Added:
void "meta"
24
Added:
[
25
Added:
Dream_html.string_attr "name" "viewport";
26
Added:
Dream_html.string_attr "content"
27
Added:
"width=device-width,initial-scale=1";
28
Added:
];
29
Added:
void "link"
30
Added:
[
31
Added:
rel "stylesheet";
32
Added:
Dream_html.path_attr
33
Added:
(Dream_html.uri_attr "href")
34
Added:
Routes.stylesheet;
35
Added:
];
36
Added:
];
37
Added:
tag "body"
38
Added:
[ class_ "hito-app" ]
39
Added:
[
40
Added:
tag "div"
41
Added:
[ class_ "app-shell" ]
42
Added:
[
43
Added:
tag "header"
44
Added:
[ class_ "masthead" ]
45
Added:
[
46
Added:
tag "a"
47
Added:
[
48
Added:
class_ "brand";
49
Added:
Dream_html.path_attr
50
Added:
(Dream_html.uri_attr "href")
51
Added:
Routes.home;
52
Added:
]
53
Added:
[
54
Added:
tag "span" [ class_ "brand-mark" ] [ txt "HD" ];
55
Added:
tag "span"
56
Added:
[ class_ "brand-copy" ]
57
Added:
[
58
Added:
tag "strong" [] [ txt "hito" ];
59
Added:
tag "small" [] [ txt "Heavy Duty logbook" ];
60
Added:
];
61
Added:
];
62
Added:
tag "nav"
63
Added:
[ class_ "primary-nav" ]
64
Added:
[
65
Added:
tag "a"
66
Added:
[
67
Added:
Dream_html.path_attr
68
Added:
(Dream_html.uri_attr "href")
69
Added:
Routes.home;
70
Added:
]
71
Added:
[ txt "Overview" ];
72
Added:
tag "a"
73
Added:
[
74
Added:
Dream_html.path_attr
75
Added:
(Dream_html.uri_attr "href")
76
Added:
Routes.routine;
77
Added:
]
78
Added:
[ txt "Routine" ];
79
Added:
tag "a"
80
Added:
[
81
Added:
Dream_html.path_attr
82
Added:
(Dream_html.uri_attr "href")
83
Added:
Routes.workout;
84
Added:
]
85
Added:
[ txt "Current workout" ];
86
Added:
tag "a"
87
Added:
[
88
Added:
Dream_html.path_attr
89
Added:
(Dream_html.uri_attr "href")
90
Added:
Routes.history;
91
Added:
]
92
Added:
[ txt "History" ];
93
Added:
];
94
Added:
];
95
Added:
tag "main" [] [ tag "div" [ class_ "page-surface" ] content ];
96
Added:
];
97
Added:
];
36
98
]
37
99
38
Removed:
let shell ~title:t content =
39
Removed:
html
40
Removed:
(head
41
Removed:
(title (txt (t ^ " — hito")))
42
Removed:
[
43
Removed:
meta ~a:[ a_charset "utf-8" ] ();
44
Removed:
meta
45
Removed:
~a:
46
Removed:
[
47
Removed:
a_name "viewport"; a_content "width=device-width,initial-scale=1";
48
Removed:
]
49
Removed:
();
50
Removed:
meta ~a:[ a_name "theme-color"; a_content "#111815" ] ();
51
Removed:
css_link ~uri:(make_uri ~service:Routes.stylesheet ()) ();
52
Removed:
])
53
Removed:
(body
54
Removed:
~a:[ a_class [ "hito-app" ] ]
55
Removed:
[
56
Removed:
div
57
Removed:
~a:[ a_class [ "app-shell" ] ]
58
Removed:
[
59
Removed:
header
60
Removed:
~a:[ a_class [ "masthead" ] ]
61
Removed:
[
62
Removed:
a
63
Removed:
~a:[ a_class [ "brand" ] ]
64
Removed:
~service:Routes.home
65
Removed:
[
66
Removed:
span ~a:[ a_class [ "brand-mark" ] ] [ txt "HD" ];
67
Removed:
span
68
Removed:
~a:[ a_class [ "brand-copy" ] ]
69
Removed:
[
70
Removed:
strong [ txt "hito" ];
71
Removed:
small [ txt "Heavy Duty logbook" ];
72
Removed:
];
73
Removed:
]
74
Removed:
();
75
Removed:
navigation ();
76
Removed:
];
77
Removed:
main [ Ot_popup.hcf ~a:[ a_class [ "page-surface" ] ] content ];
78
Removed:
];
79
Removed:
])
80
Removed:
81
Removed:
let problem ~title:t ~detail =
82
Removed:
shell ~title:t
100
Added:
let problem ~title ~detail =
101
Added:
html_page title
83
102
[
84
Removed:
p ~a:[ a_class [ "eyebrow" ] ] [ txt "Attention required" ];
85
Removed:
h2 [ txt t ];
86
Removed:
p ~a:[ a_class [ "warn" ] ] [ txt detail ];
103
Added:
tag "p" [ class_ "eyebrow" ] [ txt "Attention required" ];
104
Added:
tag "h2" [] [ txt "%s" title ];
105
Added:
tag "p" [ class_ "warn" ] [ txt "%s" detail ];
87
106
]
88
107
89
Removed:
(* A prescribed stimulus described in words: the movements, and the rep window
90
Removed:
that calibrates the load. *)
91
Removed:
let describe_prescription p =
92
Removed:
let min_reps, max_reps = Prescription.Stimulus.rep_range p in
108
Added:
let id_string (id : Repository.routine_id) = (id :> string)
109
Added:
110
Added:
let describe_prescription prescription =
111
Added:
let min_reps, max_reps = Prescription.Stimulus.rep_range prescription in
93
112
let window = Printf.sprintf "%d-%d reps" min_reps max_reps in
94
Removed:
match Prescription.Stimulus.delivery p with
95
Removed:
| Prescription.Stimulus.Single e ->
96
Removed:
Printf.sprintf "%s — %s" (Exercise.name e) window
113
Added:
match Prescription.Stimulus.delivery prescription with
114
Added:
| Prescription.Stimulus.Single exercise ->
115
Added:
Printf.sprintf "%s — %s" (Exercise.name exercise) window
97
116
| Prescription.Stimulus.Pre_exhaust { isolation; compound } ->
98
117
Printf.sprintf "%s into %s, no pause — %s" (Exercise.name isolation)
99
118
(Exercise.name compound) window
100
119
101
Removed:
let extension_select name =
102
Removed:
match
103
Removed:
List.map
104
Removed:
(fun (value, label) -> Form.Option ([], value, Some (txt label), false))
105
Removed:
Routes.extension_choices
106
Removed:
with
107
Removed:
| first :: rest -> Form.select ~name Form.string first rest
108
Removed:
| [] -> assert false
120
Added:
let extension_select () =
121
Added:
tag "select"
122
Added:
[ name "extension" ]
123
Added:
[
124
Added:
tag "option" [ value "" ] [ txt "to positive failure" ];
125
Added:
tag "option" [ value "forced" ] [ txt "then forced reps" ];
126
Added:
tag "option" [ value "negatives" ] [ txt "then negatives" ];
127
Added:
tag "option" [ value "rest-pause" ] [ txt "then rest-pause" ];
128
Added:
tag "option" [ value "static" ] [ txt "then a static hold" ];
129
Added:
]
109
130
110
Removed:
let choose_routine
111
Removed:
~(routines : (Repository.routine_id * Prescription.Routine.t) list) =
112
Removed:
shell ~title:"Choose a routine"
131
Added:
let choose_routine ~routines =
132
Added:
html_page "Choose a routine"
113
133
[
114
Removed:
h2 [ txt "Routines" ];
115
Removed:
div
134
Added:
tag "h2" [] [ txt "Routines" ];
135
Added:
tag "div" []
116
136
(List.map
117
Removed:
(fun (id, r) ->
118
Removed:
Form.post_form ~service:Routes.select_routine
119
Removed:
(fun routine ->
120
Removed:
[
121
Removed:
fieldset
122
Removed:
~legend:(legend [ txt (Prescription.Routine.name r) ])
123
Removed:
[
124
Removed:
p
125
Removed:
[
126
Removed:
txt
127
Removed:
(Printf.sprintf "%d workouts in the cycle."
128
Removed:
(List.length (Prescription.Routine.workouts r)));
129
Removed:
];
130
Removed:
Form.input ~input_type:`Hidden ~name:routine
131
Removed:
~value:(id_string id) Form.string;
132
Removed:
Form.input ~input_type:`Submit ~value:"Use this routine"
133
Removed:
Form.string;
134
Removed:
];
135
Removed:
])
136
Removed:
())
137
Added:
(fun (routine_id, routine) ->
138
Added:
tag "form"
139
Added:
[
140
Added:
Dream_html.path_attr
141
Added:
(Dream_html.uri_attr "action")
142
Added:
Routes.select_routine (id_string routine_id);
143
Added:
Dream_html.string_attr "method" "post";
144
Added:
]
145
Added:
[
146
Added:
tag "fieldset" []
147
Added:
[
148
Added:
tag "legend" []
149
Added:
[ txt "%s" (Prescription.Routine.name routine) ];
150
Added:
tag "p" []
151
Added:
[
152
Added:
txt "%d workouts in the cycle."
153
Added:
(List.length (Prescription.Routine.workouts routine));
154
Added:
];
155
Added:
void "input" [ type_ "submit"; value "Use this routine" ];
156
Added:
];
157
Added:
])
137
158
routines);
138
Removed:
fieldset
139
Removed:
~legend:(legend [ txt "Create routine" ])
159
Added:
]
160
Added:
161
Added:
let begin_form ~routine ~override label =
162
Added:
tag "form"
163
Added:
[
164
Added:
Dream_html.path_attr (Dream_html.uri_attr "action") Routes.workout;
165
Added:
Dream_html.string_attr "method" "post";
166
Added:
]
167
Added:
[
168
Added:
void "input"
140
169
[
141
Removed:
p [ txt "Custom routine authoring is coming soon." ];
142
Removed:
Form.input
143
Removed:
~a:[ a_disabled () ]
144
Removed:
~input_type:`Submit ~value:"Create routine — coming soon"
145
Removed:
Form.string;
170
Added:
type_ "hidden";
171
Added:
name "routine";
172
Added:
Dream_html.string_attr "value" "%s" (id_string routine);
146
173
];
174
Added:
void "input"
175
Added:
[
176
Added:
type_ "hidden";
177
Added:
name "override";
178
Added:
Dream_html.string_attr "value" "%s" (string_of_bool override);
179
Added:
];
180
Added:
void "input" [ type_ "submit"; value label ];
147
181
]
148
182
149
183
let home ~routine ~routine_name ~next ~readiness =
150
Removed:
let status =
184
Added:
let status, gate =
151
185
match readiness with
152
Removed:
| Recovery.Ready -> "Recovery is complete."
186
Added:
| Recovery.Ready ->
187
Added:
( "Recovery is complete.",
188
Added:
[ begin_form ~routine ~override:false "Begin next workout" ] )
153
189
| Recovery.Recovering { rested; recommended } ->
154
Removed:
Format.asprintf "Recovery: %a of %a." Recovery.pp_duration rested
155
Removed:
Recovery.pp_duration recommended
156
Removed:
in
157
Removed:
shell ~title:"Home"
158
Removed:
[
159
Removed:
h2 [ txt routine_name ];
160
Removed:
p [ txt ("Next: " ^ Prescription.Workout.name next) ];
161
Removed:
p [ txt status ];
162
Removed:
Form.post_form ~service:Routes.begin_workout
163
Removed:
(fun (routine_name, override) ->
190
Added:
( Format.asprintf "Recovery: %a of %a." Recovery.pp_duration rested
191
Added:
Recovery.pp_duration recommended,
164
192
[
165
Removed:
Form.input ~input_type:`Hidden ~name:routine_name
166
Removed:
~value:(id_string routine) Form.string;
167
Removed:
Form.input ~input_type:`Hidden ~name:override ~value:false Form.bool;
168
Removed:
Form.input ~input_type:`Submit ~value:"Begin next workout"
169
Removed:
Form.string;
170
Removed:
])
171
Removed:
();
172
Removed:
]
193
Added:
tag "div"
194
Added:
[ class_ "warn" ]
195
Added:
[
196
Added:
tag "p" []
197
Added:
[
198
Added:
txt "Heavy Duty requires recovery before the next workout.";
199
Added:
];
200
Added:
begin_form ~routine ~override:true "Begin under override";
201
Added:
];
202
Added:
] )
203
Added:
in
204
Added:
html_page "Home"
205
Added:
([
206
Added:
tag "h2" [] [ txt "%s" routine_name ];
207
Added:
tag "p" [] [ txt "Next: %s" (Prescription.Workout.name next) ];
208
Added:
tag "p" [] [ txt "%s" status ];
209
Added:
]
210
Added:
@ gate)
173
211
174
212
let routine routine =
175
Removed:
shell ~title:"Routine"
213
Added:
html_page "Routine"
176
214
[
177
Removed:
h2 [ txt (Prescription.Routine.name routine) ];
178
Removed:
ul
215
Added:
tag "h2" [] [ txt "%s" (Prescription.Routine.name routine) ];
216
Added:
tag "ul" []
179
217
(List.map
180
218
(fun workout ->
181
Removed:
li
219
Added:
tag "li" []
182
220
[
183
Removed:
txt (Prescription.Workout.name workout);
184
Removed:
ul
221
Added:
txt "%s" (Prescription.Workout.name workout);
222
Added:
tag "ul" []
185
223
(List.map
186
224
(fun stimulus ->
187
Removed:
li [ txt (describe_prescription stimulus) ])
225
Added:
tag "li" []
226
Added:
[ txt "%s" (describe_prescription stimulus) ])
188
227
(Prescription.Workout.stimuli workout));
189
228
])
190
229
(Prescription.Routine.workouts routine));
191
230
]
192
231
193
Removed:
let recovery_gate ~(routine : Repository.routine_id) ~workout ~readiness =
194
Removed:
let remaining =
195
Removed:
match readiness with
196
Removed:
| Recovery.Ready -> "Recovery is complete."
197
Removed:
| Recovery.Recovering { rested; recommended } ->
198
Removed:
Format.asprintf "You have rested %a of the %a this workout asks for."
199
Removed:
Recovery.pp_duration rested Recovery.pp_duration recommended
200
Removed:
in
201
Removed:
shell ~title:"Not recovered"
232
Added:
let error_for field errors =
233
Added:
match List.assoc_opt field errors with
234
Added:
| None -> []
235
Added:
| Some error ->
236
Added:
[
237
Added:
tag "p"
238
Added:
[ class_ "warn" ]
239
Added:
[ txt "%s" (Decode.errors_to_text [ (field, error) ]) ];
240
Added:
]
241
Added:
242
Added:
let input_row field label =
243
Added:
tag "div" []
202
244
[
203
Removed:
h2 [ txt ("Next: " ^ Prescription.Workout.name workout) ];
204
Removed:
div
205
Removed:
~a:[ a_class [ "warn" ] ]
245
Added:
tag "label" [] [ txt "%s" label ];
246
Added:
void "input" [ type_ "number"; name field; step "0.5"; required ];
247
Added:
]
248
Added:
249
Added:
let form_for_stimulus ~action_path ~prescription ~errors =
250
Added:
let fields =
251
Added:
match Prescription.Stimulus.delivery prescription with
252
Added:
| Prescription.Stimulus.Single _ ->
253
Added:
[ input_row "load" "Load (kg)"; input_row "reps" "Reps to failure" ]
254
Added:
| Prescription.Stimulus.Pre_exhaust { isolation; compound } ->
206
255
[
207
Removed:
p [ txt remaining ];
208
Removed:
p
256
Added:
tag "p" [ class_ "done" ] [ txt "%s" (Exercise.name isolation) ];
257
Added:
input_row "iso_load" "Load (kg)";
258
Added:
input_row "iso_reps" "Reps";
259
Added:
tag "p" [ class_ "done" ] [ txt "%s" (Exercise.name compound) ];
260
Added:
input_row "comp_load" "Load (kg)";
261
Added:
input_row "comp_reps" "Reps";
262
Added:
]
263
Added:
in
264
Added:
tag "form"
265
Added:
[ action_path; Dream_html.string_attr "method" "post" ]
266
Added:
[
267
Added:
tag "fieldset" []
268
Added:
([ tag "legend" [] [ txt "%s" (describe_prescription prescription) ] ]
269
Added:
@ fields
270
Added:
@ [ tag "label" [] [ txt "Ending" ]; extension_select () ]
271
Added:
@ List.concat_map
272
Added:
(fun field -> error_for field errors)
209
273
[
210
Removed:
txt
211
Removed:
"Heavy Duty treats training before recovery finishes as the \
212
Removed:
main way progress is lost — growth happens while you rest, \
213
Removed:
not while you lift. Train anyway only by explicitly\n\
214
Removed:
\ acknowledging the override; a later \
215
Removed:
diagnostic retains it.";
216
Removed:
];
217
Removed:
];
218
Removed:
Form.post_form ~service:Routes.begin_workout
219
Removed:
(fun (routine_name, override) ->
220
Removed:
[
221
Removed:
fieldset
222
Removed:
~legend:(legend [ txt "Train anyway" ])
223
Removed:
[
224
Removed:
Form.input ~input_type:`Hidden ~name:routine_name
225
Removed:
~value:(id_string routine) Form.string;
226
Removed:
Form.input ~input_type:`Hidden ~name:override ~value:true
227
Removed:
Form.bool;
228
Removed:
Form.input ~input_type:`Submit ~value:"Begin under override"
229
Removed:
Form.string;
230
Removed:
];
231
Removed:
])
232
Removed:
();
274
Added:
"load";
275
Added:
"reps";
276
Added:
"iso_load";
277
Added:
"iso_reps";
278
Added:
"comp_load";
279
Added:
"comp_reps";
280
Added:
"extension";
281
Added:
]
282
Added:
@ [ void "input" [ type_ "submit"; value "Record" ] ]);
233
283
]
234
284
235
Removed:
let single_form ~workout_id ~slot ~prescription =
236
Removed:
Form.post_form ~service:Routes.log_single
237
Removed:
(fun (workout_name, (slot_name, (load_name, (reps_name, ext_name)))) ->
238
Removed:
[
239
Removed:
fieldset
240
Removed:
~legend:(legend [ txt (describe_prescription prescription) ])
241
Removed:
([
242
Removed:
Form.input ~input_type:`Hidden ~name:workout_name ~value:workout_id
243
Removed:
Form.string;
244
Removed:
Form.input ~input_type:`Hidden ~name:slot_name ~value:slot Form.int;
245
Removed:
div
246
Removed:
~a:[ a_class [ "row" ] ]
247
Removed:
[
248
Removed:
div
249
Removed:
[
250
Removed:
label [ txt "Load (kg)" ];
251
Removed:
Form.input
252
Removed:
~a:[ a_step (Some 0.5); a_required () ]
253
Removed:
~input_type:`Number ~name:load_name Form.float;
254
Removed:
];
255
Removed:
div
256
Removed:
[
257
Removed:
label [ txt "Reps to failure" ];
258
Removed:
Form.input
259
Removed:
~a:[ a_required () ]
260
Removed:
~input_type:`Number ~name:reps_name Form.int;
261
Removed:
];
262
Removed:
];
263
Removed:
label [ txt "Ending" ];
264
Removed:
extension_select ext_name;
265
Removed:
]
266
Removed:
@ [ Form.input ~input_type:`Submit ~value:"Record" Form.string ]);
267
Removed:
])
268
Removed:
()
269
Removed:
270
Removed:
let pair_form ~workout_id ~slot ~prescription ~isolation ~compound =
271
Removed:
Form.post_form ~service:Routes.log_pair
272
Removed:
(fun ( workout_name,
273
Removed:
( slot_name,
274
Removed:
(iso_load, (iso_reps, (comp_load, (comp_reps, ext_name)))) ) ) ->
275
Removed:
[
276
Removed:
fieldset
277
Removed:
~legend:(legend [ txt (describe_prescription prescription) ])
278
Removed:
([
279
Removed:
Form.input ~input_type:`Hidden ~name:workout_name ~value:workout_id
280
Removed:
Form.string;
281
Removed:
Form.input ~input_type:`Hidden ~name:slot_name ~value:slot Form.int;
282
Removed:
p ~a:[ a_class [ "done" ] ] [ txt (Exercise.name isolation) ];
283
Removed:
div
284
Removed:
~a:[ a_class [ "row" ] ]
285
Removed:
[
286
Removed:
div
287
Removed:
[
288
Removed:
label [ txt "Load (kg)" ];
289
Removed:
Form.input
290
Removed:
~a:[ a_step (Some 0.5); a_required () ]
291
Removed:
~input_type:`Number ~name:iso_load Form.float;
292
Removed:
];
293
Removed:
div
294
Removed:
[
295
Removed:
label [ txt "Reps" ];
296
Removed:
Form.input
297
Removed:
~a:[ a_required () ]
298
Removed:
~input_type:`Number ~name:iso_reps Form.int;
299
Removed:
];
300
Removed:
];
301
Removed:
p ~a:[ a_class [ "done" ] ] [ txt (Exercise.name compound) ];
302
Removed:
div
303
Removed:
~a:[ a_class [ "row" ] ]
304
Removed:
[
305
Removed:
div
306
Removed:
[
307
Removed:
label [ txt "Load (kg)" ];
308
Removed:
Form.input
309
Removed:
~a:[ a_step (Some 0.5); a_required () ]
310
Removed:
~input_type:`Number ~name:comp_load Form.float;
311
Removed:
];
312
Removed:
div
313
Removed:
[
314
Removed:
label [ txt "Reps" ];
315
Removed:
Form.input
316
Removed:
~a:[ a_required () ]
317
Removed:
~input_type:`Number ~name:comp_reps Form.int;
318
Removed:
];
319
Removed:
];
320
Removed:
label [ txt "Ending" ];
321
Removed:
extension_select ext_name;
322
Removed:
]
323
Removed:
@ [ Form.input ~input_type:`Submit ~value:"Record" Form.string ]);
324
Removed:
])
325
Removed:
()
326
Removed:
327
Removed:
let describe_stimulus s =
328
Removed:
let movement m =
285
Added:
let describe_stimulus stimulus =
286
Added:
let movement movement =
329
287
Format.asprintf "%s %g kg x %d"
330
Removed:
(Exercise.name (Evidence.Stimulus.Movement.exercise m))
331
Removed:
(Evidence.Stimulus.Movement.load_kg m)
332
Removed:
(Evidence.Stimulus.Movement.reps m)
288
Added:
(Exercise.name (Evidence.Stimulus.Movement.exercise movement))
289
Added:
(Evidence.Stimulus.Movement.load_kg movement)
290
Added:
(Evidence.Stimulus.Movement.reps movement)
333
291
in
334
292
let body =
335
Removed:
String.concat " into " (List.map movement (Evidence.Stimulus.movements s))
293
Added:
String.concat " into "
294
Added:
(List.map movement (Evidence.Stimulus.movements stimulus))
336
295
in
337
Removed:
match Evidence.Stimulus.extensions s with
296
Added:
match Evidence.Stimulus.extensions stimulus with
338
297
| [] -> body
339
Removed:
| es ->
298
Added:
| extensions ->
340
299
body ^ ", "
341
300
^ String.concat " then "
342
Removed:
(List.map (Format.asprintf "%a" Evidence.Stimulus.pp_extension) es)
301
Added:
(List.map
302
Added:
(Format.asprintf "%a" Evidence.Stimulus.pp_extension)
303
Added:
extensions)
343
304
344
Removed:
let log_workout ~record_id ~workout =
305
Added:
let workout ?(errors = []) ~record_id workout =
345
306
let prescription = Evidence.Workout.prescription workout in
346
Removed:
let workout_id = Option.value ~default:"" record_id in
347
307
let performed = Evidence.Workout.stimuli workout in
348
308
let outstanding = Evidence.Workout.outstanding workout in
309
Added:
let form_action slot =
310
Added:
match record_id with
311
Added:
| None ->
312
Added:
Dream_html.path_attr
313
Added:
(Dream_html.uri_attr "action")
314
Added:
Routes.workout_slot slot
315
Added:
| Some record_id ->
316
Added:
Dream_html.path_attr
317
Added:
(Dream_html.uri_attr "action")
318
Added:
Routes.record_slot record_id slot
319
Added:
in
349
320
let override_note =
350
321
match Recovery.basis (Evidence.Workout.clearance workout) with
351
322
| Recovery.Recovered -> []
352
323
| Recovery.Overridden _ ->
353
324
[
354
Removed:
div
355
Removed:
~a:[ a_class [ "warn" ] ]
356
Removed:
[ txt "Begun before recovery finished." ];
325
Added:
tag "div" [ class_ "warn" ] [ txt "Begun before recovery finished." ];
357
326
]
358
327
in
359
Removed:
shell
360
Removed:
~title:(Prescription.Workout.name prescription)
328
Added:
html_page
329
Added:
(Prescription.Workout.name prescription)
361
330
(override_note
362
331
@ [
363
Removed:
h2 [ txt (Prescription.Workout.name prescription) ];
364
Removed:
p
332
Added:
tag "h2" [] [ txt "%s" (Prescription.Workout.name prescription) ];
333
Added:
tag "p" []
365
334
[
366
Removed:
txt
367
Removed:
(Printf.sprintf "%d of %d recorded." (List.length performed)
368
Removed:
(List.length (Prescription.Workout.stimuli prescription)));
335
Added:
txt "%d of %d recorded." (List.length performed)
336
Added:
(List.length (Prescription.Workout.stimuli prescription));
369
337
];
370
338
]
371
Removed:
@ (if performed = [] then []
372
Removed:
else
373
Removed:
[
374
Removed:
h2 [ txt "Recorded" ];
375
Removed:
ul (List.map (fun s -> li [ txt (describe_stimulus s) ]) performed);
376
Removed:
])
377
Removed:
@ (if outstanding = [] then
378
Removed:
[ p [ txt "Everything prescribed has been recorded." ] ]
379
Removed:
else
380
Removed:
h2 [ txt "Still to do" ]
381
Removed:
:: List.map
382
Removed:
(fun (slot, p) ->
383
Removed:
match Prescription.Stimulus.delivery p with
384
Removed:
| Prescription.Stimulus.Single _ ->
385
Removed:
single_form ~workout_id ~slot ~prescription:p
386
Removed:
| Prescription.Stimulus.Pre_exhaust { isolation; compound } ->
387
Removed:
pair_form ~workout_id ~slot ~prescription:p ~isolation
388
Removed:
~compound)
389
Removed:
outstanding)
390
339
@
391
Removed:
match record_id with
392
Removed:
| Some _ -> []
393
Removed:
| None ->
394
Removed:
[
395
Removed:
Form.post_form ~service:Routes.finish
396
Removed:
(fun () ->
397
Removed:
[
398
Removed:
Form.input ~input_type:`Submit ~value:"Finish workout"
399
Removed:
Form.string;
400
Removed:
])
401
Removed:
();
402
Removed:
])
340
Added:
if performed = [] then []
341
Added:
else
342
Added:
[
343
Added:
tag "h2" [] [ txt "Recorded" ];
344
Added:
tag "ul" []
345
Added:
(List.map
346
Added:
(fun stimulus ->
347
Added:
tag "li" [] [ txt "%s" (describe_stimulus stimulus) ])
348
Added:
performed);
349
Added:
]
350
Added:
@
351
Added:
if outstanding = [] then
352
Added:
[ tag "p" [] [ txt "Everything prescribed has been recorded." ] ]
353
Added:
else
354
Added:
tag "h2" [] [ txt "Still to do" ]
355
Added:
:: List.map
356
Added:
(fun (slot, prescription) ->
357
Added:
form_for_stimulus ~action_path:(form_action slot) ~prescription
358
Added:
~errors)
359
Added:
outstanding
360
Added:
@
361
Added:
match record_id with
362
Added:
| Some _ -> []
363
Added:
| None ->
364
Added:
[
365
Added:
tag "form"
366
Added:
[
367
Added:
Dream_html.path_attr
368
Added:
(Dream_html.uri_attr "action")
369
Added:
Routes.finish_workout;
370
Added:
Dream_html.string_attr "method" "post";
371
Added:
]
372
Added:
[ void "input" [ type_ "submit"; value "Finish workout" ] ];
373
Added:
])
403
374
404
Removed:
let history ~records =
405
Removed:
shell ~title:"History"
375
Added:
let history records =
376
Added:
html_page "History"
406
377
[
407
Removed:
h2 [ txt "History" ];
408
Removed:
(if records = [] then p [ txt "Nothing logged yet." ]
378
Added:
tag "h2" [] [ txt "History" ];
379
Added:
(if records = [] then tag "p" [] [ txt "Nothing logged yet." ]
409
380
else
410
Removed:
ul
381
Added:
tag "ul" []
411
382
(List.map
412
Removed:
(fun r ->
413
Removed:
let w = r.Repository.workout in
383
Added:
(fun record ->
384
Added:
let workout = record.Repository.workout in
414
385
let status =
415
Removed:
let completeness =
416
Removed:
match Evidence.Workout.completeness w with
417
Removed:
| Evidence.Workout.Complete -> "complete"
418
Removed:
| Incomplete -> "incomplete"
419
Removed:
in
420
Removed:
let ended =
421
Removed:
match Evidence.Workout.ended_at w with
422
Removed:
| None -> "not finished"
423
Removed:
| Some time ->
424
Removed:
Printf.sprintf "ended %d"
425
Removed:
(Recovery.timestamp_to_unix_seconds time)
426
Removed:
in
427
Removed:
ended ^ "; " ^ completeness
386
Added:
match Evidence.Workout.completeness workout with
387
Added:
| Evidence.Workout.Complete -> "complete"
388
Added:
| Incomplete -> "incomplete"
428
389
in
429
Removed:
li
390
Added:
tag "li" []
430
391
[
431
Removed:
txt
432
Removed:
(Printf.sprintf "%s — %d stimuli"
433
Removed:
(Prescription.Workout.name
434
Removed:
(Evidence.Workout.prescription w))
435
Removed:
(List.length (Evidence.Workout.stimuli w)));
436
Removed:
p ~a:[ a_class [ "done" ] ] [ txt status ];
437
Removed:
a ~service:Routes.edit
438
Removed:
[ txt "Edit missing records" ]
439
Removed:
(r.Repository.id :> string);
440
Removed:
ul
441
Removed:
(List.map
442
Removed:
(fun s -> li [ txt (describe_stimulus s) ])
443
Removed:
(Evidence.Workout.stimuli w));
392
Added:
tag "a"
393
Added:
[
394
Added:
Dream_html.path_attr
395
Added:
(Dream_html.uri_attr "href")
396
Added:
Routes.record
397
Added:
(record.Repository.id :> string);
398
Added:
]
399
Added:
[
400
Added:
txt "%s — %d stimuli"
401
Added:
(Prescription.Workout.name
402
Added:
(Evidence.Workout.prescription workout))
403
Added:
(List.length (Evidence.Workout.stimuli workout));
404
Added:
];
405
Added:
tag "p" [ class_ "done" ] [ txt "%s" status ];
444
406
])
445
407
records));
446
408
]
lib/web/pages.mli
@@ -1,8 +1,6 @@
1
Removed:
(** Pure server-rendered pages. *)
2
Removed:
3
1
open Hito_app
4
2
5
Removed:
type page = Html_types.html Eliom_content.Html.elt
3
Added:
type page = Dream_html.node
6
4
7
5
val choose_routine :
8
6
routines:(Repository.routine_id * Prescription.Routine.t) list -> page
@@ -16,12 +14,11 @@
16
14
17
15
val routine : Prescription.Routine.t -> page
18
16
19
Removed:
val recovery_gate :
20
Removed:
routine:Repository.routine_id ->
21
Removed:
workout:Prescription.Workout.t ->
22
Removed:
readiness:Recovery.readiness ->
17
Added:
val workout :
18
Added:
?errors:(string * string) list ->
19
Added:
record_id:string option ->
20
Added:
Evidence.Workout.t ->
23
21
page
24
22
25
Removed:
val log_workout : record_id:string option -> workout:Evidence.Workout.t -> page
26
Removed:
val history : records:Repository.record list -> page
23
Added:
val history : Repository.record list -> page
27
24
val problem : title:string -> detail:string -> page
lib/web/routes.ml
@@ -1,107 +1,14 @@
1
Removed:
(* Route declarations, kept apart from both the pages that link to them and the
2
Removed:
handlers that answer them — otherwise Pages and Services would depend on each
3
Removed:
other.
1
Added:
(* The path values carry format types that are inferred and checked at each use.
2
Added:
Writing an interface for them would add noise without adding safety. *)
4
3
5
Removed:
This module deliberately has no .mli. An Eliom service type carries eleven
6
Removed:
phantom parameters, and restating them per route would cost a great deal of
7
Removed:
noise for no safety: the types are inferred here and checked at every use. *)
8
Removed:
9
Removed:
(* Extensions arrive as form values. Parsing is total and rejects anything the
10
Removed:
form did not offer, rather than silently dropping it. *)
11
Removed:
let extension_of_string = function
12
Removed:
| "" -> Ok None
13
Removed:
| "forced" -> Ok (Some Evidence.Stimulus.Forced_reps)
14
Removed:
| "negatives" -> Ok (Some Evidence.Stimulus.Negatives)
15
Removed:
| "rest-pause" -> Ok (Some Evidence.Stimulus.Rest_pause)
16
Removed:
| "static" -> Ok (Some Evidence.Stimulus.Static_hold)
17
Removed:
| other -> Error other
18
Removed:
19
Removed:
let extension_choices =
20
Removed:
[
21
Removed:
("", "to positive failure");
22
Removed:
("forced", "then forced reps");
23
Removed:
("negatives", "then negatives");
24
Removed:
("rest-pause", "then rest-pause");
25
Removed:
("static", "then a static hold");
26
Removed:
]
27
Removed:
28
Removed:
(* GET / — choose a routine, or resume what is in progress. *)
29
Removed:
let home =
30
Removed:
Eliom_service.create ~path:(Eliom_service.Path [ "" ])
31
Removed:
~meth:(Eliom_service.Get Eliom_parameter.unit) ()
32
Removed:
33
Removed:
(* GET /assets/hito.css — the application stylesheet. *)
34
Removed:
let stylesheet =
35
Removed:
Eliom_service.create
36
Removed:
~path:(Eliom_service.Path [ "assets"; "hito.css" ])
37
Removed:
~meth:(Eliom_service.Get Eliom_parameter.unit) ()
38
Removed:
39
Removed:
(* GET /log — the workout in progress. *)
40
Removed:
let log =
41
Removed:
Eliom_service.create ~path:(Eliom_service.Path [ "log" ])
42
Removed:
~meth:(Eliom_service.Get Eliom_parameter.unit) ()
43
Removed:
44
Removed:
(* GET /history — what has been performed. *)
45
Removed:
let history =
46
Removed:
Eliom_service.create ~path:(Eliom_service.Path [ "history" ])
47
Removed:
~meth:(Eliom_service.Get Eliom_parameter.unit) ()
48
Removed:
49
Removed:
(* POST /begin — the override flag explicitly acknowledges early training. *)
50
Removed:
let begin_workout =
51
Removed:
Eliom_service.create ~path:(Eliom_service.Path [ "begin" ])
52
Removed:
~meth:
53
Removed:
(Eliom_service.Post
54
Removed:
( Eliom_parameter.unit,
55
Removed:
Eliom_parameter.(string "routine" ** bool "override") ))
56
Removed:
()
57
Removed:
58
Removed:
(* POST /log-single — one movement driven to failure.
59
Removed:
60
Removed:
Paths are flat: Eliom treats a path as either a page or a directory, so a
61
Removed:
page at /log cannot coexist with /log/single. *)
62
Removed:
let log_single =
63
Removed:
Eliom_service.create ~path:(Eliom_service.Path [ "log-single" ])
64
Removed:
~meth:
65
Removed:
(Eliom_service.Post
66
Removed:
( Eliom_parameter.unit,
67
Removed:
Eliom_parameter.(
68
Removed:
string "workout" ** int "slot" ** float "load" ** int "reps"
69
Removed:
** string "extension") ))
70
Removed:
()
71
Removed:
72
Removed:
(* POST /log-pair — an isolation carried into a compound, no pause between. *)
73
Removed:
let log_pair =
74
Removed:
Eliom_service.create ~path:(Eliom_service.Path [ "log-pair" ])
75
Removed:
~meth:
76
Removed:
(Eliom_service.Post
77
Removed:
( Eliom_parameter.unit,
78
Removed:
Eliom_parameter.(
79
Removed:
string "workout" ** int "slot" ** float "iso_load"
80
Removed:
** int "iso_reps" ** float "comp_load" ** int "comp_reps"
81
Removed:
** string "extension") ))
82
Removed:
()
83
Removed:
84
Removed:
(* POST /finish — complete and persist. *)
85
Removed:
let finish =
86
Removed:
Eliom_service.create ~path:(Eliom_service.Path [ "finish" ])
87
Removed:
~meth:(Eliom_service.Post (Eliom_parameter.unit, Eliom_parameter.unit))
88
Removed:
()
89
Removed:
90
Removed:
(* GET /routine — active routine details. *)
91
Removed:
let routine =
92
Removed:
Eliom_service.create ~path:(Eliom_service.Path [ "routine" ])
93
Removed:
~meth:(Eliom_service.Get Eliom_parameter.unit) ()
94
Removed:
95
Removed:
(* POST /select-routine — make a routine active without beginning it. *)
96
Removed:
let select_routine =
97
Removed:
Eliom_service.create ~path:(Eliom_service.Path [ "select-routine" ])
98
Removed:
~meth:
99
Removed:
(Eliom_service.Post
100
Removed:
(Eliom_parameter.unit, Eliom_parameter.(string "routine")))
101
Removed:
()
102
Removed:
103
Removed:
(* GET /edit — add prescribed records to a saved workout without changing its end. *)
104
Removed:
let edit =
105
Removed:
Eliom_service.create ~path:(Eliom_service.Path [ "edit" ])
106
Removed:
~meth:(Eliom_service.Get Eliom_parameter.(string "workout"))
107
Removed:
()
4
Added:
let%path home = "/"
5
Added:
let%path routines = "/routines"
6
Added:
let%path select_routine = "/routines/%s/select"
7
Added:
let%path routine = "/routine"
8
Added:
let%path workout = "/workout"
9
Added:
let%path workout_slot = "/workout/slots/%d"
10
Added:
let%path finish_workout = "/workout/finish"
11
Added:
let%path history = "/history"
12
Added:
let%path record = "/history/%s"
13
Added:
let%path record_slot = "/history/%s/slots/%d"
14
Added:
let%path stylesheet = "/assets/hito.css"
lib/web/services.ml
@@ -1,235 +0,0 @@
1
Removed:
open Hito_app
2
Removed:
module Service = Service.Make (Memory_repo)
3
Removed:
4
Removed:
(* One process, one trainee. The store and the workout in progress live for the
5
Removed:
lifetime of the server; nothing survives a restart. Both become per-trainee
6
Removed:
when authentication exists. *)
7
Removed:
let service = Service.make ~repo:(Memory_repo.create ())
8
Removed:
9
Removed:
(* The core is pure and has no clock, so wall-clock time enters here. *)
10
Removed:
let now () =
11
Removed:
Recovery.timestamp_of_unix_seconds (int_of_float (Unix.gettimeofday ()))
12
Removed:
13
Removed:
let home_page () =
14
Removed:
match Service.in_progress service with
15
Removed:
| Some workout -> Pages.log_workout ~record_id:None ~workout
16
Removed:
| None -> (
17
Removed:
match Service.active_routine service with
18
Removed:
| None -> Pages.choose_routine ~routines:(Service.list_routines service)
19
Removed:
| Some (routine, selected) -> (
20
Removed:
match
21
Removed:
( Service.next_workout service ~routine,
22
Removed:
Service.readiness service ~routine ~now:(now ()) )
23
Removed:
with
24
Removed:
| Ok next, Ok readiness ->
25
Removed:
Pages.home ~routine
26
Removed:
~routine_name:(Prescription.Routine.name selected)
27
Removed:
~next ~readiness
28
Removed:
| Error error, _ | _, Error error ->
29
Removed:
Pages.problem ~title:"Routine unavailable"
30
Removed:
~detail:(Format.asprintf "%a" Service.pp_error error)))
31
Removed:
32
Removed:
let stylesheet =
33
Removed:
match Stylesheet.read "hito.css" with
34
Removed:
| Some stylesheet -> stylesheet
35
Removed:
| None -> failwith "Embedded stylesheet hito.css is missing"
36
Removed:
37
Removed:
let register () =
38
Removed:
Eliom_registration.CssText.register ~service:Routes.stylesheet (fun () () ->
39
Removed:
Lwt.return stylesheet);
40
Removed:
41
Removed:
Eliom_registration.Html.register ~service:Routes.home (fun () () ->
42
Removed:
Lwt.return (home_page ()));
43
Removed:
44
Removed:
Eliom_registration.Html.register ~service:Routes.select_routine
45
Removed:
(fun () routine ->
46
Removed:
let routine = Repository.routine_id routine in
47
Removed:
Lwt.return
48
Removed:
(match Service.select_routine service routine with
49
Removed:
| Ok () -> home_page ()
50
Removed:
| Error error ->
51
Removed:
Pages.problem ~title:"Unknown routine"
52
Removed:
~detail:(Format.asprintf "%a" Service.pp_error error)));
53
Removed:
54
Removed:
Eliom_registration.Html.register ~service:Routes.routine (fun () () ->
55
Removed:
Lwt.return
56
Removed:
(match Service.active_routine service with
57
Removed:
| None -> Pages.choose_routine ~routines:(Service.list_routines service)
58
Removed:
| Some (_, routine) -> Pages.routine routine));
59
Removed:
60
Removed:
Eliom_registration.Html.register ~service:Routes.log (fun () () ->
61
Removed:
Lwt.return
62
Removed:
(match Service.in_progress service with
63
Removed:
| Some workout -> Pages.log_workout ~record_id:None ~workout
64
Removed:
| None ->
65
Removed:
Pages.problem ~title:"No workout in progress"
66
Removed:
~detail:"Choose a routine to begin one."));
67
Removed:
68
Removed:
Eliom_registration.Html.register ~service:Routes.history (fun () () ->
69
Removed:
Lwt.return (Pages.history ~records:(Service.history service)));
70
Removed:
71
Removed:
(* The recovery gate requires a separate explicit override action. *)
72
Removed:
Eliom_registration.Html.register ~service:Routes.begin_workout
73
Removed:
(fun () (routine, override) ->
74
Removed:
let routine = Repository.routine_id routine in
75
Removed:
let override = if override then Some () else None in
76
Removed:
Lwt.return
77
Removed:
(match
78
Removed:
Service.begin_workout service ~routine ~now:(now ()) ?override ()
79
Removed:
with
80
Removed:
| Ok workout -> Pages.log_workout ~record_id:None ~workout
81
Removed:
| Error (Service.Not_recovered readiness) -> (
82
Removed:
match Service.next_workout service ~routine with
83
Removed:
| Ok workout -> Pages.recovery_gate ~routine ~workout ~readiness
84
Removed:
| Error _ ->
85
Removed:
Pages.problem ~title:"Unknown routine"
86
Removed:
~detail:"That routine is not in the catalogue.")
87
Removed:
| Error Service.Unknown_routine ->
88
Removed:
Pages.problem ~title:"Unknown routine"
89
Removed:
~detail:"That routine is not in the catalogue."));
90
Removed:
91
Removed:
let build_movement ~exercise ~load ~reps ~extension =
92
Removed:
let outcome =
93
Removed:
match extension with
94
Removed:
| None -> Evidence.Stimulus.Positive_failure
95
Removed:
| Some e -> Evidence.Stimulus.Beyond_failure (e, [])
96
Removed:
in
97
Removed:
try
98
Removed:
Ok
99
Removed:
(Evidence.Stimulus.Movement.make ~exercise ~load_kg:load ~reps ~outcome)
100
Removed:
with
101
Removed:
| Evidence.Stimulus.Movement.Invalid Invalid_load ->
102
Removed:
Error "Load must be finite and nonnegative."
103
Removed:
| Evidence.Stimulus.Movement.Invalid Invalid_reps ->
104
Removed:
Error "Reps must be positive."
105
Removed:
in
106
Removed:
107
Removed:
(* The slot names which prescribed stimulus is being answered. *)
108
Removed:
let target_workout workout_id =
109
Removed:
if workout_id = "" then
110
Removed:
Option.map (fun workout -> (None, workout)) (Service.in_progress service)
111
Removed:
else
112
Removed:
Service.find_record service (Repository.workout_id workout_id)
113
Removed:
|> Option.map (fun record ->
114
Removed:
(Some record.Repository.id, record.Repository.workout))
115
Removed:
in
116
Removed:
let prescribed_at workout_id slot =
117
Removed:
match target_workout workout_id with
118
Removed:
| None -> None
119
Removed:
| Some (record_id, workout) ->
120
Removed:
List.assoc_opt slot (Evidence.Workout.outstanding workout)
121
Removed:
|> Option.map (fun p -> (record_id, p))
122
Removed:
in
123
Removed:
let save_stimulus record_id stimulus =
124
Removed:
match record_id with
125
Removed:
| None ->
126
Removed:
Lwt.return
127
Removed:
(match Service.log service stimulus with
128
Removed:
| Ok workout -> Pages.log_workout ~record_id:None ~workout
129
Removed:
| Error Service.No_workout_in_progress ->
130
Removed:
Pages.problem ~title:"No workout in progress"
131
Removed:
~detail:"Choose a routine to begin one."
132
Removed:
| Error (Service.Rejected error) ->
133
Removed:
Pages.problem ~title:"That is not what was prescribed"
134
Removed:
~detail:(Format.asprintf "%a" Evidence.Workout.pp_error error))
135
Removed:
| Some id ->
136
Removed:
Lwt.return
137
Removed:
(match Service.add_to_record service id stimulus with
138
Removed:
| Ok record ->
139
Removed:
Pages.log_workout
140
Removed:
~record_id:(Some (record.Repository.id :> string))
141
Removed:
~workout:record.Repository.workout
142
Removed:
| Error Service.Unknown_workout ->
143
Removed:
Pages.problem ~title:"Unknown workout"
144
Removed:
~detail:"That saved workout no longer exists."
145
Removed:
| Error (Service.Rejected_edit error) ->
146
Removed:
Pages.problem ~title:"That is not what was prescribed"
147
Removed:
~detail:(Format.asprintf "%a" Evidence.Workout.pp_error error))
148
Removed:
in
149
Removed:
150
Removed:
Eliom_registration.Html.register ~service:Routes.log_single
151
Removed:
(fun () (workout_id, (slot, (load, (reps, extension)))) ->
152
Removed:
match
153
Removed:
(Routes.extension_of_string extension, prescribed_at workout_id slot)
154
Removed:
with
155
Removed:
| Error bad, _ ->
156
Removed:
Lwt.return
157
Removed:
(Pages.problem ~title:"Unrecognised ending"
158
Removed:
~detail:
159
Removed:
(Printf.sprintf "%S is not one of the offered choices." bad))
160
Removed:
| Ok _, None ->
161
Removed:
Lwt.return
162
Removed:
(Pages.problem ~title:"No such outstanding stimulus"
163
Removed:
~detail:"That slot is not awaiting a record.")
164
Removed:
| Ok extension, Some (record_id, prescription) -> (
165
Removed:
match Prescription.Stimulus.delivery prescription with
166
Removed:
| Prescription.Stimulus.Pre_exhaust _ ->
167
Removed:
Lwt.return
168
Removed:
(Pages.problem ~title:"That slot prescribes a pair"
169
Removed:
~detail:
170
Removed:
"A pre-exhaust pair cannot be recorded as a single set.")
171
Removed:
| Prescription.Stimulus.Single exercise -> (
172
Removed:
match build_movement ~exercise ~load ~reps ~extension with
173
Removed:
| Error detail ->
174
Removed:
Lwt.return (Pages.problem ~title:"Unusable figures" ~detail)
175
Removed:
| Ok movement ->
176
Removed:
save_stimulus record_id
177
Removed:
(Evidence.Stimulus.make (Evidence.Stimulus.Single movement))
178
Removed:
)));
179
Removed:
180
Removed:
Eliom_registration.Html.register ~service:Routes.log_pair
181
Removed:
(fun
182
Removed:
()
183
Removed:
( workout_id,
184
Removed:
(slot, (iso_load, (iso_reps, (comp_load, (comp_reps, extension))))) )
185
Removed:
->
186
Removed:
match
187
Removed:
(Routes.extension_of_string extension, prescribed_at workout_id slot)
188
Removed:
with
189
Removed:
| Error bad, _ ->
190
Removed:
Lwt.return
191
Removed:
(Pages.problem ~title:"Unrecognised ending"
192
Removed:
~detail:
193
Removed:
(Printf.sprintf "%S is not one of the offered choices." bad))
194
Removed:
| Ok _, None ->
195
Removed:
Lwt.return
196
Removed:
(Pages.problem ~title:"No such outstanding stimulus"
197
Removed:
~detail:"That slot is not awaiting a record.")
198
Removed:
| Ok extension, Some (record_id, prescription) -> (
199
Removed:
match Prescription.Stimulus.delivery prescription with
200
Removed:
| Prescription.Stimulus.Single _ ->
201
Removed:
Lwt.return
202
Removed:
(Pages.problem ~title:"That slot prescribes a single set"
203
Removed:
~detail:"Only a pre-exhaust slot takes two movements.")
204
Removed:
| Prescription.Stimulus.Pre_exhaust { isolation; compound } -> (
205
Removed:
match
206
Removed:
( build_movement ~exercise:isolation ~load:iso_load
207
Removed:
~reps:iso_reps ~extension:None,
208
Removed:
build_movement ~exercise:compound ~load:comp_load
209
Removed:
~reps:comp_reps ~extension )
210
Removed:
with
211
Removed:
| Error detail, _ | _, Error detail ->
212
Removed:
Lwt.return (Pages.problem ~title:"Unusable figures" ~detail)
213
Removed:
| Ok first, Ok second ->
214
Removed:
save_stimulus record_id
215
Removed:
(Evidence.Stimulus.make
216
Removed:
(Evidence.Stimulus.Pair { first; second })))));
217
Removed:
218
Removed:
Eliom_registration.Html.register ~service:Routes.edit (fun workout_id () ->
219
Removed:
let id = Repository.workout_id workout_id in
220
Removed:
Lwt.return
221
Removed:
(match Service.find_record service id with
222
Removed:
| Some record ->
223
Removed:
Pages.log_workout ~record_id:(Some workout_id)
224
Removed:
~workout:record.Repository.workout
225
Removed:
| None ->
226
Removed:
Pages.problem ~title:"Unknown workout"
227
Removed:
~detail:"That saved workout no longer exists."));
228
Removed:
229
Removed:
Eliom_registration.Html.register ~service:Routes.finish (fun () () ->
230
Removed:
match Service.finish service ~ended_at:(now ()) with
231
Removed:
| Some _ -> Lwt.return (Pages.history ~records:(Service.history service))
232
Removed:
| None ->
233
Removed:
Lwt.return
234
Removed:
(Pages.problem ~title:"No workout in progress"
235
Removed:
~detail:"There was nothing to finish."))
lib/web/services.mli
@@ -1,6 +0,0 @@
1
Removed:
(** Eliom services for the single-user HD flow. Only {!register} is exposed: the
2
Removed:
service values' phantom types are an implementation detail. *)
3
Removed:
4
Removed:
val register : unit -> unit
5
Removed:
(** Register every handler. Called once by the launcher, before the server
6
Removed:
starts. *)
ocsidb
Binary files differ
test/dune
@@ -7,5 +7,7 @@
7
7
test_prescription
8
8
test_evidence
9
9
test_progression
10
Removed:
test_service)
11
Removed:
(libraries hito.core hito.app alcotest))
10
Added:
test_service
11
Added:
test_decode
12
Added:
test_web)
13
Added:
(libraries hito.core hito.app hito.web alcotest dream dream-html))
test/test_decode.ml
@@ -0,0 +1,54 @@
1
Added:
module Decode = Hito_web.Decode
2
Added:
module Form = Dream_html.Form
3
Added:
4
Added:
let exercise id =
5
Added:
match Exercise.find id with
6
Added:
| Some exercise -> exercise
7
Added:
| None -> Alcotest.failf "catalog is missing %S" id
8
Added:
9
Added:
let single =
10
Added:
Prescription.Stimulus.make
11
Added:
~delivery:(Prescription.Stimulus.Single (exercise "laterals"))
12
Added:
~rep_range:(6, 10) ~allowed_substitutes:[]
13
Added:
14
Added:
let stimulus_tests =
15
Added:
[
16
Added:
( "decoder",
17
Added:
[
18
Added:
( "accepts a single working stimulus",
19
Added:
`Quick,
20
Added:
fun () ->
21
Added:
match
22
Added:
Form.validate (Decode.stimulus single)
23
Added:
[ ("load", "30"); ("reps", "8"); ("extension", "") ]
24
Added:
with
25
Added:
| Ok _ -> ()
26
Added:
| Error errors ->
27
Added:
Alcotest.failf "unexpected validation errors: %a" Form.pp_error
28
Added:
errors );
29
Added:
( "rejects an unknown extension",
30
Added:
`Quick,
31
Added:
fun () ->
32
Added:
match
33
Added:
Form.validate (Decode.stimulus single)
34
Added:
[ ("load", "30"); ("reps", "8"); ("extension", "invented") ]
35
Added:
with
36
Added:
| Error [ ("extension", "error.extension") ] -> ()
37
Added:
| Error errors ->
38
Added:
Alcotest.failf "unexpected errors: %a" Form.pp_error errors
39
Added:
| Ok _ -> Alcotest.fail "expected extension validation failure" );
40
Added:
( "rejects a negative load",
41
Added:
`Quick,
42
Added:
fun () ->
43
Added:
match
44
Added:
Form.validate (Decode.stimulus single)
45
Added:
[ ("load", "-1"); ("reps", "8"); ("extension", "") ]
46
Added:
with
47
Added:
| Error [ ("load", "error.range") ] -> ()
48
Added:
| Error errors ->
49
Added:
Alcotest.failf "unexpected errors: %a" Form.pp_error errors
50
Added:
| Ok _ -> Alcotest.fail "expected load validation failure" );
51
Added:
] );
52
Added:
]
53
Added:
54
Added:
let suite = stimulus_tests
test/test_evidence.ml
@@ -2,6 +2,7 @@
2
2
3
3
module Stimulus = Evidence.Stimulus
4
4
module Workout = Evidence.Workout
5
Added:
module Feedback = Evidence.Feedback
5
6
module Log = Evidence.Log
6
7
7
8
let ok = function Ok v -> v | Error _ -> Alcotest.fail "expected Ok"
test/test_hito.ml
@@ -7,4 +7,5 @@
7
7
let () =
8
8
Alcotest.run "hito"
9
9
(Test_exercise.suite @ Test_recovery.suite @ Test_prescription.suite
10
Removed:
@ Test_evidence.suite @ Test_progression.suite @ Test_service.suite)
10
Added:
@ Test_evidence.suite @ Test_progression.suite @ Test_service.suite
11
Added:
@ Test_decode.suite @ Test_web.suite)
test/test_web.ml
@@ -0,0 +1,18 @@
1
Added:
let app () =
2
Added:
Hito_web.Handlers.create () |> Hito_web.Handlers.routes |> Dream.router
3
Added:
4
Added:
let route_tests =
5
Added:
[
6
Added:
( "web",
7
Added:
[
8
Added:
( "home serves the routine catalog before selection",
9
Added:
`Quick,
10
Added:
fun () ->
11
Added:
let response = Dream.test (app ()) (Dream.request "") in
12
Added:
Alcotest.(check int)
13
Added:
"status" 200
14
Added:
(Dream.status response |> Dream.status_to_int) );
15
Added:
] );
16
Added:
]
17
Added:
18
Added:
let suite = route_tests