225 lines
9.6 KiB
Racket
225 lines
9.6 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)
|
|
(define value (getenv name))
|
|
(and value
|
|
(not (string=? (string-trim value) ""))
|
|
(string-trim value)))
|
|
|
|
(define (safe-header-value value)
|
|
(regexp-replace* #px"[\r\n]+" value " "))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Adapt modern TLS negotiation to net/smtp's STARTTLS callback.
|
|
; pre : host is the SMTP server name and accept-untrusted-certificates? is a boolean.
|
|
; post : A client context has been created but no connection is open.
|
|
; result : An encoder accepted by smtp-send-message.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (make-starttls-encoder host accept-untrusted-certificates?)
|
|
(define context
|
|
(if accept-untrusted-certificates?
|
|
(ssl-make-client-context 'auto)
|
|
(ssl-secure-client-context)))
|
|
(λ (input-port output-port
|
|
#:mode mode
|
|
#:encrypt _protocol
|
|
#:close-original? close-original?)
|
|
(if accept-untrusted-certificates?
|
|
(ports->ssl-ports input-port
|
|
output-port
|
|
#:mode mode
|
|
#:context context
|
|
#:close-original? close-original?)
|
|
(ports->ssl-ports input-port
|
|
output-port
|
|
#:mode mode
|
|
#:context context
|
|
#:hostname host
|
|
#:close-original? close-original?))))
|
|
|
|
(define setting-environment-names
|
|
(hash "public-url" "RACKET_WIKI_PUBLIC_URL"
|
|
"smtp-host" "RACKET_WIKI_SMTP_HOST"
|
|
"smtp-port" "RACKET_WIKI_SMTP_PORT"
|
|
"smtp-from" "RACKET_WIKI_SMTP_FROM"
|
|
"smtp-user" "RACKET_WIKI_SMTP_USER"
|
|
"smtp-password" "RACKET_WIKI_SMTP_PASSWORD"
|
|
"smtp-tls" "RACKET_WIKI_SMTP_TLS"
|
|
"smtp-accept-untrusted-certificates" "RACKET_WIKI_SMTP_ACCEPT_UNTRUSTED_CERTIFICATES"
|
|
"reset-limit" "RACKET_WIKI_RESET_LIMIT"))
|
|
|
|
(define (database-mail-settings config)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(for/hash ((row (in-list (query-rows db "SELECT key, value FROM wiki_settings WHERE key LIKE 'mail.%'"))))
|
|
(values (substring (vector-ref row 0) 5) (vector-ref row 1))))))
|
|
|
|
(define (password-reset-mail-settings config)
|
|
(define stored (database-mail-settings config))
|
|
(for/hash (((key environment-name) (in-hash setting-environment-names)))
|
|
(define default
|
|
(cond
|
|
((string=? key "smtp-port") "587")
|
|
((string=? key "reset-limit") "2")
|
|
((string=? key "smtp-tls") "true")
|
|
((string=? key "smtp-accept-untrusted-certificates") "false")
|
|
(else "")))
|
|
(values key (or (hash-ref stored key #f)
|
|
(environment-value environment-name)
|
|
default))))
|
|
|
|
(define (save-password-reset-mail-settings! config settings)
|
|
(call-with-wiki-database
|
|
config
|
|
(λ (db)
|
|
(call-with-transaction
|
|
db
|
|
(λ ()
|
|
(for (((key _environment-name) (in-hash setting-environment-names)))
|
|
(define supplied-value (hash-ref settings key ""))
|
|
(define value
|
|
(if (string=? key "smtp-password")
|
|
supplied-value
|
|
(string-trim supplied-value)))
|
|
(unless (and (string=? key "smtp-password") (string=? value ""))
|
|
(if (string=? value "")
|
|
(query-exec db "DELETE FROM wiki_settings WHERE key = $1" (string-append "mail." key))
|
|
(query-exec db
|
|
"INSERT INTO wiki_settings(key, value, updated_at) VALUES ($1, $2, $3) ON CONFLICT(key) DO UPDATE SET value = excluded.value, updated_at = excluded.updated_at"
|
|
(string-append "mail." key) value (current-seconds))))))))))
|
|
|
|
(define (password-reset-mail-configured? config)
|
|
(define settings (password-reset-mail-settings config))
|
|
(and (not (string=? (hash-ref settings "public-url") ""))
|
|
(not (string=? (hash-ref settings "smtp-host") ""))
|
|
(not (string=? (hash-ref settings "smtp-from") ""))))
|
|
|
|
(define (settings-with-stored-password config supplied-settings)
|
|
(define stored-settings (password-reset-mail-settings config))
|
|
(define supplied-password (hash-ref supplied-settings "smtp-password" ""))
|
|
(define effective-password
|
|
(if (string=? supplied-password "")
|
|
(hash-ref stored-settings "smtp-password" "")
|
|
supplied-password))
|
|
(for/hash (((key _environment-name) (in-hash setting-environment-names)))
|
|
(define value
|
|
(if (string=? key "smtp-password")
|
|
effective-password
|
|
(hash-ref supplied-settings key (hash-ref stored-settings key ""))))
|
|
(values key value)))
|
|
|
|
(define (send-mail-with-settings! settings recipient subject body-lines)
|
|
(define host (string-trim (hash-ref settings "smtp-host" "")))
|
|
(define from (safe-header-value (string-trim (hash-ref settings "smtp-from" ""))))
|
|
(when (string=? host "")
|
|
(error 'send-mail-with-settings! "SMTP server is required"))
|
|
(when (string=? from "")
|
|
(error 'send-mail-with-settings! "Sender address is required"))
|
|
(define configured-port (string->number (hash-ref settings "smtp-port" "587")))
|
|
(define port
|
|
(if (and (exact-integer? configured-port) (<= 1 configured-port 65535))
|
|
configured-port
|
|
587))
|
|
(define configured-user (hash-ref settings "smtp-user" ""))
|
|
(define user
|
|
(if (string=? configured-user "") #f configured-user))
|
|
(define configured-password (hash-ref settings "smtp-password" ""))
|
|
(define password
|
|
(if (string=? configured-password "") #f configured-password))
|
|
(define starttls?
|
|
(string-ci=? (hash-ref settings "smtp-tls" "true") "true"))
|
|
(define accept-untrusted-certificates?
|
|
(string-ci=? (hash-ref settings "smtp-accept-untrusted-certificates" "false") "true"))
|
|
(define header
|
|
(string-append "From: " from "\r\n"
|
|
"To: " (safe-header-value recipient) "\r\n"
|
|
"Subject: " (safe-header-value subject) "\r\n"
|
|
"MIME-Version: 1.0\r\n"
|
|
"Content-Type: text/plain; charset=UTF-8\r\n"
|
|
"\r\n"))
|
|
(define message
|
|
(for/list ((line (in-list body-lines)))
|
|
(string->bytes/utf-8 line)))
|
|
(with-handlers ((exn:fail?
|
|
(λ (exception)
|
|
(define message (exn-message exception))
|
|
(if (regexp-match? #px"certificate verify failed" message)
|
|
(error 'send-mail-with-settings!
|
|
"TLS certificate verification failed; install a valid certificate or explicitly accept untrusted certificates for this trusted local SMTP server")
|
|
(raise exception)))))
|
|
(smtp-send-message host
|
|
from
|
|
(list recipient)
|
|
header
|
|
message
|
|
#:port-no port
|
|
#:auth-user user
|
|
#:auth-passwd password
|
|
#:tls-encode (if starttls?
|
|
(make-starttls-encoder host accept-untrusted-certificates?)
|
|
#f))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Test supplied SMTP settings without storing them.
|
|
; pre : supplied-settings contains the values from the admin form.
|
|
; post : One test message has been submitted; settings are unchanged.
|
|
; result : void.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (send-test-mail! config supplied-settings recipient)
|
|
(define settings
|
|
(settings-with-stored-password config supplied-settings))
|
|
(send-mail-with-settings!
|
|
settings
|
|
recipient
|
|
(string-append (wiki-config-site-title config) " SMTP test")
|
|
(list (string-append "This is a test message from "
|
|
(wiki-config-site-title config)
|
|
".")
|
|
""
|
|
"The SMTP server accepted the message using the settings from the administration form.")))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Send a one-time password-reset link through configured SMTP.
|
|
; pre : Required mail settings are configured in the database or environment.
|
|
; post : One email has been submitted to the SMTP server.
|
|
; result : void.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (send-password-reset-mail! config recipient token)
|
|
(unless (password-reset-mail-configured? config)
|
|
(error 'send-password-reset-mail! "Password-reset email is not configured"))
|
|
(define settings (password-reset-mail-settings config))
|
|
(define public-url
|
|
(string-trim (hash-ref settings "public-url") "/" #:right? #t))
|
|
(define reset-url
|
|
(string-append public-url "/reset-password?token=" token))
|
|
(send-mail-with-settings!
|
|
settings
|
|
recipient
|
|
"Password reset"
|
|
(list (string-append "A password reset was requested for your account at "
|
|
(wiki-config-site-title config)
|
|
".")
|
|
""
|
|
"Open this link within one hour:"
|
|
reset-url
|
|
""
|
|
"If you did not request this, you can ignore this email.")))
|