ehlo only replies with STARTTLS when certs provided.

[lambdamail.git] / lambdamail.scm

diff --git a/lambdamail.scm b/lambdamail.scm
index 7d37b30..946f831 100644 (file)
--- a/lambdamail.scm
+++ b/lambdamail.scm
@@ -2,7 +2,7 @@
 ;;
 ;; Intended for a single-user system 
 
-(import tcp6
+(import tcp6 openssl
         (chicken port)
         (chicken io)
         (chicken string)
@@ -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,15 @@
         (('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* #t in-port 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)))
@@ -118,7 +132,16 @@
                           "250-" (config-host config)
                           " Hello " (smtp-command-args "ehlo" line))
             (smtp-session 'send "250 AUTH PLAIN")
-            ;; (smtp-session 'send "250 STARTTLS")
+            (if (tls-supported? config)
+                (smtp-session 'send "250 STARTTLS"))
+            (loop mmsg received-messages))
+           ((smtp-command? "starttls" line)
+            (let ((args (smtp-command-args "starttls" line)))
+              (if (> 0 (string-length args))
+                  (smtp-session 'send "501 Syntax error (no parameters allowed)")
+                  (begin
+                    (smtp-session 'send "220 Ready to start TLS")
+                    (smtp-session 'starttls))))
             (loop mmsg received-messages))
            ((smtp-command? "auth plain" line)
             (let* ((auth-string (smtp-command-args "auth plain" line))
@@ -354,17 +377,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))))
@@ -380,6 +406,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))