refactoring by skill
This commit is contained in:
+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."))))
|
||||
|
||||
Reference in New Issue
Block a user