9e9e11f70ccac7758b691e2e7a8c20c6b95d3b0e
[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 ,(append (list processed '(br)) res)
82 #:context ,(if new-context
83 (cons new-context context)
84 context))))))
85 '(#:result () #:context ())
86 (string-split text #\newline))))
87 ;; Drop the first line break, because it's for an eof
88 ;; read.
89 (match (reverse (cadr (find-tail (cut eq? #:result <>) res)))
90 ((_ . rest) rest)
91 (() '()))))
92
93 (define colors
94 (circular-list "#8dd3c7" "#bebada" "#fb8072"
95 "#80b1d3" "#fdb462" "#b3de69"
96 "#fccde5" "#d9d9d9" "#bc80bd"
97 "#ccebc5" "#ffed6f"))
98
99 (define (avatar-color who participants)
100 (or (and=> (assoc-ref (zip participants colors) who)
101 first)
102 (first colors)))
103
104 (define (content-type->css-class value)
105 "Convert a content-type header value to a CSS class name."
106 (string-append (symbol->string (assoc-ref value 'type))
107 "-"
108 (symbol->string (assoc-ref value 'subtype))))
109
110 ;; https://icons.getbootstrap.com/icons/download/
111 (define download-icon
112 '(svg (@ (class "bi bi-download")
113 (width "1em")
114 (height "1em")
115 (viewBox "0 0 16 16")
116 (fill "currentColor")
117 (xmlns "http://www.w3.org/2000/svg"))
118 (title "Download")
119 (path (@ (fill-rule "evenodd")
120 (clip-rule "evenodd")
121 (d "M.5 8a.5.5 0 01.5.5V12a1 1 0 001 1h12a1 1 0 001-1\
122 V8.5a.5.5 0 011 0V12a2 2 0 01-2 2H2a2 2 0 01-2-2V8.5A.5.5 0 01.5 8z")) "")
123 (path (@ (fill-rule "evenodd")
124 (clip-rule "evenodd")
125 (d "M5 7.5a.5.5 0 01.707 0L8 9.793 10.293 7.5a.5.5 0 \
126 11.707.707l-2.646 2.647a.5.5 0 01-.708 0L5 8.207A.5.5 0 015 7.5z")) "")
127 (path (@ (fill-rule "evenodd")
128 (clip-rule "evenodd")
129 (d "M8 1a.5.5 0 01.5.5v8a.5.5 0 01-1 0v-8A.5.5 0 018 1z")) "")))
130
131 (define (display-message-body bug-num message-number message)
132 "Convenience procedure to render MESSAGE (part of bug with number
133 BUG-NUM), even when it is a multipart message."
134 (define (display-multipart-chunk headers body path)
135 (define (attachment-url)
136 (string-append "/issue/"
137 (number->string bug-num)
138 "/attachment/"
139 (number->string message-number)
140 "/" (string-join (map number->string path) "/")))
141 (let* ((content-type (assoc-ref headers 'content-type))
142 (html?
143 (and content-type
144 (eq? 'html (assoc-ref content-type 'subtype))))
145 (attachment?
146 (and (and=> (assoc-ref headers 'content-disposition)
147 (cut assoc-ref <> 'type))
148 content-type
149 (assoc-ref content-type 'type)))
150 (binary-attachment? (and attachment?
151 (member (assoc-ref content-type 'type)
152 '(application image))))
153 (attachment-name
154 (or (and=> (assoc-ref headers 'content-disposition)
155 (cut assoc-ref <> 'filename))
156 "file")))
157 (cond
158 ((or html? binary-attachment?)
159 `(div (@ (class "attachment"))
160 "Attachment: "
161 (a (@ (href ,(attachment-url))) ,attachment-name)))
162 ((string-suffix? ".scm" attachment-name)
163 `(div (@ (class "multipart scheme"))
164 (div (@ (class "download-part"))
165 (a (@ (href ,(attachment-url)))
166 ,download-icon))
167 ,(highlights->sxml (highlight lex-scheme body))))
168 (else
169 `(div (@ (class ,(string-join
170 (list "multipart" (or (and content-type
171 (content-type->css-class content-type))
172 "")))))
173 (div (@ (class "download-part"))
174 (a (@ (href ,(attachment-url)))
175 ,download-icon))
176 ,(prettify body))))))
177 (define (display-mime-entity entity . path)
178 (match entity
179 (($ <mime-entity> headers (? string? body))
180 (apply display-multipart-chunk `(,headers ,body ,path)))
181 ;; Message parts can be nested.
182 (($ <mime-entity> headers (? list? sub-parts))
183 (map (lambda (part sub-part-num)
184 (apply display-mime-entity part
185 (append path (list sub-part-num))))
186 sub-parts
187 (iota (length sub-parts))))
188 ;; XXX: Sometimes we get an unparseable bytevector. Convert it
189 ;; when that happens.
190 (($ <mime-entity> headers (? bytevector? raw))
191 (apply display-multipart-chunk
192 `(,headers
193 ,(bytevector->string raw "ISO-8859-1")
194 ,path)))))
195 (cond
196 ((multipart-message? message)
197 (let ((parts (email-body message)))
198 (map (lambda (part part-num)
199 (display-mime-entity part part-num))
200 parts
201 (iota (length parts)))))
202 ;; Regular message with a simple body.
203 (else
204 (display-mime-entity
205 (make-mime-entity (email-headers message)
206 (email-body message))))))
207