[OCaml] High Intensity Training Online
feat apply flash-backed post redirects
Changed files
lib/web/handlers.ml
@@ -16,12 +16,25 @@
16
16
let make ~repo ?(now = default_now) ?(registration_open = false) () =
17
17
{ service = Service.make ~repo; now; registration_open }
18
18
19
Added:
let flash_key = "hito.flash"
19
20
let html ?status page = Dream_html.respond ?status page
20
21
let redirect request path = Dream_html.redirect request path
21
22
22
23
let redirect_to request path =
23
24
redirect request (Dream_html.path_attr Dream_html.HTML.href path)
24
25
26
Added:
let redirect_with_flash request path message =
27
Added:
Dream.set_session_field request flash_key message >>= fun () ->
28
Added:
redirect_to request path
29
Added:
30
Added:
let redirect_with_flash_attr request path message =
31
Added:
Dream.set_session_field request flash_key message >>= fun () ->
32
Added:
redirect request path
33
Added:
34
Added:
let redirect_with_flash_raw request path message =
35
Added:
Dream.set_session_field request flash_key message >>= fun () ->
36
Added:
Dream.redirect request path
37
Added:
25
38
let not_found detail =
26
39
html (Pages.problem ~title:"Not found" ~detail) ~status:`Not_Found
27
40
@@ -87,7 +100,12 @@
87
100
route regardless of how many captures Dream passes. *)
88
101
let authenticated t request handler =
89
102
current_trainee t request >>= function
90
Removed:
| Some trainee -> handler trainee
103
Added:
| Some trainee -> (
104
Added:
handler trainee >>= fun response ->
105
Added:
match Dream.method_ request with
106
Added:
| `GET ->
107
Added:
Dream.drop_session_field request flash_key >|= fun () -> response
108
Added:
| _ -> Lwt.return response)
91
109
| None -> redirect_to request Routes.login
92
110
93
111
let decode_form decoder request =
@@ -273,12 +291,12 @@
273
291
274
292
let select_routine t trainee request id =
275
293
guard_csrf request >>= function
276
Removed:
| Error _ -> bad_request Present.form_invalid
294
Added:
| Error _ -> redirect_with_flash request Routes.home Present.form_invalid
277
295
| Ok () -> (
278
296
Service.select_routine t.service trainee.Trainee.id
279
297
(Repository.routine_id id)
280
298
>>= function
281
Removed:
| Ok () -> redirect_to request Routes.home
299
Added:
| Ok () -> redirect_with_flash request Routes.home "Routine selected."
282
300
| Error _ -> not_found Present.unknown_routine)
283
301
284
302
let routine t trainee request =
@@ -308,7 +326,7 @@
308
326
module Current_workout = struct
309
327
let begin_workout t trainee request =
310
328
decode_form Decode.override request >>= function
311
Removed:
| Error _ -> bad_request Present.form_invalid
329
Added:
| Error _ -> redirect_with_flash request Routes.home Present.form_invalid
312
330
| Ok override -> (
313
331
Service.active_routine t.service trainee.Trainee.id >>= function
314
332
| None -> redirect_to request Routes.routines
@@ -317,9 +335,11 @@
317
335
Service.begin_workout t.service trainee.Trainee.id ~routine
318
336
~now:(t.now ()) ?override ()
319
337
>>= function
320
Removed:
| Ok _ -> redirect_to request Routes.workout
338
Added:
| Ok _ ->
339
Added:
redirect_with_flash request Routes.workout "Workout started."
321
340
| Error (Service.Not_recovered _) ->
322
Removed:
redirect_to request Routes.home
341
Added:
redirect_with_flash request Routes.home
342
Added:
"The workout needs an explicit recovery override."
323
343
| Error Service.Unknown_routine ->
324
344
not_found Present.unknown_routine))
325
345
@@ -341,14 +361,17 @@
341
361
| Some prescription -> (
342
362
decode_form (Decode.stimulus prescription) request >>= function
343
363
| Error (`Invalid errors) ->
344
Removed:
html ~status:`Bad_Request
345
Removed:
(Pages.workout request ~trainee ~errors ~editing:slot
346
Removed:
~record_id:None ~active_slot:slot workout)
347
Removed:
| Error `Bad_request -> bad_request Present.form_invalid
364
Added:
redirect_with_flash request Routes.workout
365
Added:
(Decode.errors_to_text errors)
366
Added:
| Error `Bad_request ->
367
Added:
redirect_with_flash request Routes.workout
368
Added:
Present.form_invalid
348
369
| Ok stimulus -> (
349
370
save_current t trainee.Trainee.id stimulus >>= function
350
Removed:
| Ok () -> redirect_to request Routes.workout
351
Removed:
| Error detail -> bad_request detail)))
371
Added:
| Ok () ->
372
Added:
redirect_with_flash request Routes.workout "Record saved."
373
Added:
| Error detail ->
374
Added:
redirect_with_flash request Routes.workout detail)))
352
375
353
376
(* Correct a recorded slot of the workout in progress. The slot may be
354
377
filled, so its prescription comes from the workout, not [outstanding].
@@ -362,34 +385,41 @@
362
385
| Some prescription -> (
363
386
decode_form (Decode.stimulus prescription) request >>= function
364
387
| Error (`Invalid errors) ->
365
Removed:
html ~status:`Bad_Request
366
Removed:
(Pages.workout request ~trainee ~errors ~editing:slot
367
Removed:
~record_id:None ~active_slot:slot workout)
368
Removed:
| Error `Bad_request -> bad_request Present.form_invalid
388
Added:
redirect_with_flash request Routes.workout
389
Added:
(Decode.errors_to_text errors)
390
Added:
| Error `Bad_request ->
391
Added:
redirect_with_flash request Routes.workout
392
Added:
Present.form_invalid
369
393
| Ok stimulus -> (
370
394
replace_current t trainee.Trainee.id ~slot stimulus
371
395
>>= function
372
Removed:
| Ok () -> redirect_to request Routes.workout
373
Removed:
| Error detail -> bad_request detail)))
396
Added:
| Ok () ->
397
Added:
redirect_with_flash request Routes.workout "Record saved."
398
Added:
| Error detail ->
399
Added:
redirect_with_flash request Routes.workout detail)))
374
400
375
401
let finish t trainee request =
376
402
guard_csrf request >>= function
377
Removed:
| Error _ -> bad_request Present.form_invalid
403
Added:
| Error _ -> redirect_with_flash request Routes.home Present.form_invalid
378
404
| Ok () -> (
379
405
Service.finish t.service trainee.Trainee.id ~ended_at:(t.now ())
380
406
>>= function
381
Removed:
| Some _ -> Dream.redirect request "/logbook?prompt=feedback"
382
Removed:
| None -> not_found Present.no_workout)
407
Added:
| Some _ ->
408
Added:
redirect_with_flash_raw request "/logbook?prompt=feedback"
409
Added:
"Workout finished."
410
Added:
| None -> redirect_with_flash request Routes.home Present.no_workout)
383
411
384
412
(* Cancelling discards the current workout and returns Home. An abandoned
385
413
session is not evidence, so it leaves no record. A forged or missing
386
414
CSRF token skips the discard but still leaves the workout view. *)
387
415
let cancel t trainee request =
388
416
guard_csrf request >>= function
389
Removed:
| Error _ -> redirect_to request Routes.home
417
Added:
| Error _ ->
418
Added:
redirect_with_flash request Routes.home
419
Added:
"Workout cancellation was not confirmed."
390
420
| Ok () ->
391
421
Service.cancel t.service trainee.Trainee.id >>= fun _ ->
392
Removed:
redirect_to request Routes.home
422
Added:
redirect_with_flash request Routes.home "Workout cancelled."
393
423
394
424
let routes t =
395
425
[
@@ -430,13 +460,15 @@
430
460
signal category is rejected by the domain. *)
431
461
let record_feedback t trainee request =
432
462
decode_form Decode.feedback request >>= function
433
Removed:
| Error _ -> bad_request Present.form_invalid
463
Added:
| Error _ ->
464
Added:
redirect_with_flash request Routes.logbook Present.form_invalid
434
465
| Ok signals -> (
435
466
Service.record_feedback t.service trainee.Trainee.id
436
467
~reported_at:(t.now ()) signals
437
468
>>= function
438
Removed:
| Ok _ -> redirect_to request Routes.logbook
439
Removed:
| Error _ -> bad_request Present.form_invalid)
469
Added:
| Ok _ -> redirect_with_flash request Routes.logbook "Feedback saved."
470
Added:
| Error _ ->
471
Added:
redirect_with_flash request Routes.logbook Present.form_invalid)
440
472
441
473
let show t trainee request id =
442
474
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
@@ -459,18 +491,26 @@
459
491
| Some prescription -> (
460
492
decode_form (Decode.stimulus prescription) request >>= function
461
493
| Error (`Invalid errors) ->
462
Removed:
html ~status:`Bad_Request
463
Removed:
(Pages.workout request ~trainee ~errors ~editing:slot
464
Removed:
~record_id:(Some id) ~active_slot:slot workout)
465
Removed:
| Error `Bad_request -> bad_request Present.form_invalid
494
Added:
redirect_with_flash_attr request
495
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record id)
496
Added:
(Decode.errors_to_text errors)
497
Added:
| Error `Bad_request ->
498
Added:
redirect_with_flash_attr request
499
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record id)
500
Added:
Present.form_invalid
466
501
| Ok stimulus -> (
467
502
save_record t trainee.Trainee.id record_id stimulus
468
503
>>= function
469
504
| Ok () ->
470
Removed:
redirect request
505
Added:
redirect_with_flash_attr request
471
506
(Dream_html.path_attr Dream_html.HTML.href Routes.record
472
507
id)
473
Removed:
| Error detail -> bad_request detail)))
508
Added:
"Record saved."
509
Added:
| Error detail ->
510
Added:
redirect_with_flash_attr request
511
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
512
Added:
id)
513
Added:
detail)))
474
514
475
515
(* Correct a recorded slot of a saved workout. [replace_record] targets the
476
516
slot, replacing its record rather than appending volume. *)
@@ -483,18 +523,26 @@
483
523
| Some prescription -> (
484
524
decode_form (Decode.stimulus prescription) request >>= function
485
525
| Error (`Invalid errors) ->
486
Removed:
html ~status:`Bad_Request
487
Removed:
(Pages.workout request ~trainee ~errors ~editing:slot
488
Removed:
~record_id:(Some id) ~active_slot:slot workout)
489
Removed:
| Error `Bad_request -> bad_request Present.form_invalid
526
Added:
redirect_with_flash_attr request
527
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record id)
528
Added:
(Decode.errors_to_text errors)
529
Added:
| Error `Bad_request ->
530
Added:
redirect_with_flash_attr request
531
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record id)
532
Added:
Present.form_invalid
490
533
| Ok stimulus -> (
491
534
replace_record t trainee.Trainee.id record_id ~slot stimulus
492
535
>>= function
493
536
| Ok () ->
494
Removed:
redirect request
537
Added:
redirect_with_flash_attr request
495
538
(Dream_html.path_attr Dream_html.HTML.href Routes.record
496
539
id)
497
Removed:
| Error detail -> bad_request detail)))
540
Added:
"Record saved."
541
Added:
| Error detail ->
542
Added:
redirect_with_flash_attr request
543
Added:
(Dream_html.path_attr Dream_html.HTML.href Routes.record
544
Added:
id)
545
Added:
detail)))
498
546
499
547
let routes t =
500
548
[
@@ -528,32 +576,33 @@
528
576
~logging:(Option.is_some in_progress)
529
577
~trainee ~tab:(tab request) reports)
530
578
531
Removed:
let render_error t trainee request message =
532
Removed:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
533
Removed:
Service.app_feedback t.service trainee.Trainee.id >>= fun reports ->
534
Removed:
html ~status:`Bad_Request
535
Removed:
(Pages.app_feedback request
536
Removed:
~logging:(Option.is_some in_progress)
537
Removed:
~trainee ~tab:`Write ~error:message reports)
538
Removed:
539
579
let submit t trainee request =
540
580
decode_form Decode.app_feedback request >>= function
541
Removed:
| Error _ -> bad_request Present.form_invalid
581
Added:
| Error _ ->
582
Added:
redirect_with_flash_raw request "/app-feedback?tab=write"
583
Added:
Present.form_invalid
542
584
| Ok message -> (
543
585
Service.record_app_feedback t.service trainee.Trainee.id
544
586
~submitted_at:(t.now ()) ~message
545
587
>>= function
546
Removed:
| Ok _ -> Dream.redirect request "/app-feedback?tab=submitted"
588
Added:
| Ok _ ->
589
Added:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
590
Added:
"Feedback submitted."
547
591
| Error `Empty_message ->
548
Removed:
render_error t trainee request Present.app_feedback_empty)
592
Added:
redirect_with_flash_raw request "/app-feedback?tab=write"
593
Added:
Present.app_feedback_empty)
549
594
550
595
let upvote t trainee request id =
551
596
guard_csrf request >>= function
552
Removed:
| Error _ -> bad_request Present.form_invalid
597
Added:
| Error _ ->
598
Added:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
599
Added:
Present.form_invalid
553
600
| Ok () ->
554
601
Service.upvote_app_feedback t.service trainee.Trainee.id
555
602
(Repository.app_feedback_id id)
556
Removed:
>>= fun _ -> Dream.redirect request "/app-feedback?tab=submitted"
603
Added:
>>= fun added ->
604
Added:
redirect_with_flash_raw request "/app-feedback?tab=submitted"
605
Added:
(if added then "Vote recorded." else "Vote was not added.")
557
606
558
607
let routes t =
559
608
[
lib/web/pages.ml
@@ -18,6 +18,7 @@
18
18
let src path = Dream_html.path_attr (Dream_html.uri_attr "src") path
19
19
let action path = Dream_html.path_attr (Dream_html.uri_attr "action") path
20
20
let post_form = Dream_html.string_attr "method" "post"
21
Added:
let flash_key = "hito.flash"
21
22
22
23
(* The shell. [trainee] and [request] are present on authenticated pages, which
23
24
then show a logout control and the username on the history link. Auth pages
@@ -133,6 +134,24 @@
133
134
]
134
135
| _ -> []
135
136
in
137
Added:
let flash_notice =
138
Added:
match request with
139
Added:
| Some request -> (
140
Added:
match Dream.session_field request flash_key with
141
Added:
| Some message ->
142
Added:
[
143
Added:
tag "div"
144
Added:
[
145
Added:
class_ "toast";
146
Added:
Dream_html.attr "data-hito-toast";
147
Added:
Dream_html.string_attr "role" "status";
148
Added:
Dream_html.string_attr "aria-live" "polite";
149
Added:
]
150
Added:
[ txt "%s" message ];
151
Added:
]
152
Added:
| None -> [])
153
Added:
| None -> []
154
Added:
in
136
155
tag "html"
137
156
[ Dream_html.string_attr "lang" "en" ]
138
157
[
@@ -150,47 +169,49 @@
150
169
];
151
170
tag "body"
152
171
[ Dream_html.string_attr "class" "hito-app" ]
153
Removed:
([
154
Removed:
tag "a"
155
Removed:
[
156
Removed:
class_ "skip-link"; Dream_html.string_attr "href" "#main-content";
157
Removed:
]
158
Removed:
[ txt "Skip to main content" ];
159
Removed:
tag "div"
160
Removed:
([
161
Removed:
Dream_html.string_attr "class" "app-shell page-%s" active;
162
Removed:
Dream_html.string_attr "data-hito-page-title" "%s — hito" title;
172
Added:
(flash_notice
173
Added:
@ [
174
Added:
tag "a"
175
Added:
[
176
Added:
class_ "skip-link";
177
Added:
Dream_html.string_attr "href" "#main-content";
163
178
]
164
Removed:
@
165
Removed:
if spa_client then [ Dream_html.attr "data-hito-app-shell" ]
166
Removed:
else [])
167
Removed:
([
168
Removed:
tag "header"
169
Removed:
[ class_ "masthead" ]
170
Removed:
([
171
Removed:
tag "a"
172
Removed:
([ class_ "brand"; href Routes.home ]
179
Added:
[ txt "Skip to main content" ];
180
Added:
tag "div"
181
Added:
([
182
Added:
Dream_html.string_attr "class" "app-shell page-%s" active;
183
Added:
Dream_html.string_attr "data-hito-page-title" "%s — hito" title;
184
Added:
]
185
Added:
@
186
Added:
if spa_client then [ Dream_html.attr "data-hito-app-shell" ]
187
Added:
else [])
188
Added:
([
189
Added:
tag "header"
190
Added:
[ class_ "masthead" ]
191
Added:
([
192
Added:
tag "a"
193
Added:
([ class_ "brand"; href Routes.home ]
194
Added:
@
195
Added:
if spa_client then
196
Added:
[ Dream_html.attr "data-hito-app-link" ]
197
Added:
else [])
198
Added:
[ txt "hito" ];
199
Added:
]
200
Added:
@ primary_nav @ profile_area @ account_area);
201
Added:
tag "main"
202
Added:
[ id "main-content"; tabindex "-1" ]
203
Added:
[
204
Added:
tag "div"
205
Added:
([ class_ "page-surface" ]
173
206
@
174
207
if spa_client then
175
Removed:
[ Dream_html.attr "data-hito-app-link" ]
208
Added:
[ Dream_html.attr "data-hito-app-content" ]
176
209
else [])
177
Removed:
[ txt "hito" ];
178
Removed:
]
179
Removed:
@ primary_nav @ profile_area @ account_area);
180
Removed:
tag "main"
181
Removed:
[ id "main-content"; tabindex "-1" ]
182
Removed:
[
183
Removed:
tag "div"
184
Removed:
([ class_ "page-surface" ]
185
Removed:
@
186
Removed:
if spa_client then
187
Removed:
[ Dream_html.attr "data-hito-app-content" ]
188
Removed:
else [])
189
Removed:
content;
190
Removed:
];
191
Removed:
]
192
Removed:
@ bottom_nav);
193
Removed:
]
210
Added:
content;
211
Added:
];
212
Added:
]
213
Added:
@ bottom_nav);
214
Added:
]
194
215
@
195
216
if spa_client then
196
217
[
test/test_web.ml
@@ -349,9 +349,12 @@
349
349
let response =
350
350
post c "/routines/ideal/select" [ (* no dream.csrf *) ]
351
351
in
352
Added:
Alcotest.(check int)
353
Added:
"redirects after the refused post" 303 (status response);
354
Added:
let page = body (get c "/") in
352
355
Alcotest.(check bool)
353
Removed:
"not a redirect to success" true
354
Removed:
(status response <> 303) );
356
Added:
"preserves the CSRF error as a toast" true
357
Added:
(contains ~substring:"The submitted form is not valid." page) );
355
358
( "registering a too-short username is refused with a message",
356
359
`Quick,
357
360
fun () ->
@@ -710,20 +713,12 @@
710
713
("extension", "");
711
714
]
712
715
in
713
Removed:
Alcotest.(check int) "invalid field rejected" 400 (status invalid);
714
Removed:
let invalid_page = body invalid in
716
Added:
Alcotest.(check int) "invalid field redirects" 303 (status invalid);
717
Added:
let invalid_page = body (get c "/workout") in
715
718
Alcotest.(check bool)
716
Removed:
"marks the invalid input" true
717
Removed:
(contains ~substring:"id=\"slot-0-iso_load\"" invalid_page
718
Removed:
&& contains ~substring:"aria-invalid=\"true\"" invalid_page);
719
Removed:
Alcotest.(check bool)
720
Removed:
"links the invalid input to its stable error ID" true
721
Removed:
(contains ~substring:"aria-describedby=\"slot-0-iso_load-error\""
722
Removed:
invalid_page);
723
Removed:
Alcotest.(check bool)
724
Removed:
"gives the announced error the referenced stable ID" true
725
Removed:
(contains ~substring:"id=\"slot-0-iso_load-error\"" invalid_page
726
Removed:
&& contains ~substring:"role=\"alert\"" invalid_page) );
719
Added:
"preserves the invalid-input error as a toast" true
720
Added:
(contains ~substring:"data-hito-toast" invalid_page
721
Added:
&& contains ~substring:"role=\"status\"" invalid_page) );
727
722
( "the workout view shows one slot at a time and defaults to the first \
728
723
incomplete slot",
729
724
`Quick,
@@ -1145,11 +1140,15 @@
1145
1140
post c "/app-feedback/submit"
1146
1141
[ ("dream.csrf", token); ("message", " ") ]
1147
1142
in
1148
Removed:
Alcotest.(check int) "blank message is rejected" 400 (status blank);
1143
Added:
Alcotest.(check int) "blank message redirects" 303 (status blank);
1149
1144
Alcotest.(check bool)
1150
Removed:
"explains the validation error" true
1151
Removed:
(contains ~substring:"Enter feedback before submitting"
1152
Removed:
(body blank));
1145
Added:
"redirects to the write tab" true
1146
Added:
(List.mem "/app-feedback?tab=write"
1147
Added:
(Dream.headers blank "Location"));
1148
Added:
let blank_page = body (get c "/app-feedback?tab=write") in
1149
Added:
Alcotest.(check bool)
1150
Added:
"preserves the validation error as a toast" true
1151
Added:
(contains ~substring:"Enter feedback before submitting" blank_page);
1153
1152
let token =
1154
1153
Option.get (csrf_token (body (get c "/app-feedback")))
1155
1154
in
@@ -1166,6 +1165,9 @@
1166
1165
(List.mem "/app-feedback?tab=submitted"
1167
1166
(Dream.headers submitted "Location"));
1168
1167
let list_page = body (get c "/app-feedback?tab=submitted") in
1168
Added:
Alcotest.(check bool)
1169
Added:
"shows the success toast" true
1170
Added:
(contains ~substring:"Feedback submitted." list_page);
1169
1171
Alcotest.(check bool)
1170
1172
"lists the submitted message" true
1171
1173
(contains ~substring:"The app is clear.\nThank you!" list_page);