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