[OCaml] High Intensity Training Online
feat add persistent application feedback
Add an authenticated Feedback control and a two-tab screen for writing and reviewing application feedback. Persist trainee-scoped reports in SQLite, reject blank messages, and send progressive-enhancement form fields in the URL-encoded format accepted by Dream.form. Keep this feature outside Heavy Duty domain behavior because it records application feedback, not training guidance.
Changed files
- ENHANCEMENTS.org
- lib/app/memory_repo.ml
- lib/app/migrations.ml
- lib/app/repository.ml
- lib/app/repository.mli
- lib/app/service.ml
- lib/app/service.mli
- lib/app/sqlite_repo.ml
- lib/web/assets/hito.css
- lib/web/decode.ml
- lib/web/decode.mli
- lib/web/handlers.ml
- lib/web/pages.ml
- lib/web/pages.mli
- lib/web/routes.ml
- lib/web/workout_client.ml
- test/test_service.ml
- test/test_sqlite_repo.ml
- test/test_web.ml
ENHANCEMENTS.org
@@ -83,6 +83,9 @@
83
83
** DONE Gate logbook feedback form behind a button
84
84
The feedback form under the logbook tab should be accessed via a dedicated button not displayed outright in the logbook page
85
85
- result :: model=kiro-cli commit=6cc9062 tests=pass
86
Added:
** DONE Add authenticated app feedback
87
Added:
[2026-09-05 Sat 17:45]
88
Added:
Next to the profile button in the top header, add an app feedback button which will insert app-specific feedback written by the user to an appropriate SQLite table on the server. On the user app feedback screen, the user should be able to type freeform feedback on the application in one tab and in a second tab view the list of feedback submitted
86
89
87
90
* Routine display
88
91
** DONE Add animations to routine accordions
@@ -116,3 +119,7 @@
116
119
- result :: model=kiro-cli commit=430a6ea tests=pass
117
120
118
121
* Miscellaneous
122
Added:
123
Added:
# Local Variables:
124
Added:
# org-log-done: time
125
Added:
# End:
lib/app/memory_repo.ml
@@ -4,6 +4,7 @@
4
4
mutable current : Evidence.Workout.t option;
5
5
mutable stored : Repository.record list; (* most recent first *)
6
6
mutable feedback : Evidence.Feedback.t list; (* most recent first *)
7
Added:
mutable app_feedback : Repository.app_feedback list; (* most recent first *)
7
8
mutable next_id : int;
8
9
}
9
10
@@ -26,6 +27,7 @@
26
27
current = None;
27
28
stored = [];
28
29
feedback = [];
30
Added:
app_feedback = [];
29
31
next_id = 1;
30
32
}
31
33
in
@@ -191,3 +193,10 @@
191
193
Lwt.return_unit
192
194
193
195
let feedback t id = Lwt.return (state t id).feedback
196
Added:
197
Added:
let save_app_feedback t id report =
198
Added:
let s = state t id in
199
Added:
s.app_feedback <- report :: s.app_feedback;
200
Added:
Lwt.return_unit
201
Added:
202
Added:
let app_feedback t id = Lwt.return (state t id).app_feedback
lib/app/migrations.ml
@@ -52,6 +52,22 @@
52
52
ON feedback (trainee_id, seq DESC)|};
53
53
];
54
54
};
55
Added:
{
56
Added:
version = 3;
57
Added:
name = "application feedback";
58
Added:
statements =
59
Added:
[
60
Added:
{|CREATE TABLE IF NOT EXISTS app_feedback (
61
Added:
trainee_id TEXT NOT NULL,
62
Added:
seq INTEGER NOT NULL,
63
Added:
submitted_at INTEGER NOT NULL,
64
Added:
message TEXT NOT NULL,
65
Added:
PRIMARY KEY (trainee_id, seq)
66
Added:
)|};
67
Added:
{|CREATE INDEX IF NOT EXISTS app_feedback_by_trainee
68
Added:
ON app_feedback (trainee_id, seq DESC)|};
69
Added:
];
70
Added:
};
55
71
]
56
72
57
73
(* The ledger of applied migrations. A row per version, so a reconnect knows
lib/app/repository.ml
@@ -8,6 +8,9 @@
8
8
type record = { id : workout_id; workout : Evidence.Workout.t }
9
9
[@@warning "-69"]
10
10
11
Added:
type app_feedback = { submitted_at : Recovery.timestamp; message : string }
12
Added:
[@@warning "-69"]
13
Added:
11
14
module type S = sig
12
15
type t
13
16
@@ -46,4 +49,6 @@
46
49
val history : t -> Trainee.id -> record list Lwt.t
47
50
val save_feedback : t -> Trainee.id -> Evidence.Feedback.t -> unit Lwt.t
48
51
val feedback : t -> Trainee.id -> Evidence.Feedback.t list Lwt.t
52
Added:
val save_app_feedback : t -> Trainee.id -> app_feedback -> unit Lwt.t
53
Added:
val app_feedback : t -> Trainee.id -> app_feedback list Lwt.t
49
54
end
lib/app/repository.mli
@@ -19,6 +19,9 @@
19
19
(** A stored workout. It already knows its prescription, its timestamps, and the
20
20
basis on which it was begun. *)
21
21
22
Added:
type app_feedback = { submitted_at : Recovery.timestamp; message : string }
23
Added:
(** A freeform application comment submitted by one trainee. *)
24
Added:
22
25
(** Effects run in Lwt: an adapter may talk to a database. *)
23
26
module type S = sig
24
27
type t
@@ -47,8 +50,10 @@
47
50
t -> Trainee.id -> Trainee.credential -> Trainee.t option Lwt.t
48
51
(** Replace the account's password verifier. [None] if unknown. *)
49
52
50
Removed:
(** {2 Catalog} — shared, not trainee-scoped. *)
53
Added:
(** {2 Catalog}
51
54
55
Added:
Shared, not trainee-scoped. *)
56
Added:
52
57
val list_routines : t -> (routine_id * Prescription.Routine.t) list
53
58
val find_routine : t -> routine_id -> Prescription.Routine.t option
54
59
@@ -91,4 +96,10 @@
91
96
92
97
val feedback : t -> Trainee.id -> Evidence.Feedback.t list Lwt.t
93
98
(** Stored feedback reports, most recent first. *)
99
Added:
100
Added:
val save_app_feedback : t -> Trainee.id -> app_feedback -> unit Lwt.t
101
Added:
(** Store a freeform application feedback report. *)
102
Added:
103
Added:
val app_feedback : t -> Trainee.id -> app_feedback list Lwt.t
104
Added:
(** Stored application feedback, most recent first. *)
94
105
end
lib/app/service.ml
@@ -31,6 +31,7 @@
31
31
| Rejected e -> Evidence.Workout.pp_error ppf e
32
32
33
33
type edit_error = Unknown_workout | Rejected_edit of Evidence.Workout.error
34
Added:
type app_feedback_error = [ `Empty_message ]
34
35
35
36
(* Shared helpers over a routine and a log, used by more than one use case. *)
36
37
@@ -260,6 +261,17 @@
260
261
let list t trainee = R.feedback t.repo trainee
261
262
end
262
263
264
Added:
(* --- application feedback --- *)
265
Added:
module App_feedback = struct
266
Added:
let record t trainee ~submitted_at ~message =
267
Added:
if String.trim message = "" then Lwt.return (Error `Empty_message)
268
Added:
else
269
Added:
let report = Repository.{ submitted_at; message } in
270
Added:
R.save_app_feedback t.repo trainee report >|= fun () -> Ok report
271
Added:
272
Added:
let list t trainee = R.app_feedback t.repo trainee
273
Added:
end
274
Added:
263
275
(* Re-export the use cases as one flat service, matching Service.mli. *)
264
276
265
277
let register = Accounts.register
@@ -286,4 +298,6 @@
286
298
let diagnostics = Assessment.diagnostics
287
299
let record_feedback = Feedback.record
288
300
let feedback = Feedback.list
301
Added:
let record_app_feedback = App_feedback.record
302
Added:
let app_feedback = App_feedback.list
289
303
end
lib/app/service.mli
@@ -193,4 +193,20 @@
193
193
194
194
val feedback : t -> Trainee.id -> Evidence.Feedback.t list Lwt.t
195
195
(** Stored feedback reports, most recent first. *)
196
Added:
197
Added:
(** {2 Application feedback} *)
198
Added:
199
Added:
type app_feedback_error = [ `Empty_message ]
200
Added:
(** Why an application feedback message was refused. *)
201
Added:
202
Added:
val record_app_feedback :
203
Added:
t ->
204
Added:
Trainee.id ->
205
Added:
submitted_at:Recovery.timestamp ->
206
Added:
message:string ->
207
Added:
(Repository.app_feedback, app_feedback_error) result Lwt.t
208
Added:
(** Store a non-blank freeform application feedback message. *)
209
Added:
210
Added:
val app_feedback : t -> Trainee.id -> Repository.app_feedback list Lwt.t
211
Added:
(** Stored application feedback, most recent first. *)
196
212
end
lib/app/sqlite_repo.ml
@@ -82,6 +82,20 @@
82
82
let feedback =
83
83
(string ->* string)
84
84
"SELECT encoded FROM feedback WHERE trainee_id = ? ORDER BY seq DESC"
85
Added:
86
Added:
let next_app_feedback_seq =
87
Added:
(string ->! int)
88
Added:
"SELECT COALESCE(MAX(seq), 0) + 1 FROM app_feedback WHERE trainee_id = ?"
89
Added:
90
Added:
let insert_app_feedback =
91
Added:
(t4 string int int string ->. unit)
92
Added:
"INSERT INTO app_feedback (trainee_id, seq, submitted_at, message) \
93
Added:
VALUES (?, ?, ?, ?)"
94
Added:
95
Added:
let app_feedback =
96
Added:
(string ->* t3 int int string)
97
Added:
"SELECT seq, submitted_at, message FROM app_feedback WHERE trainee_id = \
98
Added:
? ORDER BY seq DESC"
85
99
end
86
100
87
101
(* --- pool helper --- *)
@@ -310,3 +324,25 @@
310
324
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
311
325
Db.collect_list Q.feedback (Trainee.id_to_string id))
312
326
>|= List.map decode_feedback
327
Added:
328
Added:
let save_app_feedback t id (report : Repository.app_feedback) =
329
Added:
let trainee = Trainee.id_to_string id in
330
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
331
Added:
Db.find Q.next_app_feedback_seq trainee)
332
Added:
>>= fun seq ->
333
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
334
Added:
Db.exec Q.insert_app_feedback
335
Added:
( trainee,
336
Added:
seq,
337
Added:
Recovery.timestamp_to_unix_seconds report.submitted_at,
338
Added:
report.message ))
339
Added:
340
Added:
let app_feedback t id =
341
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
342
Added:
Db.collect_list Q.app_feedback (Trainee.id_to_string id))
343
Added:
>|= List.map (fun (_seq, submitted_at, message) ->
344
Added:
Repository.
345
Added:
{
346
Added:
submitted_at = Recovery.timestamp_of_unix_seconds submitted_at;
347
Added:
message;
348
Added:
})
lib/web/assets/hito.css
@@ -745,3 +745,88 @@
745
745
.primary-nav { display: flex; }
746
746
.account { display: block; }
747
747
}
748
Added:
749
Added:
/* The app-feedback header control sits beside the profile button and uses the
750
Added:
same compact button treatment. */
751
Added:
.app-feedback-button {
752
Added:
display: inline-flex;
753
Added:
align-items: center;
754
Added:
min-height: 2.75rem;
755
Added:
padding: 0.5rem 0.9rem;
756
Added:
border: 1px solid var(--brass);
757
Added:
border-radius: var(--radius);
758
Added:
color: var(--brass);
759
Added:
background: var(--brass-wash);
760
Added:
font-weight: 700;
761
Added:
text-decoration: none;
762
Added:
}
763
Added:
.app-feedback-button:hover {
764
Added:
color: var(--paper-raised);
765
Added:
background: var(--brass);
766
Added:
}
767
Added:
.app-feedback-button[aria-current] {
768
Added:
color: var(--paper-raised);
769
Added:
background: var(--oxblood);
770
Added:
border-color: var(--oxblood-dark);
771
Added:
}
772
Added:
773
Added:
/* The app-feedback page presents one active panel at a time through native
774
Added:
links, so both tabs remain usable without JavaScript. */
775
Added:
.feedback-tabs {
776
Added:
display: flex;
777
Added:
flex-wrap: wrap;
778
Added:
gap: 0.6rem;
779
Added:
margin: 1.25rem 0 0;
780
Added:
border-bottom: 1px solid var(--rule);
781
Added:
padding-bottom: 0.6rem;
782
Added:
}
783
Added:
.feedback-tab {
784
Added:
display: inline-flex;
785
Added:
min-height: 2.75rem;
786
Added:
align-items: center;
787
Added:
padding: 0.55rem 0.9rem;
788
Added:
border: 1px solid var(--rule-strong);
789
Added:
border-radius: var(--radius);
790
Added:
color: var(--ink);
791
Added:
text-decoration: none;
792
Added:
}
793
Added:
.feedback-tab:hover,
794
Added:
.feedback-tab[aria-current] {
795
Added:
color: var(--paper-raised);
796
Added:
background: var(--oxblood);
797
Added:
border-color: var(--oxblood-dark);
798
Added:
}
799
Added:
.app-feedback-form {
800
Added:
max-width: 42rem;
801
Added:
margin-top: 1.25rem;
802
Added:
}
803
Added:
.app-feedback-form textarea {
804
Added:
display: block;
805
Added:
width: 100%;
806
Added:
min-height: 12rem;
807
Added:
border: 1px solid var(--rule-strong);
808
Added:
border-radius: var(--radius);
809
Added:
color: var(--ink);
810
Added:
background: var(--paper-raised);
811
Added:
font: 400 1rem/1.5 var(--sans);
812
Added:
padding: 0.75rem;
813
Added:
resize: vertical;
814
Added:
}
815
Added:
.app-feedback-list {
816
Added:
max-width: 48rem;
817
Added:
padding-left: 0;
818
Added:
list-style: none;
819
Added:
}
820
Added:
.app-feedback-list li {
821
Added:
margin: 1rem 0;
822
Added:
border-top: 1px solid var(--rule);
823
Added:
padding-top: 1rem;
824
Added:
}
825
Added:
.app-feedback-time {
826
Added:
color: var(--muted-ink);
827
Added:
font: 700 var(--font-size-small)/1.35 var(--mono);
828
Added:
font-variant-numeric: tabular-nums;
829
Added:
}
830
Added:
.app-feedback-message {
831
Added:
white-space: pre-wrap;
832
Added:
}
lib/web/decode.ml
@@ -96,6 +96,10 @@
96
96
let+ current = required string "current" and+ next = required string "next" in
97
97
(current, next)
98
98
99
Added:
(* --- application feedback --- *)
100
Added:
101
Added:
let app_feedback = Form.required Form.string "message"
102
Added:
99
103
(* --- subjective feedback --- *)
100
104
101
105
let level = function
lib/web/decode.mli
@@ -13,4 +13,7 @@
13
13
val profile_password : (string * string) Dream_html.Form.t
14
14
(** The current and new passwords from the change-password form. *)
15
15
16
Added:
val app_feedback : string Dream_html.Form.t
17
Added:
(** Decodes the required freeform application feedback message. *)
18
Added:
16
19
val errors_to_text : (string * string) list -> string
lib/web/handlers.ml
@@ -67,6 +67,7 @@
67
67
| `Incorrect_password -> "The current password is not correct."
68
68
| `Unknown -> "That account no longer exists."
69
69
70
Added:
let app_feedback_empty = "Enter feedback before submitting."
70
71
let username_changed = "Username changed."
71
72
let password_changed = "Password changed."
72
73
end
@@ -513,6 +514,48 @@
513
514
]
514
515
end
515
516
517
Added:
module App_feedback = struct
518
Added:
let tab request =
519
Added:
match Dream.query request "tab" with
520
Added:
| Some "submitted" -> `Submitted
521
Added:
| _ -> `Write
522
Added:
523
Added:
let show t trainee request =
524
Added:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
525
Added:
Service.app_feedback t.service trainee.Trainee.id >>= fun reports ->
526
Added:
html
527
Added:
(Pages.app_feedback request
528
Added:
~logging:(Option.is_some in_progress)
529
Added:
~trainee ~tab:(tab request) reports)
530
Added:
531
Added:
let render_error t trainee request message =
532
Added:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
533
Added:
Service.app_feedback t.service trainee.Trainee.id >>= fun reports ->
534
Added:
html ~status:`Bad_Request
535
Added:
(Pages.app_feedback request
536
Added:
~logging:(Option.is_some in_progress)
537
Added:
~trainee ~tab:`Write ~error:message reports)
538
Added:
539
Added:
let submit t trainee request =
540
Added:
decode_form Decode.app_feedback request >>= function
541
Added:
| Error _ -> bad_request Present.form_invalid
542
Added:
| Ok message -> (
543
Added:
Service.record_app_feedback t.service trainee.Trainee.id
544
Added:
~submitted_at:(t.now ()) ~message
545
Added:
>>= function
546
Added:
| Ok _ -> Dream.redirect request "/app-feedback?tab=submitted"
547
Added:
| Error `Empty_message ->
548
Added:
render_error t trainee request Present.app_feedback_empty)
549
Added:
550
Added:
let routes t =
551
Added:
[
552
Added:
Dream_html.get Routes.app_feedback (fun request ->
553
Added:
authenticated t request (fun trainee -> show t trainee request));
554
Added:
Dream_html.post Routes.submit_app_feedback (fun request ->
555
Added:
authenticated t request (fun trainee -> submit t trainee request));
556
Added:
]
557
Added:
end
558
Added:
516
559
module Profile = struct
517
560
(* The profile page. A [?changed=] query set by a successful redirect shows
518
561
a confirmation notice, so a refresh never re-posts a change. *)
@@ -600,5 +643,6 @@
600
643
601
644
let routes t =
602
645
Auth.routes t @ Overview.routes t @ Current_workout.routes t
603
Removed:
@ Logbook.routes t @ Profile.routes t @ Assets.routes
646
Added:
@ Logbook.routes t @ App_feedback.routes t @ Profile.routes t
647
Added:
@ Assets.routes
604
648
end
lib/web/pages.ml
@@ -56,17 +56,27 @@
56
56
let profile_area =
57
57
match trainee with
58
58
| Some (trainee : Trainee.t) ->
59
Removed:
let attrs =
59
Added:
let profile_attrs =
60
60
[ class_ "profile"; href Routes.profile ]
61
61
@ if spa_client then [ Dream_html.attr "data-hito-app-link" ] else []
62
62
in
63
Removed:
let attrs =
63
Added:
let profile_attrs =
64
64
if String.equal "profile" active then
65
Removed:
Dream_html.string_attr "aria-current" "page" :: attrs
66
Removed:
else attrs
65
Added:
Dream_html.string_attr "aria-current" "page" :: profile_attrs
66
Added:
else profile_attrs
67
67
in
68
Added:
let feedback_attrs =
69
Added:
[ class_ "app-feedback-button"; href Routes.app_feedback ]
70
Added:
@ if spa_client then [ Dream_html.attr "data-hito-app-link" ] else []
71
Added:
in
72
Added:
let feedback_attrs =
73
Added:
if String.equal "app-feedback" active then
74
Added:
Dream_html.string_attr "aria-current" "page" :: feedback_attrs
75
Added:
else feedback_attrs
76
Added:
in
68
77
[
69
Removed:
tag "a" attrs
78
Added:
tag "a" feedback_attrs [ txt "Feedback" ];
79
Added:
tag "a" profile_attrs
70
80
[ txt "%s" (Trainee.username_to_string trainee.username) ];
71
81
]
72
82
| None -> []
@@ -1133,6 +1143,129 @@
1133
1143
];
1134
1144
]
1135
1145
@ feedback_list feedback);
1146
Added:
]
1147
Added:
1148
Added:
(* The authenticated application feedback page. It keeps writing and reviewing
1149
Added:
feedback in separate tabs, while both tabs remain plain links for no-script
1150
Added:
use and progressive enhancement. *)
1151
Added:
let app_feedback_time timestamp =
1152
Added:
let tm =
1153
Added:
Unix.gmtime (float_of_int (Recovery.timestamp_to_unix_seconds timestamp))
1154
Added:
in
1155
Added:
Printf.sprintf "%04d-%02d-%02d %02d:%02d" (tm.Unix.tm_year + 1900)
1156
Added:
(tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min
1157
Added:
1158
Added:
let app_feedback_tab ~selected ~tab ~label =
1159
Added:
let path =
1160
Added:
match tab with
1161
Added:
| `Write -> "/app-feedback?tab=write"
1162
Added:
| `Submitted -> "/app-feedback?tab=submitted"
1163
Added:
in
1164
Added:
let attrs =
1165
Added:
[
1166
Added:
class_ "feedback-tab";
1167
Added:
Dream_html.string_attr "href" "%s" path;
1168
Added:
Dream_html.attr "data-hito-app-link";
1169
Added:
]
1170
Added:
in
1171
Added:
let attrs =
1172
Added:
if selected = tab then Dream_html.string_attr "aria-current" "page" :: attrs
1173
Added:
else attrs
1174
Added:
in
1175
Added:
tag "a" attrs [ txt "%s" label ]
1176
Added:
1177
Added:
let app_feedback_form request ?error () =
1178
Added:
let error_block =
1179
Added:
match error with
1180
Added:
| None -> []
1181
Added:
| Some message ->
1182
Added:
[
1183
Added:
tag "p"
1184
Added:
[ class_ "warn"; Dream_html.string_attr "role" "alert" ]
1185
Added:
[ txt "%s" message ];
1186
Added:
]
1187
Added:
in
1188
Added:
tag "form"
1189
Added:
[
1190
Added:
action Routes.submit_app_feedback;
1191
Added:
post_form;
1192
Added:
class_ "app-feedback-form";
1193
Added:
Dream_html.attr "data-hito-app-form";
1194
Added:
]
1195
Added:
(Dream_html.csrf_tag request
1196
Added:
:: tag "label"
1197
Added:
[ Dream_html.string_attr "for" "app-feedback-message" ]
1198
Added:
[ txt "Your feedback" ]
1199
Added:
:: tag "textarea"
1200
Added:
[
1201
Added:
name "message";
1202
Added:
id "app-feedback-message";
1203
Added:
Dream_html.string_attr "rows" "8";
1204
Added:
required;
1205
Added:
Dream_html.string_attr "placeholder"
1206
Added:
"Tell us what works well or what needs attention.";
1207
Added:
]
1208
Added:
[]
1209
Added:
:: error_block
1210
Added:
@ [ void "input" [ type_ "submit"; value "Submit feedback" ] ])
1211
Added:
1212
Added:
let app_feedback request ?(logging = false) ~trainee ?(tab = `Write) ?error
1213
Added:
reports =
1214
Added:
let panel =
1215
Added:
match tab with
1216
Added:
| `Write ->
1217
Added:
[
1218
Added:
tag "h2" [] [ txt "Write feedback" ];
1219
Added:
tag "p" []
1220
Added:
[ txt "Tell us about your experience using the application." ];
1221
Added:
app_feedback_form request ?error ();
1222
Added:
]
1223
Added:
| `Submitted ->
1224
Added:
[
1225
Added:
tag "h2" [] [ txt "Submitted feedback" ];
1226
Added:
(if reports = [] then
1227
Added:
tag "p" []
1228
Added:
[ txt "You have not submitted any application feedback." ]
1229
Added:
else
1230
Added:
tag "ul"
1231
Added:
[ class_ "app-feedback-list" ]
1232
Added:
(List.map
1233
Added:
(fun (report : Repository.app_feedback) ->
1234
Added:
tag "li" []
1235
Added:
[
1236
Added:
tag "time"
1237
Added:
[
1238
Added:
class_ "app-feedback-time";
1239
Added:
Dream_html.string_attr "datetime" "%s"
1240
Added:
(app_feedback_time report.submitted_at);
1241
Added:
]
1242
Added:
[ txt "%s" (app_feedback_time report.submitted_at) ];
1243
Added:
tag "p"
1244
Added:
[ class_ "app-feedback-message" ]
1245
Added:
[ txt "%s" report.message ];
1246
Added:
])
1247
Added:
reports));
1248
Added:
]
1249
Added:
in
1250
Added:
html_page ~trainee ~request ~active:"app-feedback" ~logging "App feedback"
1251
Added:
[
1252
Added:
tag "div" []
1253
Added:
([
1254
Added:
tag "h1" [] [ txt "App feedback" ];
1255
Added:
tag "p" [] [ txt "Help us improve hito by sharing your experience." ];
1256
Added:
tag "nav"
1257
Added:
[
1258
Added:
class_ "feedback-tabs";
1259
Added:
Dream_html.string_attr "aria-label" "App feedback tabs";
1260
Added:
]
1261
Added:
[
1262
Added:
app_feedback_tab ~selected:tab ~tab:`Write
1263
Added:
~label:"Write feedback";
1264
Added:
app_feedback_tab ~selected:tab ~tab:`Submitted
1265
Added:
~label:"Submitted feedback";
1266
Added:
];
1267
Added:
]
1268
Added:
@ panel);
1136
1269
]
1137
1270
1138
1271
(* The account profile page. It names the signed-in trainee and offers two
lib/web/pages.mli
@@ -85,3 +85,14 @@
85
85
change inline; [notice] confirms a successful one. *)
86
86
87
87
val problem : title:string -> detail:string -> page
88
Added:
89
Added:
val app_feedback :
90
Added:
Dream.request ->
91
Added:
?logging:bool ->
92
Added:
trainee:Trainee.t ->
93
Added:
?tab:[ `Write | `Submitted ] ->
94
Added:
?error:string ->
95
Added:
Repository.app_feedback list ->
96
Added:
page
97
Added:
(** The authenticated application feedback page. One tab accepts a freeform
98
Added:
message; the other lists the trainee's submitted messages. *)
lib/web/routes.ml
@@ -17,6 +17,8 @@
17
17
let%path profile = "/profile"
18
18
let%path profile_username = "/profile/username"
19
19
let%path profile_password = "/profile/password"
20
Added:
let%path app_feedback = "/app-feedback"
21
Added:
let%path submit_app_feedback = "/app-feedback/submit"
20
22
let%path feedback = "/feedback"
21
23
let%path record = "/logbook/%s"
22
24
let%path record_slot = "/logbook/%s/slots/%d"
lib/web/workout_client.ml
@@ -198,11 +198,18 @@
198
198
Option.iter (fun input -> input##.disabled := Js._true) submit;
199
199
set_busy true;
200
200
announce "Saving";
201
Added:
(* Dream.form accepts URL-encoded forms. FormData produces a
202
Added:
multipart request, which requires Dream.multipart instead. Keep
203
Added:
this shared client path URL-encoded because all app forms use
204
Added:
ordinary fields, including textareas. *)
205
Added:
let contents =
206
Added:
Form.get_form_contents form
207
Added:
|> List.map (fun (name, value) -> (name, `String (Js.string value)))
208
Added:
in
201
209
Lwt.async (fun () ->
202
210
Js_of_ocaml_lwt.XmlHttpRequest.perform_raw_url
203
211
~with_credentials:true ~override_method:`POST
204
Removed:
~contents:(`Form_contents (Form.post_form_contents form))
205
Removed:
action
212
Added:
~contents:(`POST_form contents) action
206
213
>>= fun response ->
207
214
if request <> !request_number then Lwt.return_unit
208
215
else (
test/test_service.ml
@@ -617,12 +617,54 @@
617
617
| _ -> Alcotest.fail "expected the under-recovery diagnostic" );
618
618
]
619
619
620
Added:
let app_feedback_tests =
621
Added:
[
622
Added:
( "app feedback rejects a blank message",
623
Added:
`Quick,
624
Added:
fun () ->
625
Added:
let s, t = fixture () in
626
Added:
match
627
Added:
run
628
Added:
(S.record_app_feedback s t ~submitted_at:(day 1) ~message:" \n ")
629
Added:
with
630
Added:
| Error `Empty_message -> ()
631
Added:
| Ok _ -> Alcotest.fail "expected a blank message to be refused" );
632
Added:
( "app feedback is stored newest first and isolated by trainee",
633
Added:
`Quick,
634
Added:
fun () ->
635
Added:
let s, alice = fixture () in
636
Added:
let bob =
637
Added:
(ok (run (S.register s ~username:"bobby" ~password:"heavyduty1")))
638
Added:
.Trainee.id
639
Added:
in
640
Added:
let _ =
641
Added:
ok
642
Added:
(run
643
Added:
(S.record_app_feedback s alice ~submitted_at:(day 1)
644
Added:
~message:"First"))
645
Added:
in
646
Added:
let _ =
647
Added:
ok
648
Added:
(run
649
Added:
(S.record_app_feedback s alice ~submitted_at:(day 2)
650
Added:
~message:"Second"))
651
Added:
in
652
Added:
let alice_reports = run (S.app_feedback s alice) in
653
Added:
Alcotest.(check int) "two reports" 2 (List.length alice_reports);
654
Added:
Alcotest.(check string)
655
Added:
"newest first" "Second" (List.hd alice_reports).Repository.message;
656
Added:
Alcotest.(check int)
657
Added:
"bob has no reports" 0
658
Added:
(List.length (run (S.app_feedback s bob))) );
659
Added:
]
660
Added:
620
661
let suite =
621
662
[
622
663
("service.accounts", account_tests);
623
664
("service.routines", routine_tests);
624
665
("service.clearance", clearance_tests);
625
666
("service.logging", logging_tests);
667
Added:
("service.app_feedback", app_feedback_tests);
626
668
("service.active_and_edit", active_and_edit_tests);
627
669
("service.assessment", assessment_tests);
628
670
]
test/test_sqlite_repo.ml
@@ -287,6 +287,42 @@
287
287
Alcotest.(check bool)
288
288
"pain signal preserved" true
289
289
(List.mem Evidence.Feedback.Pain signals)) );
290
Added:
( "application feedback survives a reconnect",
291
Added:
`Quick,
292
Added:
fun () ->
293
Added:
let path, uri = temp_uri () in
294
Added:
Fun.protect
295
Added:
~finally:(fun () -> cleanup path)
296
Added:
(fun () ->
297
Added:
let id =
298
Added:
let repo = connect uri in
299
Added:
let s = S.make ~repo in
300
Added:
let id =
301
Added:
(ok
302
Added:
(run (S.register s ~username:"alice" ~password:"heavyduty1")))
303
Added:
.Trainee.id
304
Added:
in
305
Added:
let _ =
306
Added:
ok
307
Added:
(run
308
Added:
(S.record_app_feedback s id ~submitted_at:(day 2)
309
Added:
~message:"The app feels clear."))
310
Added:
in
311
Added:
id
312
Added:
in
313
Added:
let repo = connect uri in
314
Added:
let s = S.make ~repo in
315
Added:
match run (S.app_feedback s id) with
316
Added:
| [ report ] ->
317
Added:
Alcotest.(check string)
318
Added:
"message persisted" "The app feels clear."
319
Added:
report.Repository.message;
320
Added:
Alcotest.(check int)
321
Added:
"timestamp persisted" (2 * 86_400)
322
Added:
(Recovery.timestamp_to_unix_seconds report.submitted_at)
323
Added:
| reports ->
324
Added:
Alcotest.failf "expected one report, got %d"
325
Added:
(List.length reports)) );
290
326
( "a username and password change survive a reconnect",
291
327
`Quick,
292
328
fun () ->
test/test_web.ml
@@ -1024,6 +1024,90 @@
1024
1024
(contains ~substring:"<details class=\"feedback-disclosure\" open"
1025
1025
prompted) );
1026
1026
] );
1027
Added:
( "web.app_feedback",
1028
Added:
[
1029
Added:
( "the header offers an app feedback button beside the profile control",
1030
Added:
`Quick,
1031
Added:
fun () ->
1032
Added:
let c = client () in
1033
Added:
let _ = sign_in_new c in
1034
Added:
let page = body (get c "/") in
1035
Added:
Alcotest.(check bool)
1036
Added:
"renders the app feedback button" true
1037
Added:
(contains ~substring:"class=\"app-feedback-button\"" page);
1038
Added:
Alcotest.(check bool)
1039
Added:
"links to the app feedback screen" true
1040
Added:
(contains ~substring:"href=\"/app-feedback\"" page);
1041
Added:
Alcotest.(check bool)
1042
Added:
"labels the button Feedback" true
1043
Added:
(contains ~substring:">Feedback</a>" page) );
1044
Added:
( "the app feedback screen has write and submitted tabs",
1045
Added:
`Quick,
1046
Added:
fun () ->
1047
Added:
let c = client () in
1048
Added:
let _ = sign_in_new c in
1049
Added:
let write_page = body (get c "/app-feedback") in
1050
Added:
Alcotest.(check bool)
1051
Added:
"starts with an app feedback heading" true
1052
Added:
(contains ~substring:"<h1>App feedback</h1>" write_page);
1053
Added:
Alcotest.(check bool)
1054
Added:
"offers the write tab" true
1055
Added:
(contains ~substring:"Write feedback" write_page);
1056
Added:
Alcotest.(check bool)
1057
Added:
"offers the submitted tab" true
1058
Added:
(contains ~substring:"Submitted feedback" write_page);
1059
Added:
Alcotest.(check bool)
1060
Added:
"renders a freeform textarea" true
1061
Added:
(contains ~substring:"id=\"app-feedback-message\"" write_page
1062
Added:
&& contains ~substring:"<textarea" write_page);
1063
Added:
Alcotest.(check bool)
1064
Added:
"posts to the app feedback endpoint" true
1065
Added:
(contains ~substring:"action=\"/app-feedback/submit\"" write_page);
1066
Added:
let submitted_page = body (get c "/app-feedback?tab=submitted") in
1067
Added:
Alcotest.(check bool)
1068
Added:
"submitted tab is selected" true
1069
Added:
(contains ~substring:"href=\"/app-feedback?tab=submitted\""
1070
Added:
submitted_page
1071
Added:
&& contains ~substring:"You have not submitted" submitted_page) );
1072
Added:
( "blank app feedback is refused and a submitted message is listed",
1073
Added:
`Quick,
1074
Added:
fun () ->
1075
Added:
let c = client () in
1076
Added:
let _ = sign_in_new c in
1077
Added:
let page = body (get c "/app-feedback") in
1078
Added:
let token = Option.get (csrf_token page) in
1079
Added:
let blank =
1080
Added:
post c "/app-feedback/submit"
1081
Added:
[ ("dream.csrf", token); ("message", " ") ]
1082
Added:
in
1083
Added:
Alcotest.(check int) "blank message is rejected" 400 (status blank);
1084
Added:
Alcotest.(check bool)
1085
Added:
"explains the validation error" true
1086
Added:
(contains ~substring:"Enter feedback before submitting"
1087
Added:
(body blank));
1088
Added:
let token =
1089
Added:
Option.get (csrf_token (body (get c "/app-feedback")))
1090
Added:
in
1091
Added:
let submitted =
1092
Added:
post c "/app-feedback/submit"
1093
Added:
[
1094
Added:
("dream.csrf", token);
1095
Added:
("message", "The app is clear.\nThank you!");
1096
Added:
]
1097
Added:
in
1098
Added:
Alcotest.(check int) "message is accepted" 303 (status submitted);
1099
Added:
Alcotest.(check bool)
1100
Added:
"redirects to submitted feedback" true
1101
Added:
(List.mem "/app-feedback?tab=submitted"
1102
Added:
(Dream.headers submitted "Location"));
1103
Added:
let list_page = body (get c "/app-feedback?tab=submitted") in
1104
Added:
Alcotest.(check bool)
1105
Added:
"lists the submitted message" true
1106
Added:
(contains ~substring:"The app is clear.\nThank you!" list_page);
1107
Added:
Alcotest.(check bool)
1108
Added:
"shows its timestamp" true
1109
Added:
(contains ~substring:"app-feedback-time" list_page) );
1110
Added:
] );
1027
1111
( "web.profile",
1028
1112
[
1029
1113
( "the profile page offers username and password forms",