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