diff options
Diffstat (limited to 'email/email.scm')
| -rw-r--r-- | email/email.scm | 85 |
1 files changed, 51 insertions, 34 deletions
diff --git a/email/email.scm b/email/email.scm index 7e613ff..381c81a 100644 --- a/email/email.scm +++ b/email/email.scm @@ -18,10 +18,13 @@ ;;; <http://www.gnu.org/licenses/>. (define-module (email email) + #:use-module (ice-9 binary-ports) #:use-module (ice-9 iconv) #:use-module (ice-9 match) #:use-module (ice-9 peg) #:use-module (ice-9 regex) + #:use-module (rnrs bytevectors) + #:use-module ((rnrs io ports) #:select (call-with-port)) #:use-module (rnrs io simple) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) @@ -570,11 +573,15 @@ 'post)) (define (body->mime-entities body boundary) - "Split BODY into a list of mime entities separated by BOUNDARY (as -explained in RFC2045), and return that list." + "Split bytevector BODY into a list of mime entities separated by +BOUNDARY (as explained in RFC2045), and return that list." (define (read-till-boundary port) - (read-while port get-line-with-delimiter - (negate (cut string-prefix? (string-append "--" boundary) <>)))) + (read-bytes-till + port + ;; TODO: Look for the boundary sequence only at the beginning of + ;; a line. + ;; Boundary is always an ASCII string. + (string->bytevector (string-append "--" boundary) "us-ascii"))) (define (read-mime-entity port) (let ((line (get-line-with-delimiter port))) @@ -586,22 +593,25 @@ explained in RFC2045), and return that list." (eof-object) (read-till-boundary port)))) - (call-with-input-string body - (lambda (port) - (read-till-boundary port) - (read-objects read-mime-entity port)))) + (call-with-port + (open-bytevector-input-port body) + (lambda (port) + (read-till-boundary port) + (read-objects read-mime-entity port)))) (define (email->headers+body email) - "Split EMAIL into headers and body. Return as multiple values." - (call-with-input-string email + "Split EMAIL bytevector into headers and body. Return as multiple +values. The returned headers is a string and body is a bytevector." + (call-with-port + (open-bytevector-input-port email) (lambda (port) + (set-port-encoding! port "us-ascii") (let ((headers (read-while port get-line-with-delimiter (lambda (line) (not (or (string= line "\n") (string= line "\r\n"))))))) (get-line-with-delimiter port) - (values headers - (read-while port get-line-with-delimiter identity)))))) + (values headers (get-bytevector-all port)))))) (define (post-process-mailbox . args) (define process-name @@ -714,16 +724,20 @@ For example, header keys and values as returned by parse-email-headers. Return a list of <mime-entity> records if the body is a multipart message. Else, return a single <mime-entity> record." - (let ((content-type (assoc-ref headers 'content-type))) - (case (assoc-ref content-type 'type) - ((multipart) - (map parse-mime-entity - (body->mime-entities body (assoc-ref content-type 'boundary)))) - ((text) - (string-trim-both - (decode-body body (assoc-ref headers 'content-transfer-encoding) - (assoc-ref content-type 'charset)))) - (else (decode-body body (assoc-ref headers 'content-transfer-encoding)))))) + (match body + ((? string? body) + (parse-email-body headers (string->bytevector body "utf-8"))) + ((? bytevector? body) + (let ((content-type (assoc-ref headers 'content-type))) + (case (assoc-ref content-type 'type) + ((multipart) + (map parse-mime-entity + (body->mime-entities body (assoc-ref content-type 'boundary)))) + ((text) + (string-trim-both + (decode-body body (assoc-ref headers 'content-transfer-encoding) + (assoc-ref content-type 'charset)))) + (else (decode-body body (assoc-ref headers 'content-transfer-encoding)))))))) (define (add-default-headers headers) ;; Default Content-Type and Content-Transfer-Encoding headers as @@ -742,8 +756,8 @@ message. Else, return a single <mime-entity> record." default-headers) headers))) -(define (parse-mime-entity text) - (let-values (((headers body) (email->headers+body text))) +(define (parse-mime-entity bv) + (let-values (((headers body) (email->headers+body bv))) (let ((headers (pre-post-order (peg:tree @@ -766,9 +780,13 @@ message. Else, return a single <mime-entity> record." (define (parse-email email) "Parse string EMAIL and return result as an <email> record." - (let-values (((headers body) (email->headers+body email))) - (let ((headers-alist (parse-email-headers headers))) - (make-email headers-alist (parse-email-body headers-alist body))))) + (match email + ((? string? email) + (parse-email (string->bytevector email "utf-8"))) + ((? bytevector? email) + (let-values (((headers body) (email->headers+body email))) + (let ((headers-alist (parse-email-headers headers))) + (make-email headers-alist (parse-email-body headers-alist body))))))) (define (parse-email-headers headers) "Parse string HEADERS as email headers and return an association @@ -824,7 +842,7 @@ list of header keys and values." (*default* . ,(lambda tree tree))))) (define* (decode-body body encoding #:optional charset) - (let ((octets + (let ((decoded-octets (case encoding ((base64) (base64-decode @@ -834,15 +852,14 @@ list of header keys and values." (ucs-range->char-set (char->integer #\A) (1+ (char->integer #\Z))) (ucs-range->char-set (char->integer #\0) (1+ (char->integer #\9))) (char-set #\+ #\/ #\=)) - body))) - ((quoted-printable) (quoted-printable-decode body)) + (bytevector->string body "us-ascii")))) + ((quoted-printable) (quoted-printable-decode + (bytevector->string body "us-ascii"))) ((#{7bit}# #{8bit}# binary) body) (else (error "Body decoding failed. Unknown encoding" encoding))))) (if charset - (case encoding - ((base64 quoted-printable) (bytevector->string octets charset)) - ((#{7bit}# #{8bit}# binary) octets)) - octets))) + (bytevector->string decoded-octets charset) + decoded-octets))) (define (read-next-email-in-mbox port) ;; Read and discard From_ line |