X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=lambdamail.git;a=blobdiff_plain;f=lambdamail.scm;h=fad257d9239b4bb9555a0a2ee4fcf7867375b7fa;hp=a5c9b3e03842e48236ff6144c302b7786383e46f;hb=refs%2Fheads%2Fmaster;hpb=5aaca6b594216605f185f1947674cb395046e49b diff --git a/lambdamail.scm b/lambdamail.scm index a5c9b3e..7d37b30 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -15,13 +15,12 @@ (chicken process-context posix) (chicken condition) (chicken sort) + (chicken random) srfi-1 srfi-13 matchable base64) -(define lambdamail-version "LambdaMail v1.5.0") +(define lambdamail-version "LambdaMail v1.7.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")) @@ -57,6 +56,14 @@ (server-loop listener config (deliver-messages config messages)))) +;;; Messages +;; + +(define-record message to from text user password stamp) +(define-record multi-message tos from text user password stamps) +(define (make-empty-multi-message) (make-multi-message '() "" "" "" "" '())) + + ;;; Receiving messages ;; @@ -94,7 +101,7 @@ (define (process-smtp smtp-session config) (smtp-session 'send "220 " (config-host config) " " lambdamail-version) - (let loop ((msg (make-empty-message)) + (let loop ((mmsg (make-empty-multi-message)) (received-messages '())) (let ((line (smtp-session 'get-line))) (print "got " line) @@ -104,7 +111,7 @@ ((smtp-command? "helo" line) (smtp-session 'set-helo! (smtp-command-args "helo" line)) (smtp-session 'send "250 ok") - (loop msg received-messages)) + (loop mmsg received-messages)) ((smtp-command? "ehlo" line) (smtp-session 'set-helo! (smtp-command-args "helo" line)) (smtp-session 'send @@ -112,48 +119,69 @@ " Hello " (smtp-command-args "ehlo" line)) (smtp-session 'send "250 AUTH PLAIN") ;; (smtp-session 'send "250 STARTTLS") - (loop msg received-messages)) + (loop mmsg received-messages)) ((smtp-command? "auth plain" line) (let* ((auth-string (smtp-command-args "auth plain" line)) (auth-decoded (base64-decode auth-string)) (auth-list (string-split auth-decoded "\x00")) (user (car auth-list)) (password (cadr auth-list))) - (message-user-set! msg user) - (message-password-set! msg password) + (multi-message-user-set! mmsg user) + (multi-message-password-set! mmsg password) (print "Attempted login, user: " user ", password: " password) (smtp-session 'send "235 authentication successful") - (loop msg received-messages))) + (loop mmsg received-messages))) ((smtp-command? "mail from:" line) - (message-from-set! msg (smtp-command-args "mail from:" line)) + (multi-message-from-set! mmsg (smtp-command-args "mail from:" line)) (smtp-session 'send "250 ok") - (loop msg received-messages)) + (loop mmsg received-messages)) ((smtp-command? "rcpt to:" line) - (message-to-set! msg (smtp-command-args "rcpt to:" line)) - (if (message-valid? msg config) - (smtp-session 'send "250 ok") - (smtp-session 'send "551 relay forbidden")) - (loop msg received-messages)) + (let* ((to (smtp-command-args "rcpt to:" line)) + (stamp (make-message-stamp to mmsg config))) + (print to) + (if (car stamp) + (begin + (multi-message-tos-set! mmsg (cons to (multi-message-tos mmsg))) + (multi-message-stamps-set! mmsg (cons stamp (multi-message-stamps mmsg))) + (smtp-session 'send "250 ok")) + (begin + (smtp-session 'send "551 relay forbidden")))) + (loop mmsg received-messages)) ((smtp-command? "data" line) (smtp-session 'send "354 intermediate") - (let text-loop ((text (conc "Received: from " (smtp-session 'helo) "\n" - "\tby " (config-host config) "\n" - "\tfor " (message-to msg) ";\n" - "\t" (time-stamp) "\n"))) + (let text-loop ((text "")) (let ((text-line (smtp-session 'get-line))) (if (string=? "." text-line) - (message-text-set! msg text) + (multi-message-text-set! mmsg text) (text-loop (conc text text-line "\n"))))) (smtp-session 'send "250 ok") - (loop (make-empty-message) (cons msg received-messages))) + (loop (make-empty-multi-message) + (append (make-single-recipient-messages mmsg smtp-session config) + received-messages))) ((smtp-command? "quit" line) (smtp-session 'send "221 closing transmission channel") received-messages) ((string=? "" (string-trim line)) - (loop msg received-messages)) + (loop mmsg received-messages)) (else (smtp-session 'send "502 command not implemented") - (loop msg received-messages))))))) + (loop mmsg received-messages))))))) + +(define (make-single-recipient-messages mmsg smtp-session config) + (map + (lambda (to stamp) + (print "making singleton messages: " to " " stamp) + (make-message to (multi-message-from mmsg) + (conc "Received: from " (smtp-session 'helo) "\n" + "\tby " (config-host config) "\n" + "\tfor " to ";\n" + "\t" (time-stamp) "\n" + (multi-message-text mmsg)) + (multi-message-user mmsg) + (multi-message-password mmsg) + stamp)) + (multi-message-tos mmsg) + (multi-message-stamps mmsg))) ;;; Message stamping and validation @@ -172,32 +200,27 @@ (filter directory-exists? (glob (conc (config-spool-dir config) "/*")))))) -(define (message-stamp msg config) +(define (make-message-stamp to mmsg config) (let* ((local-addresses (get-local-addresses config)) - (local-dest (assoc (message-to msg) local-addresses)) - (local-src (assoc (message-from msg) local-addresses))) + (local-dest (assoc to local-addresses)) + (local-src (assoc (multi-message-from mmsg) local-addresses))) (cond (local-dest (list #t 'local (cadr local-dest))) (local-src - (let ((password (caddr local-src))) - (if (and (string=? (conc "<" (message-user msg) "@" (config-host config) ">") - (message-from msg)) - password - (string=? (message-password msg) password)) + (let ((host-password (caddr local-src))) + (if (and (string=? (conc "<" (multi-message-user mmsg) "@" (config-host config) ">") + (multi-message-from mmsg)) + host-password + (string=? (multi-message-password mmsg) host-password)) (list #t 'remote) (begin - (print "Provided password " (message-password msg)) - (print "Host password " password) + (print "Provided password " (multi-message-password mmsg)) + (print "Host password " host-password) (list #f 'remote))))) (else (list #f 'relay))))) -(define (message-valid? msg config) - (let ((stamp (message-stamp msg config))) - (print "Stamp: " stamp) - (car stamp))) - ;;; Sending/Delivering messages ;; @@ -211,7 +234,7 @@ (print "From: " (message-from msg)) (print "To: " (message-to msg)) (condition-case - (match (message-stamp msg config) + (match (message-stamp msg) ((#t 'local dest-dir) (deliver-message-local msg dest-dir)) ((#t 'remote) (deliver-message-remote msg config)) ((#f 'remote) @@ -227,8 +250,14 @@ ;; Local delivery +(define unique-file-name + (let ((counter 0)) + (lambda () + (set! counter (modulo (+ counter 1) 1000)) + (conc (current-seconds) "_" counter)))) + (define (deliver-message-local msg dest-dir) - (with-output-to-file (conc dest-dir "/" (current-seconds)) + (with-output-to-file (conc dest-dir "/" (unique-file-name)) (lambda () (print (message-text msg)))) (print "* MESSAGE DELIVERED (local)") @@ -242,7 +271,7 @@ ;; 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) +(define (get-mail-servers-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) @@ -250,38 +279,48 @@ (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)))))) + (sorted-mx-entries (map cadr (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 + (list domain) ; fall-back to email address domain if no mx entries + sorted-mx-entries))) ; otherwise pick the highest priority server (define (deliver-message-remote msg config) - (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") - (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))))) + (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)) @@ -358,9 +397,9 @@ (config-spool-dir-set! config (cadr rest-args)))) (run-server config)))))))) -;; (main) +(main) -(define (test) - (run-server (make-config "localhost" 2525 "spool" '() '()))) +;; (define (test) +;; (run-server (make-config "localhost" 2525 "spool" '() '()))) ;; (test)