Improved logging.

[lambdamail.git] / lambdamail.scm

diff --git a/lambdamail.scm b/lambdamail.scm
index e66e4de..92bbd12 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 (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)
@@ -72,15 +75,18 @@
 
 (define (make-smtp-session in-port out-port config)
   (let ((user "")
-        (password ""))
+        (password "")
+        (helo ""))
     (lambda command
       (match command
         (('get-line) (read-line in-port))
         (('send strings ...) (write-line (conc (apply conc strings) "\r") out-port))
         (('set-user! u) (set! user u))
         (('set-password! p) (set! password p))
+        (('set-helo! h) (set! helo h))
         (('user) user)
-        (('password) password)))))
+        (('password) password)
+        (('helo) helo)))))
 
 (define (smtp-command? cmd-string input-string)
   (string-prefix? cmd-string (string-downcase input-string)))
@@ -91,7 +97,7 @@
       ""))
 
 (define (process-smtp smtp-session config)
-  (smtp-session 'send "220 " (config-host config) lambdamail-version)
+  (smtp-session 'send "220 " (config-host config) " " lambdamail-version)
   (let loop ((msg (make-empty-message))
              (received-messages '()))
     (let ((line (smtp-session 'get-line)))
@@ -99,9 +105,11 @@
         (print "got " line)
         (cond
          ((smtp-command? "helo" line)
+          (smtp-session 'set-helo! (smtp-command-args "helo" line))
           (smtp-session 'send "250 ok")
           (loop msg received-messages))
          ((smtp-command? "ehlo" line)
+          (smtp-session 'set-helo! (smtp-command-args "helo" line))
           (smtp-session 'send
                         "250-" (config-host config)
                         " Hello " (smtp-command-args "ehlo" line))
@@ -129,7 +137,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) "\n"
+                                      "   by " (config-host config) "\n"
+                                      "   for " (message-from msg)
+                                      "; " (time-stamp) "\n")))
             (let ((text-line (smtp-session 'get-line)))
               (if (string=? "." text-line)
                   (message-text-set! msg text)
@@ -152,7 +163,8 @@
 ;;
 
 (define (deliver-messages config messages)
-  (print "Attempting delivery of " (length messages) " mail items.")
+  (print "\n"
+         "**** Attempting delivery of " (length messages) " mail items.")
   (filter (lambda (msg) (not (deliver-message msg config)))
           messages))
 
@@ -177,9 +189,9 @@
                   (begin
                     (deliver-message-remote msg config)
                     (print "Message DELIVERED (remote):"))
-                  (print "Message DELIVERY REJECTED (auth failure):"))))
+                  (print "Message REMOTE DELIVERY REJECTED (auth failure):"))))
            (else
-            (print "Message DELIVERY REJECTED (relay forbidden):"))))
+            (print "Message REMOTE DELIVERY REJECTED (relay forbidden):"))))
         (print " * From: " (message-from msg))
         (print " * To: " (message-to msg))
         #t)
@@ -229,19 +241,27 @@
                        (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 " (if (> (string-length (car strings)) 30)
+                           (string-take (car strings) 30)
+                           (car strings)))
+     (let ((processed-string
+            (string-translate* (conc (apply conc strings) "\n")
+                               '(("\n" . "\r\n")))))
+       (write-string processed-string #f tcp-out)))))
 
 ;;; Command line argument parsing
 ;;