diff options
Diffstat (limited to 'email')
| -rw-r--r-- | email/email.scm | 85 | ||||
| -rw-r--r-- | email/utils.scm | 32 |
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." |