Almost ready for receive-only mode.

diff --git a/lambdamail.scm b/lambdamail.scm
index c47c145..1cfe6a0 100644 (file)
--- a/lambdamail.scm
+++ b/lambdamail.scm
@@ -78,32 +78,28 @@
              (line-orig (smtp 'get-line)))
     (if (string? line-orig)
         (let ((line (string-downcase line-orig)))
              (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")))
           (cond
            ((string-prefix? "helo" line)
             (message-helo-set! msg (string-drop line (string-length "helo")))

-            (print "got " line)

             (smtp 'ok)
             (loop msg (smtp 'get-line)))
            ((string-prefix? "mail from:" line)
             (smtp 'ok)
             (loop msg (smtp 'get-line)))
            ((string-prefix? "mail from:" line)

-            (print "got " 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-from-set! msg (string-drop line (string-length "mail from:")))
             (smtp 'ok)
             (loop msg (smtp 'get-line)))
            ((string-prefix? "rcpt to:" line)

-            (print "got " line)

             (message-to-set! msg (string-drop line (string-length "rcpt to:")))
             (smtp 'ok)
             (loop msg (smtp 'get-line)))
            ((string-prefix? "data" line)
             (message-to-set! msg (string-drop line (string-length "rcpt to:")))
             (smtp 'ok)
             (loop msg (smtp 'get-line)))
            ((string-prefix? "data" line)

-            (print "got " line)

             (smtp 'intermediate)
             (let text-loop ((text-line (smtp 'get-line))
                             (text ""))
             (smtp 'intermediate)
             (let text-loop ((text-line (smtp 'get-line))
                             (text ""))

-              (print "Received '" text-line "'")

               (if (string=? "." text-line)
                   (message-text-set! msg text)
                   (text-loop (smtp 'get-line)
               (if (string=? "." text-line)
                   (message-text-set! msg text)
                   (text-loop (smtp 'get-line)

-                             (conc text "\n" text-line))))
+                             (conc text text-line "\n"))))

             (deliver-message msg config)
             (smtp 'ok)
             (loop (make-empty-message)
             (deliver-message msg config)
             (smtp 'ok)
             (loop (make-empty-message)


@@ -115,7 +111,6 @@
             (loop msg (smtp 'get-line)))
            (else
             (smtp 'not-implemented)
             (loop msg (smtp 'get-line)))
            (else
             (smtp 'not-implemented)

-            (print "got " line)

             (loop msg (smtp 'get-line)))))
         'done)))
 
             (loop msg (smtp 'get-line)))))
         'done)))
 


@@ -123,11 +118,31 @@
 ;;; Message delivery
 ;;
 
 ;;; Message delivery
 ;;
 

+(define (get-to-addresses config)
+  (map (lambda (p) (cons
+                    (conc "<" (car p) "@" (config-host config) ">")
+                    (cdr p)))
+       (map (lambda (file) (cons (pathname-file file) file))
+            (glob (conc (config-spool-dir config) "/*")))))
+
+(define (remove-angle-brackets addr)
+  (let ((left-idx (substring-index "<" addr))
+        (right-idx (substring-index ">" addr)))
+    (substring addr (+ left-idx 1) right-idx)))
+

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

-  (print "Message delivered:")
-  (print " * From: " (message-from msg))
-  (print " * To: " (message-to msg))
-  (print " * Text: " (message-text msg)))
+  (let ((dest (assoc (message-to msg) (get-to-addresses config))))
+    (if dest
+        (begin
+          (with-output-to-file (cdr dest)
+            (lambda ()
+              (print "\nFrom " (remove-angle-brackets (message-from msg)))
+              (print (message-text msg)))
+            #:append)
+          (print "Message DELIVERED:"))
+        (print "Message REJECTED:"))
+    (print " * From: " (message-from msg))
+    (print " * To: " (message-to msg))))

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