d9b5b6e4c8f7c8345e4ae0f770fca81a29abd364
[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 (filter (compose (negate bot?) extract-email)
157 (participants messages)))
158 (define (show-message message)
159 `((div
160 (@ (class "row"))
161 (a (@ (id ,(number->string (email-msg-num message)))))
162 (div
163 (@ (class "avatar col-md-1")
164 (style ,(string-append "background-color:"
165 (avatar-color (sender-email message)
166 (map extract-email parties)))))
167 ,(string-upcase (string-take (sender-name message) 1)))
168 (div
169 (@ (class "message col-md-11"))
170 (div
171 (@ (class "panel panel-default"))
172 (div
173 (@ (class "panel-heading"))
174 (div
175 (@ (class "from"))
176 (span (@ (class "address")) ,(sender-name message))
177 " wrote on "
178 (span (@ (class "date"))
179 (a (@ (href ,(string-append "#" (number->string
180 (email-msg-num message)))))
181 ,(date message))))
182 (div
183 (@ (class "details"))
184 (div
185 (@ (class "recipients"))
186 (label "Recipients:")
187 ,(map (lambda (address)
188 `(span (@ (class "address")) ,address))
189 (recipients message)))
190 (div
191 (@ (class "message-id"))
192 (label "Message-ID:")
193 ,(message-id message))))
194 (div
195 (@ (class "body panel-body"))
196 ,(display-message-body message)))))
197 ,@(if (closing? message id)
198 '((div
199 (@ (class "row event"))
200 (div
201 (@ (class "col-md-offset-1 col-md-11 text-center"))
202 (div (@ (class "label label-primary closed")) "Closed"))))
203 '())))
204 (layout
205 #:title (bug-subject bug)
206 #:extra-headers
207 (cond
208 ((bug-archived bug)
209 ;; Tell browser to cache this for 12 hours.
210 '((cache-control . ((max-age . 43200)))))
211 ((bug-done bug)
212 ;; Tell browser to cache this for 1 hour.
213 '((cache-control . ((max-age . 3600)))))
214 (else '()))
215 #:body
216 `(,(header)
217 (div
218 (@ (class "container"))
219 (div
220 (@ (class "row title col-md-12"))
221 (h1 ,(bug-subject bug))
222 (span (@ (class "details"))
223 ,(status-tag bug)
224 ,(string-append "Submitted by "
225 ;; We don't use bug-originator here
226 ;; because it includes the email address.
227 ;; We cannot use extract-name on the
228 ;; return value, because it swallows
229 ;; non-ASCII characters.
230 (sender-name (first messages))
231 ".")))
232 (div
233 (@ (class "row"))
234 (div
235 (@ (class "conversation col-md-9"))
236 ,(map show-message (filter (lambda (msg)
237 ;; Ignore messages
238 ;; without body, and
239 ;; internal messages.
240 (and (email-body msg)
241 (not (internal-message? msg))))
242 messages))
243 (div
244 (@ (class "row comment-box"))
245 (a (@ (id "comment")))
246 (div
247 (@ (class "avatar col-md-1")
248 (style "background-color:#bc80bd")) "?")
249 (div
250 (@ (class "message col-md-11"))
251 (div
252 (@ (class "panel panel-default"))
253 (div
254 (@ (class "panel-heading"))
255 (div (@ (class "from"))
256 (span (@ (class "address")) "Your comment")))
257 (div
258 (@ (class "body panel-body"))
259 (p "Comments via the web interface are not currently
260 supported. To comment on this conversation "
261 (a (@ (href ,(string-append "mailto:"
262 (number->string id) "@" (%config 'debbugs-domain)
263 "?subject=" (bug-subject bug))))
264 ,(string-append "send email to "
265 (number->string id) "@" (%config 'debbugs-domain)))))))))
266
267 (div
268 (@ (class "info col-md-3"))
269 (div
270 (@ (class "stat"))
271 ,@(let ((num (length parties)))
272 `((label ,(if (= num 1)
273 "One participant"
274 (string-append (number->string num)
275 " participants")))
276 (ul ,(map (lambda (name)
277 `(li (span (@ (class "name")))
278 ,name))
279 (map extract-name parties))))))
280 (div
281 (@ (class "stat"))
282 (label "Owner")
283 ,(or (and=> (bug-owner bug) extract-name) "unassigned"))
284 (div
285 (@ (class "stat"))
286 (label "Severity")
287 ,(bug-severity bug))
288 (div
289 (@ (class "stat"))
290 (label "Status")
291 ,(status-tag bug))))))))
292
293 (define (list-of-bugs bugs)
294 "Return a table of BUGS."
295 (if (null? bugs)
296 `(p "Nothing to see here. "
297 (a (@ (href "/"))
298 "Look for something else?"))
299 `(table (@ (class "table-condensed"))
300 (thead
301 (tr (th "ID")
302 (th "Subject")
303 (th "Date submitted")
304 (th "Status")))
305 (tbody
306 ,@(map (lambda (bug)
307 (let ((id (number->string (bug-num bug))))
308 `(tr
309 (td ,(or id "-"))
310 (td ,(if id
311 `(a (@ (href ,(string-append "/issue/" id)))
312 ,(bug-subject bug))
313 (bug-subject bug)))
314 (td ,(date->string (bug-date bug)))
315 (td ,(status-tag bug)))))
316 bugs)))))
317
318 (define (list-of-matching-bugs query bugs)
319 (layout
320 #:body
321 `(,(header)
322 (div (@ (class "container"))
323 ,@(if (null? bugs)
324 `((h1 "No issues found")
325 (p "We could not find any issues matching your query "
326 (code ,query) ". "
327 (a (@ (href "/"))
328 "Try searching for something else?")))
329 `((h1 "Submissions matching " (code ,query))
330 ,(list-of-bugs bugs)))))))