aboutsummaryrefslogtreecommitdiff
path: root/email/email.scm
diff options
context:
space:
mode:
authorArun Isaac2018-09-12 17:52:08 +0530
committerArun Isaac2018-09-12 17:55:19 +0530
commit2784c121d5a3c9d8e7831c883edac3b6857bc198 (patch)
treeca03f80a787a3502524257277321c2b647e78632 /email/email.scm
parent959941b87c2e7ba732cae8ad1943432dfba83427 (diff)
downloadguile-email-2784c121d5a3c9d8e7831c883edac3b6857bc198.tar.gz
guile-email-2784c121d5a3c9d8e7831c883edac3b6857bc198.tar.lz
guile-email-2784c121d5a3c9d8e7831c883edac3b6857bc198.zip
Untabify and re-indent all sources.
* build-aux/test-driver.scm, email/base64.scm, email/email.scm, email/quoted-printable.scm, email/utils.scm, tests/quoted-printable.scm: Untabify and re-indent.
Diffstat (limited to 'email/email.scm')
-rw-r--r--email/email.scm398
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))