1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
3 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
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.
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.
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/>.
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
(ice-9 match
)
26 #:use-module
(srfi srfi-1
)
27 #:use-module
(srfi srfi-19
)
37 (define (bug-subject* bug
)
38 (or (bug-subject bug
) "(no subject)"))
40 (define (status-tag bug
)
41 "Return a colored tag indicating the BUG status."
42 (let ((status (if (bug-done bug
) "Done" "Open")))
43 `(span (@ (class ,(string-append "status-tag "
44 (string-downcase status
))))
47 (define* (layout #:key
50 (title "Guix issue tracker")
52 `(#:sxml
((doctype "html")
56 (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
57 (meta (@ (http-equiv "Content-Language") (content "en")))
58 (meta (@ (name "author") (content "Ricardo Wurmus")))
59 (meta (@ (name "viewport")
60 (content "width=device-width, initial-scale=1")))
65 (href "/css/reset.css")))
70 (href "/css/bootstrap.css")))
76 (href "/css/screen.css")))
81 (href "/css/code.css"))))
83 (footer (@ (class "text-center"))
84 (p "Copyright © 2016—2020 by the GNU Guix community."
86 "Now with even more " (span (@ (class "lambda")) "λ") "! ")
87 (p "This is free software. Download the "
88 (a (@ (href "https://git.elephly.net/software/mumi.git"))
89 "source code here") ".")))))
90 #:extra-headers
,extra-headers
))
92 (define* (search-form #:key
(standalone?
#f
))
93 `(form (@ (id "search")
96 '(class "form-inline"))
99 (@ (class ,(if standalone?
100 "input-group input-group-lg"
102 (input (@ (type "text")
103 (class "form-control")
106 (placeholder "input search query")))
107 (span (@ (class "input-group-append"))
110 (class ,(string-append (if standalone?
"btn-lg " "")
114 (define* (header #:key
(search-bar?
#t
))
116 (@ (class "navbar navbar-expand navbar-light bg-light"))
117 (a (@ (href "/") (class "navbar-brand pt-0 logo navbar-collapse"))
118 (img (@ (src "/img/logo.png") (alt "logo") (height "25"))))
126 '((cache-control .
((max-age .
60))))
128 `(,(header #:search-bar?
#f
)
130 (@ (class "container"))
131 (h1 "Guix patch tracker")
132 (p (@ (class "lead"))
133 "This is a web frontend to the Guix issue trackers. Send email to "
134 (a (@ (href ,(string-append "mailto:" (%config
'submission-email-address
))))
135 ,(%config
'submission-email-address
))
136 " to submit your patches or email "
137 (a (@ (href ,(string-append "mailto:" (%config
'submission-bug-email-address
))))
138 ,(%config
'submission-bug-email-address
))
139 " to open a new issue.")
141 (@ (class "card mb-5"))
142 (div (@ (class "card-body bg-light"))
143 ,(search-form #:standalone?
#t
)
144 (p (@ (class "card-text"))
146 "Refine your search with filters like "
147 (span (@ (class "filter"))
150 (span (@ (class "filter"))
153 (span (@ (class "filter"))
156 (span (@ (class "filter"))
157 "date:yesterday..now")
159 (span (@ (class "filter"))
160 "date:2018-04-01..2018-04-02")
162 (span (@ (class "filter"))
165 (a (@ (href "help#search"))
167 (h1 "Issues of interest")
168 (table (@ (class "table table-condensed table-sm table-hover"))
172 (th "Date submitted")
175 (tr (@ (class "bg-light")) (th (@ (colspan 4)) "Recent activity"))
176 ,@(list-of-bugs (recent-bugs 10))
177 (tr (@ (class "bg-light")) (th (@ (colspan 4)) "Priority bugs"))
178 ,@(priority-bugs)))))))
183 ;; Cache for 24 hours.
184 '((cache-control .
((max-age .
86400))))
186 `(,(header #:search-bar?
#f
)
188 (@ (class "container"))
190 (a (@ (href "search")))
191 (p "You can improve the search results by making use of the
192 simple query language. Here is a list of supported query terms with
198 (th (@ (class "col-md-3")) "Filter")
199 (th (@ (class "col-md-9")) "Description")))
202 (td (span (@ (class "filter")) "is:open") ", "
203 (span (@ (class "filter")) "is:pending"))
206 (td (span (@ (class "filter")) "is:closed") ", "
207 (span (@ (class "filter")) "is:done"))
208 (td "Issues marked as done."))
210 (td (span (@ (class "filter")) "submitter:<who>"))
211 (td "Issues submitted by a person named " (strong "who")
213 (span (@ (class "filter")) "submitter:ludo")
214 " for all issues submitted by ludo. "
215 "The filter matches both the email address and the name."))
217 (td (span (@ (class "filter")) "author:<who>"))
218 (td "Issues where a person named " (strong "who")
219 " has commented, e.g. "
220 (span (@ (class "filter")) "author:rekado")
221 " for all messages where rekado has commented. "
222 "The filter matches both the email address and the name."))
224 (td (span (@ (class "filter")) "date:<start>..<end>"))
225 (td "Issues or comments submitted within the provided range. "
226 (strong "start") " and " (strong "end") " can be one of "
227 (strong "now") ", " (strong "today") ", " (strong "yesterday")
228 ", a date in the formats "
229 (strong "YYYY-MM-DD") " or " (strong "YYYYMMDD")
230 ", or an amount and a unit for a point in the past, such as "
231 (strong "12d") " for 12 days ago. "
232 "Supported units are: "
233 (strong "h") " (hours), "
234 (strong "d") " (days), "
235 (strong "w") " (weeks), "
236 (strong "m") " (months), and "
237 (strong "y") " (years)."))))))))
243 (div (@ (class "container"))
244 (h1 "Patch not found")
245 (p "There is no submission with id " (strong ,id
))
246 (p (a (@ (href "/")) "Try another one?"))))))
248 (define (error-page message
)
252 (div (@ (class "container"))
254 (p "An error occurred. Sorry about that!")
256 (p (a (@ (href "/")) "Try something else?"))))))
258 (define (issue-page bug
)
259 "Render the conversation for the given BUG."
260 (define id
(bug-num bug
))
261 (define messages
(patch-messages id
))
262 (define parties
(sort (filter (compose (negate bot?
) extract-email
)
263 (participants messages
))
265 (string< (extract-email a
)
266 (extract-email b
)))))
267 (define (show-message message-number message previous-subject
)
268 `((div (@ (class "row mb-5"))
269 (a (@ (id ,(number->string message-number
))))
271 (@ (class "avatar col-md-1")
272 (style ,(string-append "background-color:"
273 (avatar-color (sender-email message
)
274 (map extract-email parties
)))))
275 ,(string-upcase (string-take (sender-name message
) 1)))
277 (@ (class "message col-md-11"))
281 (@ (class "card-header"))
284 (span (@ (class "address")) ,(sender-name message
))
286 (span (@ (class "date"))
287 (a (@ (href ,(string-append "#" (number->string
289 ,(date->string
(date message
)))))
290 ,@(if (string-suffix? previous-subject
(subject message
))
292 `((div (@ (class "subject")) ,(subject message
))))
294 (@ (class "details"))
296 (@ (class "recipients"))
297 (label "Recipients:")
298 ,(map (lambda (address)
299 `(span (@ (class "address")) ,address
))
300 (recipients message
)))
302 (@ (class "message-id"))
303 (label "Message-ID:")
304 ,(message-id message
))))
306 (@ (class "body card-body"))
307 ,(display-message-body id message-number message
)))))
308 ,@(if (closing? message id
)
310 (@ (class "row event"))
312 (@ (class "col-md-11 offset-md-1 text-center"))
313 (div (@ (class "badge badge-primary closed")) "Closed"))))
316 #:title
(bug-subject* bug
)
320 ;; Tell browser to cache this for 12 hours.
321 '((cache-control .
((max-age .
43200)))))
323 ;; Tell browser to cache this for 1 hour.
324 '((cache-control .
((max-age .
3600)))))
329 (@ (class "container"))
331 (@ (class "title col-md-12"))
332 (h1 ,(bug-subject* bug
))
333 (span (@ (class "details"))
335 ,(string-append "Submitted by "
336 ;; We don't use bug-originator here
337 ;; because it includes the email address.
338 ;; We cannot use extract-name on the
339 ;; return value, because it swallows
340 ;; non-ASCII characters.
341 (sender-name (first messages
))
343 ,@(if (bug-mergedwith bug
)
344 `((ul (@ (class "merged"))
347 `(li (a (@ (href ,(string-append "/issue/" id
)))
349 ;; XXX: This field can either hold a
350 ;; string of multiple ids, or a single
351 ;; number. Deal with this mess.
352 (match (bug-mergedwith bug
)
354 (string-split str
#\space
))
356 (list (number->string n
)))))))
358 ,@(if (bug-blocks bug
)
359 `((ul (@ (class "blocks"))
362 `(li (a (@ (href ,(string-append "/issue/" id
)))
364 ;; XXX: This field can either hold a
365 ;; string of multiple ids, or a single
366 ;; number. Deal with this mess.
367 (match (bug-blocks bug
)
369 (string-split str
#\space
))
371 (list (number->string n
)))))))
373 ,@(if (bug-blockedby bug
)
374 `((ul (@ (class "blockedby"))
377 `(li (a (@ (href ,(string-append "/issue/" id
)))
379 ;; XXX: This field can either hold a
380 ;; string of multiple ids, or a single
381 ;; number. Deal with this mess.
382 (match (bug-blockedby bug
)
384 (string-split str
#\space
))
386 (list (number->string n
)))))))
388 (div (@ (class "row"))
390 (@ (class "conversation col-md-9"))
391 ,(let ((msgs (filter (lambda (msg)
394 ;; internal messages.
395 (and (email-body msg
)
396 (not (internal-message? msg
))))
398 (map (lambda (message-number msg previous-subject
)
399 (show-message message-number msg previous-subject
))
402 (cons (bug-subject* bug
)
403 (map subject msgs
))))
405 (@ (class "row comment-box"))
406 (a (@ (id "comment")))
408 (@ (class "avatar col-md-1")
409 (style "background-color:#bc80bd")) "?")
411 (@ (class "message col-md-11"))
415 (@ (class "card-header"))
416 (div (@ (class "from"))
417 (span (@ (class "address")) "Your comment")))
419 (@ (class "body card-body"))
420 (p "Comments via the web interface are not currently
421 supported. To comment on this conversation "
422 (a (@ (href ,(string-append "mailto:"
423 (number->string id
) "@" (%config
'debbugs-domain
)
424 "?subject=" (bug-subject* bug
))))
425 ,(string-append "send email to "
426 (number->string id
) "@" (%config
'debbugs-domain
)))))))))
429 (@ (class "info col-md-3"))
432 ,@(let ((num (length parties
)))
435 (string-append (number->string num
)
438 (ul ,(map (lambda (name)
439 `(li (span (@ (class "name")))
441 (map extract-name parties
)))))))
446 ,(or (and=> (bug-owner bug
) extract-name
) "unassigned")))
450 (dd ,(bug-severity bug
)))
454 (dd ,(status-tag bug
)))))))))
456 (define (list-of-bugs bugs
)
457 "Return table rows for all BUGS."
459 (let ((id (number->string
(bug-num bug
))))
460 `(tr (@ (class ,(bug-severity bug
)))
463 `(a (@ (href ,(string-append "/issue/" id
)))
466 (td ,(date->string
(bug-date bug
)))
467 (td ,(status-tag bug
)))))
470 (define (priority-bugs)
473 (bugs-by-severity "serious" "open")
474 (bugs-by-severity "important" "open"))
475 (lambda (a b
) (< (bug-num a
) (bug-num b
))))))
477 (define (list-of-matching-bugs query bugs
)
481 (div (@ (class "container"))
483 `((h1 "No issues found")
484 (p "We could not find any issues matching your query "
487 "Try searching for something else?")))
488 `((h1 "Submissions matching " (code ,query
))
489 (table (@ (class "table table-condensed table-sm table-hover"))
493 (th "Date submitted")
496 ,@(list-of-bugs bugs
)))))))))