First successful remote delivery.

diff --git a/lambdamail.scm b/lambdamail.scm
index e66e4de..683781e 100644 (file)
--- a/lambdamail.scm
+++ b/lambdamail.scm
@@ -22,6 +22,9 @@
 (define-record message to from text user password)
 (define (make-empty-message) (make-message "" "" "" "" ""))
 
 (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")))
+

 
 ;;; Server initialization
 ;;
 
 ;;; Server initialization
 ;;


@@ -60,7 +63,7 @@
   (let ((messages '()))
     (let-values (((in-port out-port) (tcp-accept listener)))
       (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
   (let ((messages '()))
     (let-values (((in-port out-port) (tcp-accept listener)))
       (let-values (((local-ip remote-ip) (tcp-addresses in-port)))

-        (print "Accepted connection from " remote-ip " on " (seconds->string)))
+        (print "Accepted connection from " remote-ip " on " (time-stamp)))

       (condition-case
           (set! messages (process-smtp (make-smtp-session in-port out-port config) config))
         (o (exn)
       (condition-case
           (set! messages (process-smtp (make-smtp-session in-port out-port config) config))
         (o (exn)


@@ -129,7 +132,10 @@
           (loop msg received-messages))
          ((smtp-command? "data" line)
           (smtp-session 'send "354 intermediate")
           (loop msg received-messages))
          ((smtp-command? "data" line)
           (smtp-session 'send "354 intermediate")

-          (let text-loop ((text ""))
+          (let text-loop ((text (conc "Received: from " (smtp-session 'helo)
+                                      " by " (config-host)
+                                      " for " (message-from msg)
+                                      "; " (time-stamp))))

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


@@ -216,7 +222,7 @@
 (define (deliver-message-remote msg config)
   (let ((host (get-host-from-email (message-to msg))))
     (print "Attempting delivery to host " host)
 (define (deliver-message-remote msg config)
   (let ((host (get-host-from-email (message-to msg))))
     (print "Attempting delivery to host " host)

-    (let-values (((tcp-in tcp-out) (tcp-connect host 25)))
+    (let-values (((tcp-in tcp-out) (tcp-connect host 2525)))

       (let ((smtp-session (make-outgoing-smtp-session tcp-in tcp-out)))
         (let ((result (and
                        (smtp-session 'expect "220")
       (let ((smtp-session (make-outgoing-smtp-session tcp-in tcp-out)))
         (let ((result (and
                        (smtp-session 'expect "220")


@@ -229,19 +235,25 @@
                        (smtp-session 'send "data")
                        (smtp-session 'expect "354")
                        (smtp-session 'send (message-text msg))
                        (smtp-session 'send "data")
                        (smtp-session 'expect "354")
                        (smtp-session 'send (message-text msg))

+                       (smtp-session 'send ".")

                        (smtp-session 'expect "250")
                        (smtp-session 'send "quit"))))
           (close-input-port tcp-in)
           (close-output-port tcp-out)
           result)))))
 
                        (smtp-session 'expect "250")
                        (smtp-session 'send "quit"))))
           (close-input-port tcp-in)
           (close-output-port tcp-out)
           result)))))
 

-(define ((make-outgoing-smtp-session tcp-in tcp-out) command)
+(define ((make-outgoing-smtp-session tcp-in tcp-out) . command)

   (match command
     (('expect code)
   (match command
     (('expect code)

-     (string-prefix? "220" (read-line tcp-in)))
+     (let ((result (read-line tcp-in)))
+       (print "Expecting " code " got " result)
+       (string-prefix? code result)))

     (('send strings ...)
     (('send strings ...)

-     (write-string (string-translate (conc (apply conc strings) "\n") "\n" "\r\n")
-                   out-port))))
+     (print "Sending " (car strings) (if (> (length strings) 1) " ... (truncated)" ""))
+     (let ((processed-string
+            (string-translate* (conc (apply conc strings) "\n")
+                               '(("\n" . "\r\n")))))
+       (write-string processed-string #f tcp-out)))))

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