322 lines
11 KiB
Racket
322 lines
11 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!
|
|
delete-user!)
|
|
|
|
(struct wiki-user (id username display-name 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)
|
|
(string->symbol (vector-ref row 3))
|
|
(vector-ref row 4)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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, 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)
|
|
(else
|
|
(wiki-user (vector-ref row 0)
|
|
(vector-ref row 1)
|
|
(vector-ref row 2)
|
|
(string->symbol (vector-ref row 3))
|
|
#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.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)
|
|
(string->symbol (vector-ref row 3))
|
|
(vector-ref row 4))
|
|
(vector-ref row 5)
|
|
(vector-ref row 6)
|
|
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, 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)
|
|
(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, password_hash, role, enabled, created_at, updated_at) VALUES ($1, $2, $3, $4, $5, $6, $7)"
|
|
username
|
|
display-name
|
|
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])
|
|
(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, role = $2, enabled = $3, password_hash = $4, updated_at = $5 WHERE id = $6"
|
|
display-name
|
|
(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"
|
|
display-name
|
|
(symbol->string role)
|
|
enabled
|
|
now
|
|
id)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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))))
|