diff --git a/collects/net/scribblings/sendmail.scrbl b/collects/net/scribblings/sendmail.scrbl index cef43caa42..d034f15662 100644 --- a/collects/net/scribblings/sendmail.scrbl +++ b/collects/net/scribblings/sendmail.scrbl @@ -63,6 +63,10 @@ Raised when no mail recipients were specified for @section{Sendmail Unit} +@margin-note{@racket[sendmail@] and @racket[sendmail^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/sendmail] module.} + @defmodule[net/sendmail-unit] @defthing[sendmail@ unit?]{ diff --git a/collects/net/sendmail-unit.rkt b/collects/net/sendmail-unit.rkt index bca94df243..2fd97068e9 100644 --- a/collects/net/sendmail-unit.rkt +++ b/collects/net/sendmail-unit.rkt @@ -1,119 +1,8 @@ -#lang racket/unit +#lang racket/base -(require racket/system "sendmail-sig.rkt") +(require racket/unit + "sendmail-sig.rkt" "sendmail.rkt") -(import) -(export sendmail^) +(define-unit-from-context sendmail@ sendmail^) -(define-struct (no-mail-recipients exn) ()) - -(define sendmail-search-path - '("/usr/lib" "/usr/sbin")) - -(define sendmail-program-file - (if (or (eq? (system-type) 'unix) - (eq? (system-type) 'macosx)) - (let loop ([paths sendmail-search-path]) - (if (null? paths) - (raise (make-exn:fail:unsupported - "unable to find sendmail on this Unix variant" - (current-continuation-marks))) - (let ([p (build-path (car paths) "sendmail")]) - (if (and (file-exists? p) - (memq 'execute (file-or-directory-permissions p))) - p - (loop (cdr paths)))))) - (raise (make-exn:fail:unsupported - "sendmail only available under Unix" - (current-continuation-marks))))) - -;; send-mail-message/port : -;; string x string x list (string) x list (string) x list (string) -;; [x list (string)] -> oport - -;; -- sender can be anything, though spoofing is not recommended. -;; The recipients must all be pure email addresses. 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 to-recipients cc-recipients bcc-recipients - . other-headers) - (when (and (null? to-recipients) (null? cc-recipients) - (null? bcc-recipients)) - (raise (make-no-mail-recipients - "no mail recipients were specified" - (current-continuation-marks)))) - (let ([return (apply process* sendmail-program-file "-i" - (append to-recipients cc-recipients bcc-recipients))]) - (let ([reader (car return)] - [writer (cadr return)] - [pid (caddr return)] - [error-reader (cadddr return)]) - (close-input-port reader) - (close-input-port error-reader) - (fprintf writer "From: ~a\n" sender) - (letrec ([write-recipient-header - (lambda (header-string recipients) - (let ([header-space - (+ (string-length header-string) 2)]) - (fprintf writer "~a: " header-string) - (let loop ([to recipients] [indent header-space]) - (if (null? to) - (newline writer) - (let ([first (car to)] - [rest (cdr to)]) - (let ([len (string-length first)]) - (if (>= (+ len indent) 80) - (begin - (fprintf writer - (if (null? rest) - "\n ~a" - "\n ~a, ") - first) - (loop (cdr to) - (+ len header-space 2))) - (begin - (fprintf writer - (if (null? rest) - "~a " - "~a, ") - first) - (loop (cdr to) - (+ len indent 2))))))))))]) - (write-recipient-header "To" to-recipients) - (unless (null? cc-recipients) - (write-recipient-header "CC" cc-recipients))) - (fprintf writer "Subject: ~a\n" subject) - (fprintf writer "X-Mailer: Racket (racket-lang.org)\n") - (for-each (lambda (s) - (display s writer) - (newline writer)) - other-headers) - (newline writer) - writer))) - -;; send-mail-message : -;; string x string x list (string) x list (string) x list (string) x -;; list (string) [x list (string)] -> () - -;; -- sender can be anything, though spoofing is not recommended. The -;; recipients must all be pure email addresses. The text is expected -;; to be pre-formatted. Note that everything is expected to follow -;; RFC conventions. If any other headers are specified, they are -;; expected to be completely formatted already. - -(define (send-mail-message - sender subject to-recipients cc-recipients bcc-recipients text - . other-headers) - (let ([writer (apply send-mail-message/port sender subject - to-recipients cc-recipients bcc-recipients - other-headers)]) - (for-each (lambda (s) - (display s writer) ; We use -i, so "." is not a problem - (newline writer)) - text) - (close-output-port writer))) +(provide sendmail@) diff --git a/collects/net/sendmail.rkt b/collects/net/sendmail.rkt index e759519616..025aec0454 100644 --- a/collects/net/sendmail.rkt +++ b/collects/net/sendmail.rkt @@ -1,6 +1,120 @@ #lang racket/base -(require racket/unit "sendmail-sig.rkt" "sendmail-unit.rkt") -(define-values/invoke-unit/infer sendmail@) +(require racket/system) -(provide-signature-elements sendmail^) +(provide send-mail-message/port + send-mail-message + (struct-out no-mail-recipients)) + +(define-struct (no-mail-recipients exn) ()) + +(define sendmail-search-path + '("/usr/lib" "/usr/sbin")) + +(define sendmail-program-file + (if (or (eq? (system-type) 'unix) + (eq? (system-type) 'macosx)) + (let loop ([paths sendmail-search-path]) + (if (null? paths) + (raise (make-exn:fail:unsupported + "unable to find sendmail on this Unix variant" + (current-continuation-marks))) + (let ([p (build-path (car paths) "sendmail")]) + (if (and (file-exists? p) + (memq 'execute (file-or-directory-permissions p))) + p + (loop (cdr paths)))))) + (raise (make-exn:fail:unsupported + "sendmail only available under Unix" + (current-continuation-marks))))) + +;; send-mail-message/port : +;; string x string x list (string) x list (string) x list (string) +;; [x list (string)] -> oport + +;; -- sender can be anything, though spoofing is not recommended. +;; The recipients must all be pure email addresses. 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 to-recipients cc-recipients bcc-recipients + . other-headers) + (when (and (null? to-recipients) (null? cc-recipients) + (null? bcc-recipients)) + (raise (make-no-mail-recipients + "no mail recipients were specified" + (current-continuation-marks)))) + (let ([return (apply process* sendmail-program-file "-i" + (append to-recipients cc-recipients bcc-recipients))]) + (let ([reader (car return)] + [writer (cadr return)] + [pid (caddr return)] + [error-reader (cadddr return)]) + (close-input-port reader) + (close-input-port error-reader) + (fprintf writer "From: ~a\n" sender) + (letrec ([write-recipient-header + (lambda (header-string recipients) + (let ([header-space + (+ (string-length header-string) 2)]) + (fprintf writer "~a: " header-string) + (let loop ([to recipients] [indent header-space]) + (if (null? to) + (newline writer) + (let ([first (car to)] + [rest (cdr to)]) + (let ([len (string-length first)]) + (if (>= (+ len indent) 80) + (begin + (fprintf writer + (if (null? rest) + "\n ~a" + "\n ~a, ") + first) + (loop (cdr to) + (+ len header-space 2))) + (begin + (fprintf writer + (if (null? rest) + "~a " + "~a, ") + first) + (loop (cdr to) + (+ len indent 2))))))))))]) + (write-recipient-header "To" to-recipients) + (unless (null? cc-recipients) + (write-recipient-header "CC" cc-recipients))) + (fprintf writer "Subject: ~a\n" subject) + (fprintf writer "X-Mailer: Racket (racket-lang.org)\n") + (for-each (lambda (s) + (display s writer) + (newline writer)) + other-headers) + (newline writer) + writer))) + +;; send-mail-message : +;; string x string x list (string) x list (string) x list (string) x +;; list (string) [x list (string)] -> () + +;; -- sender can be anything, though spoofing is not recommended. The +;; recipients must all be pure email addresses. The text is expected +;; to be pre-formatted. Note that everything is expected to follow +;; RFC conventions. If any other headers are specified, they are +;; expected to be completely formatted already. + +(define (send-mail-message + sender subject to-recipients cc-recipients bcc-recipients text + . other-headers) + (let ([writer (apply send-mail-message/port sender subject + to-recipients cc-recipients bcc-recipients + other-headers)]) + (for-each (lambda (s) + (display s writer) ; We use -i, so "." is not a problem + (newline writer)) + text) + (close-output-port writer)))