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