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))
|