Trivially convert the macros to procedures.
Fix a bunch of bugs where a transaction would be closed prematurely and/or repeatedly.
This commit is contained in:
sperber
parent
9602104a8c
commit
7a54991212
|
|
@ -52,27 +52,27 @@
|
|||
(lambda (bailout)
|
||||
(let ((local (host-info:name (host-info (system-name))))
|
||||
(socket (smtp/open (:optional maybe-host "localhost"))))
|
||||
(receive (code text) (smtp-transactions socket ; Do prologue.
|
||||
(smtp/helo socket local)
|
||||
(smtp/mail socket (string-append (user-login-name)
|
||||
"@" local)))
|
||||
(if (>= code 400) (values code text) ; error
|
||||
|
||||
(receive (code text)
|
||||
(smtp-transactions/no-close socket ; Do prologue.
|
||||
(smtp/helo local)
|
||||
(smtp/mail (string-append (user-login-name)
|
||||
"@" local)))
|
||||
(if (>= code 400)
|
||||
(values code text) ; error
|
||||
;; Send over recipients and collect the losers.
|
||||
(let ((losers (filter-map
|
||||
(lambda (to)
|
||||
(receive (code text) (smtp/rcpt socket to)
|
||||
(and (>= code 400) ; Error
|
||||
(cond ((>= code 600)
|
||||
(smtp/quit socket)
|
||||
(bailout code text))
|
||||
(else `(,to ,code ,@text))))))
|
||||
to-list)))
|
||||
(lambda (to)
|
||||
(receive (code text) (smtp/rcpt socket to)
|
||||
(and (>= code 400) ; Error
|
||||
(cond ((>= code 600)
|
||||
(smtp/quit socket)
|
||||
(bailout code text))
|
||||
(else `(,to ,code ,@text))))))
|
||||
to-list)))
|
||||
|
||||
;; Send the message body and wrap things up.
|
||||
(receive (code text) (smtp-transactions socket
|
||||
(smtp/data socket body)
|
||||
(smtp/quit socket))
|
||||
(smtp/data body))
|
||||
(if (and (< code 400) (null? losers))
|
||||
(values code text)
|
||||
(values 700 losers))))))))))
|
||||
|
|
@ -90,11 +90,10 @@
|
|||
(define (%sendmail from local-host to dest-host message)
|
||||
(let ((socket (smtp/open dest-host)))
|
||||
(smtp-transactions socket
|
||||
(smtp/helo socket local-host)
|
||||
(smtp/mail socket from)
|
||||
(smtp/rcpt socket to)
|
||||
(smtp/data socket message)
|
||||
(smtp/quit socket))))
|
||||
(smtp/helo local-host)
|
||||
(smtp/mail from)
|
||||
(smtp/rcpt to)
|
||||
(smtp/data message))))
|
||||
|
||||
|
||||
;;; EXPN, VRFY, MAIL-HELP
|
||||
|
|
@ -103,12 +102,10 @@
|
|||
|
||||
(define (smtp-query socket query arg)
|
||||
(receive (code text)
|
||||
(smtp-transactions socket
|
||||
(smtp/helo socket (system-name))
|
||||
(query socket arg))
|
||||
(if (not (or (= code 421) (= code 221)))
|
||||
(smtp/quit socket))
|
||||
(values code text)))
|
||||
(smtp-transactions socket
|
||||
(smtp/helo (system-name))
|
||||
(query arg))
|
||||
(values code text)))
|
||||
|
||||
(define (expn name host)
|
||||
(smtp-query (smtp/open host) smtp/expn name))
|
||||
|
|
@ -120,10 +117,10 @@
|
|||
(smtp-query (smtp/open host) smtp/help (apply string-append (cons " " details))))
|
||||
|
||||
|
||||
;;; (smtp-transactions socket ?transaction1 ...)
|
||||
;;; (smtp-transactions/no-close socket ?transaction1 ...)
|
||||
;;; (smtp-transactions socket transaction1 ...)
|
||||
;;; (smtp-transactions/no-close socket transaction1 ...)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; These macros make it easy to do simple sequences of SMTP commands.
|
||||
;;; These procedures make it easy to do simple sequences of SMTP commands.
|
||||
;;;
|
||||
;;; Evaluate a series of expressions ?transaction1, ?transaction2, ...
|
||||
;;; - Each expression should perform an SMTP transaction,
|
||||
|
|
@ -147,9 +144,7 @@
|
|||
;;; - Otherwise, we throw away the current CODE and TEXT values, and
|
||||
;;; proceed to the next transaction.
|
||||
;;;
|
||||
;;; Since SMTP-TRANSACTIONS closes the socket whenever it aborts a sequence,
|
||||
;;; an SMTP-TRANSACTIONS form terminated with an (smtp/quit socket) transaction
|
||||
;;; will always close the socket.
|
||||
;;; SMTP-TRANSACTIONS closes the socket after the transaction.
|
||||
;;;
|
||||
;;; If the socket should be kept open in the case of an abort, use
|
||||
;;; SMTP-TRANSACTIONS/NO-CLOSE.
|
||||
|
|
@ -160,59 +155,25 @@
|
|||
;;; than proceeding to mail the other four. This may not be what you want;
|
||||
;;; if so, you'll have to roll your own.
|
||||
|
||||
(define-syntax smtp-transactions
|
||||
(syntax-rules ()
|
||||
((smtp-transactions socket ?T1 ?T2 ...)
|
||||
(let ((s socket))
|
||||
(receive (code text) (smtp-transactions/no-close s ?T1 ?T2 ...)
|
||||
(if (<= 400 code) (smtp/quit s))
|
||||
(values code text))))))
|
||||
|
||||
(define-syntax smtp-transactions/no-close
|
||||
(syntax-rules ()
|
||||
((smtp-transactions/no-close socket ?T1 ?T2 ...)
|
||||
;; %smtp-transactions/no-close replicates the socket argument,
|
||||
;; so we have to force it to be a variable.
|
||||
(let ((s socket))
|
||||
(%smtp-transactions/no-close s ?T1 ?T2 ...)))))
|
||||
|
||||
;;; SOCKET must be a variable, hence replicable.
|
||||
(define-syntax %smtp-transactions/no-close
|
||||
(syntax-rules ()
|
||||
((%smtp-transactions/no-close socket ?T1 ?T2 ?T3 ...)
|
||||
(receive (code text) ?T1
|
||||
(if (or (= code 221)
|
||||
(= code 421) ; Redundant, I know.
|
||||
(<= 400 code))
|
||||
(values code text)
|
||||
(%smtp-transactions/no-close socket ?T2 ?T3 ...))))
|
||||
|
||||
((%smtp-transactions/no-close socket ?T1)
|
||||
?T1)))
|
||||
|
||||
;;; I can't make this nested definition work. I'm not enough of a macro stud.
|
||||
;(define-syntax smtp-transactions/no-close
|
||||
; (syntax-rules ()
|
||||
; ((smtp-transactions/no-close socket ?T1 ...)
|
||||
; (letrec-syntax ((%smtp-transactions/no-close
|
||||
; (syntax-rules ()
|
||||
;
|
||||
; ((%smtp-transactions/no-close socket ?T1 ?T2 ...)
|
||||
; (receive (code text) ?T1
|
||||
; (if (or (= code 221)
|
||||
; (= code 421) ; Redundant, I know.
|
||||
; (<= 400 code))
|
||||
; (values code text)
|
||||
; (%smtp-transactions/no-close socket ?T2 ...))))
|
||||
;
|
||||
; ((%smtp-transactions/no-close socket ?T1)
|
||||
; ?T1))))
|
||||
;
|
||||
; ;; %smtp-transactions/no-close replicates the socket argument,
|
||||
; ;; so we have to force it to be a variable.
|
||||
; (let ((s socket))
|
||||
; (%smtp-transactions/no-close s ?T1 ...))))))
|
||||
(define (smtp-transactions socket . transactions)
|
||||
(receive (code text) (apply smtp-transactions/no-close socket transactions)
|
||||
(cond
|
||||
((or (= code 221)
|
||||
(= code 421))
|
||||
(values))
|
||||
(else
|
||||
(smtp/quit socket)))
|
||||
(values code text)))
|
||||
|
||||
(define (smtp-transactions/no-close socket . transactions)
|
||||
(let loop ((transactions transactions))
|
||||
(receive (code text) ((car transactions) socket)
|
||||
(if (or (null? (cdr transactions))
|
||||
(= code 221)
|
||||
(= code 421) ; Redundant, I know.
|
||||
(<= 400 code))
|
||||
(values code text)
|
||||
(loop (cdr transactions))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; The basics of the protocol
|
||||
|
|
@ -220,19 +181,19 @@
|
|||
(define (nullary-smtp-command command)
|
||||
(lambda (socket)
|
||||
(let ((port (socket:outport socket)))
|
||||
(write-string command port)
|
||||
(write-crlf port))
|
||||
(write-string command port)
|
||||
(write-crlf port))
|
||||
(handle-smtp-reply socket)))
|
||||
|
||||
|
||||
(define (unary-smtp-command command)
|
||||
(lambda (socket data)
|
||||
(let ((port (socket:outport socket)))
|
||||
(write-string command port)
|
||||
(display #\space port)
|
||||
(write-string data port)
|
||||
(write-crlf port))
|
||||
(handle-smtp-reply socket)))
|
||||
(lambda (data)
|
||||
(lambda (socket)
|
||||
(let ((port (socket:outport socket)))
|
||||
(write-string command port)
|
||||
(display #\space port)
|
||||
(write-string data port)
|
||||
(write-crlf port))
|
||||
(handle-smtp-reply socket))))
|
||||
|
||||
|
||||
(define (smtp/open host . maybe-port)
|
||||
|
|
@ -254,31 +215,32 @@
|
|||
;; DATA
|
||||
(define smtp/data
|
||||
(let ((send-DATA-msg (nullary-smtp-command "DATA")))
|
||||
(lambda (socket message) ; MESSAGE is a string or an input port.
|
||||
(receive (code text) (send-DATA-msg socket)
|
||||
(if (>= code 400) (values code text) ; Error.
|
||||
(lambda (message) ; MESSAGE is a string or an input port.
|
||||
(lambda (socket)
|
||||
(receive (code text) (send-DATA-msg socket)
|
||||
(if (>= code 400) (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)))
|
||||
;; 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)))
|
||||
|
||||
((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)))))))
|
||||
((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)))))))
|
||||
|
||||
(else (error "Message must be string or input-port.")))
|
||||
(else (error "Message must be string or input-port.")))
|
||||
|
||||
(write-string "\r\n.\r\n" p)
|
||||
(force-output p)
|
||||
(handle-smtp-reply socket)))))))
|
||||
(write-string "\r\n.\r\n" p)
|
||||
(force-output p)
|
||||
(handle-smtp-reply socket))))))))
|
||||
|
||||
;; SEND FROM: <sender-address>
|
||||
(define smtp/send (unary-smtp-command "SEND FROM:"))
|
||||
|
|
@ -301,8 +263,8 @@
|
|||
;; HELP <details>
|
||||
(define smtp/help
|
||||
(let ((send-help (unary-smtp-command "HELP")))
|
||||
(lambda (socket . details)
|
||||
(send-help socket (apply string-append details)))))
|
||||
(lambda details
|
||||
(send-help (apply string-append details)))))
|
||||
|
||||
;; NOOP
|
||||
(define smtp/noop (nullary-smtp-command "NOOP"))
|
||||
|
|
@ -311,10 +273,10 @@
|
|||
(define smtp/quit
|
||||
(let ((quit (nullary-smtp-command "QUIT")))
|
||||
(lambda (socket)
|
||||
(receive (code text) (quit socket) ; Quit & close socket gracefully.
|
||||
(receive (code text) (quit socket) ; Quit & close socket gracefully.
|
||||
(case code
|
||||
((221 421))
|
||||
(else (close-socket socket))) ; But close in any event.
|
||||
(else (close-socket socket))) ; But close in any event.
|
||||
(values code text)))))
|
||||
|
||||
;; TURN
|
||||
|
|
@ -332,7 +294,7 @@
|
|||
(define (handle-smtp-reply socket)
|
||||
(receive (code text) (read-smtp-reply (socket:inport socket))
|
||||
(case code
|
||||
((221 421) (close-socket socket))) ; All done.
|
||||
((221 421) (close-socket socket))) ; All done.
|
||||
(values code text)))
|
||||
|
||||
;;; Read a reply from the SMTP server. Returns two values:
|
||||
|
|
|
|||
Loading…
Reference in New Issue