diff options
| -rw-r--r-- | email/email.scm | 64 |
1 files changed, 50 insertions, 14 deletions
diff --git a/email/email.scm b/email/email.scm index df69394..16838d9 100644 --- a/email/email.scm +++ b/email/email.scm @@ -124,14 +124,20 @@ (define-printable-ascii-character-pattern ctext "(" ")" "\\") -(define-peg-pattern comment none - (and "(" (* (and (? fws) ccontent)) ")")) +(define-syntax-rule (define-comment-pattern name capture-type) + (define-peg-pattern name capture-type + (and (ignore "(") (* (and (? fws) ccontent)) (ignore ")")))) + +(define-comment-pattern comment none) (define-peg-pattern ccontent body (or ctext quoted-pair comment)) -(define-peg-pattern cfws body - (or (and (+ (and (? fws) comment)) (? fws)) fws)) +(define-syntax-rule (define-cfws-pattern name comment) + (define-peg-pattern name body + (or (and (+ (and (? fws) comment)) (? fws)) fws))) + +(define-cfws-pattern cfws comment) ;;; Atom @@ -144,8 +150,11 @@ (define-peg-pattern dot-atom-text body (and (+ atext) (* (and "." (+ atext))))) -(define-peg-pattern dot-atom body - (and (? cfws) dot-atom-text (? cfws))) +(define-syntax-rule (define-dot-atom-pattern name cfws) + (define-peg-pattern name body + (and (? cfws) dot-atom-text (? cfws)))) + +(define-dot-atom-pattern dot-atom cfws) ;;; Quoted strings @@ -247,11 +256,17 @@ (define-peg-pattern domain-literal body (and (? cfws) "[" (* (and (? fws) dtext)) (? fws) "]" (? cfws))) -(define-peg-pattern domain body - (or dot-atom domain-literal)) +(define-syntax-rule (define-domain-pattern name dot-atom) + (define-peg-pattern name body + (or dot-atom domain-literal))) + +(define-domain-pattern domain dot-atom) + +(define-syntax-rule (define-addr-spec-pattern name domain) + (define-peg-pattern name body + (and local-part "@" domain))) -(define-peg-pattern addr-spec body - (and local-part "@" domain)) +(define-addr-spec-pattern addr-spec domain) (define-syntax-rule (define-angle-addr-pattern name opening-bracket closing-bracket) @@ -278,8 +293,20 @@ (define-peg-pattern name-addr body (and (? display-name) unbracketed-angle-addr)) +;; In order to support emacs message mode parens style email +;; addresses, we need to capture comments in address fields and +;; process them as names. But, we need to ignore comments in other +;; parts of the email. In order to facilitate this, we define a set of +;; captured-* patterns which are used in address fields. + +(define-comment-pattern captured-comment all) +(define-cfws-pattern captured-cfws captured-comment) +(define-dot-atom-pattern captured-dot-atom captured-cfws) +(define-domain-pattern captured-domain captured-dot-atom) +(define-addr-spec-pattern captured-addr-spec captured-domain) + (define-peg-pattern mailbox all - (or name-addr addr-spec)) + (or name-addr captured-addr-spec)) (define-peg-pattern mailbox-list all (and mailbox (* (and (ignore ",") mailbox)))) @@ -580,15 +607,24 @@ explained in RFC2045), and return that list." (read-while port get-line-with-delimiter identity)))))) (define (post-process-mailbox . args) + (define process-name + (compose decode-mime-encoded-word string-trim-both)) + (match args ;; name-addr email address (`(mailbox (display-name ,name) ,address) - `((name . ,(decode-mime-encoded-word - (string-trim-both name))) + `((name . ,(process-name name)) (address . ,(string-trim-both address)))) ;; addr-spec email address - (`(mailbox ,address) + (`(mailbox ,(? string? address)) `((address . ,(string-trim-both address)))) + ;; emacs message mode parens style email address + (`(mailbox ,(? list? address-parts)) + `((name . ,(match-let ((`((captured-comment ,name)) + (flatten-and-filter '(captured-comment) address-parts))) + (process-name name))) + (address . ,(string-trim-both + (string-join (drop-right address-parts 1) ""))))) (_ (error "Failed to parse mailbox")))) (define (post-process-content-transfer-encoding _ value) |