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