#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."))))