#lang racket/base

(require racket/list
         racket/string
         racket/tcp
         net/base64
         "config.rkt"
         "report.rkt")

(provide maybe-send-report-mail
         mail-address->envelope-address
         strict-send-smtp-mail)


(define (smtp-proc name)
  (dynamic-require 'smtp name))

(define (non-empty-string? v)
  (and (string? v) (not (string=? (string-trim v) ""))))

(define (base64-line s)
  (bytes->string/utf-8 (base64-encode (string->bytes/utf-8 (or s "")) #"")))

(define (trim-envelope-address s)
  (define t (string-replace s "\"" ""))
  (regexp-replace* #rx"^[<> \t\r\n]+|[<> \t\r\n]+$" t ""))

(define (mail-address->envelope-address v)
  (define s (string-trim (format "~a" v)))
  (define m (regexp-match #px"<([^<>]+)>" s))
  (define addr (if m (cadr m) s))
  (trim-envelope-address addr))

(define (clean-address-list xs)
  (filter non-empty-string?
          (for/list ([x (in-list xs)])
            (mail-address->envelope-address x))))

(define (write-smtp-command out command)
  (display (string-append (string-trim command) "\r\n") out)
  (flush-output out))

(define (read-smtp-response in expected host)
  (let loop ([lines '()])
    (define line (read-line in 'any))
    (when (eof-object? line)
      (error 'strict-send-smtp-mail "smtp server ~a: unexpected EOF" host))
    (define lines* (cons line lines))
    (define ok-code?
      (and (>= (string-length line) 3)
           (equal? (substring line 0 3) (number->string expected))))
    (unless ok-code?
      (error 'strict-send-smtp-mail "smtp server ~a:\n     ~a" host (string-join (reverse lines*) "\n     ")))
    (if (and (> (string-length line) 3) (char=? (string-ref line 3) #\-))
        (loop lines*)
        (reverse lines*))))

(define (strict-send-smtp-mail mail
                               #:host host
                               #:port port
                               #:tls-encode [tls-encode #f]
                               #:username [username ""]
                               #:password [password ""])
  ;; The smtp package writes commands as "MAIL FROM: <addr>" and
  ;; "RCPT TO: <addr>". Some servers reject the whitespace before the path.
  ;; This sender keeps using smtp's mail struct and MIME header generation,
  ;; but sends the SMTP envelope as "MAIL FROM:<addr>" / "RCPT TO:<addr>".
  (when tls-encode
    (error 'strict-send-smtp-mail "TLS/STARTTLS is not supported by the strict sender yet"))
  (define mail-sender (smtp-proc 'mail-sender))
  (define mail-recipients (smtp-proc 'mail-recipients))
  (define mail-cc-recipients (smtp-proc 'mail-cc-recipients))
  (define mail-bcc-recipients (smtp-proc 'mail-bcc-recipients))
  (define mail-header (smtp-proc 'mail-header))
  (define sender (mail-address->envelope-address (mail-sender mail)))
  (define recipients (append (clean-address-list (mail-recipients mail))
                             (clean-address-list (mail-cc-recipients mail))
                             (clean-address-list (mail-bcc-recipients mail))))
  (unless (non-empty-string? host)
    (error 'strict-send-smtp-mail "missing SMTP host"))
  (unless (non-empty-string? sender)
    (error 'strict-send-smtp-mail "missing SMTP sender"))
  (when (null? recipients)
    (error 'strict-send-smtp-mail "missing SMTP recipient"))
  (define-values (in out) (tcp-connect host port))
  (dynamic-wind
   void
   (lambda ()
     (read-smtp-response in 220 host)
     (write-smtp-command out "EHLO localhost.localdomain")
     (read-smtp-response in 250 host)
     (when (non-empty-string? username)
       (write-smtp-command out "AUTH LOGIN")
       (read-smtp-response in 334 host)
       (write-smtp-command out (base64-line username))
       (read-smtp-response in 334 host)
       (write-smtp-command out (base64-line password))
       (read-smtp-response in 235 host))
     (write-smtp-command out (format "MAIL FROM:<~a>" sender))
     (read-smtp-response in 250 host)
     (for ([r (in-list recipients)])
       (write-smtp-command out (format "RCPT TO:<~a>" r))
       (read-smtp-response in 250 host))
     (write-smtp-command out "DATA")
     (read-smtp-response in 354 host)
     (display (mail-header mail) out)
     (display "\r\n.\r\n" out)
     (flush-output out)
     (read-smtp-response in 250 host)
     (write-smtp-command out "QUIT")
     (read-smtp-response in 221 host))
   (lambda ()
     (close-input-port in)
     (close-output-port out))))

(define (maybe-send-report-mail config summary errors
                                #:manager-name [manager-name "FLAC 48 kHz manager"]
                                #:result-label [result-label "converted"])
  (define has-errors? (positive? (summary-ref summary 'errors 0)))
  (define should-send?
    (and (manager-config-mail-enabled? config)
         (not (null? (manager-config-mail-to config)))
         (or (and has-errors? (manager-config-mail-send-on-error? config))
             (and (not has-errors?) (manager-config-mail-send-on-success? config)))))
  (when should-send?
    (define from (mail-address->envelope-address (manager-config-mail-from config)))
    (define to (clean-address-list (manager-config-mail-to config)))
    (define cc (clean-address-list (manager-config-mail-cc config)))
    (define bcc (clean-address-list (manager-config-mail-bcc config)))
    (define subject (format "~a ~a: ~a error(s), ~a ~a"
                            (manager-config-mail-subject-prefix config)
                            manager-name
                            (summary-ref summary 'errors 0)
                            (summary-ref summary 'converted 0)
                            result-label))
    (define body (html-report subject summary errors))
    (define make-mail (smtp-proc 'make-mail))
    (define mail (make-mail subject body
                            #:from from
                            #:to to
                            #:cc cc
                            #:bcc bcc
                            #:body-content-type "text/html"))
    (strict-send-smtp-mail mail
                           #:host (string-trim (manager-config-mail-host config))
                           #:port (manager-config-mail-port config)
                           #:tls-encode (manager-config-mail-tls? config)
                           #:username (string-trim (manager-config-mail-username config))
                           #:password (manager-config-mail-password config))))