ddcab952f7
There might be existing uses of `net/sendmail' that did this quoting since this code didn't do so. Such uses would continue to work fine, since quoted strings would already be plain ASCII, so a second quoting would leave it as is. Note that the quoted strings are also used as command line arguments. It seems that sendmail deals with these all fine when they appear as command line arguments. This means that any valid email address format can be used, not just "raw" emails. If there are some sendmails that don't do this, then it would be better to add a `-t' flag to let sendmail parse the text in the message. One caveat (not a new one): since they're passed as is, it is possible to use two emails in a single string, as in "a@b.com, c@d.com". This could lead to obvious problems if someone uses "Bar, Foo <foo@bar.org>" instead of "\"Bar, Foo\" <foo@bar.org>". (Using a `-t' to parse the content won't help with that...) The only way to avoid this would be to parse the emails and quote the name part if needed. But that's a much hairier piece of code.
80 lines
3.2 KiB
Racket
80 lines
3.2 KiB
Racket
#lang racket/base
|
|
|
|
(provide send-mail-message/port send-mail-message)
|
|
|
|
(require net/unihead)
|
|
|
|
(define sendmail-search-path
|
|
'("/usr/sbin" "/sbin" "/usr/local/sbin" "/usr/lib"))
|
|
|
|
(define sendmail-program-file
|
|
(let ([exe (case (system-type)
|
|
[(windows) "sendmail.exe"]
|
|
[else "sendmail"])])
|
|
(or (for/or ([path (in-list sendmail-search-path)])
|
|
(define p (build-path path exe))
|
|
(and (file-exists? p)
|
|
(memq 'execute (file-or-directory-permissions p))
|
|
p))
|
|
(raise (make-exn:fail:unsupported
|
|
(format "unable to find a sendmail executable in ~s"
|
|
sendmail-search-path)
|
|
(current-continuation-marks))))))
|
|
|
|
;; Main implementation, returns a port
|
|
(define (send-mail-core who sender subject TOs CCs BCCs headers)
|
|
(define qTOs (map encode-for-header TOs))
|
|
(define qCCs (map encode-for-header CCs))
|
|
(define qBCCs (map encode-for-header BCCs))
|
|
(define all-recipients (append qTOs qCCs qBCCs))
|
|
(when (null? all-recipients)
|
|
(error who "no mail recipients were specified"))
|
|
(define-values [p pout pin perr]
|
|
;; use -i, so "." lines are not a problem
|
|
(apply subprocess #f #f #f sendmail-program-file "-i" all-recipients))
|
|
(close-input-port pout)
|
|
(close-input-port perr)
|
|
(port-count-lines! pin)
|
|
(fprintf pin "X-Mailer: Racket (racket-lang.org)\n")
|
|
(when sender (fprintf pin "From: ~a\n" (encode-for-header sender)))
|
|
(for ([header (in-list '("To" "CC"))]
|
|
[recipients (in-list (list qTOs qCCs))]
|
|
#:unless (null? recipients))
|
|
(fprintf pin "~a: ~a" header (car recipients))
|
|
(for ([recipient (in-list (cdr recipients))])
|
|
(define col (let-values ([(line col pos) (port-next-location pin)]) col))
|
|
(fprintf pin ",~a~a"
|
|
(if ((+ col 2 (string-length recipient)) . > . 78)
|
|
"\n " " ")
|
|
recipient))
|
|
(newline pin))
|
|
(fprintf pin "Subject: ~a\n" (encode-for-header subject))
|
|
(for ([h (in-list headers)]) (fprintf pin "~a\n" h))
|
|
(newline pin)
|
|
pin)
|
|
|
|
;; send-mail-message/port:
|
|
;; String String (Listof String) (Listof String) (Listof String) String ...
|
|
;; -> Output-Port
|
|
|
|
;; -- sender can be anything, though spoofing is not recommended.
|
|
;; The recipients must all be valid email addresses, they're passed to
|
|
;; sendmail as arguments -- and seems that it handles various name+email
|
|
;; formats correctly. Note that everything is expected to follow RFC
|
|
;; conventions. If any other headers are specified, they are expected
|
|
;; to be completely formatted already. Clients are urged to use
|
|
;; close-output-port on the port returned by this procedure as soon as
|
|
;; the necessary text has been written, so that the sendmail process can
|
|
;; complete.
|
|
(define (send-mail-message/port sender subject TOs CCs BCCs . headers)
|
|
(send-mail-core 'send-mail-message/port sender subject TOs CCs BCCs headers))
|
|
|
|
;; send-mail-message :
|
|
;; string x string x list (string) x list (string) x list (string) x
|
|
;; list (string) [x list (string)] -> ()
|
|
(define (send-mail-message sender subject TOs CCs BCCs text . headers)
|
|
(define pin
|
|
(send-mail-core 'send-mail-message sender subject TOs CCs BCCs headers))
|
|
(for ([t (in-list text)]) (fprintf pin "~a\n" t))
|
|
(close-output-port pin))
|