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