diff options
| -rw-r--r-- | assets/css/screen.css | 22 | ||||
| -rw-r--r-- | mumi/messages.scm | 188 | ||||
| -rw-r--r-- | mumi/web/view/html.scm | 2 | ||||
| -rw-r--r-- | mumi/web/view/utils.scm | 58 |
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))))) |