X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=lambdamail.git;a=blobdiff_plain;f=lambdamail.scm;h=d185d89afae3e98c889572b4a1ee9078b2f71dfb;hp=e4956d8bd5d0d00e8bf183fa71841766752b4aed;hb=50c28ee76a3a6a5820bf499370ffb7f92ef061a5;hpb=5c769132c51dbe2812d70db4566e5880f80a82e7 diff --git a/lambdamail.scm b/lambdamail.scm index e4956d8..d185d89 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -8,101 +8,210 @@ (chicken string) (chicken pathname) (chicken file) + (chicken time) (chicken time posix) + (chicken process) (chicken process-context) + (chicken process-context posix) + (chicken condition) srfi-1 srfi-13 matchable) (define lambdamail-version "0.0.1") -(define-record config port) + +(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))) + + +;;; Server initialization +;; + +(define (drop-privs config) + (let ((uid (config-user config)) + (gid (config-group config))) + (if (not (null? gid)) ; Group first, since only root can switch groups. + (set! (current-group-id) gid)) + (if (not (null? uid)) + (set! (current-user-id) uid)))) + (define (run-server config) (set-buffering-mode! (current-output-port) #:line) (let ((listener (tcp-listen (config-port config) 10 "::"))) - (print "LambdaMail listening on port " (config-port config) " ...") + (print "LambdaMail v" 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))) + +;;; 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))) - (smtp-greeting out-port) - (process-smtp in-port out-port) - (print "Connection terminated.") + (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)) - -(define (smtp-reply reply out-port) - (write-line reply out-port)) - -(define (smtp-greeting out-port) - (smtp-reply (conc "220 thelambdalab.xyz LambdaMail v" lambdamail-version) out-port)) - -(define (smtp-ok out-port) - (smtp-reply "250 OK" out-port)) - -(define (smtp-intermediate out-port) - (smtp-reply "354 Intermediate" out-port)) - -(define (smtp-close out-port) - (smtp-reply "221 Closing transmission channel" out-port)) + (close-output-port out-port) + (server-loop listener config))) -(define (smtp-no out-port) - (smtp-reply "502 Command not implemented" out-port)) +;;; SMTP processing loop +;; -(define (process-smtp in-port out-port) +(define (process-smtp smtp config) (let loop ((msg (make-empty-message)) - (line-orig (read-line in-port))) + (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"))) - (print "got " line) - (smtp-ok out-port) - (loop msg (read-line in-port))) + (smtp 'ok) + (loop msg (smtp 'get-line))) ((string-prefix? "mail from:" line) - (print "got " line) (message-from-set! msg (string-drop line (string-length "mail from:"))) - (smtp-ok out-port) - (loop msg (read-line in-port))) + (smtp 'ok) + (loop msg (smtp 'get-line))) ((string-prefix? "rcpt to:" line) - (print "got " line) (message-to-set! msg (string-drop line (string-length "rcpt to:"))) - (smtp-ok out-port) - (loop msg (read-line in-port))) + (smtp 'ok) + (loop msg (smtp 'get-line))) ((string-prefix? "data" line) - (print "got " line) - (smtp-intermediate out-port) - (let text-loop ((text-line (read-line in-port)) + (smtp 'intermediate) + (let text-loop ((text-line (smtp 'get-line)) (text "")) - (print "Received '" text-line "'") (if (string=? "." text-line) (message-text-set! msg text) - (text-loop (read-line in-port) - (conc text text-line)))) - (deliver-message msg) - (smtp-ok out-port) + (text-loop (smtp 'get-line) + (conc text text-line "\n")))) + (process-message msg config) + (smtp 'ok) (loop (make-empty-message) - (read-line in-port))) + (smtp 'get-line))) ((string-prefix? "quit" line) - (smtp-close out-port) + (smtp 'close) 'done) ((string=? "" line) - (loop msg (read-line in-port))) + (loop msg (smtp 'get-line))) (else - (smtp-no out-port) - (print "got " line) - (loop msg (read-line in-port))))) + (smtp 'not-implemented) + (loop msg (smtp 'get-line))))) 'done))) - -(define (deliver-message msg) - (print "Message delivered:") - (print " * From: " (message-from msg)) - (print " * To: " (message-to msg)) - (print " * Text: " (message-text msg))) - -(run-server (make-config 25)) + + +;;; Message delivery +;; + +(define (get-to-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)) + +(define (deliver-message-maildir msg dest-dir) + (print "Delivering to maildir " dest-dir) + (with-output-to-file (conc dest-dir "/" (current-seconds)) + (lambda () + (print (message-text msg))))) + +(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)))) + + +;;; Command line argument parsing +;; + +(define (print-usage progname) + (print "Usage:\n" + progname " -h/--help\n" + progname " [-u/--user UID] [-g/--group GID] hostname [[port [spooldir]]\n" + "\n" + "The -u and -g options can be used to set the UID and GID of the process\n" + "following the creation of the TCP port listener (which often requires root).")) + +(define (main) + (let ((progname (pathname-file (car (argv)))) + (config (make-config "" 25 "/var/spool/mail" '() '()))) + (if (null? (cdr (argv))) + (print-usage progname) + (let loop ((args (cdr (argv)))) + (let ((this-arg (car args)) + (rest-args (cdr args))) + (if (string-prefix? "-" this-arg) + (cond + ((or (equal? this-arg "-u") + (equal? this-arg "--user")) + (config-user-set! config (string->number (car rest-args))) + (loop (cdr rest-args))) + ((or (equal? this-arg "-g") + (equal? this-arg "--group")) + (config-group-set! config (string->number (car rest-args))) + (loop (cdr rest-args))) + ((or (equal? this-arg "-h") + (equal? this-arg "--help")) + (print-usage progname)) + (else + (print "Unknown option " this-arg "\n") + (print-usage progname))) + (begin + (config-host-set! config this-arg) + (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)))) + (run-server config)))))))) + +(main) + +;; (run-server (make-config "thelambdalab.xyz" 2525 "/var/spool/mail"))