CC support working.

diff --git a/lambdamail.scm b/lambdamail.scm
index 87dd145..9cc8f34 100644 (file)
--- 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)")