X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=lambdamail.git;a=blobdiff_plain;f=lambdamail.scm;h=d185d89afae3e98c889572b4a1ee9078b2f71dfb;hp=ce5b188e43c1a7f29ea7565c6794eaa44a322378;hb=50c28ee76a3a6a5820bf499370ffb7f92ef061a5;hpb=e7fc7be3229edbabaaf43259591e6ac8d1c89cc5 diff --git a/lambdamail.scm b/lambdamail.scm index ce5b188..d185d89 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -8,8 +8,11 @@ (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) @@ -17,7 +20,7 @@ (define-record config - host port spool-dir) + host port spool-dir user group) (define-record message to from text helo) (define (make-empty-message) (make-message "" "" "" "")) @@ -42,6 +45,14 @@ ;;; 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 "::"))) @@ -49,6 +60,7 @@ " 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))) @@ -78,33 +90,29 @@ (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) (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) (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) (loop msg (smtp 'get-line))) ((string-prefix? "data" line) - (print "got " line) (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 (smtp 'get-line) - (conc text text-line)))) - (deliver-message msg config) + (conc text text-line "\n")))) + (process-message msg config) (smtp 'ok) (loop (make-empty-message) (smtp 'get-line))) @@ -115,40 +123,94 @@ (loop msg (smtp 'get-line))) (else (smtp 'not-implemented) - (print "got " line) (loop msg (smtp 'get-line))))) 'done))) ;;; Message delivery ;; - -(define (deliver-message msg config) - (print "Message delivered:") - (print " * From: " (message-from msg)) - (print " * To: " (message-to msg)) - (print " * Text: " (message-text msg))) + +(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: " progname " hostname [port [spooldir]]")) + (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)))) - (args (cdr (argv))) - (config (make-config "" 25 "/var/spool/mail"))) - (if (null? args) + (config (make-config "" 25 "/var/spool/mail" '() '()))) + (if (null? (cdr (argv))) (print-usage progname) - (begin - (config-host-set! config (car args)) - (unless (null? (cdr args)) - (config-port-set! config (string->number (cadr args))) - (unless (null? (cddr args)) - (config-spool-dir-set! (caddr args)))) - (run-server config))))) + (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)