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