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