The Lambda Lab
/
projects
/
lambdamail.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
2d92632
)
Added received header to mail on receipt.
author
Tim Vaughan
<tgvaughan@gmail.com>
Wed, 4 Sep 2019 17:30:36 +0000
(19:30 +0200)
committer
Tim Vaughan
<tgvaughan@gmail.com>
Wed, 4 Sep 2019 17:30:36 +0000
(19:30 +0200)
lambdamail.scm
patch
|
blob
|
history
diff --git
a/lambdamail.scm
b/lambdamail.scm
index
683781e
..
ddbce66
100644
(file)
--- a/
lambdamail.scm
+++ b/
lambdamail.scm
@@
-23,7
+23,7
@@
(define (make-empty-message) (make-message "" "" "" "" ""))
(define (time-stamp)
(define (make-empty-message) (make-message "" "" "" "" ""))
(define (time-stamp)
- (time->string (seconds->local-time
"%d %b %Y %T %z")
))
+ (time->string (seconds->local-time
) "%d %b %Y %T %z"
))
;;; Server initialization
;;; Server initialization
@@
-75,15
+75,18
@@
(define (make-smtp-session in-port out-port config)
(let ((user "")
(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))
(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)
(('user) user)
- (('password) password)))))
+ (('password) password)
+ (('helo) helo)))))
(define (smtp-command? cmd-string input-string)
(string-prefix? cmd-string (string-downcase input-string)))
(define (smtp-command? cmd-string input-string)
(string-prefix? cmd-string (string-downcase input-string)))
@@
-102,9
+105,11
@@
(print "got " line)
(cond
((smtp-command? "helo" line)
(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 '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))
(smtp-session 'send
"250-" (config-host config)
" Hello " (smtp-command-args "ehlo" line))
@@
-132,10
+137,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 (conc "Received: from " (smtp-session 'helo)
- "
by " (config-host)
- " for " (message-from msg)
- "; " (time-stamp))))
+ (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)
(let ((text-line (smtp-session 'get-line)))
(if (string=? "." text-line)
(message-text-set! msg text)
@@
-158,7
+163,8
@@
;;
(define (deliver-messages config messages)
;;
(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))
(filter (lambda (msg) (not (deliver-message msg config)))
messages))
@@
-222,7
+228,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
25
)))
+ (let-values (((tcp-in tcp-out) (tcp-connect host 25)))
(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")
@@
-249,7
+255,9
@@
(print "Expecting " code " got " result)
(string-prefix? code result)))
(('send strings ...)
(print "Expecting " code " got " result)
(string-prefix? code result)))
(('send strings ...)
- (print "Sending " (car strings) (if (> (length strings) 1) " ... (truncated)" ""))
+ (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")))))
(let ((processed-string
(string-translate* (conc (apply conc strings) "\n")
'(("\n" . "\r\n")))))