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