scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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 2002-09-02 08:21:44 +00:00
parent 9602104a8c
commit 7a54991212
1 changed files with 83 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

204
scheme/lib/smtp.scm
View File

@ -52,27 +52,27 @@
(lambda (bailout) (lambda (bailout)
(let ((local (host-info:name (host-info (system-name)))) (let ((local (host-info:name (host-info (system-name))))
(socket (smtp/open (:optional maybe-host "localhost")))) (socket (smtp/open (:optional maybe-host "localhost"))))
(receive (code text) (smtp-transactions socket ; Do prologue. (receive (code text)
(smtp/helo socket local) (smtp-transactions/no-close socket ; Do prologue.
(smtp/mail socket (string-append (user-login-name) (smtp/helo local)
"@" local))) (smtp/mail (string-append (user-login-name)
(if (>= code 400) (values code text) ; error "@" local)))
(if (>= code 400)
(values code text) ; error
;; Send over recipients and collect the losers. ;; Send over recipients and collect the losers.
(let ((losers (filter-map (let ((losers (filter-map
(lambda (to) (lambda (to)
(receive (code text) (smtp/rcpt socket to) (receive (code text) (smtp/rcpt socket to)
(and (>= code 400) ; Error (and (>= code 400) ; Error
(cond ((>= code 600) (cond ((>= code 600)
(smtp/quit socket) (smtp/quit socket)
(bailout code text)) (bailout code text))
(else `(,to ,code ,@text)))))) (else `(,to ,code ,@text))))))
to-list))) to-list)))
;; Send the message body and wrap things up. ;; Send the message body and wrap things up.
(receive (code text) (smtp-transactions socket (receive (code text) (smtp-transactions socket
(smtp/data socket body) (smtp/data body))
(smtp/quit socket))
(if (and (< code 400) (null? losers)) (if (and (< code 400) (null? losers))
(values code text) (values code text)
(values 700 losers)))))))))) (values 700 losers))))))))))
@ -90,11 +90,10 @@
(define (%sendmail from local-host to dest-host message) (define (%sendmail from local-host to dest-host message)
(let ((socket (smtp/open dest-host))) (let ((socket (smtp/open dest-host)))
(smtp-transactions socket (smtp-transactions socket
(smtp/helo socket local-host) (smtp/helo local-host)
(smtp/mail socket from) (smtp/mail from)
(smtp/rcpt socket to) (smtp/rcpt to)
(smtp/data socket message) (smtp/data message))))
(smtp/quit socket))))
;;; EXPN, VRFY, MAIL-HELP ;;; EXPN, VRFY, MAIL-HELP
@ -103,12 +102,10 @@
(define (smtp-query socket query arg) (define (smtp-query socket query arg)
(receive (code text) (receive (code text)
(smtp-transactions socket (smtp-transactions socket
(smtp/helo socket (system-name)) (smtp/helo (system-name))
(query socket arg)) (query arg))
(if (not (or (= code 421) (= code 221))) (values code text)))
(smtp/quit socket))
(values code text)))
(define (expn name host) (define (expn name host)
(smtp-query (smtp/open host) smtp/expn name)) (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-query (smtp/open host) smtp/help (apply string-append (cons " " details))))
;;; (smtp-transactions socket ?transaction1 ...) ;;; (smtp-transactions socket transaction1 ...)
;;; (smtp-transactions/no-close 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, ... ;;; Evaluate a series of expressions ?transaction1, ?transaction2, ...
;;; - Each expression should perform an SMTP transaction, ;;; - Each expression should perform an SMTP transaction,
@ -147,9 +144,7 @@
;;; - Otherwise, we throw away the current CODE and TEXT values, and ;;; - Otherwise, we throw away the current CODE and TEXT values, and
;;; proceed to the next transaction. ;;; proceed to the next transaction.
;;; ;;;
;;; Since SMTP-TRANSACTIONS closes the socket whenever it aborts a sequence, ;;; SMTP-TRANSACTIONS closes the socket after the transaction.
;;; an SMTP-TRANSACTIONS form terminated with an (smtp/quit socket) transaction
;;; will always close the socket.
;;; ;;;
;;; If the socket should be kept open in the case of an abort, use ;;; If the socket should be kept open in the case of an abort, use
;;; SMTP-TRANSACTIONS/NO-CLOSE. ;;; SMTP-TRANSACTIONS/NO-CLOSE.
@ -160,59 +155,25 @@
;;; than proceeding to mail the other four. This may not be what you want; ;;; than proceeding to mail the other four. This may not be what you want;
;;; if so, you'll have to roll your own. ;;; if so, you'll have to roll your own.
(define-syntax smtp-transactions (define (smtp-transactions socket . transactions)
(syntax-rules () (receive (code text) (apply smtp-transactions/no-close socket transactions)
((smtp-transactions socket ?T1 ?T2 ...) (cond
(let ((s socket)) ((or (= code 221)
(receive (code text) (smtp-transactions/no-close s ?T1 ?T2 ...) (= code 421))
(if (<= 400 code) (smtp/quit s)) (values))
(values code text)))))) (else
(smtp/quit socket)))
(define-syntax smtp-transactions/no-close (values code text)))
(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/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 ;;; The basics of the protocol
@ -220,19 +181,19 @@
(define (nullary-smtp-command command) (define (nullary-smtp-command command)
(lambda (socket) (lambda (socket)
(let ((port (socket:outport socket))) (let ((port (socket:outport socket)))
(write-string command port) (write-string command port)
(write-crlf port)) (write-crlf port))
(handle-smtp-reply socket))) (handle-smtp-reply socket)))
(define (unary-smtp-command command) (define (unary-smtp-command command)
(lambda (socket data) (lambda (data)
(let ((port (socket:outport socket))) (lambda (socket)
(write-string command port) (let ((port (socket:outport socket)))
(display #\space port) (write-string command port)
(write-string data port) (display #\space port)
(write-crlf port)) (write-string data port)
(handle-smtp-reply socket))) (write-crlf port))
(handle-smtp-reply socket))))
(define (smtp/open host . maybe-port) (define (smtp/open host . maybe-port)
@ -254,31 +215,32 @@
;; DATA ;; DATA
(define smtp/data (define smtp/data
(let ((send-DATA-msg (nullary-smtp-command "DATA"))) (let ((send-DATA-msg (nullary-smtp-command "DATA")))
(lambda (socket message) ; MESSAGE is a string or an input port. (lambda (message) ; MESSAGE is a string or an input port.
(receive (code text) (send-DATA-msg socket) (lambda (socket)
(if (>= code 400) (values code text) ; Error. (receive (code text) (send-DATA-msg socket)
(if (>= code 400) (values code text) ; Error.
;; We got a positive acknowledgement for the DATA msg, ;; We got a positive acknowledgement for the DATA msg,
;; now send the message body. ;; now send the message body.
(let ((p (socket:outport socket))) (let ((p (socket:outport socket)))
(cond ((string? message) (cond ((string? message)
(receive (data last-char) (smtp-stuff message #f) (receive (data last-char) (smtp-stuff message #f)
(write-string data p))) (write-string data p)))
((input-port? message) ((input-port? message)
(let lp ((last-char #f)) (let lp ((last-char #f))
(cond ((read-string/partial 1024 message) => (cond ((read-string/partial 1024 message) =>
(lambda (chunk) (lambda (chunk)
(receive (data last-char) (receive (data last-char)
(smtp-stuff chunk last-char) (smtp-stuff chunk last-char)
(write-string data p) (write-string data p)
(lp last-char))))))) (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) (write-string "\r\n.\r\n" p)
(force-output p) (force-output p)
(handle-smtp-reply socket))))))) (handle-smtp-reply socket))))))))
;; SEND FROM: <sender-address> ;; SEND FROM: <sender-address>
(define smtp/send (unary-smtp-command "SEND FROM:")) (define smtp/send (unary-smtp-command "SEND FROM:"))
@ -301,8 +263,8 @@
;; HELP <details> ;; HELP <details>
(define smtp/help (define smtp/help
(let ((send-help (unary-smtp-command "HELP"))) (let ((send-help (unary-smtp-command "HELP")))
(lambda (socket . details) (lambda details
(send-help socket (apply string-append details))))) (send-help (apply string-append details)))))
;; NOOP ;; NOOP
(define smtp/noop (nullary-smtp-command "NOOP")) (define smtp/noop (nullary-smtp-command "NOOP"))
@ -311,10 +273,10 @@
(define smtp/quit (define smtp/quit
(let ((quit (nullary-smtp-command "QUIT"))) (let ((quit (nullary-smtp-command "QUIT")))
(lambda (socket) (lambda (socket)
(receive (code text) (quit socket) ; Quit & close socket gracefully. (receive (code text) (quit socket) ; Quit & close socket gracefully.
(case code (case code
((221 421)) ((221 421))
(else (close-socket socket))) ; But close in any event. (else (close-socket socket))) ; But close in any event.
(values code text))))) (values code text)))))
;; TURN ;; TURN
@ -332,7 +294,7 @@
(define (handle-smtp-reply socket) (define (handle-smtp-reply socket)
(receive (code text) (read-smtp-reply (socket:inport socket)) (receive (code text) (read-smtp-reply (socket:inport socket))
(case code (case code
((221 421) (close-socket socket))) ; All done. ((221 421) (close-socket socket))) ; All done.
(values code text))) (values code text)))
;;; Read a reply from the SMTP server. Returns two values: ;;; Read a reply from the SMTP server. Returns two values: