Initial commit.
[software/mumi.git] / mumi / web / view / html.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017 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 (mu)
20 #:use-module (mumi messages)
21 #:use-module (mumi web view utils)
22 #:use-module (srfi srfi-1)
23 #:export (index
24 unknown
25 patch-page
26 patch-list))
27
28 (define* (layout #:key (head '()) (body '()))
29 `((doctype "html")
30 (html
31 (head
32 (title "Guix patches")
33 (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
34 (meta (@ (http-equiv "Content-Language") (content "en")))
35 (meta (@ (name "author") (content "Ricardo Wurmus")))
36 (meta (@ (name "viewport")
37 (content "width=device-width, initial-scale=1")))
38 (link
39 (@ (rel "stylesheet")
40 (media "screen")
41 (type "text/css")
42 (href "/css/reset.css")))
43 (link
44 (@ (rel "stylesheet")
45 (media "screen")
46 (type "text/css")
47 (href "/css/bootstrap.css")))
48 ,@head
49 (link
50 (@ (rel "stylesheet")
51 (media "screen")
52 (type "text/css")
53 (href "/css/screen.css"))))
54 (body ,@body))))
55
56 (define header
57 '(div (@ (id "header"))
58 (div (@ (class "container"))
59 (div (@ (class "row"))
60 (a (@ (href "/"))
61 "Guix patches")))))
62
63 (define (index)
64 (layout
65 #:body
66 `(,header
67 (div (@ (class "container"))
68 (div (@ (id "about")
69 (class "row"))
70 (p "This is a web frontend to the Guix patch submission tracker. Send email to "
71 (a (@ (href "mailto:guix-packages@gnu.org"))
72 "guix-packages@gnu.org")
73 " to submit your patches.")
74 (p "This frontend is powered by "
75 (a (@ (href "http://www.djcbsoftware.nl/code/mu"))
76 "mu")
77 "."))
78 (form (@ (id "search-patches")
79 (class "row")
80 (action "/search"))
81 (div (@ (class "form-group"))
82 (input (@ (type "text")
83 (id "query")
84 (name "query")
85 (placeholder "input search query"))))
86 (button (@ (type "submit")
87 (class "btn btn-lg btn-primary btn-block"))
88 "Search"))))))
89
90 (define (unknown id)
91 (layout
92 #:body
93 `(,header
94 (div (@ (class "container"))
95 (h1 "Patch not found")
96 (p "There is no patch with id " (strong ,id))
97 (p (a (@ (href "/")) "Try another one?"))))))
98
99 (define (patch-page id messages)
100 (define parts (participants messages))
101 (define (show-message message)
102 `((div (@ (class "row"))
103 (div (@ (class "avatar col-md-1")
104 (style ,(string-append "background-color:"
105 (avatar-color (sender message) parts))))
106 ,(string-upcase (string-take (sender message) 1)))
107 (div (@ (class "message col-md-11"))
108 (div (@ (class "panel panel-default"))
109 (div (@ (class "panel-heading"))
110 (div (@ (class "from"))
111 (span (@ (class "address"))
112 ,(mu:from message))
113 " commented on "
114 (span (@ (class "date"))
115 ,(strftime "%B %d, %Y" (localtime (mu:timestamp message)))))
116 (div (@ (class "details"))
117 (div (@ (class "recipients"))
118 (label "Recipients:")
119 ,(map (lambda (address)
120 `(span (@ (class "address")) ,address))
121 (recipients message)))
122 (div (@ (class "message-id"))
123 (label "Message-ID:")
124 ,(mu:message-id message))))
125 (div (@ (class "body panel-body"))
126 ,(prettify (mu:body-txt message))))))
127 ,(if (closing? message)
128 '(div (@ (class "row event"))
129 (div (@ (class "col-md-offset-1 col-md-11 text-center"))
130 (div (@ (class "label label-primary closed"))
131 "Closed")))
132 '())))
133 (layout
134 #:body
135 `(,header
136 (div (@ (class "container"))
137 (div (@ (class "row"))
138 (h1 ,(mu:subject (car messages))))
139 (div (@ (class "row"))
140 (div (@ (class "conversation col-md-9"))
141 ,(map show-message (filter mu:body-txt messages)))
142 (div (@ (class "info col-md-3"))
143 (div (@ (class "stat"))
144 ,@(let ((num (length parts)))
145 `((label ,(if (= num 1)
146 "One participant"
147 (string-append (number->string num)
148 " participants")))
149 (ul ,(map (lambda (address)
150 `(li (span (@ (class "address")))
151 ,address))
152 parts)))))
153 (div (@ (class "stat"))
154 (label "Owner")
155 ,(or (owner messages) "unassigned"))
156 (div (@ (class "stat"))
157 (label "Status")
158 ,(status messages))))
159 (div (@ (class "row"))
160 (p "To comment on this conversation "
161 (a (@ (href ,(string-append "mailto:" id "@debbugs.gnu.org?subject="
162 (mu:subject (last messages)))))
163 ,(string-append "send email to "
164 id "@debbugs.gnu.org"))))))))
165
166 (define (patch-list query messages)
167 (layout
168 #:body
169 `(,header
170 (div (@ (class "container"))
171 (h1 "Patches matching " (code ,query))
172 ,(if (null? messages)
173 `(p (a (@ (href "/"))
174 "There are no patches matching your query, but we have many more!"))
175 `(table (@ (class "table-condensed"))
176 (thead
177 (tr (th "ID")
178 (th "Subject")
179 (th "Date submitted")))
180 (tbody
181 ,@(map (lambda (msg)
182 (let ((id (patch-id msg)))
183 `(tr
184 (td ,(or id "-"))
185 (td ,(if id
186 `(a (@ (href ,(string-append "/patch/" id)))
187 ,(mu:subject msg))
188 (mu:subject msg)))
189 (td ,(strftime "%B %d, %Y" (localtime (mu:timestamp msg)))))))
190 messages))))))))