From: plugd Date: Thu, 3 Nov 2022 15:09:50 +0000 (+0100) Subject: Implemented, but bug in openssl call somewhere. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=lambdamail.git;a=commitdiff_plain;h=30557e12acee2628600c09b2020a93913356affc Implemented, but bug in openssl call somewhere. --- diff --git a/README b/README index 3521943..3c04fd7 100644 --- 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 --- 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))