Make SEND-MAIL-VIA-SMTP accept a headers argument.

This commit is contained in:
sperber 2002-09-02 09:02:14 +00:00
parent 1b0bce77e6
commit 0fa5f630e3
1 changed files with 31 additions and 60 deletions

View File

@ -34,7 +34,7 @@
;;; [Andreas:] I've inserted a way to do this. It works fine on my
;;; system. Does it work on your, too?
;;; (send-mail-via-smtp from to-list body [host])
;;; (send-mail-via-smtp from to-list headers body [host])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Mail message to recipients in list TO-LIST. Message handed off to server
;;; running on HOST; default is the local host. Returns two values: code and
@ -45,9 +45,9 @@
;;; that is, for each recipient refused by the server, you get the error
;;; data sent back for that guy. The success check is (< code 400).
;;;
;;; BODY is a string or an input port.
;;; BODY is a list of strings or an input port.
(define (send-mail-via-smtp from to-list body . maybe-host)
(define (send-mail-via-smtp from to-list headers body . maybe-host)
(call-with-current-continuation
(lambda (bailout)
(let ((local (host-info:name (host-info (system-name))))
@ -71,7 +71,7 @@
;; Send the message body and wrap things up.
(receive (code text) (smtp-transactions socket
(smtp/data body))
(smtp/data headers body))
(if (and (< code 400) (null? losers))
(values code text)
(values 700 losers))))))))))
@ -196,27 +196,35 @@
;; DATA
(define smtp/data
(let ((send-DATA-msg (nullary-smtp-command "DATA")))
(lambda (message) ; MESSAGE is a string or an input port.
(lambda (headers message) ; MESSAGE is a list of strings or an input port.
(lambda (socket)
(receive (code text) (send-DATA-msg socket)
(if (>= code 400)
(values code text) ; Error.
(values code text) ; Error.
;; We got a positive acknowledgement for the DATA msg,
;; now send the message body.
(let ((p (socket:outport socket)))
(cond ((string? message)
(receive (data last-char) (smtp-stuff message #f)
(write-string data p)))
(for-each (lambda (pair)
(display (car pair) p)
(write-char #\: p)
(display (cdr pair) p)
(write-crlf p))
headers)
(write-crlf p)
(cond ((or (null? message) (pair? message))
(for-each (lambda (line)
(write-data-line line p))
message))
((input-port? message)
(let lp ((last-char #f))
(cond ((read-string/partial 1024 message) =>
(lambda (chunk)
(receive (data last-char)
(smtp-stuff chunk last-char)
(write-string data p)
(lp last-char)))))))
(let lp ()
(let ((stuff (read-line message)))
(if (not (eof-object? stuff))
(begin
(write-data-line stuff p)
(newline))))))
(else (error "Message must be string or input-port.")))
@ -226,6 +234,13 @@
(force-output p)
(handle-smtp-reply socket))))))))
(define (write-data-line line port)
(display (if (string=? line ".")
".."
line)
port)
(write-crlf port))
;; SEND FROM: <sender-address>
(define smtp/send (unary-smtp-command "SEND FROM:"))
@ -327,50 +342,6 @@
(string-append "Improperly-formatted smtp reply: " line)
#f)))
;;; The message body of a piece of email is terminated by the sequence
;;; <crlf> <period> <crlf>
;;; If the message body contains this magic sequence, it has to be escaped.
;;; We do this by mapping the sequence <lf> <period> to <lf> <period> <period>;
;;; the SMTP receiver undoes this mapping.
;;; S is a string to stuff, PCHAR was the character read just before S
;;; (which matters if it is a line-feed). If S is the first chunk of the entire
;;; msg, then PCHAR can be #f. Return two values: the stuffed string, and the
;;; last char in S (or PCHAR if S is empty). The last-char value returned can
;;; be used as the PCHAR arg for the following call to SMTP-STUFF.
(define (smtp-stuff s pchar)
(let* ((slen (string-length s))
(hits ; Count up all the <lf> <period> seqs in the string.
(let lp ((count 0)
(nl? (eqv? pchar #\newline)) ; Was last char a newline?
(i 0))
(if (< i slen)
(let ((c (string-ref s i)))
(lp (if (and nl? (char=? c #\.)) (+ count 1) count)
(eq? c #\newline)
(+ i 1)))
count))))
(values (if (zero? hits)
s
;; Make a new string, and do the dot-stuffing copy.
(let ((ns (make-string (+ hits slen))))
(let lp ((nl? (eqv? pchar #\newline))
(i 0) ; S index.
(j 0)) ; NS index.
(if (< i slen)
(let ((c (string-ref s i)))
(string-set! ns j c)
(cond ((and nl? (char=? c #\.))
(string-set! ns (+ j 1) #\.)
(lp #f (+ i 1) (+ j 2)))
(else (lp (char=? c #\newline) (+ i 1) (+ j 1)))))))
ns))
(if (zero? slen) pchar (string-ref s (- slen 1)))))) ; LAST-CHAR
;;; Reply codes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This material taken from the RFC.