X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=lambdamail.scm;h=3f3594e7d1e34c19debdcd2b89e405302eacfa5d;hb=5634d7afd52fe66623d6410ba37b131884db72e3;hp=c47c14506509692b8a6e86242a5c677a2491f065;hpb=d95c6338e3c2bc2d3916022834e1e320fa8e7e93;p=lambdamail.git diff --git a/lambdamail.scm b/lambdamail.scm index c47c145..3f3594e 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -8,40 +8,34 @@ (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) + srfi-1 srfi-13 matchable base64) (define lambdamail-version "0.0.1") +(define-record config host port spool-dir user group) +(define-record message to from text helo user password) +(define (make-empty-message) (make-message "" "" "" "" "" "")) -(define-record config - host port spool-dir) -(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 outbound-mail-queue '()) ;;; 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 +43,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))) @@ -60,95 +55,178 @@ (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)) + (let ((smtp-session (make-smtp-session in-port out-port config))) + (smtp-session 'greet) + (process-smtp smtp-session config)) (o (exn) (print-error-message o))) (print "Terminating connection.") (close-input-port in-port) - (close-output-port out-port) - (server-loop listener config))) + (close-output-port out-port)) + (print "Attempting delivery of " (length outbound-mail-queue) " mail items.") + (set! outbound-mail-queue + (filter (lambda (msg) (not (deliver-message msg config))) + outbound-mail-queue)) + (server-loop listener config)) ;;; SMTP processing loop ;; -(define (process-smtp smtp config) - (let loop ((msg (make-empty-message)) - (line-orig (smtp 'get-line))) - (if (string? line-orig) - (let ((line (string-downcase 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? "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) - (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) - (print "got " line) - (loop msg (smtp 'get-line))))) - 'done))) +(define (make-smtp-session in-port out-port config) + (let ((smtp-say (lambda args (write-line (conc (apply conc args) "\r") out-port))) + (user "") + (password "")) + (lambda msg + (match msg + (('get-line) (read-line in-port)) + (('set-user! u) (set! user u)) + (('set-password! p) (set! password p)) + (('user) user) + (('password) password) + (('auth-success) (smtp-say "235 Authentication successful")) + (('greet) (smtp-say "220 " (config-host config) + " LambdaMail v" lambdamail-version)) + (('ok) (smtp-say "250 ok")) + (('ehlo host) + (smtp-say "250-" (config-host config) " Hello " host) + (smtp-say "250 AUTH PLAIN")) + (('intermediate) (smtp-say "354 intermediate")) + (('close) (smtp-say "221 closing transmission channel")) + (('not-implemented) (smtp-say "502 command not implemented")))))) + +(define (process-smtp smtp-session config) + (let loop ((msg (make-empty-message))) + (let ((line-orig (smtp-session '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"))) + (smtp-session 'ok) + (loop msg)) + ((string-prefix? "ehlo" line) + (smtp-session 'ehlo (string-drop line (+ 1 (string-length "ehlo")))) + (loop msg)) + ((string-prefix? "auth plain" line) + (let* ((auth-string (string-drop line-orig (+ 1 (string-length "auth plain")))) + (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 'auth-success) + (loop msg))) + ((string-prefix? "mail from:" line) + (message-from-set! msg (string-drop line (string-length "mail from:"))) + (smtp-session 'ok) + (loop msg)) + ((string-prefix? "rcpt to:" line) + (message-to-set! msg (string-drop line (string-length "rcpt to:"))) + (smtp-session 'ok) + (loop msg)) + ((string-prefix? "data" line) + (smtp-session 'intermediate) + (let text-loop ((text-line (smtp-session 'get-line)) + (text "")) + (if (string=? "." text-line) + (message-text-set! msg text) + (text-loop (smtp-session 'get-line) + (conc text text-line "\n")))) + (message-user-set! msg (smtp-session 'user)) + (message-password-set! msg (smtp-session 'password)) + (set! outbound-mail-queue (cons msg outbound-mail-queue)) + (smtp-session 'ok) + (loop (make-empty-message))) + ((string-prefix? "quit" line) + (smtp-session 'close) + 'done) + ((string=? "" line) + (loop msg)) + (else + (smtp-session 'not-implemented) + (loop msg)))) + 'done)))) ;;; 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-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) - (print "Message delivered:") - (print " * From: " (message-from msg)) - (print " * To: " (message-to msg)) - (print " * Text: " (message-text msg))) + (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) ;;; 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)