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