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