439 lines
17 KiB
Racket
439 lines
17 KiB
Racket
#lang racket/base
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Users, passwords, sessions, roles and CSRF authentication.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(require crypto
|
|
crypto/libcrypto
|
|
db
|
|
racket/list
|
|
racket/string
|
|
web-server/http/cookie-parse
|
|
"config.rkt"
|
|
"database.rkt")
|
|
|
|
(provide (struct-out wiki-user)
|
|
(struct-out wiki-session)
|
|
authenticate-user
|
|
create-session!
|
|
delete-session!
|
|
session-from-request
|
|
csrf-valid?
|
|
role-at-least?
|
|
list-users
|
|
administrator-exists?
|
|
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 email role enabled?) #:transparent)
|
|
(struct wiki-session (user csrf-token expires-at token) #:transparent)
|
|
|
|
(crypto-factories (list libcrypto-factory))
|
|
|
|
(define role-order
|
|
(hash 'reader 10
|
|
'editor 20
|
|
'admin 30))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Check whether a user has a required role level.
|
|
; pre : required-role is reader, editor or admin; user is a wiki-user or #f.
|
|
; post : No external state has been changed.
|
|
; result : #t when the user has the required role level, otherwise #f.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (role-at-least? user required-role)
|
|
(and user
|
|
(>= (hash-ref role-order (wiki-user-role user) 0)
|
|
(hash-ref role-order required-role 100))))
|
|
|
|
(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))))
|
|
|
|
(define (random-token [size 32])
|
|
(bytes->hex (crypto-random-bytes size)))
|
|
|
|
(define (token-hash token)
|
|
(bytes->hex (digest 'sha256 (string->bytes/utf-8 token))))
|
|
|
|
(define (password-hash password)
|
|
(pwhash '(pbkdf2 hmac sha256)
|
|
(string->bytes/utf-8 password)
|
|
'((iterations 600000))))
|
|
|
|
(define (password-valid? password stored-hash)
|
|
(with-handlers ((exn:fail? (λ (_e) #f)))
|
|
(pwhash-verify #f (string->bytes/utf-8 password) stored-hash)))
|
|
|
|
(define (row->user row)
|
|
(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)))
|
|
|
|
(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.
|
|
; pre : username and password are strings.
|
|
; post : The user database has only been read.
|
|
; result : A wiki-user on success, otherwise #f.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (authenticate-user config username password)
|
|
(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))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create a login session for a user.
|
|
; pre : user is an enabled wiki-user.
|
|
; post : A hashed session token and CSRF token have been stored in PostgreSQL.
|
|
; 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))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Delete a login session.
|
|
; pre : token is a session token string or #f.
|
|
; post : The matching stored session has been deleted when token was supplied.
|
|
; result : void.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (delete-session! config token)
|
|
(when token
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(query-exec db
|
|
"DELETE FROM sessions WHERE token_hash = $1"
|
|
(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))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Resolve an authenticated session from a request cookie.
|
|
; pre : req is a web-server request.
|
|
; post : The user and session tables have only been read.
|
|
; 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
|
|
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))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Validate a CSRF token for a session.
|
|
; pre : session is a wiki-session or #f and csrf-token is a string or #f.
|
|
; post : No external state has been changed.
|
|
; result : #t when the supplied token belongs to the session, otherwise #f.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (csrf-valid? session csrf-token)
|
|
(and session
|
|
csrf-token
|
|
(string=? csrf-token (wiki-session-csrf-token session))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : List wiki users.
|
|
; pre : The user database is initialized.
|
|
; post : The user table has only been read.
|
|
; result : A username-sorted list of wiki-user values.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (list-users config)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(for/list ([row (in-list (query-rows db
|
|
"SELECT id, username, display_name, email, role, enabled FROM users ORDER BY username"))])
|
|
(row->user row)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Check whether at least one enabled administrator exists.
|
|
; pre : The user database is initialized.
|
|
; post : The user table has only been read.
|
|
; result : #t when an enabled administrator exists, otherwise #f.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (administrator-exists? config)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(> (query-value db
|
|
"SELECT COUNT(*) FROM users WHERE role = 'admin' AND enabled = TRUE")
|
|
0))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create a wiki user.
|
|
; pre : username is unused and role/status are supported symbols.
|
|
; post : The new user and password hash have been stored.
|
|
; 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))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create or reset a wiki user by username.
|
|
; pre : role/status are supported symbols.
|
|
; post : The named user exists with the supplied display name, password, role and status.
|
|
; 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
|
|
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
|
|
display_name = excluded.display_name,
|
|
password_hash = excluded.password_hash,
|
|
role = excluded.role,
|
|
enabled = excluded.enabled,
|
|
updated_at = excluded.updated_at
|
|
SQL
|
|
username display-name hash (symbol->string role) enabled now now))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Update a wiki user.
|
|
; pre : id identifies a user and role/status are supported symbols.
|
|
; 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] [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)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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.
|
|
; post : The user and cascading sessions have been deleted when present.
|
|
; result : void.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (delete-user! config id)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(query-exec db "DELETE FROM users WHERE id = $1" id))))
|