Support downloading of attachments.
[software/mumi.git] / mumi / web / view / html.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
3 ;;;
4 ;;; This program is free software: you can redistribute it and/or
5 ;;; modify it under the terms of the GNU Affero General Public License
6 ;;; as published by the Free Software Foundation, either version 3 of
7 ;;; the License, or (at your option) any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; Affero General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU Affero General Public
15 ;;; License along with this program. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 (define-module (mumi web view html)
19 #:use-module (debbugs email)
20 #:use-module (debbugs bug)
21 #:use-module (mumi config)
22 #:use-module (mumi messages)
23 #:use-module (mumi web view utils)
24 #:use-module (srfi srfi-1)
25 #:use-module (srfi srfi-19)
26 #:export (index
27 help
28 unknown
29 error-page
30 issue-page
31 list-of-matching-bugs))
32
33 (define (status-tag bug)
34 "Return a colored tag indicating the BUG status."
35 (let ((status (if (bug-done bug) "Done" "Open")))
36 `(span (@ (class ,(string-append "status-tag "
37 (string-downcase status))))
38 ,status)))
39
40 (define* (layout #:key
41 (head '())
42 (body '())
43 (title "Guix issue tracker")
44 (extra-headers '()))
45 `(#:sxml ((doctype "html")
46 (html
47 (head
48 (title ,title)
49 (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
50 (meta (@ (http-equiv "Content-Language") (content "en")))
51 (meta (@ (name "author") (content "Ricardo Wurmus")))
52 (meta (@ (name "viewport")
53 (content "width=device-width, initial-scale=1")))
54 (link
55 (@ (rel "stylesheet")
56 (media "screen")
57 (type "text/css")
58 (href "/css/reset.css")))
59 (link
60 (@ (rel "stylesheet")
61 (media "screen")
62 (type "text/css")
63 (href "/css/bootstrap.css")))
64 ,@head
65 (link
66 (@ (rel "stylesheet")
67 (media "screen")
68 (type "text/css")
69 (href "/css/screen.css"))))
70 (body ,@body)))
71 #:extra-headers ,extra-headers))
72
73 (define* (search-form #:key (standalone? #f))
74 `(form (@ (id "search")
75 ,(if standalone?
76 '(class "row")
77 '(class "navbar-form navbar-right"))
78 (action "/search"))
79 (div
80 (@ (class ,(if standalone?
81 "input-group input-group-lg"
82 "input-group")))
83 (input (@ (type "text")
84 (class "form-control")
85 (id "query")
86 (name "query")
87 (placeholder "input search query")))
88 (span (@ (class "input-group-btn"))
89 (button
90 (@ (type "submit")
91 (class ,(string-append (if standalone? "btn-lg " "")
92 "btn btn-primary")))
93 "Search")))))
94
95 (define* (header #:key (search-bar? #t))
96 `(nav
97 (@ (id "header") (class "navbar navbar-default"))
98 (div
99 (@ (class "container-fluid"))
100 (div
101 (@ (class "navbar-header"))
102 (div (@ (class "navbar-brand"))
103 (a (@ (href "/") (class "logo"))
104 (img (@ (src "/img/logo.png")
105 (alt "Guix patch tracker"))))))
106 ,@(if search-bar?
107 `(,(search-form))
108 '()))))
109
110 (define (index)
111 (layout
112 #:extra-headers
113 '((cache-control . ((max-age . 60))))
114 #:body
115 `(,(header #:search-bar? #f)
116 (div
117 (@ (class "container"))
118 (h1 "Guix patch tracker")
119 (p (@ (class "row"))
120 "This is a web frontend to the Guix patch tracker. Send email to "
121 (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
122 ,(%config 'submission-email-address))
123 " to submit your patches.")
124 ,(search-form #:standalone? #t)
125 (div
126 (@ (class "row"))
127 (div
128 (@ (class "panel panel-default"))
129 (p (@ (class "panel-body"))
130 (strong "Hint: ")
131 "Refine your search with filters like "
132 (span (@ (class "filter"))
133 "is:open")
134 ", "
135 (span (@ (class "filter"))
136 "author:me")
137 ", "
138 (span (@ (class "filter"))
139 "submitter:me")
140 ", "
141 (span (@ (class "filter"))
142 "date:yesterday..now")
143 ", "
144 (span (@ (class "filter"))
145 "date:2018-04-01..2018-04-02")
146 ", "
147 (span (@ (class "filter"))
148 "date:1m..today")
149 ", "
150 (span (@ (class "filter"))
151 "mdate:2w..12h")
152 ", and "
153 (a (@ (href "help#search"))
154 "many more!"))))
155 ;; TODO: do this via JS?
156 ,@(let ((bugs (recent-bugs 5)))
157 (if (null? bugs)
158 '()
159 `((h2 "Recent activity")
160 ,(list-of-bugs bugs))))))))
161
162 (define (help)
163 (layout
164 #:extra-headers
165 ;; Cache for 24 hours.
166 '((cache-control . ((max-age . 86400))))
167 #:body
168 `(,(header #:search-bar? #f)
169 (div
170 (@ (class "container"))
171 (h1 "Help")
172 (a (@ (href "search")))
173 (p "You can improve the search results by making use of the
174 simple query language. Here is a list of supported query terms with
175 some examples.")
176 (table
177 (@ (class "table"))
178 (thead
179 (tr
180 (th (@ (class "col-md-3")) "Filter")
181 (th (@ (class "col-md-9")) "Description")))
182 (tbody
183 (tr
184 (td (span (@ (class "filter")) "is:open") ", "
185 (span (@ (class "filter")) "is:pending"))
186 (td "Open issues."))
187 (tr
188 (td (span (@ (class "filter")) "is:closed") ", "
189 (span (@ (class "filter")) "is:done"))
190 (td "Issues marked as done."))
191 (tr
192 (td (span (@ (class "filter")) "submitter:<who>"))
193 (td "Issues submitted by a person named " (strong "who")
194 ", e.g. "
195 (span (@ (class "filter")) "author:ludo")
196 " for all issues submitted by ludo. "
197 "The filter matches both the email address and the name."))
198 (tr
199 (td (span (@ (class "filter")) "author:<who>"))
200 (td "Issues where a person named " (strong "who")
201 " has commented, e.g. "
202 (span (@ (class "filter")) "author:rekado")
203 " for all messages where rekado has commented. "
204 "The filter matches both the email address and the name."))
205 (tr
206 (td (span (@ (class "filter")) "date:<start>..<end>"))
207 (td "Issues submitted within the provided range. "
208 (strong "start") " and " (strong "end") " can be one of "
209 (strong "now") ", " (strong "today") ", " (strong "yesterday")
210 ", a date in the formats "
211 (strong "YYYY-MM-DD") " or " (strong "YYYYMMDD")
212 ", or an amount and a unit for a point in the past, such as "
213 (strong "12d") " for 12 days ago. "
214 "Supported units are: "
215 (strong "h") " (hours), "
216 (strong "d") " (days), "
217 (strong "w") " (weeks), "
218 (strong "m") " (months), and "
219 (strong "y") " (years)."))
220 (tr
221 (td (span (@ (class "filter")) "mdate:<start>..<end>"))
222 (td "Issues with comments submitted within the provided
223 range. The supported arguments are the same as for "
224 (span (@ (class "filter")) "date:") "."))))))))
225
226 (define (unknown id)
227 (layout
228 #:body
229 `(,(header)
230 (div (@ (class "container"))
231 (h1 "Patch not found")
232 (p "There is no submission with id " (strong ,id))
233 (p (a (@ (href "/")) "Try another one?"))))))
234
235 (define (error-page message)
236 (layout
237 #:body
238 `(,(header)
239 (div (@ (class "container"))
240 (h1 "Error")
241 (p "An error occurred. Sorry about that!")
242 ,message
243 (p (a (@ (href "/")) "Try something else?"))))))
244
245 (define (issue-page bug)
246 "Render the conversation for the given BUG."
247 (define id (bug-num bug))
248 (define messages (patch-messages id))
249 (define parties (sort (filter (compose (negate bot?) extract-email)
250 (participants messages))
251 (lambda (a b)
252 (string< (extract-email a)
253 (extract-email b)))))
254 (define (show-message message)
255 `((div
256 (@ (class "row"))
257 (a (@ (id ,(number->string (email-msg-num message)))))
258 (div
259 (@ (class "avatar col-md-1")
260 (style ,(string-append "background-color:"
261 (avatar-color (sender-email message)
262 (map extract-email parties)))))
263 ,(string-upcase (string-take (sender-name message) 1)))
264 (div
265 (@ (class "message col-md-11"))
266 (div
267 (@ (class "panel panel-default"))
268 (div
269 (@ (class "panel-heading"))
270 (div
271 (@ (class "from"))
272 (span (@ (class "address")) ,(sender-name message))
273 " wrote on "
274 (span (@ (class "date"))
275 (a (@ (href ,(string-append "#" (number->string
276 (email-msg-num message)))))
277 ,(date message))))
278 (div
279 (@ (class "details"))
280 (div
281 (@ (class "recipients"))
282 (label "Recipients:")
283 ,(map (lambda (address)
284 `(span (@ (class "address")) ,address))
285 (recipients message)))
286 (div
287 (@ (class "message-id"))
288 (label "Message-ID:")
289 ,(message-id message))))
290 (div
291 (@ (class "body panel-body"))
292 ,(display-message-body id message)))))
293 ,@(if (closing? message id)
294 '((div
295 (@ (class "row event"))
296 (div
297 (@ (class "col-md-offset-1 col-md-11 text-center"))
298 (div (@ (class "label label-primary closed")) "Closed"))))
299 '())))
300 (layout
301 #:title (bug-subject bug)
302 #:extra-headers
303 (cond
304 ((bug-archived bug)
305 ;; Tell browser to cache this for 12 hours.
306 '((cache-control . ((max-age . 43200)))))
307 ((bug-done bug)
308 ;; Tell browser to cache this for 1 hour.
309 '((cache-control . ((max-age . 3600)))))
310 (else '()))
311 #:body
312 `(,(header)
313 (div
314 (@ (class "container"))
315 (div
316 (@ (class "row title col-md-12"))
317 (h1 ,(bug-subject bug))
318 (span (@ (class "details"))
319 ,(status-tag bug)
320 ,(string-append "Submitted by "
321 ;; We don't use bug-originator here
322 ;; because it includes the email address.
323 ;; We cannot use extract-name on the
324 ;; return value, because it swallows
325 ;; non-ASCII characters.
326 (sender-name (first messages))
327 ".")))
328 (div
329 (@ (class "row"))
330 (div
331 (@ (class "conversation col-md-9"))
332 ,(map show-message (filter (lambda (msg)
333 ;; Ignore messages
334 ;; without body, and
335 ;; internal messages.
336 (and (email-body msg)
337 (not (internal-message? msg))))
338 messages))
339 (div
340 (@ (class "row comment-box"))
341 (a (@ (id "comment")))
342 (div
343 (@ (class "avatar col-md-1")
344 (style "background-color:#bc80bd")) "?")
345 (div
346 (@ (class "message col-md-11"))
347 (div
348 (@ (class "panel panel-default"))
349 (div
350 (@ (class "panel-heading"))
351 (div (@ (class "from"))
352 (span (@ (class "address")) "Your comment")))
353 (div
354 (@ (class "body panel-body"))
355 (p "Comments via the web interface are not currently
356 supported. To comment on this conversation "
357 (a (@ (href ,(string-append "mailto:"
358 (number->string id) "@" (%config 'debbugs-domain)
359 "?subject=" (bug-subject bug))))
360 ,(string-append "send email to "
361 (number->string id) "@" (%config 'debbugs-domain)))))))))
362
363 (div
364 (@ (class "info col-md-3"))
365 (div
366 (@ (class "stat"))
367 ,@(let ((num (length parties)))
368 `((label ,(if (= num 1)
369 "One participant"
370 (string-append (number->string num)
371 " participants")))
372 (ul ,(map (lambda (name)
373 `(li (span (@ (class "name")))
374 ,name))
375 (map extract-name parties))))))
376 (div
377 (@ (class "stat"))
378 (label "Owner")
379 ,(or (and=> (bug-owner bug) extract-name) "unassigned"))
380 (div
381 (@ (class "stat"))
382 (label "Severity")
383 ,(bug-severity bug))
384 (div
385 (@ (class "stat"))
386 (label "Status")
387 ,(status-tag bug))))))))
388
389 (define (list-of-bugs bugs)
390 "Return a table of BUGS."
391 (if (null? bugs)
392 `(p "Nothing to see here. "
393 (a (@ (href "/"))
394 "Look for something else?"))
395 `(table (@ (class "table-condensed"))
396 (thead
397 (tr (th "ID")
398 (th "Subject")
399 (th "Date submitted")
400 (th "Status")))
401 (tbody
402 ,@(map (lambda (bug)
403 (let ((id (number->string (bug-num bug))))
404 `(tr
405 (td ,(or id "-"))
406 (td ,(if id
407 `(a (@ (href ,(string-append "/issue/" id)))
408 ,(bug-subject bug))
409 (bug-subject bug)))
410 (td ,(date->string (bug-date bug)))
411 (td ,(status-tag bug)))))
412 bugs)))))
413
414 (define (list-of-matching-bugs query bugs)
415 (layout
416 #:body
417 `(,(header)
418 (div (@ (class "container"))
419 ,@(if (null? bugs)
420 `((h1 "No issues found")
421 (p "We could not find any issues matching your query "
422 (code ,query) ". "
423 (a (@ (href "/"))
424 "Try searching for something else?")))
425 `((h1 "Submissions matching " (code ,query))
426 ,(list-of-bugs bugs)))))))