summaryrefslogtreecommitdiff
path: root/email/email.scm
diff options
context:
space:
mode:
Diffstat (limited to 'email/email.scm')
-rw-r--r--email/email.scm46
1 files changed, 23 insertions, 23 deletions
diff --git a/email/email.scm b/email/email.scm
index 6ad2d93..2c9dea4 100644
--- a/email/email.scm
+++ b/email/email.scm
@@ -562,6 +562,23 @@ explained in RFC2045), and return that list."
(values headers
(read-while port get-line-with-delimiter identity))))))
+(define (post-process-mailbox . args)
+ (define (trim-address address)
+ (string-trim-right
+ (string-trim (string-trim-both address) #\<)
+ #\>))
+
+ (match args
+ ;; name-addr email address
+ (`(mailbox (display-name ,name) ,address)
+ `((name . ,(decode-mime-encoded-word
+ (string-trim-both name)))
+ (address . ,(trim-address address))))
+ ;; addr-spec email address
+ (`(mailbox ,address)
+ `((address . ,(trim-address address))))
+ (_ (error "Failed to parse mailbox"))))
+
(define (post-process-content-transfer-encoding _ value)
(list 'content-transfer-encoding (string->lcase-symbol value)))
@@ -634,16 +651,11 @@ For example,
=> ((name . \"Foo\") (address . \"foo@example.org\"))
(parse-email-address \"foo@example.org\")
=> ((address . \"foo@example.org\"))"
- (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))))))
- (else `((address . ,address)))))
+ (pre-post-order
+ (peg:tree (match-pattern mailbox address))
+ `((mailbox . ,post-process-mailbox)
+ (*text* . ,(lambda (_ text) text))
+ (*default* . ,(lambda tree tree)))))
(define interpret-address
(match-lambda
@@ -716,11 +728,6 @@ message. Else, return a single <mime-entity> record."
(define (parse-email-headers headers)
"Parse string HEADERS as email headers and return an association
list of header keys and values."
- (define (trim-address address)
- (string-trim-right
- (string-trim (string-trim-both address) #\<)
- #\>))
-
(pre-post-order
(peg:tree
(match-pattern fields headers))
@@ -749,14 +756,7 @@ list of header keys and values."
(+ (* 60 60 (string->number zone-hours))
(* 60 (string->number zone-minutes))))))))
(orig-date . ,(lambda (_ date) (list 'date date)))
- (mailbox . ,(match-lambda*
- (`(mailbox (display-name ,name) ,address)
- `((name . ,(decode-mime-encoded-word
- (string-trim-both name)))
- (address . ,(trim-address address))))
- (`(mailbox ,address)
- `((address . ,(trim-address address))))
- (_ (error "Failed to parse mailbox"))))
+ (mailbox . ,post-process-mailbox)
(address-list *macro* . ,macro-process-address-list)
(mailbox-list *macro* . ,macro-process-address-list)
(optional-field . ,post-process-optional-field)