X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=lambdamail.git;a=blobdiff_plain;f=lambdamail.scm;h=07b14519b32214829b8572ea5df1c431934a7e72;hp=e66e4de82d6186d27ba55c3881afb15dcb52773c;hb=24573e108fe7cb5368cabd16dad6906a67ed91d1;hpb=0000b11973ff2e22ae1a7183146c8e76f8197cc1 diff --git a/lambdamail.scm b/lambdamail.scm index e66e4de..07b1451 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -14,14 +14,18 @@ (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")) + ;;; Server initialization ;; @@ -58,9 +62,10 @@ (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 " (seconds->string))) + (print "Accepted connection from " remote-ip " on " (time-stamp))) (condition-case (set! messages (process-smtp (make-smtp-session in-port out-port config) config)) (o (exn) @@ -72,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))) @@ -91,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))) @@ -99,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)) @@ -129,7 +139,10 @@ (loop msg received-messages)) ((smtp-command? "data" line) (smtp-session 'send "354 intermediate") - (let text-loop ((text "")) + (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) @@ -152,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 @@ -205,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 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") @@ -229,19 +259,32 @@ (smtp-session 'send "data") (smtp-session 'expect "354") (smtp-session 'send (message-text msg)) + (smtp-session 'send ".") (smtp-session 'expect "250") (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) +(define ((make-outgoing-smtp-session tcp-in tcp-out) . command) (match command (('expect code) - (string-prefix? "220" (read-line tcp-in))) + (let ((result (read-line tcp-in))) + (print "Expecting " code " got " result) + (string-prefix? code result))) (('send strings ...) - (write-string (string-translate (conc (apply conc strings) "\n") "\n" "\r\n") - out-port)))) + (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 ;;