X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=lambdamail.scm;h=1e9fb4dfb51eeff3d3ca134b94dc5363a980830e;hb=bb0d46c4f46a5717ed8083abebece89112a99e00;hp=c47c14506509692b8a6e86242a5c677a2491f065;hpb=d95c6338e3c2bc2d3916022834e1e320fa8e7e93;p=lambdamail.git diff --git a/lambdamail.scm b/lambdamail.scm index c47c145..1e9fb4d 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 "" "" "" "")) @@ -25,23 +28,33 @@ ;;; SMTP transactions ;; -(define ((make-smtp in-port out-port config) type) - (if (eq? type 'get-line) +(define ((make-smtp in-port out-port config) . msg) + (if (equal? msg '(get-line)) (read-line in-port) (write-line (conc - (case type - ((greeting) (conc "220 " (config-host config) + (match msg + (('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")) + (('ok) "250 ok") + (('ehlo host) (conc "250-" (config-host config) " Hello " host "\r\n" + "250 AUTH PLAIN")) + (('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 "::"))) @@ -49,6 +62,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 +92,32 @@ (line-orig (smtp 'get-line))) (if (string? line-orig) (let ((line (string-downcase line-orig))) + (print "got " line-orig) (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? "ehlo" line) + (smtp 'ehlo (string-drop line (+ 1 (string-length "ehlo")))) + (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 "\n" 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,7 +128,6 @@ (loop msg (smtp 'get-line))) (else (smtp 'not-implemented) - (print "got " line) (loop msg (smtp 'get-line))))) 'done))) @@ -123,32 +135,79 @@ ;;; 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-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! config (cadr rest-args)))) + (run-server config)))))))) (main)