[OCaml] High Intensity Training Online
feat reinstate hito.app, and serve a page from a standalone binary
Two tiers come back to life. hito.core has been usable only from tests until now. The service owns recovery policy. Entry.start demands a Recovery.clearance, and Service is the only thing that decides how one is obtained: earned by resting, or taken through begin_workout's ?override with a stated reason that stays on the record and reaches Progression.diagnose. Putting the policy here rather than in a client means the planned native app cannot quietly adopt looser rules than the web one. log gets its own error type. Reusing Entry.error would have reported "already finished" when in fact no workout was in progress, which is a different situation and would mislead the UI. Repository.save now takes an Entry.t and returns the record, so the adapter assigns identity instead of callers inventing it — the reason the port exists. The web tier is server-rendered only: no client-side OCaml, so no eliom ppx, no js_of_ocaml, and Eliom_registration.Html rather than the App functor. lib/web/app.{ml,mli} is deleted rather than fixed, since no client program is launched. Better still, the server needs no XML configuration and no dynamically loaded .cmxs: Eliom.run yields an Ocsigen_server.instruction, documented for exactly this, so bin/main.ml starts ocsigenserver programmatically and binds loopback only. There is NO AUTHENTICATION; the binding is deliberate and this must not be exposed beyond localhost. Required installing ocsipersist-sqlite: eliom.server depends on the virtual ocsipersist library, which had no implementation in the switch. It is needed only at link time, in bin. 132 Alcotests, 14 of them driving the whole HD flow through Service with no web tier: rotation, refusal when under-recovered, override with a reason, logging Day 1 in full, and a stall detected across three cycles.
Changed files
- bin/dune
- bin/main.ml
- lib/app/dune
- lib/app/dune.disabled
- lib/app/memory_repo.ml
- lib/app/memory_repo.mli
- lib/app/repository.ml
- lib/app/repository.mli
- lib/app/service.ml
- lib/app/service.mli
- lib/web/app.ml
- lib/web/app.mli
- lib/web/dune
- lib/web/dune.disabled
- lib/web/pages.ml
- lib/web/pages.mli
- lib/web/services.ml
- lib/web/services.mli
- ocsidb
- test/dune
- test/test_hito.ml
- test/test_service.ml
bin/dune
@@ -1,4 +1,7 @@
1
Added:
; ocsipersist-sqlite supplies the implementation of eliom's virtual
2
Added:
; ocsipersist dependency; it is only needed at link time, here.
3
Added:
1
4
(executable
2
5
(public_name hito)
3
6
(name main)
4
Removed:
(libraries hito.core))
7
Added:
(libraries hito.web eliom.server ocsigenserver ocsipersist-sqlite unix))
bin/main.ml
@@ -1,3 +1,27 @@
1
Removed:
(* Placeholder entry point. This becomes the Ocsigen server launcher once the
2
Removed:
web tier is implemented. *)
3
Removed:
let () = print_endline "hito"
1
Added:
(* Launcher. Ocsigenserver is started programmatically rather than through an
2
Added:
XML configuration file, so there is nothing to keep in sync and no .cmxs to
3
Added:
load dynamically — see Eliom.run, which exists for exactly this.
4
Added:
5
Added:
NO AUTHENTICATION. The socket is bound to loopback only, deliberately: any
6
Added:
process on this machine can read and write the training log, and anything
7
Added:
beyond localhost dogfooding needs authentication first. *)
8
Added:
9
Added:
let port = 8080
10
Added:
let runtime_dir = Filename.concat (Filename.get_temp_dir_name ()) "hito"
11
Added:
12
Added:
let () =
13
Added:
Hito_web.Services.register ();
14
Added:
let dir sub =
15
Added:
let d = Filename.concat runtime_dir sub in
16
Added:
(try Unix.mkdir runtime_dir 0o700 with Unix.Unix_error _ -> ());
17
Added:
(try Unix.mkdir d 0o700 with Unix.Unix_error _ -> ());
18
Added:
d
19
Added:
in
20
Added:
Printf.printf "hito listening on http://localhost:%d/ (no authentication)\n%!"
21
Added:
port;
22
Added:
Ocsigen_server.start
23
Added:
~ports:[ (`IPv4 Unix.inet_addr_loopback, port) ]
24
Added:
~logdir:(dir "log") ~datadir:(dir "data")
25
Added:
~command_pipe:(Filename.concat runtime_dir "cmd")
26
Added:
~veryverbose:()
27
Added:
[ Ocsigen_server.host [ Ocsigen_server.site [] [ Eliom.run () ] ] ]
lib/app/dune
@@ -0,0 +1,4 @@
1
Added:
(library
2
Added:
(name hito_app)
3
Added:
(public_name hito.app)
4
Added:
(libraries hito.core))
lib/app/dune.disabled
@@ -1,4 +0,0 @@
1
Removed:
(library
2
Removed:
(name hito_app)
3
Removed:
(public_name hito.app)
4
Removed:
(libraries hito.core))
lib/app/memory_repo.ml
@@ -1,10 +1,28 @@
1
Removed:
(* Minimal stubs only; implementation deferred until after the review gate. *)
1
Added:
type t = {
2
Added:
routines : (Repository.routine_id * Routine.t) list;
3
Added:
mutable log : Logbook.t;
4
Added:
mutable stored : Repository.record list; (* most recent first *)
5
Added:
mutable next_id : int;
6
Added:
}
2
7
3
Removed:
type t = unit
8
Added:
let create () =
9
Added:
{
10
Added:
routines = [ (Repository.routine_id "ideal", Routine.ideal_routine) ];
11
Added:
log = Logbook.empty;
12
Added:
stored = [];
13
Added:
next_id = 1;
14
Added:
}
4
15
5
Removed:
let create () = failwith "TODO"
6
Removed:
let list_routines _ = failwith "TODO"
7
Removed:
let find_routine _ _ = failwith "TODO"
8
Removed:
let save _ _ = failwith "TODO"
9
Removed:
let logbook _ = failwith "TODO"
10
Removed:
let history _ = failwith "TODO"
16
Added:
let list_routines t = t.routines
17
Added:
let find_routine t id = List.assoc_opt id t.routines
18
Added:
19
Added:
let save t entry =
20
Added:
let id = Repository.workout_id (Printf.sprintf "w%d" t.next_id) in
21
Added:
let record = { Repository.id; entry } in
22
Added:
t.next_id <- t.next_id + 1;
23
Added:
t.log <- Logbook.add t.log entry;
24
Added:
t.stored <- record :: t.stored;
25
Added:
record
26
Added:
27
Added:
let logbook t = t.log
28
Added:
let history t = t.stored
lib/app/memory_repo.mli
@@ -1,6 +1,7 @@
1
Removed:
(** In-memory {!Repository.S} adapter for development and tests. *)
1
Added:
(** In-memory {!Repository.S} for dogfooding and tests. Nothing survives a
2
Added:
restart. *)
2
3
3
4
include Repository.S
4
5
5
6
val create : unit -> t
6
Removed:
(** A fresh repository seeded with the Heavy Duty preset routines. *)
7
Added:
(** Seeded with HD1's Ideal Routine, the one preset the book supports. *)
lib/app/repository.ml
@@ -1,19 +1,18 @@
1
Removed:
(* Minimal stubs only; implementation deferred until after the review gate. *)
2
Removed:
3
1
type routine_id = string
4
2
type workout_id = string
5
3
6
4
let routine_id s = s
7
5
let workout_id s = s
8
6
9
Removed:
type record = { id : workout_id; entry : Logbook.Entry.t } [@@warning "-69"]
7
Added:
(* Fields are reached through the module type, not from here. *)
8
Added:
type record = { id : workout_id; entry : Entry.t } [@@warning "-69"]
10
9
11
10
module type S = sig
12
11
type t
13
12
14
13
val list_routines : t -> (routine_id * Routine.t) list
15
14
val find_routine : t -> routine_id -> Routine.t option
16
Removed:
val save : t -> record -> unit
15
Added:
val save : t -> Entry.t -> record
17
16
val logbook : t -> Logbook.t
18
17
val history : t -> record list
19
18
end
lib/app/repository.mli
@@ -1,25 +1,30 @@
1
Removed:
(** Persistence port for the application layer. Pure module type: no database,
2
Removed:
no Eliom. Identity is assigned here, since the pure core carries none. *)
1
Added:
(** Persistence port. A pure module type: no database, no Eliom.
3
2
3
Added:
Identity lives here rather than in the core, which carries none — a routine
4
Added:
or a stored workout needs a name only once something has to remember it. *)
5
Added:
4
6
type routine_id = private string
5
7
type workout_id = private string
6
8
7
9
val routine_id : string -> routine_id
8
10
val workout_id : string -> workout_id
9
11
10
Removed:
type record = { id : workout_id; entry : Logbook.Entry.t }
11
Removed:
(** A stored logbook entry. The entry already knows when it finished and which
12
Removed:
prescription it was performed against. *)
12
Added:
type record = { id : workout_id; entry : Entry.t }
13
Added:
(** A stored workout. The entry already knows its prescription, its timestamps,
14
Added:
and the basis on which it was begun. *)
13
15
14
16
module type S = sig
15
17
type t
16
18
17
19
val list_routines : t -> (routine_id * Routine.t) list
18
20
val find_routine : t -> routine_id -> Routine.t option
19
Removed:
val save : t -> record -> unit
20
21
22
Added:
val save : t -> Entry.t -> record
23
Added:
(** Store the entry under an identity the adapter assigns. Callers do not
24
Added:
invent identifiers. *)
25
Added:
21
26
val logbook : t -> Logbook.t
22
Removed:
(** The stored log, from which evidence is derived. *)
27
Added:
(** The stored log — the only source of evidence. *)
23
28
24
29
val history : t -> record list
25
30
(** Most recent first. *)
lib/app/service.ml
@@ -1,16 +1,103 @@
1
Removed:
(* Minimal stubs only; implementation deferred until after the review gate. *)
2
Removed:
3
1
module Make (R : Repository.S) = struct
4
Removed:
type t = { repo : R.t } [@@warning "-69"]
2
Added:
type t = { repo : R.t; mutable current : Entry.t option }
5
3
6
Removed:
let make ~repo = { repo }
7
Removed:
let list_routines _ = failwith "TODO"
4
Added:
let make ~repo = { repo; current = None }
5
Added:
let list_routines t = R.list_routines t.repo
8
6
9
Removed:
type error = Unknown_routine
7
Added:
type error = Unknown_routine | Not_recovered of Recovery.readiness
10
8
11
Removed:
let prescribe _ ~routine:_ ~now:_ = failwith "TODO"
12
Removed:
let start _ ~started_at:_ = failwith "TODO"
13
Removed:
let log_group _ _ = failwith "TODO"
14
Removed:
let finish _ _ ~ended_at:_ = failwith "TODO"
15
Removed:
let history _ = failwith "TODO"
9
Added:
let pp_error ppf = function
10
Added:
| Unknown_routine -> Format.pp_print_string ppf "no such routine"
11
Added:
| Not_recovered readiness ->
12
Added:
Format.fprintf ppf "not recovered: %a" Recovery.pp_readiness readiness
13
Added:
14
Added:
let routine t id =
15
Added:
match R.find_routine t.repo id with
16
Added:
| Some r -> Ok r
17
Added:
| None -> Error Unknown_routine
18
Added:
19
Added:
(* Where the cycle stands. With nothing logged, start at the beginning. *)
20
Added:
let next_of routine log =
21
Added:
match Logbook.last_prescription log with
22
Added:
| Some last -> Routine.workout_after routine last
23
Added:
| None -> List.hd (Routine.workouts routine)
24
Added:
25
Added:
let next_workout t ~routine:id =
26
Added:
Result.map (fun r -> next_of r (R.logbook t.repo)) (routine t id)
27
Added:
28
Added:
(* How long HD1 asks you to rest depends on where in the cycle you are, so
29
Added:
the recommendation comes from the last workout performed. *)
30
Added:
let recommended routine log =
31
Added:
match Logbook.last_prescription log with
32
Added:
| Some last -> Routine.recovery_after routine last
33
Added:
| None -> Routine.training_interval
34
Added:
35
Added:
let readiness t ~routine:id ~now =
36
Added:
Result.map
37
Added:
(fun r ->
38
Added:
let log = R.logbook t.repo in
39
Added:
Logbook.readiness log ~now ~recommended:(recommended r log))
40
Added:
(routine t id)
41
Added:
42
Added:
let begin_workout t ~routine:id ~now ?override () =
43
Added:
match routine t id with
44
Added:
| Error e -> Error e
45
Added:
| Ok r -> (
46
Added:
let log = R.logbook t.repo in
47
Added:
let readiness =
48
Added:
Logbook.readiness log ~now ~recommended:(recommended r log)
49
Added:
in
50
Added:
let clearance =
51
Added:
match (Recovery.clear readiness, override) with
52
Added:
| Some c, _ -> Some c
53
Added:
| None, Some reason -> Some (Recovery.override readiness ~reason)
54
Added:
| None, None -> None
55
Added:
in
56
Added:
match clearance with
57
Added:
| None -> Error (Not_recovered readiness)
58
Added:
| Some clearance ->
59
Added:
let entry =
60
Added:
Entry.start (next_of r log) ~clearance ~started_at:now
61
Added:
in
62
Added:
t.current <- Some entry;
63
Added:
Ok entry)
64
Added:
65
Added:
let in_progress t = t.current
66
Added:
67
Added:
type log_error = No_workout_in_progress | Rejected of Entry.error
68
Added:
69
Added:
let pp_log_error ppf = function
70
Added:
| No_workout_in_progress ->
71
Added:
Format.pp_print_string ppf "no workout in progress"
72
Added:
| Rejected e -> Entry.pp_error ppf e
73
Added:
74
Added:
let log t stimulus =
75
Added:
match t.current with
76
Added:
| None -> Error No_workout_in_progress
77
Added:
| Some entry -> (
78
Added:
match Entry.add_stimulus entry stimulus with
79
Added:
| Error e -> Error (Rejected e)
80
Added:
| Ok updated ->
81
Added:
t.current <- Some updated;
82
Added:
Ok updated)
83
Added:
84
Added:
let finish t ~ended_at =
85
Added:
match t.current with
86
Added:
| None -> None
87
Added:
| Some entry ->
88
Added:
(* [current] only ever holds an unfinished entry — it is cleared the
89
Added:
moment one is finished — so this cannot fail. *)
90
Added:
let finished =
91
Added:
Result.value (Entry.finish entry ~ended_at) ~default:entry
92
Added:
in
93
Added:
let record = R.save t.repo finished in
94
Added:
t.current <- None;
95
Added:
Some record
96
Added:
97
Added:
let history t = R.history t.repo
98
Added:
99
Added:
let progress t exercise =
100
Added:
Progression.assess (Logbook.evidence (R.logbook t.repo) exercise)
101
Added:
102
Added:
let diagnostics t = Progression.diagnose (Logbook.entries (R.logbook t.repo))
16
103
end
lib/app/service.mli
@@ -1,36 +1,73 @@
1
Removed:
(** Application service: orchestrates the core over a {!Repository.S}. The API
2
Removed:
the web (and future native) layer calls; no Eliom or serialization concerns.
3
Removed:
Recovery gating is informational — the caller decides whether to proceed on
4
Removed:
an early workout, since the core no longer gates it. *)
1
Added:
(** Application service: orchestrates the core over a {!Repository.S}. The API a
2
Added:
client calls — no Eliom, no HTML, no serialization.
5
3
4
Added:
Recovery gating lives here, not in the client. {!Entry.start} demands a
5
Added:
{!Recovery.clearance}, and this module is the only thing that decides how
6
Added:
one is obtained: earned by having rested, or taken deliberately through
7
Added:
{!begin_workout}'s [?override] with a stated reason. Putting that policy
8
Added:
here means a native client cannot quietly adopt looser rules than the web
9
Added:
one. *)
10
Added:
6
11
module Make (R : Repository.S) : sig
7
12
type t
8
13
9
14
val make : repo:R.t -> t
15
Added:
(** [repo] is the store this service reads and writes. *)
16
Added:
10
17
val list_routines : t -> (Repository.routine_id * Routine.t) list
11
18
12
Removed:
type error = Unknown_routine
19
Added:
type error =
20
Added:
| Unknown_routine
21
Added:
| Not_recovered of Recovery.readiness
22
Added:
(** Refused: recovery is incomplete and no reason was given. Carries the
23
Added:
reading so a client can say how much longer. *)
13
24
14
Removed:
val prescribe :
25
Added:
val pp_error : Format.formatter -> error -> unit
26
Added:
27
Added:
val next_workout :
28
Added:
t -> routine:Repository.routine_id -> (Workout_prescription.t, error) result
29
Added:
(** Where the cycle stands: the workout after the last one logged. *)
30
Added:
31
Added:
val readiness :
15
32
t ->
16
33
routine:Repository.routine_id ->
17
34
now:Recovery.timestamp ->
18
Removed:
(Workout_prescription.t * Recovery.readiness, error) result
19
Removed:
(** The routine's next workout, selected by rotation from the stored logbook's
20
Removed:
last prescription, alongside current readiness so the caller can warn
21
Removed:
before logging begins. *)
35
Added:
(Recovery.readiness, error) result
22
36
23
Removed:
val start :
24
Removed:
Workout_prescription.t -> started_at:Recovery.timestamp -> Logbook.Entry.t
37
Added:
val begin_workout :
38
Added:
t ->
39
Added:
routine:Repository.routine_id ->
40
Added:
now:Recovery.timestamp ->
41
Added:
?override:string ->
42
Added:
unit ->
43
Added:
(Entry.t, error) result
44
Added:
(** Start the next workout. [Error (Not_recovered _)] unless recovery is
45
Added:
complete or [?override] states why you are training anyway; the reason is
46
Added:
kept with the entry and reaches {!Progression.diagnose}. *)
25
47
26
Removed:
val log_group :
27
Removed:
Logbook.Entry.t ->
28
Removed:
Set_group.t ->
29
Removed:
(Logbook.Entry.t, Logbook.Entry.error) result
48
Added:
val in_progress : t -> Entry.t option
49
Added:
(** The workout being logged, if any. Single-user: one slot for the whole
50
Added:
server. This must become per-trainee before authentication exists. *)
30
51
31
Removed:
val finish :
32
Removed:
t -> Logbook.Entry.t -> ended_at:Recovery.timestamp -> Repository.record
33
Removed:
(** Complete, persist, and return the stored record. *)
52
Added:
type log_error =
53
Added:
| No_workout_in_progress
54
Added:
| Rejected of Entry.error
55
Added:
(** The workout refused the stimulus; see {!Entry.error}. *)
34
56
57
Added:
val pp_log_error : Format.formatter -> log_error -> unit
58
Added:
59
Added:
val log : t -> Stimulus.t -> (Entry.t, log_error) result
60
Added:
(** Record a stimulus against the workout in progress. *)
61
Added:
62
Added:
val finish : t -> ended_at:Recovery.timestamp -> Repository.record option
63
Added:
(** Complete and persist the workout in progress, clearing the slot. [None] if
64
Added:
nothing was in progress. *)
65
Added:
35
66
val history : t -> Repository.record list
67
Added:
68
Added:
val progress :
69
Added:
t -> Exercise.t -> (Progression.assessment, Progression.error) result
70
Added:
71
Added:
val diagnostics : t -> Progression.diagnostic list
72
Added:
(** Habits the record shows that HD1 names as causes of overtraining. *)
36
73
end
lib/web/app.ml
@@ -1,7 +0,0 @@
1
Removed:
(* The Eliom application. APP_PARAM (installed Eliom 12.1.0) requires
2
Removed:
application_name and global_data_path. *)
3
Removed:
4
Removed:
include Eliom_registration.App (struct
5
Removed:
let application_name = "hito"
6
Removed:
let global_data_path = None
7
Removed:
end)
lib/web/app.mli
@@ -1,3 +0,0 @@
1
Removed:
(** The Eliom client-server application instance for hito. *)
2
Removed:
3
Removed:
include Eliom_registration.APP
lib/web/dune
@@ -0,0 +1,8 @@
1
Added:
; Server-rendered only: no client-side OCaml, so no eliom ppx and no
2
Added:
; js_of_ocaml. Pages are plain HTML from Eliom_registration.Html.
3
Added:
4
Added:
(library
5
Added:
(name hito_web)
6
Added:
(public_name hito.web)
7
Added:
(modules services)
8
Added:
(libraries hito.core eliom.server))
lib/web/dune.disabled
@@ -1,6 +0,0 @@
1
Removed:
(library
2
Removed:
(name hito_web)
3
Removed:
(public_name hito.web)
4
Removed:
(libraries hito.core hito.app eliom.server)
5
Removed:
(preprocess
6
Removed:
(pps eliom.ppx.server)))
lib/web/pages.ml
@@ -1,6 +0,0 @@
1
Removed:
(* Minimal stubs only; implementation deferred until after the review gate. *)
2
Removed:
3
Removed:
let choose_routine ~routines:_ = failwith "TODO"
4
Removed:
let log_workout ~entry:_ = failwith "TODO"
5
Removed:
let history ~records:_ = failwith "TODO"
6
Removed:
let recovery_notice ~readiness:_ = failwith "TODO"
lib/web/pages.mli
@@ -1,20 +0,0 @@
1
Removed:
(** Page rendering. Pure view functions returning Eliom HTML; domain access goes
2
Removed:
through {!Hito_app.Service}. *)
3
Removed:
4
Removed:
open Hito_app
5
Removed:
6
Removed:
val choose_routine :
7
Removed:
routines:(Repository.routine_id * Routine.t) list ->
8
Removed:
Html_types.html Eliom_content.Html.elt
9
Removed:
10
Removed:
val log_workout :
11
Removed:
entry:Logbook.Entry.t -> Html_types.html Eliom_content.Html.elt
12
Removed:
(** The active-logging page for the entry in progress. *)
13
Removed:
14
Removed:
val history :
15
Removed:
records:Repository.record list -> Html_types.html Eliom_content.Html.elt
16
Removed:
17
Removed:
val recovery_notice :
18
Removed:
readiness:Recovery.readiness -> Html_types.html Eliom_content.Html.elt
19
Removed:
(** Informational: shown alongside {!log_workout} when the trainee has not fully
20
Removed:
rested. Never blocks logging. *)
lib/web/services.ml
@@ -1,52 +1,15 @@
1
Removed:
(* Minimal stubs only; implementation deferred until after the review gate.
1
Added:
open Eliom_content.Html.F
2
2
3
Removed:
Service *values* are declared here (so the routes exist and type-check), but
4
Removed:
handler registration is a no-op stub until the interfaces are approved. The
5
Removed:
.mli exposes only [register]. *)
6
Removed:
7
Removed:
open Hito_app
8
Removed:
9
Removed:
(* Domain identifiers cross the URL boundary via user_type. *)
10
Removed:
let routine_id_param =
11
Removed:
Eliom_parameter.user_type ~of_string:Repository.routine_id
12
Removed:
~to_string:(fun (id : Repository.routine_id) -> (id :> string))
13
Removed:
"routine"
14
Removed:
15
Removed:
(* GET / — choose a routine. *)
3
Added:
(* GET / *)
16
4
let home =
17
5
Eliom_service.create ~path:(Eliom_service.Path [ "" ])
18
6
~meth:(Eliom_service.Get Eliom_parameter.unit) ()
19
7
20
Removed:
(* GET /history — the workout history log. *)
21
Removed:
let history =
22
Removed:
Eliom_service.create ~path:(Eliom_service.Path [ "history" ])
23
Removed:
~meth:(Eliom_service.Get Eliom_parameter.unit) ()
8
Added:
let page ~title:t body_content =
9
Added:
html (head (title (txt t)) []) (body body_content)
24
10
25
Removed:
(* POST — start the chosen routine's first workout (recovery-gated). *)
26
Removed:
let start_workout =
27
Removed:
Eliom_service.create ~path:Eliom_service.No_path
28
Removed:
~meth:(Eliom_service.Post (Eliom_parameter.unit, routine_id_param))
29
Removed:
()
30
Removed:
31
Removed:
(* POST — append a set group to the in-progress workout. *)
32
Removed:
let log_group =
33
Removed:
Eliom_service.create ~path:Eliom_service.No_path
34
Removed:
~meth:(Eliom_service.Post (Eliom_parameter.unit, Eliom_parameter.unit))
35
Removed:
()
36
Removed:
37
Removed:
(* POST — finish and persist; redirects to history. *)
38
Removed:
let finish_workout =
39
Removed:
Eliom_service.create ~path:Eliom_service.No_path
40
Removed:
~meth:(Eliom_service.Post (Eliom_parameter.unit, Eliom_parameter.unit))
41
Removed:
()
42
Removed:
43
11
let register () =
44
Removed:
(* Stub: real handler registration (App.register ~service ...) is deferred
45
Removed:
until the interfaces are approved. Reference the service values so the
46
Removed:
routes are retained. *)
47
Removed:
ignore home;
48
Removed:
ignore history;
49
Removed:
ignore start_workout;
50
Removed:
ignore log_group;
51
Removed:
ignore finish_workout;
52
Removed:
()
12
Added:
Eliom_registration.Html.register ~service:home (fun () () ->
13
Added:
Lwt.return
14
Added:
(page ~title:"hito"
15
Added:
[ h1 [ txt "hito" ]; p [ txt "High Intensity Trainer Online" ] ]))
lib/web/services.mli
@@ -1,8 +1,6 @@
1
Removed:
(** Eliom services for the single-user HD flow: choose routine -> log workout ->
2
Removed:
view history. GET services are bookmarkable read pages; POST services are
3
Removed:
side-effecting actions. In-progress workout state is held in a
4
Removed:
session-scoped {!Eliom_reference}. Only [register] is exposed — the service
5
Removed:
values' phantom types are an implementation detail. *)
1
Added:
(** Eliom services for the single-user HD flow. Only {!register} is exposed: the
2
Added:
service values' phantom types are an implementation detail. *)
6
3
7
4
val register : unit -> unit
8
Removed:
(** Register all service handlers. Called once at module load. *)
5
Added:
(** Register every handler. Called once by the launcher, before the server
6
Added:
starts. *)
ocsidb
Binary files differ
test/dune
@@ -14,5 +14,6 @@
14
14
test_recovery
15
15
test_entry
16
16
test_logbook
17
Removed:
test_progression)
18
Removed:
(libraries hito.core alcotest))
17
Added:
test_progression
18
Added:
test_service)
19
Added:
(libraries hito.core hito.app alcotest))
test/test_hito.ml
@@ -1,11 +1,13 @@
1
1
(** Test harness entry point.
2
2
3
3
Suites are ordered as the modules layer: vocabulary, then what is
4
Removed:
prescribed, then what was performed, then what it means. *)
4
Added:
prescribed, then what was performed, then what it means, then the
5
Added:
application service that orchestrates them. *)
5
6
6
7
let () =
7
8
Alcotest.run "hito"
8
9
(Test_units.suite @ Test_muscle.suite @ Test_exercise.suite
9
10
@ Test_prescription.suite @ Test_workout_prescription.suite
10
11
@ Test_routine.suite @ Test_stimulus.suite @ Test_recovery.suite
11
Removed:
@ Test_entry.suite @ Test_logbook.suite @ Test_progression.suite)
12
Added:
@ Test_entry.suite @ Test_logbook.suite @ Test_progression.suite
13
Added:
@ Test_service.suite)
test/test_service.ml
@@ -0,0 +1,236 @@
1
Added:
(** Tests for {!Hito_app.Service} — the whole HD flow with no web tier. *)
2
Added:
3
Added:
open Hito_app
4
Added:
module S = Service.Make (Memory_repo)
5
Added:
6
Added:
let ok = function Ok v -> v | Error _ -> Alcotest.fail "expected Ok"
7
Added:
8
Added:
let get id =
9
Added:
match Exercise.find id with
10
Added:
| Some e -> e
11
Added:
| None -> Alcotest.failf "catalog is missing %S" id
12
Added:
13
Added:
let kg n = ok (Units.Weight.of_kg n)
14
Added:
let reps n = ok (Units.Reps.of_int n)
15
Added:
let at s = Recovery.timestamp_of_unix_seconds s
16
Added:
let day n = at (n * 86_400)
17
Added:
let ideal = Repository.routine_id "ideal"
18
Added:
let service () = S.make ~repo:(Memory_repo.create ())
19
Added:
20
Added:
let move id load r =
21
Added:
Stimulus.Movement.make ~exercise:(get id) ~load:(kg load) ~reps:(reps r)
22
Added:
~outcome:Stimulus.Positive_failure
23
Added:
24
Added:
let single id load r = ok (Stimulus.make (Stimulus.Single (move id load r)))
25
Added:
26
Added:
let pair ~isolation ~compound =
27
Added:
ok (Stimulus.make (Stimulus.Pre_exhaust { isolation; compound }))
28
Added:
29
Added:
(* HD1's Day 1 as performed. *)
30
Added:
let day_one_stimuli =
31
Added:
[
32
Added:
pair
33
Added:
~isolation:(move "dumbbell-flyes" 20. 9)
34
Added:
~compound:(move "incline-press" 60. 7);
35
Added:
single "laterals" 12. 8;
36
Added:
single "bent-over-laterals" 10. 9;
37
Added:
pair
38
Added:
~isolation:(move "lying-french-press" 30. 8)
39
Added:
~compound:(move "dips" 0. 6);
40
Added:
]
41
Added:
42
Added:
let routine_tests =
43
Added:
[
44
Added:
( "the seeded repository offers HD1's Ideal Routine",
45
Added:
`Quick,
46
Added:
fun () ->
47
Added:
match S.list_routines (service ()) with
48
Added:
| [ (_, r) ] ->
49
Added:
Alcotest.(check string) "name" "Ideal Routine" (Routine.name r)
50
Added:
| rs -> Alcotest.failf "expected one routine, got %d" (List.length rs)
51
Added:
);
52
Added:
( "an unknown routine is refused",
53
Added:
`Quick,
54
Added:
fun () ->
55
Added:
match
56
Added:
S.next_workout (service ()) ~routine:(Repository.routine_id "nope")
57
Added:
with
58
Added:
| Error S.Unknown_routine -> ()
59
Added:
| _ -> Alcotest.fail "expected Unknown_routine" );
60
Added:
( "with nothing logged the cycle starts at Day 1",
61
Added:
`Quick,
62
Added:
fun () ->
63
Added:
let w = ok (S.next_workout (service ()) ~routine:ideal) in
64
Added:
Alcotest.(check string) "Day 1" "Day 1" (Workout_prescription.name w) );
65
Added:
]
66
Added:
67
Added:
let clearance_tests =
68
Added:
[
69
Added:
( "a first workout needs no recovery: nothing has been done yet",
70
Added:
`Quick,
71
Added:
fun () ->
72
Added:
let s = service () in
73
Added:
Alcotest.(check bool)
74
Added:
"ready" true
75
Added:
(Recovery.is_ready (ok (S.readiness s ~routine:ideal ~now:(day 1))));
76
Added:
Alcotest.(check bool)
77
Added:
"starts" true
78
Added:
(Result.is_ok (S.begin_workout s ~routine:ideal ~now:(day 1) ())) );
79
Added:
( "training too soon after a workout is refused",
80
Added:
`Quick,
81
Added:
fun () ->
82
Added:
let s = service () in
83
Added:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
84
Added:
let _ = S.finish s ~ended_at:(day 1) in
85
Added:
match S.begin_workout s ~routine:ideal ~now:(day 2) () with
86
Added:
| Error (S.Not_recovered readiness) ->
87
Added:
Alcotest.(check bool)
88
Added:
"and says so" false
89
Added:
(Recovery.is_ready readiness)
90
Added:
| _ -> Alcotest.fail "expected Not_recovered" );
91
Added:
( "once rested, the next workout starts and the cycle has advanced",
92
Added:
`Quick,
93
Added:
fun () ->
94
Added:
let s = service () in
95
Added:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
96
Added:
let _ = S.finish s ~ended_at:(day 1) in
97
Added:
let entry = ok (S.begin_workout s ~routine:ideal ~now:(day 3) ()) in
98
Added:
Alcotest.(check string)
99
Added:
"Day 2" "Day 2"
100
Added:
(Workout_prescription.name (Entry.prescription entry)) );
101
Added:
( "an override is accepted and keeps its reason on the record",
102
Added:
`Quick,
103
Added:
fun () ->
104
Added:
let s = service () in
105
Added:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
106
Added:
let _ = S.finish s ~ended_at:(day 1) in
107
Added:
let entry =
108
Added:
ok
109
Added:
(S.begin_workout s ~routine:ideal ~now:(day 2)
110
Added:
~override:"travelling tomorrow" ())
111
Added:
in
112
Added:
match Recovery.basis (Entry.clearance entry) with
113
Added:
| Recovery.Overridden { reason; _ } ->
114
Added:
Alcotest.(check string) "reason" "travelling tomorrow" reason
115
Added:
| Recovery.Recovered -> Alcotest.fail "expected Overridden" );
116
Added:
( "an override while genuinely rested is not recorded as one",
117
Added:
`Quick,
118
Added:
fun () ->
119
Added:
let s = service () in
120
Added:
let entry =
121
Added:
ok
122
Added:
(S.begin_workout s ~routine:ideal ~now:(day 1)
123
Added:
~override:"just in case" ())
124
Added:
in
125
Added:
match Recovery.basis (Entry.clearance entry) with
126
Added:
| Recovery.Recovered -> ()
127
Added:
| Recovery.Overridden _ ->
128
Added:
Alcotest.fail "nothing was outstanding to override" );
129
Added:
]
130
Added:
131
Added:
let logging_tests =
132
Added:
[
133
Added:
( "logging without a workout in progress is refused",
134
Added:
`Quick,
135
Added:
fun () ->
136
Added:
match S.log (service ()) (single "laterals" 12. 8) with
137
Added:
| Error S.No_workout_in_progress -> ()
138
Added:
| _ -> Alcotest.fail "expected No_workout_in_progress" );
139
Added:
( "a stimulus the prescription does not call for is refused",
140
Added:
`Quick,
141
Added:
fun () ->
142
Added:
let s = service () in
143
Added:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
144
Added:
match S.log s (single "shrugs" 80. 10) with
145
Added:
| Error (S.Rejected (Entry.Not_prescribed _)) -> ()
146
Added:
| _ -> Alcotest.fail "expected Rejected Not_prescribed" );
147
Added:
( "Day 1 can be logged in full and finished",
148
Added:
`Quick,
149
Added:
fun () ->
150
Added:
let s = service () in
151
Added:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
152
Added:
List.iter (fun st -> ignore (ok (S.log s st))) day_one_stimuli;
153
Added:
let entry = Option.get (S.in_progress s) in
154
Added:
Alcotest.(check int)
155
Added:
"four stimuli" 4
156
Added:
(List.length (Entry.stimuli entry));
157
Added:
Alcotest.(check int)
158
Added:
"nothing outstanding" 0
159
Added:
(List.length (Entry.unperformed entry));
160
Added:
let record = Option.get (S.finish s ~ended_at:(at 3600)) in
161
Added:
Alcotest.(check bool)
162
Added:
"persisted as finished" true
163
Added:
(Entry.is_finished record.Repository.entry);
164
Added:
Alcotest.(check bool)
165
Added:
"slot cleared" true
166
Added:
(Option.is_none (S.in_progress s)) );
167
Added:
( "history returns the finished workout",
168
Added:
`Quick,
169
Added:
fun () ->
170
Added:
let s = service () in
171
Added:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
172
Added:
let _ = ok (S.log s (single "laterals" 12. 8)) in
173
Added:
let _ = S.finish s ~ended_at:(at 3600) in
174
Added:
Alcotest.(check int) "one workout" 1 (List.length (S.history s)) );
175
Added:
]
176
Added:
177
Added:
let assessment_tests =
178
Added:
[
179
Added:
( "evidence accumulates across cycles and feeds progression",
180
Added:
`Quick,
181
Added:
fun () ->
182
Added:
let s = service () in
183
Added:
(* The cycle rotates, so laterals — a Day 1 movement — recur only once
184
Added:
per three workouts. Log whole cycles and record laterals whenever
185
Added:
Day 1 comes round, at an unchanging load. *)
186
Added:
let run ~on ~load =
187
Added:
let entry =
188
Added:
ok (S.begin_workout s ~routine:ideal ~now:on ~override:"fixture" ())
189
Added:
in
190
Added:
if
191
Added:
String.equal "Day 1"
192
Added:
(Workout_prescription.name (Entry.prescription entry))
193
Added:
then ignore (ok (S.log s (single "laterals" load 8)));
194
Added:
ignore (S.finish s ~ended_at:on)
195
Added:
in
196
Added:
List.iter
197
Added:
(fun on -> run ~on ~load:12.)
198
Added:
[ day 1; day 3; day 5; day 8; day 10; day 12; day 16 ];
199
Added:
(* Laterals seen on days 1, 8 and 16 with no gain: fifteen days without
200
Added:
an advance, which is past HD1's two-week threshold. *)
201
Added:
Alcotest.(check int)
202
Added:
"seven workouts logged" 7
203
Added:
(List.length (S.history s));
204
Added:
Alcotest.(check bool)
205
Added:
"stalled" true
206
Added:
(S.progress s (get "laterals") = Ok Progression.Stalled) );
207
Added:
( "training on overrides shows up as a diagnostic",
208
Added:
`Quick,
209
Added:
fun () ->
210
Added:
let s = service () in
211
Added:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
212
Added:
let _ = S.finish s ~ended_at:(day 1) in
213
Added:
let _ =
214
Added:
ok
215
Added:
(S.begin_workout s ~routine:ideal ~now:(day 2) ~override:"impatient"
216
Added:
())
217
Added:
in
218
Added:
let _ = S.finish s ~ended_at:(day 2) in
219
Added:
match
220
Added:
List.filter
221
Added:
(function
222
Added:
| Progression.Trained_under_recovered _ -> true | _ -> false)
223
Added:
(S.diagnostics s)
224
Added:
with
225
Added:
| [ Progression.Trained_under_recovered n ] ->
226
Added:
Alcotest.(check int) "one such workout" 1 n
227
Added:
| _ -> Alcotest.fail "expected the under-recovery diagnostic" );
228
Added:
]
229
Added:
230
Added:
let suite =
231
Added:
[
232
Added:
("service.routines", routine_tests);
233
Added:
("service.clearance", clearance_tests);
234
Added:
("service.logging", logging_tests);
235
Added:
("service.assessment", assessment_tests);
236
Added:
]