diff options
Diffstat (limited to 'email/email.scm')
| -rw-r--r-- | email/email.scm | 398 |
1 files changed, 199 insertions, 199 deletions
diff --git a/email/email.scm b/email/email.scm index ccda3ac..d836908 100644 --- a/email/email.scm +++ b/email/email.scm @@ -33,26 +33,26 @@ #:use-module (email base64) #:use-module (email quoted-printable) #:use-module ((email utils) - #:select (get-line-with-delimiter - read-objects read-while - acons* alist-delete*)) + #:select (get-line-with-delimiter + read-objects read-while + acons* alist-delete*)) #:export (<email> - make-email - email? - email-headers - email-body - <mime-entity> - make-mime-entity - mime-entity? - mime-entity-headers - mime-entity-body - email->headers+body - parse-email - parse-email-headers - parse-email-body - parse-email-address - interpret-address - mbox->emails)) + make-email + email? + email-headers + email-body + <mime-entity> + make-mime-entity + mime-entity? + mime-entity-headers + mime-entity-body + email->headers+body + parse-email + parse-email-headers + parse-email-body + parse-email-address + interpret-address + mbox->emails)) (define (flatten-and-filter terms tree) (filter list? (keyword-flatten terms tree))) @@ -98,7 +98,7 @@ ;; Printable ASCII characters and UTF-8 characters > \x7f (RFC6532) (define-peg-pattern vchar body (and (not-followed-by (or (range #\Nul #\Space) - "\x7f")) + "\x7f")) peg-any)) (define-peg-pattern wsp body @@ -110,7 +110,7 @@ (define-syntax-rule (define-printable-ascii-character-pattern name . exceptions) (define-peg-pattern name body (and (not-followed-by (or . exceptions)) - vchar))) + vchar))) ;;; Quoted characters @@ -383,7 +383,7 @@ ;; TODO: What is a CTL in RFC2045? (define-peg-pattern token body (+ (and (not-followed-by (or " " crlf tspecials)) - peg-any))) + peg-any))) ;; TODO: Implement iana-token, ietf-token and x-token (define-peg-pattern iana-token body @@ -474,31 +474,31 @@ ;; RFC5322. (define-peg-pattern fields all (* (or trace - resent-date - resent-from - resent-sender - resent-to - resent-cc - resent-bcc - resent-msg-id - orig-date - from - sender - reply-to - to - cc - bcc - message-id - in-reply-to - references - subject - comments - keywords - mime-version - content - disposition - encoding - optional-field))) + resent-date + resent-from + resent-sender + resent-to + resent-cc + resent-bcc + resent-msg-id + orig-date + from + sender + reply-to + to + cc + bcc + message-id + in-reply-to + references + subject + comments + keywords + mime-version + content + disposition + encoding + optional-field))) (define-peg-pattern mime-extension-field-name all (and "Content-" (+ ftext))) @@ -508,25 +508,25 @@ (define-peg-pattern mime-entity-fields all (* (or content - disposition - encoding - mime-extension-field - optional-field))) + disposition + encoding + mime-extension-field + optional-field))) (define (decode-mime-encoded-word word) (regexp-substitute/global #f "=\\?([^?]*)\\?([^?]*)\\?([^?]*)\\?=" word 'pre (lambda (match-record) - (let ((charset (match:substring match-record 1)) - (encoding (string->lcase-symbol (match:substring match-record 2))) - (encoded-text (match:substring match-record 3))) - (bytevector->string - ((case encoding - ((b) base64-decode) - ((q) q-encoding-decode) - (else (error "Encoding of MIME word unknown" word))) - encoded-text) - charset))) + (let ((charset (match:substring match-record 1)) + (encoding (string->lcase-symbol (match:substring match-record 2))) + (encoded-text (match:substring match-record 3))) + (bytevector->string + ((case encoding + ((b) base64-decode) + ((q) q-encoding-decode) + (else (error "Encoding of MIME word unknown" word))) + encoded-text) + charset))) 'post)) (define (body->mime-entities body boundary) @@ -534,13 +534,13 @@ 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) <>)))) + (negate (cut string-prefix? (string-append "--" boundary) <>)))) (define (read-mime-entity port) (if (string-prefix? (string-append "--" boundary "--") - (get-line-with-delimiter port)) - (eof-object) - (read-till-boundary port))) + (get-line-with-delimiter port)) + (eof-object) + (read-till-boundary port))) (call-with-input-string body (lambda (port) @@ -552,12 +552,12 @@ explained in RFC2045), and return that list." (call-with-input-string email (lambda (port) (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)))))) + (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)))))) (define (post-process-content-transfer-encoding _ value) (list 'content-transfer-encoding (string->lcase-symbol value))) @@ -565,47 +565,47 @@ explained in RFC2045), and return that list." (define post-process-content-type (match-lambda* (`(content (type ,type) - (subtype ,subtype) - . ,parameters) + (subtype ,subtype) + . ,parameters) (let ((type (string->lcase-symbol type)) - (subtype (string->lcase-symbol subtype))) + (subtype (string->lcase-symbol subtype))) `(content-type - ,(acons* 'type type - 'subtype subtype - (let ((parameters - (map (match-lambda - (`(parameter (attribute ,attribute) - (value ,value)) - (cons (string->lcase-symbol attribute) value))) - (flatten-and-filter '(parameter) parameters)))) - (if (and (eq? type 'text) - (not (assoc-ref parameters 'charset))) - ;; UTF-8 is specified as the default charset in RFC6657 - (acons 'charset "utf-8" parameters) - parameters)))))))) + ,(acons* 'type type + 'subtype subtype + (let ((parameters + (map (match-lambda + (`(parameter (attribute ,attribute) + (value ,value)) + (cons (string->lcase-symbol attribute) value))) + (flatten-and-filter '(parameter) parameters)))) + (if (and (eq? type 'text) + (not (assoc-ref parameters 'charset))) + ;; UTF-8 is specified as the default charset in RFC6657 + (acons 'charset "utf-8" parameters) + parameters)))))))) (define post-process-content-disposition (match-lambda* (`(disposition ,type . ,parameters) `(content-disposition ,(acons 'type (string->lcase-symbol type) - (map (match-lambda - (('filename-parm ('value filename)) - (cons 'filename (basename filename))) - (((? (lambda (date-parm) - (member date-parm '(creation-date-parm modification-date-parm read-date-parm))) - date-parm) value) - ;; TODO: Convert to SRFI-19 datetime - (cons date-parm value)) - (('size-parm value) - (cons 'size (string->number value))) - (`(parameter (attribute ,attribute) - (value ,value)) - (cons (string->lcase-symbol attribute) value))) - (flatten-and-filter - '(filename-parm creation-date-parm modification-date-parm - read-date-parm size-parm parameter) - parameters))))))) + (map (match-lambda + (('filename-parm ('value filename)) + (cons 'filename (basename filename))) + (((? (lambda (date-parm) + (member date-parm '(creation-date-parm modification-date-parm read-date-parm))) + date-parm) value) + ;; TODO: Convert to SRFI-19 datetime + (cons date-parm value)) + (('size-parm value) + (cons 'size (string->number value))) + (`(parameter (attribute ,attribute) + (value ,value)) + (cons (string->lcase-symbol attribute) value))) + (flatten-and-filter + '(filename-parm creation-date-parm modification-date-parm + read-date-parm size-parm parameter) + parameters))))))) (define post-process-optional-field (match-lambda* @@ -613,7 +613,7 @@ explained in RFC2045), and return that list." (field-name ,field-name) ,field-value) (list (string->lcase-symbol field-name) - field-value)) + field-value)) (`(optional-field (field-name ,field-name)) (list field-name "")))) @@ -634,12 +634,12 @@ For example, (cond ((string-match "([^<]*)<([^>]*)>" address) => (lambda (match-record) - (let ((name (string-trim-both (match:substring match-record 1))) - (address (match:substring match-record 2))) - (if (string-null? name) - `((address . ,address)) - `((name . ,name) - (address . ,address)))))) + (let ((name (string-trim-both (match:substring match-record 1))) + (address (match:substring match-record 2))) + (if (string-null? name) + `((address . ,address)) + `((name . ,name) + (address . ,address)))))) (else `((address . ,address))))) (define interpret-address @@ -658,50 +658,50 @@ message. Else, return a single <mime-entity> record." (case (assoc-ref content-type 'type) ((multipart) (map parse-mime-entity - (body->mime-entities body (assoc-ref content-type 'boundary)))) + (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)))) + (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 ;; specified in RFC2045 (let ((default-headers - (acons* 'content-type '((type . text) - (subtype . plain) - ;; UTF-8 is specified as the default - ;; charset in RFC6657 - (charset . "utf-8")) - 'content-transfer-encoding '#{7bit}#))) + (acons* 'content-type '((type . text) + (subtype . plain) + ;; UTF-8 is specified as the default + ;; charset in RFC6657 + (charset . "utf-8")) + 'content-transfer-encoding '#{7bit}#))) (append (alist-delete* (append (if (assoc-ref headers 'content-type) - (list 'content-type) (list)) - (if (assoc-ref headers 'content-transfer-encoding) - (list 'content-transfer-encoding) (list))) - default-headers) - headers))) + (list 'content-type) (list)) + (if (assoc-ref headers 'content-transfer-encoding) + (list 'content-transfer-encoding) (list))) + default-headers) + headers))) (define (parse-mime-entity text) (let-values (((headers body) (email->headers+body text))) (let ((headers - (pre-post-order - (peg:tree - (match-pattern mime-entity-fields text)) - `((content . ,post-process-content-type) - (encoding . ,post-process-content-transfer-encoding) - (disposition . ,post-process-content-disposition) - (optional-field . ,post-process-optional-field) - (mime-entity-fields . ,(lambda (_ . mime-entity-fields) - (add-default-headers - (map (match-lambda - ((mime-entity-field value) - (cons mime-entity-field value)) - ((mime-entity-field . values) - (cons mime-entity-field values))) - mime-entity-fields)))) - (*text* . ,(lambda (_ text) text)) - (*default* . ,(lambda tree tree)))))) + (pre-post-order + (peg:tree + (match-pattern mime-entity-fields text)) + `((content . ,post-process-content-type) + (encoding . ,post-process-content-transfer-encoding) + (disposition . ,post-process-content-disposition) + (optional-field . ,post-process-optional-field) + (mime-entity-fields . ,(lambda (_ . mime-entity-fields) + (add-default-headers + (map (match-lambda + ((mime-entity-field value) + (cons mime-entity-field value)) + ((mime-entity-field . values) + (cons mime-entity-field values))) + mime-entity-fields)))) + (*text* . ,(lambda (_ text) text)) + (*default* . ,(lambda tree tree)))))) (make-mime-entity headers (parse-email-body headers body))))) (define (parse-email email) @@ -719,39 +719,39 @@ list of header keys and values." (peg:tree (match-pattern fields headers)) `((date-time . ,(lambda node - (match-let - ((`((day ,day) (month ,month) (year ,year) - (hours ,hours) (minutes ,minutes) (seconds ,seconds) - (zone-sign ,zone-sign) (zone-hours ,zone-hours) (zone-minutes ,zone-minutes)) - (flatten-and-filter - '(day month year hours minutes seconds - zone-sign zone-hours zone-minutes) - node))) - (make-date 0 - (string->number seconds) - (string->number minutes) - (string->number hours) - (string->number day) - (1+ (list-index - (cut equal? <> month) - (list "Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))) - (string->number year) - (* (case (string->symbol zone-sign) - ((+) 1) - ((-) -1)) - (+ (* 60 60 (string->number zone-hours)) - (* 60 (string->number zone-minutes)))))))) + (match-let + ((`((day ,day) (month ,month) (year ,year) + (hours ,hours) (minutes ,minutes) (seconds ,seconds) + (zone-sign ,zone-sign) (zone-hours ,zone-hours) (zone-minutes ,zone-minutes)) + (flatten-and-filter + '(day month year hours minutes seconds + zone-sign zone-hours zone-minutes) + node))) + (make-date 0 + (string->number seconds) + (string->number minutes) + (string->number hours) + (string->number day) + (1+ (list-index + (cut equal? <> month) + (list "Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))) + (string->number year) + (* (case (string->symbol zone-sign) + ((+) 1) + ((-) -1)) + (+ (* 60 60 (string->number zone-hours)) + (* 60 (string->number zone-minutes)))))))) (orig-date . ,(lambda (_ date) (list 'date date))) (angle-addr . ,extract-value) (mailbox . ,(match-lambda* - (`(mailbox (display-name ,name) ,address) - `((name . ,(decode-mime-encoded-word - (string-trim-both name))) - (address . ,address))) - (`(mailbox ,address) - `((address . ,(string-trim-both address)))) - (_ (error "Failed to parse mailbox")))) + (`(mailbox (display-name ,name) ,address) + `((name . ,(decode-mime-encoded-word + (string-trim-both name))) + (address . ,address))) + (`(mailbox ,address) + `((address . ,(string-trim-both address)))) + (_ (error "Failed to parse mailbox")))) (address-list *macro* . ,macro-process-address-list) (mailbox-list *macro* . ,macro-process-address-list) (optional-field . ,post-process-optional-field) @@ -760,45 +760,45 @@ list of header keys and values." (encoding . ,post-process-content-transfer-encoding) (disposition . ,post-process-content-disposition) (fields . ,(lambda (_ . fields) - (add-default-headers - (filter-map (match-lambda - (('trace . _) #f) - ((field value) - (cons field value)) - ((field . values) - (cons field values)) - (_ #f)) - fields)))) + (add-default-headers + (filter-map (match-lambda + (('trace . _) #f) + ((field value) + (cons field value)) + ((field . values) + (cons field values)) + (_ #f)) + fields)))) (*text* . ,extract-value) (*default* . ,(lambda tree tree))))) (define* (decode-body body encoding #:optional charset) (let ((octets - (case encoding - ((base64) - (base64-decode - (string-filter - (char-set-union - (ucs-range->char-set (char->integer #\a) (1+ (char->integer #\z))) - (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)) - ((#{7bit}# #{8bit}# binary) body) - (else (error "Body decoding failed. Unknown encoding" encoding))))) + (case encoding + ((base64) + (base64-decode + (string-filter + (char-set-union + (ucs-range->char-set (char->integer #\a) (1+ (char->integer #\z))) + (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)) + ((#{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))) + (case encoding + ((base64 quoted-printable) (bytevector->string octets charset)) + ((#{7bit}# #{8bit}# binary) octets)) + octets))) (define (read-next-email-in-mbox port) ;; Read and discard From_ line (get-line-with-delimiter port) ;; Read the actual email (read-while port get-line-with-delimiter - (negate (cut string-prefix? "From " <>)))) + (negate (cut string-prefix? "From " <>)))) (define (mbox->emails port) (read-objects read-next-email-in-mbox port)) |