Full conversion done
This commit is contained in:
+22
-143
@@ -1,149 +1,28 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/list
|
||||
racket/string
|
||||
racket/tcp
|
||||
net/base64
|
||||
"manager-ini.rkt"
|
||||
"report.rkt")
|
||||
(require net/smtp
|
||||
net/head
|
||||
simple-ini)
|
||||
|
||||
(provide maybe-send-report-mail
|
||||
mail-address->envelope-address
|
||||
strict-send-smtp-mail)
|
||||
(provide mail-report)
|
||||
|
||||
|
||||
(define (smtp-proc name)
|
||||
(dynamic-require 'smtp name))
|
||||
(define (mail-report ini subject report)
|
||||
(let* ((get (λ (key msg)
|
||||
(let ((v (ini-get ini 'mail key 'nil)))
|
||||
(when (eq? v 'nil)
|
||||
(error msg))
|
||||
v)))
|
||||
(from (get 'from "configure from address as name <email>"))
|
||||
(to (get 'to "configure to address as name <email>"))
|
||||
(server (get 'server "configure the smtp server"))
|
||||
(port (ini-get ini 'mail 'port 25))
|
||||
)
|
||||
(let* ((hdr (standard-message-header from (list to) '() '() subject)))
|
||||
(smtp-send-message server from (list to) hdr
|
||||
(if (list? report) report (list report))
|
||||
#:port-no port)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(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 ini 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 (ini-ref/bool ini 'mail 'enabled #f)
|
||||
(not (null? (ini-ref/addresses ini 'mail 'to "")))
|
||||
(or (and has-errors? (ini-ref/bool ini 'mail 'send-on-error #t))
|
||||
(and (not has-errors?) (ini-ref/bool ini 'mail 'send-on-success #f)))))
|
||||
(when should-send?
|
||||
(define from (mail-address->envelope-address (ini-ref/string ini 'mail 'from "")))
|
||||
(define to (clean-address-list (ini-ref/addresses ini 'mail 'to "")))
|
||||
(define cc (clean-address-list (ini-ref/addresses ini 'mail 'cc "")))
|
||||
(define bcc (clean-address-list (ini-ref/addresses ini 'mail 'bcc "")))
|
||||
(define subject (format "~a ~a: ~a error(s), ~a ~a"
|
||||
(ini-ref/string ini 'mail 'subject-prefix "[flac-48khz-manager]")
|
||||
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 (ini-ref/string ini 'mail 'host ""))
|
||||
#:port (ini-ref/int ini 'mail 'port 25)
|
||||
#:tls-encode (ini-ref/bool ini 'mail 'tls #f)
|
||||
#:username (string-trim (ini-ref/string ini 'mail 'username ""))
|
||||
#:password (ini-ref/string ini 'mail 'password ""))))
|
||||
|
||||
Reference in New Issue
Block a user