240 lines
11 KiB
Racket
240 lines
11 KiB
Racket
#lang racket/base
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Password-reset email delivery configured through the database or environment.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(require db
|
|
net/smtp
|
|
openssl
|
|
racket/string
|
|
"config.rkt"
|
|
"database.rkt")
|
|
|
|
(provide password-reset-mail-configured?
|
|
password-reset-mail-settings
|
|
save-password-reset-mail-settings!
|
|
send-test-mail!
|
|
send-password-reset-mail!)
|
|
|
|
(define (environment-value name)
|
|
(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 " "))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Adapt modern TLS negotiation to net/smtp's STARTTLS callback.
|
|
; pre : host is the SMTP server name and accept-untrusted-certificates? is a boolean.
|
|
; post : A client context has been created but no connection is open.
|
|
; result : An encoder accepted by smtp-send-message.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (make-starttls-encoder host accept-untrusted-certificates?)
|
|
(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"
|
|
"smtp-host" "RACKET_WIKI_SMTP_HOST"
|
|
"smtp-port" "RACKET_WIKI_SMTP_PORT"
|
|
"smtp-from" "RACKET_WIKI_SMTP_FROM"
|
|
"smtp-user" "RACKET_WIKI_SMTP_USER"
|
|
"smtp-password" "RACKET_WIKI_SMTP_PASSWORD"
|
|
"smtp-tls" "RACKET_WIKI_SMTP_TLS"
|
|
"smtp-accept-untrusted-certificates" "RACKET_WIKI_SMTP_ACCEPT_UNTRUSTED_CERTIFICATES"
|
|
"reset-limit" "RACKET_WIKI_RESET_LIMIT"))
|
|
|
|
(define (database-mail-settings config)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(for/hash ((row (in-list (query-rows db "SELECT key, value FROM wiki_settings WHERE key LIKE 'mail.%'"))))
|
|
(values (substring (vector-ref row 0) 5) (vector-ref row 1))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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)
|
|
(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
|
|
(λ (db)
|
|
(call-with-transaction
|
|
db
|
|
(λ ()
|
|
(for (((key _environment-name) (in-hash setting-environment-names)))
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(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.
|
|
; pre : supplied-settings contains the values from the admin form.
|
|
; post : One test message has been submitted; settings are unchanged.
|
|
; result : void.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (send-test-mail! config supplied-settings recipient)
|
|
(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.
|
|
; pre : Required mail settings are configured in the database or environment.
|
|
; post : One email has been submitted to the SMTP server.
|
|
; result : void.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (send-password-reset-mail! config recipient token)
|
|
(unless (password-reset-mail-configured? config)
|
|
(error 'send-password-reset-mail! "Password-reset email is not configured"))
|
|
(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."))))
|