Deferred mail delivery until after incomming SMTP transaction.

diff --git a/lambdamail.scm b/lambdamail.scm
index 73d5773..3f3594e 100644 (file)
--- a/lambdamail.scm
+++ b/lambdamail.scm
@@ -19,32 +19,10 @@
 (define lambdamail-version "0.0.1")
 
 (define-record config host port spool-dir user group)
 (define lambdamail-version "0.0.1")
 
 (define-record config host port spool-dir user group)

-(define-record message to from text helo)
-(define (make-empty-message) (make-message "" "" "" ""))
+(define-record message to from text helo user password)
+(define (make-empty-message) (make-message "" "" "" "" "" ""))

 
 

-
-;;; SMTP transactions
-;;
-
-(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"))))))
+(define outbound-mail-queue '())

 
 
 ;;; Server initialization
 
 
 ;;; Server initialization


@@ -84,12 +62,38 @@
          (print-error-message o)))
     (print "Terminating connection.")
     (close-input-port in-port)
          (print-error-message o)))
     (print "Terminating connection.")
     (close-input-port in-port)

-    (close-output-port out-port)
-    (server-loop listener config)))
+    (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
 ;;
 
 
 ;;; SMTP processing loop
 ;;
 

+(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))
+        (('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"))))))
+

 (define (process-smtp smtp-session config)
   (let loop ((msg (make-empty-message)))
     (let ((line-orig (smtp-session 'get-line)))
 (define (process-smtp smtp-session config)
   (let loop ((msg (make-empty-message)))
     (let ((line-orig (smtp-session 'get-line)))


@@ -131,7 +135,9 @@
                     (message-text-set! msg text)
                     (text-loop (smtp-session 'get-line)
                                (conc text text-line "\n"))))
                     (message-text-set! msg text)
                     (text-loop (smtp-session 'get-line)
                                (conc text text-line "\n"))))

-              (process-message msg config)
+              (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 'ok)
               (loop (make-empty-message)))
              ((string-prefix? "quit" line)


@@ -160,23 +166,23 @@
         (right-idx (substring-index ">" addr)))
     (substring addr (+ left-idx 1) right-idx)))
 
         (right-idx (substring-index ">" addr)))
     (substring addr (+ left-idx 1) right-idx)))
 

-(define (deliver-message-maildir msg dest-dir)
+(define (deliver-message-local msg dest-dir)

   (print "Delivering to maildir " dest-dir)
   (with-output-to-file (conc dest-dir "/" (current-seconds))
     (lambda ()
       (print (message-text msg)))))
 
   (print "Delivering to maildir " dest-dir)
   (with-output-to-file (conc dest-dir "/" (current-seconds))
     (lambda ()
       (print (message-text msg)))))
 

-(define (process-message msg config)
+(define (deliver-message msg config)

   (let ((dest (assoc (message-to msg) (get-to-addresses config))))
     (if dest
         (let ((dest-file (cdr dest)))
           (if (directory-exists? dest-file)
   (let ((dest (assoc (message-to msg) (get-to-addresses config))))
     (if dest
         (let ((dest-file (cdr dest)))
           (if (directory-exists? dest-file)

-              (deliver-message-maildir msg dest-file)
-              (deliver-message-mbox msg dest-file))
+              (deliver-message-local msg dest-file))

           (print "Message DELIVERED:"))
         (print "Message REJECTED:"))
     (print " * From: " (message-from msg))
           (print "Message DELIVERED:"))
         (print "Message REJECTED:"))
     (print " * From: " (message-from msg))

-    (print " * To: " (message-to msg))))
+    (print " * To: " (message-to msg)))
+  #t)

 
 
 ;;; Command line argument parsing
 
 
 ;;; Command line argument parsing