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

refactoring by skill

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-29 22:22:49 +02:00
parent 67fce7a330
commit 649ff0d7c5
22 changed files with 1598 additions and 1644 deletions
Download Patch File Download Diff File Expand all files Collapse all files
private/auth.rkt
+187 -181
View File
@@ -56,10 +56,10 @@
(define (bytes->hex value)
(apply string-append
(for/list ([byte (in-bytes value)])
(define hex (number->string byte 16))
(if (= (string-length hex) 1)
(string-append "0" hex)
hex))))
(let ((hex (number->string byte 16)))
(if (= (string-length hex) 1)
(string-append "0" hex)
hex)))))
(define (random-token [size 32])
(bytes->hex (crypto-random-bytes size)))
@@ -88,8 +88,8 @@
(if (sql-null? value) #f value))
(define (normalized-email email)
(define value (string-downcase (string-trim (or email ""))))
(if (string=? value "") sql-null value))
(let ((value (string-downcase (string-trim (or email "")))))
(if (string=? value "") sql-null value)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Authenticate an enabled wiki user.
@@ -101,22 +101,22 @@
(call-with-wiki-database
config
(λ (db)
(define row
(query-maybe-row
db
"SELECT id, username, display_name, email, role, enabled, password_hash FROM users WHERE username = $1"
username))
(cond
((not row) #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)
(sql-null->false (vector-ref row 3))
(string->symbol (vector-ref row 4))
#t))))))
(let ((row
(query-maybe-row
db
"SELECT id, username, display_name, email, role, enabled, password_hash FROM users WHERE username = $1"
username)))
(cond
((not row) #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)
(sql-null->false (vector-ref row 3))
(string->symbol (vector-ref row 4))
#t)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a login session for a user.
@@ -125,21 +125,21 @@
; result : A wiki-session containing the client session token.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (create-session! config user)
(define token (random-token))
(define csrf-token (random-token 24))
(define now (current-seconds))
(define expires-at (+ now (wiki-config-session-seconds config)))
(call-with-wiki-database
config
(λ (db)
(query-exec db
"INSERT INTO sessions(token_hash, user_id, csrf_token, created_at, expires_at) VALUES ($1, $2, $3, $4, $5)"
(token-hash token)
(wiki-user-id user)
csrf-token
now
expires-at)))
(wiki-session user csrf-token expires-at token))
(let* ((token (random-token))
(csrf-token (random-token 24))
(now (current-seconds))
(expires-at (+ now (wiki-config-session-seconds config))))
(call-with-wiki-database
config
(λ (db)
(query-exec db
"INSERT INTO sessions(token_hash, user_id, csrf_token, created_at, expires_at) VALUES ($1, $2, $3, $4, $5)"
(token-hash token)
(wiki-user-id user)
csrf-token
now
expires-at)))
(wiki-session user csrf-token expires-at token)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Delete a login session.
@@ -157,13 +157,13 @@
(token-hash token))))))
(define (session-cookie-token req)
(define cookie
(findf (λ (candidate)
(string=? (client-cookie-name candidate) "racket-wiki-session"))
(request-cookies req)))
(if cookie
(client-cookie-value cookie)
#f))
(let ((cookie
(findf (λ (candidate)
(string=? (client-cookie-name candidate) "racket-wiki-session"))
(request-cookies req))))
(if cookie
(client-cookie-value cookie)
#f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Resolve an authenticated session from a request cookie.
@@ -172,36 +172,36 @@
; result : A non-expired wiki-session for an enabled user, or #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (session-from-request config req)
(define token (session-cookie-token req))
(if token
(call-with-wiki-database
config
(λ (db)
(define row
(query-maybe-row
db
#<<SQL
(let ((token (session-cookie-token req)))
(if token
(call-with-wiki-database
config
(λ (db)
(let ((row
(query-maybe-row
db
#<<SQL
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
WHERE s.token_hash = $1 AND s.expires_at > $2 AND u.enabled = TRUE
SQL
(token-hash token)
(current-seconds)))
(if row
(wiki-session
(wiki-user (vector-ref row 0)
(vector-ref row 1)
(vector-ref row 2)
(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))
(token-hash token)
(current-seconds))))
(if row
(wiki-session
(wiki-user (vector-ref row 0)
(vector-ref row 1)
(vector-ref row 2)
(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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Validate a CSRF token for a session.
@@ -249,23 +249,23 @@ SQL
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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))
(call-with-wiki-database
config
(λ (db)
(query-exec
db
"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
now
now))))
(let ((now (current-seconds))
(enabled (eq? status 'enabled))
(hash (password-hash password)))
(call-with-wiki-database
config
(λ (db)
(query-exec
db
"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
now
now)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create or reset a wiki user by username.
@@ -274,15 +274,15 @@ SQL
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (upsert-user! config username display-name password role status)
(define now (current-seconds))
(define enabled (eq? status 'enabled))
(define hash (password-hash password))
(call-with-wiki-database
config
(λ (db)
(query-exec
db
#<<SQL
(let ((now (current-seconds))
(enabled (eq? status 'enabled))
(hash (password-hash password)))
(call-with-wiki-database
config
(λ (db)
(query-exec
db
#<<SQL
INSERT INTO users(username, display_name, password_hash, role, enabled, created_at, updated_at)
VALUES ($1, $2, $3, $4, $5, $6, $7)
ON CONFLICT(username) DO UPDATE SET
@@ -292,7 +292,7 @@ ON CONFLICT(username) DO UPDATE SET
enabled = excluded.enabled,
updated_at = excluded.updated_at
SQL
username display-name hash (symbol->string role) enabled now now))))
username display-name hash (symbol->string role) enabled now now)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Update a wiki user.
@@ -301,29 +301,29 @@ SQL
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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
config
(λ (db)
(if (and password (not (string=? password "")))
(query-exec db
"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, email = $2, role = $3, enabled = $4, updated_at = $5 WHERE id = $6"
display-name
(normalized-email email)
(symbol->string role)
enabled
now
id)))))
(let ((enabled (eq? status 'enabled))
(now (current-seconds)))
(call-with-wiki-database
config
(λ (db)
(if (and password (not (string=? password "")))
(query-exec db
"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, 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.
@@ -332,31 +332,31 @@ SQL
; 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?
(let ((change-password?
(and new-password (not (string=? new-password "")))))
(call-with-wiki-database
config
(λ (db)
(call-with-transaction
db
(λ ()
(when change-password?
(let ((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
"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))))))))
"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.
@@ -365,34 +365,40 @@ SQL
; 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))))))
(let ((token (random-token))
(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))
(let ((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))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Invalidate one pending password-reset token.
; pre : token is the raw token supplied to the password-reset workflow.
; post : The matching reset-token row, when present, has been deleted.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (cancel-password-reset! config token)
(call-with-wiki-database
config
@@ -412,18 +418,18 @@ SQL
(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))))))
(let* ((now (current-seconds))
(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.