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