X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=lambdamail.scm;h=73d57733467296cfff0ecb8caf17cbd8973188f5;hb=719132bb87f80e5d9814c1360a4b4f19ba16744e;hp=d185d89afae3e98c889572b4a1ee9078b2f71dfb;hpb=e0ad9e48e55d6f46293f2e043ebd527be802bcac;p=lambdamail.git diff --git a/lambdamail.scm b/lambdamail.scm index d185d89..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,18 +26,25 @@ ;;; SMTP transactions ;; -(define ((make-smtp in-port out-port config) type) - (if (eq? type 'get-line) - (read-line in-port) - (write-line (conc - (case type - ((greeting) (conc "220 " (config-host config) - " LambdaMail v" lambdamail-version)) - ((ok) "250 ok") - ((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 @@ -72,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.") @@ -85,46 +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) - (cond - ((string-prefix? "helo" line) - (message-helo-set! msg (string-drop line (string-length "helo"))) - (smtp 'ok) - (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 @@ -142,14 +160,6 @@ (right-idx (substring-index ">" addr))) (substring addr (+ left-idx 1) right-idx))) -(define (deliver-message-mbox msg dest-file) - (print "Delivering to mbox " dest-file) - (with-output-to-file dest-file - (lambda () - (print "\nFrom " (remove-angle-brackets (message-from msg))) - (print (message-text msg))) - #:append)) - (define (deliver-message-maildir msg dest-dir) (print "Delivering to maildir " dest-dir) (with-output-to-file (conc dest-dir "/" (current-seconds)) @@ -209,7 +219,7 @@ (unless (null? rest-args) (config-port-set! config (string->number (car rest-args))) (unless (null? (cdr rest-args)) - (config-spool-dir-set! (cadr rest-args)))) + (config-spool-dir-set! config (cadr rest-args)))) (run-server config)))))))) (main)