Added README.

[lambdamail.git] / lambdamail.scm

diff --git a/lambdamail.scm b/lambdamail.scm
index 1cfe6a0..d185d89 100644 (file)
--- 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)))
 
 
@@ -100,7 +112,7 @@
                   (message-text-set! msg text)
                   (text-loop (smtp 'get-line)
                              (conc text text-line "\n"))))
-            (deliver-message msg config)
+            (process-message msg config)
             (smtp 'ok)
             (loop (make-empty-message)
                   (smtp 'get-line)))
@@ -130,15 +142,27 @@
         (right-idx (substring-index ">" addr)))
     (substring addr (+ left-idx 1) right-idx)))
 
-(define (deliver-message msg config)
+(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
-        (begin
-          (with-output-to-file (cdr dest)
-            (lambda ()
-              (print "\nFrom " (remove-angle-brackets (message-from msg)))
-              (print (message-text msg)))
-            #:append)
+        (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))
@@ -149,21 +173,44 @@
 ;;
 
 (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)