css: Draw multipart separator also when following an attachment.
[software/mumi.git] / mumi / web / view / utils.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
3 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
4 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
5 ;;;
6 ;;; This program is free software: you can redistribute it and/or
7 ;;; modify it under the terms of the GNU Affero General Public License
8 ;;; as published by the Free Software Foundation, either version 3 of
9 ;;; the License, or (at your option) any later version.
10 ;;;
11 ;;; This program is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Affero General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Affero General Public
17 ;;; License along with this program. If not, see
18 ;;; <http://www.gnu.org/licenses/>.
19
20 (define-module (mumi web view utils)
21 #:use-module (ice-9 format)
22 #:use-module (ice-9 rdelim)
23 #:use-module (ice-9 match)
24 #:use-module (ice-9 regex)
25 #:use-module (ice-9 iconv)
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-9)
28 #:use-module (srfi srfi-19)
29 #:use-module (srfi srfi-26)
30 #:use-module (syntax-highlight)
31 #:use-module (syntax-highlight scheme)
32 #:use-module (email email)
33 #:use-module (mumi messages)
34 #:use-module (rnrs bytevectors)
35 #:use-module (web uri)
36 #:export (prettify
37 avatar-color
38 download-icon
39 display-message-body
40 time->string))
41
42 (define-record-type <block>
43 (make-block type lines)
44 block?
45 (type block-type)
46 (lines block-raw-lines set-block-lines!))
47
48 (define (block-lines block)
49 (reverse (block-raw-lines block)))
50
51 (define (add-block-line! block line)
52 (set-block-lines! block
53 (cons line (block-raw-lines block)))
54 block)
55
56 (define (process line blocks context)
57 "Process the current LINE. Add it to the latest block in BLOCKS or
58 add it to a new block, dependent on CONTEXT. Return the blocks along
59 with the next context."
60 (match blocks
61 ((block . other-blocks)
62 (cond
63 ((string-null? line)
64 (values (cons (add-block-line! block `(br))
65 other-blocks)
66 context))
67 ((eq? context 'snippet)
68 (if (string-prefix? "--8<---------------cut here" line)
69 (values blocks #f)
70 (values (cons (add-block-line! block
71 `(span (@ (class "line")) ,line))
72 other-blocks)
73 context)))
74 ((eq? context 'diff)
75 (if (string= "--" line)
76 ;; Retry
77 (process line blocks #f)
78 ;; Format line and add to current block
79 (let ((formatted-line
80 (cond
81 ((string= "---" line)
82 `(span (@ (class "line diff separator")) ,line))
83 ((string-prefix? "+" line)
84 `(span (@ (class "line diff addition")) ,line))
85 ((and (string-prefix? "-" line)
86 (not (string= "--" line))
87 (not (string= "-- " line)))
88 `(span (@ (class "line diff deletion")) ,line))
89 ((string-prefix? "@@" line)
90 `(span (@ (class "line diff range")) ,line))
91 (else
92 `(span (@ (class "line")) ,line)))))
93 (values (cons (add-block-line! block formatted-line)
94 other-blocks)
95 context))))
96 ((eq? context 'quote)
97 (if (string-prefix? ">" line)
98 ;; Add line to current block
99 (values (cons (add-block-line! block
100 `(span (@ (class "line")) ,line))
101 other-blocks)
102 context)
103 ;; Retry
104 (process line blocks #f)))
105 (else
106 (let ((new-context
107 (cond
108 ((string-prefix? "diff --git" line)
109 'diff)
110 ((string-prefix? ">" line)
111 'quote)
112 ((string-prefix? "--8<---------------cut here" line)
113 'snippet)
114 (else 'text)))
115 (formatted-line
116 (cond
117 ((or (string-contains line "https://")
118 (string-contains line "http://")) =>
119 (lambda (index)
120 (let* ((pre (string-take line index))
121 (post (string-drop line index))
122 (uri+ (string-split post (char-set #\< #\> #\space))))
123 (match uri+
124 ((uri-string . rest)
125 (or (and=> (string->uri uri-string)
126 (lambda (uri)
127 `(span (@ (class "line"))
128 ,(string-trim-right pre #\<)
129 (a (@ (href ,uri-string))
130 ,uri-string)
131 ,(string-join rest " "))))
132 `(span (@ (class "line")) ,line)))))))
133 ((or (string-prefix? "Signed-off-by" line)
134 (string-prefix? "Co-authored-by" line))
135 `(span (@ (class "line commit attribution")) ,line))
136 ((or (string-prefix? "From: " line)
137 (string-prefix? "Date: " line)
138 (string-prefix? "Subject: " line))
139 `(span (@ (class "line commit header")) ,line))
140 ((or (string-prefix? "* " line)
141 (string-prefix? " * " line))
142 `(span (@ (class "line commit changelog")) ,line))
143 ((string-prefix? "diff --git" line)
144 `(span (@ (class "line diff file")) ,line))
145 ((string-prefix? "--8<---------------cut here" line)
146 "")
147 (else
148 `(span (@ (class "line")) ,line)))))
149 (if (eq? new-context context)
150 (values (cons (add-block-line! block formatted-line)
151 other-blocks)
152 context)
153 (values (cons (make-block new-context (list formatted-line))
154 blocks)
155 new-context))))))))
156
157 (define (prettify text)
158 "Read each line of TEXT and apply PROCESS to it."
159 (let ((res (fold (lambda (line acc)
160 (call-with-values
161 (lambda ()
162 (process line
163 (cadr (memq #:blocks acc))
164 (cadr (memq #:context acc))))
165 (lambda (new-blocks new-context)
166 `(#:blocks ,new-blocks #:context ,new-context))))
167 (list #:blocks (list (make-block 'text '()))
168 #:context 'text)
169 (string-split text #\newline))))
170 (map (lambda (block)
171 (if (eq? 'text (block-type block))
172 `(div (@ (class ,(format #f "block ~a" (block-type block))))
173 ,(block-lines block))
174 `(details (@ (class ,(format #f "block ~a" (block-type block)))
175 (open "open"))
176 (summary ,(format #f "Toggle ~a (~a lines)" (block-type block)
177 (length (block-raw-lines block))))
178 ,(block-lines block))))
179 (reverse (cadr (memq #:blocks res))))))
180
181 (define colors
182 (circular-list "#8dd3c7" "#bebada" "#fb8072"
183 "#80b1d3" "#fdb462" "#b3de69"
184 "#fccde5" "#d9d9d9" "#bc80bd"
185 "#ccebc5" "#ffed6f"))
186
187 (define (avatar-color who participants)
188 (or (and=> (assoc-ref (zip participants colors) who)
189 first)
190 (first colors)))
191
192 (define (content-type->css-class value)
193 "Convert a content-type header value to a CSS class name."
194 (string-append (symbol->string (assoc-ref value 'type))
195 "-"
196 (symbol->string (assoc-ref value 'subtype))))
197
198 ;; https://icons.getbootstrap.com/icons/download/
199 (define download-icon
200 '(svg (@ (class "bi bi-download")
201 (width "1em")
202 (height "1em")
203 (viewBox "0 0 16 16")
204 (fill "currentColor")
205 (xmlns "http://www.w3.org/2000/svg"))
206 (title "Download")
207 (path (@ (fill-rule "evenodd")
208 (clip-rule "evenodd")
209 (d "M.5 8a.5.5 0 01.5.5V12a1 1 0 001 1h12a1 1 0 001-1\
210 V8.5a.5.5 0 011 0V12a2 2 0 01-2 2H2a2 2 0 01-2-2V8.5A.5.5 0 01.5 8z")) "")
211 (path (@ (fill-rule "evenodd")
212 (clip-rule "evenodd")
213 (d "M5 7.5a.5.5 0 01.707 0L8 9.793 10.293 7.5a.5.5 0 \
214 11.707.707l-2.646 2.647a.5.5 0 01-.708 0L5 8.207A.5.5 0 015 7.5z")) "")
215 (path (@ (fill-rule "evenodd")
216 (clip-rule "evenodd")
217 (d "M8 1a.5.5 0 01.5.5v8a.5.5 0 01-1 0v-8A.5.5 0 018 1z")) "")))
218
219 (define (display-message-body bug-num message-number message)
220 "Convenience procedure to render MESSAGE (part of bug with number
221 BUG-NUM), even when it is a multipart message."
222 (define (display-multipart-chunk headers body path)
223 (define (attachment-url)
224 (string-append "/issue/"
225 (number->string bug-num)
226 "/attachment/"
227 (number->string message-number)
228 "/" (string-join (map number->string path) "/")))
229 (let* ((content-type (assoc-ref headers 'content-type))
230 (html?
231 (and content-type
232 (eq? 'html (assoc-ref content-type 'subtype))))
233 (attachment?
234 (and (and=> (assoc-ref headers 'content-disposition)
235 (cut assoc-ref <> 'type))
236 content-type
237 (assoc-ref content-type 'type)))
238 (hide-attachment? (and attachment?
239 (or (member (assoc-ref content-type 'type)
240 '(application image video))
241 (and=> (assoc-ref headers 'content-disposition)
242 (lambda (disposition)
243 (and=> (assoc-ref disposition 'size)
244 (lambda (size)
245 (> size 5000))))))))
246 (attachment-name
247 (or (and=> (assoc-ref headers 'content-disposition)
248 (cut assoc-ref <> 'filename))
249 "file")))
250 (cond
251 ((or html? hide-attachment?)
252 `(div (@ (class "attachment"))
253 "Attachment: "
254 (a (@ (href ,(attachment-url))) ,attachment-name)
255 ,(or (and=> (assoc-ref headers 'content-disposition)
256 (lambda (disposition)
257 (and=> (assoc-ref disposition 'size)
258 (lambda (bytes)
259 (format #f " (~1,2f MiB)"
260 (exact->inexact
261 (/ bytes 1024 1024)))))))
262 "")))
263 ((string-suffix? ".scm" attachment-name)
264 `(div (@ (class "multipart scheme"))
265 (div (@ (class "download-part"))
266 (a (@ (href ,(attachment-url)))
267 ,download-icon))
268 ,(highlights->sxml (highlight lex-scheme body))))
269 (else
270 `(div (@ (class ,(string-join
271 (list "multipart" (or (and content-type
272 (content-type->css-class content-type))
273 "")))))
274 (div (@ (class "download-part"))
275 (a (@ (href ,(attachment-url)))
276 ,download-icon))
277 ,(prettify body))))))
278 (define (display-mime-entity entity . path)
279 (match entity
280 (($ <mime-entity> headers (? string? body))
281 (apply display-multipart-chunk `(,headers ,body ,path)))
282 ;; Message parts can be nested.
283 (($ <mime-entity> headers (? list? sub-parts))
284 (map (lambda (part sub-part-num)
285 (apply display-mime-entity part
286 (append path (list sub-part-num))))
287 sub-parts
288 (iota (length sub-parts))))
289 ;; XXX: Sometimes we get an unparseable bytevector. Convert it
290 ;; when that happens.
291 (($ <mime-entity> headers (? bytevector? raw))
292 (apply display-multipart-chunk
293 `(,headers
294 ,(bytevector->string raw "ISO-8859-1")
295 ,path)))))
296 (cond
297 ((multipart-message? message)
298 (let ((parts (email-body message)))
299 (map (lambda (part part-num)
300 (display-mime-entity part part-num))
301 parts
302 (iota (length parts)))))
303 ;; Regular message with a simple body.
304 (else
305 (display-mime-entity
306 (make-mime-entity (email-headers message)
307 (email-body message))))))
308
309 (define (time->string time)
310 "Return a string representing TIME in a concise, human-readable way."
311 (define seconds
312 (time-second
313 (if (date? time)
314 (date->time-utc time)
315 time)))
316
317 (define now*
318 (current-time time-utc))
319
320 (define now
321 (time-second now*))
322
323 (define elapsed
324 (- now seconds))
325
326 (cond ((< elapsed 120)
327 "seconds ago")
328 ((< elapsed 7200)
329 (let ((minutes (inexact->exact
330 (round (/ elapsed 60)))))
331 (format #f "~a minutes ago" minutes)))
332 ((< elapsed (* 48 3600))
333 (let ((hours (inexact->exact
334 (round (/ elapsed 3600)))))
335 (format #f "~a hours ago" hours)))
336 ((< elapsed (* 3600 24 7))
337 (let ((days (inexact->exact
338 (round (/ elapsed 3600 24)))))
339 (format #f "~a days ago" days)))
340 (else
341 (let* ((time (make-time time-utc 0 seconds))
342 (date (time-utc->date time))
343 (year (date-year date))
344 (current (date-year (time-utc->date now*)))
345 (format (if (= year current)
346 "~e ~b ~H:~M ~z"
347 "~e ~b ~Y ~H:~M")))
348 (string-append "on " (date->string date format))))))