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