Use guile-email.
[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 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 (string-suffix? previous-subject (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)))))))