From 719132bb87f80e5d9814c1360a4b4f19ba16744e Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Tue, 3 Sep 2019 10:06:42 +0200 Subject: [PATCH] AUTH PLAIN implementation finished. --- lambdamail.scm | 141 +++++++++++++++++++++++++++---------------------- 1 file changed, 77 insertions(+), 64 deletions(-) diff --git a/lambdamail.scm b/lambdamail.scm index 1e9fb4d..73d5773 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -14,13 +14,11 @@ (chicken process-context) (chicken process-context posix) (chicken condition) - srfi-1 srfi-13 matchable) + srfi-1 srfi-13 matchable base64) (define lambdamail-version "0.0.1") - -(define-record config - host port spool-dir user group) +(define-record config host port spool-dir user group) (define-record message to from text helo) (define (make-empty-message) (make-message "" "" "" "")) @@ -28,20 +26,25 @@ ;;; SMTP transactions ;; -(define ((make-smtp in-port out-port config) . msg) - (if (equal? msg '(get-line)) - (read-line in-port) - (write-line (conc - (match msg - (('greeting) (conc "220 " (config-host config) - " LambdaMail v" lambdamail-version)) - (('ok) "250 ok") - (('ehlo host) (conc "250-" (config-host config) " Hello " host "\r\n" - "250 AUTH PLAIN")) - (('intermediate) "354 intermediate") - (('close) "221 closing transmission channel") - (('not-implemented) "502 command not implemented")) - "\r") out-port))) +(define (make-smtp-session in-port out-port config) + (let ((smtp-say (lambda args (write-line (conc (apply conc args) "\r") out-port))) + (user "") + (password "")) + (lambda msg + (match msg + (('get-line) (read-line in-port)) + (('set-user! u) (set! user u)) + (('set-password! p) (set! password p)) + (('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")))))) ;;; Server initialization @@ -74,9 +77,9 @@ (let-values (((local-ip remote-ip) (tcp-addresses in-port))) (print "Accepted connection from " remote-ip " on " (seconds->string))) (condition-case - (let ((smtp (make-smtp in-port out-port config))) - (smtp 'greeting) - (process-smtp smtp config)) + (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.") @@ -87,49 +90,59 @@ ;;; SMTP processing loop ;; -(define (process-smtp smtp config) - (let loop ((msg (make-empty-message)) - (line-orig (smtp '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 'ok) - (loop msg (smtp 'get-line))) - ((string-prefix? "ehlo" line) - (smtp 'ehlo (string-drop line (+ 1 (string-length "ehlo")))) - (loop msg (smtp 'get-line))) - ((string-prefix? "mail from:" line) - (message-from-set! msg (string-drop line (string-length "mail from:"))) - (smtp 'ok) - (loop msg (smtp 'get-line))) - ((string-prefix? "rcpt to:" line) - (message-to-set! msg (string-drop line (string-length "rcpt to:"))) - (smtp 'ok) - (loop msg (smtp 'get-line))) - ((string-prefix? "data" line) - (smtp 'intermediate) - (let text-loop ((text-line (smtp 'get-line)) - (text "")) - (if (string=? "." text-line) - (message-text-set! msg text) - (text-loop (smtp 'get-line) - (conc text text-line "\n")))) - (process-message msg config) - (smtp 'ok) - (loop (make-empty-message) - (smtp 'get-line))) - ((string-prefix? "quit" line) - (smtp 'close) - 'done) - ((string=? "" line) - (loop msg (smtp 'get-line))) - (else - (smtp 'not-implemented) - (loop msg (smtp 'get-line))))) - 'done))) +(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")))) + (process-message msg config) + (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 -- 2.20.1