From 1d04df7655dee7ebdd292a65ad399610b532e111 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Wed, 4 Sep 2019 11:40:47 +0200 Subject: [PATCH] Cleanup. --- lambdamail.scm | 196 +++++++++++++++++++++++++------------------------ 1 file changed, 99 insertions(+), 97 deletions(-) diff --git a/lambdamail.scm b/lambdamail.scm index 3f3594e..fe9519e 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -16,13 +16,11 @@ (chicken condition) srfi-1 srfi-13 matchable base64) -(define lambdamail-version "0.0.1") +(define lambdamail-version "LambdaMail v0.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 outbound-mail-queue '()) +(define-record message to from text user password) +(define (make-empty-message) (make-message "" "" "" "" "")) ;;; Server initialization @@ -39,121 +37,125 @@ (define (run-server config) (set-buffering-mode! (current-output-port) #:line) (let ((listener (tcp-listen (config-port config) 10 "::"))) - (print "LambdaMail v" lambdamail-version + (print lambdamail-version " 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))) + (server-loop listener config '()))) ;;; Main server loop ;; -(define (server-loop listener config) - (let-values (((in-port out-port) (tcp-accept listener))) - (let-values (((local-ip remote-ip) (tcp-addresses in-port))) - (print "Accepted connection from " remote-ip " on " (seconds->string))) - (condition-case - (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)) - (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 (server-loop listener config undelivered-messages) + (let* ((messages (append (receive-messages listener config) undelivered-messages))) + (server-loop listener config (deliver-messages config messages)))) + + +;;; Receiving messages ;; +(define (receive-messages listener config) + (let ((messages '())) + (let-values (((in-port out-port) (tcp-accept listener))) + (let-values (((local-ip remote-ip) (tcp-addresses in-port))) + (print "Accepted connection from " remote-ip " on " (seconds->string))) + (condition-case + (set! messages (process-smtp (make-smtp-session in-port out-port config) config)) + (o (exn) + (print-error-message o))) + (print "Terminating connection.") + (close-input-port in-port) + (close-output-port out-port)) + messages)) + (define (make-smtp-session in-port out-port config) - (let ((smtp-say (lambda args (write-line (conc (apply conc args) "\r") out-port))) - (user "") + (let ((user "") (password "")) (lambda msg (match msg (('get-line) (read-line in-port)) + (('send-line strings ...) (write-line (conc (apply conc strings) "\r") out-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")))))) + (('password) password))))) + +(define (smtp-command? cmd-string input-string) + (string-prefix? cmd-string (string-downcase input-string))) + +(define (smtp-command-args cmd-string input-string) + (if (> (string-length input-string) (string-length cmd-string)) + (string-trim (string-drop input-string (string-length cmd-string))) + "")) (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 + (smtp-session 'send-line "220 " (config-host config) lambdamail-version) + (let loop ((msg (make-empty-message)) + (received-messages '())) + (let ((line (smtp-session 'get-line))) + (when (string? line) + (print "got " line) + (cond + ((smtp-command? "helo" line) + (smtp-session 'send-line "250 ok") + (loop msg received-messages)) + ((smtp-command? "ehlo" line) + (smtp-session 'send-line + "250-" (config-host config) + " Hello " (smtp-command-args "ehlo" line)) + (smtp-session 'send-line "250 AUTH PLAIN") + ;; (smtp-session 'send-line "250 STARTTLS") + (loop msg received-messages)) + ((smtp-command? "auth plain" line) + (let* ((auth-string (smtp-command-args "auth plain" line)) + (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 'send-line "235 authentication successful") + (loop msg received-messages))) + ((smtp-command? "mail from:" line) + (message-from-set! msg (smtp-command-args "mail from:" line)) + (smtp-session 'send-line "250 ok") + (loop msg received-messages)) + ((smtp-command? "rcpt to:" line) + (message-to-set! msg (smtp-command-args "rcpt to:" line)) + (smtp-session 'send-line "250 ok") + (loop msg received-messages)) + ((smtp-command? "data" line) + (smtp-session 'send-line "354 intermediate") + (let text-loop ((text "")) + (let ((text-line (smtp-session 'get-line))) + (if (string=? "." text-line) + (message-text-set! msg text) + (text-loop (conc text text-line "\n"))))) + (message-user-set! msg (smtp-session 'user)) + (message-password-set! msg (smtp-session 'password)) + (smtp-session 'send-line "250 ok") + (loop (make-empty-message) (cons msg received-messages))) + ((smtp-command? "quit" line) + (smtp-session 'send-line "221 closing transmission channel") + received-messages) + ((string=? "" (string-trim line)) + (loop msg received-messages)) + (else + (smtp-session 'send-line "502 command not implemented") + (loop msg received-messages))))))) + + +;;; Delivering messages ;; +(define (deliver-messages config messages) + (print "Attempting delivery of " (length messages) " mail items.") + (filter (lambda (msg) (not (deliver-message msg config))) + messages)) + (define (get-to-addresses config) (map (lambda (p) (cons (conc "<" (car p) "@" (config-host config) ">") -- 2.20.1