From 68469a9c497a0a6f2b1c4715c26d0d6665f60391 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Wed, 4 Sep 2019 23:50:18 +0200 Subject: [PATCH] Outgoing delivery working! Although there's infrastruture for retrying messages with delivery failures, this only occurs after another connection has been made. I.e. there's no support for retrying after a certain period, which is needed. --- lambdamail.scm | 92 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 56 insertions(+), 36 deletions(-) diff --git a/lambdamail.scm b/lambdamail.scm index bcd7a7e..90c186f 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -14,9 +14,10 @@ (chicken process-context) (chicken process-context posix) (chicken condition) + (chicken sort) srfi-1 srfi-13 matchable base64) -(define lambdamail-version "LambdaMail v0.0.1") +(define lambdamail-version "LambdaMail v1.0.0") (define-record config host port spool-dir user group) (define-record message to from text user password) @@ -61,6 +62,7 @@ (define (receive-messages listener config) (let ((messages '())) + (print "*** Waiting for incoming mail") (let-values (((in-port out-port) (tcp-accept listener))) (let-values (((local-ip remote-ip) (tcp-addresses in-port))) (print "Accepted connection from " remote-ip " on " (time-stamp))) @@ -163,41 +165,38 @@ ;; (define (deliver-messages config messages) - (print "\n" - "**** Attempting delivery of " (length messages) " mail items.") + (print "**** Attempting delivery of " (length messages) " mail items.") (filter (lambda (msg) (not (deliver-message msg config))) messages)) (define (deliver-message msg config) + (print "From: " (message-from msg)) + (print "To: " (message-to msg)) (condition-case - (begin - (let* ((local-addresses (get-local-addresses config)) - (dest (assoc (message-to msg) local-addresses)) - (orig (assoc (message-from msg) local-addresses))) - (cond - (dest - (let ((dest-dir (cadr dest))) - (deliver-message-local msg dest-dir)) - (print "Message DELIVERED (local):")) - (orig - (let ((password (caddr orig))) - (if (and - (string=? (conc "<" (message-user msg) "@" (config-host config) ">") - (message-from msg)) - password - (string=? (message-password msg) password)) - (begin - (deliver-message-remote msg config) - (print "Message DELIVERED (remote):")) - (print "Message REMOTE DELIVERY REJECTED (auth failure):")))) - (else - (print "Message REMOTE DELIVERY REJECTED (relay forbidden):")))) - (print " * From: " (message-from msg)) - (print " * To: " (message-to msg)) - #t) + (let* ((local-addresses (get-local-addresses config)) + (dest (assoc (message-to msg) local-addresses)) + (orig (assoc (message-from msg) local-addresses))) + (cond + (dest + (let ((dest-dir (cadr dest))) + (deliver-message-local msg dest-dir))) + (orig + (let ((password (caddr orig))) + (if (and (string=? (conc "<" (message-user msg) "@" (config-host config) ">") + (message-from msg)) + password + (string=? (message-password msg) password)) + (deliver-message-remote msg config) + (begin + (print "* REMOTE DELIVERY NOT ALLOWED (auth failure)") + #t)))) + (else + (print "* REMOTE DELIVERY REJECTED (relay forbidden)") + #t))) (o (exn) - (print "Message delivery failed.") - (print-error-message o)))) + (print "* DELIVERY FAILED") + (print-error-message o) + #t))) ;; Local delivery @@ -217,18 +216,35 @@ (define (deliver-message-local msg dest-dir) (with-output-to-file (conc dest-dir "/" (current-seconds)) (lambda () - (print (message-text msg))))) - + (print (message-text msg)))) + (print "* MESSAGE DELIVERED (local)") + #t) ;; Remote delivery -(define (get-host-from-email email-string) +(define (get-domain-from-email email-string) (car (string-split (cadr (string-split email-string "@")) ">"))) +;; 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) + (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) + (let ((s (string-split l))) + (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)))))) + (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 + (define (deliver-message-remote msg config) - (let ((host (get-host-from-email (message-to msg)))) - (print "Attempting delivery to host " host) - (let-values (((tcp-in tcp-out) (tcp-connect host 25))) + (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") @@ -246,6 +262,10 @@ (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))))) (define ((make-outgoing-smtp-session tcp-in tcp-out) . command) -- 2.20.1