150 lines
6.3 KiB
Racket
150 lines
6.3 KiB
Racket
#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))))
|