Add syntax highlighting for Scheme files.
[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")) "author: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)
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 (div
284 (@ (class "details"))
285 (div
286 (@ (class "recipients"))
287 (label "Recipients:")
288 ,(map (lambda (address)
289 `(span (@ (class "address")) ,address))
290 (recipients message)))
291 (div
292 (@ (class "message-id"))
293 (label "Message-ID:")
294 ,(message-id message))))
295 (div
296 (@ (class "body panel-body"))
297 ,(display-message-body id message)))))
298 ,@(if (closing? message id)
299 '((div
300 (@ (class "row event"))
301 (div
302 (@ (class "col-md-offset-1 col-md-11 text-center"))
303 (div (@ (class "label label-primary closed")) "Closed"))))
304 '())))
305 (layout
306 #:title (bug-subject bug)
307 #:extra-headers
308 (cond
309 ((bug-archived bug)
310 ;; Tell browser to cache this for 12 hours.
311 '((cache-control . ((max-age . 43200)))))
312 ((bug-done bug)
313 ;; Tell browser to cache this for 1 hour.
314 '((cache-control . ((max-age . 3600)))))
315 (else '()))
316 #:body
317 `(,(header)
318 (div
319 (@ (class "container"))
320 (div
321 (@ (class "row title col-md-12"))
322 (h1 ,(bug-subject bug))
323 (span (@ (class "details"))
324 ,(status-tag bug)
325 ,(string-append "Submitted by "
326 ;; We don't use bug-originator here
327 ;; because it includes the email address.
328 ;; We cannot use extract-name on the
329 ;; return value, because it swallows
330 ;; non-ASCII characters.
331 (sender-name (first messages))
332 ".")))
333 (div
334 (@ (class "row"))
335 (div
336 (@ (class "conversation col-md-9"))
337 ,(map show-message (filter (lambda (msg)
338 ;; Ignore messages
339 ;; without body, and
340 ;; internal messages.
341 (and (email-body msg)
342 (not (internal-message? msg))))
343 messages))
344 (div
345 (@ (class "row comment-box"))
346 (a (@ (id "comment")))
347 (div
348 (@ (class "avatar col-md-1")
349 (style "background-color:#bc80bd")) "?")
350 (div
351 (@ (class "message col-md-11"))
352 (div
353 (@ (class "panel panel-default"))
354 (div
355 (@ (class "panel-heading"))
356 (div (@ (class "from"))
357 (span (@ (class "address")) "Your comment")))
358 (div
359 (@ (class "body panel-body"))
360 (p "Comments via the web interface are not currently
361 supported. To comment on this conversation "
362 (a (@ (href ,(string-append "mailto:"
363 (number->string id) "@" (%config 'debbugs-domain)
364 "?subject=" (bug-subject bug))))
365 ,(string-append "send email to "
366 (number->string id) "@" (%config 'debbugs-domain)))))))))
367
368 (div
369 (@ (class "info col-md-3"))
370 (div
371 (@ (class "stat"))
372 ,@(let ((num (length parties)))
373 `((label ,(if (= num 1)
374 "One participant"
375 (string-append (number->string num)
376 " participants")))
377 (ul ,(map (lambda (name)
378 `(li (span (@ (class "name")))
379 ,name))
380 (map extract-name parties))))))
381 (div
382 (@ (class "stat"))
383 (label "Owner")
384 ,(or (and=> (bug-owner bug) extract-name) "unassigned"))
385 (div
386 (@ (class "stat"))
387 (label "Severity")
388 ,(bug-severity bug))
389 (div
390 (@ (class "stat"))
391 (label "Status")
392 ,(status-tag bug))))))))
393
394 (define (list-of-bugs bugs)
395 "Return a table of BUGS."
396 (if (null? bugs)
397 `(p "Nothing to see here. "
398 (a (@ (href "/"))
399 "Look for something else?"))
400 `(table (@ (class "table-condensed"))
401 (thead
402 (tr (th "ID")
403 (th "Subject")
404 (th "Date submitted")
405 (th "Status")))
406 (tbody
407 ,@(map (lambda (bug)
408 (let ((id (number->string (bug-num bug))))
409 `(tr
410 (td ,(or id "-"))
411 (td ,(if id
412 `(a (@ (href ,(string-append "/issue/" id)))
413 ,(bug-subject bug))
414 (bug-subject bug)))
415 (td ,(date->string (bug-date bug)))
416 (td ,(status-tag bug)))))
417 bugs)))))
418
419 (define (list-of-matching-bugs query bugs)
420 (layout
421 #:body
422 `(,(header)
423 (div (@ (class "container"))
424 ,@(if (null? bugs)
425 `((h1 "No issues found")
426 (p "We could not find any issues matching your query "
427 (code ,query) ". "
428 (a (@ (href "/"))
429 "Try searching for something else?")))
430 `((h1 "Submissions matching " (code ,query))
431 ,(list-of-bugs bugs)))))))