[OCaml] High Intensity Training Online
feat Add durable authenticated web app
Persist trainee-owned workouts in SQLite and protect the Dream UI with local authentication and SQL sessions. Keep Heavy Duty doctrine unchanged in the core.
Changed files
- .gitignore
- .kiro/steering/ocaml.md
- ARCHITECTURE.md
- bin/dune
- bin/main.ml
- dune-project
- hito.opam
- lib/app/catalog.ml
- lib/app/catalog.mli
- lib/app/codec.ml
- lib/app/codec.mli
- lib/app/dune
- lib/app/memory_repo.ml
- lib/app/memory_repo.mli
- lib/app/migrations.ml
- lib/app/migrations.mli
- lib/app/repository.ml
- lib/app/repository.mli
- lib/app/service.ml
- lib/app/service.mli
- lib/app/sqlite_repo.ml
- lib/app/sqlite_repo.mli
- lib/app/trainee.ml
- lib/app/trainee.mli
- lib/web/dune
- lib/web/handlers.ml
- lib/web/handlers.mli
- lib/web/pages.ml
- lib/web/pages.mli
- lib/web/routes.ml
- test/dune
- test/test_codec.ml
- test/test_hito.ml
- test/test_service.ml
- test/test_sqlite_repo.ml
- test/test_web.ml
.gitignore
@@ -21,3 +21,8 @@
21
21
local_db/
22
22
static/
23
23
ocsidb
24
Added:
25
Added:
# Local SQLite databases
26
Added:
*.sqlite
27
Added:
*.sqlite-wal
28
Added:
*.sqlite-shm
.kiro/steering/ocaml.md
@@ -11,9 +11,14 @@
11
11
12
12
- Modern, idiomatic OCaml. Favour the principle of least surprise: a reader
13
13
should not need to learn a local idiom to follow the code.
14
Removed:
- Introduce monadic style (`let*`, custom binds) only where it removes
15
Removed:
substantial noise — typically chained `result` plumbing.
14
Added:
- Prefer readable, shallow code. A flat sequence a reader can follow top to
15
Added:
bottom beats a deeply nested tower of `match` arms.
16
Added:
- Reach for `let*` when it flattens nested cases — chained `result` or
17
Added:
`result Lwt.t` plumbing where each step short-circuits on error. Used this
18
Added:
way, a bind improves flow and cuts indentation.
16
19
- A single `match` is clearer than a monad; don't reach for one reflexively.
20
Added:
- Two or three cascading `match ... with Error _ -> ... | Ok x -> ...`
21
Added:
steps are the signal to switch to `let*`.
17
22
- Abstract types with smart constructors for anything carrying an invariant.
18
23
- Use `result` for expected, recoverable failure.
19
24
- This includes converting untrusted external data and domain feedback a caller
ARCHITECTURE.md
@@ -62,15 +62,54 @@
62
62
63
63
Above the core sit two more libraries, dependencies pointing inward only:
64
64
65
Removed:
- **`hito.app`** — `Repository` (a port, no database), `Memory_repo`, and
66
Removed:
`Service`. Identity is assigned here, since the core carries none, and so is
67
Removed:
recovery policy: `Service` is the only thing that decides how a
68
Removed:
`Recovery.clearance` is obtained, so a second client cannot quietly adopt
69
Removed:
looser rules than the first.
65
Added:
- **`hito.app`** — `Trainee`, `Repository` (a port), `Catalog`, `Codec`,
66
Added:
`Memory_repo`, `Sqlite_repo`, `Migrations`, and `Service`. Identity is
67
Added:
assigned here, since the core carries none, and so is recovery policy:
68
Added:
`Service` is the only thing that decides how a `Recovery.clearance` is
69
Added:
obtained, so a second client cannot quietly adopt looser rules than the
70
Added:
first. Every `Repository` and `Service` operation is scoped to a
71
Added:
`Trainee.id`. There is no server-wide state: a trainee's active routine and
72
Added:
workout in progress are stored, not held in a slot.
70
73
- **`hito.web`** — `Routes`, `Decode`, `Pages`, `Handlers`. Dream and
71
74
dream-html live only here. The server renders HTML and uses no client-side
72
75
OCaml or js_of_ocaml. Wall-clock time enters here, never in the core.
76
Added:
`Handlers` is a functor over `Repository.S`, so production runs on
77
Added:
`Sqlite_repo` while tests run on `Memory_repo`. Authentication uses one
78
Added:
`authenticated` combinator: it resolves the signed-in trainee and passes it
79
Added:
to a continuation, so a route with any number of path captures shares one
80
Added:
gate. Every domain and service error becomes a user-facing sentence in one
81
Added:
`Present` module, so a handler renders a message rather than choosing its
82
Added:
wording.
73
83
84
Added:
### Accounts, sessions, and storage
85
Added:
86
Added:
- **Trainee** — an account: an opaque id, a normalized email, and a password
87
Added:
credential. A credential carries a bcrypt hash, never the password, and the
88
Added:
hash is computed and checked inside this module through `safepass`.
89
Added:
- **Repository port** — trainee-scoped account, catalog, selection,
90
Added:
in-progress, and history operations, plus a transactional `finish_workout`
91
Added:
that saves a finished workout and clears the in-progress slot as one unit.
92
Added:
Effects run in Lwt, because an adapter may talk to a database.
93
Added:
- **Sqlite_repo** — the durable store, backed by SQLite through Caqti. It stores
94
Added:
performed facts through `Codec` as opaque encoded strings and never inspects
95
Added:
domain shape. `Migrations` creates the schema on connect, including the
96
Added:
`dream_session` table Dream's SQL sessions expect. Finishing a workout —
97
Added:
saving it to history and clearing the in-progress slot — runs in one
98
Added:
transaction, so the two rows never disagree after a crash.
99
Added:
- **Migrations** — versioned, tracked schema migrations. Each migration is a
100
Added:
numbered, named set of statements; a `schema_migrations` ledger records which
101
Added:
versions a file carries, so a reconnect applies only what is missing and each
102
Added:
migration runs inside a transaction. Statements still use `IF NOT EXISTS`, so
103
Added:
a file from an earlier, ledger-less build stays safe.
104
Added:
- **Codec** — the serialization boundary. It captures only what was performed
105
Added:
and rebuilds a `Evidence.Workout.t` by driving the same core constructors a
106
Added:
live session does. A prescription is not stored; it is found again by name in
107
Added:
the `Catalog`. This keeps the core unchanged and carries no serializers.
108
Added:
- **Authentication** — `Handlers` verifies a local email and password, then
109
Added:
stores the trainee id in a signed session. Every application route requires
110
Added:
an authenticated trainee and redirects to the sign-in page otherwise. Every
111
Added:
state-changing POST verifies a CSRF token; the token is signed, not stored.
112
Added:
74
113
## Modules
75
114
76
115
### Vocabulary
@@ -161,28 +200,47 @@
161
200
dune build && ./_build/default/bin/main.exe # http://localhost:8080/
162
201
```
163
202
164
Removed:
`bin/main.ml` starts Dream directly. Dream binds loopback only by explicit
165
Removed:
configuration, so no XML configuration or runtime plug-in exists. The socket
166
Removed:
binds **loopback only**, and there is **no authentication**: anything beyond
167
Removed:
local dogfooding needs auth first.
203
Added:
`bin/main.ml` opens the SQLite store, applies migrations, and starts Dream. The
204
Added:
socket binds **loopback only**. Configuration comes from the environment:
168
205
169
Removed:
Storage is in-memory, so a restart wipes the log. The workout in progress is a
170
Removed:
single slot in `Service.t`, not a session reference — it survives a closed tab,
171
Removed:
and is single-user by construction. Both must become per-trainee before auth.
206
Added:
| Variable | Purpose | Default |
207
Added:
|---------------|---------------------------------------|------------------------|
208
Added:
| `HITO_DB` | Caqti database URI | `sqlite3:hito.sqlite` |
209
Added:
| `HITO_SECRET` | Signs session cookies and CSRF tokens | a random per-run value |
210
Added:
| `HITO_PORT` | TCP port | `8080` |
172
211
173
Removed:
| Route | Method | Purpose |
174
Removed:
|---|---|---|
175
Removed:
| `/routines` | GET | Choose a routine |
176
Removed:
| `/routines/:id/select` | POST | Make a routine active |
177
Removed:
| `/routine` | GET | Active routine details |
178
Removed:
| `/workout` | GET | The workout in progress |
179
Removed:
| `/workout` | POST | Start the next workout or refuse at the recovery gate |
180
Removed:
| `/workout/slots/:slot` | POST | Record one prescribed stimulus |
181
Removed:
| `/workout/finish` | POST | Complete and persist |
182
Removed:
| `/history` | GET | What has been performed |
183
Removed:
| `/history/:id` | GET | View a saved workout and its missing records |
184
Removed:
| `/history/:id/slots/:slot` | POST | Add a missing saved record |
212
Added:
Set `HITO_SECRET` in production. When it is unset, the server generates a random
213
Added:
secret for that run, so sessions do not survive a restart.
185
214
215
Added:
Authentication is local email and password. A password is stored as a bcrypt
216
Added:
hash. A session holds the trainee id in a signed cookie, backed by the
217
Added:
`dream_session` table. Every state-changing POST carries a signed CSRF token.
218
Added:
219
Added:
Storage is durable: trainees, their active routine, the workout in progress, and
220
Added:
history all live in SQLite. There is no server-wide in-memory state, and each
221
Added:
trainee has a separate logbook. The workout in progress is a stored row keyed by
222
Added:
trainee, so it survives a closed tab and a restart.
223
Added:
224
Added:
Dream runs its own SQL pool for sessions against the same database file, next to
225
Added:
the pool `Sqlite_repo` opens. SQLite serializes writers, so this is safe for
226
Added:
local use. A separate session store is the path to higher concurrency.
227
Added:
228
Added:
| Route | Method | Purpose |
229
Added:
|----------------------------|-----------|-------------------------------------------------------|
230
Added:
| `/register` | GET, POST | Create an account and sign in |
231
Added:
| `/login` | GET, POST | Sign in |
232
Added:
| `/logout` | POST | Sign out |
233
Added:
| `/routines` | GET | Choose a routine |
234
Added:
| `/routines/:id/select` | POST | Make a routine active |
235
Added:
| `/routine` | GET | Active routine details |
236
Added:
| `/workout` | GET | The workout in progress |
237
Added:
| `/workout` | POST | Start the next workout or refuse at the recovery gate |
238
Added:
| `/workout/slots/:slot` | POST | Record one prescribed stimulus |
239
Added:
| `/workout/finish` | POST | Complete and persist |
240
Added:
| `/history` | GET | What has been performed |
241
Added:
| `/history/:id` | GET | View a saved workout and its missing records |
242
Added:
| `/history/:id/slots/:slot` | POST | Add a missing saved record |
243
Added:
186
244
Dream permits nested resource paths, so slot and record identity live in the
187
245
path rather than hidden fields or query parameters.
188
246
@@ -195,6 +253,12 @@
195
253
196
254
One Alcotest suite per module, `test/test_<module>.ml`, each exposing a `suite`
197
255
value registered in `test/test_hito.ml` in layer order. `dune runtest`.
256
Added:
`test_codec` proves a stored workout round-trips faithfully and that malformed
257
Added:
or incomplete text is reported, not raised. `test_sqlite_repo` proves state
258
Added:
survives a reconnect and trainees stay isolated, that reapplying migrations is
259
Added:
idempotent, and that finishing is atomic across a reconnect, using a temporary
260
Added:
database file. `test_web` carries the session cookie and CSRF token between
261
Added:
requests, so it exercises authentication end to end.
198
262
199
263
## Deviations and tensions
200
264
@@ -233,9 +297,10 @@
233
297
234
298
## Deferred
235
299
236
Removed:
Authentication, and with it per-trainee storage and workout state — required
237
Removed:
before this runs anywhere but localhost. Durable storage behind the same
238
Removed:
`Repository` port. Equipment granularity, so a suggested load is one a bar
239
Removed:
actually takes. A trainee layer carrying individual recovery ability, spotter
240
Removed:
availability, and the way recovery needs outgrow strength. HD2 consolidation once
241
Removed:
sourced. A native client, which would sit on `hito.app` beside the web tier.
300
Added:
Authentication, per-trainee storage and workout state, and durable storage
301
Added:
behind the `Repository` port are now in place. What remains: equipment
302
Added:
granularity, so a suggested load is one a bar actually takes; a trainee layer
303
Added:
carrying individual recovery ability, spotter availability, and the way recovery
304
Added:
needs outgrow strength; HD2 consolidation once sourced; a separate session store
305
Added:
for higher concurrency; and a native client, which would sit on `hito.app`
306
Added:
beside the web tier.
bin/dune
@@ -1,4 +1,4 @@
1
1
(executable
2
2
(public_name hito)
3
3
(name main)
4
Removed:
(libraries hito.web dream))
4
Added:
(libraries hito.web hito.app dream lwt caqti))
bin/main.ml
@@ -1,7 +1,42 @@
1
Removed:
(* The server binds only to loopback. There is no authentication, so this is
2
Removed:
suitable only for local dogfooding. *)
1
Added:
(* The production server. State is durable: trainees, their active routine,
2
Added:
the workout in progress, and history all live in SQLite. There is no
3
Added:
server-wide in-memory state.
3
4
5
Added:
Configuration comes from the environment:
6
Added:
- HITO_DB Caqti database URI. Default: sqlite3:hito.sqlite
7
Added:
- HITO_SECRET Secret for signing session cookies and CSRF tokens. When
8
Added:
unset, a random secret is generated for this run only, so
9
Added:
sessions do not survive a restart. Set it in production.
10
Added:
- HITO_PORT TCP port. Default: 8080
11
Added:
12
Added:
The socket binds loopback only. Authentication is local email and password;
13
Added:
sessions and CSRF tokens are signed with the secret. *)
14
Added:
15
Added:
module Handlers = Hito_web.Handlers.Make (Hito_app.Sqlite_repo)
16
Added:
17
Added:
let getenv name default =
18
Added:
match Sys.getenv_opt name with Some v when v <> "" -> v | _ -> default
19
Added:
4
20
let () =
5
Removed:
Dream.run ~interface:"localhost" ~port:8080
6
Removed:
@@ Dream.logger
7
Removed:
@@ Dream.router (Hito_web.Handlers.routes (Hito_web.Handlers.create ()))
21
Added:
let db_uri = getenv "HITO_DB" "sqlite3:hito.sqlite" in
22
Added:
let port = int_of_string (getenv "HITO_PORT" "8080") in
23
Added:
let secret =
24
Added:
match Sys.getenv_opt "HITO_SECRET" with
25
Added:
| Some s when s <> "" -> s
26
Added:
| _ ->
27
Added:
prerr_endline
28
Added:
"hito: HITO_SECRET is not set; using a random secret. Sessions will \
29
Added:
not survive a restart.";
30
Added:
Dream.to_base64url (Dream.random 32)
31
Added:
in
32
Added:
match Lwt_main.run (Hito_app.Sqlite_repo.connect db_uri) with
33
Added:
| Error error ->
34
Added:
Printf.eprintf "hito: cannot open database %S: %s\n" db_uri
35
Added:
(Caqti_error.show error);
36
Added:
exit 1
37
Added:
| Ok repo ->
38
Added:
let handlers = Handlers.make ~repo () in
39
Added:
Dream.run ~interface:"localhost" ~port
40
Added:
@@ Dream.logger @@ Dream.set_secret secret @@ Dream.sql_pool db_uri
41
Added:
@@ Dream.sql_sessions
42
Added:
@@ Dream.router (Handlers.routes handlers)
dune-project
@@ -24,14 +24,24 @@
24
24
(>= 5.1))
25
25
(alcotest
26
26
(and
27
Removed:
(>= 1.8)
27
Added:
(= 1.9.1)
28
28
:with-test))
29
29
(dream
30
Removed:
(>= 1.0.0~alpha8))
30
Added:
(= 1.0.0~alpha8))
31
31
(dream-html
32
Removed:
(>= 3.11.2))
32
Added:
(= 3.11.2))
33
33
(lwt
34
Removed:
(>= 5.0))
34
Added:
(= 5.10.1))
35
Added:
(caqti
36
Added:
(= 2.3.2))
37
Added:
(caqti-lwt
38
Added:
(= 2.3.2))
39
Added:
(caqti-driver-sqlite3
40
Added:
(= 2.3.0))
41
Added:
(safepass
42
Added:
(= 3.1))
43
Added:
(uri
44
Added:
(= 4.4.0))
35
45
(crunch
36
46
(and
37
47
(= 4.1.0)
hito.opam
@@ -12,10 +12,15 @@
12
12
depends: [
13
13
"dune" {>= "3.20"}
14
14
"ocaml" {>= "5.1"}
15
Removed:
"alcotest" {>= "1.8" & with-test}
16
Removed:
"dream" {>= "1.0.0~alpha8"}
17
Removed:
"dream-html" {>= "3.11.2"}
18
Removed:
"lwt" {>= "5.0"}
15
Added:
"alcotest" {= "1.9.1" & with-test}
16
Added:
"dream" {= "1.0.0~alpha8"}
17
Added:
"dream-html" {= "3.11.2"}
18
Added:
"lwt" {= "5.10.1"}
19
Added:
"caqti" {= "2.3.2"}
20
Added:
"caqti-lwt" {= "2.3.2"}
21
Added:
"caqti-driver-sqlite3" {= "2.3.0"}
22
Added:
"safepass" {= "3.1"}
23
Added:
"uri" {= "4.4.0"}
19
24
"crunch" {= "4.1.0" & build}
20
25
"ocamlformat" {= "0.29.0" & with-dev-setup}
21
26
"odoc" {with-doc}
lib/app/catalog.ml
@@ -0,0 +1,9 @@
1
Added:
let routines = [ (Repository.routine_id "ideal", Prescription.Routine.ideal) ]
2
Added:
let find id = List.assoc_opt id routines
3
Added:
4
Added:
let find_by_name name =
5
Added:
List.find_map
6
Added:
(fun (_, routine) ->
7
Added:
if String.equal (Prescription.Routine.name routine) name then Some routine
8
Added:
else None)
9
Added:
routines
lib/app/catalog.mli
@@ -0,0 +1,9 @@
1
Added:
(** The routine catalog: the presets the book supports. Shared by every
2
Added:
repository adapter, and not trainee-scoped — a routine is authored, not
3
Added:
owned. *)
4
Added:
5
Added:
val routines : (Repository.routine_id * Prescription.Routine.t) list
6
Added:
(** Seeded with HD1's Ideal Routine, the one preset the book supports. *)
7
Added:
8
Added:
val find : Repository.routine_id -> Prescription.Routine.t option
9
Added:
val find_by_name : string -> Prescription.Routine.t option
lib/app/codec.ml
@@ -0,0 +1,298 @@
1
Added:
type error =
2
Added:
| Malformed of string
3
Added:
| Unknown_exercise of string
4
Added:
| Unknown_routine of string
5
Added:
| Unknown_workout_name of { routine : string; workout : string }
6
Added:
| Replay_rejected of string
7
Added:
8
Added:
let pp_error ppf = function
9
Added:
| Malformed detail -> Format.fprintf ppf "malformed record: %s" detail
10
Added:
| Unknown_exercise id -> Format.fprintf ppf "unknown exercise %S" id
11
Added:
| Unknown_routine name -> Format.fprintf ppf "unknown routine %S" name
12
Added:
| Unknown_workout_name { routine; workout } ->
13
Added:
Format.fprintf ppf "routine %S has no workout %S" routine workout
14
Added:
| Replay_rejected detail ->
15
Added:
Format.fprintf ppf "stored record rejected: %s" detail
16
Added:
17
Added:
(* --- extension and outcome codes --- *)
18
Added:
19
Added:
let extension_code : Evidence.Stimulus.extension -> string = function
20
Added:
| Forced_reps -> "forced"
21
Added:
| Negatives -> "negatives"
22
Added:
| Rest_pause -> "rest-pause"
23
Added:
| Static_hold -> "static"
24
Added:
25
Added:
let extension_of_code = function
26
Added:
| "forced" -> Ok Evidence.Stimulus.Forced_reps
27
Added:
| "negatives" -> Ok Evidence.Stimulus.Negatives
28
Added:
| "rest-pause" -> Ok Evidence.Stimulus.Rest_pause
29
Added:
| "static" -> Ok Evidence.Stimulus.Static_hold
30
Added:
| other -> Error (Malformed (Printf.sprintf "extension %S" other))
31
Added:
32
Added:
let encode_outcome (outcome : Evidence.Stimulus.outcome) =
33
Added:
match outcome with
34
Added:
| Positive_failure -> "positive"
35
Added:
| Beyond_failure (first, rest) ->
36
Added:
"beyond:" ^ String.concat "," (List.map extension_code (first :: rest))
37
Added:
38
Added:
let decode_outcome text =
39
Added:
if String.equal text "positive" then Ok Evidence.Stimulus.Positive_failure
40
Added:
else
41
Added:
match String.split_on_char ':' text with
42
Added:
| [ "beyond"; codes ] -> (
43
Added:
match String.split_on_char ',' codes with
44
Added:
| [] | [ "" ] -> Error (Malformed "empty beyond-failure")
45
Added:
| first :: rest ->
46
Added:
let ( let* ) = Result.bind in
47
Added:
let* first = extension_of_code first in
48
Added:
let rec go acc = function
49
Added:
| [] -> Ok (List.rev acc)
50
Added:
| code :: tl -> (
51
Added:
match extension_of_code code with
52
Added:
| Ok e -> go (e :: acc) tl
53
Added:
| Error _ as e -> e)
54
Added:
in
55
Added:
let* rest = go [] rest in
56
Added:
Ok (Evidence.Stimulus.Beyond_failure (first, rest)))
57
Added:
| _ -> Error (Malformed (Printf.sprintf "outcome %S" text))
58
Added:
59
Added:
(* --- efforts and stimuli --- *)
60
Added:
61
Added:
let encode_effort effort =
62
Added:
let exercise = Evidence.Stimulus.Effort.exercise effort in
63
Added:
Printf.sprintf "%s\t%h\t%d\t%s"
64
Added:
(Exercise.id exercise :> string)
65
Added:
(Evidence.Stimulus.Effort.load effort)
66
Added:
(Evidence.Stimulus.Effort.reps effort)
67
Added:
(encode_outcome (Evidence.Stimulus.Effort.outcome effort))
68
Added:
69
Added:
let encode_stimulus stimulus =
70
Added:
match Evidence.Stimulus.delivery stimulus with
71
Added:
| Evidence.Stimulus.Single effort ->
72
Added:
Printf.sprintf "stimulus\tsingle\t%s" (encode_effort effort)
73
Added:
| Evidence.Stimulus.Pair { first; second } ->
74
Added:
Printf.sprintf "stimulus\tpair\t%s\t%s" (encode_effort first)
75
Added:
(encode_effort second)
76
Added:
77
Added:
let ( let* ) = Result.bind
78
Added:
79
Added:
let decode_effort = function
80
Added:
| [ exid; load; reps; outcome ] -> (
81
Added:
match Exercise.find_id exid with
82
Added:
| None -> Error (Unknown_exercise exid)
83
Added:
| Some exercise -> (
84
Added:
match (float_of_string_opt load, int_of_string_opt reps) with
85
Added:
| Some load, Some reps ->
86
Added:
let* outcome = decode_outcome outcome in
87
Added:
Ok (Evidence.Stimulus.Effort.make ~exercise ~load ~reps ~outcome)
88
Added:
| _ -> Error (Malformed "effort load/reps")))
89
Added:
| _ -> Error (Malformed "effort arity")
90
Added:
91
Added:
let decode_stimulus fields =
92
Added:
match fields with
93
Added:
| "single" :: rest ->
94
Added:
let* effort = decode_effort rest in
95
Added:
Ok (Evidence.Stimulus.make (Evidence.Stimulus.Single effort))
96
Added:
| "pair" :: rest -> (
97
Added:
match rest with
98
Added:
| [ a; b; c; d; e; f; g; h ] ->
99
Added:
let* first = decode_effort [ a; b; c; d ] in
100
Added:
let* second = decode_effort [ e; f; g; h ] in
101
Added:
Ok (Evidence.Stimulus.make (Evidence.Stimulus.Pair { first; second }))
102
Added:
| _ -> Error (Malformed "pair arity"))
103
Added:
| _ -> Error (Malformed "stimulus delivery")
104
Added:
105
Added:
(* --- clearance --- *)
106
Added:
107
Added:
let encode_clearance clearance =
108
Added:
match Recovery.basis clearance with
109
Added:
| Recovery.Recovered -> "clearance\trecovered"
110
Added:
| Recovery.Overridden { rested; recommended } ->
111
Added:
Printf.sprintf "clearance\toverridden\t%d\t%d"
112
Added:
(Recovery.duration_to_seconds rested)
113
Added:
(Recovery.duration_to_seconds recommended)
114
Added:
115
Added:
(* Recovery exposes only hours/days constructors, so derive an arbitrary
116
Added:
second-valued duration through elapsed: since=0, now=secs yields exactly
117
Added:
[secs] seconds. *)
118
Added:
let seconds_duration secs =
119
Added:
Recovery.elapsed
120
Added:
~since:(Recovery.timestamp_of_unix_seconds 0)
121
Added:
~now:(Recovery.timestamp_of_unix_seconds secs)
122
Added:
123
Added:
(* A clearance cannot be minted directly; it is derived from a readiness.
124
Added:
[Recovered] comes from a [Ready] reading; an override needs a [Recovering]
125
Added:
reading carrying the stored durations. *)
126
Added:
let decode_clearance = function
127
Added:
| [ "recovered" ] -> Ok (Option.get (Recovery.clear Recovery.Ready))
128
Added:
| [ "overridden"; rested; recommended ] -> (
129
Added:
match (int_of_string_opt rested, int_of_string_opt recommended) with
130
Added:
| Some rested, Some recommended ->
131
Added:
Ok
132
Added:
(Recovery.override
133
Added:
(Recovery.Recovering
134
Added:
{
135
Added:
rested = seconds_duration rested;
136
Added:
recommended = seconds_duration recommended;
137
Added:
}))
138
Added:
| _ -> Error (Malformed "clearance durations"))
139
Added:
| _ -> Error (Malformed "clearance basis")
140
Added:
141
Added:
(* --- workout --- *)
142
Added:
143
Added:
let encode_workout ~routine_name workout =
144
Added:
let buf = Buffer.create 256 in
145
Added:
let line s =
146
Added:
Buffer.add_string buf s;
147
Added:
Buffer.add_char buf '\n'
148
Added:
in
149
Added:
line (Printf.sprintf "routine\t%s" routine_name);
150
Added:
line
151
Added:
(Printf.sprintf "prescription\t%s"
152
Added:
(Prescription.Workout.name (Evidence.Workout.prescription workout)));
153
Added:
line (encode_clearance (Evidence.Workout.clearance workout));
154
Added:
line
155
Added:
(Printf.sprintf "started\t%d"
156
Added:
(Recovery.timestamp_to_unix_seconds
157
Added:
(Evidence.Workout.started_at workout)));
158
Added:
(match Evidence.Workout.ended_at workout with
159
Added:
| Some ended ->
160
Added:
line
161
Added:
(Printf.sprintf "ended\t%d" (Recovery.timestamp_to_unix_seconds ended))
162
Added:
| None -> ());
163
Added:
List.iter
164
Added:
(fun stimulus -> line (encode_stimulus stimulus))
165
Added:
(Evidence.Workout.stimuli workout);
166
Added:
Buffer.contents buf
167
Added:
168
Added:
(* A fully-parsed header, gathered before any replay. Parsing produces this
169
Added:
typed record; replay consumes it. Keeping the two phases apart removes the
170
Added:
mutable accumulators the old single pass needed. *)
171
Added:
type parsed = {
172
Added:
routine_name : string;
173
Added:
prescription_name : string;
174
Added:
clearance : Recovery.clearance;
175
Added:
started_at : Recovery.timestamp;
176
Added:
ended_at : Recovery.timestamp option;
177
Added:
stimuli : Evidence.Stimulus.t list; (** Performance order. *)
178
Added:
}
179
Added:
180
Added:
(* Fields accumulated while folding over lines; every field is optional until
181
Added:
its line is seen. [stimuli] is reversed for O(1) prepend and flipped once at
182
Added:
the end. *)
183
Added:
type acc = {
184
Added:
a_routine : string option;
185
Added:
a_prescription : string option;
186
Added:
a_clearance : Recovery.clearance option;
187
Added:
a_started : Recovery.timestamp option;
188
Added:
a_ended : Recovery.timestamp option;
189
Added:
a_stimuli_rev : Evidence.Stimulus.t list;
190
Added:
}
191
Added:
192
Added:
let empty_acc =
193
Added:
{
194
Added:
a_routine = None;
195
Added:
a_prescription = None;
196
Added:
a_clearance = None;
197
Added:
a_started = None;
198
Added:
a_ended = None;
199
Added:
a_stimuli_rev = [];
200
Added:
}
201
Added:
202
Added:
let parse_seconds label secs =
203
Added:
match int_of_string_opt secs with
204
Added:
| Some s -> Ok (Recovery.timestamp_of_unix_seconds s)
205
Added:
| None -> Error (Malformed label)
206
Added:
207
Added:
(* Fold one line into the accumulator. A line either sets a header field or
208
Added:
appends a stimulus; anything else is malformed. *)
209
Added:
let step acc = function
210
Added:
| [ "routine"; name ] -> Ok { acc with a_routine = Some name }
211
Added:
| [ "prescription"; name ] -> Ok { acc with a_prescription = Some name }
212
Added:
| "clearance" :: rest ->
213
Added:
let* c = decode_clearance rest in
214
Added:
Ok { acc with a_clearance = Some c }
215
Added:
| [ "started"; secs ] ->
216
Added:
let* t = parse_seconds "started" secs in
217
Added:
Ok { acc with a_started = Some t }
218
Added:
| [ "ended"; secs ] ->
219
Added:
let* t = parse_seconds "ended" secs in
220
Added:
Ok { acc with a_ended = Some t }
221
Added:
| "stimulus" :: rest ->
222
Added:
let* s = decode_stimulus rest in
223
Added:
Ok { acc with a_stimuli_rev = s :: acc.a_stimuli_rev }
224
Added:
| fields -> Error (Malformed (String.concat "|" fields))
225
Added:
226
Added:
(* Parse the whole text into a typed header, or fail. Mandatory fields are
227
Added:
checked here so replay never sees a partial record. *)
228
Added:
let parse text =
229
Added:
let lines =
230
Added:
String.split_on_char '\n' text
231
Added:
|> List.filter (fun l -> String.length l > 0)
232
Added:
|> List.map (fun l -> String.split_on_char '\t' l)
233
Added:
in
234
Added:
let rec fold acc = function
235
Added:
| [] -> Ok acc
236
Added:
| line :: tl ->
237
Added:
let* acc = step acc line in
238
Added:
fold acc tl
239
Added:
in
240
Added:
let* acc = fold empty_acc lines in
241
Added:
match (acc.a_routine, acc.a_prescription, acc.a_clearance, acc.a_started) with
242
Added:
| Some routine_name, Some prescription_name, Some clearance, Some started_at
243
Added:
->
244
Added:
Ok
245
Added:
{
246
Added:
routine_name;
247
Added:
prescription_name;
248
Added:
clearance;
249
Added:
started_at;
250
Added:
ended_at = acc.a_ended;
251
Added:
stimuli = List.rev acc.a_stimuli_rev;
252
Added:
}
253
Added:
| _ -> Error (Malformed "missing header fields")
254
Added:
255
Added:
(* Resolve the prescription named in the header against the catalog. *)
256
Added:
let resolve_prescription ~find_routine parsed =
257
Added:
match find_routine parsed.routine_name with
258
Added:
| None -> Error (Unknown_routine parsed.routine_name)
259
Added:
| Some routine -> (
260
Added:
match
261
Added:
List.find_opt
262
Added:
(fun w ->
263
Added:
String.equal (Prescription.Workout.name w) parsed.prescription_name)
264
Added:
(Prescription.Routine.workouts routine)
265
Added:
with
266
Added:
| Some prescription -> Ok prescription
267
Added:
| None ->
268
Added:
Error
269
Added:
(Unknown_workout_name
270
Added:
{
271
Added:
routine = parsed.routine_name;
272
Added:
workout = parsed.prescription_name;
273
Added:
}))
274
Added:
275
Added:
(* Drive the core constructors from a typed header. The core raises on a
276
Added:
rejected stimulus; catch it once here and report it as data corruption. *)
277
Added:
let replay ~prescription parsed =
278
Added:
try
279
Added:
let workout =
280
Added:
Evidence.Workout.start prescription ~clearance:parsed.clearance
281
Added:
~started_at:parsed.started_at
282
Added:
in
283
Added:
let workout =
284
Added:
List.fold_left Evidence.Workout.add_stimulus workout parsed.stimuli
285
Added:
in
286
Added:
let workout =
287
Added:
match parsed.ended_at with
288
Added:
| Some ended_at -> Evidence.Workout.finish workout ~ended_at
289
Added:
| None -> workout
290
Added:
in
291
Added:
Ok workout
292
Added:
with Evidence.Workout.Invalid err ->
293
Added:
Error (Replay_rejected (Format.asprintf "%a" Evidence.Workout.pp_error err))
294
Added:
295
Added:
let decode_workout ~find_routine text =
296
Added:
let* parsed = parse text in
297
Added:
let* prescription = resolve_prescription ~find_routine parsed in
298
Added:
replay ~prescription parsed
lib/app/codec.mli
@@ -0,0 +1,32 @@
1
Added:
(** Serialization of performed facts, and their replay through the core.
2
Added:
3
Added:
The core types are opaque and carry no serializers, by design: the logbook
4
Added:
records, it never interprets. This module is the trust boundary for stored
5
Added:
data. It captures only what was performed — exercise, load, reps, outcome,
6
Added:
timestamps, and the basis on which a workout was begun — and rebuilds a
7
Added:
{!Evidence.Workout.t} by driving the same constructors a live session does.
8
Added:
9
Added:
A workout's prescription is not stored. It is found again by name in the
10
Added:
routine catalog, so a stored workout stays valid only as long as its routine
11
Added:
and workout names do. That is the intended coupling: prescriptions are
12
Added:
authored, not recorded. *)
13
Added:
14
Added:
type error =
15
Added:
| Malformed of string (** The stored text does not parse. *)
16
Added:
| Unknown_exercise of string
17
Added:
| Unknown_routine of string
18
Added:
| Unknown_workout_name of { routine : string; workout : string }
19
Added:
| Replay_rejected of string
20
Added:
(** The core refused a stored stimulus; the store is inconsistent. *)
21
Added:
22
Added:
val pp_error : Format.formatter -> error -> unit
23
Added:
24
Added:
val encode_workout : routine_name:string -> Evidence.Workout.t -> string
25
Added:
(** A stable, single-string encoding of a performed or in-progress workout.
26
Added:
[routine_name] identifies the catalog routine the prescription came from. *)
27
Added:
28
Added:
val decode_workout :
29
Added:
find_routine:(string -> Prescription.Routine.t option) ->
30
Added:
string ->
31
Added:
(Evidence.Workout.t, error) result
32
Added:
(** Rebuilds a workout, resolving its prescription through [find_routine]. *)
lib/app/dune
@@ -1,4 +1,12 @@
1
1
(library
2
2
(name hito_app)
3
3
(public_name hito.app)
4
Removed:
(libraries hito.core))
4
Added:
(libraries
5
Added:
hito.core
6
Added:
lwt
7
Added:
caqti
8
Added:
caqti-lwt
9
Added:
caqti-lwt.unix
10
Added:
caqti-driver-sqlite3
11
Added:
safepass
12
Added:
uri))
lib/app/memory_repo.ml
@@ -1,45 +1,124 @@
1
Removed:
type t = {
2
Removed:
routines : (Repository.routine_id * Prescription.Routine.t) list;
1
Added:
(* Per-trainee mutable state, held in a hashtable keyed by trainee id. *)
2
Added:
type trainee_state = {
3
Added:
mutable active : Repository.routine_id option;
4
Added:
mutable current : Evidence.Workout.t option;
3
5
mutable stored : Repository.record list; (* most recent first *)
4
6
mutable next_id : int;
5
7
}
6
8
7
Removed:
let create () =
8
Removed:
{
9
Removed:
routines = [ (Repository.routine_id "ideal", Prescription.Routine.ideal) ];
10
Removed:
stored = [];
11
Removed:
next_id = 1;
12
Removed:
}
9
Added:
type t = {
10
Added:
mutable trainees : Trainee.t list;
11
Added:
states : (string, trainee_state) Hashtbl.t;
12
Added:
mutable next_trainee : int;
13
Added:
}
13
14
14
Removed:
let list_routines t = t.routines
15
Removed:
let find_routine t id = List.assoc_opt id t.routines
15
Added:
let create () = { trainees = []; states = Hashtbl.create 16; next_trainee = 1 }
16
16
17
Removed:
let save t workout =
18
Removed:
let id = Repository.workout_id (Printf.sprintf "w%d" t.next_id) in
19
Removed:
let record = { Repository.id; workout } in
20
Removed:
t.next_id <- t.next_id + 1;
21
Removed:
t.stored <- record :: t.stored;
22
Removed:
record
17
Added:
let state t id =
18
Added:
let key = Trainee.id_to_string id in
19
Added:
match Hashtbl.find_opt t.states key with
20
Added:
| Some s -> s
21
Added:
| None ->
22
Added:
let s = { active = None; current = None; stored = []; next_id = 1 } in
23
Added:
Hashtbl.replace t.states key s;
24
Added:
s
23
25
26
Added:
let create_trainee t ~(email : Trainee.email) ~credential =
27
Added:
match
28
Added:
List.find_opt
29
Added:
(fun (tr : Trainee.t) ->
30
Added:
String.equal
31
Added:
(Trainee.email_to_string tr.email)
32
Added:
(Trainee.email_to_string email))
33
Added:
t.trainees
34
Added:
with
35
Added:
| Some _ -> Lwt.return (Error `Email_taken)
36
Added:
| None ->
37
Added:
let id = Trainee.id (Printf.sprintf "t%d" t.next_trainee) in
38
Added:
t.next_trainee <- t.next_trainee + 1;
39
Added:
let trainee = { Trainee.id; email; credential } in
40
Added:
t.trainees <- trainee :: t.trainees;
41
Added:
Lwt.return (Ok trainee)
42
Added:
43
Added:
let find_trainee_by_email t (email : Trainee.email) =
44
Added:
Lwt.return
45
Added:
(List.find_opt
46
Added:
(fun (tr : Trainee.t) ->
47
Added:
String.equal
48
Added:
(Trainee.email_to_string tr.email)
49
Added:
(Trainee.email_to_string email))
50
Added:
t.trainees)
51
Added:
52
Added:
let find_trainee t id =
53
Added:
Lwt.return
54
Added:
(List.find_opt
55
Added:
(fun (tr : Trainee.t) ->
56
Added:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
57
Added:
t.trainees)
58
Added:
59
Added:
let list_routines _ = Catalog.routines
60
Added:
let find_routine _ id = Catalog.find id
61
Added:
let active_routine t id = Lwt.return (state t id).active
62
Added:
63
Added:
let set_active_routine t id routine =
64
Added:
(state t id).active <- Some routine;
65
Added:
Lwt.return_unit
66
Added:
67
Added:
let in_progress t id = Lwt.return (state t id).current
68
Added:
69
Added:
let set_in_progress t id workout =
70
Added:
(state t id).current <- workout;
71
Added:
Lwt.return_unit
72
Added:
73
Added:
let save t id workout =
74
Added:
let s = state t id in
75
Added:
let wid = Repository.workout_id (Printf.sprintf "w%d" s.next_id) in
76
Added:
let record = { Repository.id = wid; workout } in
77
Added:
s.next_id <- s.next_id + 1;
78
Added:
s.stored <- record :: s.stored;
79
Added:
Lwt.return record
80
Added:
81
Added:
(* Store the finished workout and clear the in-progress slot together. In
82
Added:
memory this is a single synchronous update, so it cannot tear. *)
83
Added:
let finish_workout t id workout =
84
Added:
let s = state t id in
85
Added:
let wid = Repository.workout_id (Printf.sprintf "w%d" s.next_id) in
86
Added:
let record = { Repository.id = wid; workout } in
87
Added:
s.next_id <- s.next_id + 1;
88
Added:
s.stored <- record :: s.stored;
89
Added:
s.current <- None;
90
Added:
Lwt.return record
91
Added:
24
92
let equal_id (a : Repository.workout_id) (b : Repository.workout_id) =
25
93
String.equal (a :> string) (b :> string)
26
94
27
Removed:
let find t id = List.find_opt (fun r -> equal_id r.Repository.id id) t.stored
95
Added:
let find t id wid =
96
Added:
let s = state t id in
97
Added:
Lwt.return (List.find_opt (fun r -> equal_id r.Repository.id wid) s.stored)
28
98
29
Removed:
let replace t record =
30
Removed:
if Option.is_none (find t record.Repository.id) then false
31
Removed:
else (
32
Removed:
t.stored <-
99
Added:
let replace t id record =
100
Added:
let s = state t id in
101
Added:
if
102
Added:
not
103
Added:
(List.exists
104
Added:
(fun r -> equal_id r.Repository.id record.Repository.id)
105
Added:
s.stored)
106
Added:
then Lwt.return false
107
Added:
else begin
108
Added:
s.stored <-
33
109
List.map
34
110
(fun existing ->
35
111
if equal_id existing.Repository.id record.Repository.id then record
36
112
else existing)
37
Removed:
t.stored;
38
Removed:
true)
113
Added:
s.stored;
114
Added:
Lwt.return true
115
Added:
end
39
116
40
Removed:
let log t =
41
Removed:
List.fold_left
42
Removed:
(fun log record -> Evidence.Log.add log record.Repository.workout)
43
Removed:
Evidence.Log.empty (List.rev t.stored)
117
Added:
let log t id =
118
Added:
let s = state t id in
119
Added:
Lwt.return
120
Added:
(List.fold_left
121
Added:
(fun log record -> Evidence.Log.add log record.Repository.workout)
122
Added:
Evidence.Log.empty (List.rev s.stored))
44
123
45
Removed:
let history t = t.stored
124
Added:
let history t id = Lwt.return (state t id).stored
lib/app/memory_repo.mli
@@ -1,7 +1,7 @@
1
Removed:
(** In-memory {!Repository.S} for dogfooding and tests. Nothing survives a
2
Removed:
restart. *)
1
Added:
(** In-memory {!Repository.S} for tests. Nothing survives a restart, and it is
2
Added:
never used in production — durable storage is {!Sqlite_repo}. *)
3
3
4
4
include Repository.S
5
5
6
6
val create : unit -> t
7
Removed:
(** Seeded with HD1's Ideal Routine, the one preset the book supports. *)
7
Added:
(** Seeded with the shared routine catalog. *)
lib/app/migrations.ml
@@ -0,0 +1,116 @@
1
Added:
type migration = { version : int; name : string; statements : string list }
2
Added:
3
Added:
let migrations =
4
Added:
[
5
Added:
{
6
Added:
version = 1;
7
Added:
name = "initial schema";
8
Added:
statements =
9
Added:
[
10
Added:
{|CREATE TABLE IF NOT EXISTS trainee (
11
Added:
id TEXT PRIMARY KEY,
12
Added:
email TEXT NOT NULL UNIQUE,
13
Added:
credential TEXT NOT NULL
14
Added:
)|};
15
Added:
{|CREATE TABLE IF NOT EXISTS active_routine (
16
Added:
trainee_id TEXT PRIMARY KEY,
17
Added:
routine_id TEXT NOT NULL
18
Added:
)|};
19
Added:
{|CREATE TABLE IF NOT EXISTS in_progress (
20
Added:
trainee_id TEXT PRIMARY KEY,
21
Added:
encoded TEXT NOT NULL
22
Added:
)|};
23
Added:
{|CREATE TABLE IF NOT EXISTS workout (
24
Added:
id TEXT PRIMARY KEY,
25
Added:
trainee_id TEXT NOT NULL,
26
Added:
seq INTEGER NOT NULL,
27
Added:
encoded TEXT NOT NULL
28
Added:
)|};
29
Added:
{|CREATE INDEX IF NOT EXISTS workout_by_trainee
30
Added:
ON workout (trainee_id, seq DESC)|};
31
Added:
(* The table Dream's sql_sessions back end expects. *)
32
Added:
{|CREATE TABLE IF NOT EXISTS dream_session (
33
Added:
id TEXT PRIMARY KEY,
34
Added:
label TEXT NOT NULL,
35
Added:
expires_at REAL NOT NULL,
36
Added:
payload TEXT NOT NULL
37
Added:
)|};
38
Added:
];
39
Added:
};
40
Added:
]
41
Added:
42
Added:
(* The ledger of applied migrations. A row per version, so a reconnect knows
43
Added:
what the file already carries and skips it. *)
44
Added:
let ledger =
45
Added:
{|CREATE TABLE IF NOT EXISTS schema_migrations (
46
Added:
version INTEGER PRIMARY KEY,
47
Added:
name TEXT NOT NULL,
48
Added:
applied_at REAL NOT NULL
49
Added:
)|}
50
Added:
51
Added:
let statements =
52
Added:
List.concat_map (fun migration -> migration.statements) migrations
53
Added:
54
Added:
(* --- request helpers --- *)
55
Added:
56
Added:
let exec_sql (module Db : Caqti_lwt.CONNECTION) sql =
57
Added:
let request =
58
Added:
let open Caqti_request.Infix in
59
Added:
let open Caqti_type.Std in
60
Added:
(unit ->. unit) ~oneshot:true sql
61
Added:
in
62
Added:
Db.exec request ()
63
Added:
64
Added:
let is_applied (module Db : Caqti_lwt.CONNECTION) version =
65
Added:
let request =
66
Added:
let open Caqti_request.Infix in
67
Added:
let open Caqti_type.Std in
68
Added:
(int ->! int) ~oneshot:true
69
Added:
"SELECT COUNT(*) FROM schema_migrations WHERE version = ?"
70
Added:
in
71
Added:
Db.find request version
72
Added:
73
Added:
let record_applied (module Db : Caqti_lwt.CONNECTION) migration =
74
Added:
let request =
75
Added:
let open Caqti_request.Infix in
76
Added:
let open Caqti_type.Std in
77
Added:
(t2 int string ->. unit)
78
Added:
~oneshot:true
79
Added:
"INSERT INTO schema_migrations (version, name, applied_at) VALUES (?, ?, \
80
Added:
strftime('%s','now'))"
81
Added:
in
82
Added:
Db.exec request (migration.version, migration.name)
83
Added:
84
Added:
(* Apply one migration inside a transaction, then record it. The ledger check
85
Added:
makes this idempotent; the [IF NOT EXISTS] clauses keep an already-populated
86
Added:
file from a pre-ledger build safe. *)
87
Added:
let apply_migration ((module Db : Caqti_lwt.CONNECTION) as db) migration =
88
Added:
let open Lwt_result.Syntax in
89
Added:
let* applied = is_applied db migration.version in
90
Added:
if applied > 0 then Lwt_result.return ()
91
Added:
else
92
Added:
Db.with_transaction (fun () ->
93
Added:
let rec go = function
94
Added:
| [] -> record_applied db migration
95
Added:
| sql :: tl ->
96
Added:
let* () = exec_sql db sql in
97
Added:
go tl
98
Added:
in
99
Added:
go migration.statements)
100
Added:
101
Added:
let apply (module Db : Caqti_lwt.CONNECTION) =
102
Added:
let db = (module Db : Caqti_lwt.CONNECTION) in
103
Added:
let open Lwt_result.Syntax in
104
Added:
let run =
105
Added:
let* () = exec_sql db ledger in
106
Added:
let rec go = function
107
Added:
| [] -> Lwt_result.return ()
108
Added:
| migration :: tl ->
109
Added:
let* () = apply_migration db migration in
110
Added:
go tl
111
Added:
in
112
Added:
go migrations
113
Added:
in
114
Added:
Lwt.map
115
Added:
(function Ok () -> Ok () | Error e -> Error (e :> Caqti_error.t))
116
Added:
run
lib/app/migrations.mli
@@ -0,0 +1,24 @@
1
Added:
(** Versioned schema migrations for the SQLite store.
2
Added:
3
Added:
Each migration is a numbered, named set of statements. A [schema_migrations]
4
Added:
ledger records which versions a database file already carries, so applying
5
Added:
on connect runs only the migrations the file is missing and never repeats
6
Added:
one. Every statement still uses [IF NOT EXISTS], so a database created by an
7
Added:
earlier, ledger-less build stays safe.
8
Added:
9
Added:
Includes the [dream_session] table {!Dream.sql_sessions} expects. *)
10
Added:
11
Added:
type migration = { version : int; name : string; statements : string list }
12
Added:
(** One migration: a version, a human name, and the ordered statements it runs.
13
Added:
*)
14
Added:
15
Added:
val migrations : migration list
16
Added:
(** Every migration, in ascending version order. *)
17
Added:
18
Added:
val apply : (module Caqti_lwt.CONNECTION) -> (unit, Caqti_error.t) result Lwt.t
19
Added:
(** Create the ledger, then apply every migration not yet recorded, each inside
20
Added:
a transaction. Idempotent across reconnects. *)
21
Added:
22
Added:
val statements : string list
23
Added:
(** Every migration's statements, in order, exposed for documentation and tests.
24
Added:
*)
lib/app/repository.ml
@@ -11,11 +11,27 @@
11
11
module type S = sig
12
12
type t
13
13
14
Added:
val create_trainee :
15
Added:
t ->
16
Added:
email:Trainee.email ->
17
Added:
credential:Trainee.credential ->
18
Added:
(Trainee.t, [ `Email_taken ]) result Lwt.t
19
Added:
20
Added:
val find_trainee_by_email : t -> Trainee.email -> Trainee.t option Lwt.t
21
Added:
val find_trainee : t -> Trainee.id -> Trainee.t option Lwt.t
14
22
val list_routines : t -> (routine_id * Prescription.Routine.t) list
15
23
val find_routine : t -> routine_id -> Prescription.Routine.t option
16
Removed:
val save : t -> Evidence.Workout.t -> record
17
Removed:
val find : t -> workout_id -> record option
18
Removed:
val replace : t -> record -> bool
19
Removed:
val log : t -> Evidence.Log.t
20
Removed:
val history : t -> record list
24
Added:
val active_routine : t -> Trainee.id -> routine_id option Lwt.t
25
Added:
val set_active_routine : t -> Trainee.id -> routine_id -> unit Lwt.t
26
Added:
val in_progress : t -> Trainee.id -> Evidence.Workout.t option Lwt.t
27
Added:
28
Added:
val set_in_progress :
29
Added:
t -> Trainee.id -> Evidence.Workout.t option -> unit Lwt.t
30
Added:
31
Added:
val save : t -> Trainee.id -> Evidence.Workout.t -> record Lwt.t
32
Added:
val finish_workout : t -> Trainee.id -> Evidence.Workout.t -> record Lwt.t
33
Added:
val find : t -> Trainee.id -> workout_id -> record option Lwt.t
34
Added:
val replace : t -> Trainee.id -> record -> bool Lwt.t
35
Added:
val log : t -> Trainee.id -> Evidence.Log.t Lwt.t
36
Added:
val history : t -> Trainee.id -> record list Lwt.t
21
37
end
lib/app/repository.mli
@@ -1,8 +1,14 @@
1
1
(** Persistence port. A pure module type: no database or web framework.
2
2
3
Removed:
Identity lives here rather than in the core, which carries none — a routine
4
Removed:
or a stored workout needs a name only once something has to remember it. *)
3
Added:
Identity lives here rather than in the core, which carries none — a routine,
4
Added:
a stored workout, or a trainee needs a name only once something has to
5
Added:
remember it.
5
6
7
Added:
Every operation is scoped to a {!Trainee.id}. There is no server-wide state:
8
Added:
the active routine and the workout in progress belong to a trainee and are
9
Added:
stored, so nothing is lost across a restart and no two trainees share a
10
Added:
slot. *)
11
Added:
6
12
type routine_id = private string
7
13
type workout_id = private string
8
14
@@ -13,23 +19,54 @@
13
19
(** A stored workout. It already knows its prescription, its timestamps, and the
14
20
basis on which it was begun. *)
15
21
22
Added:
(** Effects run in Lwt: an adapter may talk to a database. *)
16
23
module type S = sig
17
24
type t
18
25
26
Added:
(** {2 Accounts} *)
27
Added:
28
Added:
val create_trainee :
29
Added:
t ->
30
Added:
email:Trainee.email ->
31
Added:
credential:Trainee.credential ->
32
Added:
(Trainee.t, [ `Email_taken ]) result Lwt.t
33
Added:
34
Added:
val find_trainee_by_email : t -> Trainee.email -> Trainee.t option Lwt.t
35
Added:
val find_trainee : t -> Trainee.id -> Trainee.t option Lwt.t
36
Added:
37
Added:
(** {2 Catalog} — shared, not trainee-scoped. *)
38
Added:
19
39
val list_routines : t -> (routine_id * Prescription.Routine.t) list
20
40
val find_routine : t -> routine_id -> Prescription.Routine.t option
21
41
22
Removed:
val save : t -> Evidence.Workout.t -> record
42
Added:
(** {2 Per-trainee selection and workout in progress} *)
43
Added:
44
Added:
val active_routine : t -> Trainee.id -> routine_id option Lwt.t
45
Added:
val set_active_routine : t -> Trainee.id -> routine_id -> unit Lwt.t
46
Added:
val in_progress : t -> Trainee.id -> Evidence.Workout.t option Lwt.t
47
Added:
48
Added:
val set_in_progress :
49
Added:
t -> Trainee.id -> Evidence.Workout.t option -> unit Lwt.t
50
Added:
(** [None] clears the slot. *)
51
Added:
52
Added:
(** {2 History} *)
53
Added:
54
Added:
val save : t -> Trainee.id -> Evidence.Workout.t -> record Lwt.t
23
55
(** Store the workout under an identity the adapter assigns. *)
24
56
25
Removed:
val find : t -> workout_id -> record option
57
Added:
val finish_workout : t -> Trainee.id -> Evidence.Workout.t -> record Lwt.t
58
Added:
(** Store a finished workout and clear the in-progress slot as one unit. An
59
Added:
adapter with transactions performs both in a single transaction, so a
60
Added:
workout is never both saved to history and still shown as in progress. *)
26
61
27
Removed:
val replace : t -> record -> bool
62
Added:
val find : t -> Trainee.id -> workout_id -> record option Lwt.t
63
Added:
64
Added:
val replace : t -> Trainee.id -> record -> bool Lwt.t
28
65
(** Replace an existing record by identity. *)
29
66
30
Removed:
val log : t -> Evidence.Log.t
67
Added:
val log : t -> Trainee.id -> Evidence.Log.t Lwt.t
31
68
(** The stored log — the only source of evidence. *)
32
69
33
Removed:
val history : t -> record list
70
Added:
val history : t -> Trainee.id -> record list Lwt.t
34
71
(** Most recent first. *)
35
72
end
lib/app/service.ml
@@ -1,13 +1,20 @@
1
1
module Make (R : Repository.S) = struct
2
Removed:
type t = {
3
Removed:
repo : R.t;
4
Removed:
mutable active : Repository.routine_id option;
5
Removed:
mutable current : Evidence.Workout.t option;
6
Removed:
}
2
Added:
open Lwt.Infix
7
3
8
Removed:
let make ~repo = { repo; active = None; current = None }
9
Removed:
let list_routines t = R.list_routines t.repo
4
Added:
type t = { repo : R.t }
10
5
6
Added:
let make ~repo = { repo }
7
Added:
8
Added:
(* Error types are part of the flat public interface, so they live at the top
9
Added:
level of the functor. The implementation below is grouped into focused
10
Added:
use-case modules over the shared [t]; the public names are re-exported at
11
Added:
the end, so callers and {!Service.mli} see one flat service. *)
12
Added:
13
Added:
type register_error =
14
Added:
[ `Email of Trainee.email_error
15
Added:
| `Password of Trainee.password_error
16
Added:
| `Email_taken ]
17
Added:
11
18
type error = Unknown_routine | Not_recovered of Recovery.readiness
12
19
13
20
let pp_error ppf = function
@@ -15,19 +22,17 @@
15
22
| Not_recovered readiness ->
16
23
Format.fprintf ppf "not recovered: %a" Recovery.pp_readiness readiness
17
24
18
Removed:
let select_routine t id =
19
Removed:
match R.find_routine t.repo id with
20
Removed:
| None -> Error Unknown_routine
21
Removed:
| Some _ ->
22
Removed:
t.active <- Some id;
23
Removed:
Ok ()
25
Added:
type log_error = No_workout_in_progress | Rejected of Evidence.Workout.error
24
26
25
Removed:
let active_routine t =
26
Removed:
match t.active with
27
Removed:
| None -> None
28
Removed:
| Some id ->
29
Removed:
Option.map (fun routine -> (id, routine)) (R.find_routine t.repo id)
27
Added:
let pp_log_error ppf = function
28
Added:
| No_workout_in_progress ->
29
Added:
Format.pp_print_string ppf "no workout in progress"
30
Added:
| Rejected e -> Evidence.Workout.pp_error ppf e
30
31
32
Added:
type edit_error = Unknown_workout | Rejected_edit of Evidence.Workout.error
33
Added:
34
Added:
(* Shared helpers over a routine and a log, used by more than one use case. *)
35
Added:
31
36
let routine t id =
32
37
match R.find_routine t.repo id with
33
38
| Some r -> Ok r
@@ -39,9 +44,6 @@
39
44
| Some last -> Prescription.Routine.workout_after routine last
40
45
| None -> List.hd (Prescription.Routine.workouts routine)
41
46
42
Removed:
let next_workout t ~routine:id =
43
Removed:
Result.map (fun r -> next_of r (R.log t.repo)) (routine t id)
44
Removed:
45
47
(* How long HD1 asks you to rest depends on where in the cycle you are, so
46
48
the recommendation comes from the last workout performed. *)
47
49
let recommended routine log =
@@ -49,89 +51,165 @@
49
51
| Some last -> Prescription.Routine.recovery_after routine last
50
52
| None -> Prescription.Routine.training_interval
51
53
52
Removed:
let readiness t ~routine:id ~now =
53
Removed:
Result.map
54
Removed:
(fun r ->
55
Removed:
let log = R.log t.repo in
56
Removed:
Evidence.Log.readiness log ~now ~recommended:(recommended r log))
57
Removed:
(routine t id)
54
Added:
(* --- accounts --- *)
55
Added:
module Accounts = struct
56
Added:
let register t ~email ~password =
57
Added:
let open Lwt_result.Syntax in
58
Added:
(* Validate the address and password, then create the account. Each step
59
Added:
short-circuits into the shared [register_error], so the happy path
60
Added:
reads top to bottom instead of nesting. *)
61
Added:
let* email =
62
Added:
Lwt.return (Result.map_error (fun e -> `Email e) (Trainee.email email))
63
Added:
in
64
Added:
let* credential =
65
Added:
Lwt.return
66
Added:
(Result.map_error
67
Added:
(fun e -> `Password e)
68
Added:
(Trainee.hash_password password))
69
Added:
in
70
Added:
Lwt_result.map_error
71
Added:
(fun `Email_taken -> `Email_taken)
72
Added:
(R.create_trainee t.repo ~email ~credential)
58
73
59
Removed:
let begin_workout t ~routine:id ~now ?override () =
60
Removed:
match routine t id with
61
Removed:
| Error e -> Error e
62
Removed:
| Ok r -> (
63
Removed:
let log = R.log t.repo in
64
Removed:
let readiness =
65
Removed:
Evidence.Log.readiness log ~now ~recommended:(recommended r log)
66
Removed:
in
67
Removed:
let clearance =
68
Removed:
match (Recovery.clear readiness, override) with
69
Removed:
| Some c, _ -> Some c
70
Removed:
| None, Some () -> Some (Recovery.override readiness)
71
Removed:
| None, None -> None
72
Removed:
in
73
Removed:
match clearance with
74
Removed:
| None -> Error (Not_recovered readiness)
75
Removed:
| Some clearance ->
76
Removed:
let workout =
77
Removed:
Evidence.Workout.start (next_of r log) ~clearance ~started_at:now
78
Removed:
in
79
Removed:
t.current <- Some workout;
80
Removed:
Ok workout)
74
Added:
let authenticate t ~email ~password =
75
Added:
match Trainee.email email with
76
Added:
| Error _ -> Lwt.return None
77
Added:
| Ok email -> (
78
Added:
R.find_trainee_by_email t.repo email >|= function
79
Added:
| Some trainee
80
Added:
when Trainee.verify_password trainee.Trainee.credential password ->
81
Added:
Some trainee
82
Added:
| _ -> None)
81
83
82
Removed:
let in_progress t = t.current
84
Added:
let find_trainee t id = R.find_trainee t.repo id
85
Added:
end
83
86
84
Removed:
type log_error = No_workout_in_progress | Rejected of Evidence.Workout.error
87
Added:
(* --- routines and selection --- *)
88
Added:
module Routines = struct
89
Added:
let list_routines t = R.list_routines t.repo
85
90
86
Removed:
let pp_log_error ppf = function
87
Removed:
| No_workout_in_progress ->
88
Removed:
Format.pp_print_string ppf "no workout in progress"
89
Removed:
| Rejected e -> Evidence.Workout.pp_error ppf e
91
Added:
let select_routine t trainee id =
92
Added:
match R.find_routine t.repo id with
93
Added:
| None -> Lwt.return (Error Unknown_routine)
94
Added:
| Some _ -> R.set_active_routine t.repo trainee id >|= fun () -> Ok ()
90
95
91
Removed:
let log t stimulus =
92
Removed:
match t.current with
93
Removed:
| None -> Error No_workout_in_progress
94
Removed:
| Some workout -> (
95
Removed:
try
96
Removed:
let updated = Evidence.Workout.add_stimulus workout stimulus in
97
Removed:
t.current <- Some updated;
98
Removed:
Ok updated
99
Removed:
with Evidence.Workout.Invalid error -> Error (Rejected error))
96
Added:
let active_routine t trainee =
97
Added:
R.active_routine t.repo trainee >|= function
98
Added:
| None -> None
99
Added:
| Some id ->
100
Added:
Option.map (fun routine -> (id, routine)) (R.find_routine t.repo id)
100
101
101
Removed:
let finish t ~ended_at =
102
Removed:
match t.current with
103
Removed:
| None -> None
104
Removed:
| Some workout ->
105
Removed:
let finished = Evidence.Workout.finish workout ~ended_at in
106
Removed:
let record = R.save t.repo finished in
107
Removed:
t.current <- None;
108
Removed:
Some record
102
Added:
let next_workout t trainee ~routine:id =
103
Added:
let open Lwt_result.Syntax in
104
Added:
let* r = Lwt.return (routine t id) in
105
Added:
let+ log = Lwt_result.ok (R.log t.repo trainee) in
106
Added:
next_of r log
109
107
110
Removed:
type edit_error = Unknown_workout | Rejected_edit of Evidence.Workout.error
108
Added:
let readiness t trainee ~routine:id ~now =
109
Added:
let open Lwt_result.Syntax in
110
Added:
let* r = Lwt.return (routine t id) in
111
Added:
let+ log = Lwt_result.ok (R.log t.repo trainee) in
112
Added:
Evidence.Log.readiness log ~now ~recommended:(recommended r log)
113
Added:
end
111
114
112
Removed:
let find_record t id = R.find t.repo id
115
Added:
(* --- the workout in progress --- *)
116
Added:
module Workouts = struct
117
Added:
let begin_workout t trainee ~routine:id ~now ?override () =
118
Added:
let open Lwt_result.Syntax in
119
Added:
let* r = Lwt.return (routine t id) in
120
Added:
let* log = Lwt_result.ok (R.log t.repo trainee) in
121
Added:
let readiness =
122
Added:
Evidence.Log.readiness log ~now ~recommended:(recommended r log)
123
Added:
in
124
Added:
let clearance =
125
Added:
match (Recovery.clear readiness, override) with
126
Added:
| Some c, _ -> Some c
127
Added:
| None, Some () -> Some (Recovery.override readiness)
128
Added:
| None, None -> None
129
Added:
in
130
Added:
match clearance with
131
Added:
| None -> Lwt.return (Error (Not_recovered readiness))
132
Added:
| Some clearance ->
133
Added:
let workout =
134
Added:
Evidence.Workout.start (next_of r log) ~clearance ~started_at:now
135
Added:
in
136
Added:
let+ () =
137
Added:
Lwt_result.ok (R.set_in_progress t.repo trainee (Some workout))
138
Added:
in
139
Added:
workout
113
140
114
Removed:
let replace t record =
115
Removed:
if R.replace t.repo record then Ok record else Error Unknown_workout
141
Added:
let in_progress t trainee = R.in_progress t.repo trainee
116
142
117
Removed:
let add_to_record t id stimulus =
118
Removed:
match R.find t.repo id with
119
Removed:
| None -> Error Unknown_workout
120
Removed:
| Some record -> (
121
Removed:
try
122
Removed:
let workout =
143
Added:
let log t trainee stimulus =
144
Added:
R.in_progress t.repo trainee >>= function
145
Added:
| None -> Lwt.return (Error No_workout_in_progress)
146
Added:
| Some workout -> (
147
Added:
match Evidence.Workout.add_stimulus workout stimulus with
148
Added:
| updated ->
149
Added:
R.set_in_progress t.repo trainee (Some updated) >|= fun () ->
150
Added:
Ok updated
151
Added:
| exception Evidence.Workout.Invalid error ->
152
Added:
Lwt.return (Error (Rejected error)))
153
Added:
154
Added:
let finish t trainee ~ended_at =
155
Added:
R.in_progress t.repo trainee >>= function
156
Added:
| None -> Lwt.return None
157
Added:
| Some workout ->
158
Added:
let finished = Evidence.Workout.finish workout ~ended_at in
159
Added:
R.finish_workout t.repo trainee finished >|= fun record -> Some record
160
Added:
end
161
Added:
162
Added:
(* --- saved records --- *)
163
Added:
module Records = struct
164
Added:
let find_record t trainee id = R.find t.repo trainee id
165
Added:
166
Added:
let add_to_record t trainee id stimulus =
167
Added:
R.find t.repo trainee id >>= function
168
Added:
| None -> Lwt.return (Error Unknown_workout)
169
Added:
| Some record -> (
170
Added:
match
123
171
Evidence.Workout.add_stimulus record.Repository.workout stimulus
124
Removed:
in
125
Removed:
replace t { record with Repository.workout }
126
Removed:
with Evidence.Workout.Invalid error -> Error (Rejected_edit error))
172
Added:
with
173
Added:
| workout ->
174
Added:
R.replace t.repo trainee { record with Repository.workout }
175
Added:
>|= fun replaced ->
176
Added:
if replaced then Ok { record with Repository.workout }
177
Added:
else Error Unknown_workout
178
Added:
| exception Evidence.Workout.Invalid error ->
179
Added:
Lwt.return (Error (Rejected_edit error)))
127
180
128
Removed:
let history t = R.history t.repo
181
Added:
let history t trainee = R.history t.repo trainee
182
Added:
end
129
183
130
Removed:
let progress t exercise =
131
Removed:
try
132
Removed:
Ok
133
Removed:
(Progression.assess (Evidence.Log.observations (R.log t.repo) exercise))
134
Removed:
with Progression.Invalid error -> Error error
184
Added:
(* --- what the record means --- *)
185
Added:
module Assessment = struct
186
Added:
let progress t trainee exercise =
187
Added:
R.log t.repo trainee >|= fun log ->
188
Added:
match Progression.assess (Evidence.Log.observations log exercise) with
189
Added:
| assessment -> Ok assessment
190
Added:
| exception Progression.Invalid error -> Error error
135
191
136
Removed:
let diagnostics t = Progression.diagnose (R.log t.repo)
192
Added:
let diagnostics t trainee =
193
Added:
R.log t.repo trainee >|= fun log -> Progression.diagnose log
194
Added:
end
195
Added:
196
Added:
(* Re-export the use cases as one flat service, matching Service.mli. *)
197
Added:
198
Added:
let register = Accounts.register
199
Added:
let authenticate = Accounts.authenticate
200
Added:
let find_trainee = Accounts.find_trainee
201
Added:
let list_routines = Routines.list_routines
202
Added:
let select_routine = Routines.select_routine
203
Added:
let active_routine = Routines.active_routine
204
Added:
let next_workout = Routines.next_workout
205
Added:
let readiness = Routines.readiness
206
Added:
let begin_workout = Workouts.begin_workout
207
Added:
let in_progress = Workouts.in_progress
208
Added:
let log = Workouts.log
209
Added:
let finish = Workouts.finish
210
Added:
let find_record = Records.find_record
211
Added:
let add_to_record = Records.add_to_record
212
Added:
let history = Records.history
213
Added:
let progress = Assessment.progress
214
Added:
let diagnostics = Assessment.diagnostics
137
215
end
lib/app/service.mli
@@ -1,6 +1,10 @@
1
1
(** Application service: orchestrates the core over a {!Repository.S}. The API a
2
2
client calls — no HTML or serialization.
3
3
4
Added:
Every call is scoped to a {!Trainee.id}. The service holds no mutable state
5
Added:
of its own: the active routine and the workout in progress live in the
6
Added:
repository, so a restart loses nothing and two trainees never share a slot.
7
Added:
4
8
Recovery gating lives here, not in the client. {!Evidence.Workout.start}
5
9
demands a {!Recovery.clearance}, and this module is the only thing that
6
10
decides how one is obtained: earned by having rested, or taken deliberately
@@ -14,6 +18,29 @@
14
18
val make : repo:R.t -> t
15
19
(** [repo] is the store this service reads and writes. *)
16
20
21
Added:
(** {2 Accounts} *)
22
Added:
23
Added:
type register_error =
24
Added:
[ `Email of Trainee.email_error
25
Added:
| `Password of Trainee.password_error
26
Added:
| `Email_taken ]
27
Added:
(** Why registration was refused: a malformed email, a too-short password, or
28
Added:
an address already in use. *)
29
Added:
30
Added:
val register :
31
Added:
t ->
32
Added:
email:string ->
33
Added:
password:string ->
34
Added:
(Trainee.t, register_error) result Lwt.t
35
Added:
36
Added:
val authenticate :
37
Added:
t -> email:string -> password:string -> Trainee.t option Lwt.t
38
Added:
(** [Some] only when the address is known and the password verifies. *)
39
Added:
40
Added:
val find_trainee : t -> Trainee.id -> Trainee.t option Lwt.t
41
Added:
42
Added:
(** {2 Routines} *)
43
Added:
17
44
val list_routines : t -> (Repository.routine_id * Prescription.Routine.t) list
18
45
19
46
type error =
@@ -23,34 +50,42 @@
23
50
the reading so a client can say how much longer. *)
24
51
25
52
val pp_error : Format.formatter -> error -> unit
26
Removed:
val select_routine : t -> Repository.routine_id -> (unit, error) result
27
53
54
Added:
val select_routine :
55
Added:
t -> Trainee.id -> Repository.routine_id -> (unit, error) result Lwt.t
56
Added:
28
57
val active_routine :
29
Removed:
t -> (Repository.routine_id * Prescription.Routine.t) option
58
Added:
t ->
59
Added:
Trainee.id ->
60
Added:
(Repository.routine_id * Prescription.Routine.t) option Lwt.t
30
61
31
62
val next_workout :
32
Removed:
t -> routine:Repository.routine_id -> (Prescription.Workout.t, error) result
63
Added:
t ->
64
Added:
Trainee.id ->
65
Added:
routine:Repository.routine_id ->
66
Added:
(Prescription.Workout.t, error) result Lwt.t
33
67
(** Where the cycle stands: the workout after the last one logged. *)
34
68
35
69
val readiness :
36
70
t ->
71
Added:
Trainee.id ->
37
72
routine:Repository.routine_id ->
38
73
now:Recovery.timestamp ->
39
Removed:
(Recovery.readiness, error) result
74
Added:
(Recovery.readiness, error) result Lwt.t
40
75
41
76
val begin_workout :
42
77
t ->
78
Added:
Trainee.id ->
43
79
routine:Repository.routine_id ->
44
80
now:Recovery.timestamp ->
45
81
?override:unit ->
46
82
unit ->
47
Removed:
(Evidence.Workout.t, error) result
83
Added:
(Evidence.Workout.t, error) result Lwt.t
48
84
(** Start the next workout. [Error (Not_recovered _)] unless recovery is
49
85
complete or [override] explicitly acknowledges early training. *)
50
86
51
Removed:
val in_progress : t -> Evidence.Workout.t option
52
Removed:
(** The workout being logged, if any. Single-user: one slot for the whole
53
Removed:
server. This must become per-trainee before authentication exists. *)
87
Added:
val in_progress : t -> Trainee.id -> Evidence.Workout.t option Lwt.t
88
Added:
(** The workout being logged, if any. Per-trainee and durable. *)
54
89
55
90
type log_error =
56
91
| No_workout_in_progress
@@ -59,28 +94,41 @@
59
94
60
95
val pp_log_error : Format.formatter -> log_error -> unit
61
96
62
Removed:
val log : t -> Evidence.Stimulus.t -> (Evidence.Workout.t, log_error) result
97
Added:
val log :
98
Added:
t ->
99
Added:
Trainee.id ->
100
Added:
Evidence.Stimulus.t ->
101
Added:
(Evidence.Workout.t, log_error) result Lwt.t
63
102
(** Record a stimulus against the workout in progress. *)
64
103
65
Removed:
val finish : t -> ended_at:Recovery.timestamp -> Repository.record option
104
Added:
val finish :
105
Added:
t ->
106
Added:
Trainee.id ->
107
Added:
ended_at:Recovery.timestamp ->
108
Added:
Repository.record option Lwt.t
66
109
(** Complete and persist the workout in progress, clearing the slot. [None] if
67
110
nothing was in progress. *)
68
111
69
112
type edit_error = Unknown_workout | Rejected_edit of Evidence.Workout.error
70
113
71
Removed:
val find_record : t -> Repository.workout_id -> Repository.record option
114
Added:
val find_record :
115
Added:
t -> Trainee.id -> Repository.workout_id -> Repository.record option Lwt.t
72
116
73
117
val add_to_record :
74
118
t ->
119
Added:
Trainee.id ->
75
120
Repository.workout_id ->
76
121
Evidence.Stimulus.t ->
77
Removed:
(Repository.record, edit_error) result
122
Added:
(Repository.record, edit_error) result Lwt.t
78
123
79
Removed:
val history : t -> Repository.record list
124
Added:
val history : t -> Trainee.id -> Repository.record list Lwt.t
80
125
81
126
val progress :
82
Removed:
t -> Exercise.t -> (Progression.assessment, Progression.error) result
127
Added:
t ->
128
Added:
Trainee.id ->
129
Added:
Exercise.t ->
130
Added:
(Progression.assessment, Progression.error) result Lwt.t
83
131
84
Removed:
val diagnostics : t -> Progression.diagnostic list
132
Added:
val diagnostics : t -> Trainee.id -> Progression.diagnostic list Lwt.t
85
133
(** Habits the record shows that HD1 names as causes of overtraining. *)
86
134
end
lib/app/sqlite_repo.ml
@@ -0,0 +1,245 @@
1
Added:
open Lwt.Infix
2
Added:
3
Added:
exception Corrupt of Codec.error
4
Added:
5
Added:
type t = {
6
Added:
pool : (Caqti_lwt.connection, Caqti_error.t) Caqti_lwt_unix.Pool.t;
7
Added:
mutable next_trainee : int;
8
Added:
}
9
Added:
10
Added:
(* --- request definitions --- *)
11
Added:
12
Added:
module Q = struct
13
Added:
open Caqti_request.Infix
14
Added:
open Caqti_type.Std
15
Added:
16
Added:
let insert_trainee =
17
Added:
(t3 string string string ->. unit)
18
Added:
"INSERT INTO trainee (id, email, credential) VALUES (?, ?, ?)"
19
Added:
20
Added:
let trainee_by_email =
21
Added:
(string ->? t3 string string string)
22
Added:
"SELECT id, email, credential FROM trainee WHERE email = ?"
23
Added:
24
Added:
let trainee_by_id =
25
Added:
(string ->? t3 string string string)
26
Added:
"SELECT id, email, credential FROM trainee WHERE id = ?"
27
Added:
28
Added:
let get_active =
29
Added:
(string ->? string)
30
Added:
"SELECT routine_id FROM active_routine WHERE trainee_id = ?"
31
Added:
32
Added:
let set_active =
33
Added:
(t2 string string ->. unit)
34
Added:
"INSERT INTO active_routine (trainee_id, routine_id) VALUES (?, ?) ON \
35
Added:
CONFLICT (trainee_id) DO UPDATE SET routine_id = excluded.routine_id"
36
Added:
37
Added:
let get_in_progress =
38
Added:
(string ->? string) "SELECT encoded FROM in_progress WHERE trainee_id = ?"
39
Added:
40
Added:
let set_in_progress =
41
Added:
(t2 string string ->. unit)
42
Added:
"INSERT INTO in_progress (trainee_id, encoded) VALUES (?, ?) ON CONFLICT \
43
Added:
(trainee_id) DO UPDATE SET encoded = excluded.encoded"
44
Added:
45
Added:
let clear_in_progress =
46
Added:
(string ->. unit) "DELETE FROM in_progress WHERE trainee_id = ?"
47
Added:
48
Added:
let next_seq =
49
Added:
(string ->! int)
50
Added:
"SELECT COALESCE(MAX(seq), 0) + 1 FROM workout WHERE trainee_id = ?"
51
Added:
52
Added:
let insert_workout =
53
Added:
(t4 string string int string ->. unit)
54
Added:
"INSERT INTO workout (id, trainee_id, seq, encoded) VALUES (?, ?, ?, ?)"
55
Added:
56
Added:
let workout_by_id =
57
Added:
(t2 string string ->? string)
58
Added:
"SELECT encoded FROM workout WHERE trainee_id = ? AND id = ?"
59
Added:
60
Added:
let update_workout =
61
Added:
(t3 string string string ->. unit)
62
Added:
"UPDATE workout SET encoded = ? WHERE trainee_id = ? AND id = ?"
63
Added:
64
Added:
let history =
65
Added:
(string ->* t2 string string)
66
Added:
"SELECT id, encoded FROM workout WHERE trainee_id = ? ORDER BY seq DESC"
67
Added:
end
68
Added:
69
Added:
(* --- pool helper --- *)
70
Added:
71
Added:
let run t f = Caqti_lwt_unix.Pool.use f t.pool >>= Caqti_lwt.or_fail
72
Added:
73
Added:
let connect uri =
74
Added:
match Caqti_lwt_unix.connect_pool (Uri.of_string uri) with
75
Added:
| Error e -> Lwt.return (Error (e :> Caqti_error.t))
76
Added:
| Ok pool -> (
77
Added:
Caqti_lwt_unix.Pool.use Migrations.apply pool >>= function
78
Added:
| Error e -> Lwt.return (Error e)
79
Added:
| Ok () -> Lwt.return (Ok { pool; next_trainee = 1 }))
80
Added:
81
Added:
(* --- decoding stored workouts --- *)
82
Added:
83
Added:
let find_routine_by_name = Catalog.find_by_name
84
Added:
85
Added:
let decode encoded =
86
Added:
match Codec.decode_workout ~find_routine:find_routine_by_name encoded with
87
Added:
| Ok workout -> workout
88
Added:
| Error e -> raise (Corrupt e)
89
Added:
90
Added:
(* --- accounts --- *)
91
Added:
92
Added:
let create_trainee t ~email ~credential =
93
Added:
let email_s = Trainee.email_to_string email in
94
Added:
let credential_s = Trainee.credential_to_hash credential in
95
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
96
Added:
Db.find_opt Q.trainee_by_email email_s)
97
Added:
>>= function
98
Added:
| Some _ -> Lwt.return (Error `Email_taken)
99
Added:
| None ->
100
Added:
let id = Printf.sprintf "t%d" t.next_trainee in
101
Added:
t.next_trainee <- t.next_trainee + 1;
102
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
103
Added:
Db.exec Q.insert_trainee (id, email_s, credential_s))
104
Added:
>|= fun () -> Ok { Trainee.id = Trainee.id id; email; credential }
105
Added:
106
Added:
let trainee_of_row (id, email, credential) =
107
Added:
match Trainee.email email with
108
Added:
| Ok email ->
109
Added:
Some
110
Added:
{
111
Added:
Trainee.id = Trainee.id id;
112
Added:
email;
113
Added:
credential = Trainee.credential_of_hash credential;
114
Added:
}
115
Added:
| Error _ -> None
116
Added:
117
Added:
let find_trainee_by_email t email =
118
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
119
Added:
Db.find_opt Q.trainee_by_email (Trainee.email_to_string email))
120
Added:
>|= function
121
Added:
| Some row -> trainee_of_row row
122
Added:
| None -> None
123
Added:
124
Added:
let find_trainee t id =
125
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
126
Added:
Db.find_opt Q.trainee_by_id (Trainee.id_to_string id))
127
Added:
>|= function
128
Added:
| Some row -> trainee_of_row row
129
Added:
| None -> None
130
Added:
131
Added:
(* --- catalog --- *)
132
Added:
133
Added:
let list_routines _ = Catalog.routines
134
Added:
let find_routine _ id = Catalog.find id
135
Added:
136
Added:
(* The routine name a workout's prescription belongs to, for encoding. Only the
137
Added:
ideal routine exists, but resolve it honestly rather than hard-code. *)
138
Added:
let routine_name_of workout =
139
Added:
let workout_name =
140
Added:
Prescription.Workout.name (Evidence.Workout.prescription workout)
141
Added:
in
142
Added:
List.find_map
143
Added:
(fun (_, routine) ->
144
Added:
if
145
Added:
List.exists
146
Added:
(fun w -> String.equal (Prescription.Workout.name w) workout_name)
147
Added:
(Prescription.Routine.workouts routine)
148
Added:
then Some (Prescription.Routine.name routine)
149
Added:
else None)
150
Added:
Catalog.routines
151
Added:
|> Option.value ~default:""
152
Added:
153
Added:
let encode workout =
154
Added:
Codec.encode_workout ~routine_name:(routine_name_of workout) workout
155
Added:
156
Added:
(* --- per-trainee selection and workout in progress --- *)
157
Added:
158
Added:
let active_routine t id =
159
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
160
Added:
Db.find_opt Q.get_active (Trainee.id_to_string id))
161
Added:
>|= Option.map Repository.routine_id
162
Added:
163
Added:
let set_active_routine t id (routine : Repository.routine_id) =
164
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
165
Added:
Db.exec Q.set_active (Trainee.id_to_string id, (routine :> string)))
166
Added:
167
Added:
let in_progress t id =
168
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
169
Added:
Db.find_opt Q.get_in_progress (Trainee.id_to_string id))
170
Added:
>|= function
171
Added:
| None -> None
172
Added:
| Some encoded -> Some (decode encoded)
173
Added:
174
Added:
let set_in_progress t id workout =
175
Added:
let trainee = Trainee.id_to_string id in
176
Added:
match workout with
177
Added:
| None ->
178
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
179
Added:
Db.exec Q.clear_in_progress trainee)
180
Added:
| Some workout ->
181
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
182
Added:
Db.exec Q.set_in_progress (trainee, encode workout))
183
Added:
184
Added:
(* --- history --- *)
185
Added:
186
Added:
let save t id workout =
187
Added:
let trainee = Trainee.id_to_string id in
188
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) -> Db.find Q.next_seq trainee)
189
Added:
>>= fun seq ->
190
Added:
let wid = Printf.sprintf "%s:w%d" trainee seq in
191
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
192
Added:
Db.exec Q.insert_workout (wid, trainee, seq, encode workout))
193
Added:
>|= fun () -> { Repository.id = Repository.workout_id wid; workout }
194
Added:
195
Added:
(* Save a finished workout and clear the in-progress slot in one transaction,
196
Added:
so the two rows never disagree after a crash. Both statements run on the same
197
Added:
connection, checked out once, inside [with_transaction]. *)
198
Added:
let finish_workout t id workout =
199
Added:
let trainee = Trainee.id_to_string id in
200
Added:
let encoded = encode workout in
201
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
202
Added:
let open Lwt_result.Syntax in
203
Added:
Db.with_transaction (fun () ->
204
Added:
let* seq = Db.find Q.next_seq trainee in
205
Added:
let wid = Printf.sprintf "%s:w%d" trainee seq in
206
Added:
let* () = Db.exec Q.insert_workout (wid, trainee, seq, encoded) in
207
Added:
let* () = Db.exec Q.clear_in_progress trainee in
208
Added:
Lwt_result.return
209
Added:
{ Repository.id = Repository.workout_id wid; workout }))
210
Added:
211
Added:
let find t id (wid : Repository.workout_id) =
212
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
213
Added:
Db.find_opt Q.workout_by_id (Trainee.id_to_string id, (wid :> string)))
214
Added:
>|= function
215
Added:
| None -> None
216
Added:
| Some encoded -> Some { Repository.id = wid; workout = decode encoded }
217
Added:
218
Added:
let replace t id record =
219
Added:
let trainee = Trainee.id_to_string id in
220
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
221
Added:
Db.find_opt Q.workout_by_id (trainee, (record.Repository.id :> string)))
222
Added:
>>= function
223
Added:
| None -> Lwt.return false
224
Added:
| Some _ ->
225
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
226
Added:
Db.exec Q.update_workout
227
Added:
( encode record.Repository.workout,
228
Added:
trainee,
229
Added:
(record.Repository.id :> string) ))
230
Added:
>|= fun () -> true
231
Added:
232
Added:
let history t id =
233
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
234
Added:
Db.collect_list Q.history (Trainee.id_to_string id))
235
Added:
>|= fun rows ->
236
Added:
List.map
237
Added:
(fun (wid, encoded) ->
238
Added:
{ Repository.id = Repository.workout_id wid; workout = decode encoded })
239
Added:
rows
240
Added:
241
Added:
let log t id =
242
Added:
history t id >|= fun records ->
243
Added:
List.fold_left
244
Added:
(fun log record -> Evidence.Log.add log record.Repository.workout)
245
Added:
Evidence.Log.empty (List.rev records)
lib/app/sqlite_repo.mli
@@ -0,0 +1,21 @@
1
Added:
(** Durable {!Repository.S} backed by SQLite through Caqti. The production
2
Added:
store.
3
Added:
4
Added:
All performed facts are stored through {!Codec}: the adapter never inspects
5
Added:
domain shape, it stores and returns opaque encoded strings. Prescriptions
6
Added:
are not stored — a workout resolves its prescription against the shared
7
Added:
{!Catalog} on read.
8
Added:
9
Added:
Identity is assigned here: trainees and workouts get string ids the adapter
10
Added:
mints. *)
11
Added:
12
Added:
include Repository.S
13
Added:
14
Added:
exception Corrupt of Codec.error
15
Added:
(** Raised when a stored workout cannot be decoded — a corrupted database or a
16
Added:
catalog that no longer names a stored routine or workout. This is a fault,
17
Added:
not a normal outcome. *)
18
Added:
19
Added:
val connect : string -> (t, Caqti_error.t) result Lwt.t
20
Added:
(** [connect uri] opens a connection pool and applies {!Migrations}. [uri] is a
21
Added:
Caqti URI such as ["sqlite3:hito.sqlite"]. *)
lib/app/trainee.ml
@@ -0,0 +1,39 @@
1
Added:
type id = string
2
Added:
3
Added:
let id s = s
4
Added:
let id_to_string s = s
5
Added:
6
Added:
type email = string
7
Added:
type email_error = Empty | No_at_sign
8
Added:
9
Added:
let pp_email_error ppf = function
10
Added:
| Empty -> Format.pp_print_string ppf "an email address is required"
11
Added:
| No_at_sign -> Format.pp_print_string ppf "that is not an email address"
12
Added:
13
Added:
let email raw =
14
Added:
let normalized = String.trim raw |> String.lowercase_ascii in
15
Added:
if String.length normalized = 0 then Error Empty
16
Added:
else if not (String.contains normalized '@') then Error No_at_sign
17
Added:
else Ok normalized
18
Added:
19
Added:
let email_to_string e = e
20
Added:
21
Added:
type credential = string (* the bcrypt hash string *)
22
Added:
23
Added:
let credential_of_hash h = h
24
Added:
let credential_to_hash h = h
25
Added:
26
Added:
type password_error = Too_short
27
Added:
28
Added:
let password_min_length = 8
29
Added:
30
Added:
let hash_password password =
31
Added:
if String.length password < password_min_length then Error Too_short
32
Added:
else Ok (Bcrypt.string_of_hash (Bcrypt.hash password))
33
Added:
34
Added:
let verify_password credential password =
35
Added:
match Bcrypt.hash_of_string credential with
36
Added:
| hash -> Bcrypt.verify password hash
37
Added:
| exception _ -> false
38
Added:
39
Added:
type t = { id : id; email : email; credential : credential }
lib/app/trainee.mli
@@ -0,0 +1,47 @@
1
Added:
(** A trainee: the account that owns a routine, a workout in progress, and a
2
Added:
logbook. Identity lives in {!Hito_app}, not the core, because the core needs
3
Added:
none.
4
Added:
5
Added:
A {!credential} is a password verifier, never the password. The hash is
6
Added:
computed and checked here so that no other layer sees a plaintext password
7
Added:
for longer than one request. *)
8
Added:
9
Added:
type id = private string
10
Added:
(** An opaque account identity, assigned by an adapter. *)
11
Added:
12
Added:
val id : string -> id
13
Added:
val id_to_string : id -> string
14
Added:
15
Added:
type email = private string
16
Added:
(** A normalized email address: trimmed and lowercased. *)
17
Added:
18
Added:
type email_error = Empty | No_at_sign
19
Added:
20
Added:
val email : string -> (email, email_error) result
21
Added:
(** Normalizes and validates an address. This is a syntactic check only. *)
22
Added:
23
Added:
val email_to_string : email -> string
24
Added:
val pp_email_error : Format.formatter -> email_error -> unit
25
Added:
26
Added:
type credential
27
Added:
(** A password verifier. Carries a salted hash, never the password. *)
28
Added:
29
Added:
val credential_of_hash : string -> credential
30
Added:
(** Wraps a stored hash read back from persistence. *)
31
Added:
32
Added:
val credential_to_hash : credential -> string
33
Added:
(** The stored hash, for persistence. *)
34
Added:
35
Added:
type password_error = Too_short
36
Added:
37
Added:
val password_min_length : int
38
Added:
39
Added:
val hash_password : string -> (credential, password_error) result
40
Added:
(** Salts and hashes a new password. Rejects passwords under
41
Added:
{!password_min_length}. *)
42
Added:
43
Added:
val verify_password : credential -> string -> bool
44
Added:
(** Constant-time verification of a candidate password against the verifier. *)
45
Added:
46
Added:
type t = { id : id; email : email; credential : credential }
47
Added:
(** A stored account. *)
lib/web/dune
@@ -11,4 +11,4 @@
11
11
(modules routes decode pages handlers stylesheet)
12
12
(preprocess
13
13
(pps dream-html.ppx))
14
Removed:
(libraries hito.core hito.app dream dream-html unix))
14
Added:
(libraries hito.core hito.app dream dream-html lwt unix))
lib/web/handlers.ml
@@ -1,219 +1,366 @@
1
1
open Lwt.Infix
2
2
open Hito_app
3
Removed:
module Service = Service.Make (Memory_repo)
4
3
5
Removed:
type t = { service : Service.t; now : unit -> Recovery.timestamp }
4
Added:
module Make (R : Repository.S) = struct
5
Added:
module Service = Service.Make (R)
6
6
7
Removed:
let default_now () =
8
Removed:
Recovery.timestamp_of_unix_seconds (int_of_float (Unix.gettimeofday ()))
7
Added:
type t = { service : Service.t; now : unit -> Recovery.timestamp }
9
8
10
Removed:
let create ?(now = default_now) () =
11
Removed:
{ service = Service.make ~repo:(Memory_repo.create ()); now }
9
Added:
let default_now () =
10
Added:
Recovery.timestamp_of_unix_seconds (int_of_float (Unix.gettimeofday ()))
12
11
13
Removed:
let html ?status page = Dream_html.respond ?status page
14
Removed:
let redirect request path = Dream_html.redirect request path
12
Added:
let make ~repo ?(now = default_now) () = { service = Service.make ~repo; now }
13
Added:
let html ?status page = Dream_html.respond ?status page
14
Added:
let redirect request path = Dream_html.redirect request path
15
15
16
Removed:
let not_found detail =
17
Removed:
html (Pages.problem ~title:"Not found" ~detail) ~status:`Not_Found
16
Added:
let redirect_to request path =
17
Added:
redirect request (Dream_html.path_attr Dream_html.HTML.href path)
18
18
19
Removed:
let bad_request detail =
20
Removed:
html (Pages.problem ~title:"Invalid request" ~detail) ~status:`Bad_Request
19
Added:
let not_found detail =
20
Added:
html (Pages.problem ~title:"Not found" ~detail) ~status:`Not_Found
21
21
22
Removed:
let decode_form decoder request =
23
Removed:
Dream_html.form decoder ~csrf:false request >|= function
24
Removed:
| `Ok value -> Ok value
25
Removed:
| `Invalid errors -> Error (`Invalid errors)
26
Removed:
| _ -> Error `Bad_request
22
Added:
let bad_request detail =
23
Added:
html (Pages.problem ~title:"Invalid request" ~detail) ~status:`Bad_Request
27
24
28
Removed:
let record_target t id =
29
Removed:
Service.find_record t.service (Repository.workout_id id)
30
Removed:
|> Option.map (fun record ->
31
Removed:
(record.Repository.id, record.Repository.workout))
25
Added:
(* --- presentation of errors ---
32
26
33
Removed:
let outstanding workout slot =
34
Removed:
List.assoc_opt slot (Evidence.Workout.outstanding workout)
27
Added:
Every domain and service error becomes a user-facing sentence here, so a
28
Added:
handler renders a message rather than deciding its wording. One module owns
29
Added:
the phrasing, and adding an error variant surfaces as a missing case. *)
30
Added:
module Present = struct
31
Added:
let form_invalid = "The submitted form is not valid."
35
32
36
Removed:
let save_current t stimulus =
37
Removed:
match Service.log t.service stimulus with
38
Removed:
| Ok _ -> Ok ()
39
Removed:
| Error Service.No_workout_in_progress -> Error "No workout is in progress."
40
Removed:
| Error (Service.Rejected error) ->
41
Removed:
Error (Format.asprintf "%a" Evidence.Workout.pp_error error)
33
Added:
let registration : Service.register_error -> string = function
34
Added:
| `Email e -> Format.asprintf "%a" Trainee.pp_email_error e
35
Added:
| `Password Trainee.Too_short ->
36
Added:
Printf.sprintf "Use at least %d characters."
37
Added:
Trainee.password_min_length
38
Added:
| `Email_taken -> "That email is already registered."
42
39
43
Removed:
let save_record t id stimulus =
44
Removed:
match Service.add_to_record t.service id stimulus with
45
Removed:
| Ok _ -> Ok ()
46
Removed:
| Error Service.Unknown_workout ->
47
Removed:
Error "That saved workout no longer exists."
48
Removed:
| Error (Service.Rejected_edit error) ->
49
Removed:
Error (Format.asprintf "%a" Evidence.Workout.pp_error error)
40
Added:
let sign_in_failed = "That email and password do not match."
41
Added:
let routine = Format.asprintf "%a" Service.pp_error
50
42
51
Removed:
module Overview = struct
52
Removed:
let page t =
53
Removed:
match Service.in_progress t.service with
54
Removed:
| Some workout -> Pages.workout ~record_id:None workout
55
Removed:
| None -> (
56
Removed:
match Service.active_routine t.service with
57
Removed:
| None ->
58
Removed:
Pages.choose_routine ~routines:(Service.list_routines t.service)
59
Removed:
| Some (routine, selected) -> (
60
Removed:
match
61
Removed:
( Service.next_workout t.service ~routine,
62
Removed:
Service.readiness t.service ~routine ~now:(t.now ()) )
63
Removed:
with
64
Removed:
| Ok next, Ok readiness ->
65
Removed:
Pages.home ~routine
66
Removed:
~routine_name:(Prescription.Routine.name selected)
67
Removed:
~next ~readiness
68
Removed:
| Error error, _ | _, Error error ->
69
Removed:
Pages.problem ~title:"Routine unavailable"
70
Removed:
~detail:(Format.asprintf "%a" Service.pp_error error)))
43
Added:
let log_error : Service.log_error -> string = function
44
Added:
| Service.No_workout_in_progress -> "No workout is in progress."
45
Added:
| Service.Rejected error ->
46
Added:
Format.asprintf "%a" Evidence.Workout.pp_error error
71
47
72
Removed:
let home t _request = html (page t)
48
Added:
let edit_error : Service.edit_error -> string = function
49
Added:
| Service.Unknown_workout -> "That saved workout no longer exists."
50
Added:
| Service.Rejected_edit error ->
51
Added:
Format.asprintf "%a" Evidence.Workout.pp_error error
73
52
74
Removed:
let routines t _request =
75
Removed:
html (Pages.choose_routine ~routines:(Service.list_routines t.service))
53
Added:
let unknown_routine = "That routine is not in the catalogue."
54
Added:
let unknown_record = "That saved workout no longer exists."
55
Added:
let no_workout = "No workout is in progress."
56
Added:
let slot_not_awaiting = "That slot is not awaiting a record."
57
Added:
end
76
58
77
Removed:
let select_routine t request id =
78
Removed:
match Service.select_routine t.service (Repository.routine_id id) with
79
Removed:
| Ok () ->
80
Removed:
redirect request (Dream_html.path_attr Dream_html.HTML.href Routes.home)
81
Removed:
| Error _ -> not_found "That routine is not in the catalogue."
59
Added:
(* --- sessions and authentication --- *)
82
60
83
Removed:
let routine t request =
84
Removed:
match Service.active_routine t.service with
85
Removed:
| Some (_, routine) -> html (Pages.routine routine)
86
Removed:
| None ->
87
Removed:
redirect request
88
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.routines)
61
Added:
let session_key = "trainee"
89
62
90
Removed:
let routes t =
91
Removed:
[
92
Removed:
Dream_html.get Routes.home (home t);
93
Removed:
Dream_html.get Routes.routines (routines t);
94
Removed:
Dream_html.post Routes.select_routine (select_routine t);
95
Removed:
Dream_html.get Routes.routine (routine t);
96
Removed:
]
97
Removed:
end
63
Added:
let current_trainee t request =
64
Added:
match Dream.session_field request session_key with
65
Added:
| None -> Lwt.return None
66
Added:
| Some id -> Service.find_trainee t.service (Trainee.id id)
98
67
99
Removed:
module Current_workout = struct
100
Removed:
let begin_workout t request =
101
Removed:
decode_form Decode.override request >>= function
102
Removed:
| Error _ -> bad_request "The submitted form is not valid."
103
Removed:
| Ok override -> (
104
Removed:
match Service.active_routine t.service with
105
Removed:
| None ->
106
Removed:
redirect request
107
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.routines)
108
Removed:
| Some (routine, _) -> (
109
Removed:
let override = if override then Some () else None in
110
Removed:
match
111
Removed:
Service.begin_workout t.service ~routine ~now:(t.now ()) ?override
112
Removed:
()
113
Removed:
with
114
Removed:
| Ok _ ->
115
Removed:
redirect request
116
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
117
Removed:
| Error (Service.Not_recovered _) ->
118
Removed:
redirect request
119
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.home)
120
Removed:
| Error Service.Unknown_routine ->
121
Removed:
not_found "That routine is not in the catalogue."))
68
Added:
(* Resolve the authenticated trainee, or send an unauthenticated request to
69
Added:
the sign-in page. [handler] receives the trainee; the request and any path
70
Added:
captures stay in the caller's scope, so this one combinator serves every
71
Added:
route regardless of how many captures Dream passes. *)
72
Added:
let authenticated t request handler =
73
Added:
current_trainee t request >>= function
74
Added:
| Some trainee -> handler trainee
75
Added:
| None -> redirect_to request Routes.login
122
76
123
Removed:
let show t request =
124
Removed:
match Service.in_progress t.service with
125
Removed:
| Some workout -> html (Pages.workout ~record_id:None workout)
126
Removed:
| None ->
127
Removed:
redirect request (Dream_html.path_attr Dream_html.HTML.href Routes.home)
77
Added:
let decode_form decoder request =
78
Added:
Dream_html.form decoder ~csrf:true request >|= function
79
Added:
| `Ok value -> Ok value
80
Added:
| `Invalid errors -> Error (`Invalid errors)
81
Added:
| _ -> Error `Bad_request
128
82
129
Removed:
let log t request slot =
130
Removed:
match Service.in_progress t.service with
131
Removed:
| None -> not_found "No workout is in progress."
132
Removed:
| Some workout -> (
133
Removed:
match outstanding workout slot with
134
Removed:
| None -> not_found "That slot is not awaiting a record."
135
Removed:
| Some prescription -> (
136
Removed:
decode_form (Decode.stimulus prescription) request >>= function
137
Removed:
| Error (`Invalid errors) ->
138
Removed:
html ~status:`Bad_Request
139
Removed:
(Pages.workout ~errors ~record_id:None workout)
140
Removed:
| Error `Bad_request ->
141
Removed:
bad_request "The submitted form is not valid."
142
Removed:
| Ok stimulus -> (
143
Removed:
match save_current t stimulus with
144
Removed:
| Ok () ->
145
Removed:
redirect request
146
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.workout)
147
Removed:
| Error detail -> bad_request detail)))
83
Added:
(* Plain (non-dream-html) form read with CSRF, for auth forms. *)
84
Added:
let read_credentials request =
85
Added:
Dream.form request >|= function
86
Added:
| `Ok fields -> (
87
Added:
let get k = List.assoc_opt k fields in
88
Added:
match (get "email", get "password") with
89
Added:
| Some email, Some password -> Ok (email, password)
90
Added:
| _ -> Error `Bad_request)
91
Added:
| _ -> Error `Bad_request
148
92
149
Removed:
let finish t request =
150
Removed:
match Service.finish t.service ~ended_at:(t.now ()) with
151
Removed:
| Some _ ->
152
Removed:
redirect request
153
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.history)
154
Removed:
| None -> not_found "No workout is in progress."
93
Added:
(* A CSRF guard for state-changing POSTs whose body carries no fields other
94
Added:
than the token. [Dream.form] verifies the token and returns [`Ok] only
95
Added:
when it is valid, so this rejects a forged or missing token. *)
96
Added:
let guard_csrf request =
97
Added:
Dream.form request >|= function `Ok _ -> Ok () | _ -> Error `Bad_request
155
98
156
Removed:
let routes t =
157
Removed:
[
158
Removed:
Dream_html.get Routes.workout (show t);
159
Removed:
Dream_html.post Routes.workout (begin_workout t);
160
Removed:
Dream_html.post Routes.workout_slot (log t);
161
Removed:
Dream_html.post Routes.finish_workout (finish t);
162
Removed:
]
163
Removed:
end
99
Added:
module Auth = struct
100
Added:
let login_page t request =
101
Added:
current_trainee t request >>= function
102
Added:
| Some _ -> redirect_to request Routes.home
103
Added:
| None -> html (Pages.login request ())
164
104
165
Removed:
module History = struct
166
Removed:
let index t _request = html (Pages.history (Service.history t.service))
105
Added:
let register_page t request =
106
Added:
current_trainee t request >>= function
107
Added:
| Some _ -> redirect_to request Routes.home
108
Added:
| None -> html (Pages.register request ())
167
109
168
Removed:
let show t _request id =
169
Removed:
match record_target t id with
170
Removed:
| None -> not_found "That saved workout no longer exists."
171
Removed:
| Some (_, workout) -> html (Pages.workout ~record_id:(Some id) workout)
110
Added:
let establish request (trainee : Trainee.t) =
111
Added:
Dream.set_session_field request session_key
112
Added:
(Trainee.id_to_string trainee.id)
113
Added:
>>= fun () -> redirect_to request Routes.home
172
114
173
Removed:
let log t request id slot =
174
Removed:
match record_target t id with
175
Removed:
| None -> not_found "That saved workout no longer exists."
176
Removed:
| Some (record_id, workout) -> (
177
Removed:
match outstanding workout slot with
178
Removed:
| None -> not_found "That slot is not awaiting a record."
179
Removed:
| Some prescription -> (
180
Removed:
decode_form (Decode.stimulus prescription) request >>= function
181
Removed:
| Error (`Invalid errors) ->
182
Removed:
html ~status:`Bad_Request
183
Removed:
(Pages.workout ~errors ~record_id:(Some id) workout)
184
Removed:
| Error `Bad_request ->
185
Removed:
bad_request "The submitted form is not valid."
186
Removed:
| Ok stimulus -> (
187
Removed:
match save_record t record_id stimulus with
188
Removed:
| Ok () ->
189
Removed:
redirect request
190
Removed:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
191
Removed:
id)
192
Removed:
| Error detail -> bad_request detail)))
115
Added:
let register t request =
116
Added:
read_credentials request >>= function
117
Added:
| Error _ ->
118
Added:
html ~status:`Bad_Request
119
Added:
(Pages.register request ~error:Present.form_invalid ())
120
Added:
| Ok (email, password) -> (
121
Added:
Service.register t.service ~email ~password >>= function
122
Added:
| Ok trainee -> establish request trainee
123
Added:
| Error err ->
124
Added:
html ~status:`Bad_Request
125
Added:
(Pages.register request ~error:(Present.registration err) ()))
193
126
194
Removed:
let routes t =
195
Removed:
[
196
Removed:
Dream_html.get Routes.history (index t);
197
Removed:
Dream_html.get Routes.record (show t);
198
Removed:
Dream_html.post Routes.record_slot (log t);
199
Removed:
]
200
Removed:
end
127
Added:
let login t request =
128
Added:
read_credentials request >>= function
129
Added:
| Error _ ->
130
Added:
html ~status:`Bad_Request
131
Added:
(Pages.login request ~error:Present.form_invalid ())
132
Added:
| Ok (email, password) -> (
133
Added:
Service.authenticate t.service ~email ~password >>= function
134
Added:
| Some trainee -> establish request trainee
135
Added:
| None ->
136
Added:
html ~status:`Unauthorized
137
Added:
(Pages.login request ~error:Present.sign_in_failed ()))
201
138
202
Removed:
module Assets = struct
203
Removed:
let stylesheet =
204
Removed:
match Stylesheet.read "hito.css" with
205
Removed:
| Some stylesheet -> stylesheet
206
Removed:
| None -> failwith "Embedded stylesheet hito.css is missing"
139
Added:
let logout _t request =
140
Added:
guard_csrf request >>= function
141
Added:
| Error _ -> bad_request Present.form_invalid
142
Added:
| Ok () ->
143
Added:
Dream.invalidate_session request >>= fun () ->
144
Added:
redirect_to request Routes.login
207
145
208
Removed:
let routes =
209
Removed:
[
210
Removed:
Dream_html.get Routes.stylesheet (fun _ ->
211
Removed:
Dream.respond
212
Removed:
~headers:[ ("Content-Type", "text/css; charset=utf-8") ]
213
Removed:
stylesheet);
214
Removed:
]
215
Removed:
end
146
Added:
let routes t =
147
Added:
[
148
Added:
Dream_html.get Routes.login (login_page t);
149
Added:
Dream_html.post Routes.login (login t);
150
Added:
Dream_html.get Routes.register (register_page t);
151
Added:
Dream_html.post Routes.register (register t);
152
Added:
Dream_html.post Routes.logout (logout t);
153
Added:
]
154
Added:
end
216
155
217
Removed:
let routes t =
218
Removed:
Overview.routes t @ Current_workout.routes t @ History.routes t
219
Removed:
@ Assets.routes
156
Added:
(* --- helpers over the service --- *)
157
Added:
158
Added:
let record_target t trainee id =
159
Added:
Service.find_record t.service trainee (Repository.workout_id id)
160
Added:
>|= Option.map (fun record ->
161
Added:
(record.Repository.id, record.Repository.workout))
162
Added:
163
Added:
let outstanding workout slot =
164
Added:
List.assoc_opt slot (Evidence.Workout.outstanding workout)
165
Added:
166
Added:
let save_current t trainee stimulus =
167
Added:
Service.log t.service trainee stimulus >|= function
168
Added:
| Ok _ -> Ok ()
169
Added:
| Error e -> Error (Present.log_error e)
170
Added:
171
Added:
let save_record t trainee id stimulus =
172
Added:
Service.add_to_record t.service trainee id stimulus >|= function
173
Added:
| Ok _ -> Ok ()
174
Added:
| Error e -> Error (Present.edit_error e)
175
Added:
176
Added:
module Overview = struct
177
Added:
let page t trainee request =
178
Added:
Service.in_progress t.service trainee.Trainee.id >>= function
179
Added:
| Some workout ->
180
Added:
Lwt.return (Pages.workout request ~trainee ~record_id:None workout)
181
Added:
| None -> (
182
Added:
Service.active_routine t.service trainee.Trainee.id >>= function
183
Added:
| None ->
184
Added:
Lwt.return
185
Added:
(Pages.choose_routine request ~trainee
186
Added:
~routines:(Service.list_routines t.service))
187
Added:
| Some (routine, selected) -> (
188
Added:
Service.next_workout t.service trainee.Trainee.id ~routine
189
Added:
>>= fun next ->
190
Added:
Service.readiness t.service trainee.Trainee.id ~routine
191
Added:
~now:(t.now ())
192
Added:
>|= fun readiness ->
193
Added:
match (next, readiness) with
194
Added:
| Ok next, Ok readiness ->
195
Added:
Pages.home request ~trainee ~routine
196
Added:
~routine_name:(Prescription.Routine.name selected)
197
Added:
~next ~readiness
198
Added:
| Error error, _ | _, Error error ->
199
Added:
Pages.problem ~title:"Routine unavailable"
200
Added:
~detail:(Present.routine error)))
201
Added:
202
Added:
let home t trainee request = page t trainee request >>= html
203
Added:
204
Added:
let routines t trainee request =
205
Added:
html
206
Added:
(Pages.choose_routine request ~trainee
207
Added:
~routines:(Service.list_routines t.service))
208
Added:
209
Added:
let select_routine t trainee request id =
210
Added:
guard_csrf request >>= function
211
Added:
| Error _ -> bad_request Present.form_invalid
212
Added:
| Ok () -> (
213
Added:
Service.select_routine t.service trainee.Trainee.id
214
Added:
(Repository.routine_id id)
215
Added:
>>= function
216
Added:
| Ok () -> redirect_to request Routes.home
217
Added:
| Error _ -> not_found Present.unknown_routine)
218
Added:
219
Added:
let routine t trainee request =
220
Added:
Service.active_routine t.service trainee.Trainee.id >>= function
221
Added:
| Some (_, routine) -> html (Pages.routine ~trainee routine)
222
Added:
| None -> redirect_to request Routes.routines
223
Added:
224
Added:
let routes t =
225
Added:
[
226
Added:
Dream_html.get Routes.home (fun request ->
227
Added:
authenticated t request (fun trainee -> home t trainee request));
228
Added:
Dream_html.get Routes.routines (fun request ->
229
Added:
authenticated t request (fun trainee -> routines t trainee request));
230
Added:
Dream_html.post Routes.select_routine (fun request id ->
231
Added:
authenticated t request (fun trainee ->
232
Added:
select_routine t trainee request id));
233
Added:
Dream_html.get Routes.routine (fun request ->
234
Added:
authenticated t request (fun trainee -> routine t trainee request));
235
Added:
]
236
Added:
end
237
Added:
238
Added:
module Current_workout = struct
239
Added:
let begin_workout t trainee request =
240
Added:
decode_form Decode.override request >>= function
241
Added:
| Error _ -> bad_request Present.form_invalid
242
Added:
| Ok override -> (
243
Added:
Service.active_routine t.service trainee.Trainee.id >>= function
244
Added:
| None -> redirect_to request Routes.routines
245
Added:
| Some (routine, _) -> (
246
Added:
let override = if override then Some () else None in
247
Added:
Service.begin_workout t.service trainee.Trainee.id ~routine
248
Added:
~now:(t.now ()) ?override ()
249
Added:
>>= function
250
Added:
| Ok _ -> redirect_to request Routes.workout
251
Added:
| Error (Service.Not_recovered _) ->
252
Added:
redirect_to request Routes.home
253
Added:
| Error Service.Unknown_routine ->
254
Added:
not_found Present.unknown_routine))
255
Added:
256
Added:
let show t trainee request =
257
Added:
Service.in_progress t.service trainee.Trainee.id >>= function
258
Added:
| Some workout ->
259
Added:
html (Pages.workout request ~trainee ~record_id:None workout)
260
Added:
| None -> redirect_to request Routes.home
261
Added:
262
Added:
let log t trainee request slot =
263
Added:
Service.in_progress t.service trainee.Trainee.id >>= function
264
Added:
| None -> not_found Present.no_workout
265
Added:
| Some workout -> (
266
Added:
match outstanding workout slot with
267
Added:
| None -> not_found Present.slot_not_awaiting
268
Added:
| Some prescription -> (
269
Added:
decode_form (Decode.stimulus prescription) request >>= function
270
Added:
| Error (`Invalid errors) ->
271
Added:
html ~status:`Bad_Request
272
Added:
(Pages.workout request ~trainee ~errors ~record_id:None
273
Added:
workout)
274
Added:
| Error `Bad_request -> bad_request Present.form_invalid
275
Added:
| Ok stimulus -> (
276
Added:
save_current t trainee.Trainee.id stimulus >>= function
277
Added:
| Ok () -> redirect_to request Routes.workout
278
Added:
| Error detail -> bad_request detail)))
279
Added:
280
Added:
let finish t trainee request =
281
Added:
guard_csrf request >>= function
282
Added:
| Error _ -> bad_request Present.form_invalid
283
Added:
| Ok () -> (
284
Added:
Service.finish t.service trainee.Trainee.id ~ended_at:(t.now ())
285
Added:
>>= function
286
Added:
| Some _ -> redirect_to request Routes.history
287
Added:
| None -> not_found Present.no_workout)
288
Added:
289
Added:
let routes t =
290
Added:
[
291
Added:
Dream_html.get Routes.workout (fun request ->
292
Added:
authenticated t request (fun trainee -> show t trainee request));
293
Added:
Dream_html.post Routes.workout (fun request ->
294
Added:
authenticated t request (fun trainee ->
295
Added:
begin_workout t trainee request));
296
Added:
Dream_html.post Routes.workout_slot (fun request slot ->
297
Added:
authenticated t request (fun trainee -> log t trainee request slot));
298
Added:
Dream_html.post Routes.finish_workout (fun request ->
299
Added:
authenticated t request (fun trainee -> finish t trainee request));
300
Added:
]
301
Added:
end
302
Added:
303
Added:
module History = struct
304
Added:
let index t trainee _request =
305
Added:
Service.history t.service trainee.Trainee.id >>= fun records ->
306
Added:
html (Pages.history ~trainee records)
307
Added:
308
Added:
let show t trainee request id =
309
Added:
record_target t trainee.Trainee.id id >>= function
310
Added:
| None -> not_found Present.unknown_record
311
Added:
| Some (_, workout) ->
312
Added:
html (Pages.workout request ~trainee ~record_id:(Some id) workout)
313
Added:
314
Added:
let log t trainee request id slot =
315
Added:
record_target t trainee.Trainee.id id >>= function
316
Added:
| None -> not_found Present.unknown_record
317
Added:
| Some (record_id, workout) -> (
318
Added:
match outstanding workout slot with
319
Added:
| None -> not_found Present.slot_not_awaiting
320
Added:
| Some prescription -> (
321
Added:
decode_form (Decode.stimulus prescription) request >>= function
322
Added:
| Error (`Invalid errors) ->
323
Added:
html ~status:`Bad_Request
324
Added:
(Pages.workout request ~trainee ~errors ~record_id:(Some id)
325
Added:
workout)
326
Added:
| Error `Bad_request -> bad_request Present.form_invalid
327
Added:
| Ok stimulus -> (
328
Added:
save_record t trainee.Trainee.id record_id stimulus
329
Added:
>>= function
330
Added:
| Ok () ->
331
Added:
redirect request
332
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
333
Added:
id)
334
Added:
| Error detail -> bad_request detail)))
335
Added:
336
Added:
let routes t =
337
Added:
[
338
Added:
Dream_html.get Routes.history (fun request ->
339
Added:
authenticated t request (fun trainee -> index t trainee request));
340
Added:
Dream_html.get Routes.record (fun request id ->
341
Added:
authenticated t request (fun trainee -> show t trainee request id));
342
Added:
Dream_html.post Routes.record_slot (fun request id slot ->
343
Added:
authenticated t request (fun trainee ->
344
Added:
log t trainee request id slot));
345
Added:
]
346
Added:
end
347
Added:
348
Added:
module Assets = struct
349
Added:
let stylesheet =
350
Added:
match Stylesheet.read "hito.css" with
351
Added:
| Some stylesheet -> stylesheet
352
Added:
| None -> failwith "Embedded stylesheet hito.css is missing"
353
Added:
354
Added:
let routes =
355
Added:
[
356
Added:
Dream_html.get Routes.stylesheet (fun _ ->
357
Added:
Dream.respond
358
Added:
~headers:[ ("Content-Type", "text/css; charset=utf-8") ]
359
Added:
stylesheet);
360
Added:
]
361
Added:
end
362
Added:
363
Added:
let routes t =
364
Added:
Auth.routes t @ Overview.routes t @ Current_workout.routes t
365
Added:
@ History.routes t @ Assets.routes
366
Added:
end
lib/web/handlers.mli
@@ -1,4 +1,14 @@
1
Removed:
type t
1
Added:
(** The web tier: routing, authentication, sessions, and CSRF. Functorized over
2
Added:
the repository so tests drive it with an in-memory store while production
3
Added:
uses SQLite. *)
2
4
3
Removed:
val create : ?now:(unit -> Recovery.timestamp) -> unit -> t
4
Removed:
val routes : t -> Dream.route list
5
Added:
module Make (R : Hito_app.Repository.S) : sig
6
Added:
type t
7
Added:
8
Added:
val make : repo:R.t -> ?now:(unit -> Recovery.timestamp) -> unit -> t
9
Added:
10
Added:
val routes : t -> Dream.route list
11
Added:
(** The route table. Session and CSRF middleware are applied per handler; wrap
12
Added:
with {!Dream.sql_sessions} or {!Dream.memory_sessions} and a secret at the
13
Added:
top level. *)
14
Added:
end
lib/web/pages.ml
@@ -12,17 +12,38 @@
12
12
let type_ = Dream_html.string_attr "type"
13
13
let step = Dream_html.string_attr "step"
14
14
let required = Dream_html.attr "required"
15
Added:
let href path = Dream_html.path_attr (Dream_html.uri_attr "href") path
16
Added:
let action path = Dream_html.path_attr (Dream_html.uri_attr "action") path
17
Added:
let post_form = Dream_html.string_attr "method" "post"
15
18
16
Removed:
let html_page ?(active = "") ?(workout_in_progress = false) title content =
19
Added:
(* The shell. [trainee] and [request] are present on authenticated pages, which
20
Added:
then show who is signed in and a logout control. Auth pages omit both. *)
21
Added:
let html_page ?trainee ?request ?(active = "") ?(workout_in_progress = false)
22
Added:
title content =
23
Added:
let nav_link path label = tag "a" [ href path ] [ txt "%s" label ] in
24
Added:
let account_area =
25
Added:
match (trainee, request) with
26
Added:
| Some (trainee : Trainee.t), Some request ->
27
Added:
[
28
Added:
tag "div"
29
Added:
[ class_ "account" ]
30
Added:
[
31
Added:
tag "span"
32
Added:
[ class_ "account-email" ]
33
Added:
[ txt "%s" (Trainee.email_to_string trainee.email) ];
34
Added:
tag "form"
35
Added:
[ action Routes.logout; post_form; class_ "logout" ]
36
Added:
[
37
Added:
Dream_html.csrf_tag request;
38
Added:
void "input" [ type_ "submit"; value "Sign out" ];
39
Added:
];
40
Added:
];
41
Added:
]
42
Added:
| _ -> []
43
Added:
in
17
44
let mobile_middle =
18
Removed:
if workout_in_progress then
19
Removed:
tag "a"
20
Removed:
[ Dream_html.path_attr (Dream_html.uri_attr "href") Routes.workout ]
21
Removed:
[ txt "Current Workout" ]
22
Removed:
else
23
Removed:
tag "a"
24
Removed:
[ Dream_html.path_attr (Dream_html.uri_attr "href") Routes.routine ]
25
Removed:
[ txt "Routine" ]
45
Added:
if workout_in_progress then nav_link Routes.workout "Current Workout"
46
Added:
else nav_link Routes.routine "Routine"
26
47
in
27
48
tag "html" []
28
49
[
@@ -36,13 +57,7 @@
36
57
Dream_html.string_attr "content"
37
58
"width=device-width,initial-scale=1";
38
59
];
39
Removed:
void "link"
40
Removed:
[
41
Removed:
rel "stylesheet";
42
Removed:
Dream_html.path_attr
43
Removed:
(Dream_html.uri_attr "href")
44
Removed:
Routes.stylesheet;
45
Removed:
];
60
Added:
void "link" [ rel "stylesheet"; href Routes.stylesheet ];
46
61
];
47
62
tag "body"
48
63
[ Dream_html.string_attr "class" "hito-app page-%s" active ]
@@ -52,56 +67,29 @@
52
67
[
53
68
tag "header"
54
69
[ class_ "masthead" ]
55
Removed:
[
56
Removed:
tag "a"
57
Removed:
[
58
Removed:
class_ "brand";
59
Removed:
Dream_html.path_attr
60
Removed:
(Dream_html.uri_attr "href")
61
Removed:
Routes.home;
62
Removed:
]
63
Removed:
[
64
Removed:
tag "span" [ class_ "brand-mark" ] [ txt "HD" ];
65
Removed:
tag "span"
66
Removed:
[ class_ "brand-copy" ]
67
Removed:
[
68
Removed:
tag "strong" [] [ txt "hito" ];
69
Removed:
tag "small" [] [ txt "High Intensity Tracker Online" ];
70
Removed:
];
71
Removed:
];
72
Removed:
tag "nav"
73
Removed:
[ class_ "primary-nav" ]
74
Removed:
[
75
Removed:
tag "a"
76
Removed:
[
77
Removed:
Dream_html.path_attr
78
Removed:
(Dream_html.uri_attr "href")
79
Removed:
Routes.home;
80
Removed:
]
81
Removed:
[ txt "Overview" ];
82
Removed:
tag "a"
83
Removed:
[
84
Removed:
Dream_html.path_attr
85
Removed:
(Dream_html.uri_attr "href")
86
Removed:
Routes.routine;
87
Removed:
]
88
Removed:
[ txt "Routine" ];
89
Removed:
tag "a"
90
Removed:
[
91
Removed:
Dream_html.path_attr
92
Removed:
(Dream_html.uri_attr "href")
93
Removed:
Routes.workout;
94
Removed:
]
95
Removed:
[ txt "Current workout" ];
96
Removed:
tag "a"
97
Removed:
[
98
Removed:
Dream_html.path_attr
99
Removed:
(Dream_html.uri_attr "href")
100
Removed:
Routes.history;
101
Removed:
]
102
Removed:
[ txt "History" ];
103
Removed:
];
104
Removed:
];
70
Added:
([
71
Added:
tag "a"
72
Added:
[ class_ "brand"; href Routes.home ]
73
Added:
[
74
Added:
tag "span" [ class_ "brand-mark" ] [ txt "HD" ];
75
Added:
tag "span"
76
Added:
[ class_ "brand-copy" ]
77
Added:
[
78
Added:
tag "strong" [] [ txt "hito" ];
79
Added:
tag "small" []
80
Added:
[ txt "High Intensity Tracker Online" ];
81
Added:
];
82
Added:
];
83
Added:
tag "nav"
84
Added:
[ class_ "primary-nav" ]
85
Added:
[
86
Added:
nav_link Routes.home "Overview";
87
Added:
nav_link Routes.routine "Routine";
88
Added:
nav_link Routes.workout "Current workout";
89
Added:
nav_link Routes.history "History";
90
Added:
];
91
Added:
]
92
Added:
@ account_area);
105
93
tag "main" [] [ tag "div" [ class_ "page-surface" ] content ];
106
94
];
107
95
tag "nav"
@@ -110,19 +98,9 @@
110
98
Dream_html.string_attr "aria-label" "Mobile navigation";
111
99
]
112
100
[
113
Removed:
tag "a"
114
Removed:
[
115
Removed:
Dream_html.path_attr (Dream_html.uri_attr "href") Routes.home;
116
Removed:
]
117
Removed:
[ txt "Home" ];
101
Added:
nav_link Routes.home "Home";
118
102
mobile_middle;
119
Removed:
tag "a"
120
Removed:
[
121
Removed:
Dream_html.path_attr
122
Removed:
(Dream_html.uri_attr "href")
123
Removed:
Routes.history;
124
Removed:
]
125
Removed:
[ txt "Log Book" ];
103
Added:
nav_link Routes.history "Log Book";
126
104
];
127
105
];
128
106
]
@@ -135,6 +113,79 @@
135
113
tag "p" [ class_ "warn" ] [ txt "%s" detail ];
136
114
]
137
115
116
Added:
(* --- authentication --- *)
117
Added:
118
Added:
let auth_error = function
119
Added:
| None -> []
120
Added:
| Some message -> [ tag "p" [ class_ "warn" ] [ txt "%s" message ] ]
121
Added:
122
Added:
let credentials_form request ~submit ~action_path =
123
Added:
tag "form"
124
Added:
[ action action_path; post_form ]
125
Added:
[
126
Added:
Dream_html.csrf_tag request;
127
Added:
tag "div"
128
Added:
[ class_ "field" ]
129
Added:
[
130
Added:
tag "label" [ Dream_html.string_attr "for" "email" ] [ txt "Email" ];
131
Added:
void "input"
132
Added:
[
133
Added:
type_ "email";
134
Added:
name "email";
135
Added:
Dream_html.string_attr "id" "email";
136
Added:
Dream_html.string_attr "autocomplete" "username";
137
Added:
required;
138
Added:
];
139
Added:
];
140
Added:
tag "div"
141
Added:
[ class_ "field" ]
142
Added:
[
143
Added:
tag "label"
144
Added:
[ Dream_html.string_attr "for" "password" ]
145
Added:
[ txt "Password" ];
146
Added:
void "input"
147
Added:
[
148
Added:
type_ "password";
149
Added:
name "password";
150
Added:
Dream_html.string_attr "id" "password";
151
Added:
Dream_html.string_attr "autocomplete" "current-password";
152
Added:
required;
153
Added:
];
154
Added:
];
155
Added:
void "input" [ type_ "submit"; value submit ];
156
Added:
]
157
Added:
158
Added:
let login request ?error () =
159
Added:
html_page ~active:"auth" "Sign in"
160
Added:
([
161
Added:
tag "h2" [] [ txt "Sign in" ];
162
Added:
credentials_form request ~submit:"Sign in" ~action_path:Routes.login;
163
Added:
tag "p" []
164
Added:
[
165
Added:
txt "No account yet? ";
166
Added:
tag "a" [ href Routes.register ] [ txt "Register" ];
167
Added:
];
168
Added:
]
169
Added:
@ auth_error error)
170
Added:
171
Added:
let register request ?error () =
172
Added:
html_page ~active:"auth" "Register"
173
Added:
([
174
Added:
tag "h2" [] [ txt "Create an account" ];
175
Added:
tag "p"
176
Added:
[ class_ "doctrine-note" ]
177
Added:
[ txt "One trainee, one logbook. Recovery is tracked per account." ];
178
Added:
credentials_form request ~submit:"Register" ~action_path:Routes.register;
179
Added:
tag "p" []
180
Added:
[
181
Added:
txt "Already registered? ";
182
Added:
tag "a" [ href Routes.login ] [ txt "Sign in" ];
183
Added:
];
184
Added:
]
185
Added:
@ auth_error error)
186
Added:
187
Added:
(* --- application pages --- *)
188
Added:
138
189
let id_string (id : Repository.routine_id) = (id :> string)
139
190
140
191
let describe_prescription prescription =
@@ -160,8 +211,8 @@
160
211
tag "option" [ value "static" ] [ txt "then a static hold" ];
161
212
]
162
213
163
Removed:
let choose_routine ~routines =
164
Removed:
html_page ~active:"home" "Choose a routine"
214
Added:
let choose_routine request ~trainee ~routines =
215
Added:
html_page ~trainee ~request ~active:"home" "Choose a routine"
165
216
[
166
217
tag "h2" [] [ txt "Routines" ];
167
218
tag "div" []
@@ -169,12 +220,10 @@
169
220
(fun (routine_id, routine) ->
170
221
tag "form"
171
222
[
172
Removed:
Dream_html.path_attr
173
Removed:
(Dream_html.uri_attr "action")
174
Removed:
Routes.select_routine (id_string routine_id);
175
Removed:
Dream_html.string_attr "method" "post";
223
Added:
action Routes.select_routine (id_string routine_id); post_form;
176
224
]
177
225
[
226
Added:
Dream_html.csrf_tag request;
178
227
tag "fieldset" []
179
228
[
180
229
tag "legend" []
@@ -190,13 +239,11 @@
190
239
routines);
191
240
]
192
241
193
Removed:
let begin_form ~routine ~override label =
242
Added:
let begin_form request ~routine ~override label =
194
243
tag "form"
244
Added:
[ action Routes.workout; post_form ]
195
245
[
196
Removed:
Dream_html.path_attr (Dream_html.uri_attr "action") Routes.workout;
197
Removed:
Dream_html.string_attr "method" "post";
198
Removed:
]
199
Removed:
[
246
Added:
Dream_html.csrf_tag request;
200
247
void "input"
201
248
[
202
249
type_ "hidden";
@@ -212,12 +259,13 @@
212
259
void "input" [ type_ "submit"; value label ];
213
260
]
214
261
215
Removed:
let home ~routine ~routine_name ~next ~readiness =
262
Added:
let home request ~trainee ~routine ~routine_name ~next ~readiness =
216
263
let status, gate =
217
264
match readiness with
218
265
| Recovery.Ready ->
219
266
( "Recovery is complete.",
220
Removed:
[ begin_form ~routine ~override:false "Begin next workout" ] )
267
Added:
[ begin_form request ~routine ~override:false "Begin next workout" ]
268
Added:
)
221
269
| Recovery.Recovering { rested; recommended } ->
222
270
( Format.asprintf "Recovery: %a of %a." Recovery.pp_duration rested
223
271
Recovery.pp_duration recommended,
@@ -236,11 +284,12 @@
236
284
"The stimulus is immediate. Recovery is the work that \
237
285
follows it.";
238
286
];
239
Removed:
begin_form ~routine ~override:true "Begin under override";
287
Added:
begin_form request ~routine ~override:true
288
Added:
"Begin under override";
240
289
];
241
290
] )
242
291
in
243
Removed:
html_page ~active:"home" "Home"
292
Added:
html_page ~trainee ~request ~active:"home" "Home"
244
293
([
245
294
tag "h2" [] [ txt "%s" routine_name ];
246
295
tag "p"
@@ -250,8 +299,8 @@
250
299
]
251
300
@ gate)
252
301
253
Removed:
let routine routine =
254
Removed:
html_page ~active:"routine" "Routine"
302
Added:
let routine ~trainee routine =
303
Added:
html_page ~trainee ~active:"routine" "Routine"
255
304
[
256
305
tag "h2" [] [ txt "%s" (Prescription.Routine.name routine) ];
257
306
tag "ul" []
@@ -297,7 +346,7 @@
297
346
];
298
347
]
299
348
300
Removed:
let form_for_stimulus ~action_path ~slot ~prescription ~errors =
349
Added:
let form_for_stimulus request ~action_path ~slot ~prescription ~errors =
301
350
let field_id field = Printf.sprintf "slot-%d-%s" slot field in
302
351
let fields =
303
352
match Prescription.Stimulus.delivery prescription with
@@ -316,9 +365,9 @@
316
365
input_row ~input_id:(field_id "comp_reps") "comp_reps" "Reps";
317
366
]
318
367
in
319
Removed:
tag "form"
320
Removed:
[ action_path; Dream_html.string_attr "method" "post" ]
368
Added:
tag "form" [ action_path; post_form ]
321
369
[
370
Added:
Dream_html.csrf_tag request;
322
371
tag "fieldset" []
323
372
([ tag "legend" [] [ txt "%s" (describe_prescription prescription) ] ]
324
373
@ fields
@@ -362,20 +411,14 @@
362
411
(Format.asprintf "%a" Evidence.Stimulus.pp_extension)
363
412
extensions)
364
413
365
Removed:
let workout ?(errors = []) ~record_id workout =
414
Added:
let workout request ~trainee ?(errors = []) ~record_id workout =
366
415
let prescription = Evidence.Workout.prescription workout in
367
416
let performed = Evidence.Workout.stimuli workout in
368
417
let outstanding = Evidence.Workout.outstanding workout in
369
418
let form_action slot =
370
419
match record_id with
371
Removed:
| None ->
372
Removed:
Dream_html.path_attr
373
Removed:
(Dream_html.uri_attr "action")
374
Removed:
Routes.workout_slot slot
375
Removed:
| Some record_id ->
376
Removed:
Dream_html.path_attr
377
Removed:
(Dream_html.uri_attr "action")
378
Removed:
Routes.record_slot record_id slot
420
Added:
| None -> action Routes.workout_slot slot
421
Added:
| Some record_id -> action Routes.record_slot record_id slot
379
422
in
380
423
let override_note =
381
424
match Recovery.basis (Evidence.Workout.clearance workout) with
@@ -422,7 +465,7 @@
422
465
]
423
466
:: List.map
424
467
(fun (slot, prescription) ->
425
Removed:
form_for_stimulus ~action_path:(form_action slot) ~slot
468
Added:
form_for_stimulus request ~action_path:(form_action slot) ~slot
426
469
~prescription ~errors)
427
470
outstanding
428
471
in
@@ -432,16 +475,15 @@
432
475
| None ->
433
476
[
434
477
tag "form"
478
Added:
[ action Routes.finish_workout; post_form ]
435
479
[
436
Removed:
Dream_html.path_attr
437
Removed:
(Dream_html.uri_attr "action")
438
Removed:
Routes.finish_workout;
439
Removed:
Dream_html.string_attr "method" "post";
440
Removed:
]
441
Removed:
[ void "input" [ type_ "submit"; value "Finish workout" ] ];
480
Added:
Dream_html.csrf_tag request;
481
Added:
void "input" [ type_ "submit"; value "Finish workout" ];
482
Added:
];
442
483
]
443
484
in
444
Removed:
html_page ~active:"workout" ~workout_in_progress:(Option.is_none record_id)
485
Added:
html_page ~trainee ~request ~active:"workout"
486
Added:
~workout_in_progress:(Option.is_none record_id)
445
487
(Prescription.Workout.name prescription)
446
488
(override_note
447
489
@ [
@@ -454,8 +496,8 @@
454
496
]
455
497
@ recorded_section @ outstanding_section @ finish_section)
456
498
457
Removed:
let history records =
458
Removed:
html_page ~active:"history" "History"
499
Added:
let history ~trainee records =
500
Added:
html_page ~trainee ~active:"history" "History"
459
501
[
460
502
tag "h2" [] [ txt "History" ];
461
503
(if records = [] then tag "p" [] [ txt "Nothing logged yet." ]
@@ -472,12 +514,7 @@
472
514
tag "li" []
473
515
[
474
516
tag "a"
475
Removed:
[
476
Removed:
Dream_html.path_attr
477
Removed:
(Dream_html.uri_attr "href")
478
Removed:
Routes.record
479
Removed:
(record.Repository.id :> string);
480
Removed:
]
517
Added:
[ href Routes.record (record.Repository.id :> string) ]
481
518
[
482
519
txt "%s — %d stimuli"
483
520
(Prescription.Workout.name
lib/web/pages.mli
@@ -2,23 +2,33 @@
2
2
3
3
type page = Dream_html.node
4
4
5
Added:
val login : Dream.request -> ?error:string -> unit -> page
6
Added:
val register : Dream.request -> ?error:string -> unit -> page
7
Added:
5
8
val choose_routine :
6
Removed:
routines:(Repository.routine_id * Prescription.Routine.t) list -> page
9
Added:
Dream.request ->
10
Added:
trainee:Trainee.t ->
11
Added:
routines:(Repository.routine_id * Prescription.Routine.t) list ->
12
Added:
page
7
13
8
14
val home :
15
Added:
Dream.request ->
16
Added:
trainee:Trainee.t ->
9
17
routine:Repository.routine_id ->
10
18
routine_name:string ->
11
19
next:Prescription.Workout.t ->
12
20
readiness:Recovery.readiness ->
13
21
page
14
22
15
Removed:
val routine : Prescription.Routine.t -> page
23
Added:
val routine : trainee:Trainee.t -> Prescription.Routine.t -> page
16
24
17
25
val workout :
26
Added:
Dream.request ->
27
Added:
trainee:Trainee.t ->
18
28
?errors:(string * string) list ->
19
29
record_id:string option ->
20
30
Evidence.Workout.t ->
21
31
page
22
32
23
Removed:
val history : Repository.record list -> page
33
Added:
val history : trainee:Trainee.t -> Repository.record list -> page
24
34
val problem : title:string -> detail:string -> page
lib/web/routes.ml
@@ -2,6 +2,9 @@
2
2
Writing an interface for them would add noise without adding safety. *)
3
3
4
4
let%path home = "/"
5
Added:
let%path register = "/register"
6
Added:
let%path login = "/login"
7
Added:
let%path logout = "/logout"
5
8
let%path routines = "/routines"
6
9
let%path select_routine = "/routines/%s/select"
7
10
let%path routine = "/routine"
test/dune
@@ -8,6 +8,8 @@
8
8
test_evidence
9
9
test_progression
10
10
test_service
11
Added:
test_codec
12
Added:
test_sqlite_repo
11
13
test_decode
12
14
test_web)
13
Removed:
(libraries hito.core hito.app hito.web alcotest dream dream-html))
15
Added:
(libraries hito.core hito.app hito.web alcotest dream dream-html lwt caqti))
test/test_codec.ml
@@ -0,0 +1,137 @@
1
Added:
(** Tests for {!Hito_app.Codec} — the serialization boundary for stored facts. A
2
Added:
stored workout must rebuild identically, since the logbook is the only
3
Added:
source of evidence. *)
4
Added:
5
Added:
open Hito_app
6
Added:
module Stimulus = Evidence.Stimulus
7
Added:
module Workout = Evidence.Workout
8
Added:
9
Added:
let get id =
10
Added:
match Exercise.find_id id with
11
Added:
| Some e -> e
12
Added:
| None -> Alcotest.failf "catalog is missing %S" id
13
Added:
14
Added:
let at s = Recovery.timestamp_of_unix_seconds s
15
Added:
let find_routine = Catalog.find_by_name
16
Added:
17
Added:
let move ?(outcome = Stimulus.Positive_failure) id load reps =
18
Added:
Stimulus.Effort.make ~exercise:(get id) ~load ~reps ~outcome
19
Added:
20
Added:
let single id load reps = Stimulus.make (Stimulus.Single (move id load reps))
21
Added:
let pair ~first ~second = Stimulus.make (Stimulus.Pair { first; second })
22
Added:
23
Added:
(* A performed Day 1, including an extension, to exercise every branch. *)
24
Added:
let sample_workout ?(finished = true) () =
25
Added:
let clearance = Option.get (Recovery.clear Recovery.Ready) in
26
Added:
let day_one =
27
Added:
List.hd (Prescription.Routine.workouts Prescription.Routine.ideal)
28
Added:
in
29
Added:
let w = Workout.start day_one ~clearance ~started_at:(at 100) in
30
Added:
let w =
31
Added:
Workout.add_stimulus w
32
Added:
(pair
33
Added:
~first:(move "dumbbell-flyes" 20. 9)
34
Added:
~second:(move "incline-press" 60. 7))
35
Added:
in
36
Added:
let w =
37
Added:
Workout.add_stimulus w
38
Added:
( single "laterals" 12. 8 |> fun _ ->
39
Added:
Stimulus.make
40
Added:
(Stimulus.Single
41
Added:
(move "laterals" 12. 8
42
Added:
~outcome:
43
Added:
(Stimulus.Beyond_failure
44
Added:
(Stimulus.Forced_reps, [ Stimulus.Negatives ])))) )
45
Added:
in
46
Added:
if finished then Workout.finish w ~ended_at:(at 3700) else w
47
Added:
48
Added:
let describe w =
49
Added:
( Prescription.Workout.name (Workout.prescription w),
50
Added:
Recovery.timestamp_to_unix_seconds (Workout.started_at w),
51
Added:
Option.map Recovery.timestamp_to_unix_seconds (Workout.ended_at w),
52
Added:
List.length (Workout.stimuli w),
53
Added:
Workout.is_finished w )
54
Added:
55
Added:
let roundtrip w =
56
Added:
let encoded = Codec.encode_workout ~routine_name:"Ideal Routine" w in
57
Added:
match Codec.decode_workout ~find_routine encoded with
58
Added:
| Ok decoded -> decoded
59
Added:
| Error e -> Alcotest.failf "decode failed: %a" Codec.pp_error e
60
Added:
61
Added:
let codec_tests =
62
Added:
[
63
Added:
( "a finished workout round-trips faithfully",
64
Added:
`Quick,
65
Added:
fun () ->
66
Added:
let w = sample_workout () in
67
Added:
let d = roundtrip w in
68
Added:
Alcotest.(check (list string))
69
Added:
"same rendered stimuli"
70
Added:
(List.map (Format.asprintf "%a" Stimulus.pp) (Workout.stimuli w))
71
Added:
(List.map (Format.asprintf "%a" Stimulus.pp) (Workout.stimuli d));
72
Added:
let name, started, ended, count, finished = describe w in
73
Added:
let name', started', ended', count', finished' = describe d in
74
Added:
Alcotest.(check string) "name" name name';
75
Added:
Alcotest.(check int) "started" started started';
76
Added:
Alcotest.(check (option int)) "ended" ended ended';
77
Added:
Alcotest.(check int) "count" count count';
78
Added:
Alcotest.(check bool) "finished" finished finished' );
79
Added:
( "an in-progress workout has no end after round-trip",
80
Added:
`Quick,
81
Added:
fun () ->
82
Added:
let w = sample_workout ~finished:false () in
83
Added:
let d = roundtrip w in
84
Added:
Alcotest.(check bool) "still open" false (Workout.is_finished d) );
85
Added:
( "an overridden clearance round-trips as an override",
86
Added:
`Quick,
87
Added:
fun () ->
88
Added:
let readiness =
89
Added:
Recovery.Recovering
90
Added:
{ rested = Recovery.hours 10; recommended = Recovery.hours 48 }
91
Added:
in
92
Added:
let clearance = Recovery.override readiness in
93
Added:
let day_one =
94
Added:
List.hd (Prescription.Routine.workouts Prescription.Routine.ideal)
95
Added:
in
96
Added:
let w = Workout.start day_one ~clearance ~started_at:(at 100) in
97
Added:
let d = roundtrip w in
98
Added:
match Recovery.basis (Workout.clearance d) with
99
Added:
| Recovery.Overridden { rested; recommended } ->
100
Added:
Alcotest.(check int)
101
Added:
"rested seconds"
102
Added:
(Recovery.duration_to_seconds (Recovery.hours 10))
103
Added:
(Recovery.duration_to_seconds rested);
104
Added:
Alcotest.(check int)
105
Added:
"recommended seconds"
106
Added:
(Recovery.duration_to_seconds (Recovery.hours 48))
107
Added:
(Recovery.duration_to_seconds recommended)
108
Added:
| Recovery.Recovered -> Alcotest.fail "expected Overridden" );
109
Added:
( "an unknown routine is reported, not raised",
110
Added:
`Quick,
111
Added:
fun () ->
112
Added:
let w = sample_workout () in
113
Added:
let encoded = Codec.encode_workout ~routine_name:"Nonexistent" w in
114
Added:
match Codec.decode_workout ~find_routine encoded with
115
Added:
| Error (Codec.Unknown_routine "Nonexistent") -> ()
116
Added:
| _ -> Alcotest.fail "expected Unknown_routine" );
117
Added:
( "a malformed line is reported as malformed",
118
Added:
`Quick,
119
Added:
fun () ->
120
Added:
let encoded =
121
Added:
"routine\tIdeal Routine\nprescription\tDay 1\ngibberish\tvalue\n"
122
Added:
in
123
Added:
match Codec.decode_workout ~find_routine encoded with
124
Added:
| Error (Codec.Malformed _) -> ()
125
Added:
| _ -> Alcotest.fail "expected Malformed" );
126
Added:
( "missing header fields are reported, not replayed",
127
Added:
`Quick,
128
Added:
fun () ->
129
Added:
(* A well-formed line, but no started/clearance: parse must refuse
130
Added:
before replay rather than build a partial workout. *)
131
Added:
let encoded = "routine\tIdeal Routine\nprescription\tDay 1\n" in
132
Added:
match Codec.decode_workout ~find_routine encoded with
133
Added:
| Error (Codec.Malformed _) -> ()
134
Added:
| _ -> Alcotest.fail "expected Malformed for missing fields" );
135
Added:
]
136
Added:
137
Added:
let suite = [ ("codec", codec_tests) ]
test/test_hito.ml
@@ -2,10 +2,12 @@
2
2
3
3
Suites are ordered as the modules layer: vocabulary, then what is
4
4
prescribed, then what was performed, then what it means, then the
5
Removed:
application service that orchestrates them. *)
5
Added:
application service that orchestrates them, then serialization, durable
6
Added:
storage, and the web tier. *)
6
7
7
8
let () =
8
9
Alcotest.run "hito"
9
10
(Test_exercise.suite @ Test_recovery.suite @ Test_prescription.suite
10
11
@ Test_evidence.suite @ Test_progression.suite @ Test_service.suite
11
Removed:
@ Test_decode.suite @ Test_web.suite)
12
Added:
@ Test_codec.suite @ Test_sqlite_repo.suite @ Test_decode.suite
13
Added:
@ Test_web.suite)
test/test_service.ml
@@ -1,10 +1,12 @@
1
Removed:
(** Tests for {!Hito_app.Service} — the whole HD flow with no web tier. *)
1
Added:
(** Tests for {!Hito_app.Service} — the whole HD flow with no web tier, now
2
Added:
scoped to a trainee and driven over Lwt against the in-memory repository. *)
2
3
3
4
open Hito_app
4
5
module S = Service.Make (Memory_repo)
5
6
module Stimulus = Evidence.Stimulus
6
7
module Workout = Evidence.Workout
7
8
9
Added:
let run = Lwt_main.run
8
10
let ok = function Ok v -> v | Error _ -> Alcotest.fail "expected Ok"
9
11
10
12
let get id =
@@ -17,8 +19,15 @@
17
19
let at s = Recovery.timestamp_of_unix_seconds s
18
20
let day n = at (n * 86_400)
19
21
let ideal = Repository.routine_id "ideal"
20
Removed:
let service () = S.make ~repo:(Memory_repo.create ())
21
22
23
Added:
(* A fresh service and a registered trainee to own everything. *)
24
Added:
let fixture () =
25
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
26
Added:
let trainee =
27
Added:
ok (run (S.register s ~email:"lifter@example.com" ~password:"heavyduty1"))
28
Added:
in
29
Added:
(s, trainee.Trainee.id)
30
Added:
22
31
let move id load_kg rep_count =
23
32
Stimulus.Effort.make ~exercise:(get id) ~load:(load load_kg)
24
33
~reps:(reps rep_count) ~outcome:Stimulus.Positive_failure
@@ -37,12 +46,78 @@
37
46
pair ~first:(move "lying-french-press" 30. 8) ~second:(move "dips" 0. 6);
38
47
]
39
48
49
Added:
let account_tests =
50
Added:
[
51
Added:
( "registration then authentication with the same password",
52
Added:
`Quick,
53
Added:
fun () ->
54
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
55
Added:
let trainee =
56
Added:
ok (run (S.register s ~email:"a@b.com" ~password:"heavyduty1"))
57
Added:
in
58
Added:
match
59
Added:
run (S.authenticate s ~email:"a@b.com" ~password:"heavyduty1")
60
Added:
with
61
Added:
| Some found ->
62
Added:
Alcotest.(check string)
63
Added:
"same id"
64
Added:
(Trainee.id_to_string trainee.Trainee.id)
65
Added:
(Trainee.id_to_string found.Trainee.id)
66
Added:
| None -> Alcotest.fail "expected authentication to succeed" );
67
Added:
( "the wrong password does not authenticate",
68
Added:
`Quick,
69
Added:
fun () ->
70
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
71
Added:
let _ =
72
Added:
ok (run (S.register s ~email:"a@b.com" ~password:"heavyduty1"))
73
Added:
in
74
Added:
Alcotest.(check bool)
75
Added:
"rejected" true
76
Added:
(Option.is_none
77
Added:
(run (S.authenticate s ~email:"a@b.com" ~password:"wrong"))) );
78
Added:
( "a duplicate email is refused",
79
Added:
`Quick,
80
Added:
fun () ->
81
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
82
Added:
let _ =
83
Added:
ok (run (S.register s ~email:"a@b.com" ~password:"heavyduty1"))
84
Added:
in
85
Added:
match run (S.register s ~email:"A@B.com" ~password:"another11") with
86
Added:
| Error `Email_taken -> ()
87
Added:
| _ -> Alcotest.fail "expected Email_taken" );
88
Added:
( "a short password is refused",
89
Added:
`Quick,
90
Added:
fun () ->
91
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
92
Added:
match run (S.register s ~email:"a@b.com" ~password:"short") with
93
Added:
| Error (`Password Trainee.Too_short) -> ()
94
Added:
| _ -> Alcotest.fail "expected Too_short" );
95
Added:
( "two trainees keep separate logs",
96
Added:
`Quick,
97
Added:
fun () ->
98
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
99
Added:
let a =
100
Added:
(ok (run (S.register s ~email:"a@b.com" ~password:"heavyduty1")))
101
Added:
.Trainee.id
102
Added:
in
103
Added:
let b =
104
Added:
(ok (run (S.register s ~email:"c@d.com" ~password:"heavyduty1")))
105
Added:
.Trainee.id
106
Added:
in
107
Added:
let _ = ok (run (S.begin_workout s a ~routine:ideal ~now:(day 1) ())) in
108
Added:
let _ = run (S.finish s a ~ended_at:(day 1)) in
109
Added:
Alcotest.(check int) "a has one" 1 (List.length (run (S.history s a)));
110
Added:
Alcotest.(check int) "b has none" 0 (List.length (run (S.history s b)))
111
Added:
);
112
Added:
]
113
Added:
40
114
let routine_tests =
41
115
[
42
116
( "the seeded repository offers HD1's Ideal Routine",
43
117
`Quick,
44
118
fun () ->
45
Removed:
match S.list_routines (service ()) with
119
Added:
let s, _ = fixture () in
120
Added:
match S.list_routines s with
46
121
| [ (_, r) ] ->
47
122
Alcotest.(check string)
48
123
"name" "Ideal Routine"
@@ -52,15 +127,17 @@
52
127
( "an unknown routine is refused",
53
128
`Quick,
54
129
fun () ->
130
Added:
let s, t = fixture () in
55
131
match
56
Removed:
S.next_workout (service ()) ~routine:(Repository.routine_id "nope")
132
Added:
run (S.next_workout s t ~routine:(Repository.routine_id "nope"))
57
133
with
58
134
| Error S.Unknown_routine -> ()
59
135
| _ -> Alcotest.fail "expected Unknown_routine" );
60
136
( "with nothing logged the cycle starts at Day 1",
61
137
`Quick,
62
138
fun () ->
63
Removed:
let w = ok (S.next_workout (service ()) ~routine:ideal) in
139
Added:
let s, t = fixture () in
140
Added:
let w = ok (run (S.next_workout s t ~routine:ideal)) in
64
141
Alcotest.(check string) "Day 1" "Day 1" (Prescription.Workout.name w) );
65
142
]
66
143
@@ -69,20 +146,22 @@
69
146
( "a first workout needs no recovery: nothing has been done yet",
70
147
`Quick,
71
148
fun () ->
72
Removed:
let s = service () in
149
Added:
let s, t = fixture () in
73
150
Alcotest.(check bool)
74
151
"ready" true
75
Removed:
(Recovery.is_ready (ok (S.readiness s ~routine:ideal ~now:(day 1))));
152
Added:
(Recovery.is_ready
153
Added:
(ok (run (S.readiness s t ~routine:ideal ~now:(day 1)))));
76
154
Alcotest.(check bool)
77
155
"starts" true
78
Removed:
(Result.is_ok (S.begin_workout s ~routine:ideal ~now:(day 1) ())) );
156
Added:
(Result.is_ok
157
Added:
(run (S.begin_workout s t ~routine:ideal ~now:(day 1) ()))) );
79
158
( "training too soon after a workout is refused",
80
159
`Quick,
81
160
fun () ->
82
Removed:
let s = service () in
83
Removed:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
84
Removed:
let _ = S.finish s ~ended_at:(day 1) in
85
Removed:
match S.begin_workout s ~routine:ideal ~now:(day 2) () with
161
Added:
let s, t = fixture () in
162
Added:
let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in
163
Added:
let _ = run (S.finish s t ~ended_at:(day 1)) in
164
Added:
match run (S.begin_workout s t ~routine:ideal ~now:(day 2) ()) with
86
165
| Error (S.Not_recovered readiness) ->
87
166
Alcotest.(check bool)
88
167
"and says so" false
@@ -91,21 +170,23 @@
91
170
( "once rested, the next workout starts and the cycle has advanced",
92
171
`Quick,
93
172
fun () ->
94
Removed:
let s = service () in
95
Removed:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
96
Removed:
let _ = S.finish s ~ended_at:(day 1) in
97
Removed:
let w = ok (S.begin_workout s ~routine:ideal ~now:(day 3) ()) in
173
Added:
let s, t = fixture () in
174
Added:
let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in
175
Added:
let _ = run (S.finish s t ~ended_at:(day 1)) in
176
Added:
let w = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 3) ())) in
98
177
Alcotest.(check string)
99
178
"Day 2" "Day 2"
100
179
(Prescription.Workout.name (Workout.prescription w)) );
101
180
( "an override is accepted and recorded",
102
181
`Quick,
103
182
fun () ->
104
Removed:
let s = service () in
105
Removed:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
106
Removed:
let _ = S.finish s ~ended_at:(day 1) in
183
Added:
let s, t = fixture () in
184
Added:
let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in
185
Added:
let _ = run (S.finish s t ~ended_at:(day 1)) in
107
186
let w =
108
Removed:
ok (S.begin_workout s ~routine:ideal ~now:(day 2) ~override:() ())
187
Added:
ok
188
Added:
(run
189
Added:
(S.begin_workout s t ~routine:ideal ~now:(day 2) ~override:() ()))
109
190
in
110
191
match Recovery.basis (Workout.clearance w) with
111
192
| Recovery.Overridden _ -> ()
@@ -113,9 +194,11 @@
113
194
( "an override while genuinely rested is not recorded as one",
114
195
`Quick,
115
196
fun () ->
116
Removed:
let s = service () in
197
Added:
let s, t = fixture () in
117
198
let w =
118
Removed:
ok (S.begin_workout s ~routine:ideal ~now:(day 1) ~override:() ())
199
Added:
ok
200
Added:
(run
201
Added:
(S.begin_workout s t ~routine:ideal ~now:(day 1) ~override:() ()))
119
202
in
120
203
match Recovery.basis (Workout.clearance w) with
121
204
| Recovery.Recovered -> ()
@@ -128,43 +211,45 @@
128
211
( "logging without a workout in progress is refused",
129
212
`Quick,
130
213
fun () ->
131
Removed:
match S.log (service ()) (single "laterals" 12. 8) with
214
Added:
let s, t = fixture () in
215
Added:
match run (S.log s t (single "laterals" 12. 8)) with
132
216
| Error S.No_workout_in_progress -> ()
133
217
| _ -> Alcotest.fail "expected No_workout_in_progress" );
134
218
( "a stimulus the prescription does not call for is refused",
135
219
`Quick,
136
220
fun () ->
137
Removed:
let s = service () in
138
Removed:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
139
Removed:
match S.log s (single "shrugs" 80. 10) with
221
Added:
let s, t = fixture () in
222
Added:
let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in
223
Added:
match run (S.log s t (single "shrugs" 80. 10)) with
140
224
| Error (S.Rejected (Workout.Not_prescribed _)) -> ()
141
225
| _ -> Alcotest.fail "expected Rejected Not_prescribed" );
142
226
( "Day 1 can be logged in full and finished",
143
227
`Quick,
144
228
fun () ->
145
Removed:
let s = service () in
146
Removed:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
147
Removed:
List.iter (fun st -> ignore (ok (S.log s st))) day_one_stimuli;
148
Removed:
let w = Option.get (S.in_progress s) in
229
Added:
let s, t = fixture () in
230
Added:
let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in
231
Added:
List.iter (fun st -> ignore (ok (run (S.log s t st)))) day_one_stimuli;
232
Added:
let w = Option.get (run (S.in_progress s t)) in
149
233
Alcotest.(check int) "four stimuli" 4 (List.length (Workout.stimuli w));
150
234
Alcotest.(check int)
151
235
"nothing outstanding" 0
152
236
(List.length (Workout.unperformed w));
153
Removed:
let record = Option.get (S.finish s ~ended_at:(at 3600)) in
237
Added:
let record = Option.get (run (S.finish s t ~ended_at:(at 3600))) in
154
238
Alcotest.(check bool)
155
239
"persisted as finished" true
156
240
(Workout.is_finished record.Repository.workout);
157
241
Alcotest.(check bool)
158
242
"slot cleared" true
159
Removed:
(Option.is_none (S.in_progress s)) );
243
Added:
(Option.is_none (run (S.in_progress s t))) );
160
244
( "history returns the finished workout",
161
245
`Quick,
162
246
fun () ->
163
Removed:
let s = service () in
164
Removed:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
165
Removed:
let _ = ok (S.log s (single "laterals" 12. 8)) in
166
Removed:
let _ = S.finish s ~ended_at:(at 3600) in
167
Removed:
Alcotest.(check int) "one workout" 1 (List.length (S.history s)) );
247
Added:
let s, t = fixture () in
248
Added:
let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in
249
Added:
let _ = ok (run (S.log s t (single "laterals" 12. 8))) in
250
Added:
let _ = run (S.finish s t ~ended_at:(at 3600)) in
251
Added:
Alcotest.(check int) "one workout" 1 (List.length (run (S.history s t)))
252
Added:
);
168
253
]
169
254
170
255
let active_and_edit_tests =
@@ -172,27 +257,28 @@
172
257
( "routine selection is explicit and rejects unknown IDs",
173
258
`Quick,
174
259
fun () ->
175
Removed:
let s = service () in
260
Added:
let s, t = fixture () in
176
261
Alcotest.(check bool)
177
262
"no initial selection" true
178
Removed:
(Option.is_none (S.active_routine s));
179
Removed:
ignore (ok (S.select_routine s ideal));
263
Added:
(Option.is_none (run (S.active_routine s t)));
264
Added:
ignore (ok (run (S.select_routine s t ideal)));
180
265
Alcotest.(check string)
181
266
"selected ideal" "Ideal Routine"
182
Removed:
(Prescription.Routine.name (snd (Option.get (S.active_routine s))));
183
Removed:
match S.select_routine s (Repository.routine_id "missing") with
267
Added:
(Prescription.Routine.name
268
Added:
(snd (Option.get (run (S.active_routine s t)))));
269
Added:
match run (S.select_routine s t (Repository.routine_id "missing")) with
184
270
| Error S.Unknown_routine -> ()
185
271
| _ -> Alcotest.fail "expected Unknown_routine" );
186
272
( "a finished record can be completed later without changing its end",
187
273
`Quick,
188
274
fun () ->
189
Removed:
let s = service () in
190
Removed:
ignore (ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()));
191
Removed:
let record = Option.get (S.finish s ~ended_at:(at 120)) in
275
Added:
let s, t = fixture () in
276
Added:
ignore (ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())));
277
Added:
let record = Option.get (run (S.finish s t ~ended_at:(at 120))) in
192
278
let record =
193
279
List.fold_left
194
280
(fun record stimulus ->
195
Removed:
ok (S.add_to_record s record.Repository.id stimulus))
281
Added:
ok (run (S.add_to_record s t record.Repository.id stimulus)))
196
282
record day_one_stimuli
197
283
in
198
284
Alcotest.(check bool)
@@ -211,46 +297,44 @@
211
297
( "evidence accumulates across cycles and feeds progression",
212
298
`Quick,
213
299
fun () ->
214
Removed:
let s = service () in
215
Removed:
(* The cycle rotates, so laterals — a Day 1 movement — recur only once
216
Removed:
per three workouts. Log whole cycles and record laterals whenever
217
Removed:
Day 1 comes round, at an unchanging load. *)
218
Removed:
let run ~on ~load =
300
Added:
let s, t = fixture () in
301
Added:
let run_workout ~on ~load =
219
302
let w =
220
Removed:
ok (S.begin_workout s ~routine:ideal ~now:on ~override:() ())
303
Added:
ok
304
Added:
(run (S.begin_workout s t ~routine:ideal ~now:on ~override:() ()))
221
305
in
222
306
if
223
307
String.equal "Day 1"
224
308
(Prescription.Workout.name (Workout.prescription w))
225
Removed:
then ignore (ok (S.log s (single "laterals" load 8)));
226
Removed:
ignore (S.finish s ~ended_at:on)
309
Added:
then ignore (ok (run (S.log s t (single "laterals" load 8))));
310
Added:
ignore (run (S.finish s t ~ended_at:on))
227
311
in
228
312
List.iter
229
Removed:
(fun on -> run ~on ~load:12.)
313
Added:
(fun on -> run_workout ~on ~load:12.)
230
314
[ day 1; day 3; day 5; day 8; day 10; day 12; day 16 ];
231
Removed:
(* Laterals seen on days 1, 8 and 16 with no gain: fifteen days without
232
Removed:
an advance, which is past HD1's two-week threshold. *)
233
315
Alcotest.(check int)
234
316
"seven workouts logged" 7
235
Removed:
(List.length (S.history s));
317
Added:
(List.length (run (S.history s t)));
236
318
Alcotest.(check bool)
237
319
"stalled" true
238
Removed:
(S.progress s (get "laterals") = Ok Progression.Stalled) );
320
Added:
(run (S.progress s t (get "laterals")) = Ok Progression.Stalled) );
239
321
( "training on overrides shows up as a diagnostic",
240
322
`Quick,
241
323
fun () ->
242
Removed:
let s = service () in
243
Removed:
let _ = ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()) in
244
Removed:
let _ = S.finish s ~ended_at:(day 1) in
324
Added:
let s, t = fixture () in
325
Added:
let _ = ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())) in
326
Added:
let _ = run (S.finish s t ~ended_at:(day 1)) in
245
327
let _ =
246
Removed:
ok (S.begin_workout s ~routine:ideal ~now:(day 2) ~override:() ())
328
Added:
ok
329
Added:
(run
330
Added:
(S.begin_workout s t ~routine:ideal ~now:(day 2) ~override:() ()))
247
331
in
248
Removed:
let _ = S.finish s ~ended_at:(day 2) in
332
Added:
let _ = run (S.finish s t ~ended_at:(day 2)) in
249
333
match
250
334
List.filter
251
335
(function
252
336
| Progression.Trained_under_recovered _ -> true | _ -> false)
253
Removed:
(S.diagnostics s)
337
Added:
(run (S.diagnostics s t))
254
338
with
255
339
| [ Progression.Trained_under_recovered n ] ->
256
340
Alcotest.(check int) "one such workout" 1 n
@@ -259,6 +343,7 @@
259
343
260
344
let suite =
261
345
[
346
Added:
("service.accounts", account_tests);
262
347
("service.routines", routine_tests);
263
348
("service.clearance", clearance_tests);
264
349
("service.logging", logging_tests);
test/test_sqlite_repo.ml
@@ -0,0 +1,198 @@
1
Added:
(** Tests for {!Hito_app.Sqlite_repo} — the durable store. Proves that state
2
Added:
survives reconnecting to the same file, and that trainees stay isolated. *)
3
Added:
4
Added:
open Hito_app
5
Added:
module S = Service.Make (Sqlite_repo)
6
Added:
module Stimulus = Evidence.Stimulus
7
Added:
module Workout = Evidence.Workout
8
Added:
9
Added:
let run = Lwt_main.run
10
Added:
let ok = function Ok v -> v | Error _ -> Alcotest.fail "expected Ok"
11
Added:
12
Added:
let get id =
13
Added:
match Exercise.find_id id with
14
Added:
| Some e -> e
15
Added:
| None -> Alcotest.failf "catalog is missing %S" id
16
Added:
17
Added:
let at s = Recovery.timestamp_of_unix_seconds s
18
Added:
let day n = at (n * 86_400)
19
Added:
let ideal = Repository.routine_id "ideal"
20
Added:
21
Added:
let single id load reps =
22
Added:
Stimulus.make
23
Added:
(Stimulus.Single
24
Added:
(Stimulus.Effort.make ~exercise:(get id) ~load ~reps
25
Added:
~outcome:Stimulus.Positive_failure))
26
Added:
27
Added:
(* A unique temp database file per test; SQLite is a plain file. *)
28
Added:
let temp_uri () =
29
Added:
let path = Filename.temp_file "hito-test-" ".sqlite" in
30
Added:
Sys.remove path;
31
Added:
(path, "sqlite3:" ^ path)
32
Added:
33
Added:
let connect uri = ok (run (Sqlite_repo.connect uri))
34
Added:
35
Added:
let cleanup path =
36
Added:
List.iter
37
Added:
(fun suffix -> try Sys.remove (path ^ suffix) with Sys_error _ -> ())
38
Added:
[ ""; "-wal"; "-shm" ]
39
Added:
40
Added:
let durability_tests =
41
Added:
[
42
Added:
( "a finished workout survives a reconnect to the same file",
43
Added:
`Quick,
44
Added:
fun () ->
45
Added:
let path, uri = temp_uri () in
46
Added:
Fun.protect
47
Added:
~finally:(fun () -> cleanup path)
48
Added:
(fun () ->
49
Added:
let trainee_id =
50
Added:
let repo = connect uri in
51
Added:
let s = S.make ~repo in
52
Added:
let trainee =
53
Added:
ok (run (S.register s ~email:"a@b.com" ~password:"heavyduty1"))
54
Added:
in
55
Added:
let id = trainee.Trainee.id in
56
Added:
let _ =
57
Added:
ok (run (S.begin_workout s id ~routine:ideal ~now:(day 1) ()))
58
Added:
in
59
Added:
let _ = ok (run (S.log s id (single "laterals" 12. 8))) in
60
Added:
let _ = run (S.finish s id ~ended_at:(day 1)) in
61
Added:
id
62
Added:
in
63
Added:
(* Reconnect with a fresh repo value to the same file. *)
64
Added:
let repo = connect uri in
65
Added:
let s = S.make ~repo in
66
Added:
let found =
67
Added:
run (S.authenticate s ~email:"a@b.com" ~password:"heavyduty1")
68
Added:
in
69
Added:
Alcotest.(check bool)
70
Added:
"account persisted" true (Option.is_some found);
71
Added:
Alcotest.(check string)
72
Added:
"same trainee id"
73
Added:
(Trainee.id_to_string trainee_id)
74
Added:
(Trainee.id_to_string (Option.get found).Trainee.id);
75
Added:
Alcotest.(check int)
76
Added:
"history persisted" 1
77
Added:
(List.length (run (S.history s trainee_id)))) );
78
Added:
( "the workout in progress is durable and per-trainee",
79
Added:
`Quick,
80
Added:
fun () ->
81
Added:
let path, uri = temp_uri () in
82
Added:
Fun.protect
83
Added:
~finally:(fun () -> cleanup path)
84
Added:
(fun () ->
85
Added:
let repo = connect uri in
86
Added:
let s = S.make ~repo in
87
Added:
let a =
88
Added:
(ok (run (S.register s ~email:"a@b.com" ~password:"heavyduty1")))
89
Added:
.Trainee.id
90
Added:
in
91
Added:
let b =
92
Added:
(ok (run (S.register s ~email:"c@d.com" ~password:"heavyduty1")))
93
Added:
.Trainee.id
94
Added:
in
95
Added:
let _ =
96
Added:
ok (run (S.begin_workout s a ~routine:ideal ~now:(day 1) ()))
97
Added:
in
98
Added:
(* Reconnect and confirm a's slot survives while b's stays empty. *)
99
Added:
let repo = connect uri in
100
Added:
let s = S.make ~repo in
101
Added:
Alcotest.(check bool)
102
Added:
"a has a workout in progress" true
103
Added:
(Option.is_some (run (S.in_progress s a)));
104
Added:
Alcotest.(check bool)
105
Added:
"b does not" true
106
Added:
(Option.is_none (run (S.in_progress s b)))) );
107
Added:
( "a saved record can be completed later and stays complete",
108
Added:
`Quick,
109
Added:
fun () ->
110
Added:
let path, uri = temp_uri () in
111
Added:
Fun.protect
112
Added:
~finally:(fun () -> cleanup path)
113
Added:
(fun () ->
114
Added:
let repo = connect uri in
115
Added:
let s = S.make ~repo in
116
Added:
let t =
117
Added:
(ok (run (S.register s ~email:"a@b.com" ~password:"heavyduty1")))
118
Added:
.Trainee.id
119
Added:
in
120
Added:
let _ =
121
Added:
ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ()))
122
Added:
in
123
Added:
let record = Option.get (run (S.finish s t ~ended_at:(at 120))) in
124
Added:
let record =
125
Added:
ok
126
Added:
(run
127
Added:
(S.add_to_record s t record.Repository.id
128
Added:
(single "laterals" 12. 8)))
129
Added:
in
130
Added:
(* Reconnect and read it back. *)
131
Added:
let repo = connect uri in
132
Added:
let s = S.make ~repo in
133
Added:
let reread =
134
Added:
Option.get (run (S.find_record s t record.Repository.id))
135
Added:
in
136
Added:
Alcotest.(check int)
137
Added:
"one stimulus survived" 1
138
Added:
(List.length (Workout.stimuli reread.Repository.workout))) );
139
Added:
]
140
Added:
141
Added:
let migration_tests =
142
Added:
[
143
Added:
( "applying migrations twice to one file is idempotent",
144
Added:
`Quick,
145
Added:
fun () ->
146
Added:
let path, uri = temp_uri () in
147
Added:
Fun.protect
148
Added:
~finally:(fun () -> cleanup path)
149
Added:
(fun () ->
150
Added:
(* First connect creates and records the schema. *)
151
Added:
let _ = connect uri in
152
Added:
(* A second connect on the same file must not fail re-applying an
153
Added:
already-recorded migration. *)
154
Added:
let repo = connect uri in
155
Added:
let s = S.make ~repo in
156
Added:
let trainee =
157
Added:
ok (run (S.register s ~email:"a@b.com" ~password:"heavyduty1"))
158
Added:
in
159
Added:
Alcotest.(check bool)
160
Added:
"usable after reconnect" true
161
Added:
(Option.is_some
162
Added:
(run
163
Added:
(S.authenticate s ~email:"a@b.com" ~password:"heavyduty1")));
164
Added:
ignore trainee) );
165
Added:
( "finishing is atomic: the record is saved and the slot cleared",
166
Added:
`Quick,
167
Added:
fun () ->
168
Added:
let path, uri = temp_uri () in
169
Added:
Fun.protect
170
Added:
~finally:(fun () -> cleanup path)
171
Added:
(fun () ->
172
Added:
let repo = connect uri in
173
Added:
let s = S.make ~repo in
174
Added:
let t =
175
Added:
(ok (run (S.register s ~email:"a@b.com" ~password:"heavyduty1")))
176
Added:
.Trainee.id
177
Added:
in
178
Added:
let _ =
179
Added:
ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ()))
180
Added:
in
181
Added:
let _ = run (S.finish s t ~ended_at:(day 1)) in
182
Added:
(* After a reconnect both effects of finish are visible together:
183
Added:
the workout is in history and no slot remains in progress. *)
184
Added:
let repo = connect uri in
185
Added:
let s = S.make ~repo in
186
Added:
Alcotest.(check int)
187
Added:
"one workout in history" 1
188
Added:
(List.length (run (S.history s t)));
189
Added:
Alcotest.(check bool)
190
Added:
"slot cleared" true
191
Added:
(Option.is_none (run (S.in_progress s t)))) );
192
Added:
]
193
Added:
194
Added:
let suite =
195
Added:
[
196
Added:
("sqlite_repo", durability_tests);
197
Added:
("sqlite_repo.migrations", migration_tests);
198
Added:
]
test/test_web.ml
@@ -1,127 +1,209 @@
1
Added:
(** Web tier tests. Sessions and CSRF are exercised end to end: a small client
2
Added:
carries the session cookie between requests and pulls the CSRF token out of
3
Added:
the rendered page, exactly as a browser would. The in-memory repository
4
Added:
stands in for SQLite; session storage is Dream's in-memory back end. *)
5
Added:
6
Added:
open Hito_app
7
Added:
module Handlers = Hito_web.Handlers.Make (Memory_repo)
8
Added:
9
Added:
(* A fresh, fully wired application: secret, in-memory sessions, routes. *)
1
10
let app () =
2
Removed:
Hito_web.Handlers.create () |> Hito_web.Handlers.routes |> Dream.router
11
Added:
let handlers = Handlers.make ~repo:(Memory_repo.create ()) () in
12
Added:
Dream.memory_sessions @@ Dream.router (Handlers.routes handlers)
13
Added:
|> fun handler -> Dream.set_secret "test-secret-value" handler
3
14
4
15
let status response = Dream.status response |> Dream.status_to_int
5
16
let body response = Lwt_main.run (Dream.body response)
6
17
7
18
let contains ~substring string =
8
Removed:
let substring_length = String.length substring in
9
Removed:
let rec at index =
10
Removed:
if index + substring_length > String.length string then false
11
Removed:
else if String.sub string index substring_length = substring then true
12
Removed:
else at (index + 1)
19
Added:
let n = String.length substring in
20
Added:
let rec at i =
21
Added:
if i + n > String.length string then false
22
Added:
else if String.sub string i n = substring then true
23
Added:
else at (i + 1)
13
24
in
14
25
at 0
15
26
16
Removed:
let post app target body =
17
Removed:
Dream.test app
18
Removed:
(Dream.request ~method_:`POST ~target
19
Removed:
~headers:[ ("Content-Type", "application/x-www-form-urlencoded") ]
20
Removed:
body)
27
Added:
(* --- a cookie-carrying client --- *)
21
28
29
Added:
(* Extract cookies (name=value) from all Set-Cookie response headers. *)
30
Added:
let cookies_of response =
31
Added:
Dream.headers response "Set-Cookie"
32
Added:
|> List.filter_map (fun sc ->
33
Added:
match String.index_opt sc ';' with
34
Added:
| Some i -> Some (String.sub sc 0 i)
35
Added:
| None -> Some sc)
36
Added:
37
Added:
type client = { app : Dream.handler; mutable jar : string list }
38
Added:
39
Added:
let client () = { app = app (); jar = [] }
40
Added:
41
Added:
let cookie_header client =
42
Added:
if client.jar = [] then [] else [ ("Cookie", String.concat "; " client.jar) ]
43
Added:
44
Added:
let remember client response =
45
Added:
(* Replace cookies of the same name; keep the rest. *)
46
Added:
List.iter
47
Added:
(fun fresh ->
48
Added:
let name =
49
Added:
match String.index_opt fresh '=' with
50
Added:
| Some i -> String.sub fresh 0 i
51
Added:
| None -> fresh
52
Added:
in
53
Added:
client.jar <-
54
Added:
fresh
55
Added:
:: List.filter
56
Added:
(fun old ->
57
Added:
not
58
Added:
(String.length old >= String.length name
59
Added:
&& String.sub old 0 (String.length name) = name
60
Added:
&& (String.length old = String.length name
61
Added:
|| old.[String.length name] = '=')))
62
Added:
client.jar)
63
Added:
(cookies_of response)
64
Added:
65
Added:
let get client target =
66
Added:
let response =
67
Added:
Dream.test client.app
68
Added:
(Dream.request ~method_:`GET ~target ~headers:(cookie_header client) "")
69
Added:
in
70
Added:
remember client response;
71
Added:
response
72
Added:
73
Added:
let post client target fields =
74
Added:
let body =
75
Added:
fields
76
Added:
|> List.map (fun (k, v) ->
77
Added:
Dream.to_percent_encoded k ^ "=" ^ Dream.to_percent_encoded v)
78
Added:
|> String.concat "&"
79
Added:
in
80
Added:
let response =
81
Added:
Dream.test client.app
82
Added:
(Dream.request ~method_:`POST ~target
83
Added:
~headers:
84
Added:
(("Content-Type", "application/x-www-form-urlencoded")
85
Added:
:: cookie_header client)
86
Added:
body)
87
Added:
in
88
Added:
remember client response;
89
Added:
response
90
Added:
91
Added:
(* A tiny substring search, since Str is not a dependency here. *)
92
Added:
let index_from ~needle haystack start =
93
Added:
let n = String.length needle and h = String.length haystack in
94
Added:
let rec at i =
95
Added:
if i + n > h then None
96
Added:
else if String.sub haystack i n = needle then Some i
97
Added:
else at (i + 1)
98
Added:
in
99
Added:
if start < 0 then None else at start
100
Added:
101
Added:
(* Pull the CSRF token value out of a rendered form. *)
102
Added:
let csrf_token html =
103
Added:
match index_from ~needle:"name=\"dream.csrf\"" html 0 with
104
Added:
| None -> None
105
Added:
| Some idx -> (
106
Added:
match index_from ~needle:"value=\"" html idx with
107
Added:
| None -> None
108
Added:
| Some v ->
109
Added:
let start = v + String.length "value=\"" in
110
Added:
let stop = String.index_from html start '"' in
111
Added:
Some (String.sub html start (stop - start)))
112
Added:
113
Added:
let register client ~email ~password =
114
Added:
let page = body (get client "/register") in
115
Added:
let token = Option.get (csrf_token page) in
116
Added:
post client "/register"
117
Added:
[ ("dream.csrf", token); ("email", email); ("password", password) ]
118
Added:
119
Added:
let sign_in_new client =
120
Added:
register client ~email:"lifter@example.com" ~password:"heavyduty1"
121
Added:
22
122
let route_tests =
23
123
[
24
Removed:
( "web",
124
Added:
( "web.auth",
25
125
[
26
Removed:
( "home serves the routine catalog before selection",
126
Added:
( "an unauthenticated visit to the overview redirects to sign-in",
27
127
`Quick,
28
128
fun () ->
29
Removed:
let response = Dream.test (app ()) (Dream.request "") in
30
Removed:
Alcotest.(check int) "status" 200 (status response);
129
Added:
let c = client () in
130
Added:
let response = get c "/" in
131
Added:
Alcotest.(check int) "redirect" 303 (status response) );
132
Added:
( "the sign-in page renders a CSRF-protected form",
133
Added:
`Quick,
134
Added:
fun () ->
135
Added:
let c = client () in
136
Added:
let page = body (get c "/login") in
31
137
Alcotest.(check bool)
32
Removed:
"Overview active class" true
33
Removed:
(contains ~substring:"page-home" (body response));
138
Added:
"has csrf field" true
139
Added:
(contains ~substring:"dream.csrf" page);
34
140
Alcotest.(check bool)
35
Removed:
"expanded brand subtitle" true
36
Removed:
(contains ~substring:"High Intensity Tracker Online"
37
Removed:
(body response));
141
Added:
"has a password field" true
142
Added:
(contains ~substring:"type=\"password\"" page) );
143
Added:
( "registration signs the trainee in and reaches the overview",
144
Added:
`Quick,
145
Added:
fun () ->
146
Added:
let c = client () in
147
Added:
let registered = sign_in_new c in
148
Added:
Alcotest.(check int)
149
Added:
"registered, redirected" 303 (status registered);
150
Added:
let overview = get c "/" in
151
Added:
Alcotest.(check int) "authenticated overview" 200 (status overview);
38
152
Alcotest.(check bool)
39
Removed:
"mobile navigation shell" true
40
Removed:
(contains ~substring:"bottom-nav" (body response));
153
Added:
"shows the routine catalog" true
154
Added:
(contains ~substring:"Routines" (body overview));
41
155
Alcotest.(check bool)
42
Removed:
"routine mobile action" true
43
Removed:
(contains ~substring:">Routine<" (body response));
44
Removed:
Alcotest.(check bool)
45
Removed:
"log book mobile action" true
46
Removed:
(contains ~substring:">Log Book<" (body response)) );
47
Removed:
( "stylesheet declares requested fonts and focus rules",
156
Added:
"shows the signed-in email" true
157
Added:
(contains ~substring:"lifter@example.com" (body overview)) );
158
Added:
( "a form post without a CSRF token is refused",
48
159
`Quick,
49
160
fun () ->
161
Added:
let c = client () in
162
Added:
let _ = sign_in_new c in
50
163
let response =
51
Removed:
Dream.test (app ()) (Dream.request ~target:"/assets/hito.css" "")
164
Added:
post c "/routines/ideal/select" [ (* no dream.csrf *) ]
52
165
in
53
Removed:
Alcotest.(check int) "stylesheet" 200 (status response);
54
Removed:
let stylesheet = body response in
55
166
Alcotest.(check bool)
56
Removed:
"Work Sans" true
57
Removed:
(contains ~substring:"Work Sans" stylesheet);
58
Removed:
Alcotest.(check bool)
59
Removed:
"Courier Prime" true
60
Removed:
(contains ~substring:"Courier Prime" stylesheet);
61
Removed:
Alcotest.(check bool)
62
Removed:
"font display swap" true
63
Removed:
(contains ~substring:"display=swap" stylesheet);
64
Removed:
Alcotest.(check bool)
65
Removed:
"visible focus" true
66
Removed:
(contains ~substring:":focus-visible" stylesheet);
67
Removed:
Alcotest.(check bool)
68
Removed:
"active workout navigation" true
69
Removed:
(contains ~substring:".page-workout .primary-nav" stylesheet);
70
Removed:
Alcotest.(check bool)
71
Removed:
"42rem mobile breakpoint" true
72
Removed:
(contains ~substring:"@media (max-width: 42rem)" stylesheet);
73
Removed:
Alcotest.(check bool)
74
Removed:
"sticky bottom navigation" true
75
Removed:
(contains ~substring:".bottom-nav" stylesheet);
76
Removed:
Alcotest.(check bool)
77
Removed:
"fixed bottom navigation" true
78
Removed:
(contains ~substring:"position: fixed" stylesheet);
79
Removed:
Alcotest.(check bool)
80
Removed:
"safe area spacing" true
81
Removed:
(contains ~substring:"safe-area-inset-bottom" stylesheet);
82
Removed:
Alcotest.(check bool)
83
Removed:
"Bootstrap small text scale" true
84
Removed:
(contains ~substring:"--font-size-small: 0.875rem" stylesheet);
85
Removed:
Alcotest.(check bool)
86
Removed:
"balanced heading scale" true
87
Removed:
(contains
88
Removed:
~substring:"clamp(1.75rem, 4vw, var(--font-size-heading))"
89
Removed:
stylesheet);
90
Removed:
Alcotest.(check bool)
91
Removed:
"accessible control height" true
92
Removed:
(contains ~substring:"min-height: 3rem" stylesheet) );
93
Removed:
( "a new workout exposes outstanding effort forms on Overview",
167
Added:
"not a redirect to success" true
168
Added:
(status response <> 303) );
169
Added:
] );
170
Added:
( "web.flow",
171
Added:
[
172
Added:
( "a signed-in trainee starts a workout and sees the effort forms",
94
173
`Quick,
95
174
fun () ->
96
Removed:
let application = app () in
97
Removed:
let selection = post application "/routines/ideal/select" "" in
175
Added:
let c = client () in
176
Added:
let _ = sign_in_new c in
177
Added:
let select_page = body (get c "/") in
178
Added:
let token = Option.get (csrf_token select_page) in
179
Added:
let selection =
180
Added:
post c "/routines/ideal/select" [ ("dream.csrf", token) ]
181
Added:
in
98
182
Alcotest.(check int) "routine selected" 303 (status selection);
99
Removed:
let started = post application "/workout" "override=false" in
183
Added:
let home_page = body (get c "/") in
184
Added:
let token = Option.get (csrf_token home_page) in
185
Added:
let started =
186
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
187
Added:
in
100
188
Alcotest.(check int) "workout started" 303 (status started);
101
Removed:
let overview = Dream.test application (Dream.request "") in
102
Removed:
Alcotest.(check int) "overview" 200 (status overview);
103
Removed:
let page = body overview in
189
Added:
let workout_page = body (get c "/workout") in
104
190
Alcotest.(check bool)
105
Removed:
"Current workout active class" true
106
Removed:
(contains ~substring:"page-workout" page);
107
Removed:
Alcotest.(check bool)
108
Removed:
"current workout mobile action" true
109
Removed:
(contains ~substring:">Current Workout<" page);
110
Removed:
Alcotest.(check bool)
111
191
"outstanding heading" true
112
Removed:
(contains ~substring:"Still to do" page);
192
Added:
(contains ~substring:"Still to do" workout_page);
113
193
Alcotest.(check bool)
114
194
"first effort form" true
115
Removed:
(contains ~substring:"/workout/slots/0" page);
116
Removed:
Alcotest.(check bool)
117
Removed:
"load label references control" true
118
Removed:
(contains ~substring:"for=\"slot-0-iso_load\"" page);
119
Removed:
Alcotest.(check bool)
120
Removed:
"load control has ID" true
121
Removed:
(contains ~substring:"id=\"slot-0-iso_load\"" page);
122
Removed:
Alcotest.(check bool)
123
Removed:
"ending label references control" true
124
Removed:
(contains ~substring:"for=\"slot-0-extension\"" page) );
195
Added:
(contains ~substring:"/workout/slots/0" workout_page) );
196
Added:
( "signing out returns the trainee to the sign-in page",
197
Added:
`Quick,
198
Added:
fun () ->
199
Added:
let c = client () in
200
Added:
let _ = sign_in_new c in
201
Added:
let page = body (get c "/") in
202
Added:
let token = Option.get (csrf_token page) in
203
Added:
let out = post c "/logout" [ ("dream.csrf", token) ] in
204
Added:
Alcotest.(check int) "logout redirect" 303 (status out);
205
Added:
let after = get c "/" in
206
Added:
Alcotest.(check int) "overview now redirects" 303 (status after) );
125
207
] );
126
208
]
127
209