[OCaml] High Intensity Training Online
test Split test_web.ml into a test/web directory
test_web.ml was 2259 lines in one file, three times the next largest test, and mirrored none of the feature split it exercises. Turn on (include_subdirs qualified) so a directory is a module namespace, drop the hand-maintained module list, and cut the file along its thirteen existing suite boundaries: test/web/auth.ml is Web.Auth, and so on. The shared client, cookie, and CSRF helpers become Web.Support. Mechanical only. Every suite keeps its name and contents, the runner keeps the order, and the same 327 tests pass.
Changed files
- test/dune
- test/test_hito.ml
- test/test_web.ml
- test/web/app_feedback.ml
- test/web/auth.ml
- test/web/duplicate_feedback.ml
- test/web/errors.ml
- test/web/flow.ml
- test/web/import.ml
- test/web/isolation.ml
- test/web/lifecycle.ml
- test/web/profile.ml
- test/web/routine_selection.ml
- test/web/saved_record_add.ml
- test/web/sign_in.ml
- test/web/slot_bounds.ml
- test/web/support.ml
test/dune
@@ -1,25 +1,10 @@
1
Added:
; One test executable. Sub-directories are module namespaces: test/web/auth.ml is
2
Added:
; Web.Auth. Every module under test/ belongs to the runner, so no list to keep.
3
Added:
4
Added:
(include_subdirs qualified)
5
Added:
1
6
(test
2
7
(name test_hito)
3
Removed:
(modules
4
Removed:
test_hito
5
Removed:
memory_repo
6
Removed:
test_exercise
7
Removed:
test_recovery
8
Removed:
test_prescription
9
Removed:
test_evidence
10
Removed:
test_progression
11
Removed:
test_service
12
Removed:
test_workout_import
13
Removed:
test_import_service
14
Removed:
test_codec
15
Removed:
test_import_codec
16
Removed:
test_import_repo
17
Removed:
test_import_sqlite
18
Removed:
test_bcrypt_hash
19
Removed:
test_sqlite_repo
20
Removed:
test_decode
21
Removed:
test_hevy_csv
22
Removed:
test_web)
23
8
(libraries
24
9
hito.core
25
10
hito.app
test/test_hito.ml
@@ -12,4 +12,9 @@
12
12
@ Test_workout_import.suite @ Test_import_service.suite @ Test_codec.suite
13
13
@ Test_import_codec.suite @ Test_import_repo.suite @ Test_import_sqlite.suite
14
14
@ Test_bcrypt_hash.suite @ Test_sqlite_repo.suite @ Test_decode.suite
15
Removed:
@ Test_hevy_csv.suite @ Test_web.suite)
15
Added:
@ Test_hevy_csv.suite @ Web.Auth.suite @ Web.Flow.suite
16
Added:
@ Web.App_feedback.suite @ Web.Profile.suite @ Web.Errors.suite
17
Added:
@ Web.Sign_in.suite @ Web.Routine_selection.suite
18
Added:
@ Web.Saved_record_add.suite @ Web.Slot_bounds.suite
19
Added:
@ Web.Duplicate_feedback.suite @ Web.Lifecycle.suite @ Web.Isolation.suite
20
Added:
@ Web.Import.suite)
test/test_web.ml
@@ -1,2255 +0,0 @@
1
Removed:
(** Web tier tests. Sessions and CSRF are exercised end to end: a small client
2
Removed:
carries the session cookie between requests and pulls the CSRF token out of
3
Removed:
the rendered page, exactly as a browser would. The in-memory repository
4
Removed:
stands in for SQLite; session storage is Dream's in-memory back end. *)
5
Removed:
6
Removed:
open Hito_app
7
Removed:
open Hito_persistence
8
Removed:
module Handlers = Hito_web.Handlers.Make (Memory_repo) (Bcrypt_hash)
9
Removed:
10
Removed:
(* A fresh, fully wired application: secret, in-memory sessions, routes.
11
Removed:
Registration is opened here so the auth-flow tests can create trainees via
12
Removed:
[/register]; production keeps it closed. *)
13
Removed:
let app () =
14
Removed:
let handlers =
15
Removed:
Handlers.make ~repo:(Memory_repo.create ()) ~registration_open:true ()
16
Removed:
in
17
Removed:
Dream.memory_sessions @@ Dream.router (Handlers.routes handlers)
18
Removed:
|> fun handler -> Dream.set_secret "test-secret-value" handler
19
Removed:
20
Removed:
let status response = Dream.status response |> Dream.status_to_int
21
Removed:
let body response = Lwt_main.run (Dream.body response)
22
Removed:
23
Removed:
(* The redirect target of a 3xx response — the URL half of a URL-to-URL flow. *)
24
Removed:
let location response =
25
Removed:
match Dream.header response "Location" with
26
Removed:
| Some target -> target
27
Removed:
| None -> Alcotest.failf "expected a Location header on a redirect"
28
Removed:
29
Removed:
(* --- a cookie-carrying client --- *)
30
Removed:
31
Removed:
(* Extract cookies (name=value) from all Set-Cookie response headers. *)
32
Removed:
let cookies_of response =
33
Removed:
Dream.headers response "Set-Cookie"
34
Removed:
|> List.filter_map (fun sc ->
35
Removed:
match String.index_opt sc ';' with
36
Removed:
| Some i -> Some (String.sub sc 0 i)
37
Removed:
| None -> Some sc)
38
Removed:
39
Removed:
type client = { app : Dream.handler; mutable jar : string list }
40
Removed:
41
Removed:
let client () = { app = app (); jar = [] }
42
Removed:
43
Removed:
let cookie_header client =
44
Removed:
if client.jar = [] then [] else [ ("Cookie", String.concat "; " client.jar) ]
45
Removed:
46
Removed:
let remember client response =
47
Removed:
(* Replace cookies of the same name; keep the rest. *)
48
Removed:
List.iter
49
Removed:
(fun fresh ->
50
Removed:
let name =
51
Removed:
match String.index_opt fresh '=' with
52
Removed:
| Some i -> String.sub fresh 0 i
53
Removed:
| None -> fresh
54
Removed:
in
55
Removed:
client.jar <-
56
Removed:
fresh
57
Removed:
:: List.filter
58
Removed:
(fun old ->
59
Removed:
not
60
Removed:
(String.length old >= String.length name
61
Removed:
&& String.sub old 0 (String.length name) = name
62
Removed:
&& (String.length old = String.length name
63
Removed:
|| old.[String.length name] = '=')))
64
Removed:
client.jar)
65
Removed:
(cookies_of response)
66
Removed:
67
Removed:
let get client target =
68
Removed:
let response =
69
Removed:
Dream.test client.app
70
Removed:
(Dream.request ~method_:`GET ~target ~headers:(cookie_header client) "")
71
Removed:
in
72
Removed:
remember client response;
73
Removed:
response
74
Removed:
75
Removed:
let post client target fields =
76
Removed:
let body =
77
Removed:
fields
78
Removed:
|> List.map (fun (k, v) ->
79
Removed:
Dream.to_percent_encoded k ^ "=" ^ Dream.to_percent_encoded v)
80
Removed:
|> String.concat "&"
81
Removed:
in
82
Removed:
let response =
83
Removed:
Dream.test client.app
84
Removed:
(Dream.request ~method_:`POST ~target
85
Removed:
~headers:
86
Removed:
(("Content-Type", "application/x-www-form-urlencoded")
87
Removed:
:: cookie_header client)
88
Removed:
body)
89
Removed:
in
90
Removed:
remember client response;
91
Removed:
response
92
Removed:
93
Removed:
(* A multipart/form-data POST. [file] is [(field, filename, content)]; [fields]
94
Removed:
are plain text parts. The CSRF token rides as its own text part, exactly as
95
Removed:
[Dream.csrf_tag] renders it into a browser form, so [Dream.multipart ~csrf]
96
Removed:
verifies it. The boundary is fixed but improbable in the body. *)
97
Removed:
let post_multipart client target ~file ~fields =
98
Removed:
let boundary = "----hitotestboundary7Xk2p" in
99
Removed:
let buf = Buffer.create 1024 in
100
Removed:
let part_field (name, value) =
101
Removed:
Buffer.add_string buf ("--" ^ boundary ^ "\r\n");
102
Removed:
Buffer.add_string buf
103
Removed:
(Printf.sprintf "Content-Disposition: form-data; name=%S\r\n\r\n" name);
104
Removed:
Buffer.add_string buf value;
105
Removed:
Buffer.add_string buf "\r\n"
106
Removed:
in
107
Removed:
List.iter part_field fields;
108
Removed:
(match file with
109
Removed:
| Some (name, filename, content) ->
110
Removed:
Buffer.add_string buf ("--" ^ boundary ^ "\r\n");
111
Removed:
Buffer.add_string buf
112
Removed:
(Printf.sprintf
113
Removed:
"Content-Disposition: form-data; name=%S; filename=%S\r\n" name
114
Removed:
filename);
115
Removed:
Buffer.add_string buf "Content-Type: text/csv\r\n\r\n";
116
Removed:
Buffer.add_string buf content;
117
Removed:
Buffer.add_string buf "\r\n"
118
Removed:
| None -> ());
119
Removed:
Buffer.add_string buf ("--" ^ boundary ^ "--\r\n");
120
Removed:
let response =
121
Removed:
Dream.test client.app
122
Removed:
(Dream.request ~method_:`POST ~target
123
Removed:
~headers:
124
Removed:
(("Content-Type", "multipart/form-data; boundary=" ^ boundary)
125
Removed:
:: cookie_header client)
126
Removed:
(Buffer.contents buf))
127
Removed:
in
128
Removed:
remember client response;
129
Removed:
response
130
Removed:
131
Removed:
let index_from ~needle haystack start =
132
Removed:
let n = String.length needle and h = String.length haystack in
133
Removed:
let rec at i =
134
Removed:
if i + n > h then None
135
Removed:
else if String.sub haystack i n = needle then Some i
136
Removed:
else at (i + 1)
137
Removed:
in
138
Removed:
if start < 0 then None else at start
139
Removed:
140
Removed:
(* Pull the CSRF token value out of a rendered form. *)
141
Removed:
let csrf_token html =
142
Removed:
match index_from ~needle:"name=\"dream.csrf\"" html 0 with
143
Removed:
| None -> None
144
Removed:
| Some idx -> (
145
Removed:
match index_from ~needle:"value=\"" html idx with
146
Removed:
| None -> None
147
Removed:
| Some v ->
148
Removed:
let start = v + String.length "value=\"" in
149
Removed:
let stop = String.index_from html start '"' in
150
Removed:
Some (String.sub html start (stop - start)))
151
Removed:
152
Removed:
let register client ~username ~password =
153
Removed:
let page = body (get client "/register") in
154
Removed:
let token = Option.get (csrf_token page) in
155
Removed:
post client "/register"
156
Removed:
[ ("dream.csrf", token); ("username", username); ("password", password) ]
157
Removed:
158
Removed:
let sign_in_new client =
159
Removed:
register client ~username:"lifter" ~password:"heavyduty1"
160
Removed:
161
Removed:
(* Sign in through the credential form, as a returning trainee would. Unlike
162
Removed:
[register], this exercises the [POST /login] path. *)
163
Removed:
let sign_in client ~username ~password =
164
Removed:
let page = body (get client "/login") in
165
Removed:
let token = Option.get (csrf_token page) in
166
Removed:
post client "/login"
167
Removed:
[ ("dream.csrf", token); ("username", username); ("password", password) ]
168
Removed:
169
Removed:
(* An application whose clock the test drives. A shared [Memory_repo] and a
170
Removed:
mutable [now] cell let a deep test advance time across the recovery gate,
171
Removed:
which the wall-clock default cannot. Registration is open so the test can
172
Removed:
create the trainee it drives. Also hands back the repository, so a deep test
173
Removed:
can assert the domain state its flow produced. *)
174
Removed:
let clocked_client () =
175
Removed:
let now = ref 0 in
176
Removed:
let repo = Memory_repo.create () in
177
Removed:
let handlers =
178
Removed:
Handlers.make ~repo
179
Removed:
~now:(fun () -> Recovery.timestamp_of_unix_seconds !now)
180
Removed:
~registration_open:true ()
181
Removed:
in
182
Removed:
let app =
183
Removed:
Dream.memory_sessions @@ Dream.router (Handlers.routes handlers) |> fun h ->
184
Removed:
Dream.set_secret "test-secret-value" h
185
Removed:
in
186
Removed:
({ app; jar = [] }, now, repo)
187
Removed:
188
Removed:
let day n = n * 86_400
189
Removed:
190
Removed:
(* A client that hands back its repository, so a test can assert the domain
191
Removed:
state the flow produced — the log, the stored feedback, the renamed account —
192
Removed:
rather than reading it back out of rendered HTML. *)
193
Removed:
let client_with_repo () =
194
Removed:
let repo = Memory_repo.create () in
195
Removed:
let handlers = Handlers.make ~repo ~registration_open:true () in
196
Removed:
let app =
197
Removed:
Dream.memory_sessions @@ Dream.router (Handlers.routes handlers) |> fun h ->
198
Removed:
Dream.set_secret "test-secret-value" h
199
Removed:
in
200
Removed:
({ app; jar = [] }, repo)
201
Removed:
202
Removed:
(* Look up the sole seeded trainee by the name the flow helpers register. *)
203
Removed:
let the_trainee repo ~username =
204
Removed:
match Trainee.username username with
205
Removed:
| Error _ -> Alcotest.failf "test username %S is invalid" username
206
Removed:
| Ok u -> (
207
Removed:
match Lwt_main.run (Memory_repo.find_trainee_by_username repo u) with
208
Removed:
| Some trainee -> trainee
209
Removed:
| None -> Alcotest.failf "no trainee named %S" username)
210
Removed:
211
Removed:
(* Drive a trainee to the start of a fresh Day 1 workout: select the ideal
212
Removed:
routine and begin without an override. Returns the client. *)
213
Removed:
let start_day_one c =
214
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
215
Removed:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
216
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
217
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
218
Removed:
219
Removed:
(* Record every slot of the in-progress Day 1 workout, one at a time, addressed
220
Removed:
by [?slot=]. Slot 0 is the flyes/incline-press pair; slot 3 is the
221
Removed:
french-press/dips pair; slots 1 and 2 are single lateral movements. *)
222
Removed:
let record_all_day_one_slots c =
223
Removed:
let record_pair slot comp_load =
224
Removed:
let token =
225
Removed:
Option.get (csrf_token (body (get c ("/workout?slot=" ^ slot))))
226
Removed:
in
227
Removed:
post c ("/workout/slots/" ^ slot)
228
Removed:
[
229
Removed:
("dream.csrf", token);
230
Removed:
("iso_load", "20");
231
Removed:
("iso_reps", "9");
232
Removed:
("comp_load", comp_load);
233
Removed:
("comp_reps", "7");
234
Removed:
("extension", "");
235
Removed:
]
236
Removed:
in
237
Removed:
let record_single slot load reps =
238
Removed:
let token =
239
Removed:
Option.get (csrf_token (body (get c ("/workout?slot=" ^ slot))))
240
Removed:
in
241
Removed:
post c ("/workout/slots/" ^ slot)
242
Removed:
[
243
Removed:
("dream.csrf", token); ("load", load); ("reps", reps); ("extension", "");
244
Removed:
]
245
Removed:
in
246
Removed:
let _ = record_pair "0" "60" in
247
Removed:
let _ = record_single "1" "12" "8" in
248
Removed:
let _ = record_single "2" "10" "9" in
249
Removed:
let _ = record_pair "3" "0" in
250
Removed:
()
251
Removed:
252
Removed:
let route_tests =
253
Removed:
[
254
Removed:
( "web.auth",
255
Removed:
[
256
Removed:
( "an unauthenticated visit to the overview redirects to sign-in",
257
Removed:
`Quick,
258
Removed:
fun () ->
259
Removed:
let c = client () in
260
Removed:
let response = get c "/" in
261
Removed:
Alcotest.(check int) "redirect" 303 (status response);
262
Removed:
Alcotest.(check string) "to /login" "/login" (location response) );
263
Removed:
( "the sign-in page is served",
264
Removed:
`Quick,
265
Removed:
fun () ->
266
Removed:
let c = client () in
267
Removed:
Alcotest.(check int) "GET /login" 200 (status (get c "/login")) );
268
Removed:
( "every page carries the copyright and deployment version banner",
269
Removed:
`Quick,
270
Removed:
fun () ->
271
Removed:
let c = client () in
272
Removed:
let rendered = body (get c "/login") in
273
Removed:
let version =
274
Removed:
match Sys.getenv_opt "HITO_VERSION" with
275
Removed:
| Some value when value <> "" -> value
276
Removed:
| _ -> "development"
277
Removed:
in
278
Removed:
let now = Unix.gmtime (Unix.gettimeofday ()) in
279
Removed:
let copyright =
280
Removed:
Printf.sprintf "© %d Marius Peter" (now.Unix.tm_year + 1900)
281
Removed:
in
282
Removed:
Alcotest.(check bool)
283
Removed:
"copyright notice" true
284
Removed:
(Option.is_some (index_from ~needle:copyright rendered 0));
285
Removed:
Alcotest.(check bool)
286
Removed:
"deployment version markup" true
287
Removed:
(Option.is_some
288
Removed:
(index_from ~needle:"deployment-version" rendered 0));
289
Removed:
Alcotest.(check bool)
290
Removed:
"deployment version value" true
291
Removed:
(Option.is_some
292
Removed:
(index_from ~needle:(">" ^ version ^ "</code>") rendered 0)) );
293
Removed:
( "registration creates the account, signs in, and reaches the overview",
294
Removed:
`Quick,
295
Removed:
fun () ->
296
Removed:
let c, repo = client_with_repo () in
297
Removed:
let registered =
298
Removed:
register c ~username:"lifter" ~password:"heavyduty1"
299
Removed:
in
300
Removed:
Alcotest.(check int)
301
Removed:
"registered, redirected" 303 (status registered);
302
Removed:
(* The account now exists: the flow orchestrated a real create. *)
303
Removed:
let trainee = the_trainee repo ~username:"lifter" in
304
Removed:
Alcotest.(check string)
305
Removed:
"stored under the normalized username" "lifter"
306
Removed:
(Trainee.username_to_string trainee.Trainee.username);
307
Removed:
(* The session authenticates the follow-up request. *)
308
Removed:
Alcotest.(check int)
309
Removed:
"authenticated overview" 200
310
Removed:
(status (get c "/")) );
311
Removed:
( "an authenticated trainee reaches the overview",
312
Removed:
`Quick,
313
Removed:
fun () ->
314
Removed:
let c = client () in
315
Removed:
let _ = sign_in_new c in
316
Removed:
Alcotest.(check int) "home" 200 (status (get c "/")) );
317
Removed:
( "sign-out clears the session",
318
Removed:
`Quick,
319
Removed:
fun () ->
320
Removed:
let c = client () in
321
Removed:
let _ = sign_in_new c in
322
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
323
Removed:
let out = post c "/logout" [ ("dream.csrf", token) ] in
324
Removed:
Alcotest.(check int) "logout redirects" 303 (status out);
325
Removed:
(* The session is gone: the overview again bounces to sign-in. *)
326
Removed:
let after = get c "/" in
327
Removed:
Alcotest.(check int) "overview now redirects" 303 (status after);
328
Removed:
Alcotest.(check string) "to /login" "/login" (location after) );
329
Removed:
( "a form post without a CSRF token is refused and changes nothing",
330
Removed:
`Quick,
331
Removed:
fun () ->
332
Removed:
let c, repo = client_with_repo () in
333
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
334
Removed:
let response =
335
Removed:
post c "/routines/ideal/select" [ (* no dream.csrf *) ]
336
Removed:
in
337
Removed:
Alcotest.(check int)
338
Removed:
"redirects after the refused post" 303 (status response);
339
Removed:
(* No routine was selected: the refused post had no domain effect. *)
340
Removed:
let trainee = the_trainee repo ~username:"lifter" in
341
Removed:
Alcotest.(check bool)
342
Removed:
"no active routine" true
343
Removed:
(Option.is_none
344
Removed:
(Lwt_main.run
345
Removed:
(Memory_repo.active_routine repo trainee.Trainee.id))) );
346
Removed:
( "a too-short username is refused",
347
Removed:
`Quick,
348
Removed:
fun () ->
349
Removed:
let c, repo = client_with_repo () in
350
Removed:
let response = register c ~username:"abc" ~password:"heavyduty1" in
351
Removed:
Alcotest.(check int) "rejected" 400 (status response);
352
Removed:
Alcotest.(check (option string))
353
Removed:
"no account created" None
354
Removed:
(Lwt_main.run
355
Removed:
(match Trainee.username "abc" with
356
Removed:
| Ok u -> Memory_repo.find_trainee_by_username repo u
357
Removed:
| Error _ -> Lwt.return None)
358
Removed:
|> Option.map (fun t -> Trainee.id_to_string t.Trainee.id)) );
359
Removed:
( "a too-long username is refused",
360
Removed:
`Quick,
361
Removed:
fun () ->
362
Removed:
let c = client () in
363
Removed:
let response =
364
Removed:
register c ~username:"abcdefghijklmnopqrstu"
365
Removed:
~password:"heavyduty1"
366
Removed:
in
367
Removed:
Alcotest.(check int) "rejected" 400 (status response) );
368
Removed:
( "a short password is accepted (passwords carry no policy)",
369
Removed:
`Quick,
370
Removed:
fun () ->
371
Removed:
let c = client () in
372
Removed:
let response = register c ~username:"lifter" ~password:"x" in
373
Removed:
Alcotest.(check int) "registered, redirected" 303 (status response);
374
Removed:
Alcotest.(check int)
375
Removed:
"authenticated overview" 200
376
Removed:
(status (get c "/")) );
377
Removed:
( "with registration closed the register routes are absent",
378
Removed:
`Quick,
379
Removed:
fun () ->
380
Removed:
(* The production default: [registration_open] unset. *)
381
Removed:
let handlers = Handlers.make ~repo:(Memory_repo.create ()) () in
382
Removed:
let app =
383
Removed:
Dream.memory_sessions @@ Dream.router (Handlers.routes handlers)
384
Removed:
|> fun h -> Dream.set_secret "test-secret-value" h
385
Removed:
in
386
Removed:
let c = { app; jar = [] } in
387
Removed:
Alcotest.(check int)
388
Removed:
"GET /register is not found" 404
389
Removed:
(status (get c "/register"));
390
Removed:
Alcotest.(check int)
391
Removed:
"GET /login is served" 200
392
Removed:
(status (get c "/login")) );
393
Removed:
] );
394
Removed:
( "web.flow",
395
Removed:
[
396
Removed:
( "the logbook shows the action button group and an empty table state",
397
Removed:
`Quick,
398
Removed:
fun () ->
399
Removed:
let c = client () in
400
Removed:
let _ = sign_in_new c in
401
Removed:
let page = body (get c "/logbook") in
402
Removed:
Alcotest.(check bool)
403
Removed:
"Log feedback action" true
404
Removed:
(Option.is_some (index_from ~needle:"Log feedback" page 0));
405
Removed:
Alcotest.(check bool)
406
Removed:
"Edit logbook action" true
407
Removed:
(Option.is_some (index_from ~needle:"Edit logbook" page 0));
408
Removed:
Alcotest.(check bool)
409
Removed:
"the button group is present" true
410
Removed:
(Option.is_some
411
Removed:
(index_from ~needle:"class=\"button-group\"" page 0));
412
Removed:
Alcotest.(check bool)
413
Removed:
"empty state when nothing is logged" true
414
Removed:
(Option.is_some (index_from ~needle:"Nothing logged yet." page 0))
415
Removed:
);
416
Removed:
( "a finished workout appears in the logbook table with a progress \
417
Removed:
column",
418
Removed:
`Quick,
419
Removed:
fun () ->
420
Removed:
let c = client () in
421
Removed:
let _ = sign_in_new c in
422
Removed:
let _ = start_day_one c in
423
Removed:
record_all_day_one_slots c;
424
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
425
Removed:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
426
Removed:
let page = body (get c "/logbook") in
427
Removed:
Alcotest.(check bool)
428
Removed:
"the logbook table is present" true
429
Removed:
(Option.is_some
430
Removed:
(index_from ~needle:"class=\"logbook-table\"" page 0));
431
Removed:
Alcotest.(check bool)
432
Removed:
"the progressed-exercises column header" true
433
Removed:
(Option.is_some
434
Removed:
(index_from ~needle:"Exercises progressed" page 0)) );
435
Removed:
( "selecting a routine redirects and records the active routine",
436
Removed:
`Quick,
437
Removed:
fun () ->
438
Removed:
(* POST-redirect-GET: selecting a routine answers 303, and the
439
Removed:
redirected GET is served. The domain effect is what matters: the
440
Removed:
trainee now has an active routine. *)
441
Removed:
let c, repo = client_with_repo () in
442
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
443
Removed:
let trainee = the_trainee repo ~username:"lifter" in
444
Removed:
Alcotest.(check bool)
445
Removed:
"no active routine before selection" true
446
Removed:
(Option.is_none
447
Removed:
(Lwt_main.run
448
Removed:
(Memory_repo.active_routine repo trainee.Trainee.id)));
449
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
450
Removed:
let selection =
451
Removed:
post c "/routines/ideal/select" [ ("dream.csrf", token) ]
452
Removed:
in
453
Removed:
Alcotest.(check int) "selection redirects" 303 (status selection);
454
Removed:
Alcotest.(check bool)
455
Removed:
"a routine is now active" true
456
Removed:
(Option.is_some
457
Removed:
(Lwt_main.run
458
Removed:
(Memory_repo.active_routine repo trainee.Trainee.id)));
459
Removed:
(* The redirected GET is served. *)
460
Removed:
Alcotest.(check int)
461
Removed:
"the redirected GET is 200" 200
462
Removed:
(status (get c "/")) );
463
Removed:
( "a signed-in trainee selects a routine and begins a workout",
464
Removed:
`Quick,
465
Removed:
fun () ->
466
Removed:
let c, repo = client_with_repo () in
467
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
468
Removed:
let trainee = the_trainee repo ~username:"lifter" in
469
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
470
Removed:
let selection =
471
Removed:
post c "/routines/ideal/select" [ ("dream.csrf", token) ]
472
Removed:
in
473
Removed:
Alcotest.(check int) "routine selected" 303 (status selection);
474
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
475
Removed:
let started =
476
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
477
Removed:
in
478
Removed:
Alcotest.(check int) "workout started" 303 (status started);
479
Removed:
(* The workout is now in progress in the domain, and its view is
480
Removed:
served. *)
481
Removed:
Alcotest.(check bool)
482
Removed:
"a workout is in progress" true
483
Removed:
(Option.is_some
484
Removed:
(Lwt_main.run
485
Removed:
(Memory_repo.in_progress repo trainee.Trainee.id)));
486
Removed:
Alcotest.(check int)
487
Removed:
"the workout view is served" 200
488
Removed:
(status (get c "/workout"));
489
Removed:
(* The static workout client asset is served. *)
490
Removed:
let asset = get c "/assets/workout-client.js" in
491
Removed:
Alcotest.(check int) "serves the workout client" 200 (status asset)
492
Removed:
);
493
Removed:
( "the routine page is served once a routine is selected",
494
Removed:
`Quick,
495
Removed:
fun () ->
496
Removed:
let c = client () in
497
Removed:
let _ = sign_in_new c in
498
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
499
Removed:
let selection =
500
Removed:
post c "/routines/ideal/select" [ ("dream.csrf", token) ]
501
Removed:
in
502
Removed:
Alcotest.(check int) "routine selected" 303 (status selection);
503
Removed:
Alcotest.(check int)
504
Removed:
"routine page served" 200
505
Removed:
(status (get c "/routine")) );
506
Removed:
( "a recorded slot can be corrected, replacing it rather than adding \
507
Removed:
volume",
508
Removed:
`Quick,
509
Removed:
fun () ->
510
Removed:
let c, repo = client_with_repo () in
511
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
512
Removed:
let trainee = the_trainee repo ~username:"lifter" in
513
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
514
Removed:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
515
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
516
Removed:
let _ =
517
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
518
Removed:
in
519
Removed:
(* Slot 1 is the single Laterals set. Record it, then correct it —
520
Removed:
one slot at a time, addressed by [?slot=]. *)
521
Removed:
let token =
522
Removed:
Option.get (csrf_token (body (get c "/workout?slot=1")))
523
Removed:
in
524
Removed:
let recorded =
525
Removed:
post c "/workout/slots/1"
526
Removed:
[
527
Removed:
("dream.csrf", token);
528
Removed:
("load", "12");
529
Removed:
("reps", "8");
530
Removed:
("extension", "");
531
Removed:
]
532
Removed:
in
533
Removed:
Alcotest.(check int) "recorded" 303 (status recorded);
534
Removed:
let filled_after_record () =
535
Removed:
match
536
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
537
Removed:
with
538
Removed:
| Some w -> Evidence.Workout.filled_slots w
539
Removed:
| None -> Alcotest.failf "expected a workout in progress"
540
Removed:
in
541
Removed:
Alcotest.(check int) "one filled slot" 1 (filled_after_record ());
542
Removed:
let token =
543
Removed:
Option.get (csrf_token (body (get c "/workout?slot=1")))
544
Removed:
in
545
Removed:
let corrected =
546
Removed:
post c "/workout/slots/1/edit"
547
Removed:
[
548
Removed:
("dream.csrf", token);
549
Removed:
("load", "16");
550
Removed:
("reps", "6");
551
Removed:
("extension", "");
552
Removed:
]
553
Removed:
in
554
Removed:
Alcotest.(check int) "corrected" 303 (status corrected);
555
Removed:
(* A correction replaces the slot; it does not add volume. *)
556
Removed:
Alcotest.(check int)
557
Removed:
"still one filled slot, not two" 1 (filled_after_record ()) );
558
Removed:
( "a saved workout's slot can be corrected from the logbook view",
559
Removed:
`Quick,
560
Removed:
fun () ->
561
Removed:
let c, repo = client_with_repo () in
562
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
563
Removed:
let trainee = the_trainee repo ~username:"lifter" in
564
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
565
Removed:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
566
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
567
Removed:
let _ =
568
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
569
Removed:
in
570
Removed:
let token =
571
Removed:
Option.get (csrf_token (body (get c "/workout?slot=1")))
572
Removed:
in
573
Removed:
let _ =
574
Removed:
post c "/workout/slots/1"
575
Removed:
[
576
Removed:
("dream.csrf", token);
577
Removed:
("load", "12");
578
Removed:
("reps", "8");
579
Removed:
("extension", "");
580
Removed:
]
581
Removed:
in
582
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
583
Removed:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
584
Removed:
(* The one saved workout is w1 for this trainee. Correct its slot
585
Removed:
through the logbook path, then confirm the store still has one
586
Removed:
filled slot — a correction, not extra volume. *)
587
Removed:
let record_page = body (get c "/logbook/w1?slot=1") in
588
Removed:
let token = Option.get (csrf_token record_page) in
589
Removed:
let corrected =
590
Removed:
post c "/logbook/w1/slots/1/edit"
591
Removed:
[
592
Removed:
("dream.csrf", token);
593
Removed:
("load", "20");
594
Removed:
("reps", "7");
595
Removed:
("extension", "");
596
Removed:
]
597
Removed:
in
598
Removed:
Alcotest.(check int) "corrected" 303 (status corrected);
599
Removed:
let record =
600
Removed:
Lwt_main.run
601
Removed:
(Memory_repo.find repo trainee.Trainee.id
602
Removed:
(Repository.workout_id "w1"))
603
Removed:
in
604
Removed:
Alcotest.(check int)
605
Removed:
"still one filled slot" 1
606
Removed:
(match record with
607
Removed:
| Some r -> Evidence.Workout.filled_slots r.Repository.workout
608
Removed:
| None -> Alcotest.failf "expected the saved workout w1") );
609
Removed:
( "an invalid workout field is rejected and records nothing",
610
Removed:
`Quick,
611
Removed:
fun () ->
612
Removed:
let c, repo = client_with_repo () in
613
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
614
Removed:
let trainee = the_trainee repo ~username:"lifter" in
615
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
616
Removed:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
617
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
618
Removed:
let _ =
619
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
620
Removed:
in
621
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
622
Removed:
let invalid =
623
Removed:
post c "/workout/slots/0"
624
Removed:
[
625
Removed:
("dream.csrf", token);
626
Removed:
("iso_load", "not-a-number");
627
Removed:
("iso_reps", "8");
628
Removed:
("comp_load", "40");
629
Removed:
("comp_reps", "6");
630
Removed:
("extension", "");
631
Removed:
]
632
Removed:
in
633
Removed:
Alcotest.(check int) "invalid field redirects" 303 (status invalid);
634
Removed:
(* The bad input recorded no slot. *)
635
Removed:
Alcotest.(check int)
636
Removed:
"no slot was filled" 0
637
Removed:
(match
638
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
639
Removed:
with
640
Removed:
| Some w -> Evidence.Workout.filled_slots w
641
Removed:
| None -> Alcotest.failf "expected a workout in progress") );
642
Removed:
( "recording a slot advances the count of filled slots",
643
Removed:
`Quick,
644
Removed:
fun () ->
645
Removed:
let c, repo = client_with_repo () in
646
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
647
Removed:
let trainee = the_trainee repo ~username:"lifter" in
648
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
649
Removed:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
650
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
651
Removed:
let _ =
652
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
653
Removed:
in
654
Removed:
let filled () =
655
Removed:
match
656
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
657
Removed:
with
658
Removed:
| Some w -> Evidence.Workout.filled_slots w
659
Removed:
| None -> Alcotest.failf "expected a workout in progress"
660
Removed:
in
661
Removed:
Alcotest.(check int) "nothing recorded yet" 0 (filled ());
662
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
663
Removed:
let recorded =
664
Removed:
post c "/workout/slots/0"
665
Removed:
[
666
Removed:
("dream.csrf", token);
667
Removed:
("iso_load", "10");
668
Removed:
("iso_reps", "8");
669
Removed:
("comp_load", "40");
670
Removed:
("comp_reps", "6");
671
Removed:
("extension", "");
672
Removed:
]
673
Removed:
in
674
Removed:
Alcotest.(check int) "recorded slot 0" 303 (status recorded);
675
Removed:
Alcotest.(check int) "one slot filled" 1 (filled ()) );
676
Removed:
( "signing out returns the trainee to the sign-in page",
677
Removed:
`Quick,
678
Removed:
fun () ->
679
Removed:
let c = client () in
680
Removed:
let _ = sign_in_new c in
681
Removed:
let page = body (get c "/") in
682
Removed:
let token = Option.get (csrf_token page) in
683
Removed:
let out = post c "/logout" [ ("dream.csrf", token) ] in
684
Removed:
Alcotest.(check int) "logout redirect" 303 (status out);
685
Removed:
let after = get c "/" in
686
Removed:
Alcotest.(check int) "overview now redirects" 303 (status after);
687
Removed:
Alcotest.(check string) "to /login" "/login" (location after) );
688
Removed:
( "cancelling a workout without a CSRF token leaves it in progress",
689
Removed:
`Quick,
690
Removed:
fun () ->
691
Removed:
let c, repo = client_with_repo () in
692
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
693
Removed:
let trainee = the_trainee repo ~username:"lifter" in
694
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
695
Removed:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
696
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
697
Removed:
let _ =
698
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
699
Removed:
in
700
Removed:
let response = post c "/workout/cancel" [ (* no dream.csrf *) ] in
701
Removed:
(* Cancelling always navigates away to Home. A forged or missing
702
Removed:
token skips the discard, so the workout remains in progress. *)
703
Removed:
Alcotest.(check int)
704
Removed:
"navigates away without an error page" 303 (status response);
705
Removed:
Alcotest.(check bool)
706
Removed:
"returns Home" true
707
Removed:
(List.mem "/" (Dream.headers response "Location"));
708
Removed:
Alcotest.(check bool)
709
Removed:
"workout still in progress" true
710
Removed:
(Option.is_some
711
Removed:
(Lwt_main.run
712
Removed:
(Memory_repo.in_progress repo trainee.Trainee.id))) );
713
Removed:
( "cancelling after recording a set discards the workout entirely",
714
Removed:
`Quick,
715
Removed:
fun () ->
716
Removed:
let c, repo = client_with_repo () in
717
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
718
Removed:
let trainee = the_trainee repo ~username:"lifter" in
719
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
720
Removed:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
721
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
722
Removed:
let _ =
723
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
724
Removed:
in
725
Removed:
let token =
726
Removed:
Option.get (csrf_token (body (get c "/workout?slot=1")))
727
Removed:
in
728
Removed:
let recorded =
729
Removed:
post c "/workout/slots/1"
730
Removed:
[
731
Removed:
("dream.csrf", token);
732
Removed:
("load", "12");
733
Removed:
("reps", "8");
734
Removed:
("extension", "");
735
Removed:
]
736
Removed:
in
737
Removed:
Alcotest.(check int) "recorded a set" 303 (status recorded);
738
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
739
Removed:
let cancelled =
740
Removed:
post c "/workout/cancel" [ ("dream.csrf", token) ]
741
Removed:
in
742
Removed:
Alcotest.(check int) "cancel returns Home" 303 (status cancelled);
743
Removed:
Alcotest.(check bool)
744
Removed:
"returns Home, not the logbook" true
745
Removed:
(List.mem "/" (Dream.headers cancelled "Location"));
746
Removed:
(* No current workout, and no record: an abandoned session is not
747
Removed:
evidence. *)
748
Removed:
Alcotest.(check bool)
749
Removed:
"no workout in progress" true
750
Removed:
(Option.is_none
751
Removed:
(Lwt_main.run
752
Removed:
(Memory_repo.in_progress repo trainee.Trainee.id)));
753
Removed:
Alcotest.(check int)
754
Removed:
"history is empty" 0
755
Removed:
(List.length
756
Removed:
(Lwt_main.run (Memory_repo.history repo trainee.Trainee.id)));
757
Removed:
Alcotest.(check int)
758
Removed:
"the discarded workout has no record" 404
759
Removed:
(status (get c "/logbook/w1")) );
760
Removed:
( "sequential feedback stores only answered factors, never skipped ones",
761
Removed:
`Quick,
762
Removed:
fun () ->
763
Removed:
let c, repo = client_with_repo () in
764
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
765
Removed:
let trainee = the_trainee repo ~username:"lifter" in
766
Removed:
let _ = get c "/logbook?feedback=start" in
767
Removed:
let step_action step action extra =
768
Removed:
let token = Option.get (csrf_token (body (get c "/logbook"))) in
769
Removed:
post c "/feedback"
770
Removed:
(("dream.csrf", token)
771
Removed:
:: ("step", string_of_int step)
772
Removed:
:: ("action", action) :: extra)
773
Removed:
in
774
Removed:
let first = step_action 0 "next" [ ("choice", "better") ] in
775
Removed:
Alcotest.(check int) "first factor redirects" 303 (status first);
776
Removed:
let _ = step_action 1 "skip" [] in
777
Removed:
let saved = step_action 2 "save" [] in
778
Removed:
Alcotest.(check int) "final feedback redirects" 303 (status saved);
779
Removed:
let reports =
780
Removed:
Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)
781
Removed:
in
782
Removed:
Alcotest.(check int)
783
Removed:
"one feedback report stored" 1 (List.length reports);
784
Removed:
let signal_list = Feedback.signals (List.hd reports) in
785
Removed:
Alcotest.(check (list bool))
786
Removed:
"only motivation stored" [ true ]
787
Removed:
(List.map
788
Removed:
(function
789
Removed:
| Feedback.Motivation Feedback.Better_than_usual -> true
790
Removed:
| _ -> false)
791
Removed:
signal_list) );
792
Removed:
( "skipping the entire feedback flow records nothing",
793
Removed:
`Quick,
794
Removed:
fun () ->
795
Removed:
let c, repo = client_with_repo () in
796
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
797
Removed:
let trainee = the_trainee repo ~username:"lifter" in
798
Removed:
let start = body (get c "/logbook?feedback=start") in
799
Removed:
let token = Option.get (csrf_token start) in
800
Removed:
let skipped = post c "/feedback/cancel" [ ("dream.csrf", token) ] in
801
Removed:
Alcotest.(check int) "full-flow skip redirects" 303 (status skipped);
802
Removed:
Alcotest.(check int)
803
Removed:
"no feedback report was stored" 0
804
Removed:
(List.length
805
Removed:
(Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)))
806
Removed:
);
807
Removed:
( "back keeps an earlier answer, which still persists on save",
808
Removed:
`Quick,
809
Removed:
fun () ->
810
Removed:
let c, repo = client_with_repo () in
811
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
812
Removed:
let trainee = the_trainee repo ~username:"lifter" in
813
Removed:
let _ = get c "/logbook?feedback=start" in
814
Removed:
let step_action step action extra =
815
Removed:
let token = Option.get (csrf_token (body (get c "/logbook"))) in
816
Removed:
post c "/feedback"
817
Removed:
(("dream.csrf", token)
818
Removed:
:: ("step", string_of_int step)
819
Removed:
:: ("action", action) :: extra)
820
Removed:
in
821
Removed:
(* Answer motivation, move to difficulty, return, then skip
822
Removed:
motivation and difficulty before saving. The earlier motivation
823
Removed:
answer remains in the flow. *)
824
Removed:
let _ = step_action 0 "next" [ ("choice", "better") ] in
825
Removed:
let back = step_action 1 "back" [] in
826
Removed:
Alcotest.(check int) "back redirects" 303 (status back);
827
Removed:
let _ = step_action 0 "skip" [] in
828
Removed:
let _ = step_action 1 "skip" [] in
829
Removed:
let _ = step_action 2 "save" [] in
830
Removed:
let reports =
831
Removed:
Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)
832
Removed:
in
833
Removed:
Alcotest.(check int) "one report stored" 1 (List.length reports);
834
Removed:
let signals = Feedback.signals (List.hd reports) in
835
Removed:
Alcotest.(check bool)
836
Removed:
"the pre-back motivation answer persists" true
837
Removed:
(List.exists
838
Removed:
(function
839
Removed:
| Feedback.Motivation Feedback.Better_than_usual -> true
840
Removed:
| _ -> false)
841
Removed:
signals) );
842
Removed:
( "closing the feedback modal discards the flow",
843
Removed:
`Quick,
844
Removed:
fun () ->
845
Removed:
let c, repo = client_with_repo () in
846
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
847
Removed:
let trainee = the_trainee repo ~username:"lifter" in
848
Removed:
let start = body (get c "/logbook?feedback=start") in
849
Removed:
let token = Option.get (csrf_token start) in
850
Removed:
let _ =
851
Removed:
post c "/feedback"
852
Removed:
[
853
Removed:
("dream.csrf", token);
854
Removed:
("step", "0");
855
Removed:
("action", "next");
856
Removed:
("choice", "better");
857
Removed:
]
858
Removed:
in
859
Removed:
let appetite = body (get c "/logbook") in
860
Removed:
let token = Option.get (csrf_token appetite) in
861
Removed:
let closed = post c "/feedback/cancel" [ ("dream.csrf", token) ] in
862
Removed:
Alcotest.(check int) "close redirects" 303 (status closed);
863
Removed:
(* A discarded flow stores nothing. *)
864
Removed:
Alcotest.(check int)
865
Removed:
"no feedback report stored" 0
866
Removed:
(List.length
867
Removed:
(Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)))
868
Removed:
);
869
Removed:
( "finishing a workout redirects to the logbook feedback prompt",
870
Removed:
`Quick,
871
Removed:
fun () ->
872
Removed:
let c, repo = client_with_repo () in
873
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
874
Removed:
let trainee = the_trainee repo ~username:"lifter" in
875
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
876
Removed:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
877
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
878
Removed:
let _ =
879
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
880
Removed:
in
881
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
882
Removed:
let finished = post c "/workout/finish" [ ("dream.csrf", token) ] in
883
Removed:
Alcotest.(check int) "finish redirects" 303 (status finished);
884
Removed:
Alcotest.(check bool)
885
Removed:
"redirects to the logbook with a feedback prompt" true
886
Removed:
(List.mem "/logbook?prompt=feedback"
887
Removed:
(Dream.headers finished "Location"));
888
Removed:
(* The workout is now in history and no longer in progress. *)
889
Removed:
Alcotest.(check int)
890
Removed:
"one workout in history" 1
891
Removed:
(List.length
892
Removed:
(Lwt_main.run (Memory_repo.history repo trainee.Trainee.id)));
893
Removed:
Alcotest.(check bool)
894
Removed:
"nothing in progress" true
895
Removed:
(Option.is_none
896
Removed:
(Lwt_main.run
897
Removed:
(Memory_repo.in_progress repo trainee.Trainee.id))) );
898
Removed:
( "beginning before recovery is refused without an override",
899
Removed:
`Quick,
900
Removed:
fun () ->
901
Removed:
let c, repo = client_with_repo () in
902
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
903
Removed:
let trainee = the_trainee repo ~username:"lifter" in
904
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
905
Removed:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
906
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
907
Removed:
let _ =
908
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
909
Removed:
in
910
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
911
Removed:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
912
Removed:
(* Recovery has not elapsed. Beginning the next workout without an
913
Removed:
override is bounced back to Home and starts nothing. *)
914
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
915
Removed:
let refused =
916
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
917
Removed:
in
918
Removed:
Alcotest.(check int) "early begin bounced" 303 (status refused);
919
Removed:
Alcotest.(check bool)
920
Removed:
"returns Home, not the workout" true
921
Removed:
(List.mem "/" (Dream.headers refused "Location"));
922
Removed:
Alcotest.(check bool)
923
Removed:
"no new workout in progress" true
924
Removed:
(Option.is_none
925
Removed:
(Lwt_main.run
926
Removed:
(Memory_repo.in_progress repo trainee.Trainee.id))) );
927
Removed:
( "overriding recovery begins the next workout on an override basis",
928
Removed:
`Quick,
929
Removed:
fun () ->
930
Removed:
let c, repo = client_with_repo () in
931
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
932
Removed:
let trainee = the_trainee repo ~username:"lifter" in
933
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
934
Removed:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
935
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
936
Removed:
let _ =
937
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
938
Removed:
in
939
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
940
Removed:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
941
Removed:
(* Recovery has not elapsed, so the next workout is begun under an
942
Removed:
explicit override. The deviation is recorded on the workout's
943
Removed:
clearance basis, never silent. *)
944
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
945
Removed:
let began =
946
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "true") ]
947
Removed:
in
948
Removed:
Alcotest.(check int) "override begin succeeds" 303 (status began);
949
Removed:
let basis =
950
Removed:
match
951
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
952
Removed:
with
953
Removed:
| Some w -> Recovery.basis (Evidence.Workout.clearance w)
954
Removed:
| None -> Alcotest.failf "expected a workout in progress"
955
Removed:
in
956
Removed:
Alcotest.(check bool)
957
Removed:
"the workout carries an override basis" true
958
Removed:
(match basis with Recovery.Overridden _ -> true | _ -> false) );
959
Removed:
] );
960
Removed:
( "web.app_feedback",
961
Removed:
[
962
Removed:
( "the app feedback screen and its tabs are served",
963
Removed:
`Quick,
964
Removed:
fun () ->
965
Removed:
let c = client () in
966
Removed:
let _ = sign_in_new c in
967
Removed:
Alcotest.(check int)
968
Removed:
"write tab served" 200
969
Removed:
(status (get c "/app-feedback"));
970
Removed:
Alcotest.(check int)
971
Removed:
"submitted tab served" 200
972
Removed:
(status (get c "/app-feedback?tab=submitted")) );
973
Removed:
( "blank app feedback is refused; a real message is stored",
974
Removed:
`Quick,
975
Removed:
fun () ->
976
Removed:
let c, repo = client_with_repo () in
977
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
978
Removed:
let trainee = the_trainee repo ~username:"lifter" in
979
Removed:
let stored_count () =
980
Removed:
List.length
981
Removed:
(Lwt_main.run
982
Removed:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id))
983
Removed:
in
984
Removed:
let token =
985
Removed:
Option.get (csrf_token (body (get c "/app-feedback")))
986
Removed:
in
987
Removed:
let blank =
988
Removed:
post c "/app-feedback/submit"
989
Removed:
[ ("dream.csrf", token); ("message", " ") ]
990
Removed:
in
991
Removed:
Alcotest.(check int) "blank message redirects" 303 (status blank);
992
Removed:
Alcotest.(check bool)
993
Removed:
"redirects to the write tab" true
994
Removed:
(List.mem "/app-feedback?tab=write"
995
Removed:
(Dream.headers blank "Location"));
996
Removed:
(* Blank input stored nothing. *)
997
Removed:
Alcotest.(check int)
998
Removed:
"no report stored for blank input" 0 (stored_count ());
999
Removed:
let token =
1000
Removed:
Option.get (csrf_token (body (get c "/app-feedback")))
1001
Removed:
in
1002
Removed:
let submitted =
1003
Removed:
post c "/app-feedback/submit"
1004
Removed:
[
1005
Removed:
("dream.csrf", token);
1006
Removed:
("message", "The app is clear.\nThank you!");
1007
Removed:
]
1008
Removed:
in
1009
Removed:
Alcotest.(check int) "message is accepted" 303 (status submitted);
1010
Removed:
Alcotest.(check bool)
1011
Removed:
"redirects to submitted feedback" true
1012
Removed:
(List.mem "/app-feedback?tab=submitted"
1013
Removed:
(Dream.headers submitted "Location"));
1014
Removed:
(* The report now exists with the exact message. *)
1015
Removed:
let reports =
1016
Removed:
Lwt_main.run
1017
Removed:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)
1018
Removed:
in
1019
Removed:
Alcotest.(check int) "one report stored" 1 (List.length reports);
1020
Removed:
Alcotest.(check string)
1021
Removed:
"stores the exact message" "The app is clear.\nThank you!"
1022
Removed:
(List.hd reports).Repository.message );
1023
Removed:
( "feedback records its author and accepts another trainee's vote",
1024
Removed:
`Quick,
1025
Removed:
fun () ->
1026
Removed:
let alice = client () in
1027
Removed:
let _ = register alice ~username:"alice" ~password:"heavyduty1" in
1028
Removed:
let bob = { alice with jar = [] } in
1029
Removed:
let _ = register bob ~username:"bobby" ~password:"heavyduty1" in
1030
Removed:
let submit client message =
1031
Removed:
let token =
1032
Removed:
Option.get (csrf_token (body (get client "/app-feedback")))
1033
Removed:
in
1034
Removed:
post client "/app-feedback/submit"
1035
Removed:
[ ("dream.csrf", token); ("message", message) ]
1036
Removed:
in
1037
Removed:
Alcotest.(check int)
1038
Removed:
"alice feedback accepted" 303
1039
Removed:
(status (submit alice "Alice report"));
1040
Removed:
Alcotest.(check int)
1041
Removed:
"bob feedback accepted" 303
1042
Removed:
(status (submit bob "Bob report"));
1043
Removed:
(* Bob's report is t2:1 — the vote control on Alice's view posts
1044
Removed:
there. Alice upvotes it. *)
1045
Removed:
let list_page = body (get alice "/app-feedback?tab=submitted") in
1046
Removed:
let token = Option.get (csrf_token list_page) in
1047
Removed:
let voted =
1048
Removed:
post alice "/app-feedback/t2:1/upvote" [ ("dream.csrf", token) ]
1049
Removed:
in
1050
Removed:
Alcotest.(check int) "upvote redirects" 303 (status voted) );
1051
Removed:
( "an owner can edit and remove their feedback",
1052
Removed:
`Quick,
1053
Removed:
fun () ->
1054
Removed:
let c, repo = client_with_repo () in
1055
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1056
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1057
Removed:
let token =
1058
Removed:
Option.get (csrf_token (body (get c "/app-feedback")))
1059
Removed:
in
1060
Removed:
let _ =
1061
Removed:
post c "/app-feedback/submit"
1062
Removed:
[ ("dream.csrf", token); ("message", "First report") ]
1063
Removed:
in
1064
Removed:
let feedback_id () =
1065
Removed:
(List.hd
1066
Removed:
(Lwt_main.run
1067
Removed:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
1068
Removed:
.Repository.feedback_id |> Repository.app_feedback_id_to_string
1069
Removed:
in
1070
Removed:
let id = feedback_id () in
1071
Removed:
(* A blank edit is refused and changes nothing. *)
1072
Removed:
let token =
1073
Removed:
Option.get
1074
Removed:
(csrf_token (body (get c "/app-feedback?tab=submitted")))
1075
Removed:
in
1076
Removed:
let blank =
1077
Removed:
post c
1078
Removed:
("/app-feedback/" ^ id ^ "/edit")
1079
Removed:
[ ("dream.csrf", token); ("message", " ") ]
1080
Removed:
in
1081
Removed:
Alcotest.(check int) "blank edit redirects" 303 (status blank);
1082
Removed:
Alcotest.(check string)
1083
Removed:
"message unchanged by blank edit" "First report"
1084
Removed:
(List.hd
1085
Removed:
(Lwt_main.run
1086
Removed:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
1087
Removed:
.Repository.message;
1088
Removed:
(* A real edit changes the stored message. *)
1089
Removed:
let token =
1090
Removed:
Option.get
1091
Removed:
(csrf_token (body (get c "/app-feedback?tab=submitted")))
1092
Removed:
in
1093
Removed:
let edited =
1094
Removed:
post c
1095
Removed:
("/app-feedback/" ^ id ^ "/edit")
1096
Removed:
[ ("dream.csrf", token); ("message", "Edited report") ]
1097
Removed:
in
1098
Removed:
Alcotest.(check int) "edit redirects" 303 (status edited);
1099
Removed:
Alcotest.(check string)
1100
Removed:
"message updated by edit" "Edited report"
1101
Removed:
(List.hd
1102
Removed:
(Lwt_main.run
1103
Removed:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
1104
Removed:
.Repository.message;
1105
Removed:
(* Removal deletes the report. *)
1106
Removed:
let token =
1107
Removed:
Option.get
1108
Removed:
(csrf_token (body (get c "/app-feedback?tab=submitted")))
1109
Removed:
in
1110
Removed:
let removed =
1111
Removed:
post c
1112
Removed:
("/app-feedback/" ^ id ^ "/remove")
1113
Removed:
[ ("dream.csrf", token) ]
1114
Removed:
in
1115
Removed:
Alcotest.(check int) "remove redirects" 303 (status removed);
1116
Removed:
Alcotest.(check int)
1117
Removed:
"report removed" 0
1118
Removed:
(List.length
1119
Removed:
(Lwt_main.run
1120
Removed:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
1121
Removed:
);
1122
Removed:
( "another trainee cannot edit or remove app feedback",
1123
Removed:
`Quick,
1124
Removed:
fun () ->
1125
Removed:
let alice, repo = client_with_repo () in
1126
Removed:
let _ = register alice ~username:"alice" ~password:"heavyduty1" in
1127
Removed:
let bob = { alice with jar = [] } in
1128
Removed:
let _ = register bob ~username:"bobby" ~password:"heavyduty1" in
1129
Removed:
let bob_trainee = the_trainee repo ~username:"bobby" in
1130
Removed:
(* Bob owns t2:1. Alice attempts to edit and remove it. Both are
1131
Removed:
refused at the ownership check, so the report and its message
1132
Removed:
survive. *)
1133
Removed:
let token =
1134
Removed:
Option.get (csrf_token (body (get bob "/app-feedback")))
1135
Removed:
in
1136
Removed:
let _ =
1137
Removed:
post bob "/app-feedback/submit"
1138
Removed:
[ ("dream.csrf", token); ("message", "Bob owns this") ]
1139
Removed:
in
1140
Removed:
let stored () =
1141
Removed:
Lwt_main.run
1142
Removed:
(Memory_repo.app_feedback repo ~viewer:bob_trainee.Trainee.id)
1143
Removed:
in
1144
Removed:
Alcotest.(check int)
1145
Removed:
"one report before cross-user attempts" 1
1146
Removed:
(List.length (stored ()));
1147
Removed:
let token =
1148
Removed:
Option.get
1149
Removed:
(csrf_token (body (get alice "/app-feedback?tab=submitted")))
1150
Removed:
in
1151
Removed:
let edited =
1152
Removed:
post alice "/app-feedback/t2:1/edit"
1153
Removed:
[ ("dream.csrf", token); ("message", "Taken over") ]
1154
Removed:
in
1155
Removed:
Alcotest.(check int) "cross-user edit redirects" 303 (status edited);
1156
Removed:
let token =
1157
Removed:
Option.get
1158
Removed:
(csrf_token (body (get alice "/app-feedback?tab=submitted")))
1159
Removed:
in
1160
Removed:
let removed =
1161
Removed:
post alice "/app-feedback/t2:1/remove" [ ("dream.csrf", token) ]
1162
Removed:
in
1163
Removed:
Alcotest.(check int)
1164
Removed:
"cross-user remove redirects" 303 (status removed);
1165
Removed:
(* The report still exists with its original message: the cross-user
1166
Removed:
attempts changed nothing. *)
1167
Removed:
let after = stored () in
1168
Removed:
Alcotest.(check int)
1169
Removed:
"report survives cross-user attempts" 1 (List.length after);
1170
Removed:
Alcotest.(check string)
1171
Removed:
"message is unchanged" "Bob owns this"
1172
Removed:
(List.hd after).Repository.message );
1173
Removed:
] );
1174
Removed:
( "web.profile",
1175
Removed:
[
1176
Removed:
( "the profile page is served for a signed-in trainee",
1177
Removed:
`Quick,
1178
Removed:
fun () ->
1179
Removed:
let c = client () in
1180
Removed:
let _ = sign_in_new c in
1181
Removed:
Alcotest.(check int)
1182
Removed:
"profile served" 200
1183
Removed:
(status (get c "/profile")) );
1184
Removed:
( "changing the username updates the stored account",
1185
Removed:
`Quick,
1186
Removed:
fun () ->
1187
Removed:
let c, repo = client_with_repo () in
1188
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1189
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1190
Removed:
let token = Option.get (csrf_token (body (get c "/profile"))) in
1191
Removed:
let changed =
1192
Removed:
post c "/profile/username"
1193
Removed:
[ ("dream.csrf", token); ("username", "athlete") ]
1194
Removed:
in
1195
Removed:
Alcotest.(check int)
1196
Removed:
"redirects after the change" 303 (status changed);
1197
Removed:
Alcotest.(check bool)
1198
Removed:
"redirects back to the profile with a notice" true
1199
Removed:
(List.mem "/profile?changed=username"
1200
Removed:
(Dream.headers changed "Location"));
1201
Removed:
(* The account now answers to the new name, and no longer to the
1202
Removed:
old one. *)
1203
Removed:
let renamed =
1204
Removed:
Lwt_main.run (Memory_repo.find_trainee repo trainee.Trainee.id)
1205
Removed:
in
1206
Removed:
Alcotest.(check (option string))
1207
Removed:
"stored under the new username" (Some "athlete")
1208
Removed:
(Option.map
1209
Removed:
(fun t -> Trainee.username_to_string t.Trainee.username)
1210
Removed:
renamed);
1211
Removed:
Alcotest.(check bool)
1212
Removed:
"old name no longer resolves" true
1213
Removed:
(Option.is_none
1214
Removed:
(Lwt_main.run
1215
Removed:
(match Trainee.username "lifter" with
1216
Removed:
| Ok u -> Memory_repo.find_trainee_by_username repo u
1217
Removed:
| Error _ -> Lwt.return None))) );
1218
Removed:
( "a taken username is refused and the account keeps its name",
1219
Removed:
`Quick,
1220
Removed:
fun () ->
1221
Removed:
let c, repo = client_with_repo () in
1222
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1223
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1224
Removed:
(* Register a second account in the same store. *)
1225
Removed:
let other = { c with jar = [] } in
1226
Removed:
let _ = register other ~username:"taken" ~password:"heavyduty1" in
1227
Removed:
let token = Option.get (csrf_token (body (get c "/profile"))) in
1228
Removed:
let refused =
1229
Removed:
post c "/profile/username"
1230
Removed:
[ ("dream.csrf", token); ("username", "taken") ]
1231
Removed:
in
1232
Removed:
Alcotest.(check int)
1233
Removed:
"renders an invalid response" 400 (status refused);
1234
Removed:
(* The account still holds its original name. *)
1235
Removed:
Alcotest.(check (option string))
1236
Removed:
"name unchanged after refusal" (Some "lifter")
1237
Removed:
(Option.map
1238
Removed:
(fun t -> Trainee.username_to_string t.Trainee.username)
1239
Removed:
(Lwt_main.run
1240
Removed:
(Memory_repo.find_trainee repo trainee.Trainee.id))) );
1241
Removed:
( "changing the password requires the current one",
1242
Removed:
`Quick,
1243
Removed:
fun () ->
1244
Removed:
let c = client () in
1245
Removed:
let _ = sign_in_new c in
1246
Removed:
let token = Option.get (csrf_token (body (get c "/profile"))) in
1247
Removed:
let refused =
1248
Removed:
post c "/profile/password"
1249
Removed:
[
1250
Removed:
("dream.csrf", token);
1251
Removed:
("current", "wrongpass");
1252
Removed:
("next", "newsecret1");
1253
Removed:
]
1254
Removed:
in
1255
Removed:
Alcotest.(check int)
1256
Removed:
"renders an invalid response" 400 (status refused);
1257
Removed:
(* Now change it with the correct current password. *)
1258
Removed:
let token = Option.get (csrf_token (body (get c "/profile"))) in
1259
Removed:
let changed =
1260
Removed:
post c "/profile/password"
1261
Removed:
[
1262
Removed:
("dream.csrf", token);
1263
Removed:
("current", "heavyduty1");
1264
Removed:
("next", "newsecret1");
1265
Removed:
]
1266
Removed:
in
1267
Removed:
Alcotest.(check int)
1268
Removed:
"redirects after the change" 303 (status changed);
1269
Removed:
Alcotest.(check bool)
1270
Removed:
"redirects back to the profile with a notice" true
1271
Removed:
(List.mem "/profile?changed=password"
1272
Removed:
(Dream.headers changed "Location"));
1273
Removed:
(* The new password now authenticates and the old one no longer
1274
Removed:
does. Sign out, then prove the change through the sign-in flow. *)
1275
Removed:
let token = Option.get (csrf_token (body (get c "/profile"))) in
1276
Removed:
let _ = post c "/logout" [ ("dream.csrf", token) ] in
1277
Removed:
let old_pw = sign_in c ~username:"lifter" ~password:"heavyduty1" in
1278
Removed:
Alcotest.(check int)
1279
Removed:
"the old password no longer works" 401 (status old_pw);
1280
Removed:
let new_pw = sign_in c ~username:"lifter" ~password:"newsecret1" in
1281
Removed:
Alcotest.(check int)
1282
Removed:
"the new password authenticates" 303 (status new_pw) );
1283
Removed:
( "the settings page is separate from the profile page",
1284
Removed:
`Quick,
1285
Removed:
fun () ->
1286
Removed:
let c = client () in
1287
Removed:
let _ = sign_in_new c in
1288
Removed:
Alcotest.(check int)
1289
Removed:
"settings served" 200
1290
Removed:
(status (get c "/settings"));
1291
Removed:
Alcotest.(check int)
1292
Removed:
"profile served separately" 200
1293
Removed:
(status (get c "/profile")) );
1294
Removed:
( "the settings theme form redirects after a valid update",
1295
Removed:
`Quick,
1296
Removed:
fun () ->
1297
Removed:
let c = client () in
1298
Removed:
let _ = sign_in_new c in
1299
Removed:
let token = Option.get (csrf_token (body (get c "/settings"))) in
1300
Removed:
let updated =
1301
Removed:
post c "/settings/theme"
1302
Removed:
[ ("dream.csrf", token); ("theme", "dark") ]
1303
Removed:
in
1304
Removed:
Alcotest.(check int) "theme update redirects" 303 (status updated);
1305
Removed:
Alcotest.(check string)
1306
Removed:
"returns to settings" "/settings"
1307
Removed:
(List.hd (Dream.headers updated "Location")) );
1308
Removed:
] );
1309
Removed:
( "web.errors",
1310
Removed:
[
1311
Removed:
( "an unknown path responds 404",
1312
Removed:
`Quick,
1313
Removed:
fun () ->
1314
Removed:
let c = client () in
1315
Removed:
let _ = sign_in_new c in
1316
Removed:
Alcotest.(check int)
1317
Removed:
"responds 404" 404
1318
Removed:
(status (get c "/no-such-page")) );
1319
Removed:
( "the 404 response never depends on a session",
1320
Removed:
`Quick,
1321
Removed:
fun () ->
1322
Removed:
let c = client () in
1323
Removed:
Alcotest.(check int)
1324
Removed:
"unauthenticated 404" 404
1325
Removed:
(status (get c "/deep/unknown/path")) );
1326
Removed:
] );
1327
Removed:
( "web.sign_in",
1328
Removed:
[
1329
Removed:
( "a returning trainee signs in with their credentials",
1330
Removed:
`Quick,
1331
Removed:
fun () ->
1332
Removed:
(* Register, then sign out, then sign back in through the credential
1333
Removed:
form. This exercises [POST /login], which registration's
1334
Removed:
auto-sign-in never touches. *)
1335
Removed:
let c = client () in
1336
Removed:
let _ = sign_in_new c in
1337
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
1338
Removed:
let _ = post c "/logout" [ ("dream.csrf", token) ] in
1339
Removed:
Alcotest.(check int)
1340
Removed:
"signed out, overview redirects" 303
1341
Removed:
(status (get c "/"));
1342
Removed:
let signed_in =
1343
Removed:
sign_in c ~username:"lifter" ~password:"heavyduty1"
1344
Removed:
in
1345
Removed:
Alcotest.(check int) "sign-in redirects" 303 (status signed_in);
1346
Removed:
Alcotest.(check bool)
1347
Removed:
"sign-in lands on Home" true
1348
Removed:
(List.mem "/" (Dream.headers signed_in "Location"));
1349
Removed:
Alcotest.(check int)
1350
Removed:
"authenticated overview" 200
1351
Removed:
(status (get c "/")) );
1352
Removed:
( "a wrong password is refused and establishes no session",
1353
Removed:
`Quick,
1354
Removed:
fun () ->
1355
Removed:
let c = client () in
1356
Removed:
let _ = sign_in_new c in
1357
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
1358
Removed:
let _ = post c "/logout" [ ("dream.csrf", token) ] in
1359
Removed:
let refused =
1360
Removed:
sign_in c ~username:"lifter" ~password:"not-the-password"
1361
Removed:
in
1362
Removed:
Alcotest.(check int) "rejected" 401 (status refused);
1363
Removed:
(* The rejected attempt establishes no session. *)
1364
Removed:
Alcotest.(check int)
1365
Removed:
"still unauthenticated" 303
1366
Removed:
(status (get c "/")) );
1367
Removed:
( "an unknown username is refused like a wrong password",
1368
Removed:
`Quick,
1369
Removed:
fun () ->
1370
Removed:
let c = client () in
1371
Removed:
let refused = sign_in c ~username:"nobody" ~password:"heavyduty1" in
1372
Removed:
Alcotest.(check int) "rejected" 401 (status refused);
1373
Removed:
Alcotest.(check int)
1374
Removed:
"no session established" 303
1375
Removed:
(status (get c "/")) );
1376
Removed:
( "an already-authenticated visit to the sign-in page redirects Home",
1377
Removed:
`Quick,
1378
Removed:
fun () ->
1379
Removed:
let c = client () in
1380
Removed:
let _ = sign_in_new c in
1381
Removed:
let response = get c "/login" in
1382
Removed:
Alcotest.(check int) "redirects" 303 (status response);
1383
Removed:
Alcotest.(check bool)
1384
Removed:
"sends an authenticated visitor Home" true
1385
Removed:
(List.mem "/" (Dream.headers response "Location")) );
1386
Removed:
( "an already-authenticated visit to the register page redirects Home",
1387
Removed:
`Quick,
1388
Removed:
fun () ->
1389
Removed:
let c = client () in
1390
Removed:
let _ = sign_in_new c in
1391
Removed:
let response = get c "/register" in
1392
Removed:
Alcotest.(check int) "redirects" 303 (status response);
1393
Removed:
Alcotest.(check bool)
1394
Removed:
"sends an authenticated visitor Home" true
1395
Removed:
(List.mem "/" (Dream.headers response "Location")) );
1396
Removed:
] );
1397
Removed:
( "web.routine_selection",
1398
Removed:
[
1399
Removed:
( "selecting an unknown routine is not found and selects nothing",
1400
Removed:
`Quick,
1401
Removed:
fun () ->
1402
Removed:
let c, repo = client_with_repo () in
1403
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1404
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1405
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
1406
Removed:
let response =
1407
Removed:
post c "/routines/no-such-routine/select"
1408
Removed:
[ ("dream.csrf", token) ]
1409
Removed:
in
1410
Removed:
Alcotest.(check int) "responds 404" 404 (status response);
1411
Removed:
(* A missing routine leaves the trainee with no active routine. *)
1412
Removed:
Alcotest.(check bool)
1413
Removed:
"no routine was selected" true
1414
Removed:
(Option.is_none
1415
Removed:
(Lwt_main.run
1416
Removed:
(Memory_repo.active_routine repo trainee.Trainee.id))) );
1417
Removed:
] );
1418
Removed:
( "web.saved_record_add",
1419
Removed:
[
1420
Removed:
( "an outstanding slot of a saved workout can be recorded, not only \
1421
Removed:
corrected",
1422
Removed:
`Quick,
1423
Removed:
fun () ->
1424
Removed:
(* Finish a workout with a single slot recorded, so the saved record
1425
Removed:
still has outstanding slots. Then record one of those through the
1426
Removed:
plain add path [POST /logbook/:id/slots/:d], which the edit tests
1427
Removed:
never exercise. *)
1428
Removed:
let c, repo = client_with_repo () in
1429
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1430
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1431
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
1432
Removed:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
1433
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
1434
Removed:
let _ =
1435
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
1436
Removed:
in
1437
Removed:
(* Record only slot 1, then finish. Slots 0, 2, 3 stay outstanding. *)
1438
Removed:
let token =
1439
Removed:
Option.get (csrf_token (body (get c "/workout?slot=1")))
1440
Removed:
in
1441
Removed:
let _ =
1442
Removed:
post c "/workout/slots/1"
1443
Removed:
[
1444
Removed:
("dream.csrf", token);
1445
Removed:
("load", "12");
1446
Removed:
("reps", "8");
1447
Removed:
("extension", "");
1448
Removed:
]
1449
Removed:
in
1450
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
1451
Removed:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
1452
Removed:
let filled_of_w1 () =
1453
Removed:
match
1454
Removed:
Lwt_main.run
1455
Removed:
(Memory_repo.find repo trainee.Trainee.id
1456
Removed:
(Repository.workout_id "w1"))
1457
Removed:
with
1458
Removed:
| Some r -> Evidence.Workout.filled_slots r.Repository.workout
1459
Removed:
| None -> Alcotest.failf "expected the saved workout w1"
1460
Removed:
in
1461
Removed:
Alcotest.(check int)
1462
Removed:
"saved workout starts with one slot" 1 (filled_of_w1 ());
1463
Removed:
(* Add slot 2 through the non-edit path. *)
1464
Removed:
let token =
1465
Removed:
Option.get (csrf_token (body (get c "/logbook/w1?slot=2")))
1466
Removed:
in
1467
Removed:
let added =
1468
Removed:
post c "/logbook/w1/slots/2"
1469
Removed:
[
1470
Removed:
("dream.csrf", token);
1471
Removed:
("load", "10");
1472
Removed:
("reps", "9");
1473
Removed:
("extension", "");
1474
Removed:
]
1475
Removed:
in
1476
Removed:
Alcotest.(check int)
1477
Removed:
"recorded a saved-workout slot" 303 (status added);
1478
Removed:
Alcotest.(check int) "now two filled slots" 2 (filled_of_w1 ()) );
1479
Removed:
( "recording an already-filled slot through the add path is refused",
1480
Removed:
`Quick,
1481
Removed:
fun () ->
1482
Removed:
(* The add path lists only outstanding slots. A filled slot is not
1483
Removed:
awaiting a record, so posting to it is a 404, not a silent second
1484
Removed:
entry that would add volume. *)
1485
Removed:
let c, repo = client_with_repo () in
1486
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1487
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1488
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
1489
Removed:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
1490
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
1491
Removed:
let _ =
1492
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
1493
Removed:
in
1494
Removed:
let token =
1495
Removed:
Option.get (csrf_token (body (get c "/workout?slot=1")))
1496
Removed:
in
1497
Removed:
let _ =
1498
Removed:
post c "/workout/slots/1"
1499
Removed:
[
1500
Removed:
("dream.csrf", token);
1501
Removed:
("load", "12");
1502
Removed:
("reps", "8");
1503
Removed:
("extension", "");
1504
Removed:
]
1505
Removed:
in
1506
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
1507
Removed:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
1508
Removed:
(* Slot 1 is filled. Re-posting to its add path is refused. *)
1509
Removed:
let token =
1510
Removed:
Option.get (csrf_token (body (get c "/logbook/w1?slot=2")))
1511
Removed:
in
1512
Removed:
let refused =
1513
Removed:
post c "/logbook/w1/slots/1"
1514
Removed:
[
1515
Removed:
("dream.csrf", token);
1516
Removed:
("load", "20");
1517
Removed:
("reps", "6");
1518
Removed:
("extension", "");
1519
Removed:
]
1520
Removed:
in
1521
Removed:
Alcotest.(check int)
1522
Removed:
"filled slot is not awaiting" 404 (status refused);
1523
Removed:
(* The refused post added no volume: still one filled slot. *)
1524
Removed:
Alcotest.(check int)
1525
Removed:
"still one filled slot" 1
1526
Removed:
(match
1527
Removed:
Lwt_main.run
1528
Removed:
(Memory_repo.find repo trainee.Trainee.id
1529
Removed:
(Repository.workout_id "w1"))
1530
Removed:
with
1531
Removed:
| Some r -> Evidence.Workout.filled_slots r.Repository.workout
1532
Removed:
| None -> Alcotest.failf "expected the saved workout w1") );
1533
Removed:
] );
1534
Removed:
( "web.slot_bounds",
1535
Removed:
[
1536
Removed:
( "posting to a slot beyond the workout is not found",
1537
Removed:
`Quick,
1538
Removed:
fun () ->
1539
Removed:
(* Day 1 has four slots (0..3). Slot 9 does not exist, so the log
1540
Removed:
handler answers 404 rather than recording phantom volume. *)
1541
Removed:
let c, repo = client_with_repo () in
1542
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1543
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1544
Removed:
let _ = start_day_one c in
1545
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
1546
Removed:
let response =
1547
Removed:
post c "/workout/slots/9"
1548
Removed:
[
1549
Removed:
("dream.csrf", token);
1550
Removed:
("load", "10");
1551
Removed:
("reps", "8");
1552
Removed:
("extension", "");
1553
Removed:
]
1554
Removed:
in
1555
Removed:
Alcotest.(check int)
1556
Removed:
"out-of-range slot is not found" 404 (status response);
1557
Removed:
(* No phantom volume was recorded. *)
1558
Removed:
Alcotest.(check int)
1559
Removed:
"nothing recorded" 0
1560
Removed:
(match
1561
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
1562
Removed:
with
1563
Removed:
| Some w -> Evidence.Workout.filled_slots w
1564
Removed:
| None -> Alcotest.failf "expected a workout in progress") );
1565
Removed:
( "editing a slot beyond the workout is not found",
1566
Removed:
`Quick,
1567
Removed:
fun () ->
1568
Removed:
let c = client () in
1569
Removed:
let _ = sign_in_new c in
1570
Removed:
let _ = start_day_one c in
1571
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
1572
Removed:
let response =
1573
Removed:
post c "/workout/slots/9/edit"
1574
Removed:
[
1575
Removed:
("dream.csrf", token);
1576
Removed:
("load", "10");
1577
Removed:
("reps", "8");
1578
Removed:
("extension", "");
1579
Removed:
]
1580
Removed:
in
1581
Removed:
Alcotest.(check int)
1582
Removed:
"out-of-range edit is not found" 404 (status response) );
1583
Removed:
( "logging with no workout in progress is not found",
1584
Removed:
`Quick,
1585
Removed:
fun () ->
1586
Removed:
let c = client () in
1587
Removed:
let _ = sign_in_new c in
1588
Removed:
(* No routine selected, no workout begun: the CSRF token comes from
1589
Removed:
Home, but the slot route has no workout to record against. *)
1590
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
1591
Removed:
let response =
1592
Removed:
post c "/workout/slots/0"
1593
Removed:
[
1594
Removed:
("dream.csrf", token);
1595
Removed:
("load", "10");
1596
Removed:
("reps", "8");
1597
Removed:
("extension", "");
1598
Removed:
]
1599
Removed:
in
1600
Removed:
Alcotest.(check int) "no workout is not found" 404 (status response)
1601
Removed:
);
1602
Removed:
] );
1603
Removed:
( "web.duplicate_feedback",
1604
Removed:
[
1605
Removed:
( "a step out of sync with the session records nothing",
1606
Removed:
`Quick,
1607
Removed:
fun () ->
1608
Removed:
(* The flow advances one factor at a time and stores its position in
1609
Removed:
the session. A post whose [step] disagrees with that position —
1610
Removed:
a stale form, a double submit, or a crafted body — is refused as
1611
Removed:
an invalid form rather than recording a factor twice. This is the
1612
Removed:
web tier's guard against a duplicate signal ever reaching the
1613
Removed:
domain. *)
1614
Removed:
let c, repo = client_with_repo () in
1615
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1616
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1617
Removed:
let start = body (get c "/logbook?feedback=start") in
1618
Removed:
let token = Option.get (csrf_token start) in
1619
Removed:
(* The session is at step 0; post step 3 instead. *)
1620
Removed:
let mismatched =
1621
Removed:
post c "/feedback"
1622
Removed:
[
1623
Removed:
("dream.csrf", token);
1624
Removed:
("step", "3");
1625
Removed:
("action", "next");
1626
Removed:
("choice", "1");
1627
Removed:
]
1628
Removed:
in
1629
Removed:
Alcotest.(check int)
1630
Removed:
"mismatched step redirects" 303 (status mismatched);
1631
Removed:
Alcotest.(check string)
1632
Removed:
"stale feedback returns to the logbook" "/logbook"
1633
Removed:
(location mismatched);
1634
Removed:
(* The mismatched post advanced nothing and stored no report. *)
1635
Removed:
Alcotest.(check int)
1636
Removed:
"no feedback stored" 0
1637
Removed:
(List.length
1638
Removed:
(Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)))
1639
Removed:
);
1640
Removed:
( "answering every factor stores exactly one signal per category",
1641
Removed:
`Quick,
1642
Removed:
fun () ->
1643
Removed:
(* The flow admits one answer per factor, so the stored report holds
1644
Removed:
one signal per category and never a duplicate. *)
1645
Removed:
let c, repo = client_with_repo () in
1646
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1647
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1648
Removed:
let _ = get c "/logbook?feedback=start" in
1649
Removed:
let rec advance step =
1650
Removed:
if step < 2 then begin
1651
Removed:
let token = Option.get (csrf_token (body (get c "/logbook"))) in
1652
Removed:
let _ =
1653
Removed:
post c "/feedback"
1654
Removed:
[
1655
Removed:
("dream.csrf", token);
1656
Removed:
("step", string_of_int step);
1657
Removed:
("action", "next");
1658
Removed:
("choice", "worse");
1659
Removed:
]
1660
Removed:
in
1661
Removed:
advance (step + 1)
1662
Removed:
end
1663
Removed:
in
1664
Removed:
advance 0;
1665
Removed:
let token = Option.get (csrf_token (body (get c "/logbook"))) in
1666
Removed:
let saved =
1667
Removed:
post c "/feedback"
1668
Removed:
[ ("dream.csrf", token); ("step", "2"); ("action", "save") ]
1669
Removed:
in
1670
Removed:
Alcotest.(check int) "final save redirects" 303 (status saved);
1671
Removed:
(* Exactly one report, with one signal per distinct factor. *)
1672
Removed:
let reports =
1673
Removed:
Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)
1674
Removed:
in
1675
Removed:
Alcotest.(check int) "one report stored" 1 (List.length reports);
1676
Removed:
let signals = Feedback.signals (List.hd reports) in
1677
Removed:
let count p = List.length (List.filter p signals) in
1678
Removed:
let open Feedback in
1679
Removed:
Alcotest.(check int)
1680
Removed:
"one motivation signal" 1
1681
Removed:
(count (function Motivation _ -> true | _ -> false));
1682
Removed:
Alcotest.(check int)
1683
Removed:
"one difficulty signal" 1
1684
Removed:
(count (function Difficulty _ -> true | _ -> false)) );
1685
Removed:
] );
1686
Removed:
( "web.lifecycle",
1687
Removed:
[
1688
Removed:
( "a full cycle: begin Day 1, record every slot, finish, and see it \
1689
Removed:
saved complete",
1690
Removed:
`Quick,
1691
Removed:
fun () ->
1692
Removed:
(* A deep end-to-end pass over the primary flow with a driven clock.
1693
Removed:
Begin Day 1, record all four slots, finish, and confirm the
1694
Removed:
logbook persists a complete Day 1 with four stimuli. The clocked
1695
Removed:
client and repo share a store, so the flow's domain effect is
1696
Removed:
read straight from history. *)
1697
Removed:
let c, now, repo = clocked_client () in
1698
Removed:
now := day 10;
1699
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1700
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1701
Removed:
let _ = start_day_one c in
1702
Removed:
let in_progress_filled () =
1703
Removed:
match
1704
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
1705
Removed:
with
1706
Removed:
| Some w -> Evidence.Workout.filled_slots w
1707
Removed:
| None -> Alcotest.failf "expected a workout in progress"
1708
Removed:
in
1709
Removed:
Alcotest.(check int)
1710
Removed:
"opens with no slots recorded" 0 (in_progress_filled ());
1711
Removed:
record_all_day_one_slots c;
1712
Removed:
Alcotest.(check int)
1713
Removed:
"all four slots recorded" 4 (in_progress_filled ());
1714
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
1715
Removed:
let finished = post c "/workout/finish" [ ("dream.csrf", token) ] in
1716
Removed:
Alcotest.(check int) "finish redirects" 303 (status finished);
1717
Removed:
Alcotest.(check bool)
1718
Removed:
"sends the trainee to the logbook feedback prompt" true
1719
Removed:
(List.mem "/logbook?prompt=feedback"
1720
Removed:
(Dream.headers finished "Location"));
1721
Removed:
(* History holds one complete Day 1 with four stimuli. *)
1722
Removed:
let history =
1723
Removed:
Lwt_main.run (Memory_repo.history repo trainee.Trainee.id)
1724
Removed:
in
1725
Removed:
Alcotest.(check int)
1726
Removed:
"one workout in history" 1 (List.length history);
1727
Removed:
let saved = (List.hd history).Repository.workout in
1728
Removed:
Alcotest.(check string)
1729
Removed:
"the saved workout is Day 1" "Day 1"
1730
Removed:
(Prescription.Workout.name (Evidence.Workout.prescription saved));
1731
Removed:
Alcotest.(check int)
1732
Removed:
"records four stimuli" 4
1733
Removed:
(List.length (Evidence.Workout.stimuli saved));
1734
Removed:
Alcotest.(check bool)
1735
Removed:
"the saved workout is complete" true
1736
Removed:
(Evidence.Workout.completeness saved = Evidence.Workout.Complete);
1737
Removed:
(* The saved workout is durable and reachable at its own URL. *)
1738
Removed:
Alcotest.(check int)
1739
Removed:
"the saved workout is reachable" 200
1740
Removed:
(status (get c "/logbook/w1")) );
1741
Removed:
( "the recovery gate blocks the next workout until enough rest, then \
1742
Removed:
Day 2 begins",
1743
Removed:
`Quick,
1744
Removed:
fun () ->
1745
Removed:
(* The deepest flow: after finishing Day 1, the next workout is
1746
Removed:
gated until 48 hours of recovery pass. The web tier drives the
1747
Removed:
clock, so this proves the gate over HTTP, not just in the
1748
Removed:
service. Beginning too early is refused; resting past the
1749
Removed:
interval clears the gate and advances the cycle to Day 2. *)
1750
Removed:
let c, now, repo = clocked_client () in
1751
Removed:
now := day 10;
1752
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1753
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1754
Removed:
let _ = start_day_one c in
1755
Removed:
record_all_day_one_slots c;
1756
Removed:
let token = Option.get (csrf_token (body (get c "/workout"))) in
1757
Removed:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
1758
Removed:
(* One hour later: recovery is far from complete. Beginning without
1759
Removed:
an override is refused and starts nothing. *)
1760
Removed:
now := day 10 + 3600;
1761
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
1762
Removed:
let refused =
1763
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
1764
Removed:
in
1765
Removed:
Alcotest.(check int)
1766
Removed:
"an early begin is bounced back" 303 (status refused);
1767
Removed:
Alcotest.(check bool)
1768
Removed:
"the early begin returns Home, not the workout" true
1769
Removed:
(List.mem "/" (Dream.headers refused "Location"));
1770
Removed:
Alcotest.(check bool)
1771
Removed:
"no workout was started" true
1772
Removed:
(Option.is_none
1773
Removed:
(Lwt_main.run
1774
Removed:
(Memory_repo.in_progress repo trainee.Trainee.id)));
1775
Removed:
(* Rest two full days: past the 48-hour training interval. The gate
1776
Removed:
clears and the next begin succeeds. *)
1777
Removed:
now := day 13;
1778
Removed:
let token = Option.get (csrf_token (body (get c "/"))) in
1779
Removed:
let began =
1780
Removed:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
1781
Removed:
in
1782
Removed:
Alcotest.(check int) "the rested begin succeeds" 303 (status began);
1783
Removed:
Alcotest.(check bool)
1784
Removed:
"the rested begin reaches the workout" true
1785
Removed:
(List.mem "/workout" (Dream.headers began "Location"));
1786
Removed:
(* The cycle has advanced to Day 2, cleared on recovery, not an
1787
Removed:
override. *)
1788
Removed:
let workout =
1789
Removed:
match
1790
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
1791
Removed:
with
1792
Removed:
| Some w -> w
1793
Removed:
| None -> Alcotest.failf "expected a workout in progress"
1794
Removed:
in
1795
Removed:
Alcotest.(check string)
1796
Removed:
"the cycle advanced to Day 2" "Day 2"
1797
Removed:
(Prescription.Workout.name
1798
Removed:
(Evidence.Workout.prescription workout));
1799
Removed:
Alcotest.(check bool)
1800
Removed:
"cleared on recovery, not an override" true
1801
Removed:
(match Recovery.basis (Evidence.Workout.clearance workout) with
1802
Removed:
| Recovery.Recovered -> true
1803
Removed:
| Recovery.Overridden _ -> false) );
1804
Removed:
] );
1805
Removed:
( "web.isolation",
1806
Removed:
[
1807
Removed:
( "two trainees never share workout or logbook state",
1808
Removed:
`Quick,
1809
Removed:
fun () ->
1810
Removed:
(* Two trainees on the same store, each with their own cookie jar.
1811
Removed:
One begins and finishes a workout; the other must see none of it:
1812
Removed:
not the in-progress workout, not the saved record. This proves
1813
Removed:
the per-trainee scoping the service promises, over HTTP. *)
1814
Removed:
let alice, repo = client_with_repo () in
1815
Removed:
let _ = register alice ~username:"alice" ~password:"heavyduty1" in
1816
Removed:
let bob = { alice with jar = [] } in
1817
Removed:
let _ = register bob ~username:"bobby" ~password:"heavyduty1" in
1818
Removed:
let alice_t = the_trainee repo ~username:"alice" in
1819
Removed:
let bob_t = the_trainee repo ~username:"bobby" in
1820
Removed:
(* Alice selects and begins a workout, records a slot. *)
1821
Removed:
let token = Option.get (csrf_token (body (get alice "/"))) in
1822
Removed:
let _ =
1823
Removed:
post alice "/routines/ideal/select" [ ("dream.csrf", token) ]
1824
Removed:
in
1825
Removed:
let token = Option.get (csrf_token (body (get alice "/"))) in
1826
Removed:
let _ =
1827
Removed:
post alice "/workout"
1828
Removed:
[ ("dream.csrf", token); ("override", "false") ]
1829
Removed:
in
1830
Removed:
let token =
1831
Removed:
Option.get (csrf_token (body (get alice "/workout?slot=1")))
1832
Removed:
in
1833
Removed:
let _ =
1834
Removed:
post alice "/workout/slots/1"
1835
Removed:
[
1836
Removed:
("dream.csrf", token);
1837
Removed:
("load", "12");
1838
Removed:
("reps", "8");
1839
Removed:
("extension", "");
1840
Removed:
]
1841
Removed:
in
1842
Removed:
(* Alice has a workout in progress; Bob does not. *)
1843
Removed:
Alcotest.(check bool)
1844
Removed:
"Alice has a workout in progress" true
1845
Removed:
(Option.is_some
1846
Removed:
(Lwt_main.run
1847
Removed:
(Memory_repo.in_progress repo alice_t.Trainee.id)));
1848
Removed:
Alcotest.(check bool)
1849
Removed:
"Bob has no workout in progress" true
1850
Removed:
(Option.is_none
1851
Removed:
(Lwt_main.run (Memory_repo.in_progress repo bob_t.Trainee.id)));
1852
Removed:
Alcotest.(check int)
1853
Removed:
"Bob's workout view redirects" 303
1854
Removed:
(status (get bob "/workout"));
1855
Removed:
(* Alice finishes; her record becomes w1 for her. *)
1856
Removed:
let token = Option.get (csrf_token (body (get alice "/workout"))) in
1857
Removed:
let _ = post alice "/workout/finish" [ ("dream.csrf", token) ] in
1858
Removed:
Alcotest.(check int)
1859
Removed:
"Alice has one saved workout" 1
1860
Removed:
(List.length
1861
Removed:
(Lwt_main.run (Memory_repo.history repo alice_t.Trainee.id)));
1862
Removed:
Alcotest.(check int)
1863
Removed:
"Alice sees her saved workout" 200
1864
Removed:
(status (get alice "/logbook/w1"));
1865
Removed:
(* Bob's history is empty, and Alice's record is unreachable from
1866
Removed:
Bob's session. Ids are per-trainee, so Bob's own w1 does not
1867
Removed:
exist. *)
1868
Removed:
Alcotest.(check int)
1869
Removed:
"Bob's history is empty" 0
1870
Removed:
(List.length
1871
Removed:
(Lwt_main.run (Memory_repo.history repo bob_t.Trainee.id)));
1872
Removed:
Alcotest.(check int)
1873
Removed:
"Bob cannot open a record he does not own" 404
1874
Removed:
(status (get bob "/logbook/w1")) );
1875
Removed:
] );
1876
Removed:
( "web.import",
1877
Removed:
(* The Hevy import web flow, end to end. Each test drives the multipart
1878
Removed:
upload and the review POSTs, then asserts status, redirect location,
1879
Removed:
and Repository state — never rendered HTML. The CSRF token is read from
1880
Removed:
the profile page body, as a browser would. *)
1881
Removed:
let header =
1882
Removed:
"title,start_time,end_time,description,exercise_title,superset_id,exercise_notes,set_index,set_type,weight_kg,reps,distance_km,duration_seconds,rpe\r\n"
1883
Removed:
in
1884
Removed:
(* One native row. Datetimes are Hevy local wall time. *)
1885
Removed:
let row ~title ~exercise ~set_type ~weight ~reps ?(set_index = 0)
1886
Removed:
?(start = "01 Jan 2024, 10:00") ?(finish = "01 Jan 2024, 11:00") () =
1887
Removed:
Printf.sprintf "%s,%S,%S,,%s,,,%d,%s,%s,%d,,,\r\n" title start finish
1888
Removed:
exercise set_index set_type weight reps
1889
Removed:
in
1890
Removed:
let csv rows = header ^ String.concat "" rows in
1891
Removed:
(* Register, then read a CSRF token from the profile page. *)
1892
Removed:
let signed_in_profile_token c =
1893
Removed:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1894
Removed:
Option.get (csrf_token (body (get c "/profile")))
1895
Removed:
in
1896
Removed:
let review_token c url = Option.get (csrf_token (body (get c url))) in
1897
Removed:
let batches repo trainee =
1898
Removed:
Lwt_main.run (Memory_repo.import_batches repo trainee.Trainee.id)
1899
Removed:
in
1900
Removed:
let imported repo trainee =
1901
Removed:
Lwt_main.run (Memory_repo.imported_records repo trainee.Trainee.id)
1902
Removed:
in
1903
Removed:
[
1904
Removed:
( "a valid native export uploads to a stored batch with immutable source",
1905
Removed:
`Quick,
1906
Removed:
fun () ->
1907
Removed:
let c, repo = client_with_repo () in
1908
Removed:
let token = signed_in_profile_token c in
1909
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1910
Removed:
let source =
1911
Removed:
csv
1912
Removed:
[
1913
Removed:
row ~title:"Legs" ~exercise:"Barbell Squat"
1914
Removed:
~set_type:"failure" ~weight:"100" ~reps:8 ();
1915
Removed:
]
1916
Removed:
in
1917
Removed:
let response =
1918
Removed:
post_multipart c "/profile/import"
1919
Removed:
~file:(Some ("csv", "workouts.csv", source))
1920
Removed:
~fields:[ ("dream.csrf", token); ("utc_offset_seconds", "0") ]
1921
Removed:
in
1922
Removed:
Alcotest.(check int) "303 to review" 303 (status response);
1923
Removed:
Alcotest.(check bool)
1924
Removed:
"redirects to the review URL" true
1925
Removed:
(index_from ~needle:"/profile/import/" (location response) 0
1926
Removed:
|> Option.is_some);
1927
Removed:
let stored = batches repo trainee in
1928
Removed:
Alcotest.(check int) "one batch stored" 1 (List.length stored);
1929
Removed:
Alcotest.(check string)
1930
Removed:
"source retained verbatim" source
1931
Removed:
(Workout_import.batch_source (List.hd stored)) );
1932
Removed:
( "a duplicate upload is refused, the override stores a second batch",
1933
Removed:
`Quick,
1934
Removed:
fun () ->
1935
Removed:
let c, repo = client_with_repo () in
1936
Removed:
let token = signed_in_profile_token c in
1937
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1938
Removed:
let source =
1939
Removed:
csv
1940
Removed:
[
1941
Removed:
row ~title:"Legs" ~exercise:"Barbell Squat"
1942
Removed:
~set_type:"failure" ~weight:"100" ~reps:8 ();
1943
Removed:
]
1944
Removed:
in
1945
Removed:
let upload ?(allow = false) () =
1946
Removed:
let token = Option.get (csrf_token (body (get c "/profile"))) in
1947
Removed:
let fields =
1948
Removed:
[ ("dream.csrf", token); ("utc_offset_seconds", "0") ]
1949
Removed:
@ if allow then [ ("allow_duplicate", "true") ] else []
1950
Removed:
in
1951
Removed:
post_multipart c "/profile/import"
1952
Removed:
~file:(Some ("csv", "workouts.csv", source))
1953
Removed:
~fields
1954
Removed:
in
1955
Removed:
ignore token;
1956
Removed:
let first = upload () in
1957
Removed:
Alcotest.(check int) "first upload 303" 303 (status first);
1958
Removed:
let second = upload () in
1959
Removed:
Alcotest.(check int)
1960
Removed:
"duplicate redirects to profile" 303 (status second);
1961
Removed:
Alcotest.(check string)
1962
Removed:
"duplicate lands on profile" "/profile" (location second);
1963
Removed:
Alcotest.(check int)
1964
Removed:
"still one batch after duplicate" 1
1965
Removed:
(List.length (batches repo trainee));
1966
Removed:
let overridden = upload ~allow:true () in
1967
Removed:
Alcotest.(check int) "override 303" 303 (status overridden);
1968
Removed:
let stored = batches repo trainee in
1969
Removed:
Alcotest.(check int)
1970
Removed:
"override stores a second batch" 2 (List.length stored);
1971
Removed:
(* The two batches have distinct ids, so the override did not
1972
Removed:
overwrite the original. *)
1973
Removed:
let ids =
1974
Removed:
List.map
1975
Removed:
(fun b ->
1976
Removed:
Workout_import.batch_id_to_string
1977
Removed:
(Workout_import.batch_identity b))
1978
Removed:
stored
1979
Removed:
in
1980
Removed:
Alcotest.(check bool)
1981
Removed:
"the two batch ids differ" true
1982
Removed:
(match ids with [ a; b ] -> a <> b | _ -> false) );
1983
Removed:
( "warmup and unsupported rows persist as warnings, not sets",
1984
Removed:
`Quick,
1985
Removed:
fun () ->
1986
Removed:
let c, repo = client_with_repo () in
1987
Removed:
let token = signed_in_profile_token c in
1988
Removed:
let trainee = the_trainee repo ~username:"lifter" in
1989
Removed:
let source =
1990
Removed:
csv
1991
Removed:
[
1992
Removed:
row ~title:"Legs" ~exercise:"Barbell Squat" ~set_type:"warmup"
1993
Removed:
~weight:"40" ~reps:10 ~set_index:0 ();
1994
Removed:
row ~title:"Legs" ~exercise:"Barbell Squat" ~set_type:"wibble"
1995
Removed:
~weight:"50" ~reps:10 ~set_index:1 ();
1996
Removed:
row ~title:"Legs" ~exercise:"Barbell Squat"
1997
Removed:
~set_type:"failure" ~weight:"100" ~reps:8 ~set_index:2 ();
1998
Removed:
]
1999
Removed:
in
2000
Removed:
let response =
2001
Removed:
post_multipart c "/profile/import"
2002
Removed:
~file:(Some ("csv", "workouts.csv", source))
2003
Removed:
~fields:[ ("dream.csrf", token); ("utc_offset_seconds", "0") ]
2004
Removed:
in
2005
Removed:
Alcotest.(check int) "303 to review" 303 (status response);
2006
Removed:
let batch = List.hd (batches repo trainee) in
2007
Removed:
(* Two warnings: the warmup and the unknown set type. *)
2008
Removed:
Alcotest.(check int)
2009
Removed:
"two rows dropped as warnings" 2
2010
Removed:
(List.length (Workout_import.batch_warnings batch));
2011
Removed:
(* The workout keeps only the one failure set; no provisional set
2012
Removed:
was invented for the dropped rows. *)
2013
Removed:
let w = List.hd (Workout_import.batch_workouts batch) in
2014
Removed:
Alcotest.(check int)
2015
Removed:
"only the failure set survives" 1
2016
Removed:
(List.length (Workout_import.workout_sets w)) );
2017
Removed:
( "map, confirm, then promote writes an imported record",
2018
Removed:
`Quick,
2019
Removed:
fun () ->
2020
Removed:
let c, repo = client_with_repo () in
2021
Removed:
let token = signed_in_profile_token c in
2022
Removed:
let trainee = the_trainee repo ~username:"lifter" in
2023
Removed:
(* A single normal set: it needs both a mapping and a normal-set
2024
Removed:
confirmation before it can promote. *)
2025
Removed:
let source =
2026
Removed:
csv
2027
Removed:
[
2028
Removed:
row ~title:"Legs" ~exercise:"Barbell Squat" ~set_type:"normal"
2029
Removed:
~weight:"100" ~reps:8 ();
2030
Removed:
]
2031
Removed:
in
2032
Removed:
let _ =
2033
Removed:
post_multipart c "/profile/import"
2034
Removed:
~file:(Some ("csv", "workouts.csv", source))
2035
Removed:
~fields:[ ("dream.csrf", token); ("utc_offset_seconds", "0") ]
2036
Removed:
in
2037
Removed:
let batch = List.hd (batches repo trainee) in
2038
Removed:
let bid =
2039
Removed:
Workout_import.batch_id_to_string
2040
Removed:
(Workout_import.batch_identity batch)
2041
Removed:
in
2042
Removed:
let wid =
2043
Removed:
Workout_import.workout_id_to_string
2044
Removed:
(Workout_import.workout_identity
2045
Removed:
(List.hd (Workout_import.batch_workouts batch)))
2046
Removed:
in
2047
Removed:
let review = "/profile/import/" ^ bid in
2048
Removed:
let map_url =
2049
Removed:
Printf.sprintf "/profile/import/%s/workouts/%s/map" bid wid
2050
Removed:
in
2051
Removed:
let t = review_token c review in
2052
Removed:
let _ =
2053
Removed:
post c map_url
2054
Removed:
[
2055
Removed:
("dream.csrf", t);
2056
Removed:
("source_name", "Barbell Squat");
2057
Removed:
("exercise_id", "squats");
2058
Removed:
]
2059
Removed:
in
2060
Removed:
let t = review_token c review in
2061
Removed:
let confirm_url =
2062
Removed:
Printf.sprintf "/profile/import/%s/workouts/%s/confirm" bid wid
2063
Removed:
in
2064
Removed:
let _ =
2065
Removed:
post c confirm_url
2066
Removed:
[ ("dream.csrf", t); ("acknowledgement", "clean form") ]
2067
Removed:
in
2068
Removed:
let t = review_token c review in
2069
Removed:
let promote_url =
2070
Removed:
Printf.sprintf "/profile/import/%s/workouts/%s/promote" bid wid
2071
Removed:
in
2072
Removed:
let promote = post c promote_url [ ("dream.csrf", t) ] in
2073
Removed:
Alcotest.(check int) "promotion redirects" 303 (status promote);
2074
Removed:
Alcotest.(check int)
2075
Removed:
"one imported record exists" 1
2076
Removed:
(List.length (imported repo trainee)) );
2077
Removed:
( "a dropset workout stays blocked and writes no record",
2078
Removed:
`Quick,
2079
Removed:
fun () ->
2080
Removed:
let c, repo = client_with_repo () in
2081
Removed:
let token = signed_in_profile_token c in
2082
Removed:
let trainee = the_trainee repo ~username:"lifter" in
2083
Removed:
let source =
2084
Removed:
csv
2085
Removed:
[
2086
Removed:
row ~title:"Legs" ~exercise:"Barbell Squat"
2087
Removed:
~set_type:"dropset" ~weight:"100" ~reps:8 ();
2088
Removed:
]
2089
Removed:
in
2090
Removed:
let _ =
2091
Removed:
post_multipart c "/profile/import"
2092
Removed:
~file:(Some ("csv", "workouts.csv", source))
2093
Removed:
~fields:[ ("dream.csrf", token); ("utc_offset_seconds", "0") ]
2094
Removed:
in
2095
Removed:
let batch = List.hd (batches repo trainee) in
2096
Removed:
let bid =
2097
Removed:
Workout_import.batch_id_to_string
2098
Removed:
(Workout_import.batch_identity batch)
2099
Removed:
in
2100
Removed:
let wid =
2101
Removed:
Workout_import.workout_id_to_string
2102
Removed:
(Workout_import.workout_identity
2103
Removed:
(List.hd (Workout_import.batch_workouts batch)))
2104
Removed:
in
2105
Removed:
let review = "/profile/import/" ^ bid in
2106
Removed:
(* Map the dropset's exercise so only the dropset itself blocks. *)
2107
Removed:
let t = review_token c review in
2108
Removed:
let _ =
2109
Removed:
post c
2110
Removed:
(Printf.sprintf "/profile/import/%s/workouts/%s/map" bid wid)
2111
Removed:
[
2112
Removed:
("dream.csrf", t);
2113
Removed:
("source_name", "Barbell Squat");
2114
Removed:
("exercise_id", "squats");
2115
Removed:
]
2116
Removed:
in
2117
Removed:
let t = review_token c review in
2118
Removed:
let promote =
2119
Removed:
post c
2120
Removed:
(Printf.sprintf "/profile/import/%s/workouts/%s/promote" bid wid)
2121
Removed:
[ ("dream.csrf", t) ]
2122
Removed:
in
2123
Removed:
Alcotest.(check int) "still a redirect" 303 (status promote);
2124
Removed:
Alcotest.(check int)
2125
Removed:
"no record written for a dropset" 0
2126
Removed:
(List.length (imported repo trainee)) );
2127
Removed:
( "a partial batch promotion promotes the eligible sibling and retains \
2128
Removed:
the blocked one",
2129
Removed:
`Quick,
2130
Removed:
fun () ->
2131
Removed:
let c, repo = client_with_repo () in
2132
Removed:
let token = signed_in_profile_token c in
2133
Removed:
let trainee = the_trainee repo ~username:"lifter" in
2134
Removed:
(* Two workouts: one ready failure set, one dropset that blocks. *)
2135
Removed:
let source =
2136
Removed:
csv
2137
Removed:
[
2138
Removed:
row ~title:"Legs" ~exercise:"Barbell Squat"
2139
Removed:
~set_type:"failure" ~weight:"100" ~reps:8
2140
Removed:
~start:"01 Jan 2024, 10:00" ~finish:"01 Jan 2024, 11:00" ();
2141
Removed:
row ~title:"Arms" ~exercise:"Barbell Curl" ~set_type:"dropset"
2142
Removed:
~weight:"30" ~reps:8 ~start:"02 Jan 2024, 10:00"
2143
Removed:
~finish:"02 Jan 2024, 11:00" ();
2144
Removed:
]
2145
Removed:
in
2146
Removed:
let _ =
2147
Removed:
post_multipart c "/profile/import"
2148
Removed:
~file:(Some ("csv", "workouts.csv", source))
2149
Removed:
~fields:[ ("dream.csrf", token); ("utc_offset_seconds", "0") ]
2150
Removed:
in
2151
Removed:
let batch = List.hd (batches repo trainee) in
2152
Removed:
let bid =
2153
Removed:
Workout_import.batch_id_to_string
2154
Removed:
(Workout_import.batch_identity batch)
2155
Removed:
in
2156
Removed:
let review = "/profile/import/" ^ bid in
2157
Removed:
(* Map the ready workout's exercise so its only blocker clears. *)
2158
Removed:
let ready_wid =
2159
Removed:
List.find_map
2160
Removed:
(fun w ->
2161
Removed:
if String.equal (Workout_import.workout_title w) "Legs" then
2162
Removed:
Some
2163
Removed:
(Workout_import.workout_id_to_string
2164
Removed:
(Workout_import.workout_identity w))
2165
Removed:
else None)
2166
Removed:
(Workout_import.batch_workouts batch)
2167
Removed:
|> Option.get
2168
Removed:
in
2169
Removed:
let t = review_token c review in
2170
Removed:
let _ =
2171
Removed:
post c
2172
Removed:
(Printf.sprintf "/profile/import/%s/workouts/%s/map" bid
2173
Removed:
ready_wid)
2174
Removed:
[
2175
Removed:
("dream.csrf", t);
2176
Removed:
("source_name", "Barbell Squat");
2177
Removed:
("exercise_id", "squats");
2178
Removed:
]
2179
Removed:
in
2180
Removed:
let t = review_token c review in
2181
Removed:
let promote =
2182
Removed:
post c
2183
Removed:
(Printf.sprintf "/profile/import/%s/promote" bid)
2184
Removed:
[ ("dream.csrf", t) ]
2185
Removed:
in
2186
Removed:
Alcotest.(check int)
2187
Removed:
"batch promotion redirects" 303 (status promote);
2188
Removed:
(* Only the eligible sibling is promoted. The blocked dropset
2189
Removed:
writes no record and stays in the batch. *)
2190
Removed:
Alcotest.(check int)
2191
Removed:
"one record from the eligible sibling" 1
2192
Removed:
(List.length (imported repo trainee)) );
2193
Removed:
( "an unknown batch GET is 404, an unknown exercise mapping changes \
2194
Removed:
nothing",
2195
Removed:
`Quick,
2196
Removed:
fun () ->
2197
Removed:
let c, repo = client_with_repo () in
2198
Removed:
let token = signed_in_profile_token c in
2199
Removed:
let trainee = the_trainee repo ~username:"lifter" in
2200
Removed:
(* Unknown batch id: the review GET is a 404. *)
2201
Removed:
ignore token;
2202
Removed:
Alcotest.(check int)
2203
Removed:
"unknown batch review is 404" 404
2204
Removed:
(status (get c "/profile/import/no-such-batch"));
2205
Removed:
(* Upload a real batch, then map to an id absent from the catalog.
2206
Removed:
No mapping is recorded. *)
2207
Removed:
let source =
2208
Removed:
csv
2209
Removed:
[
2210
Removed:
row ~title:"Legs" ~exercise:"Barbell Squat" ~set_type:"normal"
2211
Removed:
~weight:"100" ~reps:8 ();
2212
Removed:
]
2213
Removed:
in
2214
Removed:
let up_token = Option.get (csrf_token (body (get c "/profile"))) in
2215
Removed:
let _ =
2216
Removed:
post_multipart c "/profile/import"
2217
Removed:
~file:(Some ("csv", "workouts.csv", source))
2218
Removed:
~fields:
2219
Removed:
[ ("dream.csrf", up_token); ("utc_offset_seconds", "0") ]
2220
Removed:
in
2221
Removed:
let batch = List.hd (batches repo trainee) in
2222
Removed:
let bid =
2223
Removed:
Workout_import.batch_id_to_string
2224
Removed:
(Workout_import.batch_identity batch)
2225
Removed:
in
2226
Removed:
let wid =
2227
Removed:
Workout_import.workout_id_to_string
2228
Removed:
(Workout_import.workout_identity
2229
Removed:
(List.hd (Workout_import.batch_workouts batch)))
2230
Removed:
in
2231
Removed:
let review = "/profile/import/" ^ bid in
2232
Removed:
let t = review_token c review in
2233
Removed:
let response =
2234
Removed:
post c
2235
Removed:
(Printf.sprintf "/profile/import/%s/workouts/%s/map" bid wid)
2236
Removed:
[
2237
Removed:
("dream.csrf", t);
2238
Removed:
("source_name", "Barbell Squat");
2239
Removed:
("exercise_id", "not-an-exercise");
2240
Removed:
]
2241
Removed:
in
2242
Removed:
Alcotest.(check int)
2243
Removed:
"unknown exercise redirects, not errors" 303 (status response);
2244
Removed:
(* The stored workout still has no mapping for the source name. *)
2245
Removed:
let reloaded = List.hd (batches repo trainee) in
2246
Removed:
let w = List.hd (Workout_import.batch_workouts reloaded) in
2247
Removed:
Alcotest.(check bool)
2248
Removed:
"no mapping was recorded" true
2249
Removed:
(Option.is_none
2250
Removed:
(Workout_import.workout_mapping w ~source_name:"Barbell Squat"))
2251
Removed:
);
2252
Removed:
] );
2253
Removed:
]
2254
Removed:
2255
Removed:
let suite = route_tests
test/web/app_feedback.ml
@@ -0,0 +1,220 @@
1
Added:
open Hito_app
2
Added:
open Support
3
Added:
4
Added:
let suite =
5
Added:
[
6
Added:
( "web.app_feedback",
7
Added:
[
8
Added:
( "the app feedback screen and its tabs are served",
9
Added:
`Quick,
10
Added:
fun () ->
11
Added:
let c = client () in
12
Added:
let _ = sign_in_new c in
13
Added:
Alcotest.(check int)
14
Added:
"write tab served" 200
15
Added:
(status (get c "/app-feedback"));
16
Added:
Alcotest.(check int)
17
Added:
"submitted tab served" 200
18
Added:
(status (get c "/app-feedback?tab=submitted")) );
19
Added:
( "blank app feedback is refused; a real message is stored",
20
Added:
`Quick,
21
Added:
fun () ->
22
Added:
let c, repo = client_with_repo () in
23
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
24
Added:
let trainee = the_trainee repo ~username:"lifter" in
25
Added:
let stored_count () =
26
Added:
List.length
27
Added:
(Lwt_main.run
28
Added:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id))
29
Added:
in
30
Added:
let token =
31
Added:
Option.get (csrf_token (body (get c "/app-feedback")))
32
Added:
in
33
Added:
let blank =
34
Added:
post c "/app-feedback/submit"
35
Added:
[ ("dream.csrf", token); ("message", " ") ]
36
Added:
in
37
Added:
Alcotest.(check int) "blank message redirects" 303 (status blank);
38
Added:
Alcotest.(check bool)
39
Added:
"redirects to the write tab" true
40
Added:
(List.mem "/app-feedback?tab=write"
41
Added:
(Dream.headers blank "Location"));
42
Added:
(* Blank input stored nothing. *)
43
Added:
Alcotest.(check int)
44
Added:
"no report stored for blank input" 0 (stored_count ());
45
Added:
let token =
46
Added:
Option.get (csrf_token (body (get c "/app-feedback")))
47
Added:
in
48
Added:
let submitted =
49
Added:
post c "/app-feedback/submit"
50
Added:
[
51
Added:
("dream.csrf", token);
52
Added:
("message", "The app is clear.\nThank you!");
53
Added:
]
54
Added:
in
55
Added:
Alcotest.(check int) "message is accepted" 303 (status submitted);
56
Added:
Alcotest.(check bool)
57
Added:
"redirects to submitted feedback" true
58
Added:
(List.mem "/app-feedback?tab=submitted"
59
Added:
(Dream.headers submitted "Location"));
60
Added:
(* The report now exists with the exact message. *)
61
Added:
let reports =
62
Added:
Lwt_main.run
63
Added:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)
64
Added:
in
65
Added:
Alcotest.(check int) "one report stored" 1 (List.length reports);
66
Added:
Alcotest.(check string)
67
Added:
"stores the exact message" "The app is clear.\nThank you!"
68
Added:
(List.hd reports).Repository.message );
69
Added:
( "feedback records its author and accepts another trainee's vote",
70
Added:
`Quick,
71
Added:
fun () ->
72
Added:
let alice = client () in
73
Added:
let _ = register alice ~username:"alice" ~password:"heavyduty1" in
74
Added:
let bob = { alice with jar = [] } in
75
Added:
let _ = register bob ~username:"bobby" ~password:"heavyduty1" in
76
Added:
let submit client message =
77
Added:
let token =
78
Added:
Option.get (csrf_token (body (get client "/app-feedback")))
79
Added:
in
80
Added:
post client "/app-feedback/submit"
81
Added:
[ ("dream.csrf", token); ("message", message) ]
82
Added:
in
83
Added:
Alcotest.(check int)
84
Added:
"alice feedback accepted" 303
85
Added:
(status (submit alice "Alice report"));
86
Added:
Alcotest.(check int)
87
Added:
"bob feedback accepted" 303
88
Added:
(status (submit bob "Bob report"));
89
Added:
(* Bob's report is t2:1 — the vote control on Alice's view posts
90
Added:
there. Alice upvotes it. *)
91
Added:
let list_page = body (get alice "/app-feedback?tab=submitted") in
92
Added:
let token = Option.get (csrf_token list_page) in
93
Added:
let voted =
94
Added:
post alice "/app-feedback/t2:1/upvote" [ ("dream.csrf", token) ]
95
Added:
in
96
Added:
Alcotest.(check int) "upvote redirects" 303 (status voted) );
97
Added:
( "an owner can edit and remove their feedback",
98
Added:
`Quick,
99
Added:
fun () ->
100
Added:
let c, repo = client_with_repo () in
101
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
102
Added:
let trainee = the_trainee repo ~username:"lifter" in
103
Added:
let token =
104
Added:
Option.get (csrf_token (body (get c "/app-feedback")))
105
Added:
in
106
Added:
let _ =
107
Added:
post c "/app-feedback/submit"
108
Added:
[ ("dream.csrf", token); ("message", "First report") ]
109
Added:
in
110
Added:
let feedback_id () =
111
Added:
(List.hd
112
Added:
(Lwt_main.run
113
Added:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
114
Added:
.Repository.feedback_id |> Repository.app_feedback_id_to_string
115
Added:
in
116
Added:
let id = feedback_id () in
117
Added:
(* A blank edit is refused and changes nothing. *)
118
Added:
let token =
119
Added:
Option.get
120
Added:
(csrf_token (body (get c "/app-feedback?tab=submitted")))
121
Added:
in
122
Added:
let blank =
123
Added:
post c
124
Added:
("/app-feedback/" ^ id ^ "/edit")
125
Added:
[ ("dream.csrf", token); ("message", " ") ]
126
Added:
in
127
Added:
Alcotest.(check int) "blank edit redirects" 303 (status blank);
128
Added:
Alcotest.(check string)
129
Added:
"message unchanged by blank edit" "First report"
130
Added:
(List.hd
131
Added:
(Lwt_main.run
132
Added:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
133
Added:
.Repository.message;
134
Added:
(* A real edit changes the stored message. *)
135
Added:
let token =
136
Added:
Option.get
137
Added:
(csrf_token (body (get c "/app-feedback?tab=submitted")))
138
Added:
in
139
Added:
let edited =
140
Added:
post c
141
Added:
("/app-feedback/" ^ id ^ "/edit")
142
Added:
[ ("dream.csrf", token); ("message", "Edited report") ]
143
Added:
in
144
Added:
Alcotest.(check int) "edit redirects" 303 (status edited);
145
Added:
Alcotest.(check string)
146
Added:
"message updated by edit" "Edited report"
147
Added:
(List.hd
148
Added:
(Lwt_main.run
149
Added:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
150
Added:
.Repository.message;
151
Added:
(* Removal deletes the report. *)
152
Added:
let token =
153
Added:
Option.get
154
Added:
(csrf_token (body (get c "/app-feedback?tab=submitted")))
155
Added:
in
156
Added:
let removed =
157
Added:
post c
158
Added:
("/app-feedback/" ^ id ^ "/remove")
159
Added:
[ ("dream.csrf", token) ]
160
Added:
in
161
Added:
Alcotest.(check int) "remove redirects" 303 (status removed);
162
Added:
Alcotest.(check int)
163
Added:
"report removed" 0
164
Added:
(List.length
165
Added:
(Lwt_main.run
166
Added:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
167
Added:
);
168
Added:
( "another trainee cannot edit or remove app feedback",
169
Added:
`Quick,
170
Added:
fun () ->
171
Added:
let alice, repo = client_with_repo () in
172
Added:
let _ = register alice ~username:"alice" ~password:"heavyduty1" in
173
Added:
let bob = { alice with jar = [] } in
174
Added:
let _ = register bob ~username:"bobby" ~password:"heavyduty1" in
175
Added:
let bob_trainee = the_trainee repo ~username:"bobby" in
176
Added:
(* Bob owns t2:1. Alice attempts to edit and remove it. Both are
177
Added:
refused at the ownership check, so the report and its message
178
Added:
survive. *)
179
Added:
let token =
180
Added:
Option.get (csrf_token (body (get bob "/app-feedback")))
181
Added:
in
182
Added:
let _ =
183
Added:
post bob "/app-feedback/submit"
184
Added:
[ ("dream.csrf", token); ("message", "Bob owns this") ]
185
Added:
in
186
Added:
let stored () =
187
Added:
Lwt_main.run
188
Added:
(Memory_repo.app_feedback repo ~viewer:bob_trainee.Trainee.id)
189
Added:
in
190
Added:
Alcotest.(check int)
191
Added:
"one report before cross-user attempts" 1
192
Added:
(List.length (stored ()));
193
Added:
let token =
194
Added:
Option.get
195
Added:
(csrf_token (body (get alice "/app-feedback?tab=submitted")))
196
Added:
in
197
Added:
let edited =
198
Added:
post alice "/app-feedback/t2:1/edit"
199
Added:
[ ("dream.csrf", token); ("message", "Taken over") ]
200
Added:
in
201
Added:
Alcotest.(check int) "cross-user edit redirects" 303 (status edited);
202
Added:
let token =
203
Added:
Option.get
204
Added:
(csrf_token (body (get alice "/app-feedback?tab=submitted")))
205
Added:
in
206
Added:
let removed =
207
Added:
post alice "/app-feedback/t2:1/remove" [ ("dream.csrf", token) ]
208
Added:
in
209
Added:
Alcotest.(check int)
210
Added:
"cross-user remove redirects" 303 (status removed);
211
Added:
(* The report still exists with its original message: the cross-user
212
Added:
attempts changed nothing. *)
213
Added:
let after = stored () in
214
Added:
Alcotest.(check int)
215
Added:
"report survives cross-user attempts" 1 (List.length after);
216
Added:
Alcotest.(check string)
217
Added:
"message is unchanged" "Bob owns this"
218
Added:
(List.hd after).Repository.message );
219
Added:
] );
220
Added:
]
test/web/auth.ml
@@ -0,0 +1,146 @@
1
Added:
open Hito_app
2
Added:
open Support
3
Added:
4
Added:
let suite =
5
Added:
[
6
Added:
( "web.auth",
7
Added:
[
8
Added:
( "an unauthenticated visit to the overview redirects to sign-in",
9
Added:
`Quick,
10
Added:
fun () ->
11
Added:
let c = client () in
12
Added:
let response = get c "/" in
13
Added:
Alcotest.(check int) "redirect" 303 (status response);
14
Added:
Alcotest.(check string) "to /login" "/login" (location response) );
15
Added:
( "the sign-in page is served",
16
Added:
`Quick,
17
Added:
fun () ->
18
Added:
let c = client () in
19
Added:
Alcotest.(check int) "GET /login" 200 (status (get c "/login")) );
20
Added:
( "every page carries the copyright and deployment version banner",
21
Added:
`Quick,
22
Added:
fun () ->
23
Added:
let c = client () in
24
Added:
let rendered = body (get c "/login") in
25
Added:
let version =
26
Added:
match Sys.getenv_opt "HITO_VERSION" with
27
Added:
| Some value when value <> "" -> value
28
Added:
| _ -> "development"
29
Added:
in
30
Added:
let now = Unix.gmtime (Unix.gettimeofday ()) in
31
Added:
let copyright =
32
Added:
Printf.sprintf "© %d Marius Peter" (now.Unix.tm_year + 1900)
33
Added:
in
34
Added:
Alcotest.(check bool)
35
Added:
"copyright notice" true
36
Added:
(Option.is_some (index_from ~needle:copyright rendered 0));
37
Added:
Alcotest.(check bool)
38
Added:
"deployment version markup" true
39
Added:
(Option.is_some
40
Added:
(index_from ~needle:"deployment-version" rendered 0));
41
Added:
Alcotest.(check bool)
42
Added:
"deployment version value" true
43
Added:
(Option.is_some
44
Added:
(index_from ~needle:(">" ^ version ^ "</code>") rendered 0)) );
45
Added:
( "registration creates the account, signs in, and reaches the overview",
46
Added:
`Quick,
47
Added:
fun () ->
48
Added:
let c, repo = client_with_repo () in
49
Added:
let registered =
50
Added:
register c ~username:"lifter" ~password:"heavyduty1"
51
Added:
in
52
Added:
Alcotest.(check int)
53
Added:
"registered, redirected" 303 (status registered);
54
Added:
(* The account now exists: the flow orchestrated a real create. *)
55
Added:
let trainee = the_trainee repo ~username:"lifter" in
56
Added:
Alcotest.(check string)
57
Added:
"stored under the normalized username" "lifter"
58
Added:
(Trainee.username_to_string trainee.Trainee.username);
59
Added:
(* The session authenticates the follow-up request. *)
60
Added:
Alcotest.(check int)
61
Added:
"authenticated overview" 200
62
Added:
(status (get c "/")) );
63
Added:
( "an authenticated trainee reaches the overview",
64
Added:
`Quick,
65
Added:
fun () ->
66
Added:
let c = client () in
67
Added:
let _ = sign_in_new c in
68
Added:
Alcotest.(check int) "home" 200 (status (get c "/")) );
69
Added:
( "sign-out clears the session",
70
Added:
`Quick,
71
Added:
fun () ->
72
Added:
let c = client () in
73
Added:
let _ = sign_in_new c in
74
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
75
Added:
let out = post c "/logout" [ ("dream.csrf", token) ] in
76
Added:
Alcotest.(check int) "logout redirects" 303 (status out);
77
Added:
(* The session is gone: the overview again bounces to sign-in. *)
78
Added:
let after = get c "/" in
79
Added:
Alcotest.(check int) "overview now redirects" 303 (status after);
80
Added:
Alcotest.(check string) "to /login" "/login" (location after) );
81
Added:
( "a form post without a CSRF token is refused and changes nothing",
82
Added:
`Quick,
83
Added:
fun () ->
84
Added:
let c, repo = client_with_repo () in
85
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
86
Added:
let response =
87
Added:
post c "/routines/ideal/select" [ (* no dream.csrf *) ]
88
Added:
in
89
Added:
Alcotest.(check int)
90
Added:
"redirects after the refused post" 303 (status response);
91
Added:
(* No routine was selected: the refused post had no domain effect. *)
92
Added:
let trainee = the_trainee repo ~username:"lifter" in
93
Added:
Alcotest.(check bool)
94
Added:
"no active routine" true
95
Added:
(Option.is_none
96
Added:
(Lwt_main.run
97
Added:
(Memory_repo.active_routine repo trainee.Trainee.id))) );
98
Added:
( "a too-short username is refused",
99
Added:
`Quick,
100
Added:
fun () ->
101
Added:
let c, repo = client_with_repo () in
102
Added:
let response = register c ~username:"abc" ~password:"heavyduty1" in
103
Added:
Alcotest.(check int) "rejected" 400 (status response);
104
Added:
Alcotest.(check (option string))
105
Added:
"no account created" None
106
Added:
(Lwt_main.run
107
Added:
(match Trainee.username "abc" with
108
Added:
| Ok u -> Memory_repo.find_trainee_by_username repo u
109
Added:
| Error _ -> Lwt.return None)
110
Added:
|> Option.map (fun t -> Trainee.id_to_string t.Trainee.id)) );
111
Added:
( "a too-long username is refused",
112
Added:
`Quick,
113
Added:
fun () ->
114
Added:
let c = client () in
115
Added:
let response =
116
Added:
register c ~username:"abcdefghijklmnopqrstu"
117
Added:
~password:"heavyduty1"
118
Added:
in
119
Added:
Alcotest.(check int) "rejected" 400 (status response) );
120
Added:
( "a short password is accepted (passwords carry no policy)",
121
Added:
`Quick,
122
Added:
fun () ->
123
Added:
let c = client () in
124
Added:
let response = register c ~username:"lifter" ~password:"x" in
125
Added:
Alcotest.(check int) "registered, redirected" 303 (status response);
126
Added:
Alcotest.(check int)
127
Added:
"authenticated overview" 200
128
Added:
(status (get c "/")) );
129
Added:
( "with registration closed the register routes are absent",
130
Added:
`Quick,
131
Added:
fun () ->
132
Added:
(* The production default: [registration_open] unset. *)
133
Added:
let handlers = Handlers.make ~repo:(Memory_repo.create ()) () in
134
Added:
let app =
135
Added:
Dream.memory_sessions @@ Dream.router (Handlers.routes handlers)
136
Added:
|> fun h -> Dream.set_secret "test-secret-value" h
137
Added:
in
138
Added:
let c = { app; jar = [] } in
139
Added:
Alcotest.(check int)
140
Added:
"GET /register is not found" 404
141
Added:
(status (get c "/register"));
142
Added:
Alcotest.(check int)
143
Added:
"GET /login is served" 200
144
Added:
(status (get c "/login")) );
145
Added:
] );
146
Added:
]
test/web/duplicate_feedback.ml
@@ -0,0 +1,89 @@
1
Added:
open Hito_app
2
Added:
open Support
3
Added:
4
Added:
let suite =
5
Added:
[
6
Added:
( "web.duplicate_feedback",
7
Added:
[
8
Added:
( "a step out of sync with the session records nothing",
9
Added:
`Quick,
10
Added:
fun () ->
11
Added:
(* The flow advances one factor at a time and stores its position in
12
Added:
the session. A post whose [step] disagrees with that position —
13
Added:
a stale form, a double submit, or a crafted body — is refused as
14
Added:
an invalid form rather than recording a factor twice. This is the
15
Added:
web tier's guard against a duplicate signal ever reaching the
16
Added:
domain. *)
17
Added:
let c, repo = client_with_repo () in
18
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
19
Added:
let trainee = the_trainee repo ~username:"lifter" in
20
Added:
let start = body (get c "/logbook?feedback=start") in
21
Added:
let token = Option.get (csrf_token start) in
22
Added:
(* The session is at step 0; post step 3 instead. *)
23
Added:
let mismatched =
24
Added:
post c "/feedback"
25
Added:
[
26
Added:
("dream.csrf", token);
27
Added:
("step", "3");
28
Added:
("action", "next");
29
Added:
("choice", "1");
30
Added:
]
31
Added:
in
32
Added:
Alcotest.(check int)
33
Added:
"mismatched step redirects" 303 (status mismatched);
34
Added:
Alcotest.(check string)
35
Added:
"stale feedback returns to the logbook" "/logbook"
36
Added:
(location mismatched);
37
Added:
(* The mismatched post advanced nothing and stored no report. *)
38
Added:
Alcotest.(check int)
39
Added:
"no feedback stored" 0
40
Added:
(List.length
41
Added:
(Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)))
42
Added:
);
43
Added:
( "answering every factor stores exactly one signal per category",
44
Added:
`Quick,
45
Added:
fun () ->
46
Added:
(* The flow admits one answer per factor, so the stored report holds
47
Added:
one signal per category and never a duplicate. *)
48
Added:
let c, repo = client_with_repo () in
49
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
50
Added:
let trainee = the_trainee repo ~username:"lifter" in
51
Added:
let _ = get c "/logbook?feedback=start" in
52
Added:
let rec advance step =
53
Added:
if step < 2 then begin
54
Added:
let token = Option.get (csrf_token (body (get c "/logbook"))) in
55
Added:
let _ =
56
Added:
post c "/feedback"
57
Added:
[
58
Added:
("dream.csrf", token);
59
Added:
("step", string_of_int step);
60
Added:
("action", "next");
61
Added:
("choice", "worse");
62
Added:
]
63
Added:
in
64
Added:
advance (step + 1)
65
Added:
end
66
Added:
in
67
Added:
advance 0;
68
Added:
let token = Option.get (csrf_token (body (get c "/logbook"))) in
69
Added:
let saved =
70
Added:
post c "/feedback"
71
Added:
[ ("dream.csrf", token); ("step", "2"); ("action", "save") ]
72
Added:
in
73
Added:
Alcotest.(check int) "final save redirects" 303 (status saved);
74
Added:
(* Exactly one report, with one signal per distinct factor. *)
75
Added:
let reports =
76
Added:
Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)
77
Added:
in
78
Added:
Alcotest.(check int) "one report stored" 1 (List.length reports);
79
Added:
let signals = Feedback.signals (List.hd reports) in
80
Added:
let count p = List.length (List.filter p signals) in
81
Added:
let open Feedback in
82
Added:
Alcotest.(check int)
83
Added:
"one motivation signal" 1
84
Added:
(count (function Motivation _ -> true | _ -> false));
85
Added:
Alcotest.(check int)
86
Added:
"one difficulty signal" 1
87
Added:
(count (function Difficulty _ -> true | _ -> false)) );
88
Added:
] );
89
Added:
]
test/web/errors.ml
@@ -0,0 +1,23 @@
1
Added:
open Support
2
Added:
3
Added:
let suite =
4
Added:
[
5
Added:
( "web.errors",
6
Added:
[
7
Added:
( "an unknown path responds 404",
8
Added:
`Quick,
9
Added:
fun () ->
10
Added:
let c = client () in
11
Added:
let _ = sign_in_new c in
12
Added:
Alcotest.(check int)
13
Added:
"responds 404" 404
14
Added:
(status (get c "/no-such-page")) );
15
Added:
( "the 404 response never depends on a session",
16
Added:
`Quick,
17
Added:
fun () ->
18
Added:
let c = client () in
19
Added:
Alcotest.(check int)
20
Added:
"unauthenticated 404" 404
21
Added:
(status (get c "/deep/unknown/path")) );
22
Added:
] );
23
Added:
]
test/web/flow.ml
@@ -0,0 +1,572 @@
1
Added:
open Hito_app
2
Added:
open Support
3
Added:
4
Added:
let suite =
5
Added:
[
6
Added:
( "web.flow",
7
Added:
[
8
Added:
( "the logbook shows the action button group and an empty table state",
9
Added:
`Quick,
10
Added:
fun () ->
11
Added:
let c = client () in
12
Added:
let _ = sign_in_new c in
13
Added:
let page = body (get c "/logbook") in
14
Added:
Alcotest.(check bool)
15
Added:
"Log feedback action" true
16
Added:
(Option.is_some (index_from ~needle:"Log feedback" page 0));
17
Added:
Alcotest.(check bool)
18
Added:
"Edit logbook action" true
19
Added:
(Option.is_some (index_from ~needle:"Edit logbook" page 0));
20
Added:
Alcotest.(check bool)
21
Added:
"the button group is present" true
22
Added:
(Option.is_some
23
Added:
(index_from ~needle:"class=\"button-group\"" page 0));
24
Added:
Alcotest.(check bool)
25
Added:
"empty state when nothing is logged" true
26
Added:
(Option.is_some (index_from ~needle:"Nothing logged yet." page 0))
27
Added:
);
28
Added:
( "a finished workout appears in the logbook table with a progress \
29
Added:
column",
30
Added:
`Quick,
31
Added:
fun () ->
32
Added:
let c = client () in
33
Added:
let _ = sign_in_new c in
34
Added:
let _ = start_day_one c in
35
Added:
record_all_day_one_slots c;
36
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
37
Added:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
38
Added:
let page = body (get c "/logbook") in
39
Added:
Alcotest.(check bool)
40
Added:
"the logbook table is present" true
41
Added:
(Option.is_some
42
Added:
(index_from ~needle:"class=\"logbook-table\"" page 0));
43
Added:
Alcotest.(check bool)
44
Added:
"the progressed-exercises column header" true
45
Added:
(Option.is_some
46
Added:
(index_from ~needle:"Exercises progressed" page 0)) );
47
Added:
( "selecting a routine redirects and records the active routine",
48
Added:
`Quick,
49
Added:
fun () ->
50
Added:
(* POST-redirect-GET: selecting a routine answers 303, and the
51
Added:
redirected GET is served. The domain effect is what matters: the
52
Added:
trainee now has an active routine. *)
53
Added:
let c, repo = client_with_repo () in
54
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
55
Added:
let trainee = the_trainee repo ~username:"lifter" in
56
Added:
Alcotest.(check bool)
57
Added:
"no active routine before selection" true
58
Added:
(Option.is_none
59
Added:
(Lwt_main.run
60
Added:
(Memory_repo.active_routine repo trainee.Trainee.id)));
61
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
62
Added:
let selection =
63
Added:
post c "/routines/ideal/select" [ ("dream.csrf", token) ]
64
Added:
in
65
Added:
Alcotest.(check int) "selection redirects" 303 (status selection);
66
Added:
Alcotest.(check bool)
67
Added:
"a routine is now active" true
68
Added:
(Option.is_some
69
Added:
(Lwt_main.run
70
Added:
(Memory_repo.active_routine repo trainee.Trainee.id)));
71
Added:
(* The redirected GET is served. *)
72
Added:
Alcotest.(check int)
73
Added:
"the redirected GET is 200" 200
74
Added:
(status (get c "/")) );
75
Added:
( "a signed-in trainee selects a routine and begins a workout",
76
Added:
`Quick,
77
Added:
fun () ->
78
Added:
let c, repo = client_with_repo () in
79
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
80
Added:
let trainee = the_trainee repo ~username:"lifter" in
81
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
82
Added:
let selection =
83
Added:
post c "/routines/ideal/select" [ ("dream.csrf", token) ]
84
Added:
in
85
Added:
Alcotest.(check int) "routine selected" 303 (status selection);
86
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
87
Added:
let started =
88
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
89
Added:
in
90
Added:
Alcotest.(check int) "workout started" 303 (status started);
91
Added:
(* The workout is now in progress in the domain, and its view is
92
Added:
served. *)
93
Added:
Alcotest.(check bool)
94
Added:
"a workout is in progress" true
95
Added:
(Option.is_some
96
Added:
(Lwt_main.run
97
Added:
(Memory_repo.in_progress repo trainee.Trainee.id)));
98
Added:
Alcotest.(check int)
99
Added:
"the workout view is served" 200
100
Added:
(status (get c "/workout"));
101
Added:
(* The static workout client asset is served. *)
102
Added:
let asset = get c "/assets/workout-client.js" in
103
Added:
Alcotest.(check int) "serves the workout client" 200 (status asset)
104
Added:
);
105
Added:
( "the routine page is served once a routine is selected",
106
Added:
`Quick,
107
Added:
fun () ->
108
Added:
let c = client () in
109
Added:
let _ = sign_in_new c in
110
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
111
Added:
let selection =
112
Added:
post c "/routines/ideal/select" [ ("dream.csrf", token) ]
113
Added:
in
114
Added:
Alcotest.(check int) "routine selected" 303 (status selection);
115
Added:
Alcotest.(check int)
116
Added:
"routine page served" 200
117
Added:
(status (get c "/routine")) );
118
Added:
( "a recorded slot can be corrected, replacing it rather than adding \
119
Added:
volume",
120
Added:
`Quick,
121
Added:
fun () ->
122
Added:
let c, repo = client_with_repo () in
123
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
124
Added:
let trainee = the_trainee repo ~username:"lifter" in
125
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
126
Added:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
127
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
128
Added:
let _ =
129
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
130
Added:
in
131
Added:
(* Slot 1 is the single Laterals set. Record it, then correct it —
132
Added:
one slot at a time, addressed by [?slot=]. *)
133
Added:
let token =
134
Added:
Option.get (csrf_token (body (get c "/workout?slot=1")))
135
Added:
in
136
Added:
let recorded =
137
Added:
post c "/workout/slots/1"
138
Added:
[
139
Added:
("dream.csrf", token);
140
Added:
("load", "12");
141
Added:
("reps", "8");
142
Added:
("extension", "");
143
Added:
]
144
Added:
in
145
Added:
Alcotest.(check int) "recorded" 303 (status recorded);
146
Added:
let filled_after_record () =
147
Added:
match
148
Added:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
149
Added:
with
150
Added:
| Some w -> Evidence.Workout.filled_slots w
151
Added:
| None -> Alcotest.failf "expected a workout in progress"
152
Added:
in
153
Added:
Alcotest.(check int) "one filled slot" 1 (filled_after_record ());
154
Added:
let token =
155
Added:
Option.get (csrf_token (body (get c "/workout?slot=1")))
156
Added:
in
157
Added:
let corrected =
158
Added:
post c "/workout/slots/1/edit"
159
Added:
[
160
Added:
("dream.csrf", token);
161
Added:
("load", "16");
162
Added:
("reps", "6");
163
Added:
("extension", "");
164
Added:
]
165
Added:
in
166
Added:
Alcotest.(check int) "corrected" 303 (status corrected);
167
Added:
(* A correction replaces the slot; it does not add volume. *)
168
Added:
Alcotest.(check int)
169
Added:
"still one filled slot, not two" 1 (filled_after_record ()) );
170
Added:
( "a saved workout's slot can be corrected from the logbook view",
171
Added:
`Quick,
172
Added:
fun () ->
173
Added:
let c, repo = client_with_repo () in
174
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
175
Added:
let trainee = the_trainee repo ~username:"lifter" in
176
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
177
Added:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
178
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
179
Added:
let _ =
180
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
181
Added:
in
182
Added:
let token =
183
Added:
Option.get (csrf_token (body (get c "/workout?slot=1")))
184
Added:
in
185
Added:
let _ =
186
Added:
post c "/workout/slots/1"
187
Added:
[
188
Added:
("dream.csrf", token);
189
Added:
("load", "12");
190
Added:
("reps", "8");
191
Added:
("extension", "");
192
Added:
]
193
Added:
in
194
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
195
Added:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
196
Added:
(* The one saved workout is w1 for this trainee. Correct its slot
197
Added:
through the logbook path, then confirm the store still has one
198
Added:
filled slot — a correction, not extra volume. *)
199
Added:
let record_page = body (get c "/logbook/w1?slot=1") in
200
Added:
let token = Option.get (csrf_token record_page) in
201
Added:
let corrected =
202
Added:
post c "/logbook/w1/slots/1/edit"
203
Added:
[
204
Added:
("dream.csrf", token);
205
Added:
("load", "20");
206
Added:
("reps", "7");
207
Added:
("extension", "");
208
Added:
]
209
Added:
in
210
Added:
Alcotest.(check int) "corrected" 303 (status corrected);
211
Added:
let record =
212
Added:
Lwt_main.run
213
Added:
(Memory_repo.find repo trainee.Trainee.id
214
Added:
(Repository.workout_id "w1"))
215
Added:
in
216
Added:
Alcotest.(check int)
217
Added:
"still one filled slot" 1
218
Added:
(match record with
219
Added:
| Some r -> Evidence.Workout.filled_slots r.Repository.workout
220
Added:
| None -> Alcotest.failf "expected the saved workout w1") );
221
Added:
( "an invalid workout field is rejected and records nothing",
222
Added:
`Quick,
223
Added:
fun () ->
224
Added:
let c, repo = client_with_repo () in
225
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
226
Added:
let trainee = the_trainee repo ~username:"lifter" in
227
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
228
Added:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
229
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
230
Added:
let _ =
231
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
232
Added:
in
233
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
234
Added:
let invalid =
235
Added:
post c "/workout/slots/0"
236
Added:
[
237
Added:
("dream.csrf", token);
238
Added:
("iso_load", "not-a-number");
239
Added:
("iso_reps", "8");
240
Added:
("comp_load", "40");
241
Added:
("comp_reps", "6");
242
Added:
("extension", "");
243
Added:
]
244
Added:
in
245
Added:
Alcotest.(check int) "invalid field redirects" 303 (status invalid);
246
Added:
(* The bad input recorded no slot. *)
247
Added:
Alcotest.(check int)
248
Added:
"no slot was filled" 0
249
Added:
(match
250
Added:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
251
Added:
with
252
Added:
| Some w -> Evidence.Workout.filled_slots w
253
Added:
| None -> Alcotest.failf "expected a workout in progress") );
254
Added:
( "recording a slot advances the count of filled slots",
255
Added:
`Quick,
256
Added:
fun () ->
257
Added:
let c, repo = client_with_repo () in
258
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
259
Added:
let trainee = the_trainee repo ~username:"lifter" in
260
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
261
Added:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
262
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
263
Added:
let _ =
264
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
265
Added:
in
266
Added:
let filled () =
267
Added:
match
268
Added:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
269
Added:
with
270
Added:
| Some w -> Evidence.Workout.filled_slots w
271
Added:
| None -> Alcotest.failf "expected a workout in progress"
272
Added:
in
273
Added:
Alcotest.(check int) "nothing recorded yet" 0 (filled ());
274
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
275
Added:
let recorded =
276
Added:
post c "/workout/slots/0"
277
Added:
[
278
Added:
("dream.csrf", token);
279
Added:
("iso_load", "10");
280
Added:
("iso_reps", "8");
281
Added:
("comp_load", "40");
282
Added:
("comp_reps", "6");
283
Added:
("extension", "");
284
Added:
]
285
Added:
in
286
Added:
Alcotest.(check int) "recorded slot 0" 303 (status recorded);
287
Added:
Alcotest.(check int) "one slot filled" 1 (filled ()) );
288
Added:
( "signing out returns the trainee to the sign-in page",
289
Added:
`Quick,
290
Added:
fun () ->
291
Added:
let c = client () in
292
Added:
let _ = sign_in_new c in
293
Added:
let page = body (get c "/") in
294
Added:
let token = Option.get (csrf_token page) in
295
Added:
let out = post c "/logout" [ ("dream.csrf", token) ] in
296
Added:
Alcotest.(check int) "logout redirect" 303 (status out);
297
Added:
let after = get c "/" in
298
Added:
Alcotest.(check int) "overview now redirects" 303 (status after);
299
Added:
Alcotest.(check string) "to /login" "/login" (location after) );
300
Added:
( "cancelling a workout without a CSRF token leaves it in progress",
301
Added:
`Quick,
302
Added:
fun () ->
303
Added:
let c, repo = client_with_repo () in
304
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
305
Added:
let trainee = the_trainee repo ~username:"lifter" in
306
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
307
Added:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
308
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
309
Added:
let _ =
310
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
311
Added:
in
312
Added:
let response = post c "/workout/cancel" [ (* no dream.csrf *) ] in
313
Added:
(* Cancelling always navigates away to Home. A forged or missing
314
Added:
token skips the discard, so the workout remains in progress. *)
315
Added:
Alcotest.(check int)
316
Added:
"navigates away without an error page" 303 (status response);
317
Added:
Alcotest.(check bool)
318
Added:
"returns Home" true
319
Added:
(List.mem "/" (Dream.headers response "Location"));
320
Added:
Alcotest.(check bool)
321
Added:
"workout still in progress" true
322
Added:
(Option.is_some
323
Added:
(Lwt_main.run
324
Added:
(Memory_repo.in_progress repo trainee.Trainee.id))) );
325
Added:
( "cancelling after recording a set discards the workout entirely",
326
Added:
`Quick,
327
Added:
fun () ->
328
Added:
let c, repo = client_with_repo () in
329
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
330
Added:
let trainee = the_trainee repo ~username:"lifter" in
331
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
332
Added:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
333
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
334
Added:
let _ =
335
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
336
Added:
in
337
Added:
let token =
338
Added:
Option.get (csrf_token (body (get c "/workout?slot=1")))
339
Added:
in
340
Added:
let recorded =
341
Added:
post c "/workout/slots/1"
342
Added:
[
343
Added:
("dream.csrf", token);
344
Added:
("load", "12");
345
Added:
("reps", "8");
346
Added:
("extension", "");
347
Added:
]
348
Added:
in
349
Added:
Alcotest.(check int) "recorded a set" 303 (status recorded);
350
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
351
Added:
let cancelled =
352
Added:
post c "/workout/cancel" [ ("dream.csrf", token) ]
353
Added:
in
354
Added:
Alcotest.(check int) "cancel returns Home" 303 (status cancelled);
355
Added:
Alcotest.(check bool)
356
Added:
"returns Home, not the logbook" true
357
Added:
(List.mem "/" (Dream.headers cancelled "Location"));
358
Added:
(* No current workout, and no record: an abandoned session is not
359
Added:
evidence. *)
360
Added:
Alcotest.(check bool)
361
Added:
"no workout in progress" true
362
Added:
(Option.is_none
363
Added:
(Lwt_main.run
364
Added:
(Memory_repo.in_progress repo trainee.Trainee.id)));
365
Added:
Alcotest.(check int)
366
Added:
"history is empty" 0
367
Added:
(List.length
368
Added:
(Lwt_main.run (Memory_repo.history repo trainee.Trainee.id)));
369
Added:
Alcotest.(check int)
370
Added:
"the discarded workout has no record" 404
371
Added:
(status (get c "/logbook/w1")) );
372
Added:
( "sequential feedback stores only answered factors, never skipped ones",
373
Added:
`Quick,
374
Added:
fun () ->
375
Added:
let c, repo = client_with_repo () in
376
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
377
Added:
let trainee = the_trainee repo ~username:"lifter" in
378
Added:
let _ = get c "/logbook?feedback=start" in
379
Added:
let step_action step action extra =
380
Added:
let token = Option.get (csrf_token (body (get c "/logbook"))) in
381
Added:
post c "/feedback"
382
Added:
(("dream.csrf", token)
383
Added:
:: ("step", string_of_int step)
384
Added:
:: ("action", action) :: extra)
385
Added:
in
386
Added:
let first = step_action 0 "next" [ ("choice", "better") ] in
387
Added:
Alcotest.(check int) "first factor redirects" 303 (status first);
388
Added:
let _ = step_action 1 "skip" [] in
389
Added:
let saved = step_action 2 "save" [] in
390
Added:
Alcotest.(check int) "final feedback redirects" 303 (status saved);
391
Added:
let reports =
392
Added:
Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)
393
Added:
in
394
Added:
Alcotest.(check int)
395
Added:
"one feedback report stored" 1 (List.length reports);
396
Added:
let signal_list = Feedback.signals (List.hd reports) in
397
Added:
Alcotest.(check (list bool))
398
Added:
"only motivation stored" [ true ]
399
Added:
(List.map
400
Added:
(function
401
Added:
| Feedback.Motivation Feedback.Better_than_usual -> true
402
Added:
| _ -> false)
403
Added:
signal_list) );
404
Added:
( "skipping the entire feedback flow records nothing",
405
Added:
`Quick,
406
Added:
fun () ->
407
Added:
let c, repo = client_with_repo () in
408
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
409
Added:
let trainee = the_trainee repo ~username:"lifter" in
410
Added:
let start = body (get c "/logbook?feedback=start") in
411
Added:
let token = Option.get (csrf_token start) in
412
Added:
let skipped = post c "/feedback/cancel" [ ("dream.csrf", token) ] in
413
Added:
Alcotest.(check int) "full-flow skip redirects" 303 (status skipped);
414
Added:
Alcotest.(check int)
415
Added:
"no feedback report was stored" 0
416
Added:
(List.length
417
Added:
(Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)))
418
Added:
);
419
Added:
( "back keeps an earlier answer, which still persists on save",
420
Added:
`Quick,
421
Added:
fun () ->
422
Added:
let c, repo = client_with_repo () in
423
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
424
Added:
let trainee = the_trainee repo ~username:"lifter" in
425
Added:
let _ = get c "/logbook?feedback=start" in
426
Added:
let step_action step action extra =
427
Added:
let token = Option.get (csrf_token (body (get c "/logbook"))) in
428
Added:
post c "/feedback"
429
Added:
(("dream.csrf", token)
430
Added:
:: ("step", string_of_int step)
431
Added:
:: ("action", action) :: extra)
432
Added:
in
433
Added:
(* Answer motivation, move to difficulty, return, then skip
434
Added:
motivation and difficulty before saving. The earlier motivation
435
Added:
answer remains in the flow. *)
436
Added:
let _ = step_action 0 "next" [ ("choice", "better") ] in
437
Added:
let back = step_action 1 "back" [] in
438
Added:
Alcotest.(check int) "back redirects" 303 (status back);
439
Added:
let _ = step_action 0 "skip" [] in
440
Added:
let _ = step_action 1 "skip" [] in
441
Added:
let _ = step_action 2 "save" [] in
442
Added:
let reports =
443
Added:
Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)
444
Added:
in
445
Added:
Alcotest.(check int) "one report stored" 1 (List.length reports);
446
Added:
let signals = Feedback.signals (List.hd reports) in
447
Added:
Alcotest.(check bool)
448
Added:
"the pre-back motivation answer persists" true
449
Added:
(List.exists
450
Added:
(function
451
Added:
| Feedback.Motivation Feedback.Better_than_usual -> true
452
Added:
| _ -> false)
453
Added:
signals) );
454
Added:
( "closing the feedback modal discards the flow",
455
Added:
`Quick,
456
Added:
fun () ->
457
Added:
let c, repo = client_with_repo () in
458
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
459
Added:
let trainee = the_trainee repo ~username:"lifter" in
460
Added:
let start = body (get c "/logbook?feedback=start") in
461
Added:
let token = Option.get (csrf_token start) in
462
Added:
let _ =
463
Added:
post c "/feedback"
464
Added:
[
465
Added:
("dream.csrf", token);
466
Added:
("step", "0");
467
Added:
("action", "next");
468
Added:
("choice", "better");
469
Added:
]
470
Added:
in
471
Added:
let appetite = body (get c "/logbook") in
472
Added:
let token = Option.get (csrf_token appetite) in
473
Added:
let closed = post c "/feedback/cancel" [ ("dream.csrf", token) ] in
474
Added:
Alcotest.(check int) "close redirects" 303 (status closed);
475
Added:
(* A discarded flow stores nothing. *)
476
Added:
Alcotest.(check int)
477
Added:
"no feedback report stored" 0
478
Added:
(List.length
479
Added:
(Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)))
480
Added:
);
481
Added:
( "finishing a workout redirects to the logbook feedback prompt",
482
Added:
`Quick,
483
Added:
fun () ->
484
Added:
let c, repo = client_with_repo () in
485
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
486
Added:
let trainee = the_trainee repo ~username:"lifter" in
487
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
488
Added:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
489
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
490
Added:
let _ =
491
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
492
Added:
in
493
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
494
Added:
let finished = post c "/workout/finish" [ ("dream.csrf", token) ] in
495
Added:
Alcotest.(check int) "finish redirects" 303 (status finished);
496
Added:
Alcotest.(check bool)
497
Added:
"redirects to the logbook with a feedback prompt" true
498
Added:
(List.mem "/logbook?prompt=feedback"
499
Added:
(Dream.headers finished "Location"));
500
Added:
(* The workout is now in history and no longer in progress. *)
501
Added:
Alcotest.(check int)
502
Added:
"one workout in history" 1
503
Added:
(List.length
504
Added:
(Lwt_main.run (Memory_repo.history repo trainee.Trainee.id)));
505
Added:
Alcotest.(check bool)
506
Added:
"nothing in progress" true
507
Added:
(Option.is_none
508
Added:
(Lwt_main.run
509
Added:
(Memory_repo.in_progress repo trainee.Trainee.id))) );
510
Added:
( "beginning before recovery is refused without an override",
511
Added:
`Quick,
512
Added:
fun () ->
513
Added:
let c, repo = client_with_repo () in
514
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
515
Added:
let trainee = the_trainee repo ~username:"lifter" in
516
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
517
Added:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
518
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
519
Added:
let _ =
520
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
521
Added:
in
522
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
523
Added:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
524
Added:
(* Recovery has not elapsed. Beginning the next workout without an
525
Added:
override is bounced back to Home and starts nothing. *)
526
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
527
Added:
let refused =
528
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
529
Added:
in
530
Added:
Alcotest.(check int) "early begin bounced" 303 (status refused);
531
Added:
Alcotest.(check bool)
532
Added:
"returns Home, not the workout" true
533
Added:
(List.mem "/" (Dream.headers refused "Location"));
534
Added:
Alcotest.(check bool)
535
Added:
"no new workout in progress" true
536
Added:
(Option.is_none
537
Added:
(Lwt_main.run
538
Added:
(Memory_repo.in_progress repo trainee.Trainee.id))) );
539
Added:
( "overriding recovery begins the next workout on an override basis",
540
Added:
`Quick,
541
Added:
fun () ->
542
Added:
let c, repo = client_with_repo () in
543
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
544
Added:
let trainee = the_trainee repo ~username:"lifter" in
545
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
546
Added:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
547
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
548
Added:
let _ =
549
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
550
Added:
in
551
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
552
Added:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
553
Added:
(* Recovery has not elapsed, so the next workout is begun under an
554
Added:
explicit override. The deviation is recorded on the workout's
555
Added:
clearance basis, never silent. *)
556
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
557
Added:
let began =
558
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "true") ]
559
Added:
in
560
Added:
Alcotest.(check int) "override begin succeeds" 303 (status began);
561
Added:
let basis =
562
Added:
match
563
Added:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
564
Added:
with
565
Added:
| Some w -> Recovery.basis (Evidence.Workout.clearance w)
566
Added:
| None -> Alcotest.failf "expected a workout in progress"
567
Added:
in
568
Added:
Alcotest.(check bool)
569
Added:
"the workout carries an override basis" true
570
Added:
(match basis with Recovery.Overridden _ -> true | _ -> false) );
571
Added:
] );
572
Added:
]
test/web/import.ml
@@ -0,0 +1,383 @@
1
Added:
open Hito_app
2
Added:
open Support
3
Added:
4
Added:
let suite =
5
Added:
[
6
Added:
( "web.import",
7
Added:
(* The Hevy import web flow, end to end. Each test drives the multipart
8
Added:
upload and the review POSTs, then asserts status, redirect location,
9
Added:
and Repository state — never rendered HTML. The CSRF token is read from
10
Added:
the profile page body, as a browser would. *)
11
Added:
let header =
12
Added:
"title,start_time,end_time,description,exercise_title,superset_id,exercise_notes,set_index,set_type,weight_kg,reps,distance_km,duration_seconds,rpe\r\n"
13
Added:
in
14
Added:
(* One native row. Datetimes are Hevy local wall time. *)
15
Added:
let row ~title ~exercise ~set_type ~weight ~reps ?(set_index = 0)
16
Added:
?(start = "01 Jan 2024, 10:00") ?(finish = "01 Jan 2024, 11:00") () =
17
Added:
Printf.sprintf "%s,%S,%S,,%s,,,%d,%s,%s,%d,,,\r\n" title start finish
18
Added:
exercise set_index set_type weight reps
19
Added:
in
20
Added:
let csv rows = header ^ String.concat "" rows in
21
Added:
(* Register, then read a CSRF token from the profile page. *)
22
Added:
let signed_in_profile_token c =
23
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
24
Added:
Option.get (csrf_token (body (get c "/profile")))
25
Added:
in
26
Added:
let review_token c url = Option.get (csrf_token (body (get c url))) in
27
Added:
let batches repo trainee =
28
Added:
Lwt_main.run (Memory_repo.import_batches repo trainee.Trainee.id)
29
Added:
in
30
Added:
let imported repo trainee =
31
Added:
Lwt_main.run (Memory_repo.imported_records repo trainee.Trainee.id)
32
Added:
in
33
Added:
[
34
Added:
( "a valid native export uploads to a stored batch with immutable source",
35
Added:
`Quick,
36
Added:
fun () ->
37
Added:
let c, repo = client_with_repo () in
38
Added:
let token = signed_in_profile_token c in
39
Added:
let trainee = the_trainee repo ~username:"lifter" in
40
Added:
let source =
41
Added:
csv
42
Added:
[
43
Added:
row ~title:"Legs" ~exercise:"Barbell Squat"
44
Added:
~set_type:"failure" ~weight:"100" ~reps:8 ();
45
Added:
]
46
Added:
in
47
Added:
let response =
48
Added:
post_multipart c "/profile/import"
49
Added:
~file:(Some ("csv", "workouts.csv", source))
50
Added:
~fields:[ ("dream.csrf", token); ("utc_offset_seconds", "0") ]
51
Added:
in
52
Added:
Alcotest.(check int) "303 to review" 303 (status response);
53
Added:
Alcotest.(check bool)
54
Added:
"redirects to the review URL" true
55
Added:
(index_from ~needle:"/profile/import/" (location response) 0
56
Added:
|> Option.is_some);
57
Added:
let stored = batches repo trainee in
58
Added:
Alcotest.(check int) "one batch stored" 1 (List.length stored);
59
Added:
Alcotest.(check string)
60
Added:
"source retained verbatim" source
61
Added:
(Workout_import.batch_source (List.hd stored)) );
62
Added:
( "a duplicate upload is refused, the override stores a second batch",
63
Added:
`Quick,
64
Added:
fun () ->
65
Added:
let c, repo = client_with_repo () in
66
Added:
let token = signed_in_profile_token c in
67
Added:
let trainee = the_trainee repo ~username:"lifter" in
68
Added:
let source =
69
Added:
csv
70
Added:
[
71
Added:
row ~title:"Legs" ~exercise:"Barbell Squat"
72
Added:
~set_type:"failure" ~weight:"100" ~reps:8 ();
73
Added:
]
74
Added:
in
75
Added:
let upload ?(allow = false) () =
76
Added:
let token = Option.get (csrf_token (body (get c "/profile"))) in
77
Added:
let fields =
78
Added:
[ ("dream.csrf", token); ("utc_offset_seconds", "0") ]
79
Added:
@ if allow then [ ("allow_duplicate", "true") ] else []
80
Added:
in
81
Added:
post_multipart c "/profile/import"
82
Added:
~file:(Some ("csv", "workouts.csv", source))
83
Added:
~fields
84
Added:
in
85
Added:
ignore token;
86
Added:
let first = upload () in
87
Added:
Alcotest.(check int) "first upload 303" 303 (status first);
88
Added:
let second = upload () in
89
Added:
Alcotest.(check int)
90
Added:
"duplicate redirects to profile" 303 (status second);
91
Added:
Alcotest.(check string)
92
Added:
"duplicate lands on profile" "/profile" (location second);
93
Added:
Alcotest.(check int)
94
Added:
"still one batch after duplicate" 1
95
Added:
(List.length (batches repo trainee));
96
Added:
let overridden = upload ~allow:true () in
97
Added:
Alcotest.(check int) "override 303" 303 (status overridden);
98
Added:
let stored = batches repo trainee in
99
Added:
Alcotest.(check int)
100
Added:
"override stores a second batch" 2 (List.length stored);
101
Added:
(* The two batches have distinct ids, so the override did not
102
Added:
overwrite the original. *)
103
Added:
let ids =
104
Added:
List.map
105
Added:
(fun b ->
106
Added:
Workout_import.batch_id_to_string
107
Added:
(Workout_import.batch_identity b))
108
Added:
stored
109
Added:
in
110
Added:
Alcotest.(check bool)
111
Added:
"the two batch ids differ" true
112
Added:
(match ids with [ a; b ] -> a <> b | _ -> false) );
113
Added:
( "warmup and unsupported rows persist as warnings, not sets",
114
Added:
`Quick,
115
Added:
fun () ->
116
Added:
let c, repo = client_with_repo () in
117
Added:
let token = signed_in_profile_token c in
118
Added:
let trainee = the_trainee repo ~username:"lifter" in
119
Added:
let source =
120
Added:
csv
121
Added:
[
122
Added:
row ~title:"Legs" ~exercise:"Barbell Squat" ~set_type:"warmup"
123
Added:
~weight:"40" ~reps:10 ~set_index:0 ();
124
Added:
row ~title:"Legs" ~exercise:"Barbell Squat" ~set_type:"wibble"
125
Added:
~weight:"50" ~reps:10 ~set_index:1 ();
126
Added:
row ~title:"Legs" ~exercise:"Barbell Squat"
127
Added:
~set_type:"failure" ~weight:"100" ~reps:8 ~set_index:2 ();
128
Added:
]
129
Added:
in
130
Added:
let response =
131
Added:
post_multipart c "/profile/import"
132
Added:
~file:(Some ("csv", "workouts.csv", source))
133
Added:
~fields:[ ("dream.csrf", token); ("utc_offset_seconds", "0") ]
134
Added:
in
135
Added:
Alcotest.(check int) "303 to review" 303 (status response);
136
Added:
let batch = List.hd (batches repo trainee) in
137
Added:
(* Two warnings: the warmup and the unknown set type. *)
138
Added:
Alcotest.(check int)
139
Added:
"two rows dropped as warnings" 2
140
Added:
(List.length (Workout_import.batch_warnings batch));
141
Added:
(* The workout keeps only the one failure set; no provisional set
142
Added:
was invented for the dropped rows. *)
143
Added:
let w = List.hd (Workout_import.batch_workouts batch) in
144
Added:
Alcotest.(check int)
145
Added:
"only the failure set survives" 1
146
Added:
(List.length (Workout_import.workout_sets w)) );
147
Added:
( "map, confirm, then promote writes an imported record",
148
Added:
`Quick,
149
Added:
fun () ->
150
Added:
let c, repo = client_with_repo () in
151
Added:
let token = signed_in_profile_token c in
152
Added:
let trainee = the_trainee repo ~username:"lifter" in
153
Added:
(* A single normal set: it needs both a mapping and a normal-set
154
Added:
confirmation before it can promote. *)
155
Added:
let source =
156
Added:
csv
157
Added:
[
158
Added:
row ~title:"Legs" ~exercise:"Barbell Squat" ~set_type:"normal"
159
Added:
~weight:"100" ~reps:8 ();
160
Added:
]
161
Added:
in
162
Added:
let _ =
163
Added:
post_multipart c "/profile/import"
164
Added:
~file:(Some ("csv", "workouts.csv", source))
165
Added:
~fields:[ ("dream.csrf", token); ("utc_offset_seconds", "0") ]
166
Added:
in
167
Added:
let batch = List.hd (batches repo trainee) in
168
Added:
let bid =
169
Added:
Workout_import.batch_id_to_string
170
Added:
(Workout_import.batch_identity batch)
171
Added:
in
172
Added:
let wid =
173
Added:
Workout_import.workout_id_to_string
174
Added:
(Workout_import.workout_identity
175
Added:
(List.hd (Workout_import.batch_workouts batch)))
176
Added:
in
177
Added:
let review = "/profile/import/" ^ bid in
178
Added:
let map_url =
179
Added:
Printf.sprintf "/profile/import/%s/workouts/%s/map" bid wid
180
Added:
in
181
Added:
let t = review_token c review in
182
Added:
let _ =
183
Added:
post c map_url
184
Added:
[
185
Added:
("dream.csrf", t);
186
Added:
("source_name", "Barbell Squat");
187
Added:
("exercise_id", "squats");
188
Added:
]
189
Added:
in
190
Added:
let t = review_token c review in
191
Added:
let confirm_url =
192
Added:
Printf.sprintf "/profile/import/%s/workouts/%s/confirm" bid wid
193
Added:
in
194
Added:
let _ =
195
Added:
post c confirm_url
196
Added:
[ ("dream.csrf", t); ("acknowledgement", "clean form") ]
197
Added:
in
198
Added:
let t = review_token c review in
199
Added:
let promote_url =
200
Added:
Printf.sprintf "/profile/import/%s/workouts/%s/promote" bid wid
201
Added:
in
202
Added:
let promote = post c promote_url [ ("dream.csrf", t) ] in
203
Added:
Alcotest.(check int) "promotion redirects" 303 (status promote);
204
Added:
Alcotest.(check int)
205
Added:
"one imported record exists" 1
206
Added:
(List.length (imported repo trainee)) );
207
Added:
( "a dropset workout stays blocked and writes no record",
208
Added:
`Quick,
209
Added:
fun () ->
210
Added:
let c, repo = client_with_repo () in
211
Added:
let token = signed_in_profile_token c in
212
Added:
let trainee = the_trainee repo ~username:"lifter" in
213
Added:
let source =
214
Added:
csv
215
Added:
[
216
Added:
row ~title:"Legs" ~exercise:"Barbell Squat"
217
Added:
~set_type:"dropset" ~weight:"100" ~reps:8 ();
218
Added:
]
219
Added:
in
220
Added:
let _ =
221
Added:
post_multipart c "/profile/import"
222
Added:
~file:(Some ("csv", "workouts.csv", source))
223
Added:
~fields:[ ("dream.csrf", token); ("utc_offset_seconds", "0") ]
224
Added:
in
225
Added:
let batch = List.hd (batches repo trainee) in
226
Added:
let bid =
227
Added:
Workout_import.batch_id_to_string
228
Added:
(Workout_import.batch_identity batch)
229
Added:
in
230
Added:
let wid =
231
Added:
Workout_import.workout_id_to_string
232
Added:
(Workout_import.workout_identity
233
Added:
(List.hd (Workout_import.batch_workouts batch)))
234
Added:
in
235
Added:
let review = "/profile/import/" ^ bid in
236
Added:
(* Map the dropset's exercise so only the dropset itself blocks. *)
237
Added:
let t = review_token c review in
238
Added:
let _ =
239
Added:
post c
240
Added:
(Printf.sprintf "/profile/import/%s/workouts/%s/map" bid wid)
241
Added:
[
242
Added:
("dream.csrf", t);
243
Added:
("source_name", "Barbell Squat");
244
Added:
("exercise_id", "squats");
245
Added:
]
246
Added:
in
247
Added:
let t = review_token c review in
248
Added:
let promote =
249
Added:
post c
250
Added:
(Printf.sprintf "/profile/import/%s/workouts/%s/promote" bid wid)
251
Added:
[ ("dream.csrf", t) ]
252
Added:
in
253
Added:
Alcotest.(check int) "still a redirect" 303 (status promote);
254
Added:
Alcotest.(check int)
255
Added:
"no record written for a dropset" 0
256
Added:
(List.length (imported repo trainee)) );
257
Added:
( "a partial batch promotion promotes the eligible sibling and retains \
258
Added:
the blocked one",
259
Added:
`Quick,
260
Added:
fun () ->
261
Added:
let c, repo = client_with_repo () in
262
Added:
let token = signed_in_profile_token c in
263
Added:
let trainee = the_trainee repo ~username:"lifter" in
264
Added:
(* Two workouts: one ready failure set, one dropset that blocks. *)
265
Added:
let source =
266
Added:
csv
267
Added:
[
268
Added:
row ~title:"Legs" ~exercise:"Barbell Squat"
269
Added:
~set_type:"failure" ~weight:"100" ~reps:8
270
Added:
~start:"01 Jan 2024, 10:00" ~finish:"01 Jan 2024, 11:00" ();
271
Added:
row ~title:"Arms" ~exercise:"Barbell Curl" ~set_type:"dropset"
272
Added:
~weight:"30" ~reps:8 ~start:"02 Jan 2024, 10:00"
273
Added:
~finish:"02 Jan 2024, 11:00" ();
274
Added:
]
275
Added:
in
276
Added:
let _ =
277
Added:
post_multipart c "/profile/import"
278
Added:
~file:(Some ("csv", "workouts.csv", source))
279
Added:
~fields:[ ("dream.csrf", token); ("utc_offset_seconds", "0") ]
280
Added:
in
281
Added:
let batch = List.hd (batches repo trainee) in
282
Added:
let bid =
283
Added:
Workout_import.batch_id_to_string
284
Added:
(Workout_import.batch_identity batch)
285
Added:
in
286
Added:
let review = "/profile/import/" ^ bid in
287
Added:
(* Map the ready workout's exercise so its only blocker clears. *)
288
Added:
let ready_wid =
289
Added:
List.find_map
290
Added:
(fun w ->
291
Added:
if String.equal (Workout_import.workout_title w) "Legs" then
292
Added:
Some
293
Added:
(Workout_import.workout_id_to_string
294
Added:
(Workout_import.workout_identity w))
295
Added:
else None)
296
Added:
(Workout_import.batch_workouts batch)
297
Added:
|> Option.get
298
Added:
in
299
Added:
let t = review_token c review in
300
Added:
let _ =
301
Added:
post c
302
Added:
(Printf.sprintf "/profile/import/%s/workouts/%s/map" bid
303
Added:
ready_wid)
304
Added:
[
305
Added:
("dream.csrf", t);
306
Added:
("source_name", "Barbell Squat");
307
Added:
("exercise_id", "squats");
308
Added:
]
309
Added:
in
310
Added:
let t = review_token c review in
311
Added:
let promote =
312
Added:
post c
313
Added:
(Printf.sprintf "/profile/import/%s/promote" bid)
314
Added:
[ ("dream.csrf", t) ]
315
Added:
in
316
Added:
Alcotest.(check int)
317
Added:
"batch promotion redirects" 303 (status promote);
318
Added:
(* Only the eligible sibling is promoted. The blocked dropset
319
Added:
writes no record and stays in the batch. *)
320
Added:
Alcotest.(check int)
321
Added:
"one record from the eligible sibling" 1
322
Added:
(List.length (imported repo trainee)) );
323
Added:
( "an unknown batch GET is 404, an unknown exercise mapping changes \
324
Added:
nothing",
325
Added:
`Quick,
326
Added:
fun () ->
327
Added:
let c, repo = client_with_repo () in
328
Added:
let token = signed_in_profile_token c in
329
Added:
let trainee = the_trainee repo ~username:"lifter" in
330
Added:
(* Unknown batch id: the review GET is a 404. *)
331
Added:
ignore token;
332
Added:
Alcotest.(check int)
333
Added:
"unknown batch review is 404" 404
334
Added:
(status (get c "/profile/import/no-such-batch"));
335
Added:
(* Upload a real batch, then map to an id absent from the catalog.
336
Added:
No mapping is recorded. *)
337
Added:
let source =
338
Added:
csv
339
Added:
[
340
Added:
row ~title:"Legs" ~exercise:"Barbell Squat" ~set_type:"normal"
341
Added:
~weight:"100" ~reps:8 ();
342
Added:
]
343
Added:
in
344
Added:
let up_token = Option.get (csrf_token (body (get c "/profile"))) in
345
Added:
let _ =
346
Added:
post_multipart c "/profile/import"
347
Added:
~file:(Some ("csv", "workouts.csv", source))
348
Added:
~fields:
349
Added:
[ ("dream.csrf", up_token); ("utc_offset_seconds", "0") ]
350
Added:
in
351
Added:
let batch = List.hd (batches repo trainee) in
352
Added:
let bid =
353
Added:
Workout_import.batch_id_to_string
354
Added:
(Workout_import.batch_identity batch)
355
Added:
in
356
Added:
let wid =
357
Added:
Workout_import.workout_id_to_string
358
Added:
(Workout_import.workout_identity
359
Added:
(List.hd (Workout_import.batch_workouts batch)))
360
Added:
in
361
Added:
let review = "/profile/import/" ^ bid in
362
Added:
let t = review_token c review in
363
Added:
let response =
364
Added:
post c
365
Added:
(Printf.sprintf "/profile/import/%s/workouts/%s/map" bid wid)
366
Added:
[
367
Added:
("dream.csrf", t);
368
Added:
("source_name", "Barbell Squat");
369
Added:
("exercise_id", "not-an-exercise");
370
Added:
]
371
Added:
in
372
Added:
Alcotest.(check int)
373
Added:
"unknown exercise redirects, not errors" 303 (status response);
374
Added:
(* The stored workout still has no mapping for the source name. *)
375
Added:
let reloaded = List.hd (batches repo trainee) in
376
Added:
let w = List.hd (Workout_import.batch_workouts reloaded) in
377
Added:
Alcotest.(check bool)
378
Added:
"no mapping was recorded" true
379
Added:
(Option.is_none
380
Added:
(Workout_import.workout_mapping w ~source_name:"Barbell Squat"))
381
Added:
);
382
Added:
] );
383
Added:
]
test/web/isolation.ml
@@ -0,0 +1,77 @@
1
Added:
open Hito_app
2
Added:
open Support
3
Added:
4
Added:
let suite =
5
Added:
[
6
Added:
( "web.isolation",
7
Added:
[
8
Added:
( "two trainees never share workout or logbook state",
9
Added:
`Quick,
10
Added:
fun () ->
11
Added:
(* Two trainees on the same store, each with their own cookie jar.
12
Added:
One begins and finishes a workout; the other must see none of it:
13
Added:
not the in-progress workout, not the saved record. This proves
14
Added:
the per-trainee scoping the service promises, over HTTP. *)
15
Added:
let alice, repo = client_with_repo () in
16
Added:
let _ = register alice ~username:"alice" ~password:"heavyduty1" in
17
Added:
let bob = { alice with jar = [] } in
18
Added:
let _ = register bob ~username:"bobby" ~password:"heavyduty1" in
19
Added:
let alice_t = the_trainee repo ~username:"alice" in
20
Added:
let bob_t = the_trainee repo ~username:"bobby" in
21
Added:
(* Alice selects and begins a workout, records a slot. *)
22
Added:
let token = Option.get (csrf_token (body (get alice "/"))) in
23
Added:
let _ =
24
Added:
post alice "/routines/ideal/select" [ ("dream.csrf", token) ]
25
Added:
in
26
Added:
let token = Option.get (csrf_token (body (get alice "/"))) in
27
Added:
let _ =
28
Added:
post alice "/workout"
29
Added:
[ ("dream.csrf", token); ("override", "false") ]
30
Added:
in
31
Added:
let token =
32
Added:
Option.get (csrf_token (body (get alice "/workout?slot=1")))
33
Added:
in
34
Added:
let _ =
35
Added:
post alice "/workout/slots/1"
36
Added:
[
37
Added:
("dream.csrf", token);
38
Added:
("load", "12");
39
Added:
("reps", "8");
40
Added:
("extension", "");
41
Added:
]
42
Added:
in
43
Added:
(* Alice has a workout in progress; Bob does not. *)
44
Added:
Alcotest.(check bool)
45
Added:
"Alice has a workout in progress" true
46
Added:
(Option.is_some
47
Added:
(Lwt_main.run
48
Added:
(Memory_repo.in_progress repo alice_t.Trainee.id)));
49
Added:
Alcotest.(check bool)
50
Added:
"Bob has no workout in progress" true
51
Added:
(Option.is_none
52
Added:
(Lwt_main.run (Memory_repo.in_progress repo bob_t.Trainee.id)));
53
Added:
Alcotest.(check int)
54
Added:
"Bob's workout view redirects" 303
55
Added:
(status (get bob "/workout"));
56
Added:
(* Alice finishes; her record becomes w1 for her. *)
57
Added:
let token = Option.get (csrf_token (body (get alice "/workout"))) in
58
Added:
let _ = post alice "/workout/finish" [ ("dream.csrf", token) ] in
59
Added:
Alcotest.(check int)
60
Added:
"Alice has one saved workout" 1
61
Added:
(List.length
62
Added:
(Lwt_main.run (Memory_repo.history repo alice_t.Trainee.id)));
63
Added:
Alcotest.(check int)
64
Added:
"Alice sees her saved workout" 200
65
Added:
(status (get alice "/logbook/w1"));
66
Added:
(* Bob's history is empty, and Alice's record is unreachable from
67
Added:
Bob's session. Ids are per-trainee, so Bob's own w1 does not
68
Added:
exist. *)
69
Added:
Alcotest.(check int)
70
Added:
"Bob's history is empty" 0
71
Added:
(List.length
72
Added:
(Lwt_main.run (Memory_repo.history repo bob_t.Trainee.id)));
73
Added:
Alcotest.(check int)
74
Added:
"Bob cannot open a record he does not own" 404
75
Added:
(status (get bob "/logbook/w1")) );
76
Added:
] );
77
Added:
]
test/web/lifecycle.ml
@@ -0,0 +1,125 @@
1
Added:
open Hito_app
2
Added:
open Support
3
Added:
4
Added:
let suite =
5
Added:
[
6
Added:
( "web.lifecycle",
7
Added:
[
8
Added:
( "a full cycle: begin Day 1, record every slot, finish, and see it \
9
Added:
saved complete",
10
Added:
`Quick,
11
Added:
fun () ->
12
Added:
(* A deep end-to-end pass over the primary flow with a driven clock.
13
Added:
Begin Day 1, record all four slots, finish, and confirm the
14
Added:
logbook persists a complete Day 1 with four stimuli. The clocked
15
Added:
client and repo share a store, so the flow's domain effect is
16
Added:
read straight from history. *)
17
Added:
let c, now, repo = clocked_client () in
18
Added:
now := day 10;
19
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
20
Added:
let trainee = the_trainee repo ~username:"lifter" in
21
Added:
let _ = start_day_one c in
22
Added:
let in_progress_filled () =
23
Added:
match
24
Added:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
25
Added:
with
26
Added:
| Some w -> Evidence.Workout.filled_slots w
27
Added:
| None -> Alcotest.failf "expected a workout in progress"
28
Added:
in
29
Added:
Alcotest.(check int)
30
Added:
"opens with no slots recorded" 0 (in_progress_filled ());
31
Added:
record_all_day_one_slots c;
32
Added:
Alcotest.(check int)
33
Added:
"all four slots recorded" 4 (in_progress_filled ());
34
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
35
Added:
let finished = post c "/workout/finish" [ ("dream.csrf", token) ] in
36
Added:
Alcotest.(check int) "finish redirects" 303 (status finished);
37
Added:
Alcotest.(check bool)
38
Added:
"sends the trainee to the logbook feedback prompt" true
39
Added:
(List.mem "/logbook?prompt=feedback"
40
Added:
(Dream.headers finished "Location"));
41
Added:
(* History holds one complete Day 1 with four stimuli. *)
42
Added:
let history =
43
Added:
Lwt_main.run (Memory_repo.history repo trainee.Trainee.id)
44
Added:
in
45
Added:
Alcotest.(check int)
46
Added:
"one workout in history" 1 (List.length history);
47
Added:
let saved = (List.hd history).Repository.workout in
48
Added:
Alcotest.(check string)
49
Added:
"the saved workout is Day 1" "Day 1"
50
Added:
(Prescription.Workout.name (Evidence.Workout.prescription saved));
51
Added:
Alcotest.(check int)
52
Added:
"records four stimuli" 4
53
Added:
(List.length (Evidence.Workout.stimuli saved));
54
Added:
Alcotest.(check bool)
55
Added:
"the saved workout is complete" true
56
Added:
(Evidence.Workout.completeness saved = Evidence.Workout.Complete);
57
Added:
(* The saved workout is durable and reachable at its own URL. *)
58
Added:
Alcotest.(check int)
59
Added:
"the saved workout is reachable" 200
60
Added:
(status (get c "/logbook/w1")) );
61
Added:
( "the recovery gate blocks the next workout until enough rest, then \
62
Added:
Day 2 begins",
63
Added:
`Quick,
64
Added:
fun () ->
65
Added:
(* The deepest flow: after finishing Day 1, the next workout is
66
Added:
gated until 48 hours of recovery pass. The web tier drives the
67
Added:
clock, so this proves the gate over HTTP, not just in the
68
Added:
service. Beginning too early is refused; resting past the
69
Added:
interval clears the gate and advances the cycle to Day 2. *)
70
Added:
let c, now, repo = clocked_client () in
71
Added:
now := day 10;
72
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
73
Added:
let trainee = the_trainee repo ~username:"lifter" in
74
Added:
let _ = start_day_one c in
75
Added:
record_all_day_one_slots c;
76
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
77
Added:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
78
Added:
(* One hour later: recovery is far from complete. Beginning without
79
Added:
an override is refused and starts nothing. *)
80
Added:
now := day 10 + 3600;
81
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
82
Added:
let refused =
83
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
84
Added:
in
85
Added:
Alcotest.(check int)
86
Added:
"an early begin is bounced back" 303 (status refused);
87
Added:
Alcotest.(check bool)
88
Added:
"the early begin returns Home, not the workout" true
89
Added:
(List.mem "/" (Dream.headers refused "Location"));
90
Added:
Alcotest.(check bool)
91
Added:
"no workout was started" true
92
Added:
(Option.is_none
93
Added:
(Lwt_main.run
94
Added:
(Memory_repo.in_progress repo trainee.Trainee.id)));
95
Added:
(* Rest two full days: past the 48-hour training interval. The gate
96
Added:
clears and the next begin succeeds. *)
97
Added:
now := day 13;
98
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
99
Added:
let began =
100
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
101
Added:
in
102
Added:
Alcotest.(check int) "the rested begin succeeds" 303 (status began);
103
Added:
Alcotest.(check bool)
104
Added:
"the rested begin reaches the workout" true
105
Added:
(List.mem "/workout" (Dream.headers began "Location"));
106
Added:
(* The cycle has advanced to Day 2, cleared on recovery, not an
107
Added:
override. *)
108
Added:
let workout =
109
Added:
match
110
Added:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
111
Added:
with
112
Added:
| Some w -> w
113
Added:
| None -> Alcotest.failf "expected a workout in progress"
114
Added:
in
115
Added:
Alcotest.(check string)
116
Added:
"the cycle advanced to Day 2" "Day 2"
117
Added:
(Prescription.Workout.name
118
Added:
(Evidence.Workout.prescription workout));
119
Added:
Alcotest.(check bool)
120
Added:
"cleared on recovery, not an override" true
121
Added:
(match Recovery.basis (Evidence.Workout.clearance workout) with
122
Added:
| Recovery.Recovered -> true
123
Added:
| Recovery.Overridden _ -> false) );
124
Added:
] );
125
Added:
]
test/web/profile.ml
@@ -0,0 +1,141 @@
1
Added:
open Hito_app
2
Added:
open Support
3
Added:
4
Added:
let suite =
5
Added:
[
6
Added:
( "web.profile",
7
Added:
[
8
Added:
( "the profile page is served for a signed-in trainee",
9
Added:
`Quick,
10
Added:
fun () ->
11
Added:
let c = client () in
12
Added:
let _ = sign_in_new c in
13
Added:
Alcotest.(check int)
14
Added:
"profile served" 200
15
Added:
(status (get c "/profile")) );
16
Added:
( "changing the username updates the stored account",
17
Added:
`Quick,
18
Added:
fun () ->
19
Added:
let c, repo = client_with_repo () in
20
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
21
Added:
let trainee = the_trainee repo ~username:"lifter" in
22
Added:
let token = Option.get (csrf_token (body (get c "/profile"))) in
23
Added:
let changed =
24
Added:
post c "/profile/username"
25
Added:
[ ("dream.csrf", token); ("username", "athlete") ]
26
Added:
in
27
Added:
Alcotest.(check int)
28
Added:
"redirects after the change" 303 (status changed);
29
Added:
Alcotest.(check bool)
30
Added:
"redirects back to the profile with a notice" true
31
Added:
(List.mem "/profile?changed=username"
32
Added:
(Dream.headers changed "Location"));
33
Added:
(* The account now answers to the new name, and no longer to the
34
Added:
old one. *)
35
Added:
let renamed =
36
Added:
Lwt_main.run (Memory_repo.find_trainee repo trainee.Trainee.id)
37
Added:
in
38
Added:
Alcotest.(check (option string))
39
Added:
"stored under the new username" (Some "athlete")
40
Added:
(Option.map
41
Added:
(fun t -> Trainee.username_to_string t.Trainee.username)
42
Added:
renamed);
43
Added:
Alcotest.(check bool)
44
Added:
"old name no longer resolves" true
45
Added:
(Option.is_none
46
Added:
(Lwt_main.run
47
Added:
(match Trainee.username "lifter" with
48
Added:
| Ok u -> Memory_repo.find_trainee_by_username repo u
49
Added:
| Error _ -> Lwt.return None))) );
50
Added:
( "a taken username is refused and the account keeps its name",
51
Added:
`Quick,
52
Added:
fun () ->
53
Added:
let c, repo = client_with_repo () in
54
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
55
Added:
let trainee = the_trainee repo ~username:"lifter" in
56
Added:
(* Register a second account in the same store. *)
57
Added:
let other = { c with jar = [] } in
58
Added:
let _ = register other ~username:"taken" ~password:"heavyduty1" in
59
Added:
let token = Option.get (csrf_token (body (get c "/profile"))) in
60
Added:
let refused =
61
Added:
post c "/profile/username"
62
Added:
[ ("dream.csrf", token); ("username", "taken") ]
63
Added:
in
64
Added:
Alcotest.(check int)
65
Added:
"renders an invalid response" 400 (status refused);
66
Added:
(* The account still holds its original name. *)
67
Added:
Alcotest.(check (option string))
68
Added:
"name unchanged after refusal" (Some "lifter")
69
Added:
(Option.map
70
Added:
(fun t -> Trainee.username_to_string t.Trainee.username)
71
Added:
(Lwt_main.run
72
Added:
(Memory_repo.find_trainee repo trainee.Trainee.id))) );
73
Added:
( "changing the password requires the current one",
74
Added:
`Quick,
75
Added:
fun () ->
76
Added:
let c = client () in
77
Added:
let _ = sign_in_new c in
78
Added:
let token = Option.get (csrf_token (body (get c "/profile"))) in
79
Added:
let refused =
80
Added:
post c "/profile/password"
81
Added:
[
82
Added:
("dream.csrf", token);
83
Added:
("current", "wrongpass");
84
Added:
("next", "newsecret1");
85
Added:
]
86
Added:
in
87
Added:
Alcotest.(check int)
88
Added:
"renders an invalid response" 400 (status refused);
89
Added:
(* Now change it with the correct current password. *)
90
Added:
let token = Option.get (csrf_token (body (get c "/profile"))) in
91
Added:
let changed =
92
Added:
post c "/profile/password"
93
Added:
[
94
Added:
("dream.csrf", token);
95
Added:
("current", "heavyduty1");
96
Added:
("next", "newsecret1");
97
Added:
]
98
Added:
in
99
Added:
Alcotest.(check int)
100
Added:
"redirects after the change" 303 (status changed);
101
Added:
Alcotest.(check bool)
102
Added:
"redirects back to the profile with a notice" true
103
Added:
(List.mem "/profile?changed=password"
104
Added:
(Dream.headers changed "Location"));
105
Added:
(* The new password now authenticates and the old one no longer
106
Added:
does. Sign out, then prove the change through the sign-in flow. *)
107
Added:
let token = Option.get (csrf_token (body (get c "/profile"))) in
108
Added:
let _ = post c "/logout" [ ("dream.csrf", token) ] in
109
Added:
let old_pw = sign_in c ~username:"lifter" ~password:"heavyduty1" in
110
Added:
Alcotest.(check int)
111
Added:
"the old password no longer works" 401 (status old_pw);
112
Added:
let new_pw = sign_in c ~username:"lifter" ~password:"newsecret1" in
113
Added:
Alcotest.(check int)
114
Added:
"the new password authenticates" 303 (status new_pw) );
115
Added:
( "the settings page is separate from the profile page",
116
Added:
`Quick,
117
Added:
fun () ->
118
Added:
let c = client () in
119
Added:
let _ = sign_in_new c in
120
Added:
Alcotest.(check int)
121
Added:
"settings served" 200
122
Added:
(status (get c "/settings"));
123
Added:
Alcotest.(check int)
124
Added:
"profile served separately" 200
125
Added:
(status (get c "/profile")) );
126
Added:
( "the settings theme form redirects after a valid update",
127
Added:
`Quick,
128
Added:
fun () ->
129
Added:
let c = client () in
130
Added:
let _ = sign_in_new c in
131
Added:
let token = Option.get (csrf_token (body (get c "/settings"))) in
132
Added:
let updated =
133
Added:
post c "/settings/theme"
134
Added:
[ ("dream.csrf", token); ("theme", "dark") ]
135
Added:
in
136
Added:
Alcotest.(check int) "theme update redirects" 303 (status updated);
137
Added:
Alcotest.(check string)
138
Added:
"returns to settings" "/settings"
139
Added:
(List.hd (Dream.headers updated "Location")) );
140
Added:
] );
141
Added:
]
test/web/routine_selection.ml
@@ -0,0 +1,27 @@
1
Added:
open Hito_app
2
Added:
open Support
3
Added:
4
Added:
let suite =
5
Added:
[
6
Added:
( "web.routine_selection",
7
Added:
[
8
Added:
( "selecting an unknown routine is not found and selects nothing",
9
Added:
`Quick,
10
Added:
fun () ->
11
Added:
let c, repo = client_with_repo () in
12
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
13
Added:
let trainee = the_trainee repo ~username:"lifter" in
14
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
15
Added:
let response =
16
Added:
post c "/routines/no-such-routine/select"
17
Added:
[ ("dream.csrf", token) ]
18
Added:
in
19
Added:
Alcotest.(check int) "responds 404" 404 (status response);
20
Added:
(* A missing routine leaves the trainee with no active routine. *)
21
Added:
Alcotest.(check bool)
22
Added:
"no routine was selected" true
23
Added:
(Option.is_none
24
Added:
(Lwt_main.run
25
Added:
(Memory_repo.active_routine repo trainee.Trainee.id))) );
26
Added:
] );
27
Added:
]
test/web/saved_record_add.ml
@@ -0,0 +1,122 @@
1
Added:
open Hito_app
2
Added:
open Support
3
Added:
4
Added:
let suite =
5
Added:
[
6
Added:
( "web.saved_record_add",
7
Added:
[
8
Added:
( "an outstanding slot of a saved workout can be recorded, not only \
9
Added:
corrected",
10
Added:
`Quick,
11
Added:
fun () ->
12
Added:
(* Finish a workout with a single slot recorded, so the saved record
13
Added:
still has outstanding slots. Then record one of those through the
14
Added:
plain add path [POST /logbook/:id/slots/:d], which the edit tests
15
Added:
never exercise. *)
16
Added:
let c, repo = client_with_repo () in
17
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
18
Added:
let trainee = the_trainee repo ~username:"lifter" in
19
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
20
Added:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
21
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
22
Added:
let _ =
23
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
24
Added:
in
25
Added:
(* Record only slot 1, then finish. Slots 0, 2, 3 stay outstanding. *)
26
Added:
let token =
27
Added:
Option.get (csrf_token (body (get c "/workout?slot=1")))
28
Added:
in
29
Added:
let _ =
30
Added:
post c "/workout/slots/1"
31
Added:
[
32
Added:
("dream.csrf", token);
33
Added:
("load", "12");
34
Added:
("reps", "8");
35
Added:
("extension", "");
36
Added:
]
37
Added:
in
38
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
39
Added:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
40
Added:
let filled_of_w1 () =
41
Added:
match
42
Added:
Lwt_main.run
43
Added:
(Memory_repo.find repo trainee.Trainee.id
44
Added:
(Repository.workout_id "w1"))
45
Added:
with
46
Added:
| Some r -> Evidence.Workout.filled_slots r.Repository.workout
47
Added:
| None -> Alcotest.failf "expected the saved workout w1"
48
Added:
in
49
Added:
Alcotest.(check int)
50
Added:
"saved workout starts with one slot" 1 (filled_of_w1 ());
51
Added:
(* Add slot 2 through the non-edit path. *)
52
Added:
let token =
53
Added:
Option.get (csrf_token (body (get c "/logbook/w1?slot=2")))
54
Added:
in
55
Added:
let added =
56
Added:
post c "/logbook/w1/slots/2"
57
Added:
[
58
Added:
("dream.csrf", token);
59
Added:
("load", "10");
60
Added:
("reps", "9");
61
Added:
("extension", "");
62
Added:
]
63
Added:
in
64
Added:
Alcotest.(check int)
65
Added:
"recorded a saved-workout slot" 303 (status added);
66
Added:
Alcotest.(check int) "now two filled slots" 2 (filled_of_w1 ()) );
67
Added:
( "recording an already-filled slot through the add path is refused",
68
Added:
`Quick,
69
Added:
fun () ->
70
Added:
(* The add path lists only outstanding slots. A filled slot is not
71
Added:
awaiting a record, so posting to it is a 404, not a silent second
72
Added:
entry that would add volume. *)
73
Added:
let c, repo = client_with_repo () in
74
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
75
Added:
let trainee = the_trainee repo ~username:"lifter" in
76
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
77
Added:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
78
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
79
Added:
let _ =
80
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
81
Added:
in
82
Added:
let token =
83
Added:
Option.get (csrf_token (body (get c "/workout?slot=1")))
84
Added:
in
85
Added:
let _ =
86
Added:
post c "/workout/slots/1"
87
Added:
[
88
Added:
("dream.csrf", token);
89
Added:
("load", "12");
90
Added:
("reps", "8");
91
Added:
("extension", "");
92
Added:
]
93
Added:
in
94
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
95
Added:
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
96
Added:
(* Slot 1 is filled. Re-posting to its add path is refused. *)
97
Added:
let token =
98
Added:
Option.get (csrf_token (body (get c "/logbook/w1?slot=2")))
99
Added:
in
100
Added:
let refused =
101
Added:
post c "/logbook/w1/slots/1"
102
Added:
[
103
Added:
("dream.csrf", token);
104
Added:
("load", "20");
105
Added:
("reps", "6");
106
Added:
("extension", "");
107
Added:
]
108
Added:
in
109
Added:
Alcotest.(check int)
110
Added:
"filled slot is not awaiting" 404 (status refused);
111
Added:
(* The refused post added no volume: still one filled slot. *)
112
Added:
Alcotest.(check int)
113
Added:
"still one filled slot" 1
114
Added:
(match
115
Added:
Lwt_main.run
116
Added:
(Memory_repo.find repo trainee.Trainee.id
117
Added:
(Repository.workout_id "w1"))
118
Added:
with
119
Added:
| Some r -> Evidence.Workout.filled_slots r.Repository.workout
120
Added:
| None -> Alcotest.failf "expected the saved workout w1") );
121
Added:
] );
122
Added:
]
test/web/sign_in.ml
@@ -0,0 +1,75 @@
1
Added:
open Support
2
Added:
3
Added:
let suite =
4
Added:
[
5
Added:
( "web.sign_in",
6
Added:
[
7
Added:
( "a returning trainee signs in with their credentials",
8
Added:
`Quick,
9
Added:
fun () ->
10
Added:
(* Register, then sign out, then sign back in through the credential
11
Added:
form. This exercises [POST /login], which registration's
12
Added:
auto-sign-in never touches. *)
13
Added:
let c = client () in
14
Added:
let _ = sign_in_new c in
15
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
16
Added:
let _ = post c "/logout" [ ("dream.csrf", token) ] in
17
Added:
Alcotest.(check int)
18
Added:
"signed out, overview redirects" 303
19
Added:
(status (get c "/"));
20
Added:
let signed_in =
21
Added:
sign_in c ~username:"lifter" ~password:"heavyduty1"
22
Added:
in
23
Added:
Alcotest.(check int) "sign-in redirects" 303 (status signed_in);
24
Added:
Alcotest.(check bool)
25
Added:
"sign-in lands on Home" true
26
Added:
(List.mem "/" (Dream.headers signed_in "Location"));
27
Added:
Alcotest.(check int)
28
Added:
"authenticated overview" 200
29
Added:
(status (get c "/")) );
30
Added:
( "a wrong password is refused and establishes no session",
31
Added:
`Quick,
32
Added:
fun () ->
33
Added:
let c = client () in
34
Added:
let _ = sign_in_new c in
35
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
36
Added:
let _ = post c "/logout" [ ("dream.csrf", token) ] in
37
Added:
let refused =
38
Added:
sign_in c ~username:"lifter" ~password:"not-the-password"
39
Added:
in
40
Added:
Alcotest.(check int) "rejected" 401 (status refused);
41
Added:
(* The rejected attempt establishes no session. *)
42
Added:
Alcotest.(check int)
43
Added:
"still unauthenticated" 303
44
Added:
(status (get c "/")) );
45
Added:
( "an unknown username is refused like a wrong password",
46
Added:
`Quick,
47
Added:
fun () ->
48
Added:
let c = client () in
49
Added:
let refused = sign_in c ~username:"nobody" ~password:"heavyduty1" in
50
Added:
Alcotest.(check int) "rejected" 401 (status refused);
51
Added:
Alcotest.(check int)
52
Added:
"no session established" 303
53
Added:
(status (get c "/")) );
54
Added:
( "an already-authenticated visit to the sign-in page redirects Home",
55
Added:
`Quick,
56
Added:
fun () ->
57
Added:
let c = client () in
58
Added:
let _ = sign_in_new c in
59
Added:
let response = get c "/login" in
60
Added:
Alcotest.(check int) "redirects" 303 (status response);
61
Added:
Alcotest.(check bool)
62
Added:
"sends an authenticated visitor Home" true
63
Added:
(List.mem "/" (Dream.headers response "Location")) );
64
Added:
( "an already-authenticated visit to the register page redirects Home",
65
Added:
`Quick,
66
Added:
fun () ->
67
Added:
let c = client () in
68
Added:
let _ = sign_in_new c in
69
Added:
let response = get c "/register" in
70
Added:
Alcotest.(check int) "redirects" 303 (status response);
71
Added:
Alcotest.(check bool)
72
Added:
"sends an authenticated visitor Home" true
73
Added:
(List.mem "/" (Dream.headers response "Location")) );
74
Added:
] );
75
Added:
]
test/web/slot_bounds.ml
@@ -0,0 +1,75 @@
1
Added:
open Hito_app
2
Added:
open Support
3
Added:
4
Added:
let suite =
5
Added:
[
6
Added:
( "web.slot_bounds",
7
Added:
[
8
Added:
( "posting to a slot beyond the workout is not found",
9
Added:
`Quick,
10
Added:
fun () ->
11
Added:
(* Day 1 has four slots (0..3). Slot 9 does not exist, so the log
12
Added:
handler answers 404 rather than recording phantom volume. *)
13
Added:
let c, repo = client_with_repo () in
14
Added:
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
15
Added:
let trainee = the_trainee repo ~username:"lifter" in
16
Added:
let _ = start_day_one c in
17
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
18
Added:
let response =
19
Added:
post c "/workout/slots/9"
20
Added:
[
21
Added:
("dream.csrf", token);
22
Added:
("load", "10");
23
Added:
("reps", "8");
24
Added:
("extension", "");
25
Added:
]
26
Added:
in
27
Added:
Alcotest.(check int)
28
Added:
"out-of-range slot is not found" 404 (status response);
29
Added:
(* No phantom volume was recorded. *)
30
Added:
Alcotest.(check int)
31
Added:
"nothing recorded" 0
32
Added:
(match
33
Added:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
34
Added:
with
35
Added:
| Some w -> Evidence.Workout.filled_slots w
36
Added:
| None -> Alcotest.failf "expected a workout in progress") );
37
Added:
( "editing a slot beyond the workout is not found",
38
Added:
`Quick,
39
Added:
fun () ->
40
Added:
let c = client () in
41
Added:
let _ = sign_in_new c in
42
Added:
let _ = start_day_one c in
43
Added:
let token = Option.get (csrf_token (body (get c "/workout"))) in
44
Added:
let response =
45
Added:
post c "/workout/slots/9/edit"
46
Added:
[
47
Added:
("dream.csrf", token);
48
Added:
("load", "10");
49
Added:
("reps", "8");
50
Added:
("extension", "");
51
Added:
]
52
Added:
in
53
Added:
Alcotest.(check int)
54
Added:
"out-of-range edit is not found" 404 (status response) );
55
Added:
( "logging with no workout in progress is not found",
56
Added:
`Quick,
57
Added:
fun () ->
58
Added:
let c = client () in
59
Added:
let _ = sign_in_new c in
60
Added:
(* No routine selected, no workout begun: the CSRF token comes from
61
Added:
Home, but the slot route has no workout to record against. *)
62
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
63
Added:
let response =
64
Added:
post c "/workout/slots/0"
65
Added:
[
66
Added:
("dream.csrf", token);
67
Added:
("load", "10");
68
Added:
("reps", "8");
69
Added:
("extension", "");
70
Added:
]
71
Added:
in
72
Added:
Alcotest.(check int) "no workout is not found" 404 (status response)
73
Added:
);
74
Added:
] );
75
Added:
]
test/web/support.ml
@@ -0,0 +1,251 @@
1
Added:
(** Shared support for the web tier tests. Sessions and CSRF are exercised end
2
Added:
to end: a small client carries the session cookie between requests and pulls
3
Added:
the CSRF token out of the rendered page, exactly as a browser would. The
4
Added:
in-memory repository stands in for SQLite; session storage is Dream's
5
Added:
in-memory back end. *)
6
Added:
7
Added:
open Hito_app
8
Added:
open Hito_persistence
9
Added:
module Handlers = Hito_web.Handlers.Make (Memory_repo) (Bcrypt_hash)
10
Added:
11
Added:
(* A fresh, fully wired application: secret, in-memory sessions, routes.
12
Added:
Registration is opened here so the auth-flow tests can create trainees via
13
Added:
[/register]; production keeps it closed. *)
14
Added:
let app () =
15
Added:
let handlers =
16
Added:
Handlers.make ~repo:(Memory_repo.create ()) ~registration_open:true ()
17
Added:
in
18
Added:
Dream.memory_sessions @@ Dream.router (Handlers.routes handlers)
19
Added:
|> fun handler -> Dream.set_secret "test-secret-value" handler
20
Added:
21
Added:
let status response = Dream.status response |> Dream.status_to_int
22
Added:
let body response = Lwt_main.run (Dream.body response)
23
Added:
24
Added:
(* The redirect target of a 3xx response — the URL half of a URL-to-URL flow. *)
25
Added:
let location response =
26
Added:
match Dream.header response "Location" with
27
Added:
| Some target -> target
28
Added:
| None -> Alcotest.failf "expected a Location header on a redirect"
29
Added:
30
Added:
(* --- a cookie-carrying client --- *)
31
Added:
32
Added:
(* Extract cookies (name=value) from all Set-Cookie response headers. *)
33
Added:
let cookies_of response =
34
Added:
Dream.headers response "Set-Cookie"
35
Added:
|> List.filter_map (fun sc ->
36
Added:
match String.index_opt sc ';' with
37
Added:
| Some i -> Some (String.sub sc 0 i)
38
Added:
| None -> Some sc)
39
Added:
40
Added:
type client = { app : Dream.handler; mutable jar : string list }
41
Added:
42
Added:
let client () = { app = app (); jar = [] }
43
Added:
44
Added:
let cookie_header client =
45
Added:
if client.jar = [] then [] else [ ("Cookie", String.concat "; " client.jar) ]
46
Added:
47
Added:
let remember client response =
48
Added:
(* Replace cookies of the same name; keep the rest. *)
49
Added:
List.iter
50
Added:
(fun fresh ->
51
Added:
let name =
52
Added:
match String.index_opt fresh '=' with
53
Added:
| Some i -> String.sub fresh 0 i
54
Added:
| None -> fresh
55
Added:
in
56
Added:
client.jar <-
57
Added:
fresh
58
Added:
:: List.filter
59
Added:
(fun old ->
60
Added:
not
61
Added:
(String.length old >= String.length name
62
Added:
&& String.sub old 0 (String.length name) = name
63
Added:
&& (String.length old = String.length name
64
Added:
|| old.[String.length name] = '=')))
65
Added:
client.jar)
66
Added:
(cookies_of response)
67
Added:
68
Added:
let get client target =
69
Added:
let response =
70
Added:
Dream.test client.app
71
Added:
(Dream.request ~method_:`GET ~target ~headers:(cookie_header client) "")
72
Added:
in
73
Added:
remember client response;
74
Added:
response
75
Added:
76
Added:
let post client target fields =
77
Added:
let body =
78
Added:
fields
79
Added:
|> List.map (fun (k, v) ->
80
Added:
Dream.to_percent_encoded k ^ "=" ^ Dream.to_percent_encoded v)
81
Added:
|> String.concat "&"
82
Added:
in
83
Added:
let response =
84
Added:
Dream.test client.app
85
Added:
(Dream.request ~method_:`POST ~target
86
Added:
~headers:
87
Added:
(("Content-Type", "application/x-www-form-urlencoded")
88
Added:
:: cookie_header client)
89
Added:
body)
90
Added:
in
91
Added:
remember client response;
92
Added:
response
93
Added:
94
Added:
(* A multipart/form-data POST. [file] is [(field, filename, content)]; [fields]
95
Added:
are plain text parts. The CSRF token rides as its own text part, exactly as
96
Added:
[Dream.csrf_tag] renders it into a browser form, so [Dream.multipart ~csrf]
97
Added:
verifies it. The boundary is fixed but improbable in the body. *)
98
Added:
let post_multipart client target ~file ~fields =
99
Added:
let boundary = "----hitotestboundary7Xk2p" in
100
Added:
let buf = Buffer.create 1024 in
101
Added:
let part_field (name, value) =
102
Added:
Buffer.add_string buf ("--" ^ boundary ^ "\r\n");
103
Added:
Buffer.add_string buf
104
Added:
(Printf.sprintf "Content-Disposition: form-data; name=%S\r\n\r\n" name);
105
Added:
Buffer.add_string buf value;
106
Added:
Buffer.add_string buf "\r\n"
107
Added:
in
108
Added:
List.iter part_field fields;
109
Added:
(match file with
110
Added:
| Some (name, filename, content) ->
111
Added:
Buffer.add_string buf ("--" ^ boundary ^ "\r\n");
112
Added:
Buffer.add_string buf
113
Added:
(Printf.sprintf
114
Added:
"Content-Disposition: form-data; name=%S; filename=%S\r\n" name
115
Added:
filename);
116
Added:
Buffer.add_string buf "Content-Type: text/csv\r\n\r\n";
117
Added:
Buffer.add_string buf content;
118
Added:
Buffer.add_string buf "\r\n"
119
Added:
| None -> ());
120
Added:
Buffer.add_string buf ("--" ^ boundary ^ "--\r\n");
121
Added:
let response =
122
Added:
Dream.test client.app
123
Added:
(Dream.request ~method_:`POST ~target
124
Added:
~headers:
125
Added:
(("Content-Type", "multipart/form-data; boundary=" ^ boundary)
126
Added:
:: cookie_header client)
127
Added:
(Buffer.contents buf))
128
Added:
in
129
Added:
remember client response;
130
Added:
response
131
Added:
132
Added:
let index_from ~needle haystack start =
133
Added:
let n = String.length needle and h = String.length haystack in
134
Added:
let rec at i =
135
Added:
if i + n > h then None
136
Added:
else if String.sub haystack i n = needle then Some i
137
Added:
else at (i + 1)
138
Added:
in
139
Added:
if start < 0 then None else at start
140
Added:
141
Added:
(* Pull the CSRF token value out of a rendered form. *)
142
Added:
let csrf_token html =
143
Added:
match index_from ~needle:"name=\"dream.csrf\"" html 0 with
144
Added:
| None -> None
145
Added:
| Some idx -> (
146
Added:
match index_from ~needle:"value=\"" html idx with
147
Added:
| None -> None
148
Added:
| Some v ->
149
Added:
let start = v + String.length "value=\"" in
150
Added:
let stop = String.index_from html start '"' in
151
Added:
Some (String.sub html start (stop - start)))
152
Added:
153
Added:
let register client ~username ~password =
154
Added:
let page = body (get client "/register") in
155
Added:
let token = Option.get (csrf_token page) in
156
Added:
post client "/register"
157
Added:
[ ("dream.csrf", token); ("username", username); ("password", password) ]
158
Added:
159
Added:
let sign_in_new client =
160
Added:
register client ~username:"lifter" ~password:"heavyduty1"
161
Added:
162
Added:
(* Sign in through the credential form, as a returning trainee would. Unlike
163
Added:
[register], this exercises the [POST /login] path. *)
164
Added:
let sign_in client ~username ~password =
165
Added:
let page = body (get client "/login") in
166
Added:
let token = Option.get (csrf_token page) in
167
Added:
post client "/login"
168
Added:
[ ("dream.csrf", token); ("username", username); ("password", password) ]
169
Added:
170
Added:
(* An application whose clock the test drives. A shared [Memory_repo] and a
171
Added:
mutable [now] cell let a deep test advance time across the recovery gate,
172
Added:
which the wall-clock default cannot. Registration is open so the test can
173
Added:
create the trainee it drives. Also hands back the repository, so a deep test
174
Added:
can assert the domain state its flow produced. *)
175
Added:
let clocked_client () =
176
Added:
let now = ref 0 in
177
Added:
let repo = Memory_repo.create () in
178
Added:
let handlers =
179
Added:
Handlers.make ~repo
180
Added:
~now:(fun () -> Recovery.timestamp_of_unix_seconds !now)
181
Added:
~registration_open:true ()
182
Added:
in
183
Added:
let app =
184
Added:
Dream.memory_sessions @@ Dream.router (Handlers.routes handlers) |> fun h ->
185
Added:
Dream.set_secret "test-secret-value" h
186
Added:
in
187
Added:
({ app; jar = [] }, now, repo)
188
Added:
189
Added:
let day n = n * 86_400
190
Added:
191
Added:
(* A client that hands back its repository, so a test can assert the domain
192
Added:
state the flow produced — the log, the stored feedback, the renamed account —
193
Added:
rather than reading it back out of rendered HTML. *)
194
Added:
let client_with_repo () =
195
Added:
let repo = Memory_repo.create () in
196
Added:
let handlers = Handlers.make ~repo ~registration_open:true () in
197
Added:
let app =
198
Added:
Dream.memory_sessions @@ Dream.router (Handlers.routes handlers) |> fun h ->
199
Added:
Dream.set_secret "test-secret-value" h
200
Added:
in
201
Added:
({ app; jar = [] }, repo)
202
Added:
203
Added:
(* Look up the sole seeded trainee by the name the flow helpers register. *)
204
Added:
let the_trainee repo ~username =
205
Added:
match Trainee.username username with
206
Added:
| Error _ -> Alcotest.failf "test username %S is invalid" username
207
Added:
| Ok u -> (
208
Added:
match Lwt_main.run (Memory_repo.find_trainee_by_username repo u) with
209
Added:
| Some trainee -> trainee
210
Added:
| None -> Alcotest.failf "no trainee named %S" username)
211
Added:
212
Added:
(* Drive a trainee to the start of a fresh Day 1 workout: select the ideal
213
Added:
routine and begin without an override. Returns the client. *)
214
Added:
let start_day_one c =
215
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
216
Added:
let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in
217
Added:
let token = Option.get (csrf_token (body (get c "/"))) in
218
Added:
post c "/workout" [ ("dream.csrf", token); ("override", "false") ]
219
Added:
220
Added:
(* Record every slot of the in-progress Day 1 workout, one at a time, addressed
221
Added:
by [?slot=]. Slot 0 is the flyes/incline-press pair; slot 3 is the
222
Added:
french-press/dips pair; slots 1 and 2 are single lateral movements. *)
223
Added:
let record_all_day_one_slots c =
224
Added:
let record_pair slot comp_load =
225
Added:
let token =
226
Added:
Option.get (csrf_token (body (get c ("/workout?slot=" ^ slot))))
227
Added:
in
228
Added:
post c ("/workout/slots/" ^ slot)
229
Added:
[
230
Added:
("dream.csrf", token);
231
Added:
("iso_load", "20");
232
Added:
("iso_reps", "9");
233
Added:
("comp_load", comp_load);
234
Added:
("comp_reps", "7");
235
Added:
("extension", "");
236
Added:
]
237
Added:
in
238
Added:
let record_single slot load reps =
239
Added:
let token =
240
Added:
Option.get (csrf_token (body (get c ("/workout?slot=" ^ slot))))
241
Added:
in
242
Added:
post c ("/workout/slots/" ^ slot)
243
Added:
[
244
Added:
("dream.csrf", token); ("load", load); ("reps", reps); ("extension", "");
245
Added:
]
246
Added:
in
247
Added:
let _ = record_pair "0" "60" in
248
Added:
let _ = record_single "1" "12" "8" in
249
Added:
let _ = record_single "2" "10" "9" in
250
Added:
let _ = record_pair "3" "0" in
251
Added:
()