X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=lambdamail.git;a=blobdiff_plain;f=lambdamail.scm;h=07b14519b32214829b8572ea5df1c431934a7e72;hp=683781e9ae0e96b462ca058a12ed138f82be9cc2;hb=24573e108fe7cb5368cabd16dad6906a67ed91d1;hpb=2d92632d54049b81988e5eabb849eaa4b2248830 diff --git a/lambdamail.scm b/lambdamail.scm index 683781e..07b1451 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -14,16 +14,17 @@ (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) (define (make-empty-message) (make-message "" "" "" "" "")) (define (time-stamp) - (time->string (seconds->local-time "%d %b %Y %T %z"))) + (time->string (seconds->local-time) "%d %b %Y %T %z")) ;;; Server initialization @@ -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))) @@ -75,15 +77,18 @@ (define (make-smtp-session in-port out-port config) (let ((user "") - (password "")) + (password "") + (helo "")) (lambda command (match command (('get-line) (read-line in-port)) (('send strings ...) (write-line (conc (apply conc strings) "\r") out-port)) (('set-user! u) (set! user u)) (('set-password! p) (set! password p)) + (('set-helo! h) (set! helo h)) (('user) user) - (('password) password))))) + (('password) password) + (('helo) helo))))) (define (smtp-command? cmd-string input-string) (string-prefix? cmd-string (string-downcase input-string))) @@ -94,7 +99,7 @@ "")) (define (process-smtp smtp-session config) - (smtp-session 'send "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))) @@ -102,9 +107,11 @@ (print "got " line) (cond ((smtp-command? "helo" line) + (smtp-session 'set-helo! (smtp-command-args "helo" line)) (smtp-session 'send "250 ok") (loop msg received-messages)) ((smtp-command? "ehlo" line) + (smtp-session 'set-helo! (smtp-command-args "helo" line)) (smtp-session 'send "250-" (config-host config) " Hello " (smtp-command-args "ehlo" line)) @@ -132,10 +139,10 @@ (loop msg received-messages)) ((smtp-command? "data" line) (smtp-session 'send "354 intermediate") - (let text-loop ((text (conc "Received: from " (smtp-session 'helo) - " by " (config-host) - " for " (message-from msg) - "; " (time-stamp)))) + (let text-loop ((text (conc "Received: from " (smtp-session 'helo) "\n" + " by " (config-host config) "\n" + " for " (message-from msg) + "; " (time-stamp) "\n"))) (let ((text-line (smtp-session 'get-line))) (if (string=? "." text-line) (message-text-set! msg text) @@ -158,40 +165,39 @@ ;; (define (deliver-messages config messages) - (print "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-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) + (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 @@ -211,18 +217,36 @@ (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 2525))) + (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") @@ -240,6 +264,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) @@ -249,12 +277,15 @@ (print "Expecting " code " got " result) (string-prefix? code result))) (('send strings ...) - (print "Sending " (car strings) (if (> (length strings) 1) " ... (truncated)" "")) + (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))))) + ;;; Command line argument parsing ;;