summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--assets/css/screen.css22
-rw-r--r--mumi/messages.scm188
-rw-r--r--mumi/web/view/html.scm2
-rw-r--r--mumi/web/view/utils.scm58
4 files changed, 265 insertions, 5 deletions
diff --git a/assets/css/screen.css b/assets/css/screen.css
index 21c55a4..9021320 100644
--- a/assets/css/screen.css
+++ b/assets/css/screen.css
@@ -155,6 +155,23 @@ input#query {
border: none;
}
+.message .body .multipart {
+ padding-bottom: 1rem;
+}
+
+.message .body .multipart + .multipart {
+ padding-top: 1rem;
+ padding-bottom: 1rem;
+ border-top: 1px dashed #ddd;
+}
+
+.multipart.application-pgp-signature {
+ display: none;
+}
+
+.multipart.text-x-patch {
+}
+
.message .from .address {
font-weight: bold;
}
@@ -221,3 +238,8 @@ input#query {
.status-tag.open {
background: #2cbe4e;
}
+
+.error.parse {
+ font-style: italic;
+ font-size: 0.8em;
+}
diff --git a/mumi/messages.scm b/mumi/messages.scm
index 9614852..e6edfe0 100644
--- a/mumi/messages.scm
+++ b/mumi/messages.scm
@@ -22,13 +22,20 @@
#:use-module (ice-9 optargs)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
+ #:use-module (ice-9 textual-ports)
#:use-module (debbugs soap)
#:use-module (debbugs operations)
#:use-module (debbugs email)
#:use-module (debbugs bug)
+ #:use-module (debbugs rfc822)
#:use-module (mumi config)
#:use-module (mailutils mailutils)
- #:export (search-bugs fetch-bug recent-bugs))
+ #:export (search-bugs
+ fetch-bug
+ recent-bugs
+
+ split-multipart-message
+ multipart-message?))
;; TODO: mu-address-get-personal skips non ASCII characters
;; ex: (mu-address-get-personal "ludo@gnu.org (Ludovic Courtès)")
@@ -86,12 +93,189 @@
(define-public (internal-message? message)
(bot? (sender-email message)))
+
+;; Taken from (debbugs rfc822).
+(define* (read-token predicate #:optional (port (current-input-port)))
+ "Read characters from PORT and call the procedure PREDICATE with
+each character until PREDICATE returns #F. Return a string with the
+accumulated characters."
+ (let ((r (open-output-string)))
+ (define (finish) (get-output-string r))
+ (let loop ((c (peek-char port)))
+ (cond ((eof-object? c) (finish))
+ ((predicate c)
+ (write-char (read-char port) r)
+ (loop (peek-char port)))
+ (else (finish))))))
+
+(define* (read-until delimiter #:optional (port (current-input-port)))
+ "Return the string up to DELIMITER. Also read DELIMITER and throw
+it away."
+ (let ((result (read-token (lambda (char) (not (char=? char delimiter))) port)))
+ (read-token (cut char=? <> delimiter) port)
+ result))
+
+(define* (read-between delimiter #:optional (port (current-input-port)))
+ "Return the string after DELIMITER and before DELIMITER from PORT."
+ (read-token (cut char=? <> delimiter) port)
+ (read-until delimiter port))
+
+(define* (read-key-value-pair #:optional (port (current-input-port)))
+ "Read a single key value pair from PORT. The key is separated from
+the value by an equal sign. The value may be wrapped in double
+quotes. The pair must end with a semicolon."
+ (let* ((key (read-until #\= port))
+ (val (if (char=? (peek-char port) #\")
+ (let ((return (read-between #\" port)))
+ (read-until #\; port)
+ return)
+ (read-until #\; port))))
+ (cons (string-downcase key) val)))
+
+(define (throw-away char-pred)
+ "Return a procedure that reads and discards any number of characters
+for which the predicate CHAR-PRED returns #T from a port."
+ (lambda* (#:optional (port (current-input-port)))
+ (while (char-pred (peek-char port))
+ (read-token char-pred port))))
+
+(define (parse-multipart-header port)
+ "Read a multipart header string from PORT and return an alist of
+attributes."
+ (let loop ((acc `(("type" . ,(read-until #\; port)))))
+ (if (eof-object? (peek-char port))
+ acc
+ (begin
+ ((throw-away char-whitespace?) port)
+ (loop (cons (read-key-value-pair port) acc))))))
+
+(define (multipart-header? line)
+ "Return the attributes of the provided Content-Type header value."
+ (and (string? line)
+ (string-prefix? "multipart" line)
+ (call-with-input-string line parse-multipart-header)))
+
+(define (multipart-message? message)
+ (multipart-header? (header message "content-type")))
+
+(define (qp-decoder port)
+ "Read a quoted-printable line from PORT and return the decoded
+string."
+ (let ((decoder-port (mu-decoder-port port "quoted-printable")))
+ (with-output-to-string
+ (lambda ()
+ (let loop ((line (get-line decoder-port)))
+ (cond
+ ((eof-object? line) #t)
+ (else
+ (display line)
+ (newline)
+ (loop (get-line decoder-port)))))))))
+
+(define (decode headers str)
+ "Decode the string STR according to the encoding specified in
+HEADERS."
+ (if (and=> (assoc-ref headers "content-transfer-encoding")
+ (lambda (values)
+ (string-contains (first values) "quoted-printable")))
+ (with-input-from-string str
+ (lambda () (qp-decoder (current-input-port))))
+ str))
+
+(define* (collect-parts boundary port #:key nested?)
+ "Read multipart message parts from PORT and return them as a list of
+containing #:headers and #:body. If NESTED? is #T look for nested
+multipart messages."
+ (define final-boundary (string-append boundary "--"))
+ (let loop ((headers (rfc822-header->list port))
+ (line (get-line port))
+ (current-part '())
+ (parts '()))
+ (cond
+ ((or (string=? line final-boundary)
+ (eof-object? line))
+ ;; We're done!
+ (reverse (cons `(#:headers ,headers
+ #:body ,(decode headers
+ (string-join (reverse current-part) "\n")))
+ parts)))
+ ((string=? boundary line)
+ ;; End of this part
+ (let ((next-headers (rfc822-header->list port))
+ (next-line (get-line port)))
+ (loop next-headers
+ next-line
+ '()
+ (cons `(#:headers ,headers
+ #:body ,(decode headers
+ (string-join (reverse current-part) "\n")))
+ parts))))
+ ;; New part beginning with an in-body multipart
+ ;; header.
+ ((and nested?
+ (null? current-part)
+ (and=> (assoc-ref headers "content-type")
+ (match-lambda
+ (() #f)
+ ((val) (multipart-header? val)))))
+ => (lambda (attributes)
+ ;; Parse multipart body.
+ (let ((embedded-parts
+ (let* ((boundary (string-append "--"
+ (assoc-ref attributes "boundary")))
+ (final-boundary (string-append boundary "--")))
+ (if (string=? boundary line)
+ (collect-parts boundary port)
+ ;; Invalid multipart message
+ '()))))
+ ;; TODO: there might be some white space after the end of
+ ;; this embedded multipart message. Not sure what to do
+ ;; with it, though.
+ (loop '()
+ (get-line port)
+ '()
+ (cons `(#:headers ,headers
+ #:body ,(decode headers
+ embedded-parts))
+ parts)))))
+ ;; Just a boring old message body: add the line to
+ ;; the current part.
+ (else
+ (loop headers
+ (get-line port)
+ (cons line current-part)
+ parts)))))
+
+;; A multipart message may contain a body that is a multipart message
+;; itself. This is signalized by a Content-Type header on the first
+;; line after the boundary.
+(define (split-multipart-message attributes message)
+ "Return list of message parts contained in the multipart MESSAGE.
+The ATTRIBUTES alist must contain the boundary string and the
+multipart type, among other things. A message part is either a list
+of strings, or if the body itself contains a multipart message a lists
+of message parts."
+ (let ((boundary (string-append "--"
+ (assoc-ref attributes "boundary"))))
+ (call-with-input-string (email-body message)
+ (lambda (port)
+ ;; Ignore everything up to the first boundary string.
+ (let ((found (let loop ((line (get-line port)))
+ (cond
+ ((eof-object? line) #f)
+ ((string=? boundary line) #t)
+ (else (loop (get-line port)))))))
+ (if found
+ (collect-parts boundary port #:nested? #t)
+ ;; Invalid multipart message
+ '()))))))
+
+
(define-public (patch-messages id)
"Return list of messages relating to the bug ID."
;; TODO: sort by date necessary?
(soap-invoke* (%config 'debbugs) get-bug-log id))
-
(define* (search-bugs query #:key (attributes '()) (max 100))
"Return a list of all bugs matching the given QUERY string."
(let* ((matches (soap-invoke* (%config 'debbugs)
diff --git a/mumi/web/view/html.scm b/mumi/web/view/html.scm
index 4d8a1e1..bb52376 100644
--- a/mumi/web/view/html.scm
+++ b/mumi/web/view/html.scm
@@ -184,7 +184,7 @@
,(message-id message))))
(div
(@ (class "body panel-body"))
- ,(prettify (email-body message))))))
+ ,(display-message-body message)))))
,@(if (closing? message id)
'((div
(@ (class "row event"))
diff --git a/mumi/web/view/utils.scm b/mumi/web/view/utils.scm
index 73a5969..4277ce8 100644
--- a/mumi/web/view/utils.scm
+++ b/mumi/web/view/utils.scm
@@ -17,9 +17,13 @@
(define-module (mumi web view utils)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (debbugs email)
+ #:use-module (mumi messages)
#:export (prettify
- avatar-color))
+ avatar-color
+ display-message-body))
;; TODO: at some point this should tokenize the text, then apply
;; styles, then output sxml, but for now we keep it simple
@@ -61,7 +65,9 @@
(if (eof-object? line)
;; Drop the first line break, because it's for an eof
;; read.
- (cdr (reverse result))
+ (match (reverse result)
+ ((_ . rest) rest)
+ (() '()))
(loop (read-line port)
(cons (process line)
(cons '(br) result))))))))
@@ -76,3 +82,51 @@
(or (and=> (assoc-ref (zip participants colors) who)
first)
(first colors)))
+
+(define (content-type->css-class value)
+ "Convert a content-type header value to a CSS class name."
+ (string-map (lambda (chr)
+ (cond
+ ((char-set-contains? char-set:letter chr) chr)
+ (else #\-)))
+ (string-take value (or (string-index value #\;)
+ (string-length value)))))
+
+(define (display-multipart-chunk headers body)
+ (let ((classes
+ (string-join `("multipart"
+ ,(or (and=> (assoc-ref headers "content-type")
+ (lambda (value)
+ (content-type->css-class (first value))))
+ "")))))
+ `(div (@ (class ,classes))
+ ,(prettify body))))
+
+(define (display-message-body message)
+ "Convenience procedure to render MESSAGE, even when it is a
+multipart message."
+ (cond
+ ((multipart-message? message)
+ => (lambda (attributes)
+ (match (split-multipart-message attributes message)
+ (()
+ (cons
+ `(p (@ (class "error parse"))
+ "[Failed to process the following multipart message. Sorry!]")
+ (prettify (email-body message))))
+ (parts
+ (map (match-lambda
+ (() "")
+ ((#:headers hs #:body '()) "")
+ ((#:headers hs #:body (? string? body))
+ (display-multipart-chunk hs body))
+ ;; Message parts can be nested.
+ ((#:headers hs #:body sub-parts)
+ (map (match-lambda
+ ((#:headers hs #:body body)
+ (display-multipart-chunk hs body)))
+ sub-parts)))
+ parts)))))
+ ;; Regular message with a simple body.
+ (else
+ (prettify (email-body message)))))