diff options
Diffstat (limited to 'email')
| -rw-r--r-- | email/base64.scm | 16 | ||||
| -rw-r--r-- | email/email.scm | 398 | ||||
| -rw-r--r-- | email/quoted-printable.scm | 68 | ||||
| -rw-r--r-- | email/utils.scm | 46 |
4 files changed, 264 insertions, 264 deletions
diff --git a/email/base64.scm b/email/base64.scm index 6b11b3f..94b7388 100644 --- a/email/base64.scm +++ b/email/base64.scm @@ -142,9 +142,9 @@ (put p #\=))))))) (extract))))) - ;; Decodes a base64 string. The string must contain only pure - ;; unpadded base64 data. - +;; Decodes a base64 string. The string must contain only pure +;; unpadded base64 data. + (define base64-decode (case-lambda ((str) @@ -199,11 +199,11 @@ (eof-object) (f (get-line port)))) - ;; Reads the common -----BEGIN/END type----- delimited format from - ;; the given port. Returns two values: a string with the type and a - ;; bytevector containing the base64 decoded data. The second value - ;; is the eof object if there is an eof before the BEGIN delimiter. - +;; Reads the common -----BEGIN/END type----- delimited format from +;; the given port. Returns two values: a string with the type and a +;; bytevector containing the base64 decoded data. The second value +;; is the eof object if there is an eof before the BEGIN delimiter. + (define (get-delimited-base64 port) (define (get-first-data-line port) ;; Some MIME data has header fields in the same format as mail 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)) diff --git a/email/quoted-printable.scm b/email/quoted-printable.scm index d084a7e..b6f4c54 100644 --- a/email/quoted-printable.scm +++ b/email/quoted-printable.scm @@ -23,8 +23,8 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-26) #:export (quoted-printable-decode - quoted-printable-encode - q-encoding-decode)) + quoted-printable-encode + q-encoding-decode)) ;; TODO: Error out on invalid quoted-printable input (define quoted-printable-decode @@ -33,30 +33,30 @@ (call-with-input-string str quoted-printable-decode)) (((? port? in)) (let-values (((out get-bytevector) - (open-bytevector-output-port))) + (open-bytevector-output-port))) (call-with-port - out (lambda (out) - (quoted-printable-decode in out) - (get-bytevector))))) + out (lambda (out) + (quoted-printable-decode in out) + (get-bytevector))))) (((? port? in) (? port? out)) (let ((c (read-char in))) (cond - ((eof-object? c) out) - ((char=? c #\=) - ;; TODO: Support "\r\n" line ending - (let ((c1 (read-char in))) - (unless (char=? c1 #\Newline) - (let ((c2 (read-char in))) - (put-u8 out (string->number (string c1 c2) 16))))) - (quoted-printable-decode in out)) - (else (put-u8 out (char->integer c)) - (quoted-printable-decode in out))))))) + ((eof-object? c) out) + ((char=? c #\=) + ;; TODO: Support "\r\n" line ending + (let ((c1 (read-char in))) + (unless (char=? c1 #\Newline) + (let ((c2 (read-char in))) + (put-u8 out (string->number (string c1 c2) 16))))) + (quoted-printable-decode in out)) + (else (put-u8 out (char->integer c)) + (quoted-printable-decode in out))))))) (define quoted-printable-encode (match-lambda* (((? bytevector? bv)) (call-with-port (open-bytevector-input-port bv) - quoted-printable-encode)) + quoted-printable-encode)) (((? port? in)) (call-with-output-string (cut quoted-printable-encode in <>))) @@ -64,24 +64,24 @@ (quoted-printable-encode in out 76)) (((? port? in) (? port? out) (? integer? number-of-chars-left-on-this-line)) (let ((x (get-u8 in)) - (put-into-output - (lambda (str) - (let* ((len (string-length str)) - (break-line? (<= number-of-chars-left-on-this-line len))) - (put-string - out (string-append (if break-line? "=\n" "") str)) - (if break-line? - (- 76 len) - (- number-of-chars-left-on-this-line len)))))) + (put-into-output + (lambda (str) + (let* ((len (string-length str)) + (break-line? (<= number-of-chars-left-on-this-line len))) + (put-string + out (string-append (if break-line? "=\n" "") str)) + (if break-line? + (- 76 len) + (- number-of-chars-left-on-this-line len)))))) (unless (eof-object? x) - (let ((c (integer->char x))) - (quoted-printable-encode - in out - (put-into-output - (if (char-set-contains? - (char-set-delete char-set:ascii #\newline #\return) c) - (string c) - (format #f "=~:@(~2,'0x~)" x)))))))))) + (let ((c (integer->char x))) + (quoted-printable-encode + in out + (put-into-output + (if (char-set-contains? + (char-set-delete char-set:ascii #\newline #\return) c) + (string c) + (format #f "=~:@(~2,'0x~)" x)))))))))) (define (q-encoding-decode str) (quoted-printable-decode diff --git a/email/utils.scm b/email/utils.scm index 7d51ebb..e942fc2 100644 --- a/email/utils.scm +++ b/email/utils.scm @@ -23,18 +23,18 @@ #:use-module (ice-9 textual-ports) #:use-module (rnrs io simple) #:export (get-line-with-delimiter - read-objects - read-while - acons* - alist-delete*)) + read-objects + read-while + acons* + alist-delete*)) (define (read-objects read-proc port) "Read all objects using READ-PROC from PORT and return them as a list." (let ((x (read-proc port))) (if (eof-object? x) - (list) - (cons x (read-objects read-proc port))))) + (list) + (cons x (read-objects read-proc port))))) (define* (read-while port read-proc pred) "Read from PORT using READ-PROC while PRED returns #t. READ-PROC is @@ -45,8 +45,8 @@ string returned by READ-PROC as argument." (cond ((eof-object? x) x) ((pred x) - (put-string output x) - (read-while-loop output)) + (put-string output x) + (read-while-loop output)) (#t (unget-string port x))))) (let ((str (call-with-output-string read-while-loop))) @@ -57,8 +57,8 @@ string returned by READ-PROC as argument." delimiting linefeed character." (let ((line (get-line port))) (if (eof-object? line) - line - (string-append line "\n")))) + line + (string-append line "\n")))) (define acons* (match-lambda* @@ -72,24 +72,24 @@ delimiting linefeed character." "Return a list containing all elements of ALIST whose keys are not a member of KEYS." (filter (match-lambda - ((key . _) - (not (member key keys)))) - alist)) + ((key . _) + (not (member key keys)))) + alist)) (define (cg-string-ci pat accum) (syntax-case pat () ((pat-str-syntax) (string? (syntax->datum #'pat-str-syntax)) (let ((pat-str (syntax->datum #'pat-str-syntax))) (let ((plen (string-length pat-str))) - #`(lambda (str len pos) - (let ((end (+ pos #,plen))) - (and (<= end len) - (string-ci= str #,pat-str pos end) - #,(case accum - ((all) #`(list end (list 'cg-string #,pat-str))) - ((name) #`(list end 'cg-string)) - ((body) #`(list end #,pat-str)) - ((none) #`(list end '())) - (else (error "bad accum" accum))))))))))) + #`(lambda (str len pos) + (let ((end (+ pos #,plen))) + (and (<= end len) + (string-ci= str #,pat-str pos end) + #,(case accum + ((all) #`(list end (list 'cg-string #,pat-str))) + ((name) #`(list end 'cg-string)) + ((body) #`(list end #,pat-str)) + ((none) #`(list end '())) + (else (error "bad accum" accum))))))))))) (add-peg-compiler! 'string-ci cg-string-ci) |