refactoring by skill
This commit is contained in:
@@ -28,49 +28,49 @@ SQL
|
||||
(format "/uploads/~a/~a" reference stored-name))
|
||||
|
||||
(define (page-references db page-id)
|
||||
(define current
|
||||
(query-row db
|
||||
"SELECT namespace, slug FROM pages WHERE id = $1"
|
||||
page-id))
|
||||
(define references
|
||||
(list (if (string=? (vector-ref current 0) "")
|
||||
(vector-ref current 1)
|
||||
(string-append (vector-ref current 0) ":" (vector-ref current 1)))))
|
||||
(define aliases-available?
|
||||
(query-value db "SELECT to_regclass('page_aliases') IS NOT NULL"))
|
||||
(when aliases-available?
|
||||
(for ((row (in-list
|
||||
(query-rows db
|
||||
"SELECT namespace, slug FROM page_aliases WHERE page_id = $1 ORDER BY id"
|
||||
page-id))))
|
||||
(define reference
|
||||
(if (string=? (vector-ref row 0) "")
|
||||
(vector-ref row 1)
|
||||
(string-append (vector-ref row 0) ":" (vector-ref row 1))))
|
||||
(set! references (cons reference references))))
|
||||
references)
|
||||
(let* ((current
|
||||
(query-row db
|
||||
"SELECT namespace, slug FROM pages WHERE id = $1"
|
||||
page-id))
|
||||
(references
|
||||
(list (if (string=? (vector-ref current 0) "")
|
||||
(vector-ref current 1)
|
||||
(string-append (vector-ref current 0) ":" (vector-ref current 1)))))
|
||||
(aliases-available?
|
||||
(query-value db "SELECT to_regclass('page_aliases') IS NOT NULL")))
|
||||
(when aliases-available?
|
||||
(for ((row (in-list
|
||||
(query-rows db
|
||||
"SELECT namespace, slug FROM page_aliases WHERE page_id = $1 ORDER BY id"
|
||||
page-id))))
|
||||
(let ((reference
|
||||
(if (string=? (vector-ref row 0) "")
|
||||
(vector-ref row 1)
|
||||
(string-append (vector-ref row 0) ":" (vector-ref row 1)))))
|
||||
(set! references (cons reference references)))))
|
||||
references))
|
||||
|
||||
(define (record-references! db page-id page-version-id markdown current? referenced-at)
|
||||
(for ((row (in-list (attachment-rows db))))
|
||||
(define attachment-id (vector-ref row 0))
|
||||
(define owner-page-id (vector-ref row 1))
|
||||
(define stored-name (vector-ref row 2))
|
||||
(define found? #f)
|
||||
(for ((reference (in-list (page-references db owner-page-id))))
|
||||
(when (string-contains? markdown (attachment-url reference stored-name))
|
||||
(set! found? #t)))
|
||||
(when found?
|
||||
(query-exec db
|
||||
#<<SQL
|
||||
(let ((attachment-id (vector-ref row 0))
|
||||
(owner-page-id (vector-ref row 1))
|
||||
(stored-name (vector-ref row 2))
|
||||
(found? #f))
|
||||
(for ((reference (in-list (page-references db owner-page-id))))
|
||||
(when (string-contains? markdown (attachment-url reference stored-name))
|
||||
(set! found? #t)))
|
||||
(when found?
|
||||
(query-exec db
|
||||
#<<SQL
|
||||
INSERT INTO attachment_references
|
||||
(attachment_id, page_id, page_version_id, current_reference, referenced_at)
|
||||
VALUES ($1, $2, $3, $4, $5)
|
||||
SQL
|
||||
attachment-id
|
||||
page-id
|
||||
page-version-id
|
||||
current?
|
||||
referenced-at))))
|
||||
attachment-id
|
||||
page-id
|
||||
page-version-id
|
||||
current?
|
||||
referenced-at)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
|
||||
+187
-181
@@ -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.
|
||||
|
||||
@@ -830,7 +830,7 @@ SQL
|
||||
(and version-number
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(lambda (db)
|
||||
(λ (db)
|
||||
(and
|
||||
(query-maybe-value
|
||||
db
|
||||
@@ -962,13 +962,13 @@ SQL
|
||||
'externalUrl)
|
||||
"https://example.com/path")
|
||||
(check-exn exn:fail?
|
||||
(lambda ()
|
||||
(λ ()
|
||||
(concept-content
|
||||
(hash 'id concept-a
|
||||
'label "Unsafe concept"
|
||||
'externalUrl "javascript:alert(1)"))))
|
||||
(check-exn exn:fail?
|
||||
(lambda ()
|
||||
(λ ()
|
||||
(concept-map-storage-document
|
||||
(hash 'concepts (list (hash 'id "legacy:map:concept-1"))
|
||||
'items '())))))
|
||||
|
||||
+72
-49
@@ -97,59 +97,82 @@
|
||||
(define (normalize-cmap-styles styles [who 'cmap-styles])
|
||||
(unless (and (list? styles) (<= 1 (length styles) maximum-style-count))
|
||||
(error who "styles must contain between 1 and ~a entries" maximum-style-count))
|
||||
(define seen (make-hash))
|
||||
(define normalized
|
||||
(for/list ([style (in-list styles)])
|
||||
(unless (hash? style) (error who "each style must be an object"))
|
||||
(define id (required-string who (hash-ref style 'id #f) "style id" 120))
|
||||
(unless (regexp-match? #px"^[A-Za-z0-9_-]+$" id) (error who "invalid style id"))
|
||||
(when (hash-ref seen id #f) (error who "duplicate style id: ~a" id))
|
||||
(hash-set! seen id #t)
|
||||
(define name (and (string? (hash-ref style 'name #f))
|
||||
(required-string who (hash-ref style 'name) "style name" maximum-style-name-length)))
|
||||
(define name-key (and (string? (hash-ref style 'nameKey #f))
|
||||
(string->symbol (required-string who (hash-ref style 'nameKey) "style name key" 40))))
|
||||
(unless (or name (member name-key permitted-name-keys))
|
||||
(error who "a style needs a name"))
|
||||
(hash 'id id
|
||||
(if (member name-key permitted-name-keys) 'nameKey 'name)
|
||||
(if (member name-key permitted-name-keys) (symbol->string name-key) name)
|
||||
'protected (string=? id "default")
|
||||
'values (normalize-style-values who (hash-ref style 'values #f)))))
|
||||
(unless (hash-ref seen "default" #f) (error who "the default style is required"))
|
||||
normalized)
|
||||
(let* ((seen (make-hash))
|
||||
(normalized
|
||||
(for/list ([style (in-list styles)])
|
||||
(unless (hash? style) (error who "each style must be an object"))
|
||||
(let* ((id (required-string who (hash-ref style 'id #f) "style id" 120))
|
||||
(name (and (string? (hash-ref style 'name #f))
|
||||
(required-string who
|
||||
(hash-ref style 'name)
|
||||
"style name"
|
||||
maximum-style-name-length)))
|
||||
(name-key
|
||||
(and (string? (hash-ref style 'nameKey #f))
|
||||
(string->symbol
|
||||
(required-string who
|
||||
(hash-ref style 'nameKey)
|
||||
"style name key"
|
||||
40)))))
|
||||
(unless (regexp-match? #px"^[A-Za-z0-9_-]+$" id)
|
||||
(error who "invalid style id"))
|
||||
(when (hash-ref seen id #f)
|
||||
(error who "duplicate style id: ~a" id))
|
||||
(hash-set! seen id #t)
|
||||
(unless (or name (member name-key permitted-name-keys))
|
||||
(error who "a style needs a name"))
|
||||
(hash 'id id
|
||||
(if (member name-key permitted-name-keys) 'nameKey 'name)
|
||||
(if (member name-key permitted-name-keys) (symbol->string name-key) name)
|
||||
'protected (string=? id "default")
|
||||
'values (normalize-style-values who (hash-ref style 'values #f)))))))
|
||||
(unless (hash-ref seen "default" #f)
|
||||
(error who "the default style is required"))
|
||||
normalized))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the shared CMap appearance styles.
|
||||
; pre : The wiki database is configured and its schema is initialized.
|
||||
; post : Default styles are inserted when no style setting exists yet.
|
||||
; result : A validated, normalized non-empty list of style hashes.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (read-cmap-styles config)
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(lambda (db)
|
||||
(define stored
|
||||
(query-maybe-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key))
|
||||
(if stored
|
||||
(normalize-cmap-styles (string->jsexpr stored) 'read-cmap-styles)
|
||||
(let ([encoded (jsexpr->string (normalize-cmap-styles initial-cmap-styles))])
|
||||
(query-exec
|
||||
db
|
||||
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO NOTHING"
|
||||
setting-key encoded (current-seconds))
|
||||
(normalize-cmap-styles
|
||||
(string->jsexpr
|
||||
(query-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key))
|
||||
'read-cmap-styles))))))
|
||||
(λ (db)
|
||||
(let ((stored
|
||||
(query-maybe-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key)))
|
||||
(if stored
|
||||
(normalize-cmap-styles (string->jsexpr stored) 'read-cmap-styles)
|
||||
(let ((encoded (jsexpr->string (normalize-cmap-styles initial-cmap-styles))))
|
||||
(query-exec
|
||||
db
|
||||
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO NOTHING"
|
||||
setting-key encoded (current-seconds))
|
||||
(normalize-cmap-styles
|
||||
(string->jsexpr
|
||||
(query-value db "SELECT value FROM wiki_settings WHERE key = $1" setting-key))
|
||||
'read-cmap-styles)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Validate and store the shared CMap appearance styles.
|
||||
; pre : styles is a non-empty list containing the required default style.
|
||||
; post : The normalized style setting is stored atomically in the database.
|
||||
; result : The normalized list of stored style hashes.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (save-cmap-styles! config styles)
|
||||
(define normalized (normalize-cmap-styles styles 'save-cmap-styles!))
|
||||
(define encoded (jsexpr->string normalized))
|
||||
(when (> (bytes-length (string->bytes/utf-8 encoded)) (* 128 1024))
|
||||
(error 'save-cmap-styles! "style data is too large"))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(lambda (db)
|
||||
(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"
|
||||
setting-key encoded (current-seconds))))
|
||||
normalized)
|
||||
(let* ((normalized (normalize-cmap-styles styles 'save-cmap-styles!))
|
||||
(encoded (jsexpr->string normalized)))
|
||||
(when (> (bytes-length (string->bytes/utf-8 encoded)) (* 128 1024))
|
||||
(error 'save-cmap-styles! "style data is too large"))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(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"
|
||||
setting-key encoded (current-seconds))))
|
||||
normalized))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
@@ -164,8 +187,8 @@
|
||||
(list (hash 'id "default" 'nameKey "style-default" 'values values))))
|
||||
(check-equal? (hash-ref (hash-ref (first normalized) 'values) 'backgroundColor) "#fff4cf")
|
||||
(check-equal? (length (normalize-cmap-styles initial-cmap-styles)) 5)
|
||||
(check-exn exn:fail? (lambda () (normalize-cmap-styles '())))
|
||||
(check-exn exn:fail? (λ () (normalize-cmap-styles '())))
|
||||
(check-exn exn:fail?
|
||||
(lambda ()
|
||||
(λ ()
|
||||
(normalize-cmap-styles
|
||||
(list (hash 'id "custom" 'name "Custom" 'values values))))))
|
||||
|
||||
+25
-1
@@ -17,20 +17,44 @@
|
||||
|
||||
;; Concept ids are stored as plain UUID strings. Validation accepts uppercase
|
||||
;; input, while normalization always produces the canonical lowercase form.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Check whether a value is a plain UUID concept identifier.
|
||||
; pre : value is any Racket value.
|
||||
; post : No state is changed.
|
||||
; result : #t when value is a UUID string, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (concept-id? value)
|
||||
(uuid-string? value))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Convert a supported concept identifier to its canonical form.
|
||||
; pre : value is any Racket value.
|
||||
; post : No state is changed.
|
||||
; result : A lowercase UUID string, or #f when value is not recognized.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (normalize-concept-id value)
|
||||
(cond
|
||||
[(uuid-string? value) (string-downcase value)]
|
||||
[(and (string? value)
|
||||
(regexp-match prefixed-uuid-concept-id-pattern value))
|
||||
=> (lambda (match) (string-downcase (cadr match)))]
|
||||
=> (λ (match) (string-downcase (cadr match)))]
|
||||
[else #f]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Create a new canonical concept identifier.
|
||||
; pre : none.
|
||||
; post : No persistent state is changed.
|
||||
; result : A freshly generated lowercase UUID string.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (new-concept-id)
|
||||
(uuid-string))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Normalize a concept identifier or create a replacement.
|
||||
; pre : value is any Racket value.
|
||||
; post : No persistent state is changed.
|
||||
; result : The normalized identifier, or a fresh UUID when value is invalid.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (normalized-or-new-concept-id value)
|
||||
(or (normalize-concept-id value)
|
||||
(new-concept-id)))
|
||||
|
||||
+53
-11
@@ -43,35 +43,77 @@
|
||||
#:site-title [site-title "Racket Wiki"]
|
||||
#:session-seconds [session-seconds (* 12 60 60)]
|
||||
#:language [language "en"])
|
||||
(define normalized-listen-ip
|
||||
(if (equal? listen-ip "*")
|
||||
#f
|
||||
listen-ip))
|
||||
(wiki-config (path->complete-path data-dir)
|
||||
port
|
||||
normalized-listen-ip
|
||||
secure-cookie?
|
||||
site-title
|
||||
session-seconds
|
||||
language))
|
||||
(let ((normalized-listen-ip
|
||||
(if (equal? listen-ip "*")
|
||||
#f
|
||||
listen-ip)))
|
||||
(wiki-config (path->complete-path data-dir)
|
||||
port
|
||||
normalized-listen-ip
|
||||
secure-cookie?
|
||||
site-title
|
||||
session-seconds
|
||||
language)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Create the default wiki configuration.
|
||||
; pre : none.
|
||||
; post : No files or settings have been changed.
|
||||
; result : A wiki-config using the documented default values.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (default-wiki-config)
|
||||
(make-wiki-config))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Resolve the directory containing uploaded files.
|
||||
; pre : config is a wiki-config value.
|
||||
; post : No directory is created.
|
||||
; result : The uploads path below the configured data directory.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (uploads-directory config)
|
||||
(build-path (wiki-config-data-dir config) "uploads"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Resolve the directory reserved for deleted data.
|
||||
; pre : config is a wiki-config value.
|
||||
; post : No directory is created.
|
||||
; result : The deleted-data path below the configured data directory.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (deleted-directory config)
|
||||
(build-path (wiki-config-data-dir config) "deleted"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Resolve the writable static-data directory.
|
||||
; pre : config is a wiki-config value.
|
||||
; post : No directory is created.
|
||||
; result : The static path below the configured data directory.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (data-static-directory config)
|
||||
(build-path (wiki-config-data-dir config) "static"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Resolve the downloaded browser-library directory.
|
||||
; pre : config is a wiki-config value.
|
||||
; post : No directory is created.
|
||||
; result : The vendor path below the writable static-data directory.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (vendor-directory config)
|
||||
(build-path (data-static-directory config) "vendor"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Resolve the PostgreSQL settings file.
|
||||
; pre : config is a wiki-config value.
|
||||
; post : No file is created or read.
|
||||
; result : The database.rktd path below the configured data directory.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (database-config-path config)
|
||||
(build-path (wiki-config-data-dir config) "database.rktd"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Resolve the selected-language settings file.
|
||||
; pre : config is a wiki-config value.
|
||||
; post : No file is created or read.
|
||||
; result : The language.rktd path below the configured data directory.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (language-config-path config)
|
||||
(build-path (wiki-config-data-dir config) "language.rktd"))
|
||||
|
||||
+65
-29
@@ -26,6 +26,12 @@
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Check whether PostgreSQL settings have been saved.
|
||||
; pre : config is a wiki-config value.
|
||||
; post : The settings path has only been inspected.
|
||||
; result : #t when database.rktd exists, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (database-settings-exist? config)
|
||||
(file-exists? (database-config-path config)))
|
||||
|
||||
@@ -45,12 +51,24 @@
|
||||
(hash-ref value 'password "")
|
||||
(hash-ref value 'ssl 'no)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the saved PostgreSQL connection settings.
|
||||
; pre : config is a wiki-config value.
|
||||
; post : The settings file, when present, has only been read.
|
||||
; result : A database-settings value, or #f when no settings file exists.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (read-database-settings config)
|
||||
(and (database-settings-exist? config)
|
||||
(call-with-input-file (database-config-path config)
|
||||
(λ (in)
|
||||
(datum->settings (read in))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Persist PostgreSQL connection settings.
|
||||
; pre : config and settings are wiki-config and database-settings values.
|
||||
; post : database.rktd contains settings and is private where supported.
|
||||
; result : void.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (write-database-settings! config settings)
|
||||
(make-directory* (wiki-config-data-dir config))
|
||||
(call-with-output-file (database-config-path config)
|
||||
@@ -63,24 +81,30 @@
|
||||
(void))
|
||||
|
||||
(define (connect settings)
|
||||
(define password
|
||||
(if (string=? (database-settings-password settings) "")
|
||||
#f
|
||||
(database-settings-password settings)))
|
||||
(postgresql-connect #:server (database-settings-server settings)
|
||||
#:port (database-settings-port settings)
|
||||
#:database (database-settings-database settings)
|
||||
#:user (database-settings-user settings)
|
||||
#:password password
|
||||
#:ssl (database-settings-ssl settings)))
|
||||
(let ((password
|
||||
(if (string=? (database-settings-password settings) "")
|
||||
#f
|
||||
(database-settings-password settings))))
|
||||
(postgresql-connect #:server (database-settings-server settings)
|
||||
#:port (database-settings-port settings)
|
||||
#:database (database-settings-database settings)
|
||||
#:user (database-settings-user settings)
|
||||
#:password password
|
||||
#:ssl (database-settings-ssl settings))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Verify that supplied PostgreSQL settings can execute a query.
|
||||
; pre : settings is a database-settings value for a reachable database.
|
||||
; post : The temporary connection is closed on success or failure.
|
||||
; result : void, or a database exception when validation fails.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (test-database-settings! settings)
|
||||
(define db (connect settings))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ () (query-value db "SELECT 1"))
|
||||
(λ () (disconnect db)))
|
||||
(void))
|
||||
(let ((db (connect settings)))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ () (query-value db "SELECT 1"))
|
||||
(λ () (disconnect db)))
|
||||
(void)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Run a procedure with a fresh PostgreSQL connection.
|
||||
@@ -89,26 +113,32 @@
|
||||
; result : The value returned by proc.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (call-with-wiki-database config proc)
|
||||
(define settings (read-database-settings config))
|
||||
(unless settings
|
||||
(error 'call-with-wiki-database "PostgreSQL is not configured"))
|
||||
(define db (connect settings))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ () (proc db))
|
||||
(λ () (disconnect db))))
|
||||
(let ((settings (read-database-settings config)))
|
||||
(unless settings
|
||||
(error 'call-with-wiki-database "PostgreSQL is not configured"))
|
||||
(let ((db (connect settings)))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ () (proc db))
|
||||
(λ () (disconnect db))))))
|
||||
|
||||
(define (initialize-on-connection! db config)
|
||||
(migrate-database! db config)
|
||||
(query-exec db "DELETE FROM sessions WHERE expires_at <= $1" (current-seconds))
|
||||
(void))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Initialize the wiki schema using explicit PostgreSQL settings.
|
||||
; pre : settings can connect to a writable PostgreSQL database.
|
||||
; post : Migrations are complete, expired sessions are removed and the connection is closed.
|
||||
; result : void.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (initialize-database-with-settings! settings config)
|
||||
(define db (connect settings))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ () (initialize-on-connection! db config))
|
||||
(λ () (disconnect db))))
|
||||
(let ((db (connect settings)))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ () (initialize-on-connection! db config))
|
||||
(λ () (disconnect db)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Initialize the PostgreSQL schema used by racket-wiki.
|
||||
@@ -122,6 +152,12 @@
|
||||
(λ (db)
|
||||
(initialize-on-connection! db config))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Check whether the configured database has the required core tables.
|
||||
; pre : config is a wiki-config value.
|
||||
; post : The database is unchanged and every temporary connection is closed.
|
||||
; result : #t when settings and core tables are available, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (database-ready? config)
|
||||
(and (database-settings-exist? config)
|
||||
(with-handlers ((exn:fail? (λ (_e) #f)))
|
||||
|
||||
+18
-18
@@ -82,10 +82,10 @@
|
||||
; result : The decoded JSON value, or an empty hash for an empty body.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (request-json req)
|
||||
(define body (request-post-data/raw req))
|
||||
(if body
|
||||
(bytes->jsexpr body)
|
||||
(hash)))
|
||||
(let ((body (request-post-data/raw req)))
|
||||
(if body
|
||||
(bytes->jsexpr body)
|
||||
(hash))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read a request header as UTF-8 text.
|
||||
@@ -94,11 +94,11 @@
|
||||
; result : The header value as a string, or #f when absent.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (request-header/string req name)
|
||||
(define found
|
||||
(headers-assq* (string->bytes/utf-8 name)
|
||||
(request-headers/raw req)))
|
||||
(and found
|
||||
(bytes->string/utf-8 (header-value found))))
|
||||
(let ((found
|
||||
(headers-assq* (string->bytes/utf-8 name)
|
||||
(request-headers/raw req))))
|
||||
(and found
|
||||
(bytes->string/utf-8 (header-value found)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Create an HTTP response containing bytes.
|
||||
@@ -121,12 +121,12 @@
|
||||
; result : A MIME byte string; application/octet-stream when the extension is unknown.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (extension->mime filename)
|
||||
(define lower (string-downcase filename))
|
||||
(cond
|
||||
((regexp-match? #px"[.]png$" lower) #"image/png")
|
||||
((regexp-match? #px"[.](jpg|jpeg)$" lower) #"image/jpeg")
|
||||
((regexp-match? #px"[.]gif$" lower) #"image/gif")
|
||||
((regexp-match? #px"[.]webp$" lower) #"image/webp")
|
||||
((regexp-match? #px"[.]pdf$" lower) #"application/pdf")
|
||||
((regexp-match? #px"[.]txt$" lower) #"text/plain; charset=utf-8")
|
||||
(else #"application/octet-stream")))
|
||||
(let ((lower (string-downcase filename)))
|
||||
(cond
|
||||
((regexp-match? #px"[.]png$" lower) #"image/png")
|
||||
((regexp-match? #px"[.](jpg|jpeg)$" lower) #"image/jpeg")
|
||||
((regexp-match? #px"[.]gif$" lower) #"image/gif")
|
||||
((regexp-match? #px"[.]webp$" lower) #"image/webp")
|
||||
((regexp-match? #px"[.]pdf$" lower) #"application/pdf")
|
||||
((regexp-match? #px"[.]txt$" lower) #"text/plain; charset=utf-8")
|
||||
(else #"application/octet-stream"))))
|
||||
|
||||
+155
-140
@@ -18,10 +18,10 @@
|
||||
send-password-reset-mail!)
|
||||
|
||||
(define (environment-value name)
|
||||
(define value (getenv name))
|
||||
(and value
|
||||
(not (string=? (string-trim value) ""))
|
||||
(string-trim value)))
|
||||
(let ((value (getenv name)))
|
||||
(and value
|
||||
(not (string=? (string-trim value) ""))
|
||||
(string-trim value))))
|
||||
|
||||
(define (safe-header-value value)
|
||||
(regexp-replace* #px"[\r\n]+" value " "))
|
||||
@@ -33,26 +33,26 @@
|
||||
; 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?))))
|
||||
(let ((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"
|
||||
@@ -72,20 +72,32 @@
|
||||
(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))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Resolve the effective password-reset mail settings.
|
||||
; pre : The wiki database schema is initialized.
|
||||
; post : Database settings and environment variables have only been read.
|
||||
; result : A hash containing every supported mail setting and its effective value.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(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))))
|
||||
(let ((stored (database-mail-settings config)))
|
||||
(for/hash (((key environment-name) (in-hash setting-environment-names)))
|
||||
(let ((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))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Store password-reset mail settings supplied by an administrator.
|
||||
; pre : settings is a hash containing string values for supported mail keys.
|
||||
; post : Non-empty settings are upserted and cleared settings are removed atomically.
|
||||
; result : void.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (save-password-reset-mail-settings! config settings)
|
||||
(call-with-wiki-database
|
||||
config
|
||||
@@ -94,88 +106,91 @@
|
||||
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))))))))))
|
||||
(let* ((supplied-value (hash-ref settings key ""))
|
||||
(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)))))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Check whether password-reset email has its minimum required settings.
|
||||
; pre : The wiki database schema is initialized.
|
||||
; post : Mail settings have only been read.
|
||||
; result : #t when public URL, SMTP host and sender are non-empty, otherwise #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(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") ""))))
|
||||
(let ((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)))
|
||||
(let* ((stored-settings (password-reset-mail-settings config))
|
||||
(supplied-password (hash-ref supplied-settings "smtp-password" ""))
|
||||
(effective-password
|
||||
(if (string=? supplied-password "")
|
||||
(hash-ref stored-settings "smtp-password" "")
|
||||
supplied-password)))
|
||||
(for/hash (((key _environment-name) (in-hash setting-environment-names)))
|
||||
(let ((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))))
|
||||
(let ((host (string-trim (hash-ref settings "smtp-host" "")))
|
||||
(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"))
|
||||
(let* ((configured-port (string->number (hash-ref settings "smtp-port" "587")))
|
||||
(port
|
||||
(if (and (exact-integer? configured-port) (<= 1 configured-port 65535))
|
||||
configured-port
|
||||
587))
|
||||
(configured-user (hash-ref settings "smtp-user" ""))
|
||||
(user (if (string=? configured-user "") #f configured-user))
|
||||
(configured-password (hash-ref settings "smtp-password" ""))
|
||||
(password (if (string=? configured-password "") #f configured-password))
|
||||
(starttls? (string-ci=? (hash-ref settings "smtp-tls" "true") "true"))
|
||||
(accept-untrusted-certificates?
|
||||
(string-ci=? (hash-ref settings "smtp-accept-untrusted-certificates" "false") "true"))
|
||||
(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"))
|
||||
(message
|
||||
(for/list ((line (in-list body-lines)))
|
||||
(string->bytes/utf-8 line))))
|
||||
(with-handlers ((exn:fail?
|
||||
(λ (exception)
|
||||
(let ((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.
|
||||
@@ -184,17 +199,17 @@
|
||||
; 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.")))
|
||||
(let ((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.
|
||||
@@ -205,20 +220,20 @@
|
||||
(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.")))
|
||||
(let* ((settings (password-reset-mail-settings config))
|
||||
(public-url
|
||||
(string-trim (hash-ref settings "public-url") "/" #:right? #t))
|
||||
(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."))))
|
||||
|
||||
+99
-131
@@ -112,6 +112,12 @@ CREATE TABLE IF NOT EXISTS wiki_schema (
|
||||
SQL
|
||||
))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the newest recorded wiki database schema version.
|
||||
; pre : db is an open PostgreSQL connection.
|
||||
; post : Schema tables have only been inspected.
|
||||
; result : The highest recorded version, or 0 when wiki_schema does not exist.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (database-schema-version db)
|
||||
(if (table-exists? db "wiki_schema")
|
||||
(query-value db "SELECT COALESCE(MAX(version), 0) FROM wiki_schema")
|
||||
@@ -147,51 +153,51 @@ SQL
|
||||
(install-schema-1! db))))
|
||||
|
||||
(define (legacy-mime-type stored-name)
|
||||
(define lower (string-downcase stored-name))
|
||||
(cond
|
||||
((regexp-match? #px"[.]png$" lower) "image/png")
|
||||
((regexp-match? #px"[.](jpg|jpeg)$" lower) "image/jpeg")
|
||||
((regexp-match? #px"[.]gif$" lower) "image/gif")
|
||||
((regexp-match? #px"[.]webp$" lower) "image/webp")
|
||||
((regexp-match? #px"[.]pdf$" lower) "application/pdf")
|
||||
((regexp-match? #px"[.]txt$" lower) "text/plain; charset=utf-8")
|
||||
(else "application/octet-stream")))
|
||||
(let ((lower (string-downcase stored-name)))
|
||||
(cond
|
||||
((regexp-match? #px"[.]png$" lower) "image/png")
|
||||
((regexp-match? #px"[.](jpg|jpeg)$" lower) "image/jpeg")
|
||||
((regexp-match? #px"[.]gif$" lower) "image/gif")
|
||||
((regexp-match? #px"[.]webp$" lower) "image/webp")
|
||||
((regexp-match? #px"[.]pdf$" lower) "application/pdf")
|
||||
((regexp-match? #px"[.]txt$" lower) "text/plain; charset=utf-8")
|
||||
(else "application/octet-stream"))))
|
||||
|
||||
(define (migrate-1->2! db config)
|
||||
(query-exec db "ALTER TABLE attachments ADD COLUMN IF NOT EXISTS mime_type TEXT")
|
||||
(query-exec db "ALTER TABLE attachments ADD COLUMN IF NOT EXISTS content BYTEA")
|
||||
(define rows
|
||||
(query-rows db
|
||||
#<<SQL
|
||||
(let ((rows
|
||||
(query-rows db
|
||||
#<<SQL
|
||||
SELECT a.id, p.slug, a.stored_name, a.content
|
||||
FROM attachments a
|
||||
JOIN pages p ON p.id = a.page_id
|
||||
ORDER BY a.id
|
||||
SQL
|
||||
))
|
||||
(for ((row (in-list rows)))
|
||||
(define attachment-id (vector-ref row 0))
|
||||
(define slug (vector-ref row 1))
|
||||
(define stored-name (vector-ref row 2))
|
||||
(define content (vector-ref row 3))
|
||||
(unless (bytes? content)
|
||||
(define path (build-path (uploads-directory config) slug stored-name))
|
||||
(unless (file-exists? path)
|
||||
(error 'migrate-database!
|
||||
"schema 1 -> 2 cannot migrate attachment ~a: missing file ~a"
|
||||
stored-name
|
||||
(path->string path)))
|
||||
(define bytes (file->bytes path))
|
||||
(query-exec db
|
||||
"UPDATE attachments SET content = $1, mime_type = $2, size = $3 WHERE id = $4"
|
||||
bytes
|
||||
(legacy-mime-type stored-name)
|
||||
(bytes-length bytes)
|
||||
attachment-id)))
|
||||
(query-exec db "UPDATE attachments SET mime_type = 'application/octet-stream' WHERE mime_type IS NULL")
|
||||
(query-exec db "ALTER TABLE attachments ALTER COLUMN mime_type SET NOT NULL")
|
||||
(query-exec db "ALTER TABLE attachments ALTER COLUMN content SET NOT NULL")
|
||||
(record-schema-version! db 2))
|
||||
)))
|
||||
(for ((row (in-list rows)))
|
||||
(let ((attachment-id (vector-ref row 0))
|
||||
(slug (vector-ref row 1))
|
||||
(stored-name (vector-ref row 2))
|
||||
(content (vector-ref row 3)))
|
||||
(unless (bytes? content)
|
||||
(let ((path (build-path (uploads-directory config) slug stored-name)))
|
||||
(unless (file-exists? path)
|
||||
(error 'migrate-database!
|
||||
"schema 1 -> 2 cannot migrate attachment ~a: missing file ~a"
|
||||
stored-name
|
||||
(path->string path)))
|
||||
(let ((bytes (file->bytes path)))
|
||||
(query-exec db
|
||||
"UPDATE attachments SET content = $1, mime_type = $2, size = $3 WHERE id = $4"
|
||||
bytes
|
||||
(legacy-mime-type stored-name)
|
||||
(bytes-length bytes)
|
||||
attachment-id))))))
|
||||
(query-exec db "UPDATE attachments SET mime_type = 'application/octet-stream' WHERE mime_type IS NULL")
|
||||
(query-exec db "ALTER TABLE attachments ALTER COLUMN mime_type SET NOT NULL")
|
||||
(query-exec db "ALTER TABLE attachments ALTER COLUMN content SET NOT NULL")
|
||||
(record-schema-version! db 2)))
|
||||
|
||||
|
||||
(define (replace-page-todos! db page-id markdown)
|
||||
@@ -1092,10 +1098,10 @@ CREATE TEMP TABLE concept_uuid_rekey (
|
||||
) ON COMMIT DROP
|
||||
SQL
|
||||
)
|
||||
(define old-ids
|
||||
(query-list
|
||||
db
|
||||
#<<SQL
|
||||
(let* ((old-ids
|
||||
(query-list
|
||||
db
|
||||
#<<SQL
|
||||
WITH all_current_ids AS (
|
||||
SELECT id AS old_id FROM concept_definitions
|
||||
UNION
|
||||
@@ -1119,27 +1125,28 @@ FROM all_current_ids
|
||||
WHERE nullif(old_id, '') IS NOT NULL
|
||||
ORDER BY old_id
|
||||
SQL
|
||||
))
|
||||
;; Reserve every already canonical UUID before generating replacements, so a
|
||||
;; random id can never collide with a UUID encountered later in the query.
|
||||
(define used-ids (make-hash))
|
||||
(for ([old-id (in-list old-ids)])
|
||||
(define normalized (normalize-concept-id old-id))
|
||||
(when normalized (hash-set! used-ids normalized #t)))
|
||||
(define (fresh-unused-id)
|
||||
(let loop ()
|
||||
(define candidate (new-concept-id))
|
||||
(if (hash-has-key? used-ids candidate)
|
||||
(loop)
|
||||
(begin
|
||||
(hash-set! used-ids candidate #t)
|
||||
candidate))))
|
||||
(for ([old-id (in-list old-ids)])
|
||||
(query-exec
|
||||
db
|
||||
"INSERT INTO concept_uuid_rekey(old_id, new_id) VALUES ($1, $2)"
|
||||
old-id
|
||||
(or (normalize-concept-id old-id) (fresh-unused-id))))
|
||||
))
|
||||
;; Reserve every already canonical UUID before generating replacements,
|
||||
;; so a random id can never collide with a UUID encountered later.
|
||||
(used-ids (make-hash)))
|
||||
(for ([old-id (in-list old-ids)])
|
||||
(let ((normalized (normalize-concept-id old-id)))
|
||||
(when normalized (hash-set! used-ids normalized #t))))
|
||||
(letrec ((fresh-unused-id
|
||||
(λ ()
|
||||
(let loop ()
|
||||
(let ((candidate (new-concept-id)))
|
||||
(if (hash-has-key? used-ids candidate)
|
||||
(loop)
|
||||
(begin
|
||||
(hash-set! used-ids candidate #t)
|
||||
candidate)))))))
|
||||
(for ([old-id (in-list old-ids)])
|
||||
(query-exec
|
||||
db
|
||||
"INSERT INTO concept_uuid_rekey(old_id, new_id) VALUES ($1, $2)"
|
||||
old-id
|
||||
(or (normalize-concept-id old-id) (fresh-unused-id)))))
|
||||
(query-exec
|
||||
db
|
||||
#<<SQL
|
||||
@@ -1205,7 +1212,7 @@ ADD CONSTRAINT concept_definitions_uuid_id_check
|
||||
CHECK (id ~ '^[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}$')
|
||||
SQL
|
||||
)
|
||||
(record-schema-version! db 21))
|
||||
(record-schema-version! db 21)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Bring a racket-wiki PostgreSQL database to the current schema.
|
||||
@@ -1219,72 +1226,33 @@ SQL
|
||||
db
|
||||
(λ ()
|
||||
(recognize-or-install-schema-1! db)
|
||||
(define version (database-schema-version db))
|
||||
(when (< version 1)
|
||||
(error 'migrate-database! "unable to determine the existing wiki database schema"))
|
||||
(when (= version 1)
|
||||
(migrate-1->2! db config))
|
||||
(define after-attachments (database-schema-version db))
|
||||
(when (= after-attachments 2)
|
||||
(migrate-2->3! db))
|
||||
(define after-todos (database-schema-version db))
|
||||
(when (= after-todos 3)
|
||||
(migrate-3->4! db))
|
||||
(define after-bookmarks (database-schema-version db))
|
||||
(when (= after-bookmarks 4)
|
||||
(migrate-4->5! db))
|
||||
(define after-todo-reindex (database-schema-version db))
|
||||
(when (= after-todo-reindex 5)
|
||||
(migrate-5->6! db))
|
||||
(define after-attachment-references (database-schema-version db))
|
||||
(when (= after-attachment-references 6)
|
||||
(migrate-6->7! db))
|
||||
(define after-namespaces (database-schema-version db))
|
||||
(when (= after-namespaces 7)
|
||||
(migrate-7->8! db))
|
||||
(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 after-concept-map-history (database-schema-version db))
|
||||
(when (= after-concept-map-history 11)
|
||||
(migrate-11->12! db))
|
||||
(define after-concept-map-history-cleanup (database-schema-version db))
|
||||
(when (= after-concept-map-history-cleanup 12)
|
||||
(migrate-12->13! db))
|
||||
(define after-people (database-schema-version db))
|
||||
(when (= after-people 13)
|
||||
(migrate-13->14! db))
|
||||
(define after-concept-definitions (database-schema-version db))
|
||||
(when (= after-concept-definitions 14)
|
||||
(migrate-14->15! db))
|
||||
(define after-submap-concepts (database-schema-version db))
|
||||
(when (= after-submap-concepts 15)
|
||||
(migrate-15->16! db))
|
||||
(define after-concept-link-aliases (database-schema-version db))
|
||||
(when (= after-concept-link-aliases 16)
|
||||
(migrate-16->17! db))
|
||||
(define after-concept-name-merge (database-schema-version db))
|
||||
(when (= after-concept-name-merge 17)
|
||||
(migrate-17->18! db))
|
||||
(define after-concept-normalization (database-schema-version db))
|
||||
(when (= after-concept-normalization 18)
|
||||
(migrate-18->19! db))
|
||||
(define after-placement-content-cleanup (database-schema-version db))
|
||||
(when (= after-placement-content-cleanup 19)
|
||||
(migrate-19->20! db))
|
||||
(define after-central-concept-references (database-schema-version db))
|
||||
(when (= after-central-concept-references 20)
|
||||
(migrate-20->21! db))
|
||||
(define resulting-version (database-schema-version db))
|
||||
(when (> resulting-version current-schema-version)
|
||||
(error 'migrate-database!
|
||||
"database schema ~a is newer than this racket-wiki supports (~a)"
|
||||
resulting-version
|
||||
current-schema-version))
|
||||
resulting-version)))
|
||||
(let loop ((version (database-schema-version db)))
|
||||
(cond
|
||||
((< version 1)
|
||||
(error 'migrate-database! "unable to determine the existing wiki database schema"))
|
||||
((= version 1) (migrate-1->2! db config) (loop (database-schema-version db)))
|
||||
((= version 2) (migrate-2->3! db) (loop (database-schema-version db)))
|
||||
((= version 3) (migrate-3->4! db) (loop (database-schema-version db)))
|
||||
((= version 4) (migrate-4->5! db) (loop (database-schema-version db)))
|
||||
((= version 5) (migrate-5->6! db) (loop (database-schema-version db)))
|
||||
((= version 6) (migrate-6->7! db) (loop (database-schema-version db)))
|
||||
((= version 7) (migrate-7->8! db) (loop (database-schema-version db)))
|
||||
((= version 8) (migrate-8->9! db) (loop (database-schema-version db)))
|
||||
((= version 9) (migrate-9->10! db) (loop (database-schema-version db)))
|
||||
((= version 10) (migrate-10->11! db) (loop (database-schema-version db)))
|
||||
((= version 11) (migrate-11->12! db) (loop (database-schema-version db)))
|
||||
((= version 12) (migrate-12->13! db) (loop (database-schema-version db)))
|
||||
((= version 13) (migrate-13->14! db) (loop (database-schema-version db)))
|
||||
((= version 14) (migrate-14->15! db) (loop (database-schema-version db)))
|
||||
((= version 15) (migrate-15->16! db) (loop (database-schema-version db)))
|
||||
((= version 16) (migrate-16->17! db) (loop (database-schema-version db)))
|
||||
((= version 17) (migrate-17->18! db) (loop (database-schema-version db)))
|
||||
((= version 18) (migrate-18->19! db) (loop (database-schema-version db)))
|
||||
((= version 19) (migrate-19->20! db) (loop (database-schema-version db)))
|
||||
((= version 20) (migrate-20->21! db) (loop (database-schema-version db)))
|
||||
((> version current-schema-version)
|
||||
(error 'migrate-database!
|
||||
"database schema ~a is newer than this racket-wiki supports (~a)"
|
||||
version
|
||||
current-schema-version))
|
||||
(else version))))))
|
||||
|
||||
+56
-32
@@ -19,10 +19,16 @@
|
||||
'name (vector-ref row 1)
|
||||
'active (vector-ref row 2)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : List people available for CMap person tags.
|
||||
; pre : The wiki database schema is initialized.
|
||||
; post : Person rows have only been read.
|
||||
; result : A name-sorted list of person hashes, optionally excluding inactive rows.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (list-people config [include-inactive? #t])
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(lambda (db)
|
||||
(λ (db)
|
||||
(for/list ((row (in-list
|
||||
(query-rows
|
||||
db
|
||||
@@ -35,45 +41,57 @@
|
||||
(define (clean-person-name who name)
|
||||
(unless (string? name)
|
||||
(raise-argument-error who "string?" name))
|
||||
(define clean (string-trim name))
|
||||
(when (or (string=? clean "") (> (string-length clean) 200))
|
||||
(error who "person name must contain between 1 and 200 characters"))
|
||||
clean)
|
||||
(let ((clean (string-trim name)))
|
||||
(when (or (string=? clean "") (> (string-length clean) 200))
|
||||
(error who "person name must contain between 1 and 200 characters"))
|
||||
clean))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Create or reactivate a person in the shared registry.
|
||||
; pre : name is a string containing between 1 and 200 non-whitespace characters.
|
||||
; post : A matching person exists and is active.
|
||||
; result : The stored person hash.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (create-person! config name)
|
||||
(define clean-name (clean-person-name 'create-person! name))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(lambda (db)
|
||||
(define now (current-seconds))
|
||||
(row->person
|
||||
(query-row
|
||||
db
|
||||
#<<SQL
|
||||
(let ((clean-name (clean-person-name 'create-person! name)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(let ((now (current-seconds)))
|
||||
(row->person
|
||||
(query-row
|
||||
db
|
||||
#<<SQL
|
||||
INSERT INTO people(name, active, created_at, updated_at)
|
||||
VALUES ($1, TRUE, $2, $2)
|
||||
ON CONFLICT (lower(name)) DO UPDATE
|
||||
SET name = excluded.name, active = TRUE, updated_at = excluded.updated_at
|
||||
RETURNING id, name, active
|
||||
SQL
|
||||
clean-name now)))))
|
||||
clean-name now)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Change the name and active state of one registered person.
|
||||
; pre : id identifies a possible person and name is valid registry text.
|
||||
; post : The matching row, when present, contains the supplied values.
|
||||
; result : The updated person hash, or #f when id does not exist.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (update-person! config id name active?)
|
||||
(define clean-name (clean-person-name 'update-person! name))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(lambda (db)
|
||||
(define row
|
||||
(query-maybe-row
|
||||
db
|
||||
#<<SQL
|
||||
(let ((clean-name (clean-person-name 'update-person! name)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(let ((row
|
||||
(query-maybe-row
|
||||
db
|
||||
#<<SQL
|
||||
UPDATE people
|
||||
SET name = $1, active = $2, updated_at = $3
|
||||
WHERE id = $4
|
||||
RETURNING id, name, active
|
||||
SQL
|
||||
clean-name (if active? #t #f) (current-seconds) id))
|
||||
(and row (row->person row)))))
|
||||
clean-name (if active? #t #f) (current-seconds) id)))
|
||||
(and row (row->person row)))))))
|
||||
|
||||
(define (person-tag-names document)
|
||||
(remove-duplicates
|
||||
@@ -91,18 +109,24 @@ SQL
|
||||
|
||||
;; Called inside the concept-map write transaction. New names become active;
|
||||
;; an explicitly deactivated existing name remains deactivated.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Add previously unknown person tags from a CMap document.
|
||||
; pre : db is inside the CMap write transaction and document is a CMap hash.
|
||||
; post : Every distinct person tag has a registry row; existing rows are unchanged.
|
||||
; result : void.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (sync-person-tags! db document)
|
||||
(define now (current-seconds))
|
||||
(for ((name (in-list (person-tag-names document))))
|
||||
(query-exec
|
||||
db
|
||||
#<<SQL
|
||||
(let ((now (current-seconds)))
|
||||
(for ((name (in-list (person-tag-names document))))
|
||||
(query-exec
|
||||
db
|
||||
#<<SQL
|
||||
INSERT INTO people(name, active, created_at, updated_at)
|
||||
VALUES ($1, TRUE, $2, $2)
|
||||
ON CONFLICT (lower(name)) DO NOTHING
|
||||
SQL
|
||||
name now))
|
||||
(void))
|
||||
name now))
|
||||
(void)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
+92
-92
@@ -24,10 +24,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 setup-form-token
|
||||
(bytes->hex (crypto-random-bytes 32)))
|
||||
@@ -49,16 +49,16 @@
|
||||
(vendor-files-ready? config)))
|
||||
|
||||
(define (request-form req)
|
||||
(define body (request-post-data/raw req))
|
||||
(if body
|
||||
(form-urlencoded->alist (bytes->string/utf-8 body))
|
||||
'()))
|
||||
(let ((body (request-post-data/raw req)))
|
||||
(if body
|
||||
(form-urlencoded->alist (bytes->string/utf-8 body))
|
||||
'())))
|
||||
|
||||
(define (form-value form key [default ""])
|
||||
(define found (assoc key form))
|
||||
(if (and found (cdr found))
|
||||
(cdr found)
|
||||
default))
|
||||
(let ((found (assoc key form)))
|
||||
(if (and found (cdr found))
|
||||
(cdr found)
|
||||
default)))
|
||||
|
||||
(define setup-style
|
||||
#<<CSS
|
||||
@@ -96,21 +96,21 @@ CSS
|
||||
|
||||
|
||||
(define (language-field config [form '()])
|
||||
(define language (form-value form 'language (current-language config)))
|
||||
`((label
|
||||
,(tr config 'language)
|
||||
(select ((name "language"))
|
||||
(option ((value "en") ,@(if (string-ci=? language "en") '((selected "selected")) '())) ,(tr config 'language-en))
|
||||
(option ((value "nl") ,@(if (string-ci=? language "nl") '((selected "selected")) '())) ,(tr config 'language-nl))))))
|
||||
(let ((language (form-value form 'language (current-language config))))
|
||||
`((label
|
||||
,(tr config 'language)
|
||||
(select ((name "language"))
|
||||
(option ((value "en") ,@(if (string-ci=? language "en") '((selected "selected")) '())) ,(tr config 'language-en))
|
||||
(option ((value "nl") ,@(if (string-ci=? language "nl") '((selected "selected")) '())) ,(tr config 'language-nl)))))))
|
||||
|
||||
(define (database-fields config [form '()])
|
||||
(define settings (read-database-settings config))
|
||||
(define ssl-text
|
||||
(form-value form
|
||||
'db-ssl
|
||||
(symbol->string (setting-value settings database-settings-ssl 'no))))
|
||||
(define ssl (string->symbol ssl-text))
|
||||
`((h2 ,(tr config 'postgresql))
|
||||
(let* ((settings (read-database-settings config))
|
||||
(ssl-text
|
||||
(form-value form
|
||||
'db-ssl
|
||||
(symbol->string (setting-value settings database-settings-ssl 'no))))
|
||||
(ssl (string->symbol ssl-text)))
|
||||
`((h2 ,(tr config 'postgresql))
|
||||
(div ((class "fields"))
|
||||
(label
|
||||
,(tr config 'server)
|
||||
@@ -147,7 +147,7 @@ CSS
|
||||
(select ((name "db-ssl"))
|
||||
(option ((value "no") ,@(if (eq? ssl 'no) '((selected "selected")) '())) ,(tr config 'ssl-no))
|
||||
(option ((value "optional") ,@(if (eq? ssl 'optional) '((selected "selected")) '())) ,(tr config 'ssl-optional))
|
||||
(option ((value "yes") ,@(if (eq? ssl 'yes) '((selected "selected")) '())) ,(tr config 'ssl-required)))))))
|
||||
(option ((value "yes") ,@(if (eq? ssl 'yes) '((selected "selected")) '())) ,(tr config 'ssl-required))))))))
|
||||
|
||||
(define (admin-fields config [form '()])
|
||||
`((h2 ,(tr config 'administrator))
|
||||
@@ -177,10 +177,10 @@ CSS
|
||||
(required "required"))))))
|
||||
|
||||
(define (setup-page config [message #f] [form '()])
|
||||
(define db-ready? (database-ready? config))
|
||||
(define administrator-ready? (admin-ready? config))
|
||||
(define vendor-ready? (vendor-files-ready? config))
|
||||
`(html
|
||||
(let ((db-ready? (database-ready? config))
|
||||
(administrator-ready? (admin-ready? config))
|
||||
(vendor-ready? (vendor-files-ready? config)))
|
||||
`(html
|
||||
(head
|
||||
(meta ((charset "utf-8")))
|
||||
(meta ((name "viewport") (content "width=device-width, initial-scale=1")))
|
||||
@@ -210,7 +210,7 @@ CSS
|
||||
(p ((class "note"))
|
||||
"Frontend libraries are stored below "
|
||||
(code ,(path->string (vendor-directory config)))
|
||||
" and are served locally after setup.")))))
|
||||
" and are served locally after setup."))))))
|
||||
|
||||
(define (setup-page-response config [message #f] [form '()])
|
||||
(html-response
|
||||
@@ -218,85 +218,85 @@ CSS
|
||||
#:headers (list (make-header #"Cache-Control" #"no-store"))))
|
||||
|
||||
(define (validate-admin-form form)
|
||||
(define username (string-trim (form-value form 'username)))
|
||||
(define display-name (string-trim (form-value form 'display-name)))
|
||||
(define password (form-value form 'password))
|
||||
(define password-confirm (form-value form 'password-confirm))
|
||||
(cond
|
||||
((string=? username "") "Administrator username is required.")
|
||||
((string=? password "") "Administrator password is required.")
|
||||
((< (string-length password) 8) "Administrator password must contain at least 8 characters.")
|
||||
((not (string=? password password-confirm)) "The two passwords do not match.")
|
||||
(else
|
||||
(list username
|
||||
(if (string=? display-name "") username display-name)
|
||||
password))))
|
||||
(let ((username (string-trim (form-value form 'username)))
|
||||
(display-name (string-trim (form-value form 'display-name)))
|
||||
(password (form-value form 'password))
|
||||
(password-confirm (form-value form 'password-confirm)))
|
||||
(cond
|
||||
((string=? username "") "Administrator username is required.")
|
||||
((string=? password "") "Administrator password is required.")
|
||||
((< (string-length password) 8) "Administrator password must contain at least 8 characters.")
|
||||
((not (string=? password password-confirm)) "The two passwords do not match.")
|
||||
(else
|
||||
(list username
|
||||
(if (string=? display-name "") username display-name)
|
||||
password)))))
|
||||
|
||||
(define (form->database-settings form)
|
||||
(define port (string->number (form-value form 'db-port "5432")))
|
||||
(define ssl-text (form-value form 'db-ssl "no"))
|
||||
(define ssl
|
||||
(let* ((port (string->number (form-value form 'db-port "5432")))
|
||||
(ssl-text (form-value form 'db-ssl "no"))
|
||||
(ssl
|
||||
(cond
|
||||
((string=? ssl-text "yes") 'yes)
|
||||
((string=? ssl-text "optional") 'optional)
|
||||
(else 'no))))
|
||||
(cond
|
||||
((string=? ssl-text "yes") 'yes)
|
||||
((string=? ssl-text "optional") 'optional)
|
||||
(else 'no)))
|
||||
(cond
|
||||
((string=? (string-trim (form-value form 'db-server)) "") "PostgreSQL server is required.")
|
||||
((or (not port) (not (exact-integer? port)) (< port 1) (> port 65535)) "PostgreSQL port is invalid.")
|
||||
((string=? (string-trim (form-value form 'db-database)) "") "PostgreSQL database is required.")
|
||||
((string=? (string-trim (form-value form 'db-user)) "") "PostgreSQL user is required.")
|
||||
(else
|
||||
(database-settings (string-trim (form-value form 'db-server))
|
||||
port
|
||||
(string-trim (form-value form 'db-database))
|
||||
(string-trim (form-value form 'db-user))
|
||||
(form-value form 'db-password)
|
||||
ssl))))
|
||||
((string=? (string-trim (form-value form 'db-server)) "") "PostgreSQL server is required.")
|
||||
((or (not port) (not (exact-integer? port)) (< port 1) (> port 65535)) "PostgreSQL port is invalid.")
|
||||
((string=? (string-trim (form-value form 'db-database)) "") "PostgreSQL database is required.")
|
||||
((string=? (string-trim (form-value form 'db-user)) "") "PostgreSQL user is required.")
|
||||
(else
|
||||
(database-settings (string-trim (form-value form 'db-server))
|
||||
port
|
||||
(string-trim (form-value form 'db-database))
|
||||
(string-trim (form-value form 'db-user))
|
||||
(form-value form 'db-password)
|
||||
ssl)))))
|
||||
|
||||
|
||||
(define (configure-language! config form)
|
||||
(define language (string-downcase (form-value form 'language (current-language config))))
|
||||
(unless (member language '("en" "nl"))
|
||||
(error 'setup "Unsupported UI language: ~a" language))
|
||||
(write-language! config language))
|
||||
(let ((language (string-downcase (form-value form 'language (current-language config)))))
|
||||
(unless (member language '("en" "nl"))
|
||||
(error 'setup "Unsupported UI language: ~a" language))
|
||||
(write-language! config language)))
|
||||
|
||||
(define (configure-database! config form)
|
||||
(unless (database-ready? config)
|
||||
(define settings (form->database-settings form))
|
||||
(when (string? settings)
|
||||
(error 'setup settings))
|
||||
(test-database-settings! settings)
|
||||
(initialize-database-with-settings! settings config)
|
||||
(write-database-settings! config settings)))
|
||||
(let ((settings (form->database-settings form)))
|
||||
(when (string? settings)
|
||||
(error 'setup settings))
|
||||
(test-database-settings! settings)
|
||||
(initialize-database-with-settings! settings config)
|
||||
(write-database-settings! config settings))))
|
||||
|
||||
(define (configure-administrator! config form)
|
||||
(unless (admin-ready? config)
|
||||
(define admin-values (validate-admin-form form))
|
||||
(when (string? admin-values)
|
||||
(error 'setup admin-values))
|
||||
(create-user! config
|
||||
(list-ref admin-values 0)
|
||||
(list-ref admin-values 1)
|
||||
(list-ref admin-values 2)
|
||||
'admin
|
||||
'enabled)))
|
||||
(let ((admin-values (validate-admin-form form)))
|
||||
(when (string? admin-values)
|
||||
(error 'setup admin-values))
|
||||
(create-user! config
|
||||
(list-ref admin-values 0)
|
||||
(list-ref admin-values 1)
|
||||
(list-ref admin-values 2)
|
||||
'admin
|
||||
'enabled))))
|
||||
|
||||
(define (cleartext-password-error? message)
|
||||
(and (string? message)
|
||||
(regexp-match? #rx"refusing to send cleartext password" message)))
|
||||
|
||||
(define (setup-error-message e)
|
||||
(define message (exn-message e))
|
||||
(if (cleartext-password-error? message)
|
||||
(string-append
|
||||
"PostgreSQL requests cleartext password authentication. "
|
||||
"Configure the matching pg_hba.conf rule for this database/user to use "
|
||||
"scram-sha-256 (recommended), then reload PostgreSQL and try again. "
|
||||
"If more than one pg_hba.conf rule could match, remember that PostgreSQL "
|
||||
"uses the first matching rule. "
|
||||
"The entered non-password fields have been preserved below.\n\n"
|
||||
"Technical detail: " message)
|
||||
message))
|
||||
(let ((message (exn-message e)))
|
||||
(if (cleartext-password-error? message)
|
||||
(string-append
|
||||
"PostgreSQL requests cleartext password authentication. "
|
||||
"Configure the matching pg_hba.conf rule for this database/user to use "
|
||||
"scram-sha-256 (recommended), then reload PostgreSQL and try again. "
|
||||
"If more than one pg_hba.conf rule could match, remember that PostgreSQL "
|
||||
"uses the first matching rule. "
|
||||
"The entered non-password fields have been preserved below.\n\n"
|
||||
"Technical detail: " message)
|
||||
message)))
|
||||
|
||||
(define (complete-setup! config req)
|
||||
(call-with-semaphore
|
||||
|
||||
+263
-252
@@ -50,15 +50,15 @@
|
||||
; post : The data directory and writable static directory exist.
|
||||
; result : void.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (ensure-wiki-data! config)
|
||||
(for ((directory (in-list (list (wiki-config-data-dir config)
|
||||
(data-static-directory config)))))
|
||||
(make-directory* directory)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (slug-alphanumeric? char)
|
||||
(or (char-alphabetic? char)
|
||||
(char-numeric? char)))
|
||||
@@ -74,6 +74,12 @@
|
||||
(char=? char #\_)
|
||||
(char=? char #\-)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Check whether a string is a valid page or namespace slug.
|
||||
; pre : slug is a string.
|
||||
; post : No state is changed.
|
||||
; result : #t for a non-special slug of at most 120 supported characters.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (valid-slug? slug)
|
||||
(and (> (string-length slug) 0)
|
||||
(<= (string-length slug) 120)
|
||||
@@ -100,10 +106,10 @@
|
||||
; result : Two values: namespace and slug. The namespace is empty for root pages.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (split-page-reference reference)
|
||||
(define match (regexp-match #px"^([^:]+):(.*)$" reference))
|
||||
(if match
|
||||
(values (list-ref match 1) (list-ref match 2))
|
||||
(values "" reference)))
|
||||
(let ((match (regexp-match #px"^([^:]+):(.*)$" reference)))
|
||||
(if match
|
||||
(values (list-ref match 1) (list-ref match 2))
|
||||
(values "" reference))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Check whether a namespace-qualified page reference is valid.
|
||||
@@ -112,63 +118,69 @@
|
||||
; result : #t for root slugs or namespace:slug references with letter/number namespaces.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (valid-page-reference? reference)
|
||||
(define-values (namespace slug) (split-page-reference reference))
|
||||
(and (valid-slug? slug)
|
||||
(or (string=? namespace "")
|
||||
(and (valid-slug? namespace)
|
||||
(<= (string-length namespace) 80)))))
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(and (valid-slug? slug)
|
||||
(or (string=? namespace "")
|
||||
(and (valid-slug? namespace)
|
||||
(<= (string-length namespace) 80))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Derive a stable page slug from a human-readable title.
|
||||
; pre : title is a string.
|
||||
; post : No state is changed.
|
||||
; result : A lowercase, normalized slug containing at most 120 characters.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (title->slug title)
|
||||
(define normalized
|
||||
(string-downcase
|
||||
(string-normalize-nfkd (string-trim title))))
|
||||
(define out (open-output-string))
|
||||
(define separator-needed? #f)
|
||||
(define wrote-character? #f)
|
||||
(for ((char (in-string normalized)))
|
||||
(cond
|
||||
((slug-alphanumeric? char)
|
||||
(when (and separator-needed? wrote-character?)
|
||||
(write-char #\- out))
|
||||
(write-char char out)
|
||||
(set! separator-needed? #f)
|
||||
(set! wrote-character? #t))
|
||||
((combining-mark? char)
|
||||
(void))
|
||||
(else
|
||||
(set! separator-needed? #t))))
|
||||
(define slug (get-output-string out))
|
||||
(define limited
|
||||
(if (> (string-length slug) 120)
|
||||
(substring slug 0 120)
|
||||
slug))
|
||||
(regexp-replace #px"-+$" limited ""))
|
||||
(let ((normalized
|
||||
(string-downcase
|
||||
(string-normalize-nfkd (string-trim title))))
|
||||
(out (open-output-string))
|
||||
(separator-needed? #f)
|
||||
(wrote-character? #f))
|
||||
(for ((char (in-string normalized)))
|
||||
(cond
|
||||
((slug-alphanumeric? char)
|
||||
(when (and separator-needed? wrote-character?)
|
||||
(write-char #\- out))
|
||||
(write-char char out)
|
||||
(set! separator-needed? #f)
|
||||
(set! wrote-character? #t))
|
||||
((combining-mark? char)
|
||||
(void))
|
||||
(else
|
||||
(set! separator-needed? #t))))
|
||||
(let* ((slug (get-output-string out))
|
||||
(limited
|
||||
(if (> (string-length slug) 120)
|
||||
(substring slug 0 120)
|
||||
slug)))
|
||||
(regexp-replace #px"-+$" limited ""))))
|
||||
|
||||
(define (tags->text tags)
|
||||
(jsexpr->string tags))
|
||||
|
||||
(define (text->tags text)
|
||||
(with-handlers ((exn:fail? (λ (_e) '())))
|
||||
(define value (string->jsexpr text))
|
||||
(if (list? value) value '())))
|
||||
(let ((value (string->jsexpr text)))
|
||||
(if (list? value) value '()))))
|
||||
|
||||
(define (row->page row [include-markdown? #t])
|
||||
(define namespace (vector-ref row 9))
|
||||
(define slug (vector-ref row 0))
|
||||
(define result
|
||||
(hash 'slug (page-reference namespace slug)
|
||||
'pageSlug slug
|
||||
'namespace namespace
|
||||
'title (vector-ref row 1)
|
||||
'createdAt (vector-ref row 3)
|
||||
'updatedAt (vector-ref row 4)
|
||||
'createdBy (vector-ref row 5)
|
||||
'updatedBy (vector-ref row 6)
|
||||
'tags (text->tags (vector-ref row 7))
|
||||
'currentVersion (vector-ref row 8)))
|
||||
(if include-markdown?
|
||||
(hash-set result 'markdown (vector-ref row 2))
|
||||
result))
|
||||
(let* ((namespace (vector-ref row 9))
|
||||
(slug (vector-ref row 0))
|
||||
(result
|
||||
(hash 'slug (page-reference namespace slug)
|
||||
'pageSlug slug
|
||||
'namespace namespace
|
||||
'title (vector-ref row 1)
|
||||
'createdAt (vector-ref row 3)
|
||||
'updatedAt (vector-ref row 4)
|
||||
'createdBy (vector-ref row 5)
|
||||
'updatedBy (vector-ref row 6)
|
||||
'tags (text->tags (vector-ref row 7))
|
||||
'currentVersion (vector-ref row 8))))
|
||||
(if include-markdown?
|
||||
(hash-set result 'markdown (vector-ref row 2))
|
||||
result)))
|
||||
|
||||
(define page-columns
|
||||
"slug, title, markdown, created_at, updated_at, created_by, updated_by, tags, current_version, namespace")
|
||||
@@ -177,20 +189,20 @@
|
||||
"p.slug, p.title, p.markdown, p.created_at, p.updated_at, p.created_by, p.updated_by, p.tags, p.current_version, p.namespace")
|
||||
|
||||
(define (page-id/db db namespace slug)
|
||||
(define current-id
|
||||
(query-maybe-value db
|
||||
"SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE"
|
||||
namespace slug))
|
||||
(if current-id
|
||||
current-id
|
||||
(query-maybe-value db
|
||||
#<<SQL
|
||||
(let ((current-id
|
||||
(query-maybe-value db
|
||||
"SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE"
|
||||
namespace slug)))
|
||||
(if current-id
|
||||
current-id
|
||||
(query-maybe-value db
|
||||
#<<SQL
|
||||
SELECT p.id
|
||||
FROM page_aliases a
|
||||
JOIN pages p ON p.id = a.page_id
|
||||
WHERE a.namespace = $1 AND a.slug = $2 AND p.archived = FALSE
|
||||
SQL
|
||||
namespace slug)))
|
||||
namespace slug))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : List current wiki page metadata.
|
||||
@@ -221,21 +233,21 @@ SQL
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(define row
|
||||
(query-maybe-row db
|
||||
(string-append "SELECT " page-columns
|
||||
" FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE")
|
||||
namespace slug))
|
||||
(define resolved-row
|
||||
(if row
|
||||
row
|
||||
(query-maybe-row db
|
||||
(string-append
|
||||
"SELECT " page-columns/prefixed
|
||||
" FROM page_aliases a JOIN pages p ON p.id = a.page_id"
|
||||
" WHERE a.namespace = $1 AND a.slug = $2 AND p.archived = FALSE")
|
||||
namespace slug)))
|
||||
(if resolved-row (row->page resolved-row) #f))))))
|
||||
(let* ((row
|
||||
(query-maybe-row db
|
||||
(string-append "SELECT " page-columns
|
||||
" FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE")
|
||||
namespace slug))
|
||||
(resolved-row
|
||||
(if row
|
||||
row
|
||||
(query-maybe-row db
|
||||
(string-append
|
||||
"SELECT " page-columns/prefixed
|
||||
" FROM page_aliases a JOIN pages p ON p.id = a.page_id"
|
||||
" WHERE a.namespace = $1 AND a.slug = $2 AND p.archived = FALSE")
|
||||
namespace slug))))
|
||||
(if resolved-row (row->page resolved-row) #f)))))))
|
||||
|
||||
(define (replace-todos! db page-id markdown)
|
||||
(query-exec db "DELETE FROM todo_items WHERE page_id = $1" page-id)
|
||||
@@ -263,17 +275,17 @@ SQL
|
||||
; result : The new page metadata with Markdown.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (create-page! config reference title markdown author [summary "Created page"] [tags '()])
|
||||
(define-values (namespace slug) (split-page-reference reference))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(call-with-transaction
|
||||
db
|
||||
(λ ()
|
||||
(define now (current-seconds))
|
||||
(define page-id
|
||||
(query-value db
|
||||
#<<SQL
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(call-with-transaction
|
||||
db
|
||||
(λ ()
|
||||
(let* ((now (current-seconds))
|
||||
(page-id
|
||||
(query-value db
|
||||
#<<SQL
|
||||
INSERT INTO pages(namespace, slug, title, markdown, tags, current_version,
|
||||
created_at, updated_at, created_by, updated_by, search_document)
|
||||
VALUES ($1, $2, $3, $4, $5, 1, $6, $6, $7, $7,
|
||||
@@ -281,13 +293,13 @@ VALUES ($1, $2, $3, $4, $5, 1, $6, $6, $7, $7,
|
||||
setweight(to_tsvector('simple', coalesce($4, '')), 'B'))
|
||||
RETURNING id
|
||||
SQL
|
||||
namespace slug title markdown (tags->text tags) now author))
|
||||
(define page-version-id
|
||||
(insert-version! db page-id 1 title markdown author "create" summary now tags))
|
||||
(replace-todos! db page-id markdown)
|
||||
(replace-current-attachment-references! db page-id markdown now)
|
||||
(record-version-attachment-references! db page-id page-version-id markdown now)))))
|
||||
(read-page config reference))
|
||||
namespace slug title markdown (tags->text tags) now author))
|
||||
(page-version-id
|
||||
(insert-version! db page-id 1 title markdown author "create" summary now tags)))
|
||||
(replace-todos! db page-id markdown)
|
||||
(replace-current-attachment-references! db page-id markdown now)
|
||||
(record-version-attachment-references! db page-id page-version-id markdown now))))))
|
||||
(read-page config reference)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Save a new version of an existing wiki page.
|
||||
@@ -296,36 +308,35 @@ SQL
|
||||
; result : The updated page metadata with Markdown.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (update-page! config reference title markdown author base-version [summary "Edited page"] [tags #f] [new-namespace #f])
|
||||
(define-values (namespace slug) (split-page-reference reference))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(call-with-transaction
|
||||
db
|
||||
(λ ()
|
||||
(define row
|
||||
(query-maybe-row db
|
||||
"SELECT id, current_version, tags, namespace FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE FOR UPDATE"
|
||||
namespace slug))
|
||||
(unless row
|
||||
(error 'update-page! "unknown page: ~a" slug))
|
||||
(define current-version (vector-ref row 1))
|
||||
(define supplied-version
|
||||
(if (number? base-version)
|
||||
base-version
|
||||
(string->number (format "~a" base-version))))
|
||||
(unless (and supplied-version (= current-version supplied-version))
|
||||
(error 'update-page! "version-conflict"))
|
||||
(define page-tags
|
||||
(if tags tags (text->tags (vector-ref row 2))))
|
||||
(define target-namespace (vector-ref row 3))
|
||||
(when (and (not (eq? new-namespace #f))
|
||||
(not (string=? (string-trim new-namespace) target-namespace)))
|
||||
(error 'update-page! "use rename-page! to change a page namespace"))
|
||||
(define next-version (+ current-version 1))
|
||||
(define now (current-seconds))
|
||||
(query-exec db
|
||||
#<<SQL
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(call-with-transaction
|
||||
db
|
||||
(λ ()
|
||||
(let ((row
|
||||
(query-maybe-row db
|
||||
"SELECT id, current_version, tags, namespace FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE FOR UPDATE"
|
||||
namespace slug)))
|
||||
(unless row
|
||||
(error 'update-page! "unknown page: ~a" slug))
|
||||
(let* ((current-version (vector-ref row 1))
|
||||
(supplied-version
|
||||
(if (number? base-version)
|
||||
base-version
|
||||
(string->number (format "~a" base-version))))
|
||||
(page-tags (if tags tags (text->tags (vector-ref row 2))))
|
||||
(target-namespace (vector-ref row 3))
|
||||
(next-version (+ current-version 1))
|
||||
(now (current-seconds)))
|
||||
(unless (and supplied-version (= current-version supplied-version))
|
||||
(error 'update-page! "version-conflict"))
|
||||
(when (and (not (eq? new-namespace #f))
|
||||
(not (string=? (string-trim new-namespace) target-namespace)))
|
||||
(error 'update-page! "use rename-page! to change a page namespace"))
|
||||
(query-exec db
|
||||
#<<SQL
|
||||
UPDATE pages
|
||||
SET title = $1, markdown = $2, tags = $3, current_version = $4,
|
||||
updated_at = $5, updated_by = $6, namespace = $7,
|
||||
@@ -333,14 +344,14 @@ SET title = $1, markdown = $2, tags = $3, current_version = $4,
|
||||
setweight(to_tsvector('simple', coalesce($2, '')), 'B')
|
||||
WHERE id = $8
|
||||
SQL
|
||||
title markdown (tags->text page-tags) next-version now author target-namespace (vector-ref row 0))
|
||||
(define page-id (vector-ref row 0))
|
||||
(define page-version-id
|
||||
(insert-version! db page-id next-version title markdown author "edit" summary now page-tags))
|
||||
(replace-todos! db page-id markdown)
|
||||
(replace-current-attachment-references! db page-id markdown now)
|
||||
(record-version-attachment-references! db page-id page-version-id markdown now)))))
|
||||
(read-page config (page-reference namespace slug)))
|
||||
title markdown (tags->text page-tags) next-version now author target-namespace (vector-ref row 0))
|
||||
(let* ((page-id (vector-ref row 0))
|
||||
(page-version-id
|
||||
(insert-version! db page-id next-version title markdown author "edit" summary now page-tags)))
|
||||
(replace-todos! db page-id markdown)
|
||||
(replace-current-attachment-references! db page-id markdown now)
|
||||
(record-version-attachment-references! db page-id page-version-id markdown now))))))))
|
||||
(read-page config (page-reference namespace slug))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Rename or move a page while keeping its old address as an alias.
|
||||
@@ -350,63 +361,63 @@ SQL
|
||||
; result : The renamed page metadata with Markdown.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (rename-page! config reference title target-namespace target-slug author [summary "Renamed page"])
|
||||
(define-values (namespace slug) (split-page-reference reference))
|
||||
(define clean-namespace (string-trim target-namespace))
|
||||
(define clean-slug (string-trim target-slug))
|
||||
(unless (valid-page-reference? (page-reference clean-namespace clean-slug))
|
||||
(error 'rename-page! "invalid page address: ~a" (page-reference clean-namespace clean-slug)))
|
||||
(when (string=? (string-trim title) "")
|
||||
(error 'rename-page! "title is required"))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(call-with-transaction
|
||||
db
|
||||
(λ ()
|
||||
(define row
|
||||
(query-maybe-row db
|
||||
"SELECT id, title, markdown, tags, current_version FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE FOR UPDATE"
|
||||
namespace slug))
|
||||
(unless row
|
||||
(error 'rename-page! "unknown page: ~a" reference))
|
||||
(define page-id (vector-ref row 0))
|
||||
(define old-title (vector-ref row 1))
|
||||
(define markdown (vector-ref row 2))
|
||||
(define tags (text->tags (vector-ref row 3)))
|
||||
(define current-version (vector-ref row 4))
|
||||
(define address-changed?
|
||||
(or (not (string=? namespace clean-namespace))
|
||||
(not (string=? slug clean-slug))))
|
||||
(when address-changed?
|
||||
(define target-page-id
|
||||
(query-maybe-value db
|
||||
"SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE"
|
||||
clean-namespace clean-slug))
|
||||
(when (and target-page-id (not (= target-page-id page-id)))
|
||||
(error 'rename-page! "page address is already in use: ~a"
|
||||
(page-reference clean-namespace clean-slug)))
|
||||
(define target-alias-page-id
|
||||
(query-maybe-value db
|
||||
"SELECT page_id FROM page_aliases WHERE namespace = $1 AND slug = $2"
|
||||
clean-namespace clean-slug))
|
||||
(when (and target-alias-page-id (not (= target-alias-page-id page-id)))
|
||||
(error 'rename-page! "page address is already an alias: ~a"
|
||||
(page-reference clean-namespace clean-slug)))
|
||||
(when target-alias-page-id
|
||||
(query-exec db
|
||||
"DELETE FROM page_aliases WHERE namespace = $1 AND slug = $2 AND page_id = $3"
|
||||
clean-namespace clean-slug page-id))
|
||||
(query-exec db
|
||||
#<<SQL
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(let ((clean-namespace (string-trim target-namespace))
|
||||
(clean-slug (string-trim target-slug)))
|
||||
(unless (valid-page-reference? (page-reference clean-namespace clean-slug))
|
||||
(error 'rename-page! "invalid page address: ~a" (page-reference clean-namespace clean-slug)))
|
||||
(when (string=? (string-trim title) "")
|
||||
(error 'rename-page! "title is required"))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(call-with-transaction
|
||||
db
|
||||
(λ ()
|
||||
(let ((row
|
||||
(query-maybe-row db
|
||||
"SELECT id, title, markdown, tags, current_version FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE FOR UPDATE"
|
||||
namespace slug)))
|
||||
(unless row
|
||||
(error 'rename-page! "unknown page: ~a" reference))
|
||||
(let* ((page-id (vector-ref row 0))
|
||||
(old-title (vector-ref row 1))
|
||||
(markdown (vector-ref row 2))
|
||||
(tags (text->tags (vector-ref row 3)))
|
||||
(current-version (vector-ref row 4))
|
||||
(address-changed?
|
||||
(or (not (string=? namespace clean-namespace))
|
||||
(not (string=? slug clean-slug)))))
|
||||
(when address-changed?
|
||||
(let ((target-page-id
|
||||
(query-maybe-value db
|
||||
"SELECT id FROM pages WHERE namespace = $1 AND slug = $2 AND archived = FALSE"
|
||||
clean-namespace clean-slug))
|
||||
(target-alias-page-id
|
||||
(query-maybe-value db
|
||||
"SELECT page_id FROM page_aliases WHERE namespace = $1 AND slug = $2"
|
||||
clean-namespace clean-slug)))
|
||||
(when (and target-page-id (not (= target-page-id page-id)))
|
||||
(error 'rename-page! "page address is already in use: ~a"
|
||||
(page-reference clean-namespace clean-slug)))
|
||||
(when (and target-alias-page-id (not (= target-alias-page-id page-id)))
|
||||
(error 'rename-page! "page address is already an alias: ~a"
|
||||
(page-reference clean-namespace clean-slug)))
|
||||
(when target-alias-page-id
|
||||
(query-exec db
|
||||
"DELETE FROM page_aliases WHERE namespace = $1 AND slug = $2 AND page_id = $3"
|
||||
clean-namespace clean-slug page-id))
|
||||
(query-exec db
|
||||
#<<SQL
|
||||
INSERT INTO page_aliases(namespace, slug, title, page_id, created_at, created_by)
|
||||
VALUES ($1, $2, $3, $4, $5, $6)
|
||||
ON CONFLICT (namespace, slug) DO NOTHING
|
||||
SQL
|
||||
namespace slug old-title page-id (current-seconds) author))
|
||||
(define next-version (+ current-version 1))
|
||||
(define now (current-seconds))
|
||||
(query-exec db
|
||||
#<<SQL
|
||||
namespace slug old-title page-id (current-seconds) author)))
|
||||
(let ((next-version (+ current-version 1))
|
||||
(now (current-seconds)))
|
||||
(query-exec db
|
||||
#<<SQL
|
||||
UPDATE pages
|
||||
SET namespace = $1, slug = $2, title = $3, current_version = $4,
|
||||
updated_at = $5, updated_by = $6,
|
||||
@@ -414,11 +425,11 @@ SET namespace = $1, slug = $2, title = $3, current_version = $4,
|
||||
setweight(to_tsvector('simple', coalesce(markdown, '')), 'B')
|
||||
WHERE id = $7
|
||||
SQL
|
||||
clean-namespace clean-slug title next-version now author page-id)
|
||||
(define page-version-id
|
||||
(insert-version! db page-id next-version title markdown author "rename" summary now tags))
|
||||
(record-version-attachment-references! db page-id page-version-id markdown now)))))
|
||||
(read-page config (page-reference clean-namespace clean-slug)))
|
||||
clean-namespace clean-slug title next-version now author page-id)
|
||||
(let ((page-version-id
|
||||
(insert-version! db page-id next-version title markdown author "rename" summary now tags)))
|
||||
(record-version-attachment-references! db page-id page-version-id markdown now)))))))))
|
||||
(read-page config (page-reference clean-namespace clean-slug)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Archive an existing wiki page.
|
||||
@@ -427,32 +438,32 @@ SQL
|
||||
; result : void.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (archive-page! config reference author)
|
||||
(define-values (namespace slug) (split-page-reference reference))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(define id
|
||||
(query-maybe-value db
|
||||
#<<SQL
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(let ((id
|
||||
(query-maybe-value db
|
||||
#<<SQL
|
||||
UPDATE pages
|
||||
SET archived = TRUE, archived_at = $1, archived_by = $2
|
||||
WHERE namespace = $3 AND slug = $4 AND archived = FALSE
|
||||
RETURNING id
|
||||
SQL
|
||||
(current-seconds) author namespace slug))
|
||||
(unless id
|
||||
(error 'archive-page! "unknown page: ~a" slug))
|
||||
(query-exec db
|
||||
"DELETE FROM attachment_references WHERE page_id = $1 AND current_reference = TRUE"
|
||||
id)))
|
||||
(void))
|
||||
(current-seconds) author namespace slug)))
|
||||
(unless id
|
||||
(error 'archive-page! "unknown page: ~a" slug))
|
||||
(query-exec db
|
||||
"DELETE FROM attachment_references WHERE page_id = $1 AND current_reference = TRUE"
|
||||
id))))
|
||||
(void)))
|
||||
|
||||
(define (page-id config reference)
|
||||
(define-values (namespace slug) (split-page-reference reference))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(page-id/db db namespace slug))))
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(page-id/db db namespace slug)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the version history for a wiki page.
|
||||
@@ -461,29 +472,29 @@ SQL
|
||||
; result : A newest-first list of version metadata hashes.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (page-history config reference)
|
||||
(define-values (namespace slug) (split-page-reference reference))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(define id (page-id/db db namespace slug))
|
||||
(unless id
|
||||
(error 'page-history "unknown page: ~a" slug))
|
||||
(for/list ((row (in-list
|
||||
(query-rows db
|
||||
#<<SQL
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(let ((id (page-id/db db namespace slug)))
|
||||
(unless id
|
||||
(error 'page-history "unknown page: ~a" slug))
|
||||
(for/list ((row (in-list
|
||||
(query-rows db
|
||||
#<<SQL
|
||||
SELECT version, title, author, action, summary, tags, created_at
|
||||
FROM page_versions
|
||||
WHERE page_id = $1
|
||||
ORDER BY version DESC
|
||||
SQL
|
||||
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)
|
||||
'tags (text->tags (vector-ref row 5))
|
||||
'createdAt (vector-ref row 6))))))
|
||||
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)
|
||||
'tags (text->tags (vector-ref row 5))
|
||||
'createdAt (vector-ref row 6))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read one stored page version.
|
||||
@@ -492,32 +503,32 @@ SQL
|
||||
; result : Version metadata with Markdown, or #f when the version is absent.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (read-version config reference version)
|
||||
(define-values (namespace slug) (split-page-reference reference))
|
||||
(define version-number
|
||||
(if (number? version) version (string->number version)))
|
||||
(and version-number
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(define id (page-id/db db namespace slug))
|
||||
(define row
|
||||
(and id
|
||||
(query-maybe-row db
|
||||
#<<SQL
|
||||
(let-values (((namespace slug) (split-page-reference reference)))
|
||||
(let ((version-number
|
||||
(if (number? version) version (string->number version))))
|
||||
(and version-number
|
||||
(call-with-wiki-database
|
||||
config
|
||||
(λ (db)
|
||||
(let* ((id (page-id/db db namespace slug))
|
||||
(row
|
||||
(and id
|
||||
(query-maybe-row db
|
||||
#<<SQL
|
||||
SELECT version, title, markdown, author, action, summary, tags, created_at
|
||||
FROM page_versions
|
||||
WHERE page_id = $1 AND version = $2
|
||||
SQL
|
||||
id version-number)))
|
||||
(and row
|
||||
(hash 'version (vector-ref row 0)
|
||||
'title (vector-ref row 1)
|
||||
'markdown (vector-ref row 2)
|
||||
'author (vector-ref row 3)
|
||||
'action (vector-ref row 4)
|
||||
'summary (vector-ref row 5)
|
||||
'tags (text->tags (vector-ref row 6))
|
||||
'createdAt (vector-ref row 7)))))))
|
||||
id version-number))))
|
||||
(and row
|
||||
(hash 'version (vector-ref row 0)
|
||||
'title (vector-ref row 1)
|
||||
'markdown (vector-ref row 2)
|
||||
'author (vector-ref row 3)
|
||||
'action (vector-ref row 4)
|
||||
'summary (vector-ref row 5)
|
||||
'tags (text->tags (vector-ref row 6))
|
||||
'createdAt (vector-ref row 7))))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Search current wiki pages using PostgreSQL full-text search.
|
||||
|
||||
+21
-21
@@ -16,24 +16,24 @@
|
||||
; result : A list of hashes containing item number, line number and text.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (extract-todos markdown)
|
||||
(define lines (string-split markdown "\n" #:trim? #f))
|
||||
(define in-fence? #f)
|
||||
(define item-number 0)
|
||||
(define result '())
|
||||
(for ((line (in-list lines))
|
||||
(line-number (in-naturals 1)))
|
||||
(define trimmed (string-trim line))
|
||||
(cond
|
||||
((regexp-match? #px"^(```|~~~)" trimmed)
|
||||
(set! in-fence? (not in-fence?)))
|
||||
((not in-fence?)
|
||||
(for ((match (in-list (regexp-match* #px"[Tt][Oo][Dd][Oo]\\([^()]+\\)" line))))
|
||||
(define text (string-trim (substring match 5 (- (string-length match) 1))))
|
||||
(when (not (string=? text ""))
|
||||
(set! item-number (+ item-number 1))
|
||||
(set! result
|
||||
(cons (hash 'number item-number
|
||||
'line line-number
|
||||
'text text)
|
||||
result)))))))
|
||||
(reverse result))
|
||||
(let ((lines (string-split markdown "\n" #:trim? #f))
|
||||
(in-fence? #f)
|
||||
(item-number 0)
|
||||
(result '()))
|
||||
(for ((line (in-list lines))
|
||||
(line-number (in-naturals 1)))
|
||||
(let ((trimmed (string-trim line)))
|
||||
(cond
|
||||
((regexp-match? #px"^(```|~~~)" trimmed)
|
||||
(set! in-fence? (not in-fence?)))
|
||||
((not in-fence?)
|
||||
(for ((match (in-list (regexp-match* #px"[Tt][Oo][Dd][Oo]\\([^()]+\\)" line))))
|
||||
(let ((text (string-trim (substring match 5 (- (string-length match) 1)))))
|
||||
(when (not (string=? text ""))
|
||||
(set! item-number (+ item-number 1))
|
||||
(set! result
|
||||
(cons (hash 'number item-number
|
||||
'line line-number
|
||||
'text text)
|
||||
result)))))))))
|
||||
(reverse result)))
|
||||
|
||||
+39
-39
@@ -39,9 +39,9 @@
|
||||
"https://cdn.jsdelivr.net/npm/diff2html@3.4.56/bundles/css/diff2html.min.css")))
|
||||
|
||||
(define (vendor-file-ready? config name)
|
||||
(define path (build-path (vendor-directory config) name))
|
||||
(and (file-exists? path)
|
||||
(> (file-size path) 0)))
|
||||
(let ((path (build-path (vendor-directory config) name)))
|
||||
(and (file-exists? path)
|
||||
(> (file-size path) 0))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Check whether all required browser libraries are installed.
|
||||
@@ -56,40 +56,40 @@
|
||||
|
||||
(define (download-content source)
|
||||
(parameterize ((current-https-protocol 'secure))
|
||||
(define-values (in headers)
|
||||
(get-pure-port/headers (string->url source)
|
||||
'()
|
||||
#:redirections 5
|
||||
#:status? #t))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(define status-match
|
||||
(regexp-match #px"^HTTP/[^ ]+ ([0-9][0-9][0-9])" headers))
|
||||
(unless (and status-match
|
||||
(= (string->number (list-ref status-match 1)) 200))
|
||||
(error 'download-vendor-files!
|
||||
"download failed for ~a: ~a"
|
||||
source
|
||||
(or (and status-match (list-ref status-match 1))
|
||||
"invalid HTTP status")))
|
||||
(port->bytes in))
|
||||
(λ ()
|
||||
(close-input-port in)))))
|
||||
(let-values (((in headers)
|
||||
(get-pure-port/headers (string->url source)
|
||||
'()
|
||||
#:redirections 5
|
||||
#:status? #t)))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(let ((status-match
|
||||
(regexp-match #px"^HTTP/[^ ]+ ([0-9][0-9][0-9])" headers)))
|
||||
(unless (and status-match
|
||||
(= (string->number (list-ref status-match 1)) 200))
|
||||
(error 'download-vendor-files!
|
||||
"download failed for ~a: ~a"
|
||||
source
|
||||
(or (and status-match (list-ref status-match 1))
|
||||
"invalid HTTP status")))
|
||||
(port->bytes in)))
|
||||
(λ ()
|
||||
(close-input-port in))))))
|
||||
|
||||
(define (download-file! config name source)
|
||||
(define directory (vendor-directory config))
|
||||
(define target (build-path directory name))
|
||||
(define temporary-target
|
||||
(build-path directory (string-append name ".download")))
|
||||
(define content (download-content source))
|
||||
(make-directory* (path-only target))
|
||||
(call-with-output-file temporary-target
|
||||
(λ (out)
|
||||
(write-bytes content out))
|
||||
#:exists 'truncate/replace)
|
||||
(rename-file-or-directory temporary-target target #t)
|
||||
(void))
|
||||
(let* ((directory (vendor-directory config))
|
||||
(target (build-path directory name))
|
||||
(temporary-target
|
||||
(build-path directory (string-append name ".download")))
|
||||
(content (download-content source)))
|
||||
(make-directory* (path-only target))
|
||||
(call-with-output-file temporary-target
|
||||
(λ (out)
|
||||
(write-bytes content out))
|
||||
#:exists 'truncate/replace)
|
||||
(rename-file-or-directory temporary-target target #t)
|
||||
(void)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Download all browser libraries required by the wiki frontend.
|
||||
@@ -101,10 +101,10 @@
|
||||
(define (download-vendor-files! config)
|
||||
(make-directory* (vendor-directory config))
|
||||
(for ([entry (in-list vendor-files)])
|
||||
(define name (car entry))
|
||||
(define source (cdr entry))
|
||||
(unless (vendor-file-ready? config name)
|
||||
(download-file! config name source)))
|
||||
(let ((name (car entry))
|
||||
(source (cdr entry)))
|
||||
(unless (vendor-file-ready? config name)
|
||||
(download-file! config name source))))
|
||||
(unless (vendor-files-ready? config)
|
||||
(error 'download-vendor-files! "frontend vendor setup is incomplete"))
|
||||
(void))
|
||||
|
||||
Reference in New Issue
Block a user