From 935848622042a42de81bd89975bcaa99710ddb3d Mon Sep 17 00:00:00 2001 From: plugd Date: Tue, 20 Jul 2021 12:28:16 +0200 Subject: [PATCH] CC support working. --- lambdamail.scm | 109 ++++++++++++++++++++++++++++--------------------- 1 file changed, 63 insertions(+), 46 deletions(-) diff --git a/lambdamail.scm b/lambdamail.scm index 87dd145..9cc8f34 100644 --- a/lambdamail.scm +++ b/lambdamail.scm @@ -15,13 +15,12 @@ (chicken process-context posix) (chicken condition) (chicken sort) + (chicken random) srfi-1 srfi-13 matchable base64) (define lambdamail-version "LambdaMail v1.5.0") (define-record config host port spool-dir user group) -(define-record message to from text user password) -(define (make-empty-message) (make-message '() "" "" "" "")) (define (time-stamp) (time->string (seconds->local-time) "%d %b %Y %T %z")) @@ -57,6 +56,14 @@ (server-loop listener config (deliver-messages config messages)))) +;;; Messages +;; + +(define-record message to from text user password stamp) +(define-record multi-message tos from text user password stamps) +(define (make-empty-multi-message) (make-multi-message '() "" "" "" "" '())) + + ;;; Receiving messages ;; @@ -94,7 +101,7 @@ (define (process-smtp smtp-session config) (smtp-session 'send "220 " (config-host config) " " lambdamail-version) - (let loop ((msg (make-empty-message)) + (let loop ((mmsg (make-empty-multi-message)) (received-messages '())) (let ((line (smtp-session 'get-line))) (print "got " line) @@ -104,7 +111,7 @@ ((smtp-command? "helo" line) (smtp-session 'set-helo! (smtp-command-args "helo" line)) (smtp-session 'send "250 ok") - (loop msg received-messages)) + (loop mmsg received-messages)) ((smtp-command? "ehlo" line) (smtp-session 'set-helo! (smtp-command-args "helo" line)) (smtp-session 'send @@ -112,60 +119,69 @@ " Hello " (smtp-command-args "ehlo" line)) (smtp-session 'send "250 AUTH PLAIN") ;; (smtp-session 'send "250 STARTTLS") - (loop msg received-messages)) + (loop mmsg 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))) - (message-user-set! msg user) - (message-password-set! msg password) + (multi-message-user-set! mmsg user) + (multi-message-password-set! mmsg password) (print "Attempted login, user: " user ", password: " password) (smtp-session 'send "235 authentication successful") - (loop msg received-messages))) + (loop mmsg received-messages))) ((smtp-command? "mail from:" line) - (message-from-set! msg (smtp-command-args "mail from:" line)) + (multi-message-from-set! mmsg (smtp-command-args "mail from:" line)) (smtp-session 'send "250 ok") - (loop msg received-messages)) + (loop mmsg received-messages)) ((smtp-command? "rcpt to:" line) - (message-to-set! msg (cons (smtp-command-args "rcpt to:" line) - (message-to msg))) - (if (message-valid? msg config) - (smtp-session 'send "250 ok") - (smtp-session 'send "551 relay forbidden")) - (loop msg received-messages)) + (let* ((to (smtp-command-args "rcpt to:" line)) + (stamp (make-message-stamp to mmsg config))) + (print to) + (if (car stamp) + (begin + (multi-message-tos-set! mmsg (cons to (multi-message-tos mmsg))) + (multi-message-stamps-set! mmsg (cons stamp (multi-message-stamps mmsg))) + (smtp-session 'send "250 ok")) + (begin + (smtp-session 'send "551 relay forbidden")))) + (loop mmsg received-messages)) ((smtp-command? "data" line) (smtp-session 'send "354 intermediate") - (let text-loop ((text '())) + (let text-loop ((text "")) (let ((text-line (smtp-session 'get-line))) (if (string=? "." text-line) - (message-text-set! msg text) + (multi-message-text-set! mmsg text) (text-loop (conc text text-line "\n"))))) (smtp-session 'send "250 ok") - (loop (make-empty-message) (append (get-single-recipient-messages msg smtp-session) - received-messages))) + (loop (make-empty-multi-message) + (append (make-single-recipient-messages mmsg smtp-session config) + received-messages))) ((smtp-command? "quit" line) (smtp-session 'send "221 closing transmission channel") received-messages) ((string=? "" (string-trim line)) - (loop msg received-messages)) + (loop mmsg received-messages)) (else (smtp-session 'send "502 command not implemented") - (loop msg received-messages))))))) + (loop mmsg received-messages))))))) -(define (get-single-recipient-messages smtp-session msg) +(define (make-single-recipient-messages mmsg smtp-session config) (map - (lambda (to) - (make-message to (message-from msg) + (lambda (to stamp) + (print "making singleton messages: " to " " stamp) + (make-message to (multi-message-from mmsg) (conc "Received: from " (smtp-session 'helo) "\n" "\tby " (config-host config) "\n" "\tfor " to ";\n" "\t" (time-stamp) "\n" - (message-text msg)) - (message-user msg) - (message-password msg))) - (message-to msg))) + (multi-message-text mmsg)) + (multi-message-user mmsg) + (multi-message-password mmsg) + stamp)) + (multi-message-tos mmsg) + (multi-message-stamps mmsg))) ;;; Message stamping and validation @@ -184,32 +200,27 @@ (filter directory-exists? (glob (conc (config-spool-dir config) "/*")))))) -(define (message-stamp msg config) +(define (make-message-stamp to mmsg config) (let* ((local-addresses (get-local-addresses config)) - (local-dest (assoc (message-to msg) local-addresses)) - (local-src (assoc (message-from msg) local-addresses))) + (local-dest (assoc to local-addresses)) + (local-src (assoc (multi-message-from mmsg) local-addresses))) (cond (local-dest (list #t 'local (cadr local-dest))) (local-src - (let ((password (caddr local-src))) - (if (and (string=? (conc "<" (message-user msg) "@" (config-host config) ">") - (message-from msg)) - password - (string=? (message-password msg) password)) + (let ((host-password (caddr local-src))) + (if (and (string=? (conc "<" (multi-message-user mmsg) "@" (config-host config) ">") + (multi-message-from mmsg)) + host-password + (string=? (multi-message-password mmsg) host-password)) (list #t 'remote) (begin - (print "Provided password " (message-password msg)) - (print "Host password " password) + (print "Provided password " (multi-message-password mmsg)) + (print "Host password " host-password) (list #f 'remote))))) (else (list #f 'relay))))) -(define (message-valid? msg config) - (let ((stamp (message-stamp msg config))) - (print "Stamp: " stamp) - (car stamp))) - ;;; Sending/Delivering messages ;; @@ -223,7 +234,7 @@ (print "From: " (message-from msg)) (print "To: " (message-to msg)) (condition-case - (match (message-stamp msg config) + (match (message-stamp msg) ((#t 'local dest-dir) (deliver-message-local msg dest-dir)) ((#t 'remote) (deliver-message-remote msg config)) ((#f 'remote) @@ -239,8 +250,14 @@ ;; Local delivery +(define unique-file-name + (let ((counter 0)) + (lambda () + (set! counter (modulo (+ counter 1) 1000)) + (conc (current-seconds) "_" counter)))) + (define (deliver-message-local msg dest-dir) - (with-output-to-file (conc dest-dir "/" (current-seconds)) + (with-output-to-file (conc dest-dir "/" (unique-file-name)) (lambda () (print (message-text msg)))) (print "* MESSAGE DELIVERED (local)") -- 2.20.1