From 0000b11973ff2e22ae1a7183146c8e76f8197cc1 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Wed, 4 Sep 2019 17:52:46 +0200 Subject: [PATCH] Draft remote-delivery implementation. --- lambdamail.scm | 118 +++++++++++++++++++++++++++++++------------------ 1 file changed, 76 insertions(+), 42 deletions(-) diff --git a/lambdamail.scm b/lambdamail.scm index 48383e4..e66e4de 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -73,10 +73,10 @@ (define (make-smtp-session in-port out-port config) (let ((user "") (password "")) - (lambda msg - (match msg + (lambda command + (match command (('get-line) (read-line in-port)) - (('send-line strings ...) (write-line (conc (apply conc strings) "\r") out-port)) + (('send strings ...) (write-line (conc (apply conc strings) "\r") out-port)) (('set-user! u) (set! user u)) (('set-password! p) (set! password p)) (('user) user) @@ -91,7 +91,7 @@ "")) (define (process-smtp smtp-session config) - (smtp-session 'send-line "220 " (config-host config) lambdamail-version) + (smtp-session 'send "220 " (config-host config) lambdamail-version) (let loop ((msg (make-empty-message)) (received-messages '())) (let ((line (smtp-session 'get-line))) @@ -99,14 +99,14 @@ (print "got " line) (cond ((smtp-command? "helo" line) - (smtp-session 'send-line "250 ok") + (smtp-session 'send "250 ok") (loop msg received-messages)) ((smtp-command? "ehlo" line) - (smtp-session 'send-line + (smtp-session 'send "250-" (config-host config) " Hello " (smtp-command-args "ehlo" line)) - (smtp-session 'send-line "250 AUTH PLAIN") - ;; (smtp-session 'send-line "250 STARTTLS") + (smtp-session 'send "250 AUTH PLAIN") + ;; (smtp-session 'send "250 STARTTLS") (loop msg received-messages)) ((smtp-command? "auth plain" line) (let* ((auth-string (smtp-command-args "auth plain" line)) @@ -117,18 +117,18 @@ (smtp-session 'set-user! user) (smtp-session 'set-password! password) (print "Attempted login, user: " user ", password: " password) - (smtp-session 'send-line "235 authentication successful") + (smtp-session 'send "235 authentication successful") (loop msg received-messages))) ((smtp-command? "mail from:" line) (message-from-set! msg (smtp-command-args "mail from:" line)) - (smtp-session 'send-line "250 ok") + (smtp-session 'send "250 ok") (loop msg received-messages)) ((smtp-command? "rcpt to:" line) (message-to-set! msg (smtp-command-args "rcpt to:" line)) - (smtp-session 'send-line "250 ok") + (smtp-session 'send "250 ok") (loop msg received-messages)) ((smtp-command? "data" line) - (smtp-session 'send-line "354 intermediate") + (smtp-session 'send "354 intermediate") (let text-loop ((text "")) (let ((text-line (smtp-session 'get-line))) (if (string=? "." text-line) @@ -136,15 +136,15 @@ (text-loop (conc text text-line "\n"))))) (message-user-set! msg (smtp-session 'user)) (message-password-set! msg (smtp-session 'password)) - (smtp-session 'send-line "250 ok") + (smtp-session 'send "250 ok") (loop (make-empty-message) (cons msg received-messages))) ((smtp-command? "quit" line) - (smtp-session 'send-line "221 closing transmission channel") + (smtp-session 'send "221 closing transmission channel") received-messages) ((string=? "" (string-trim line)) (loop msg received-messages)) (else - (smtp-session 'send-line "502 command not implemented") + (smtp-session 'send "502 command not implemented") (loop msg received-messages))))))) @@ -157,30 +157,35 @@ messages)) (define (deliver-message msg config) - (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-file)) - (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) - (print "Message DELIVERED (remote):")) - (print "Message DELIVERY REJECTED (auth failure):")))) - (else - (print "Message DELIVERY REJECTED (relay forbidden):")))) - (print " * From: " (message-from msg)) - (print " * To: " (message-to msg)) - #t) + (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-file)) + (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 DELIVERY REJECTED (auth failure):")))) + (else + (print "Message DELIVERY REJECTED (relay forbidden):")))) + (print " * From: " (message-from msg)) + (print " * To: " (message-to msg)) + #t) + (o (exn) + (print "Message delivery failed.") + (print-error-message o)))) ;; Local delivery @@ -205,9 +210,38 @@ ;; Remote delivery -(define (deliver-message-remote msg) - (print "TODO")) - +(define (get-host-from-email email-string) + (car (string-split (cadr (string-split email-string "@")) ">"))) + +(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 ((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 'expect "250") + (smtp-session 'send "quit")))) + (close-input-port tcp-in) + (close-output-port tcp-out) + result))))) + +(define ((make-outgoing-smtp-session tcp-in tcp-out) command) + (match command + (('expect code) + (string-prefix? "220" (read-line tcp-in))) + (('send strings ...) + (write-string (string-translate (conc (apply conc strings) "\n") "\n" "\r\n") + out-port)))) ;;; Command line argument parsing ;; -- 2.20.1