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
This commit is contained in:
sperber
parent
9b59e5bbe6
commit
65279a42e9
|
|
@ -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 <sperber@informatik.uni-tuebingen.de>
|
||||
;;; 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 <local-hostname>
|
||||
(define smtp/helo (unary-smtp-command "HELO"))
|
||||
(define smtp-helo (unary-smtp-command "HELO"))
|
||||
|
||||
;; MAIL FROM: <sender-address>
|
||||
(define smtp/mail (unary-smtp-command "MAIL FROM:"))
|
||||
(define smtp-mail (unary-smtp-command "MAIL FROM:"))
|
||||
|
||||
;; RECIPIENT TO: <destination-address>
|
||||
(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: <sender-address>
|
||||
(define smtp/send (unary-smtp-command "SEND FROM:"))
|
||||
(define smtp-send (unary-smtp-command "SEND FROM:"))
|
||||
|
||||
;; SEND OR MAIL <sender-address>
|
||||
(define smtp/soml (unary-smtp-command "SOML FROM:"))
|
||||
(define smtp-soml (unary-smtp-command "SOML FROM:"))
|
||||
|
||||
;; SEND AND MAIL <sender-address>
|
||||
(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 <user>
|
||||
(define smtp/vrfy (unary-smtp-command "VRFY"))
|
||||
(define smtp-vrfy (unary-smtp-command "VRFY"))
|
||||
|
||||
;; EXPAND <user>
|
||||
(define smtp/expn (unary-smtp-command "EXPN"))
|
||||
(define smtp-expn (unary-smtp-command "EXPN"))
|
||||
|
||||
;; HELP <details>
|
||||
(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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue