From 65279a42e94284655df126ddd6306b91b73e3cbc Mon Sep 17 00:00:00 2001 From: sperber Date: Tue, 21 Jan 2003 15:31:38 +0000 Subject: [PATCH] Revamp SMTP once more: - introduce SMTP-CONNECTION records - regularize naming (no funny slashes) - in SMTP-SEND-MAIL, add date header if not present - gratuitous capitalizion of word components for field names in outgoing headers --- scheme/lib/smtp.scm | 160 ++++++++++++++++++++------------------------ scheme/packages.scm | 17 +++-- 2 files changed, 81 insertions(+), 96 deletions(-) diff --git a/scheme/lib/smtp.scm b/scheme/lib/smtp.scm index ef8144f..03a5a52 100644 --- a/scheme/lib/smtp.scm +++ b/scheme/lib/smtp.scm @@ -3,6 +3,7 @@ ;;; This file is part of the Scheme Untergrund Networking package. ;;; Copyright (c) 1995 by Brian D. Carlstrom and Olin Shivers. +;;; Copyright (c) 2002-2003 by Mike Sperber ;;; For copyright information, see the file COPYING which comes with ;;; the distribution. @@ -28,9 +29,6 @@ ;;; of addresses. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; (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 ;;; text-list. However, if only problem with message is that some recipients @@ -42,110 +40,78 @@ ;;; ;;; BODY is a list of strings or an input port. -(define (send-mail-via-smtp from to-list headers body . maybe-host) +(define (smtp-send-mail from to-list headers body . maybe-host) (call-with-current-continuation (lambda (bailout) (let* ((host (:optional maybe-host "localhost")) (local (if (string=? host "localhost") (system-name) ; we don't need any DNS for that (system-fqdn))) - (socket (smtp/open host))) + (connection (smtp-connect host))) (receive (code text) - (smtp-transactions/no-close socket ; Do prologue. - (smtp/helo local) - (smtp/mail from)) + (smtp-transactions/no-close connection ; Do prologue. + (smtp-helo local) + (smtp-mail from)) (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 to) socket) + (receive (code text) + ((smtp-rcpt to) (smtp-connection-socket connection)) (and (>= code 400) ; Error (cond ((>= code 600) - (smtp/quit socket) + (smtp-quit + (smtp-connection-socket connection)) (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 headers body)) + (receive (code text) + (smtp-transactions connection + (smtp-data (normalize-headers headers) body)) (if (and (< code 400) (null? losers)) (values code text) (values 700 losers)))))))))) -;;; EXPN, VRFY, MAIL-HELP -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; These three are simple queries of the server. +(define (normalize-headers headers) + (if (assq 'date headers) + headers + (cons (cons 'date + (rfc822-time->string (time))) + headers))) (define (smtp-query socket query arg) (receive (code text) (smtp-transactions socket - (smtp/helo (system-name)) + (smtp-helo (system-name)) (query arg)) (values code text))) -(define (expn name host) - (smtp-query (smtp/open host) smtp/expn name)) +(define (smtp-expand name host) + (smtp-query (smtp-connect host) smtp-expn name)) -(define (vrfy name host) - (smtp-query (smtp/open host) smtp/vrfy name)) +(define (smtp-verify name host) + (smtp-query (smtp-connect host) smtp-vrfy name)) -(define (mail-help host . details) - (smtp-query (smtp/open host) smtp/help (apply string-append (cons " " details)))) +(define (smtp-get-help host . details) + (smtp-query (smtp-connect host) smtp-help (apply string-append (cons " " details)))) +(define (smtp-transactions connection . transactions) + (let ((socket (smtp-connection-socket connection))) + (receive (code text) (apply smtp-transactions/no-close connection transactions) + (cond + ((or (= code 221) + (= code 421)) + (values)) + (else + (smtp-quit socket))) + (values code text)))) -;;; (smtp-transactions socket transaction1 ...) -;;; (smtp-transactions/no-close socket transaction1 ...) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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, -;;; and return two values: -;;; + CODE (the integer reply code) -;;; + TEXT (list of strings that came with the reply). -;;; -;;; - If the transaction's reply code is 221 or 421 (meaning the socket has -;;; been closed), then the transaction sequence is aborted, and the -;;; SMTP-TRANSACTIONS form returns the CODE and TEXT values for the current -;;; transaction. -;;; -;;; - If the reply code is an error code (in the four- or five-hundred range), -;;; the transaction sequence is aborted, and the fatal transaction's CODE -;;; and TEXT values are returned. SMTP-TRANSACTIONS will additionally -;;; close the socket for you; SMTP-TRANSACTIONS/NO-CLOSE will not. -;;; -;;; - If the transaction is the last in the transaction sequence, -;;; its CODE and TEXT values are returned. -;;; -;;; - Otherwise, we throw away the current CODE and TEXT values, and -;;; proceed to the next transaction. -;;; -;;; 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. -;;; -;;; We abort sequences if a transaction results in a 400-class error code. -;;; So, a sequence mailing a message to five people, with 5 RCPT's, would -;;; abort if the mailing address for one of these people was wrong, rather -;;; than proceeding to mail the other four. This may not be what you want; -;;; if so, you'll have to roll your own. - -(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) +(define (smtp-transactions/no-close connection . transactions) (let loop ((transactions transactions)) - (receive (code text) ((car transactions) socket) + (receive (code text) ((car transactions) (smtp-connection-socket connection)) (if (or (null? (cdr transactions)) (= code 221) (= code 421) ; Redundant, I know. @@ -173,26 +139,30 @@ (write-crlf port)) (handle-smtp-reply socket)))) +(define-record-type smtp-connection :smtp-connection + (make-smtp-connection socket) + smtp-connection? + (socket smtp-connection-socket)) -(define (smtp/open host . maybe-port) +(define (smtp-connect host . maybe-port) (let ((sock (socket-connect protocol-family/internet socket-type/stream host (:optional maybe-port "smtp")))) (receive (code text) (handle-smtp-reply sock) (if (< code 400) - sock + (make-smtp-connection sock) (error "SMTP socket-open server-reply error" sock code text))))) ;; HELLO -(define smtp/helo (unary-smtp-command "HELO")) +(define smtp-helo (unary-smtp-command "HELO")) ;; MAIL FROM: -(define smtp/mail (unary-smtp-command "MAIL FROM:")) +(define smtp-mail (unary-smtp-command "MAIL FROM:")) ;; RECIPIENT TO: -(define smtp/rcpt (unary-smtp-command "RCPT TO:")) +(define smtp-rcpt (unary-smtp-command "RCPT TO:")) ;; DATA -(define smtp/data +(define smtp-data (let ((send-DATA-msg (nullary-smtp-command "DATA"))) (lambda (headers message) ; MESSAGE is a list of strings or an input port. (lambda (socket) @@ -204,7 +174,7 @@ ;; now send the message body. (let ((p (socket:outport socket))) (for-each (lambda (pair) - (display (car pair) p) + (display (symbol->field-name (car pair)) p) (write-char #\: p) (display (cdr pair) p) (write-crlf p)) @@ -232,6 +202,18 @@ (force-output p) (handle-smtp-reply socket)))))))) +(define component-charset (char-set-complement (char-set #\-))) + +(define (symbol->field-name symbol) + (let ((components (string-tokenize (symbol->string symbol) component-charset))) + (string-join (map upcase-string components) "-"))) + +(define (upcase-string strng) + (if (string=? "" strng) + "" + (string-append (string (char-upcase (string-ref strng 0))) + (substring strng 1 (string-length strng))))) + (define (write-data-line line port) (display (if (string=? line ".") ".." @@ -240,34 +222,34 @@ (write-crlf port)) ;; SEND FROM: -(define smtp/send (unary-smtp-command "SEND FROM:")) +(define smtp-send (unary-smtp-command "SEND FROM:")) ;; SEND OR MAIL -(define smtp/soml (unary-smtp-command "SOML FROM:")) +(define smtp-soml (unary-smtp-command "SOML FROM:")) ;; SEND AND MAIL -(define smtp/saml (unary-smtp-command "SOML SAML:")) +(define smtp-saml (unary-smtp-command "SOML SAML:")) ;; RESET -(define smtp/rset (nullary-smtp-command "RSET")) +(define smtp-rset (nullary-smtp-command "RSET")) ;; VERIFY -(define smtp/vrfy (unary-smtp-command "VRFY")) +(define smtp-vrfy (unary-smtp-command "VRFY")) ;; EXPAND -(define smtp/expn (unary-smtp-command "EXPN")) +(define smtp-expn (unary-smtp-command "EXPN")) ;; HELP
-(define smtp/help +(define smtp-help (let ((send-help (unary-smtp-command "HELP"))) (lambda details (send-help (apply string-append details))))) ;; NOOP -(define smtp/noop (nullary-smtp-command "NOOP")) +(define smtp-noop (nullary-smtp-command "NOOP")) ;; QUIT -(define smtp/quit +(define smtp-quit (let ((quit (nullary-smtp-command "QUIT"))) (lambda (socket) (receive (code text) (quit socket) ; Quit & close socket gracefully. @@ -277,7 +259,7 @@ (values code text))))) ;; TURN -(define smtp/turn (nullary-smtp-command "TURN")) +(define smtp-turn (nullary-smtp-command "TURN")) ;;; Read and handle the reply. Return an integer (the reply code), ;;; and a list of the text lines that came tagged by the reply code. diff --git a/scheme/packages.scm b/scheme/packages.scm index 006f510..a9e2c65 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -32,13 +32,14 @@ emit-text)) (define-interface smtp-interface - (export send-mail-via-smtp - expn vrfy mail-help + (export smtp-send-mail + smtp-expand smtp-verify smtp-help smtp-transactions smtp-transactions/no-close - smtp/open smtp/helo smtp/mail smtp/rcpt smtp/data - smtp/send smtp/soml smtp/saml smtp/rset smtp/expn - smtp/help smtp/noop smtp/quit smtp/turn)) + smtp-connect + smtp-helo smtp-mail smtp-rcpt smtp-data + smtp-send smtp-soml smtp-saml smtp-rset smtp-expn + smtp-help smtp-noop smtp-quit smtp-turn)) (define-interface rfc822-interface (export read-rfc822-headers @@ -371,12 +372,14 @@ (open scheme-with-scsh ; user-login-name and sockets + define-record-types (subset srfi-1 (filter-map)) + (subset srfi-13 (string-tokenize string-join)) crlf-io ; read-crlf-line write-crlf receiving ; values receive - let-opt ; let-optionals dns ; SYSTEM-FQDN - ) + let-opt + (subset rfc822 (rfc822-time->string))) (files (lib smtp))) (define-structure rfc822 rfc822-interface