Make SEND-MAIL-VIA-SMTP accept a headers argument.
This commit is contained in:
parent
1b0bce77e6
commit
0fa5f630e3
|
@ -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.
|
||||
|
|
Loading…
Reference in New Issue