Implemented, but bug in openssl call somewhere.

diff --git a/README b/README
index 3521943..3c04fd7 100644 (file)
--- a/README
+++ b/README
@@ -5,22 +5,19 @@ This is an _extremely simple_ SMTP server designed specifically for
 running on personal servers with a very small number (~1) users.  It
 is probably best defined in terms of what it does not support:
 
-- It does not (yet?) support TLS connections.
 - It does not relay messages between remote addresses.
 - It does not spawn threads to allow simultaneous inbound connections.
 - It does not respond with honest errors on failed deliveries.
 
-Apart from the lack of TLS, I consider these features.  There's no
-(obvious) way for LambdaMail to become a source of spam, the lack
-of multithreaded operation is a built-in rate limiter (not to mention
-its side effect of making all delivery operations "atomic"), and
-its penchant for just responding "250 OK" to almost everything means
-that it doesn't leak information about users on the system.
+I consider these features.  There's no (obvious) way for LambdaMail to
+become a source of spam, the lack of multithreaded operation is a
+built-in rate limiter (not to mention its side effect of making all
+delivery operations "atomic"), and its penchant for just responding
+"250 OK" to almost everything means that it doesn't leak information
+about users on the system.
 
-LambdaMail is still under active development and, given that it was
-written for a single use case, lacks any documentation.  However
-it's a pretty simple Scheme program, so glancing over the code should
-suffice.
+LambdaMail lacks any documentation.  However it's a pretty simple
+Scheme program, so glancing over the code should suffice.
 
 License
 -------

diff --git a/lambdamail.scm b/lambdamail.scm
index 7caf27e..c51ac6a 100644 (file)
--- a/lambdamail.scm
+++ b/lambdamail.scm
@@ -18,9 +18,12 @@
         (chicken random)
         srfi-1 srfi-13 matchable base64)
 
-(define lambdamail-version "LambdaMail v1.7.0")
+(define lambdamail-version "LambdaMail v1.8.0")
 
-(define-record config host port spool-dir user group)
+(define-record config host port spool-dir user group certfile keyfile)
+(define (tls-supported? config)
+  (and (config-certfile config)
+       (config-keyfile config)))
 
 (define (time-stamp)
   (time->string (seconds->local-time) "%d %b %Y %T %z"))
@@ -32,18 +35,21 @@
 (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.
+    (if gid ; Group first, since only root can switch groups.
         (set! (current-group-id) gid))
-    (if (not (null? uid))
+    (if 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-version
-           " listening on port " (config-port config) " ...")
-    (print "(Host name: " (config-host config)
-           ", Spool dir: " (config-spool-dir config) ")")
+    (print "Starting " lambdamail-version " with the following configuration:")
+    (print "Host: '" (config-host config) "'\n"
+           "Port: '" (config-port config) "'\n"
+           "Spool dir: '" (config-spool-dir config) "'")
+    (when (tls-supported? config)
+      (print "Cert file: '" (config-certfile config) "'\n"
+             "Key file: '" (config-keyfile config) "'"))
     (drop-privs config)
     (server-loop listener config '())))
 
@@ -89,7 +95,16 @@
         (('get-line) (read-line in-port))
         (('send strings ...) (write-line (conc (apply conc strings) "\r") out-port))
         (('set-helo! h) (set! helo h))
-        (('helo) helo)))))
+        (('helo) helo)
+        (('starttls)
+         (let-values (((in-port-tls out-port-tls)
+                       (ssl-start* tcp-in: in-port
+                                   tcp-out: out-port
+                                   certificate: (config-certfile config)
+                                   private-key: (config-keyfile config)
+                                   protocol: (cons 'tlsv12 ssl-max-protocol))))
+           (set! in-port in-port-tls)
+           (set! out-port out-port-tls)))))))
 
 (define (smtp-command? cmd-string input-string)
   (string-prefix? cmd-string (string-downcase input-string)))
@@ -122,14 +137,11 @@
             (loop mmsg received-messages))
            ((smtp-command? "starttls" line)
             (let ((args (smtp-command-args "starttls" line)))
-              (if (= 0 (string-length args))
+              (if (> 0 (string-length args))
                   (smtp-session 'send "501 Syntax error (no parameters allowed)")
                   (begin
                     (smtp-session 'send "220 Ready to start TLS")
-
-                    ;; TODO: initiate TLS handshake using (ssl-start*)
-
-                    ))))
+                    (smtp-session 'starttls)))))
            ((smtp-command? "auth plain" line)
             (let* ((auth-string (smtp-command-args "auth plain" line))
                    (auth-decoded (base64-decode auth-string))
@@ -364,17 +376,20 @@
   (print "Usage:\n"
          progname " -h/--help\n"
          progname " -v/--version\n"
-         progname " [-u/--user UID] [-g/--group GID] hostname [[port [spooldir]]\n"
+         progname " [-u/--user UID] [-g/--group GID] [-c/--certfile] [-k/--keyfile]\n"
+         (make-string (string-length progname)) " 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)."))
+         "following the creation of the TCP port listener (which often requires root).\n"
+         "The -c and -k options specify certificate and key files in PEM format for\n"
+         "optional STARTTLS support."))
 
 (define (print-version)
   (print lambdamail-version))
 
 (define (main)
   (let ((progname (pathname-file (car (argv))))
-        (config (make-config "" 25 "/var/spool/mail" '() '())))
+        (config (make-config "" 25 "/var/spool/mail" #f #f #f #f)))
     (if (null? (cdr (argv)))
         (print-usage progname)
         (let loop ((args (cdr (argv))))
@@ -390,6 +405,14 @@
                       (equal? this-arg "--group"))
                   (config-group-set! config (string->number (car rest-args)))
                   (loop (cdr rest-args)))
+                 ((or (equal? this-arg "-c")
+                      (equal? this-arg "--certfile"))
+                  (config-certfile-set! config (car rest-args))
+                  (loop (cdr rest-args)))
+                 ((or (equal? this-arg "-k")
+                      (equal? this-arg "--keyfile"))
+                  (config-keyfile-set! config (car rest-args))
+                  (loop (cdr rest-args)))
                  ((or (equal? this-arg "-h")
                       (equal? this-arg "--help"))
                   (print-usage progname))