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