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