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.
private/cmap-storage.rkt
+105 -11
View File
@@ -14,6 +14,8 @@
list-recent-concept-maps
search-concept-maps
read-concept-map
concept-map-history
read-concept-map-version
create-concept-map!
rename-concept-map!
update-concept-map!
@@ -70,6 +72,15 @@
(document->text document)
(void))
(define (insert-concept-map-version! db map-id version title document-text author action summary now)
(query-exec db
#<<SQL
INSERT INTO concept_map_versions
(concept_map_id, version, title, document, author, action, summary, created_at)
VALUES ($1, $2, $3, $4::text::jsonb, $5, $6, $7, $8)
SQL
map-id version title document-text author action summary now))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : List current concept-map metadata.
; pre : Database schema migration 9 has been installed.
@@ -208,14 +219,21 @@ SQL
(call-with-wiki-database
config
(λ (db)
(query-exec
(call-with-transaction
db
#<<SQL
(λ ()
(define map-id
(query-value
db
#<<SQL
INSERT INTO concept_maps
(slug, title, document, current_version, created_at, updated_at, created_by, updated_by)
VALUES ($1, $2, $3::text::jsonb, 1, $4, $4, $5, $5)
RETURNING id
SQL
clean-slug clean-title document-text now author)))
clean-slug clean-title document-text now author))
(insert-concept-map-version!
db map-id 1 clean-title document-text author "create" "Created CMap" now)))))
(read-concept-map config clean-slug))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -237,7 +255,7 @@ SQL
(define row
(query-maybe-row
db
"SELECT id, current_version FROM concept_maps WHERE slug = $1 AND archived = FALSE FOR UPDATE"
"SELECT id, current_version, document::text FROM concept_maps WHERE slug = $1 AND archived = FALSE FOR UPDATE"
slug))
(unless row
(error 'rename-concept-map! "unknown concept map: ~a" slug))
@@ -248,6 +266,8 @@ SQL
(string->number (format "~a" base-version))))
(unless (and supplied-version (= supplied-version current-version))
(error 'rename-concept-map! "version-conflict"))
(define next-version (+ current-version 1))
(define now (current-seconds))
(query-exec
db
#<<SQL
@@ -259,10 +279,13 @@ SET title = $1,
WHERE id = $5
SQL
clean-title
(+ current-version 1)
(current-seconds)
next-version
now
author
(vector-ref row 0))))))
(vector-ref row 0))
(insert-concept-map-version!
db (vector-ref row 0) next-version clean-title (vector-ref row 2)
author "rename" "Renamed CMap" now)))))
(read-concept-map config slug))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -271,7 +294,8 @@ SQL
; post : Title, document, version and audit fields are updated atomically.
; result : The updated concept-map hash.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (update-concept-map! config slug title document author base-version)
(define (update-concept-map! config slug title document author base-version
[summary "Edited CMap"] [action "edit"])
(define clean-title (string-trim title))
(validate-concept-map-input 'update-concept-map! slug clean-title document)
(define document-text (document->text document))
@@ -295,6 +319,8 @@ SQL
(string->number (format "~a" base-version))))
(unless (and supplied-version (= supplied-version current-version))
(error 'update-concept-map! "version-conflict"))
(define next-version (+ current-version 1))
(define now (current-seconds))
(query-exec
db
#<<SQL
@@ -308,12 +334,80 @@ WHERE id = $6
SQL
clean-title
document-text
(+ current-version 1)
(current-seconds)
next-version
now
author
(vector-ref row 0))))))
(vector-ref row 0))
(insert-concept-map-version!
db (vector-ref row 0) next-version clean-title document-text
author action summary now)))))
(read-concept-map config slug))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read immutable version metadata for a concept map.
; pre : slug identifies a current concept map.
; post : Version rows have only been read.
; result : A newest-first list without the potentially large documents.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (concept-map-history config slug)
(call-with-wiki-database
config
(λ (db)
(define map-id
(query-maybe-value
db
"SELECT id FROM concept_maps WHERE slug = $1 AND archived = FALSE"
slug))
(unless map-id
(error 'concept-map-history "unknown concept map: ~a" slug))
(for/list ((row (in-list
(query-rows db
#<<SQL
SELECT version, title, author, action, summary, created_at
FROM concept_map_versions
WHERE concept_map_id = $1
ORDER BY version DESC
SQL
map-id))))
(hash 'version (vector-ref row 0)
'title (vector-ref row 1)
'author (vector-ref row 2)
'action (vector-ref row 3)
'summary (vector-ref row 4)
'createdAt (vector-ref row 5))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read one immutable concept-map version.
; pre : slug and version identify a possible historical version.
; post : Version rows have only been read.
; result : Version metadata including its editor document, or #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (read-concept-map-version config slug version)
(define version-number
(if (number? version) version (string->number version)))
(and version-number
(call-with-wiki-database
config
(λ (db)
(define row
(query-maybe-row db
#<<SQL
SELECT cmv.version, cmv.title, cmv.document::text, cmv.author,
cmv.action, cmv.summary, cmv.created_at
FROM concept_map_versions cmv
JOIN concept_maps cm ON cm.id = cmv.concept_map_id
WHERE cm.slug = $1 AND cm.archived = FALSE AND cmv.version = $2
SQL
slug version-number))
(and row
(hash 'version (vector-ref row 0)
'title (vector-ref row 1)
'document (text->document (vector-ref row 2))
'author (vector-ref row 3)
'action (vector-ref row 4)
'summary (vector-ref row 5)
'createdAt (vector-ref row 6)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Soft-delete one concept map.
; pre : slug identifies a current map.
private/mail.rkt
+224
View File
@@ -0,0 +1,224 @@
#lang racket/base
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Password-reset email delivery configured through the database or environment.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require db
net/smtp
openssl
racket/string
"config.rkt"
"database.rkt")
(provide password-reset-mail-configured?
password-reset-mail-settings
save-password-reset-mail-settings!
send-test-mail!
send-password-reset-mail!)
(define (environment-value name)
(define value (getenv name))
(and value
(not (string=? (string-trim value) ""))
(string-trim value)))
(define (safe-header-value value)
(regexp-replace* #px"[\r\n]+" value " "))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Adapt modern TLS negotiation to net/smtp's STARTTLS callback.
; pre : host is the SMTP server name and accept-untrusted-certificates? is a boolean.
; post : A client context has been created but no connection is open.
; result : An encoder accepted by smtp-send-message.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-starttls-encoder host accept-untrusted-certificates?)
(define context
(if accept-untrusted-certificates?
(ssl-make-client-context 'auto)
(ssl-secure-client-context)))
(λ (input-port output-port
#:mode mode
#:encrypt _protocol
#:close-original? close-original?)
(if accept-untrusted-certificates?
(ports->ssl-ports input-port
output-port
#:mode mode
#:context context
#:close-original? close-original?)
(ports->ssl-ports input-port
output-port
#:mode mode
#:context context
#:hostname host
#:close-original? close-original?))))
(define setting-environment-names
(hash "public-url" "RACKET_WIKI_PUBLIC_URL"
"smtp-host" "RACKET_WIKI_SMTP_HOST"
"smtp-port" "RACKET_WIKI_SMTP_PORT"
"smtp-from" "RACKET_WIKI_SMTP_FROM"
"smtp-user" "RACKET_WIKI_SMTP_USER"
"smtp-password" "RACKET_WIKI_SMTP_PASSWORD"
"smtp-tls" "RACKET_WIKI_SMTP_TLS"
"smtp-accept-untrusted-certificates" "RACKET_WIKI_SMTP_ACCEPT_UNTRUSTED_CERTIFICATES"
"reset-limit" "RACKET_WIKI_RESET_LIMIT"))
(define (database-mail-settings config)
(call-with-wiki-database
config
(λ (db)
(for/hash ((row (in-list (query-rows db "SELECT key, value FROM wiki_settings WHERE key LIKE 'mail.%'"))))
(values (substring (vector-ref row 0) 5) (vector-ref row 1))))))
(define (password-reset-mail-settings config)
(define stored (database-mail-settings config))
(for/hash (((key environment-name) (in-hash setting-environment-names)))
(define default
(cond
((string=? key "smtp-port") "587")
((string=? key "reset-limit") "2")
((string=? key "smtp-tls") "true")
((string=? key "smtp-accept-untrusted-certificates") "false")
(else "")))
(values key (or (hash-ref stored key #f)
(environment-value environment-name)
default))))
(define (save-password-reset-mail-settings! config settings)
(call-with-wiki-database
config
(λ (db)
(call-with-transaction
db
(λ ()
(for (((key _environment-name) (in-hash setting-environment-names)))
(define supplied-value (hash-ref settings key ""))
(define value
(if (string=? key "smtp-password")
supplied-value
(string-trim supplied-value)))
(unless (and (string=? key "smtp-password") (string=? value ""))
(if (string=? value "")
(query-exec db "DELETE FROM wiki_settings WHERE key = $1" (string-append "mail." key))
(query-exec db
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO UPDATE SET value = excluded.value, updated_at = excluded.updated_at"
(string-append "mail." key) value (current-seconds))))))))))
(define (password-reset-mail-configured? config)
(define settings (password-reset-mail-settings config))
(and (not (string=? (hash-ref settings "public-url") ""))
(not (string=? (hash-ref settings "smtp-host") ""))
(not (string=? (hash-ref settings "smtp-from") ""))))
(define (settings-with-stored-password config supplied-settings)
(define stored-settings (password-reset-mail-settings config))
(define supplied-password (hash-ref supplied-settings "smtp-password" ""))
(define effective-password
(if (string=? supplied-password "")
(hash-ref stored-settings "smtp-password" "")
supplied-password))
(for/hash (((key _environment-name) (in-hash setting-environment-names)))
(define value
(if (string=? key "smtp-password")
effective-password
(hash-ref supplied-settings key (hash-ref stored-settings key ""))))
(values key value)))
(define (send-mail-with-settings! settings recipient subject body-lines)
(define host (string-trim (hash-ref settings "smtp-host" "")))
(define from (safe-header-value (string-trim (hash-ref settings "smtp-from" ""))))
(when (string=? host "")
(error 'send-mail-with-settings! "SMTP server is required"))
(when (string=? from "")
(error 'send-mail-with-settings! "Sender address is required"))
(define configured-port (string->number (hash-ref settings "smtp-port" "587")))
(define port
(if (and (exact-integer? configured-port) (<= 1 configured-port 65535))
configured-port
587))
(define configured-user (hash-ref settings "smtp-user" ""))
(define user
(if (string=? configured-user "") #f configured-user))
(define configured-password (hash-ref settings "smtp-password" ""))
(define password
(if (string=? configured-password "") #f configured-password))
(define starttls?
(string-ci=? (hash-ref settings "smtp-tls" "true") "true"))
(define accept-untrusted-certificates?
(string-ci=? (hash-ref settings "smtp-accept-untrusted-certificates" "false") "true"))
(define header
(string-append "From: " from "\r\n"
"To: " (safe-header-value recipient) "\r\n"
"Subject: " (safe-header-value subject) "\r\n"
"MIME-Version: 1.0\r\n"
"Content-Type: text/plain; charset=UTF-8\r\n"
"\r\n"))
(define message
(for/list ((line (in-list body-lines)))
(string->bytes/utf-8 line)))
(with-handlers ((exn:fail?
(λ (exception)
(define message (exn-message exception))
(if (regexp-match? #px"certificate verify failed" message)
(error 'send-mail-with-settings!
"TLS certificate verification failed; install a valid certificate or explicitly accept untrusted certificates for this trusted local SMTP server")
(raise exception)))))
(smtp-send-message host
from
(list recipient)
header
message
#:port-no port
#:auth-user user
#:auth-passwd password
#:tls-encode (if starttls?
(make-starttls-encoder host accept-untrusted-certificates?)
#f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Test supplied SMTP settings without storing them.
; pre : supplied-settings contains the values from the admin form.
; post : One test message has been submitted; settings are unchanged.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (send-test-mail! config supplied-settings recipient)
(define settings
(settings-with-stored-password config supplied-settings))
(send-mail-with-settings!
settings
recipient
(string-append (wiki-config-site-title config) " SMTP test")
(list (string-append "This is a test message from "
(wiki-config-site-title config)
".")
""
"The SMTP server accepted the message using the settings from the administration form.")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Send a one-time password-reset link through configured SMTP.
; pre : Required mail settings are configured in the database or environment.
; post : One email has been submitted to the SMTP server.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (send-password-reset-mail! config recipient token)
(unless (password-reset-mail-configured? config)
(error 'send-password-reset-mail! "Password-reset email is not configured"))
(define settings (password-reset-mail-settings config))
(define public-url
(string-trim (hash-ref settings "public-url") "/" #:right? #t))
(define reset-url
(string-append public-url "/reset-password?token=" token))
(send-mail-with-settings!
settings
recipient
"Password reset"
(list (string-append "A password reset was requested for your account at "
(wiki-config-site-title config)
".")
""
"Open this link within one hour:"
reset-url
""
"If you did not request this, you can ignore this email.")))
private/migrations.rkt
+68 -1
View File
@@ -20,7 +20,7 @@
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define current-schema-version 9)
(define current-schema-version 11)
(define schema-1-statements
(list
@@ -323,6 +323,67 @@ SQL
"CREATE INDEX IF NOT EXISTS concept_maps_title_idx ON concept_maps(lower(title))")
(record-schema-version! db 9))
(define (migrate-9->10! db)
(query-exec db "ALTER TABLE users ADD COLUMN IF NOT EXISTS email TEXT")
(query-exec db
"CREATE UNIQUE INDEX IF NOT EXISTS users_email_unique_idx ON users(lower(email)) WHERE email IS NOT NULL")
(query-exec db
#<<SQL
CREATE TABLE IF NOT EXISTS password_reset_tokens (
token_hash TEXT PRIMARY KEY,
user_id BIGINT NOT NULL REFERENCES users(id) ON DELETE CASCADE,
created_at BIGINT NOT NULL,
expires_at BIGINT NOT NULL,
used_at BIGINT
)
SQL
)
(query-exec db
#<<SQL
CREATE TABLE IF NOT EXISTS wiki_settings (
key TEXT PRIMARY KEY,
value TEXT NOT NULL,
updated_at BIGINT NOT NULL
)
SQL
)
(query-exec db
"CREATE INDEX IF NOT EXISTS password_reset_tokens_user_idx ON password_reset_tokens(user_id, expires_at DESC)")
(query-exec db
"CREATE INDEX IF NOT EXISTS password_reset_tokens_expires_idx ON password_reset_tokens(expires_at)")
(record-schema-version! db 10))
(define (migrate-10->11! db)
(query-exec db
#<<SQL
CREATE TABLE IF NOT EXISTS concept_map_versions (
id BIGSERIAL PRIMARY KEY,
concept_map_id BIGINT NOT NULL REFERENCES concept_maps(id) ON DELETE CASCADE,
version BIGINT NOT NULL,
title TEXT NOT NULL,
document JSONB NOT NULL,
author TEXT NOT NULL,
action TEXT NOT NULL,
summary TEXT NOT NULL,
created_at BIGINT NOT NULL,
UNIQUE(concept_map_id, version)
)
SQL
)
(query-exec db
"CREATE INDEX IF NOT EXISTS concept_map_versions_map_idx ON concept_map_versions(concept_map_id, version DESC)")
(query-exec db
#<<SQL
INSERT INTO concept_map_versions
(concept_map_id, version, title, document, author, action, summary, created_at)
SELECT id, current_version, title, document, updated_by, 'snapshot',
'Current state when CMap history was enabled', updated_at
FROM concept_maps
ON CONFLICT (concept_map_id, version) DO NOTHING
SQL
)
(record-schema-version! db 11))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Bring a racket-wiki PostgreSQL database to the current schema.
; pre : db is a writable PostgreSQL connection and config identifies the
@@ -361,6 +422,12 @@ SQL
(define after-page-aliases (database-schema-version db))
(when (= after-page-aliases 8)
(migrate-8->9! db))
(define after-concept-maps (database-schema-version db))
(when (= after-concept-maps 9)
(migrate-9->10! db))
(define after-user-profiles (database-schema-version db))
(when (= after-user-profiles 10)
(migrate-10->11! db))
(define resulting-version (database-schema-version db))
(when (> resulting-version current-schema-version)
(error 'migrate-database!