From: plugd <plugd@thelambdalab.xyz>
Date: Thu, 29 Sep 2022 12:29:12 +0000 (+0200)
Subject: Remote mail delivery will now try all mail servers.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=aff9db4ac6f7d557eacf9fc89f15e6ca65d10786;p=lambdamail.git

Remote mail delivery will now try all mail servers.
---

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))