From 7a549912120c4d074b3e990faef04bd3249ff53a Mon Sep 17 00:00:00 2001 From: sperber Date: Mon, 2 Sep 2002 08:21:44 +0000 Subject: [PATCH] Trivially convert the macros to procedures. Fix a bunch of bugs where a transaction would be closed prematurely and/or repeatedly. --- scheme/lib/smtp.scm | 204 ++++++++++++++++++-------------------------- 1 file changed, 83 insertions(+), 121 deletions(-) diff --git a/scheme/lib/smtp.scm b/scheme/lib/smtp.scm index 20a7b40..5afa711 100644 --- a/scheme/lib/smtp.scm +++ b/scheme/lib/smtp.scm @@ -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: (define smtp/send (unary-smtp-command "SEND FROM:")) @@ -301,8 +263,8 @@ ;; HELP
(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: