Handle nested mime entries recursively.
[software/mumi.git] / mumi / web / view / utils.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
3 ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
4 ;;;
5 ;;; This program is free software: you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Affero General Public License
7 ;;; as published by the Free Software Foundation, either version 3 of
8 ;;; the License, or (at your option) any later version.
9 ;;;
10 ;;; This program is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Affero General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Affero General Public
16 ;;; License along with this program. If not, see
17 ;;; <http://www.gnu.org/licenses/>.
18
19 (define-module (mumi web view utils)
20 #:use-module (ice-9 rdelim)
21 #:use-module (ice-9 match)
22 #:use-module (ice-9 regex)
23 #:use-module (ice-9 receive)
24 #:use-module (srfi srfi-1)
25 #:use-module (srfi srfi-26)
26 #:use-module (syntax-highlight)
27 #:use-module (syntax-highlight scheme)
28 #:use-module (email email)
29 #:use-module (mumi messages)
30 #:export (prettify
31 avatar-color
32 display-message-body))
33
34 ;; TODO: at some point this should tokenize the text, then apply
35 ;; styles, then output sxml, but for now we keep it simple
36 (define (process line context)
37 (cond
38 ((string-prefix? "--8<---------------cut here" line)
39 (values `(span (@ (class "line cut-here")) ,line) #f))
40 ((and (member 'diff context)
41 (string= "---" line))
42 (values `(span (@ (class "line diff separator")) ,line) #f))
43 ((string-prefix? "diff --git" line)
44 (values `(span (@ (class "line diff file")) ,line) 'diff))
45 ((and (member 'diff context)
46 (string-prefix? "+" line))
47 (values `(span (@ (class "line diff addition")) ,line) #f))
48 ((and (member 'diff context)
49 (string-prefix? "-" line)
50 (not (string= "--" line))
51 (not (string= "-- " line)))
52 (values `(span (@ (class "line diff deletion")) ,line) #f))
53 ((and (member 'diff context)
54 (string-prefix? "@@" line))
55 (values `(span (@ (class "line diff range")) ,line) #f))
56 ((string-prefix? ">" line)
57 (values `(span (@ (class "line quote")) ,line) #f))
58 ((or (string-prefix? "Signed-off-by" line)
59 (string-prefix? "Co-authored-by" line))
60 (values `(span (@ (class "commit attribution")) ,line) #f))
61 ((or (string-prefix? "From: " line)
62 (string-prefix? "Date: " line)
63 (string-prefix? "Subject: " line))
64 (values `(span (@ (class "commit header")) ,line) 'commit))
65 ((and (member 'commit context)
66 (or (string-prefix? "* " line)
67 (string-prefix? " * " line)))
68 (values `(span (@ (class "commit changelog")) ,line) #f))
69 (else
70 (values `(span (@ (class "line")) ,line) #f))))
71
72 (define (prettify text)
73 "Read each line of TEXT and apply PROCESS to it."
74 (let ((res (fold (lambda (line acc)
75 (match acc
76 ((#:result res #:context context)
77 (receive (processed new-context)
78 (process line context)
79 `(#:result ,(append (list processed '(br)) res)
80 #:context ,(if new-context
81 (cons new-context context)
82 context))))))
83 '(#:result () #:context ())
84 (string-split text #\newline))))
85 ;; Drop the first line break, because it's for an eof
86 ;; read.
87 (match (reverse (cadr (find-tail (cut eq? #:result <>) res)))
88 ((_ . rest) rest)
89 (() '()))))
90
91 (define colors
92 (circular-list "#8dd3c7" "#bebada" "#fb8072"
93 "#80b1d3" "#fdb462" "#b3de69"
94 "#fccde5" "#d9d9d9" "#bc80bd"
95 "#ccebc5" "#ffed6f"))
96
97 (define (avatar-color who participants)
98 (or (and=> (assoc-ref (zip participants colors) who)
99 first)
100 (first colors)))
101
102 (define (content-type->css-class value)
103 "Convert a content-type header value to a CSS class name."
104 (string-append (symbol->string (assoc-ref value 'type))
105 "-"
106 (symbol->string (assoc-ref value 'subtype))))
107
108 (define (display-message-body bug-num message-number message)
109 "Convenience procedure to render MESSAGE (part of bug with number
110 BUG-NUM), even when it is a multipart message."
111 (define (display-multipart-chunk headers body path)
112 (define (attachment-url)
113 (string-append "/issue/"
114 (number->string bug-num)
115 "/attachment/"
116 (number->string message-number)
117 "/" (string-join (map number->string path) "/")))
118 (let* ((content-type (assoc-ref headers 'content-type))
119 (attachment?
120 (and (and=> (assoc-ref headers 'content-disposition)
121 (cut assoc-ref <> 'type))
122 content-type
123 (assoc-ref content-type 'type)))
124 (binary-attachment? (and attachment?
125 (eq? (assoc-ref content-type 'type) 'application)))
126 (attachment-name
127 (or (and=> (assoc-ref headers 'content-disposition)
128 (cut assoc-ref <> 'filename))
129 "file")))
130 (cond
131 (binary-attachment?
132 `(div (@ (class "attachment"))
133 "Attachment: "
134 (a (@ (href ,(attachment-url))) ,attachment-name)))
135 ((string-suffix? ".scm" attachment-name)
136 `(div (@ (class "multipart scheme"))
137 (div (@ (class "download-part"))
138 (a (@ (href ,(attachment-url)))
139 "Download"))
140 ,(highlights->sxml (highlight lex-scheme body))))
141 (else
142 `(div (@ (class ,(string-join
143 (list "multipart" (or (and content-type
144 (content-type->css-class content-type))
145 "")))))
146 (div (@ (class "download-part"))
147 (a (@ (href ,(attachment-url)))
148 "Download"))
149 ,(prettify body))))))
150 (define (display-mime-entity entity . path)
151 (match entity
152 (($ <mime-entity> headers (? string? body))
153 (apply display-multipart-chunk `(,headers ,body ,path)))
154 ;; Message parts can be nested.
155 (($ <mime-entity> headers sub-parts)
156 (map (lambda (part sub-part-num)
157 (apply display-mime-entity part
158 (append path (list sub-part-num))))
159 sub-parts
160 (iota (length sub-parts))))))
161 (cond
162 ((multipart-message? message)
163 (let ((parts (email-body message)))
164 (map (lambda (part part-num)
165 (display-mime-entity part part-num))
166 parts
167 (iota (length parts)))))
168 ;; Regular message with a simple body.
169 (else
170 (prettify (email-body message)))))