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