X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=lambdamail.git;a=blobdiff_plain;f=lambdamail.scm;h=683781e9ae0e96b462ca058a12ed138f82be9cc2;hp=fe9519efb0740e037de5fa8280c5688e79d1f1af;hb=2d92632d54049b81988e5eabb849eaa4b2248830;hpb=1d04df7655dee7ebdd292a65ad399610b532e111 diff --git a/lambdamail.scm b/lambdamail.scm index fe9519e..683781e 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -22,6 +22,9 @@ (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 ;; @@ -60,7 +63,7 @@ (let ((messages '())) (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) @@ -73,10 +76,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 +94,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 +102,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,38 +120,41 @@ (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") - (let text-loop ((text "")) + (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-line (smtp-session 'get-line))) (if (string=? "." text-line) (message-text-set! msg text) (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))))))) -;;; Delivering messages +;;; Sending/Delivering messages ;; (define (deliver-messages config messages) @@ -156,36 +162,98 @@ (filter (lambda (msg) (not (deliver-message msg config))) messages)) -(define (get-to-addresses config) +(define (deliver-message msg config) + (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 + +(define (get-local-addresses config) (map (lambda (p) (cons (conc "<" (car p) "@" (config-host config) ">") (cdr p))) - (map (lambda (file) (cons (pathname-file file) file)) - (glob (conc (config-spool-dir config) "/*"))))) - -(define (remove-angle-brackets addr) - (let ((left-idx (substring-index "<" addr)) - (right-idx (substring-index ">" addr))) - (substring addr (+ left-idx 1) right-idx))) + (map (lambda (file) + (list (pathname-file file) file + (let ((password-file (conc file ".auth"))) + (if (file-exists? password-file) + (with-input-from-file password-file read-line) + #f)))) + (filter directory-exists? + (glob (conc (config-spool-dir config) "/*")))))) (define (deliver-message-local msg dest-dir) - (print "Delivering to maildir " dest-dir) (with-output-to-file (conc dest-dir "/" (current-seconds)) (lambda () (print (message-text msg))))) -(define (deliver-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-local msg dest-file)) - (print "Message DELIVERED:")) - (print "Message REJECTED:")) - (print " * From: " (message-from msg)) - (print " * To: " (message-to msg))) - #t) +;; Remote delivery + +(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 2525))) + (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") + (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) + (let ((result (read-line tcp-in))) + (print "Expecting " code " got " result) + (string-prefix? code result))) + (('send strings ...) + (print "Sending " (car strings) (if (> (length strings) 1) " ... (truncated)" "")) + (let ((processed-string + (string-translate* (conc (apply conc strings) "\n") + '(("\n" . "\r\n"))))) + (write-string processed-string #f tcp-out))))) ;;; Command line argument parsing ;; @@ -232,4 +300,5 @@ (main) -;; (run-server (make-config "thelambdalab.xyz" 2525 "/var/spool/mail")) +;; (define (test) +;; (run-server (make-config "localhost" 2525 "spool" '() '())))