[OCaml] High Intensity Training Online
feat Set username account bounds
Require normalized usernames from four through twenty characters and remove local password policy restrictions.
Changed files
ARCHITECTURE.md
@@ -84,8 +84,10 @@
84
84
### Accounts, sessions, and storage
85
85
86
86
- **Trainee** — an account: an opaque id, a normalized username, and a password
87
Removed:
credential. A credential carries a bcrypt hash, never the password, and the
88
Removed:
hash is computed and checked inside this module through `safepass`.
87
Added:
credential. A username is trimmed and lowercased, then required to be 4 to 20
88
Added:
characters. A credential carries a bcrypt hash, never the password, and the
89
Added:
hash is computed and checked inside this module through `safepass`. Passwords
90
Added:
carry no length or content policy.
89
91
- **Repository port** — trainee-scoped account, catalog, selection,
90
92
in-progress, and history operations, plus a transactional `finish_workout`
91
93
that saves a finished workout and clears the in-progress slot as one unit.
@@ -212,9 +214,11 @@
212
214
Set `HITO_SECRET` in production. When it is unset, the server generates a random
213
215
secret for that run, so sessions do not survive a restart.
214
216
215
Removed:
Authentication is local username and password. A password is stored as a bcrypt
216
Removed:
hash. A session holds the trainee id in a signed cookie, backed by the
217
Removed:
`dream_session` table. Every state-changing POST carries a signed CSRF token.
217
Added:
Authentication is local username and password. A username is normalized and must
218
Added:
be 4 to 20 characters; a password has no length or content policy. A password is
219
Added:
stored as a bcrypt hash. A session holds the trainee id in a signed cookie,
220
Added:
backed by the `dream_session` table. Every state-changing POST carries a signed
221
Added:
CSRF token.
218
222
219
223
Storage is durable: trainees, their active routine, the workout in progress, and
220
224
history all live in SQLite. There is no server-wide in-memory state, and each
lib/app/service.ml
@@ -10,11 +10,7 @@
10
10
use-case modules over the shared [t]; the public names are re-exported at
11
11
the end, so callers and {!Service.mli} see one flat service. *)
12
12
13
Removed:
type register_error =
14
Removed:
[ `Username of Trainee.username_error
15
Removed:
| `Password of Trainee.password_error
16
Removed:
| `Username_taken ]
17
Removed:
13
Added:
type register_error = [ `Username of Trainee.username_error | `Username_taken ]
18
14
type error = Unknown_routine | Not_recovered of Recovery.readiness
19
15
20
16
let pp_error ppf = function
@@ -55,19 +51,14 @@
55
51
module Accounts = struct
56
52
let register t ~username ~password =
57
53
let open Lwt_result.Syntax in
58
Removed:
(* Validate the username and password, then create the account. Each step
59
Removed:
short-circuits into the shared [register_error], so the happy path
60
Removed:
reads top to bottom instead of nesting. *)
54
Added:
(* Validate the username, hash the password, then create the account.
55
Added:
Username validation short-circuits into [register_error]; the password
56
Added:
carries no policy, so hashing always succeeds. *)
61
57
let* username =
62
58
Lwt.return
63
59
(Result.map_error (fun e -> `Username e) (Trainee.username username))
64
60
in
65
Removed:
let* credential =
66
Removed:
Lwt.return
67
Removed:
(Result.map_error
68
Removed:
(fun e -> `Password e)
69
Removed:
(Trainee.hash_password password))
70
Removed:
in
61
Added:
let credential = Trainee.hash_password password in
71
62
Lwt_result.map_error
72
63
(fun `Username_taken -> `Username_taken)
73
64
(R.create_trainee t.repo ~username ~credential)
lib/app/service.mli
@@ -20,12 +20,9 @@
20
20
21
21
(** {2 Accounts} *)
22
22
23
Removed:
type register_error =
24
Removed:
[ `Username of Trainee.username_error
25
Removed:
| `Password of Trainee.password_error
26
Removed:
| `Username_taken ]
27
Removed:
(** Why registration was refused: a malformed username, a too-short password,
28
Removed:
or a username already in use. *)
23
Added:
type register_error = [ `Username of Trainee.username_error | `Username_taken ]
24
Added:
(** Why registration was refused: a malformed username or a username already
25
Added:
in use. Passwords carry no policy, so they never refuse registration. *)
29
26
30
27
val register :
31
28
t ->
lib/app/trainee.ml
@@ -4,14 +4,25 @@
4
4
let id_to_string s = s
5
5
6
6
type username = string
7
Removed:
type username_error = Empty
7
Added:
type username_error = Too_short | Too_long
8
8
9
Added:
let username_min_length = 4
10
Added:
let username_max_length = 20
11
Added:
9
12
let pp_username_error ppf = function
10
Removed:
| Empty -> Format.pp_print_string ppf "a username is required"
13
Added:
| Too_short ->
14
Added:
Format.fprintf ppf "a username needs at least %d characters"
15
Added:
username_min_length
16
Added:
| Too_long ->
17
Added:
Format.fprintf ppf "a username can have at most %d characters"
18
Added:
username_max_length
11
19
12
20
let username raw =
13
21
let normalized = String.trim raw |> String.lowercase_ascii in
14
Removed:
if String.length normalized = 0 then Error Empty else Ok normalized
22
Added:
let n = String.length normalized in
23
Added:
if n < username_min_length then Error Too_short
24
Added:
else if n > username_max_length then Error Too_long
25
Added:
else Ok normalized
15
26
16
27
let username_to_string u = u
17
28
@@ -19,14 +30,7 @@
19
30
20
31
let credential_of_hash h = h
21
32
let credential_to_hash h = h
22
Removed:
23
Removed:
type password_error = Too_short
24
Removed:
25
Removed:
let password_min_length = 8
26
Removed:
27
Removed:
let hash_password password =
28
Removed:
if String.length password < password_min_length then Error Too_short
29
Removed:
else Ok (Bcrypt.string_of_hash (Bcrypt.hash password))
33
Added:
let hash_password password = Bcrypt.string_of_hash (Bcrypt.hash password)
30
34
31
35
let verify_password credential password =
32
36
match Bcrypt.hash_of_string credential with
lib/app/trainee.mli
@@ -15,10 +15,17 @@
15
15
type username = private string
16
16
(** A normalized username: trimmed and lowercased ASCII. *)
17
17
18
Removed:
type username_error = Empty
18
Added:
type username_error =
19
Added:
| Too_short (** Fewer than {!username_min_length} characters. *)
20
Added:
| Too_long (** More than {!username_max_length} characters. *)
19
21
22
Added:
val username_min_length : int
23
Added:
val username_max_length : int
24
Added:
20
25
val username : string -> (username, username_error) result
21
Removed:
(** Normalizes and validates a username. Requires a nonempty value. *)
26
Added:
(** Normalizes and validates a username. Trims and lowercases the input, then
27
Added:
requires its length within {!username_min_length}..{!username_max_length}
28
Added:
inclusive. *)
22
29
23
30
val username_to_string : username -> string
24
31
val pp_username_error : Format.formatter -> username_error -> unit
@@ -32,13 +39,9 @@
32
39
val credential_to_hash : credential -> string
33
40
(** The stored hash, for persistence. *)
34
41
35
Removed:
type password_error = Too_short
36
Removed:
37
Removed:
val password_min_length : int
38
Removed:
39
Removed:
val hash_password : string -> (credential, password_error) result
40
Removed:
(** Salts and hashes a new password. Rejects passwords under
41
Removed:
{!password_min_length}. *)
42
Added:
val hash_password : string -> credential
43
Added:
(** Salts and hashes a new password. Accepts any string; there is no length or
44
Added:
content policy on passwords. *)
42
45
43
46
val verify_password : credential -> string -> bool
44
47
(** Constant-time verification of a candidate password against the verifier. *)
lib/web/handlers.ml
@@ -32,9 +32,6 @@
32
32
33
33
let registration : Service.register_error -> string = function
34
34
| `Username e -> Format.asprintf "%a" Trainee.pp_username_error e
35
Removed:
| `Password Trainee.Too_short ->
36
Removed:
Printf.sprintf "Use at least %d characters."
37
Removed:
Trainee.password_min_length
38
35
| `Username_taken -> "That username is already registered."
39
36
40
37
let sign_in_failed = "That username and password do not match."
test/test_service.ml
@@ -101,20 +101,76 @@
101
101
(run
102
102
(S.authenticate s ~username:" Alice " ~password:"heavyduty1")))
103
103
);
104
Removed:
( "an empty username is refused",
104
Added:
( "a username under four characters is refused",
105
105
`Quick,
106
106
fun () ->
107
107
let s = S.make ~repo:(Memory_repo.create ()) in
108
Removed:
match run (S.register s ~username:" " ~password:"heavyduty1") with
109
Removed:
| Error (`Username Trainee.Empty) -> ()
110
Removed:
| _ -> Alcotest.fail "expected Empty" );
111
Removed:
( "a short password is refused",
108
Added:
match run (S.register s ~username:"abc" ~password:"heavyduty1") with
109
Added:
| Error (`Username Trainee.Too_short) -> ()
110
Added:
| _ -> Alcotest.fail "expected Too_short" );
111
Added:
( "a four-character username is accepted",
112
112
`Quick,
113
113
fun () ->
114
114
let s = S.make ~repo:(Memory_repo.create ()) in
115
Removed:
match run (S.register s ~username:"alice" ~password:"short") with
116
Removed:
| Error (`Password Trainee.Too_short) -> ()
117
Removed:
| _ -> Alcotest.fail "expected Too_short" );
115
Added:
match run (S.register s ~username:"abcd" ~password:"heavyduty1") with
116
Added:
| Ok _ -> ()
117
Added:
| Error _ ->
118
Added:
Alcotest.fail "expected the boundary username to be accepted" );
119
Added:
( "a twenty-character username is accepted",
120
Added:
`Quick,
121
Added:
fun () ->
122
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
123
Added:
match
124
Added:
run (S.register s ~username:"abcdefghijklmnopqrst" ~password:"pw")
125
Added:
with
126
Added:
| Ok _ -> ()
127
Added:
| Error _ ->
128
Added:
Alcotest.fail "expected the boundary username to be accepted" );
129
Added:
( "a username over twenty characters is refused",
130
Added:
`Quick,
131
Added:
fun () ->
132
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
133
Added:
match
134
Added:
run (S.register s ~username:"abcdefghijklmnopqrstu" ~password:"pw")
135
Added:
with
136
Added:
| Error (`Username Trainee.Too_long) -> ()
137
Added:
| _ -> Alcotest.fail "expected Too_long" );
138
Added:
( "surrounding whitespace does not count toward the length bounds",
139
Added:
`Quick,
140
Added:
fun () ->
141
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
142
Added:
(* " abcd " normalizes to the four-character "abcd". *)
143
Added:
match run (S.register s ~username:" abcd " ~password:"pw") with
144
Added:
| Ok trainee ->
145
Added:
Alcotest.(check string)
146
Added:
"trimmed and lowercased" "abcd"
147
Added:
(Trainee.username_to_string trainee.Trainee.username)
148
Added:
| Error _ ->
149
Added:
Alcotest.fail "expected the trimmed username to be accepted" );
150
Added:
( "a short password is accepted",
151
Added:
`Quick,
152
Added:
fun () ->
153
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
154
Added:
match run (S.register s ~username:"alice" ~password:"x") with
155
Added:
| Ok _ -> ()
156
Added:
| Error _ -> Alcotest.fail "expected a short password to be accepted" );
157
Added:
( "an empty password is accepted",
158
Added:
`Quick,
159
Added:
fun () ->
160
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
161
Added:
match run (S.register s ~username:"bobby" ~password:"") with
162
Added:
| Ok _ -> ()
163
Added:
| Error _ -> Alcotest.fail "expected an empty password to be accepted"
164
Added:
);
165
Added:
( "a short password still authenticates",
166
Added:
`Quick,
167
Added:
fun () ->
168
Added:
let s = S.make ~repo:(Memory_repo.create ()) in
169
Added:
let _ = ok (run (S.register s ~username:"carol" ~password:"x")) in
170
Added:
Alcotest.(check bool)
171
Added:
"signs in" true
172
Added:
(Option.is_some
173
Added:
(run (S.authenticate s ~username:"carol" ~password:"x"))) );
118
174
( "two trainees keep separate logs",
119
175
`Quick,
120
176
fun () ->
@@ -124,7 +180,7 @@
124
180
.Trainee.id
125
181
in
126
182
let b =
127
Removed:
(ok (run (S.register s ~username:"bob" ~password:"heavyduty1")))
183
Added:
(ok (run (S.register s ~username:"bobby" ~password:"heavyduty1")))
128
184
.Trainee.id
129
185
in
130
186
let _ = ok (run (S.begin_workout s a ~routine:ideal ~now:(day 1) ())) in
test/test_sqlite_repo.ml
@@ -89,7 +89,7 @@
89
89
.Trainee.id
90
90
in
91
91
let b =
92
Removed:
(ok (run (S.register s ~username:"bob" ~password:"heavyduty1")))
92
Added:
(ok (run (S.register s ~username:"bobby" ~password:"heavyduty1")))
93
93
.Trainee.id
94
94
in
95
95
let _ =
@@ -136,6 +136,24 @@
136
136
Alcotest.(check int)
137
137
"one stimulus survived" 1
138
138
(List.length (Workout.stimuli reread.Repository.workout))) );
139
Added:
( "a short password persists and authenticates after a reconnect",
140
Added:
`Quick,
141
Added:
fun () ->
142
Added:
let path, uri = temp_uri () in
143
Added:
Fun.protect
144
Added:
~finally:(fun () -> cleanup path)
145
Added:
(fun () ->
146
Added:
let repo = connect uri in
147
Added:
let s = S.make ~repo in
148
Added:
(* No password policy: a one-character password is stored and later
149
Added:
verifies against its persisted hash. *)
150
Added:
let _ = ok (run (S.register s ~username:"alice" ~password:"x")) in
151
Added:
let repo = connect uri in
152
Added:
let s = S.make ~repo in
153
Added:
Alcotest.(check bool)
154
Added:
"short password authenticates after reconnect" true
155
Added:
(Option.is_some
156
Added:
(run (S.authenticate s ~username:"alice" ~password:"x")))) );
139
157
]
140
158
141
159
let migration_tests =
test/test_web.ml
@@ -185,6 +185,36 @@
185
185
Alcotest.(check bool)
186
186
"not a redirect to success" true
187
187
(status response <> 303) );
188
Added:
( "registering a too-short username is refused with a message",
189
Added:
`Quick,
190
Added:
fun () ->
191
Added:
let c = client () in
192
Added:
let response = register c ~username:"abc" ~password:"heavyduty1" in
193
Added:
Alcotest.(check int) "rejected" 400 (status response);
194
Added:
Alcotest.(check bool)
195
Added:
"explains the minimum length" true
196
Added:
(contains ~substring:"at least 4 characters" (body response)) );
197
Added:
( "registering a too-long username is refused with a message",
198
Added:
`Quick,
199
Added:
fun () ->
200
Added:
let c = client () in
201
Added:
let response =
202
Added:
register c ~username:"abcdefghijklmnopqrstu"
203
Added:
~password:"heavyduty1"
204
Added:
in
205
Added:
Alcotest.(check int) "rejected" 400 (status response);
206
Added:
Alcotest.(check bool)
207
Added:
"explains the maximum length" true
208
Added:
(contains ~substring:"at most 20 characters" (body response)) );
209
Added:
( "registering with a short password succeeds",
210
Added:
`Quick,
211
Added:
fun () ->
212
Added:
let c = client () in
213
Added:
let response = register c ~username:"lifter" ~password:"x" in
214
Added:
Alcotest.(check int) "registered, redirected" 303 (status response);
215
Added:
Alcotest.(check int)
216
Added:
"authenticated overview" 200
217
Added:
(status (get c "/")) );
188
218
] );
189
219
( "web.flow",
190
220
[