utils: Simplify prettify.
[software/mumi.git] / mumi / web / view / utils.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
3 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
4 ;;;
5 ;;; This program is free software: you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Affero General Public License
7 ;;; as published by the Free Software Foundation, either version 3 of
8 ;;; the License, or (at your option) any later version.
9 ;;;
10 ;;; This program is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Affero General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Affero General Public
16 ;;; License along with this program. If not, see
17 ;;; <http://www.gnu.org/licenses/>.
18
19 (define-module (mumi web view utils)
20 #:use-module (ice-9 rdelim)
21 #:use-module (ice-9 match)
22 #:use-module (ice-9 regex)
23 #:use-module (ice-9 receive)
24 #:use-module (ice-9 iconv)
25 #:use-module (srfi srfi-1)
26 #:use-module (srfi srfi-26)
27 #:use-module (syntax-highlight)
28 #:use-module (syntax-highlight scheme)
29 #:use-module (email email)
30 #:use-module (mumi messages)
31 #:use-module (rnrs bytevectors)
32 #:export (prettify
33 avatar-color
34 display-message-body))
35
36 ;; TODO: at some point this should tokenize the text, then apply
37 ;; styles, then output sxml, but for now we keep it simple
38 (define (process line context)
39 (cond
40 ((string-prefix? "--8<---------------cut here" line)
41 (values `(span (@ (class "line cut-here")) ,line) #f))
42 ((and (member 'diff context)
43 (string= "---" line))
44 (values `(span (@ (class "line diff separator")) ,line) #f))
45 ((string-prefix? "diff --git" line)
46 (values `(span (@ (class "line diff file")) ,line) 'diff))
47 ((and (member 'diff context)
48 (string-prefix? "+" line))
49 (values `(span (@ (class "line diff addition")) ,line) #f))
50 ((and (member 'diff context)
51 (string-prefix? "-" line)
52 (not (string= "--" line))
53 (not (string= "-- " line)))
54 (values `(span (@ (class "line diff deletion")) ,line) #f))
55 ((and (member 'diff context)
56 (string-prefix? "@@" line))
57 (values `(span (@ (class "line diff range")) ,line) #f))
58 ((string-prefix? ">" line)
59 (values `(span (@ (class "line quote")) ,line) #f))
60 ((or (string-prefix? "Signed-off-by" line)
61 (string-prefix? "Co-authored-by" line))
62 (values `(span (@ (class "commit attribution")) ,line) #f))
63 ((or (string-prefix? "From: " line)
64 (string-prefix? "Date: " line)
65 (string-prefix? "Subject: " line))
66 (values `(span (@ (class "commit header")) ,line) 'commit))
67 ((and (member 'commit context)
68 (or (string-prefix? "* " line)
69 (string-prefix? " * " line)))
70 (values `(span (@ (class "commit changelog")) ,line) #f))
71 (else
72 (values `(span (@ (class "line")) ,line) #f))))
73
74 (define (prettify text)
75 "Read each line of TEXT and apply PROCESS to it."
76 (let ((res (fold (lambda (line acc)
77 (match acc
78 ((#:result res #:context context)
79 (receive (processed new-context)
80 (process line context)
81 `(#:result ,(cons* '(br) processed res)
82 #:context ,(if new-context
83 (cons new-context context)
84 context))))))
85 '(#:result () #:context ())
86 (string-split text #\newline))))
87 (reverse (and=> (memq #:result res) cadr))))
88
89 (define colors
90 (circular-list "#8dd3c7" "#bebada" "#fb8072"
91 "#80b1d3" "#fdb462" "#b3de69"
92 "#fccde5" "#d9d9d9" "#bc80bd"
93 "#ccebc5" "#ffed6f"))
94
95 (define (avatar-color who participants)
96 (or (and=> (assoc-ref (zip participants colors) who)
97 first)
98 (first colors)))
99
100 (define (content-type->css-class value)
101 "Convert a content-type header value to a CSS class name."
102 (string-append (symbol->string (assoc-ref value 'type))
103 "-"
104 (symbol->string (assoc-ref value 'subtype))))
105
106 ;; https://icons.getbootstrap.com/icons/download/
107 (define download-icon
108 '(svg (@ (class "bi bi-download")
109 (width "1em")
110 (height "1em")
111 (viewBox "0 0 16 16")
112 (fill "currentColor")
113 (xmlns "http://www.w3.org/2000/svg"))
114 (title "Download")
115 (path (@ (fill-rule "evenodd")
116 (clip-rule "evenodd")
117 (d "M.5 8a.5.5 0 01.5.5V12a1 1 0 001 1h12a1 1 0 001-1\
118 V8.5a.5.5 0 011 0V12a2 2 0 01-2 2H2a2 2 0 01-2-2V8.5A.5.5 0 01.5 8z")) "")
119 (path (@ (fill-rule "evenodd")
120 (clip-rule "evenodd")
121 (d "M5 7.5a.5.5 0 01.707 0L8 9.793 10.293 7.5a.5.5 0 \
122 11.707.707l-2.646 2.647a.5.5 0 01-.708 0L5 8.207A.5.5 0 015 7.5z")) "")
123 (path (@ (fill-rule "evenodd")
124 (clip-rule "evenodd")
125 (d "M8 1a.5.5 0 01.5.5v8a.5.5 0 01-1 0v-8A.5.5 0 018 1z")) "")))
126
127 (define (display-message-body bug-num message-number message)
128 "Convenience procedure to render MESSAGE (part of bug with number
129 BUG-NUM), even when it is a multipart message."
130 (define (display-multipart-chunk headers body path)
131 (define (attachment-url)
132 (string-append "/issue/"
133 (number->string bug-num)
134 "/attachment/"
135 (number->string message-number)
136 "/" (string-join (map number->string path) "/")))
137 (let* ((content-type (assoc-ref headers 'content-type))
138 (html?
139 (and content-type
140 (eq? 'html (assoc-ref content-type 'subtype))))
141 (attachment?
142 (and (and=> (assoc-ref headers 'content-disposition)
143 (cut assoc-ref <> 'type))
144 content-type
145 (assoc-ref content-type 'type)))
146 (binary-attachment? (and attachment?
147 (member (assoc-ref content-type 'type)
148 '(application image))))
149 (attachment-name
150 (or (and=> (assoc-ref headers 'content-disposition)
151 (cut assoc-ref <> 'filename))
152 "file")))
153 (cond
154 ((or html? binary-attachment?)
155 `(div (@ (class "attachment"))
156 "Attachment: "
157 (a (@ (href ,(attachment-url))) ,attachment-name)))
158 ((string-suffix? ".scm" attachment-name)
159 `(div (@ (class "multipart scheme"))
160 (div (@ (class "download-part"))
161 (a (@ (href ,(attachment-url)))
162 ,download-icon))
163 ,(highlights->sxml (highlight lex-scheme body))))
164 (else
165 `(div (@ (class ,(string-join
166 (list "multipart" (or (and content-type
167 (content-type->css-class content-type))
168 "")))))
169 (div (@ (class "download-part"))
170 (a (@ (href ,(attachment-url)))
171 ,download-icon))
172 ,(prettify body))))))
173 (define (display-mime-entity entity . path)
174 (match entity
175 (($ <mime-entity> headers (? string? body))
176 (apply display-multipart-chunk `(,headers ,body ,path)))
177 ;; Message parts can be nested.
178 (($ <mime-entity> headers (? list? sub-parts))
179 (map (lambda (part sub-part-num)
180 (apply display-mime-entity part
181 (append path (list sub-part-num))))
182 sub-parts
183 (iota (length sub-parts))))
184 ;; XXX: Sometimes we get an unparseable bytevector. Convert it
185 ;; when that happens.
186 (($ <mime-entity> headers (? bytevector? raw))
187 (apply display-multipart-chunk
188 `(,headers
189 ,(bytevector->string raw "ISO-8859-1")
190 ,path)))))
191 (cond
192 ((multipart-message? message)
193 (let ((parts (email-body message)))
194 (map (lambda (part part-num)
195 (display-mime-entity part part-num))
196 parts
197 (iota (length parts)))))
198 ;; Regular message with a simple body.
199 (else
200 (display-mime-entity
201 (make-mime-entity (email-headers message)
202 (email-body message))))))
203