X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=lambdamail.git;a=blobdiff_plain;f=lambdamail.scm;h=07b14519b32214829b8572ea5df1c431934a7e72;hp=cffc81f610f04a57dc7ee71cc0b876b200e12b84;hb=24573e108fe7cb5368cabd16dad6906a67ed91d1;hpb=4106bac227d80d4e75fee7a08a4ad257ba91e603 diff --git a/lambdamail.scm b/lambdamail.scm index cffc81f..07b1451 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -14,32 +14,17 @@ (chicken process-context) (chicken process-context posix) (chicken condition) - srfi-1 srfi-13) + (chicken sort) + srfi-1 srfi-13 matchable base64) -(define lambdamail-version "0.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-record config - host port spool-dir user group) -(define-record message to from text helo) -(define (make-empty-message) (make-message "" "" "" "")) - - -;;; SMTP transactions -;; - -(define ((make-smtp in-port out-port config) type) - (if (eq? type 'get-line) - (read-line in-port) - (write-line (conc - (case type - ((greeting) (conc "220 " (config-host config) - " LambdaMail v" lambdamail-version)) - ((ok) "250 ok") - ((intermediate) "354 intermediate") - ((close) "221 closing transmission channel") - ((not-implemented) "502 command not implemented")) - "\r") out-port))) +(define (time-stamp) + (time->string (seconds->local-time) "%d %b %Y %T %z")) ;;; Server initialization @@ -56,117 +41,249 @@ (define (run-server config) (set-buffering-mode! (current-output-port) #:line) (let ((listener (tcp-listen (config-port config) 10 "::"))) - (print "LambdaMail v" lambdamail-version + (print lambdamail-version " listening on port " (config-port config) " ...") (print "(Host name: " (config-host config) ", Spool dir: " (config-spool-dir config) ")") (drop-privs config) - (server-loop listener config))) + (server-loop listener config '()))) ;;; Main server loop ;; -(define (server-loop listener config) - (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))) - (condition-case - (let ((smtp (make-smtp in-port out-port config))) - (smtp 'greeting) - (process-smtp smtp config)) - (o (exn) - (print-error-message o))) - (print "Terminating connection.") - (close-input-port in-port) - (close-output-port out-port) - (server-loop listener config))) - -;;; SMTP processing loop +(define (server-loop listener config undelivered-messages) + (let* ((messages (append (receive-messages listener config) undelivered-messages))) + (server-loop listener config (deliver-messages config messages)))) + + +;;; Receiving messages ;; -(define (process-smtp smtp config) +(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))) + (condition-case + (set! messages (process-smtp (make-smtp-session in-port out-port config) config)) + (o (exn) + (print-error-message o))) + (print "Terminating connection.") + (close-input-port in-port) + (close-output-port out-port)) + messages)) + +(define (make-smtp-session in-port out-port config) + (let ((user "") + (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) + (('helo) helo))))) + +(define (smtp-command? cmd-string input-string) + (string-prefix? cmd-string (string-downcase input-string))) + +(define (smtp-command-args cmd-string input-string) + (if (> (string-length input-string) (string-length cmd-string)) + (string-trim (string-drop input-string (string-length cmd-string))) + "")) + +(define (process-smtp smtp-session config) + (smtp-session 'send "220 " (config-host config) " " lambdamail-version) (let loop ((msg (make-empty-message)) - (line-orig (smtp 'get-line))) - (if (string? line-orig) - (let ((line (string-downcase line-orig))) - (print "got " line) - (cond - ((string-prefix? "helo" line) - (message-helo-set! msg (string-drop line (string-length "helo"))) - (smtp 'ok) - (loop msg (smtp 'get-line))) - ((string-prefix? "mail from:" line) - (message-from-set! msg (string-drop line (string-length "mail from:"))) - (smtp 'ok) - (loop msg (smtp 'get-line))) - ((string-prefix? "rcpt to:" line) - (message-to-set! msg (string-drop line (string-length "rcpt to:"))) - (smtp 'ok) - (loop msg (smtp 'get-line))) - ((string-prefix? "data" line) - (smtp 'intermediate) - (let text-loop ((text-line (smtp 'get-line)) - (text "")) + (received-messages '())) + (let ((line (smtp-session 'get-line))) + (when (string? line) + (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)) + (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)) + (auth-decoded (base64-decode auth-string)) + (auth-list (string-split auth-decoded "\x00")) + (user (car auth-list)) + (password (cadr auth-list))) + (smtp-session 'set-user! user) + (smtp-session 'set-password! password) + (print "Attempted login, user: " user ", password: " password) + (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 "250 ok") + (loop msg received-messages)) + ((smtp-command? "rcpt to:" line) + (message-to-set! msg (smtp-command-args "rcpt to:" line)) + (smtp-session 'send "250 ok") + (loop msg received-messages)) + ((smtp-command? "data" line) + (smtp-session 'send "354 intermediate") + (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) - (text-loop (smtp 'get-line) - (conc text text-line "\n")))) - (process-message msg config) - (smtp 'ok) - (loop (make-empty-message) - (smtp 'get-line))) - ((string-prefix? "quit" line) - (smtp 'close) - 'done) - ((string=? "" line) - (loop msg (smtp 'get-line))) - (else - (smtp 'not-implemented) - (loop msg (smtp 'get-line))))) - 'done))) - - -;;; Message delivery + (text-loop (conc text text-line "\n"))))) + (message-user-set! msg (smtp-session 'user)) + (message-password-set! msg (smtp-session 'password)) + (smtp-session 'send "250 ok") + (loop (make-empty-message) (cons msg received-messages))) + ((smtp-command? "quit" line) + (smtp-session 'send "221 closing transmission channel") + received-messages) + ((string=? "" (string-trim line)) + (loop msg received-messages)) + (else + (smtp-session 'send "502 command not implemented") + (loop msg received-messages))))))) + + +;;; Sending/Delivering messages ;; -(define (get-to-addresses config) +(define (deliver-messages config messages) + (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 + (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 "* DELIVERY FAILED") + (print-error-message o) + #t))) + + +;; 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))) - -(define (deliver-message-mbox msg dest-file) - (print "Delivering to mbox " dest-file) - (with-output-to-file dest-file - (lambda () - (print "\nFrom " (remove-angle-brackets (message-from msg))) - (print (message-text msg))) - #:append)) + (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-maildir msg dest-dir) - (print "Delivering to maildir " dest-dir) +(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-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* ((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") + (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 (process-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-maildir msg dest-file) - (deliver-message-mbox msg dest-file)) - (print "Message DELIVERED:")) - (print "Message REJECTED:")) - (print " * From: " (message-from msg)) - (print " * To: " (message-to msg)))) +(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 " (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 @@ -209,9 +326,10 @@ (unless (null? rest-args) (config-port-set! config (string->number (car rest-args))) (unless (null? (cdr rest-args)) - (config-spool-dir-set! (cadr rest-args)))) + (config-spool-dir-set! config (cadr rest-args)))) (run-server config)))))))) (main) -;; (run-server (make-config "thelambdalab.xyz" 2525 "/var/spool/mail")) +;; (define (test) +;; (run-server (make-config "localhost" 2525 "spool" '() '())))