diff options
Diffstat (limited to 'collects/net/sendmail-unit.ss')
| -rw-r--r-- | collects/net/sendmail-unit.ss | 214 |
1 files changed, 107 insertions, 107 deletions
diff --git a/collects/net/sendmail-unit.ss b/collects/net/sendmail-unit.ss index e01ff9a400..eefe4a254e 100644 --- a/collects/net/sendmail-unit.ss +++ b/collects/net/sendmail-unit.ss @@ -1,119 +1,119 @@ #lang scheme/unit - (require mzlib/process "sendmail-sig.ss") +(require mzlib/process "sendmail-sig.ss") - (import) - (export sendmail^) +(import) +(export sendmail^) - (define-struct (no-mail-recipients exn) ()) +(define-struct (no-mail-recipients exn) ()) - (define sendmail-search-path - '("/usr/lib" "/usr/sbin")) +(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))))) +(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 +;; 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. +;; -- 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 - (lambda (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: MzScheme: see www.plt-scheme.org\n") - (for-each (lambda (s) - (display s writer) - (newline writer)) - other-headers) - (newline writer) - writer)))) +(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: MzScheme: see www.plt-scheme.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)] -> () +;; 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. +;; -- 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 - (lambda (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)))) +(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))) |