-(define (process-message msg config)
- (let ((dest (assoc (message-to msg) (get-to-addresses config))))
- (if dest
- (let ((dest-file (cdr dest)))
- (if (directory-exists? dest-file)
- (deliver-message-maildir msg dest-file)
- (deliver-message-mbox msg dest-file))
- (print "Message DELIVERED:"))
- (print "Message REJECTED:"))
- (print " * From: " (message-from msg))
- (print " * To: " (message-to msg))))
+(define (deliver-message-remote msg config)
+ (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))
+
+(define ((make-outgoing-smtp-session tcp-in tcp-out) . command)
+ (match command
+ (('expect codes ...)
+ (let loop ((result (read-line tcp-in)))
+ (if (and (> (string-length result) 3)
+ (eq? (string-ref result 3) #\-))
+ (loop (read-line tcp-in)) ;status continues on next line
+ (begin
+ (print "Expecting one of " codes " got " result)
+ (or-list (map (lambda (code)
+ (string-prefix? code result))
+ codes))))))
+ (('send strings ...)
+ (print "Sending " (if (> (string-length (car strings)) 30)
+ (string-take (car strings) 30)
+ (car strings)))
+ (let ((processed-string
+ (string-translate* (conc (apply conc strings) "\n")
+ '(("\n" . "\r\n")))))
+ (write-string processed-string #f tcp-out)))))