[OCaml] High Intensity Training Online
feat add a profile page for username and password
The top-bar profile button opened the logbook. Point it at a dedicated profile page with two independent forms: rename the account, and change the password. Layering, inward only: - repository: add update_username (rejecting a name another account holds) and update_credential; implement in both adapters. SQLite runs the rename check-and-write in one transaction so a concurrent rename cannot race it. - service: change_username validates the new name, then defers the uniqueness check to the repository; change_password verifies the current password before storing the new one, so a hijacked session cannot reset it silently. Passwords keep their no-policy stance. - web: /profile (GET) plus /profile/username and /profile/password (POST). A successful change redirects with a ?changed= notice (post/redirect/get), so a refresh never re-posts. Errors render inline. No doctrine bearing: accounts are not training state. Plan and record stay distinct and no training rule changes. Tests: service-level username and password changes and their refusals; a SQLite durability test that both survive a reconnect; web-level profile page, rename, taken-name refusal, and password-change flows.
Changed files
- ARCHITECTURE.org
- lib/app/memory_repo.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
- test/test_service.ml
- test/test_sqlite_repo.ml
- test/test_web.ml
ARCHITECTURE.org
@@ -362,6 +362,9 @@
362
362
| =/logbook/:id= | GET | A saved workout |
363
363
| =/logbook/:id/slots/:slot= | POST | Add a missing record |
364
364
| =/logbook/:id/slots/:slot/edit= | POST | Correct a saved slot |
365
Added:
| =/profile= | GET | Account profile: rename and change password |
366
Added:
| =/profile/username= | POST | Change the username |
367
Added:
| =/profile/password= | POST | Change the password (verifies the current one)|
365
368
| =/assets/hito.css= | GET | Stylesheet (embedded at build time) |
366
369
| =/assets/workout-client.js= | GET | Enhancement client (embedded at build time) |
367
370
lib/app/memory_repo.ml
@@ -65,6 +65,59 @@
65
65
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
66
66
t.trainees)
67
67
68
Added:
let replace_trainee t (updated : Trainee.t) =
69
Added:
t.trainees <-
70
Added:
List.map
71
Added:
(fun (tr : Trainee.t) ->
72
Added:
if
73
Added:
String.equal
74
Added:
(Trainee.id_to_string tr.id)
75
Added:
(Trainee.id_to_string updated.id)
76
Added:
then updated
77
Added:
else tr)
78
Added:
t.trainees
79
Added:
80
Added:
let update_username t id (username : Trainee.username) =
81
Added:
match
82
Added:
List.find_opt
83
Added:
(fun (tr : Trainee.t) ->
84
Added:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
85
Added:
t.trainees
86
Added:
with
87
Added:
| None -> Lwt.return (Error `Username_taken)
88
Added:
| Some current ->
89
Added:
let taken =
90
Added:
List.exists
91
Added:
(fun (tr : Trainee.t) ->
92
Added:
(not
93
Added:
(String.equal
94
Added:
(Trainee.id_to_string tr.id)
95
Added:
(Trainee.id_to_string id)))
96
Added:
&& String.equal
97
Added:
(Trainee.username_to_string tr.username)
98
Added:
(Trainee.username_to_string username))
99
Added:
t.trainees
100
Added:
in
101
Added:
if taken then Lwt.return (Error `Username_taken)
102
Added:
else begin
103
Added:
let updated = { current with Trainee.username } in
104
Added:
replace_trainee t updated;
105
Added:
Lwt.return (Ok updated)
106
Added:
end
107
Added:
108
Added:
let update_credential t id credential =
109
Added:
match
110
Added:
List.find_opt
111
Added:
(fun (tr : Trainee.t) ->
112
Added:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
113
Added:
t.trainees
114
Added:
with
115
Added:
| None -> Lwt.return None
116
Added:
| Some current ->
117
Added:
let updated = { current with Trainee.credential } in
118
Added:
replace_trainee t updated;
119
Added:
Lwt.return (Some updated)
120
Added:
68
121
let list_routines _ = Catalog.routines
69
122
let find_routine _ id = Catalog.find id
70
123
let active_routine t id = Lwt.return (state t id).active
lib/app/repository.ml
@@ -19,6 +19,16 @@
19
19
20
20
val find_trainee_by_username : t -> Trainee.username -> Trainee.t option Lwt.t
21
21
val find_trainee : t -> Trainee.id -> Trainee.t option Lwt.t
22
Added:
23
Added:
val update_username :
24
Added:
t ->
25
Added:
Trainee.id ->
26
Added:
Trainee.username ->
27
Added:
(Trainee.t, [ `Username_taken ]) result Lwt.t
28
Added:
29
Added:
val update_credential :
30
Added:
t -> Trainee.id -> Trainee.credential -> Trainee.t option Lwt.t
31
Added:
22
32
val list_routines : t -> (routine_id * Prescription.Routine.t) list
23
33
val find_routine : t -> routine_id -> Prescription.Routine.t option
24
34
val active_routine : t -> Trainee.id -> routine_id option Lwt.t
lib/app/repository.mli
@@ -34,6 +34,19 @@
34
34
val find_trainee_by_username : t -> Trainee.username -> Trainee.t option Lwt.t
35
35
val find_trainee : t -> Trainee.id -> Trainee.t option Lwt.t
36
36
37
Added:
val update_username :
38
Added:
t ->
39
Added:
Trainee.id ->
40
Added:
Trainee.username ->
41
Added:
(Trainee.t, [ `Username_taken ]) result Lwt.t
42
Added:
(** Rename the account. [`Username_taken] if another account holds the name.
43
Added:
The trainee's own current name is accepted as a no-op. Returns the updated
44
Added:
trainee on success. *)
45
Added:
46
Added:
val update_credential :
47
Added:
t -> Trainee.id -> Trainee.credential -> Trainee.t option Lwt.t
48
Added:
(** Replace the account's password verifier. [None] if unknown. *)
49
Added:
37
50
(** {2 Catalog} — shared, not trainee-scoped. *)
38
51
39
52
val list_routines : t -> (routine_id * Prescription.Routine.t) list
lib/app/service.ml
@@ -11,6 +11,11 @@
11
11
the end, so callers and {!Service.mli} see one flat service. *)
12
12
13
13
type register_error = [ `Username of Trainee.username_error | `Username_taken ]
14
Added:
15
Added:
type change_username_error =
16
Added:
[ `Username of Trainee.username_error | `Username_taken | `Unknown ]
17
Added:
18
Added:
type change_password_error = [ `Incorrect_password | `Unknown ]
14
19
type error = Unknown_routine | Not_recovered of Recovery.readiness
15
20
16
21
let pp_error ppf = function
@@ -74,6 +79,31 @@
74
79
| _ -> None)
75
80
76
81
let find_trainee t id = R.find_trainee t.repo id
82
Added:
83
Added:
(* Rename the account. Validate the new name, then let the repository check
84
Added:
it is free. The trainee's own current name is accepted as a no-op. *)
85
Added:
let change_username t id ~username =
86
Added:
let open Lwt_result.Syntax in
87
Added:
let* username =
88
Added:
Lwt.return
89
Added:
(Result.map_error (fun e -> `Username e) (Trainee.username username))
90
Added:
in
91
Added:
Lwt_result.map_error
92
Added:
(fun `Username_taken -> `Username_taken)
93
Added:
(R.update_username t.repo id username)
94
Added:
95
Added:
(* Change the password. The current password must verify first, so a
96
Added:
hijacked session cannot silently reset it. Passwords carry no policy, so
97
Added:
any new password is accepted once the current one checks out. *)
98
Added:
let change_password t id ~current ~next =
99
Added:
R.find_trainee t.repo id >>= function
100
Added:
| None -> Lwt.return (Error `Unknown)
101
Added:
| Some trainee ->
102
Added:
if not (Trainee.verify_password trainee.Trainee.credential current)
103
Added:
then Lwt.return (Error `Incorrect_password)
104
Added:
else
105
Added:
R.update_credential t.repo id (Trainee.hash_password next)
106
Added:
>|= fun updated -> Option.to_result ~none:`Unknown updated
77
107
end
78
108
79
109
(* --- routines and selection --- *)
@@ -235,6 +265,8 @@
235
265
let register = Accounts.register
236
266
let authenticate = Accounts.authenticate
237
267
let find_trainee = Accounts.find_trainee
268
Added:
let change_username = Accounts.change_username
269
Added:
let change_password = Accounts.change_password
238
270
let list_routines = Routines.list_routines
239
271
let select_routine = Routines.select_routine
240
272
let active_routine = Routines.active_routine
lib/app/service.mli
@@ -36,6 +36,32 @@
36
36
37
37
val find_trainee : t -> Trainee.id -> Trainee.t option Lwt.t
38
38
39
Added:
type change_username_error =
40
Added:
[ `Username of Trainee.username_error | `Username_taken | `Unknown ]
41
Added:
(** Why a rename was refused: a malformed name, a name already in use, or an
42
Added:
unknown account. *)
43
Added:
44
Added:
val change_username :
45
Added:
t ->
46
Added:
Trainee.id ->
47
Added:
username:string ->
48
Added:
(Trainee.t, change_username_error) result Lwt.t
49
Added:
(** Rename the account. The trainee's own current name is accepted as a no-op.
50
Added:
Returns the updated trainee on success. *)
51
Added:
52
Added:
type change_password_error = [ `Incorrect_password | `Unknown ]
53
Added:
(** Why a password change was refused: the current password did not verify, or
54
Added:
the account is unknown. *)
55
Added:
56
Added:
val change_password :
57
Added:
t ->
58
Added:
Trainee.id ->
59
Added:
current:string ->
60
Added:
next:string ->
61
Added:
(Trainee.t, change_password_error) result Lwt.t
62
Added:
(** Change the password. [current] must verify before [next] is stored, so a
63
Added:
hijacked session cannot reset it silently. Passwords carry no policy. *)
64
Added:
39
65
(** {2 Routines} *)
40
66
41
67
val list_routines : t -> (Repository.routine_id * Prescription.Routine.t) list
lib/app/sqlite_repo.ml
@@ -25,6 +25,12 @@
25
25
(string ->? t3 string string string)
26
26
"SELECT id, username, credential FROM trainee WHERE id = ?"
27
27
28
Added:
let update_username =
29
Added:
(t2 string string ->. unit) "UPDATE trainee SET username = ? WHERE id = ?"
30
Added:
31
Added:
let update_credential =
32
Added:
(t2 string string ->. unit) "UPDATE trainee SET credential = ? WHERE id = ?"
33
Added:
28
34
let get_active =
29
35
(string ->? string)
30
36
"SELECT routine_id FROM active_routine WHERE trainee_id = ?"
@@ -139,6 +145,34 @@
139
145
>|= function
140
146
| Some row -> trainee_of_row row
141
147
| None -> None
148
Added:
149
Added:
(* Rename in one transaction: check the name is free for anyone else, then
150
Added:
update. Running both on the same connection keeps the check and the write
151
Added:
from racing another rename. The trainee's own current name is a no-op. *)
152
Added:
let update_username t id (username : Trainee.username) =
153
Added:
let trainee = Trainee.id_to_string id in
154
Added:
let username_s = Trainee.username_to_string username in
155
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
156
Added:
let open Lwt_result.Syntax in
157
Added:
Db.with_transaction (fun () ->
158
Added:
let* holder = Db.find_opt Q.trainee_by_username username_s in
159
Added:
match holder with
160
Added:
| Some (holder_id, _, _) when not (String.equal holder_id trainee) ->
161
Added:
Lwt_result.return (Error `Username_taken)
162
Added:
| _ ->
163
Added:
let* () = Db.exec Q.update_username (username_s, trainee) in
164
Added:
let* row = Db.find_opt Q.trainee_by_id trainee in
165
Added:
Lwt_result.return
166
Added:
(match Option.bind row trainee_of_row with
167
Added:
| Some updated -> Ok updated
168
Added:
| None -> Error `Username_taken)))
169
Added:
170
Added:
let update_credential t id credential =
171
Added:
let trainee = Trainee.id_to_string id in
172
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
173
Added:
Db.exec Q.update_credential
174
Added:
(Trainee.credential_to_hash credential, trainee))
175
Added:
>>= fun () -> find_trainee t id
142
176
143
177
(* --- catalog --- *)
144
178
lib/web/assets/hito.css
@@ -581,6 +581,28 @@
581
581
padding: 0.9rem 1rem;
582
582
}
583
583
584
Added:
/* A confirmation notice: a quiet, oxblood-accented panel that reports a
585
Added:
successful change on the profile page. */
586
Added:
.notice {
587
Added:
max-width: 47rem;
588
Added:
margin: 1rem 0;
589
Added:
border: 1px solid var(--rule-strong);
590
Added:
border-left: 5px solid var(--oxblood);
591
Added:
color: var(--ink);
592
Added:
background: var(--paper-raised);
593
Added:
padding: 0.9rem 1rem;
594
Added:
}
595
Added:
596
Added:
/* The profile page: each account setting is its own bordered section, and its
597
Added:
form keeps the shared field and submit styling. */
598
Added:
.profile-section {
599
Added:
max-width: 32rem;
600
Added:
margin-top: 2rem;
601
Added:
border-top: 1px solid var(--rule);
602
Added:
padding-top: 1rem;
603
Added:
}
604
Added:
.profile-form { margin-top: 0.5rem; }
605
Added:
584
606
.done {
585
607
color: var(--evergreen);
586
608
font: 700 0.85rem/1.4 var(--mono);
lib/web/decode.ml
@@ -84,6 +84,18 @@
84
84
85
85
let override = Form.required Form.bool "override"
86
86
87
Added:
(* --- profile --- *)
88
Added:
89
Added:
(* The raw username string; the domain normalizes and validates it downstream. *)
90
Added:
let profile_username = Form.required Form.string "username"
91
Added:
92
Added:
(* Current and new password, both required. Passwords carry no policy here; the
93
Added:
service verifies the current one before storing the new one. *)
94
Added:
let profile_password =
95
Added:
let open Form in
96
Added:
let+ current = required string "current" and+ next = required string "next" in
97
Added:
(current, next)
98
Added:
87
99
(* --- subjective feedback --- *)
88
100
89
101
let level = function
lib/web/decode.mli
@@ -7,4 +7,10 @@
7
7
(** Decodes the subjective feedback form: leveled selects and boolean flags,
8
8
dropping any signal left unreported. *)
9
9
10
Added:
val profile_username : string Dream_html.Form.t
11
Added:
(** The raw username from the rename form; the domain validates it. *)
12
Added:
13
Added:
val profile_password : (string * string) Dream_html.Form.t
14
Added:
(** The current and new passwords from the change-password form. *)
15
Added:
10
16
val errors_to_text : (string * string) list -> string
lib/web/handlers.ml
@@ -57,6 +57,18 @@
57
57
let unknown_record = "That saved workout no longer exists."
58
58
let no_workout = "No workout is in progress."
59
59
let slot_not_awaiting = "That slot is not awaiting a record."
60
Added:
61
Added:
let change_username : Service.change_username_error -> string = function
62
Added:
| `Username e -> Format.asprintf "%a" Trainee.pp_username_error e
63
Added:
| `Username_taken -> "That username is already registered."
64
Added:
| `Unknown -> "That account no longer exists."
65
Added:
66
Added:
let change_password : Service.change_password_error -> string = function
67
Added:
| `Incorrect_password -> "The current password is not correct."
68
Added:
| `Unknown -> "That account no longer exists."
69
Added:
70
Added:
let username_changed = "Username changed."
71
Added:
let password_changed = "Password changed."
60
72
end
61
73
62
74
(* --- sessions and authentication --- *)
@@ -505,6 +517,66 @@
505
517
]
506
518
end
507
519
520
Added:
module Profile = struct
521
Added:
(* The profile page. A [?changed=] query set by a successful redirect shows
522
Added:
a confirmation notice, so a refresh never re-posts a change. *)
523
Added:
let show t trainee request =
524
Added:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
525
Added:
let notice =
526
Added:
match Dream.query request "changed" with
527
Added:
| Some "username" -> Some Present.username_changed
528
Added:
| Some "password" -> Some Present.password_changed
529
Added:
| _ -> None
530
Added:
in
531
Added:
html
532
Added:
(Pages.profile request
533
Added:
~logging:(Option.is_some in_progress)
534
Added:
~trainee ?notice ())
535
Added:
536
Added:
let render_error t trainee request ?username_error ?password_error () =
537
Added:
Service.in_progress t.service trainee.Trainee.id >>= fun in_progress ->
538
Added:
html ~status:`Bad_Request
539
Added:
(Pages.profile request
540
Added:
~logging:(Option.is_some in_progress)
541
Added:
~trainee ?username_error ?password_error ())
542
Added:
543
Added:
let change_username t trainee request =
544
Added:
decode_form Decode.profile_username request >>= function
545
Added:
| Error _ -> bad_request Present.form_invalid
546
Added:
| Ok username -> (
547
Added:
Service.change_username t.service trainee.Trainee.id ~username
548
Added:
>>= function
549
Added:
| Ok _ -> Dream.redirect request "/profile?changed=username"
550
Added:
| Error error ->
551
Added:
render_error t trainee request
552
Added:
~username_error:(Present.change_username error)
553
Added:
())
554
Added:
555
Added:
let change_password t trainee request =
556
Added:
decode_form Decode.profile_password request >>= function
557
Added:
| Error _ -> bad_request Present.form_invalid
558
Added:
| Ok (current, next) -> (
559
Added:
Service.change_password t.service trainee.Trainee.id ~current ~next
560
Added:
>>= function
561
Added:
| Ok _ -> Dream.redirect request "/profile?changed=password"
562
Added:
| Error error ->
563
Added:
render_error t trainee request
564
Added:
~password_error:(Present.change_password error)
565
Added:
())
566
Added:
567
Added:
let routes t =
568
Added:
[
569
Added:
Dream_html.get Routes.profile (fun request ->
570
Added:
authenticated t request (fun trainee -> show t trainee request));
571
Added:
Dream_html.post Routes.profile_username (fun request ->
572
Added:
authenticated t request (fun trainee ->
573
Added:
change_username t trainee request));
574
Added:
Dream_html.post Routes.profile_password (fun request ->
575
Added:
authenticated t request (fun trainee ->
576
Added:
change_password t trainee request));
577
Added:
]
578
Added:
end
579
Added:
508
580
module Assets = struct
509
581
let stylesheet =
510
582
match Stylesheet.read "hito.css" with
@@ -532,5 +604,5 @@
532
604
533
605
let routes t =
534
606
Auth.routes t @ Overview.routes t @ Current_workout.routes t
535
Removed:
@ Logbook.routes t @ Assets.routes
607
Added:
@ Logbook.routes t @ Profile.routes t @ Assets.routes
536
608
end
lib/web/pages.ml
@@ -50,18 +50,18 @@
50
50
nav_link "logbook" Routes.logbook "Logbook";
51
51
]
52
52
in
53
Removed:
(* The profile control names the signed-in trainee and links to the logbook.
54
Removed:
It sits in the masthead, and on mobile it is the top-bar profile button the
55
Removed:
bottom nav has no room for. *)
53
Added:
(* The profile control names the signed-in trainee and opens the profile
54
Added:
page. It sits in the masthead, and on mobile it is the top-bar profile
55
Added:
button the bottom nav has no room for. *)
56
56
let profile_area =
57
57
match trainee with
58
58
| Some (trainee : Trainee.t) ->
59
59
let attrs =
60
Removed:
[ class_ "profile"; href Routes.logbook ]
60
Added:
[ class_ "profile"; href Routes.profile ]
61
61
@ if spa_client then [ Dream_html.attr "data-hito-app-link" ] else []
62
62
in
63
63
let attrs =
64
Removed:
if String.equal "logbook" active then
64
Added:
if String.equal "profile" active then
65
65
Dream_html.string_attr "aria-current" "page" :: attrs
66
66
else attrs
67
67
in
@@ -1134,3 +1134,107 @@
1134
1134
]
1135
1135
@ feedback_list feedback);
1136
1136
]
1137
Added:
1138
Added:
(* The account profile page. It names the signed-in trainee and offers two
1139
Added:
independent forms: rename the account, and change the password. Each form
1140
Added:
reports its own error inline; [notice] confirms a successful change. Both are
1141
Added:
plain authenticated app-forms, so they work with or without script. *)
1142
Added:
let profile request ?(logging = false) ~trainee ?username_error ?password_error
1143
Added:
?notice () =
1144
Added:
let notice_block =
1145
Added:
match notice with
1146
Added:
| Some message -> [ tag "p" [ class_ "notice" ] [ txt "%s" message ] ]
1147
Added:
| None -> []
1148
Added:
in
1149
Added:
let error_block = function
1150
Added:
| Some message ->
1151
Added:
[
1152
Added:
tag "p"
1153
Added:
[ class_ "warn"; Dream_html.string_attr "role" "alert" ]
1154
Added:
[ txt "%s" message ];
1155
Added:
]
1156
Added:
| None -> []
1157
Added:
in
1158
Added:
html_page ~trainee ~request ~active:"profile" ~logging "Profile"
1159
Added:
([ tag "h1" [] [ txt "Profile" ] ]
1160
Added:
@ notice_block
1161
Added:
@ [
1162
Added:
tag "section"
1163
Added:
[ class_ "profile-section" ]
1164
Added:
([
1165
Added:
tag "h2" [] [ txt "Username" ];
1166
Added:
tag "form"
1167
Added:
[
1168
Added:
action Routes.profile_username;
1169
Added:
post_form;
1170
Added:
class_ "profile-form";
1171
Added:
Dream_html.attr "data-hito-app-form";
1172
Added:
]
1173
Added:
[
1174
Added:
Dream_html.csrf_tag request;
1175
Added:
tag "div"
1176
Added:
[ class_ "field" ]
1177
Added:
[
1178
Added:
tag "label"
1179
Added:
[ Dream_html.string_attr "for" "username" ]
1180
Added:
[ txt "Username" ];
1181
Added:
void "input"
1182
Added:
[
1183
Added:
type_ "text";
1184
Added:
name "username";
1185
Added:
Dream_html.string_attr "id" "username";
1186
Added:
Dream_html.string_attr "value" "%s"
1187
Added:
(Trainee.username_to_string trainee.Trainee.username);
1188
Added:
required;
1189
Added:
];
1190
Added:
];
1191
Added:
void "input" [ type_ "submit"; value "Change username" ];
1192
Added:
];
1193
Added:
]
1194
Added:
@ error_block username_error);
1195
Added:
tag "section"
1196
Added:
[ class_ "profile-section" ]
1197
Added:
([
1198
Added:
tag "h2" [] [ txt "Password" ];
1199
Added:
tag "form"
1200
Added:
[
1201
Added:
action Routes.profile_password;
1202
Added:
post_form;
1203
Added:
class_ "profile-form";
1204
Added:
Dream_html.attr "data-hito-app-form";
1205
Added:
]
1206
Added:
[
1207
Added:
Dream_html.csrf_tag request;
1208
Added:
tag "div"
1209
Added:
[ class_ "field" ]
1210
Added:
[
1211
Added:
tag "label"
1212
Added:
[ Dream_html.string_attr "for" "current" ]
1213
Added:
[ txt "Current password" ];
1214
Added:
void "input"
1215
Added:
[
1216
Added:
type_ "password";
1217
Added:
name "current";
1218
Added:
Dream_html.string_attr "id" "current";
1219
Added:
required;
1220
Added:
];
1221
Added:
];
1222
Added:
tag "div"
1223
Added:
[ class_ "field" ]
1224
Added:
[
1225
Added:
tag "label"
1226
Added:
[ Dream_html.string_attr "for" "next" ]
1227
Added:
[ txt "New password" ];
1228
Added:
void "input"
1229
Added:
[
1230
Added:
type_ "password";
1231
Added:
name "next";
1232
Added:
Dream_html.string_attr "id" "next";
1233
Added:
required;
1234
Added:
];
1235
Added:
];
1236
Added:
void "input" [ type_ "submit"; value "Change password" ];
1237
Added:
];
1238
Added:
]
1239
Added:
@ error_block password_error);
1240
Added:
])
lib/web/pages.mli
@@ -71,4 +71,17 @@
71
71
[feedback] lists past reports, most recent first. [suggest_feedback] shows a
72
72
prompt inviting feedback, set after a workout finishes. *)
73
73
74
Added:
val profile :
75
Added:
Dream.request ->
76
Added:
?logging:bool ->
77
Added:
trainee:Trainee.t ->
78
Added:
?username_error:string ->
79
Added:
?password_error:string ->
80
Added:
?notice:string ->
81
Added:
unit ->
82
Added:
page
83
Added:
(** The account profile page: rename the account and change the password, each
84
Added:
an independent form. [username_error] and [password_error] report a refused
85
Added:
change inline; [notice] confirms a successful one. *)
86
Added:
74
87
val problem : title:string -> detail:string -> page
lib/web/routes.ml
@@ -14,6 +14,9 @@
14
14
let%path finish_workout = "/workout/finish"
15
15
let%path cancel_workout = "/workout/cancel"
16
16
let%path logbook = "/logbook"
17
Added:
let%path profile = "/profile"
18
Added:
let%path profile_username = "/profile/username"
19
Added:
let%path profile_password = "/profile/password"
17
20
let%path feedback = "/feedback"
18
21
let%path record = "/logbook/%s"
19
22
let%path record_slot = "/logbook/%s/slots/%d"
test/test_service.ml
@@ -188,6 +188,107 @@
188
188
Alcotest.(check int) "a has one" 1 (List.length (run (S.history s a)));
189
189
Alcotest.(check int) "b has none" 0 (List.length (run (S.history s b)))
190
190
);
191
Added:
( "changing the username renames the account",
192
Added:
`Quick,
193
Added:
fun () ->
194
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
195
Added:
let id =
196
Added:
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
197
Added:
.Trainee.id
198
Added:
in
199
Added:
(match run (S.change_username s id ~username:"alicia") with
200
Added:
| Ok updated ->
201
Added:
Alcotest.(check string)
202
Added:
"renamed" "alicia"
203
Added:
(Trainee.username_to_string updated.Trainee.username)
204
Added:
| Error _ -> Alcotest.fail "expected the rename to succeed");
205
Added:
(* The old name is free; the new name resolves the same account. *)
206
Added:
match run (S.find_trainee s id) with
207
Added:
| Some found ->
208
Added:
Alcotest.(check string)
209
Added:
"persisted new name" "alicia"
210
Added:
(Trainee.username_to_string found.Trainee.username)
211
Added:
| None -> Alcotest.fail "account vanished" );
212
Added:
( "renaming to the account's own name is a no-op success",
213
Added:
`Quick,
214
Added:
fun () ->
215
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
216
Added:
let id =
217
Added:
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
218
Added:
.Trainee.id
219
Added:
in
220
Added:
match run (S.change_username s id ~username:" ALICE ") with
221
Added:
| Ok updated ->
222
Added:
Alcotest.(check string)
223
Added:
"kept the normalized name" "alice"
224
Added:
(Trainee.username_to_string updated.Trainee.username)
225
Added:
| Error _ -> Alcotest.fail "expected a no-op rename to succeed" );
226
Added:
( "renaming to another trainee's name is refused",
227
Added:
`Quick,
228
Added:
fun () ->
229
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
230
Added:
let a =
231
Added:
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
232
Added:
.Trainee.id
233
Added:
in
234
Added:
let _ =
235
Added:
ok (run (S.register s ~username:"bobby" ~password:"heavyduty1"))
236
Added:
in
237
Added:
match run (S.change_username s a ~username:"bobby") with
238
Added:
| Error `Username_taken -> ()
239
Added:
| _ -> Alcotest.fail "expected Username_taken" );
240
Added:
( "an invalid new username is refused",
241
Added:
`Quick,
242
Added:
fun () ->
243
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
244
Added:
let id =
245
Added:
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
246
Added:
.Trainee.id
247
Added:
in
248
Added:
match run (S.change_username s id ~username:"ab") with
249
Added:
| Error (`Username Trainee.Too_short) -> ()
250
Added:
| _ -> Alcotest.fail "expected Too_short" );
251
Added:
( "changing the password requires the current one",
252
Added:
`Quick,
253
Added:
fun () ->
254
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
255
Added:
let id =
256
Added:
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
257
Added:
.Trainee.id
258
Added:
in
259
Added:
(match
260
Added:
run (S.change_password s id ~current:"wrong" ~next:"newsecret1")
261
Added:
with
262
Added:
| Error `Incorrect_password -> ()
263
Added:
| _ -> Alcotest.fail "expected Incorrect_password");
264
Added:
(* The old password still works after a refused change. *)
265
Added:
Alcotest.(check bool)
266
Added:
"old password still valid" true
267
Added:
(Option.is_some
268
Added:
(run (S.authenticate s ~username:"alice" ~password:"heavyduty1")))
269
Added:
);
270
Added:
( "a correct current password changes the password",
271
Added:
`Quick,
272
Added:
fun () ->
273
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
274
Added:
let id =
275
Added:
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
276
Added:
.Trainee.id
277
Added:
in
278
Added:
(match
279
Added:
run (S.change_password s id ~current:"heavyduty1" ~next:"newsecret1")
280
Added:
with
281
Added:
| Ok _ -> ()
282
Added:
| Error _ -> Alcotest.fail "expected the change to succeed");
283
Added:
Alcotest.(check bool)
284
Added:
"the old password no longer works" true
285
Added:
(Option.is_none
286
Added:
(run (S.authenticate s ~username:"alice" ~password:"heavyduty1")));
287
Added:
Alcotest.(check bool)
288
Added:
"the new password works" true
289
Added:
(Option.is_some
290
Added:
(run (S.authenticate s ~username:"alice" ~password:"newsecret1")))
291
Added:
);
191
292
]
192
293
193
294
let routine_tests =
test/test_sqlite_repo.ml
@@ -287,6 +287,50 @@
287
287
Alcotest.(check bool)
288
288
"pain signal preserved" true
289
289
(List.mem Evidence.Feedback.Pain signals)) );
290
Added:
( "a username and password change survive 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 _ = ok (run (S.change_username s id ~username:"alicia")) in
306
Added:
let _ =
307
Added:
ok
308
Added:
(run
309
Added:
(S.change_password s id ~current:"heavyduty1"
310
Added:
~next:"newsecret1"))
311
Added:
in
312
Added:
id
313
Added:
in
314
Added:
(* Reconnect: the new name and password must be the ones stored. *)
315
Added:
let repo = connect uri in
316
Added:
let s = S.make ~repo in
317
Added:
(match run (S.find_trainee s id) with
318
Added:
| Some found ->
319
Added:
Alcotest.(check string)
320
Added:
"renamed account persisted" "alicia"
321
Added:
(Trainee.username_to_string found.Trainee.username)
322
Added:
| None -> Alcotest.fail "account vanished");
323
Added:
Alcotest.(check bool)
324
Added:
"the old password no longer authenticates" true
325
Added:
(Option.is_none
326
Added:
(run
327
Added:
(S.authenticate s ~username:"alicia" ~password:"heavyduty1")));
328
Added:
Alcotest.(check bool)
329
Added:
"the new password authenticates" true
330
Added:
(Option.is_some
331
Added:
(run
332
Added:
(S.authenticate s ~username:"alicia" ~password:"newsecret1"))))
333
Added:
);
290
334
]
291
335
292
336
let suite =
test/test_web.ml
@@ -176,9 +176,10 @@
176
176
"labels the logbook tab Logbook" true
177
177
(contains ~substring:">Logbook</a>" (body overview));
178
178
Alcotest.(check bool)
179
Removed:
"shows the username on a profile control linking to the logbook"
179
Added:
"shows the username on a profile control opening the profile page"
180
180
true
181
181
(contains ~substring:"class=\"profile\"" (body overview)
182
Added:
&& contains ~substring:"href=\"/profile\"" (body overview)
182
183
&& contains ~substring:">lifter</a>" (body overview));
183
184
Alcotest.(check bool)
184
185
"omits the header username" false
@@ -1007,6 +1008,108 @@
1007
1008
"opens the feedback disclosure on a suggestion" true
1008
1009
(contains ~substring:"<details class=\"feedback-disclosure\" open"
1009
1010
prompted) );
1011
Added:
] );
1012
Added:
( "web.profile",
1013
Added:
[
1014
Added:
( "the profile page offers username and password forms",
1015
Added:
`Quick,
1016
Added:
fun () ->
1017
Added:
let c = client () in
1018
Added:
let _ = sign_in_new c in
1019
Added:
let page = body (get c "/profile") in
1020
Added:
Alcotest.(check bool)
1021
Added:
"starts with a page heading" true
1022
Added:
(contains ~substring:"<h1>Profile</h1>" page);
1023
Added:
Alcotest.(check bool)
1024
Added:
"posts a username change to its route" true
1025
Added:
(contains ~substring:"action=\"/profile/username\"" page);
1026
Added:
Alcotest.(check bool)
1027
Added:
"posts a password change to its route" true
1028
Added:
(contains ~substring:"action=\"/profile/password\"" page);
1029
Added:
Alcotest.(check bool)
1030
Added:
"prefills the current username" true
1031
Added:
(contains ~substring:"value=\"lifter\"" page);
1032
Added:
Alcotest.(check bool)
1033
Added:
"asks for the current password" true
1034
Added:
(contains ~substring:"name=\"current\"" page) );
1035
Added:
( "changing the username updates the profile and the navigation",
1036
Added:
`Quick,
1037
Added:
fun () ->
1038
Added:
let c = client () in
1039
Added:
let _ = sign_in_new c in
1040
Added:
let token = Option.get (csrf_token (body (get c "/profile"))) in
1041
Added:
let changed =
1042
Added:
post c "/profile/username"
1043
Added:
[ ("dream.csrf", token); ("username", "athlete") ]
1044
Added:
in
1045
Added:
Alcotest.(check int)
1046
Added:
"redirects after the change" 303 (status changed);
1047
Added:
Alcotest.(check bool)
1048
Added:
"redirects back to the profile with a notice" true
1049
Added:
(List.mem "/profile?changed=username"
1050
Added:
(Dream.headers changed "Location"));
1051
Added:
let page = body (get c "/profile?changed=username") in
1052
Added:
Alcotest.(check bool)
1053
Added:
"confirms the change" true
1054
Added:
(contains ~substring:"Username changed" page);
1055
Added:
Alcotest.(check bool)
1056
Added:
"shows the new name in the profile control" true
1057
Added:
(contains ~substring:">athlete</a>" page) );
1058
Added:
( "a taken username is refused with an inline error",
1059
Added:
`Quick,
1060
Added:
fun () ->
1061
Added:
let c = client () in
1062
Added:
let _ = sign_in_new c in
1063
Added:
(* Register a second account in the same store, via a client that
1064
Added:
shares the app but keeps its own cookie jar. *)
1065
Added:
let other = { c with jar = [] } in
1066
Added:
let _ = register other ~username:"taken" ~password:"heavyduty1" in
1067
Added:
let token = Option.get (csrf_token (body (get c "/profile"))) in
1068
Added:
let refused =
1069
Added:
post c "/profile/username"
1070
Added:
[ ("dream.csrf", token); ("username", "taken") ]
1071
Added:
in
1072
Added:
Alcotest.(check int)
1073
Added:
"renders an invalid response" 400 (status refused);
1074
Added:
Alcotest.(check bool)
1075
Added:
"explains the name is taken" true
1076
Added:
(contains ~substring:"already registered" (body refused)) );
1077
Added:
( "changing the password requires the current one",
1078
Added:
`Quick,
1079
Added:
fun () ->
1080
Added:
let c = client () in
1081
Added:
let _ = sign_in_new c in
1082
Added:
let token = Option.get (csrf_token (body (get c "/profile"))) in
1083
Added:
let refused =
1084
Added:
post c "/profile/password"
1085
Added:
[
1086
Added:
("dream.csrf", token);
1087
Added:
("current", "wrongpass");
1088
Added:
("next", "newsecret1");
1089
Added:
]
1090
Added:
in
1091
Added:
Alcotest.(check int)
1092
Added:
"renders an invalid response" 400 (status refused);
1093
Added:
Alcotest.(check bool)
1094
Added:
"explains the current password is wrong" true
1095
Added:
(contains ~substring:"current password is not correct"
1096
Added:
(body refused));
1097
Added:
(* Now change it with the correct current password. *)
1098
Added:
let token = Option.get (csrf_token (body (get c "/profile"))) in
1099
Added:
let changed =
1100
Added:
post c "/profile/password"
1101
Added:
[
1102
Added:
("dream.csrf", token);
1103
Added:
("current", "heavyduty1");
1104
Added:
("next", "newsecret1");
1105
Added:
]
1106
Added:
in
1107
Added:
Alcotest.(check int)
1108
Added:
"redirects after the change" 303 (status changed);
1109
Added:
Alcotest.(check bool)
1110
Added:
"redirects back to the profile with a notice" true
1111
Added:
(List.mem "/profile?changed=password"
1112
Added:
(Dream.headers changed "Location")) );
1010
1113
] );
1011
1114
]
1012
1115