hans/racket-wiki
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cmap functions, email, architecture documentation.

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-18 03:33:10 +02:00
parent 12f1ed2764
commit 63b7ca0853
33 changed files with 3974 additions and 80 deletions
Download Patch File Download Diff File Expand all files Collapse all files
private/auth.rkt
+134 -17
View File
@@ -26,9 +26,13 @@
create-user!
upsert-user!
update-user!
update-own-profile!
request-password-reset!
cancel-password-reset!
reset-password!
delete-user!)
(struct wiki-user (id username display-name role enabled?) #:transparent)
(struct wiki-user (id username display-name email role enabled?) #:transparent)
(struct wiki-session (user csrf-token expires-at token) #:transparent)
(crypto-factories (list libcrypto-factory))
@@ -76,8 +80,16 @@
(wiki-user (vector-ref row 0)
(vector-ref row 1)
(vector-ref row 2)
(string->symbol (vector-ref row 3))
(vector-ref row 4)))
(sql-null->false (vector-ref row 3))
(string->symbol (vector-ref row 4))
(vector-ref row 5)))
(define (sql-null->false value)
(if (sql-null? value) #f value))
(define (normalized-email email)
(define value (string-downcase (string-trim (or email ""))))
(if (string=? value "") sql-null value))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Authenticate an enabled wiki user.
@@ -92,17 +104,18 @@
(define row
(query-maybe-row
db
"SELECT id, username, display_name, role, enabled, password_hash FROM users WHERE username = $1"
"SELECT id, username, display_name, email, role, enabled, password_hash FROM users WHERE username = $1"
username))
(cond
((not row) #f)
((not (vector-ref row 4)) #f)
((not (password-valid? password (vector-ref row 5))) #f)
((not (vector-ref row 5)) #f)
((not (password-valid? password (vector-ref row 6))) #f)
(else
(wiki-user (vector-ref row 0)
(vector-ref row 1)
(vector-ref row 2)
(string->symbol (vector-ref row 3))
(sql-null->false (vector-ref row 3))
(string->symbol (vector-ref row 4))
#t))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -168,7 +181,7 @@
(query-maybe-row
db
#<<SQL
SELECT u.id, u.username, u.display_name, u.role, u.enabled,
SELECT u.id, u.username, u.display_name, u.email, u.role, u.enabled,
s.csrf_token, s.expires_at
FROM sessions s
JOIN users u ON u.id = s.user_id
@@ -181,10 +194,11 @@ SQL
(wiki-user (vector-ref row 0)
(vector-ref row 1)
(vector-ref row 2)
(string->symbol (vector-ref row 3))
(vector-ref row 4))
(vector-ref row 5)
(sql-null->false (vector-ref row 3))
(string->symbol (vector-ref row 4))
(vector-ref row 5))
(vector-ref row 6)
(vector-ref row 7)
token)
#f)))
#f))
@@ -211,7 +225,7 @@ SQL
config
(λ (db)
(for/list ([row (in-list (query-rows db
"SELECT id, username, display_name, role, enabled FROM users ORDER BY username"))])
"SELECT id, username, display_name, email, role, enabled FROM users ORDER BY username"))])
(row->user row)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -234,7 +248,7 @@ SQL
; post : The new user and password hash have been stored.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-user! config username display-name password role status)
(define (create-user! config username display-name password role status [email #f])
(define now (current-seconds))
(define enabled (eq? status 'enabled))
(define hash (password-hash password))
@@ -243,9 +257,10 @@ SQL
(λ (db)
(query-exec
db
"INSERT INTO users(username, display_name, password_hash, role, enabled, created_at, updated_at) VALUES ($1, $2, $3, $4, $5, $6, $7)"
"INSERT INTO users(username, display_name, email, password_hash, role, enabled, created_at, updated_at) VALUES ($1, $2, $3, $4, $5, $6, $7, $8)"
username
display-name
(normalized-email email)
hash
(symbol->string role)
enabled
@@ -285,7 +300,7 @@ SQL
; post : Display name, role and status are updated; a non-empty password replaces the password hash.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (update-user! config id display-name role status [password #f])
(define (update-user! config id display-name role status [password #f] [email #f])
(define enabled (eq? status 'enabled))
(define now (current-seconds))
(call-with-wiki-database
@@ -293,21 +308,123 @@ SQL
(λ (db)
(if (and password (not (string=? password "")))
(query-exec db
"UPDATE users SET display_name = $1, role = $2, enabled = $3, password_hash = $4, updated_at = $5 WHERE id = $6"
"UPDATE users SET display_name = $1, email = $2, role = $3, enabled = $4, password_hash = $5, updated_at = $6 WHERE id = $7"
display-name
(normalized-email email)
(symbol->string role)
enabled
(password-hash password)
now
id)
(query-exec db
"UPDATE users SET display_name = $1, role = $2, enabled = $3, updated_at = $4 WHERE id = $5"
"UPDATE users SET display_name = $1, email = $2, role = $3, enabled = $4, updated_at = $5 WHERE id = $6"
display-name
(normalized-email email)
(symbol->string role)
enabled
now
id)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Update the authenticated user's profile and optionally password.
; pre : user-id and session-token identify the active account/session.
; post : Name/email are updated; password changes retain only the active session.
; result : void; an invalid current password raises an exception.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (update-own-profile! config user-id session-token display-name email current-password new-password)
(define change-password?
(and new-password (not (string=? new-password ""))))
(call-with-wiki-database
config
(λ (db)
(call-with-transaction
db
(λ ()
(when change-password?
(define stored-hash
(query-maybe-value db "SELECT password_hash FROM users WHERE id = $1" user-id))
(unless (and stored-hash current-password (password-valid? current-password stored-hash))
(error 'update-own-profile! "The current password is incorrect")))
(if change-password?
(query-exec db
"UPDATE users SET display_name = $1, email = $2, password_hash = $3, updated_at = $4 WHERE id = $5"
display-name (normalized-email email) (password-hash new-password) (current-seconds) user-id)
(query-exec db
"UPDATE users SET display_name = $1, email = $2, updated_at = $3 WHERE id = $4"
display-name (normalized-email email) (current-seconds) user-id))
(when change-password?
(query-exec db
"DELETE FROM sessions WHERE user_id = $1 AND token_hash <> $2"
user-id
(token-hash session-token))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a short-lived one-time password-reset token for an account.
; pre : identity is a username or email string.
; post : Any prior unused tokens for the matching enabled user are invalidated.
; result : A pair containing raw token and email, or #f when no account matches.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (request-password-reset! config identity [lifetime 3600] [maximum-per-hour 2])
(define token (random-token))
(define now (current-seconds))
(call-with-wiki-database
config
(λ (db)
(call-with-transaction
db
(λ ()
(query-exec db "DELETE FROM password_reset_tokens WHERE created_at <= $1" (- now 3600))
(define row
(query-maybe-row db
"SELECT id, email FROM users WHERE enabled = TRUE AND (lower(username) = lower($1) OR lower(email) = lower($1)) FOR UPDATE"
(string-trim identity)))
(if (and row (not (sql-null? (vector-ref row 1))))
(let ((recent-count
(query-value db
"SELECT COUNT(*) FROM password_reset_tokens WHERE user_id = $1 AND created_at > $2"
(vector-ref row 0)
(- now 3600))))
(if (>= recent-count maximum-per-hour)
#f
(begin
(query-exec db
"INSERT INTO password_reset_tokens(token_hash, user_id, created_at, expires_at) VALUES ($1, $2, $3, $4)"
(token-hash token) (vector-ref row 0) now (+ now lifetime))
(cons token (vector-ref row 1)))))
#f))))))
(define (cancel-password-reset! config token)
(call-with-wiki-database
config
(λ (db)
(query-exec db "DELETE FROM password_reset_tokens WHERE token_hash = $1" (token-hash token)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Consume a password-reset token and replace the account password.
; pre : token/password are strings and the password meets the caller's policy.
; post : A valid token is used once, all sessions are revoked and password updated.
; result : #t on success, #f for an invalid, expired or already-used token.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (reset-password! config token password)
(call-with-wiki-database
config
(λ (db)
(call-with-transaction
db
(λ ()
(define now (current-seconds))
(define user-id
(query-maybe-value db
"SELECT user_id FROM password_reset_tokens WHERE token_hash = $1 AND used_at IS NULL AND expires_at > $2 FOR UPDATE"
(token-hash token) now))
(if user-id
(begin
(query-exec db "UPDATE users SET password_hash = $1, updated_at = $2 WHERE id = $3" (password-hash password) now user-id)
(query-exec db "UPDATE password_reset_tokens SET used_at = $1 WHERE user_id = $2 AND used_at IS NULL" now user-id)
(query-exec db "DELETE FROM sessions WHERE user_id = $1" user-id)
#t)
#f))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Delete a wiki user.
; pre : id identifies a possible user.