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