summaryrefslogtreecommitdiff
path: root/email
diff options
context:
space:
mode:
authorArun Isaac2019-07-26 01:53:22 +0530
committerArun Isaac2019-07-28 12:13:43 +0530
commitac83c2a00c13702bc365cd0f3074239fa63d743f (patch)
treed5055a15da9dba36033bb207a541ee890098f8fe /email
parent36474696eaa6187e7077f73d02daeb0138e03124 (diff)
downloadguile-email-ac83c2a00c13702bc365cd0f3074239fa63d743f.tar.gz
guile-email-ac83c2a00c13702bc365cd0f3074239fa63d743f.tar.lz
guile-email-ac83c2a00c13702bc365cd0f3074239fa63d743f.zip
email: Support email with mixed encoding of characters.
Prior to this, parse-email would accept email in the form of a string. A string is constrained to use the same encoding for all its characters whereas an email can have characters encoded using different encoding schemes. Therefore, it is more correct that parse-email deals with bytevectors instead of strings. * email/utils.scm (read-bytes-till): New function. * email/email.scm (body->mime-entities, email->headers+body, decode-body): Deal with emails as bytevectors instead of strings. (parse-mime-entity): Rename text argument to bv. (parse-email, parse-email-body): Overload to handle input in the form of a string or bytevector. * doc/guile-email.texi (Parsing e-mail): Document overloading of parse-email and parse-email-body. * tests/email.scm ("handle truncated multipart message gracefully"): Deal in bytevectors instead of strings. ("email with 8 bit encoding and non UTF-8 charset", "multipart email with a 8 bit encoding and non UTF-8 charset part"): New tests. * tests/email-with-8bit-encoding-and-non-utf8-charset, tests/multipart-email-with-a-8bit-encoding-and-non-utf8-charset-part: New files. Reported-by: Jack Hill <jackhill@jackhill.us>
Diffstat (limited to 'email')
-rw-r--r--email/email.scm85
-rw-r--r--email/utils.scm32
2 files changed, 82 insertions, 35 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
diff --git a/email/utils.scm b/email/utils.scm
index 35a96d8..2040b21 100644
--- a/email/utils.scm
+++ b/email/utils.scm
@@ -1,5 +1,5 @@
;;; guile-email --- Guile email parser
-;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of guile-email.
;;;
@@ -20,11 +20,17 @@
(define-module (email utils)
#:use-module (ice-9 match)
#:use-module (ice-9 peg codegen)
+ #:use-module (ice-9 binary-ports)
#:use-module (ice-9 textual-ports)
+ #:use-module (rnrs bytevectors)
+ #:use-module ((rnrs io ports)
+ #:select (call-with-bytevector-output-port))
#:use-module (rnrs io simple)
+ #:use-module (srfi srfi-26)
#:export (get-line-with-delimiter
read-objects
read-while
+ read-bytes-till
acons*
alist-delete*))
@@ -52,6 +58,30 @@ string returned by READ-PROC as argument."
(let ((str (call-with-output-string read-while-loop)))
(if (string-null? str) (eof-object) str)))
+(define (read-bytes-till port sequence)
+ "Read bytes from PORT until byte SEQUENCE is seen or end-of-file is
+reached. If SEQUENCE is seen, unget it to PORT and return."
+ (define (read-bytes-and-write-till in out sequence)
+ (let ((octet (get-u8 in)))
+ (cond
+ ((eof-object? octet) octet)
+ ;; If octet read matches first octet of sequence, try matching
+ ;; the full sequence.
+ ((= octet (bytevector-u8-ref sequence 0))
+ (unget-bytevector in sequence 0 1)
+ (let ((bv (get-bytevector-n in (bytevector-length sequence))))
+ (cond
+ ((bytevector=? bv sequence) (unget-bytevector in bv))
+ (else (unget-bytevector in bv 1)
+ (put-u8 out octet)
+ (read-bytes-and-write-till in out sequence)))))
+ ;; Else, output the octet and continue reading.
+ (else (put-u8 out octet)
+ (read-bytes-and-write-till in out sequence)))))
+
+ (call-with-bytevector-output-port
+ (cut read-bytes-and-write-till port <> sequence)))
+
(define (get-line-with-delimiter port)
"Read a line from PORT and return it as a string including the
delimiting linefeed character."