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