From: Tim Vaughan <tgvaughan@gmail.com>
Date: Wed, 4 Sep 2019 17:01:16 +0000 (+0200)
Subject: First successful remote delivery.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=lambdamail.git;a=commitdiff_plain;h=2d92632d54049b81988e5eabb849eaa4b2248830

First successful remote delivery.
---

diff --git a/lambdamail.scm b/lambdamail.scm
index e66e4de..683781e 100644
--- 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 (time-stamp)
+  (time->string (seconds->local-time "%d %b %Y %T %z")))
+
 
 ;;; 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)))
-        (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)
@@ -129,7 +132,10 @@
           (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)
@@ -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)
-    (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")
@@ -229,19 +235,25 @@
                        (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)))))
 
-(define ((make-outgoing-smtp-session tcp-in tcp-out) command)
+(define ((make-outgoing-smtp-session tcp-in tcp-out) . command)
   (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 ...)
-     (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
 ;;