view: Sort participants by 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 ;;;
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 unknown
28 error-page
29 issue-page
30 list-of-matching-bugs))
31
32 (define (status-tag bug)
33 "Return a colored tag indicating the BUG status."
34 (let ((status (if (bug-done bug) "Done" "Open")))
35 `(span (@ (class ,(string-append "status-tag "
36 (string-downcase status))))
37 ,status)))
38
39 (define* (layout #:key
40 (head '())
41 (body '())
42 (title "Guix issue tracker")
43 (extra-headers '()))
44 `(#:sxml ((doctype "html")
45 (html
46 (head
47 (title ,title)
48 (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
49 (meta (@ (http-equiv "Content-Language") (content "en")))
50 (meta (@ (name "author") (content "Ricardo Wurmus")))
51 (meta (@ (name "viewport")
52 (content "width=device-width, initial-scale=1")))
53 (link
54 (@ (rel "stylesheet")
55 (media "screen")
56 (type "text/css")
57 (href "/css/reset.css")))
58 (link
59 (@ (rel "stylesheet")
60 (media "screen")
61 (type "text/css")
62 (href "/css/bootstrap.css")))
63 ,@head
64 (link
65 (@ (rel "stylesheet")
66 (media "screen")
67 (type "text/css")
68 (href "/css/screen.css"))))
69 (body ,@body)))
70 #:extra-headers ,extra-headers))
71
72 (define* (search-form #:key (standalone? #f))
73 `(form (@ (id "search")
74 ,(if standalone?
75 '(class "row")
76 '(class "navbar-form navbar-right"))
77 (action "/search"))
78 (div
79 (@ (class ,(if standalone?
80 "input-group input-group-lg"
81 "input-group")))
82 (input (@ (type "text")
83 (class "form-control")
84 (id "query")
85 (name "query")
86 (placeholder "input search query")))
87 (span (@ (class "input-group-btn"))
88 (button
89 (@ (type "submit")
90 (class ,(string-append (if standalone? "btn-lg " "")
91 "btn btn-primary")))
92 "Search")))))
93
94 (define* (header #:key (search-bar? #t))
95 `(nav
96 (@ (id "header") (class "navbar navbar-default"))
97 (div
98 (@ (class "container-fluid"))
99 (div
100 (@ (class "navbar-header"))
101 (div (@ (class "navbar-brand"))
102 (a (@ (href "/") (class "logo"))
103 (img (@ (src "/img/logo.png")
104 (alt "Guix patch tracker"))))))
105 ,@(if search-bar?
106 `(,(search-form))
107 '()))))
108
109 (define (index)
110 (layout
111 #:extra-headers
112 '((cache-control . ((max-age . 60))))
113 #:body
114 `(,(header #:search-bar? #f)
115 (div
116 (@ (class "container"))
117 (h1 "Guix patch tracker")
118 (div
119 (@ (id "about")
120 (class "row"))
121 (p "This is a web frontend to the Guix patch tracker. Send email to "
122 (a (@ (href ,(string-append "mailto:" (%config 'submission-email-address))))
123 ,(%config 'submission-email-address))
124 " to submit your patches."))
125 ,(search-form #:standalone? #t)
126 ;; TODO: do this via JS?
127 ,@(let ((bugs (recent-bugs 5)))
128 (if (null? bugs)
129 '()
130 `((h2 "Recent activity")
131 ,(list-of-bugs bugs))))))))
132
133 (define (unknown id)
134 (layout
135 #:body
136 `(,(header)
137 (div (@ (class "container"))
138 (h1 "Patch not found")
139 (p "There is no submission with id " (strong ,id))
140 (p (a (@ (href "/")) "Try another one?"))))))
141
142 (define (error-page message)
143 (layout
144 #:body
145 `(,(header)
146 (div (@ (class "container"))
147 (h1 "Error")
148 (p "An error occurred. Sorry about that!")
149 ,message
150 (p (a (@ (href "/")) "Try something else?"))))))
151
152 (define (issue-page bug)
153 "Render the conversation for the given BUG."
154 (define id (bug-num bug))
155 (define messages (patch-messages id))
156 (define parties (sort (filter (compose (negate bot?) extract-email)
157 (participants messages))
158 (lambda (a b)
159 (string< (extract-email a)
160 (extract-email b)))))
161 (define (show-message message)
162 `((div
163 (@ (class "row"))
164 (a (@ (id ,(number->string (email-msg-num message)))))
165 (div
166 (@ (class "avatar col-md-1")
167 (style ,(string-append "background-color:"
168 (avatar-color (sender-email message)
169 (map extract-email parties)))))
170 ,(string-upcase (string-take (sender-name message) 1)))
171 (div
172 (@ (class "message col-md-11"))
173 (div
174 (@ (class "panel panel-default"))
175 (div
176 (@ (class "panel-heading"))
177 (div
178 (@ (class "from"))
179 (span (@ (class "address")) ,(sender-name message))
180 " wrote on "
181 (span (@ (class "date"))
182 (a (@ (href ,(string-append "#" (number->string
183 (email-msg-num message)))))
184 ,(date message))))
185 (div
186 (@ (class "details"))
187 (div
188 (@ (class "recipients"))
189 (label "Recipients:")
190 ,(map (lambda (address)
191 `(span (@ (class "address")) ,address))
192 (recipients message)))
193 (div
194 (@ (class "message-id"))
195 (label "Message-ID:")
196 ,(message-id message))))
197 (div
198 (@ (class "body panel-body"))
199 ,(display-message-body message)))))
200 ,@(if (closing? message id)
201 '((div
202 (@ (class "row event"))
203 (div
204 (@ (class "col-md-offset-1 col-md-11 text-center"))
205 (div (@ (class "label label-primary closed")) "Closed"))))
206 '())))
207 (layout
208 #:title (bug-subject bug)
209 #:extra-headers
210 (cond
211 ((bug-archived bug)
212 ;; Tell browser to cache this for 12 hours.
213 '((cache-control . ((max-age . 43200)))))
214 ((bug-done bug)
215 ;; Tell browser to cache this for 1 hour.
216 '((cache-control . ((max-age . 3600)))))
217 (else '()))
218 #:body
219 `(,(header)
220 (div
221 (@ (class "container"))
222 (div
223 (@ (class "row title col-md-12"))
224 (h1 ,(bug-subject bug))
225 (span (@ (class "details"))
226 ,(status-tag bug)
227 ,(string-append "Submitted by "
228 ;; We don't use bug-originator here
229 ;; because it includes the email address.
230 ;; We cannot use extract-name on the
231 ;; return value, because it swallows
232 ;; non-ASCII characters.
233 (sender-name (first messages))
234 ".")))
235 (div
236 (@ (class "row"))
237 (div
238 (@ (class "conversation col-md-9"))
239 ,(map show-message (filter (lambda (msg)
240 ;; Ignore messages
241 ;; without body, and
242 ;; internal messages.
243 (and (email-body msg)
244 (not (internal-message? msg))))
245 messages))
246 (div
247 (@ (class "row comment-box"))
248 (a (@ (id "comment")))
249 (div
250 (@ (class "avatar col-md-1")
251 (style "background-color:#bc80bd")) "?")
252 (div
253 (@ (class "message col-md-11"))
254 (div
255 (@ (class "panel panel-default"))
256 (div
257 (@ (class "panel-heading"))
258 (div (@ (class "from"))
259 (span (@ (class "address")) "Your comment")))
260 (div
261 (@ (class "body panel-body"))
262 (p "Comments via the web interface are not currently
263 supported. To comment on this conversation "
264 (a (@ (href ,(string-append "mailto:"
265 (number->string id) "@" (%config 'debbugs-domain)
266 "?subject=" (bug-subject bug))))
267 ,(string-append "send email to "
268 (number->string id) "@" (%config 'debbugs-domain)))))))))
269
270 (div
271 (@ (class "info col-md-3"))
272 (div
273 (@ (class "stat"))
274 ,@(let ((num (length parties)))
275 `((label ,(if (= num 1)
276 "One participant"
277 (string-append (number->string num)
278 " participants")))
279 (ul ,(map (lambda (name)
280 `(li (span (@ (class "name")))
281 ,name))
282 (map extract-name parties))))))
283 (div
284 (@ (class "stat"))
285 (label "Owner")
286 ,(or (and=> (bug-owner bug) extract-name) "unassigned"))
287 (div
288 (@ (class "stat"))
289 (label "Severity")
290 ,(bug-severity bug))
291 (div
292 (@ (class "stat"))
293 (label "Status")
294 ,(status-tag bug))))))))
295
296 (define (list-of-bugs bugs)
297 "Return a table of BUGS."
298 (if (null? bugs)
299 `(p "Nothing to see here. "
300 (a (@ (href "/"))
301 "Look for something else?"))
302 `(table (@ (class "table-condensed"))
303 (thead
304 (tr (th "ID")
305 (th "Subject")
306 (th "Date submitted")
307 (th "Status")))
308 (tbody
309 ,@(map (lambda (bug)
310 (let ((id (number->string (bug-num bug))))
311 `(tr
312 (td ,(or id "-"))
313 (td ,(if id
314 `(a (@ (href ,(string-append "/issue/" id)))
315 ,(bug-subject bug))
316 (bug-subject bug)))
317 (td ,(date->string (bug-date bug)))
318 (td ,(status-tag bug)))))
319 bugs)))))
320
321 (define (list-of-matching-bugs query bugs)
322 (layout
323 #:body
324 `(,(header)
325 (div (@ (class "container"))
326 ,@(if (null? bugs)
327 `((h1 "No issues found")
328 (p "We could not find any issues matching your query "
329 (code ,query) ". "
330 (a (@ (href "/"))
331 "Try searching for something else?")))
332 `((h1 "Submissions matching " (code ,query))
333 ,(list-of-bugs bugs)))))))