From aff9db4ac6f7d557eacf9fc89f15e6ca65d10786 Mon Sep 17 00:00:00 2001 From: plugd Date: Thu, 29 Sep 2022 14:29:12 +0200 Subject: [PATCH] Remote mail delivery will now try all mail servers. --- lambdamail.scm | 70 ++++++++++++++++++++++++++++---------------------- 1 file changed, 40 insertions(+), 30 deletions(-) diff --git a/lambdamail.scm b/lambdamail.scm index fad257d..ed7f662 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -271,7 +271,7 @@ ;; This is a hack - there's no built-in interface to res_query() ;; in chicken, so we have to resort to a system call to dig... -(define (get-mail-server-for-domain domain) +(define (get-mail-servers-for-domain domain) (let* ((mx-lines (let-values (((in out id) (process (conc "dig " domain " mx +short")))) (with-input-from-port in read-lines))) (mx-entries (map (lambda (l) @@ -279,38 +279,48 @@ (list (string->number (car s)) (string-drop-right (cadr s) 1)))) ; remove trailing "." mx-lines)) - (sorted-mx-entries (sort mx-entries (lambda (e f) (< (car e) (car f)))))) + (sorted-mx-entries (map cadr (sort mx-entries (lambda (e f) (< (car e) (car f))))))) (if (null? sorted-mx-entries) - domain ; fall-back to email address domain if no mx entries - (cadar sorted-mx-entries)))) ; otherwise pick the highest priority server + (list domain) ; fall-back to email address domain if no mx entries + sorted-mx-entries))) ; otherwise pick the highest priority server (define (deliver-message-remote msg config) - (let* ((domain (get-domain-from-email (message-to msg))) - (mail-server (get-mail-server-for-domain domain))) - (print "Attempting delivery to " mail-server) - (let-values (((tcp-in tcp-out) (tcp-connect mail-server 25))) - (let ((smtp-session (make-outgoing-smtp-session tcp-in tcp-out))) - (let ((result (and - (smtp-session 'expect "220") - (smtp-session 'send "helo " (config-host config)) - (smtp-session 'expect "250") - (smtp-session 'send "mail from:" (message-from msg)) - (smtp-session 'expect "250") - (smtp-session 'send "rcpt to:" (message-to msg)) - (smtp-session 'expect "250") - (smtp-session 'send "data") - (smtp-session 'expect "354") - (smtp-session 'send (message-text msg)) - (smtp-session 'send ".") - (smtp-session 'expect "250" "5") ;Do not try again on rejects. - (smtp-session 'send "quit")))) - (close-input-port tcp-in) - (close-output-port tcp-out) - (print "Connection closed.") - (if result - (print "* MESSAGE DELIVERED (remote)") - (print "* REMOTE DELIVERY FAILED (unexpected server response)")) - result))))) + (let ((domain (get-domain-from-email (message-to msg)))) + (let loop ((mail-servers (get-mail-servers-for-domain domain))) + (if (null? mail-servers) + (begin + (print "* REMOTE DELIVERY FAILED (Could not connect to any mail server)") + #f) + (condition-case + (let ((mail-server (car mail-servers))) + (print "Attempting delivery to " mail-server) + (let-values (((tcp-in tcp-out) (tcp-connect mail-server 25))) + (let ((smtp-session (make-outgoing-smtp-session tcp-in tcp-out))) + (let ((result (and + (smtp-session 'expect "220") + (smtp-session 'send "helo " (config-host config)) + (smtp-session 'expect "250") + (smtp-session 'send "mail from:" (message-from msg)) + (smtp-session 'expect "250") + (smtp-session 'send "rcpt to:" (message-to msg)) + (smtp-session 'expect "250") + (smtp-session 'send "data") + (smtp-session 'expect "354") + (smtp-session 'send (message-text msg)) + (smtp-session 'send ".") + (smtp-session 'expect "250" "5") ;Do not try again on rejects. + (smtp-session 'send "quit")))) + (close-input-port tcp-in) + (close-output-port tcp-out) + (print "Connection closed.") + (if result + (print "* MESSAGE DELIVERED (remote)") + (print "* REMOTE DELIVERY FAILED (unexpected server response)")) + result)))) + (o (exn) + (print-error-messsage o) + (print "* Failed to connect. Trying next server.") + (loop (cdr mail-servers)))))))) (define (or-list l) (fold (lambda (a b) (or a b)) #f l)) -- 2.20.1