Commit | Line | Data |
---|---|---|
5a2812ca AC |
1 | structure Support :> SUPPORT = |
2 | struct | |
3 | ||
4 | open Util Sql Init | |
5 | ||
6 | datatype status = | |
7 | NEW | |
8 | | PENDING | |
9 | | CLOSED | |
10 | ||
11 | type category = { id : int, grp : int, name : string, descr : string } | |
12 | type issue = { id : int, usr : int, cat : int, title : string, priv : bool, status : status, stamp : C.timestamp } | |
13 | type post = { id : int, usr : int, iss : int, body : string, stamp : C.timestamp } | |
14 | type subscription = { usr : int, cat : int } | |
15 | ||
16 | ||
17 | (* Categories *) | |
18 | ||
19 | fun mkCatRow [id, grp, name, descr] = | |
20 | {id = C.intFromSql id, grp = C.intFromSql grp, name = C.stringFromSql name, | |
21 | descr = C.stringFromSql descr} | |
22 | | mkCatRow row = rowError ("category", row) | |
23 | ||
24 | fun lookupCategory id = | |
25 | mkCatRow (C.oneRow (getDb ()) ($`SELECT id, grp, name, descr | |
26 | FROM SupCategory | |
27 | WHERE id = ^(C.intToSql id)`)) | |
28 | ||
29 | fun listCategories () = | |
30 | C.map (getDb ()) mkCatRow ($`SELECT id, grp, name, descr | |
31 | FROM SupCategory | |
32 | ORDER BY name`) | |
33 | ||
34 | fun mkCatRow' (sub :: rest) = | |
35 | (not (C.isNull sub), mkCatRow rest) | |
36 | | mkCatRow' row = Init.rowError ("category'", row) | |
37 | ||
38 | fun listCategoriesWithSubscriptions usr = | |
39 | C.map (getDb ()) mkCatRow' ($`SELECT cat, id, grp, name, descr | |
40 | FROM SupCategory LEFT OUTER JOIN SupSubscription | |
41 | ON (usr = ^(C.intToSql usr) AND cat = id) | |
42 | ORDER BY name`) | |
43 | ||
44 | fun addCategory (grp, name, descr) = | |
45 | let | |
46 | val db = getDb () | |
47 | val id = nextSeq (db, "SupCategorySeq") | |
48 | in | |
49 | C.dml db ($`INSERT INTO SupCategory (id, grp, name, descr) | |
50 | VALUES (^(C.intToSql id), ^(C.intToSql grp), ^(C.stringToSql name), ^(C.stringToSql descr))`); | |
51 | id | |
52 | end | |
53 | ||
54 | fun modCategory (cat : category) = | |
55 | let | |
56 | val db = getDb () | |
57 | in | |
58 | ignore (C.dml db ($`UPDATE SupCategory SET | |
59 | grp = ^(C.intToSql (#grp cat)), name = ^(C.stringToSql (#name cat)), | |
60 | descr = ^(C.stringToSql (#descr cat)) | |
61 | WHERE id = ^(C.intToSql (#id cat))`)) | |
62 | end | |
63 | ||
64 | fun deleteCategory id = | |
65 | ignore (C.dml (getDb ()) ($`DELETE FROM SupCategory WHERE id = ^(C.intToSql id)`)) | |
66 | ||
67 | ||
68 | (* Issues *) | |
69 | ||
70 | val statusToSql = | |
71 | fn NEW => "0" | |
72 | | PENDING => "1" | |
73 | | CLOSED => "2" | |
74 | ||
75 | fun statusFromSql v = | |
76 | case C.intFromSql v of | |
77 | 0 => NEW | |
78 | | 1 => PENDING | |
79 | | 2 => CLOSED | |
80 | | _ => raise Fail "Bad support issue status" | |
81 | ||
82 | fun mkIssueRow [id, usr, cat, title, priv, status, stamp] = | |
83 | {id = C.intFromSql id, usr = C.intFromSql usr, cat = C.intFromSql cat, | |
84 | title = C.stringFromSql title, priv = C.boolFromSql priv, | |
85 | status = statusFromSql status, stamp = C.timestampFromSql stamp} | |
86 | | mkIssueRow row = rowError ("issue", row) | |
87 | ||
88 | fun lookupIssue id = | |
89 | mkIssueRow (C.oneRow (getDb ()) ($`SELECT id, usr, cat, title, priv, status, stamp | |
90 | FROM SupIssue | |
91 | WHERE id = ^(C.intToSql id)`)) | |
92 | ||
93 | fun listIssues () = | |
94 | C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp | |
95 | FROM SupIssue | |
96 | ORDER BY stamp DESC`) | |
97 | ||
5d851d7c AC |
98 | fun mkIssueRow' (name :: rest) = (C.stringFromSql name, mkIssueRow rest) |
99 | | mkIssueRow' r = Init.rowError ("issue'", r) | |
100 | ||
101 | fun listOpenIssues usr = | |
102 | C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, SupIssue.usr, SupIssue.cat, title, priv, status, stamp | |
103 | FROM SupIssue JOIN SupCategory ON cat = SupCategory.id | |
104 | JOIN WebUser ON WebUser.id = SupIssue.usr | |
105 | WHERE status < 2 | |
106 | AND (usr = ^(C.intToSql usr) | |
107 | OR ((SELECT COUNT( * ) FROM SupSubscription | |
108 | WHERE SupSubscription.usr = ^(C.intToSql usr) | |
109 | AND SupSubscription.cat = SupIssue.cat) > 0 | |
110 | AND (not priv OR (SELECT COUNT( * ) FROM Membership | |
111 | WHERE Membership.usr = ^(C.intToSql usr) | |
112 | AND Membership.grp = SupCategory.grp) > 0))) | |
113 | ORDER BY stamp DESC`) | |
114 | ||
1cb3df3f | 115 | fun listCategoryIssues cat = |
5d851d7c AC |
116 | C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, usr, cat, title, priv, status, stamp |
117 | FROM SupIssue | |
118 | JOIN WebUser ON WebUser.id = usr | |
119 | WHERE cat = ^(C.intToSql cat) | |
120 | ORDER BY stamp DESC`) | |
1cb3df3f AC |
121 | |
122 | fun listOpenCategoryIssues (cat, usr) = | |
5d851d7c AC |
123 | C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp |
124 | FROM SupIssue | |
125 | JOIN WebUser ON WebUser.id = usr | |
126 | WHERE cat = ^(C.intToSql cat) | |
127 | AND status < 2 | |
128 | AND (NOT priv OR usr = ^(C.intToSql usr)) | |
129 | ORDER BY stamp DESC`) | |
1cb3df3f AC |
130 | |
131 | fun listOpenCategoryIssuesAdmin cat = | |
5d851d7c AC |
132 | C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp |
133 | FROM SupIssue | |
134 | JOIN WebUser ON WebUser.id = usr | |
135 | WHERE cat = ^(C.intToSql cat) | |
136 | AND status < 2 | |
137 | ORDER BY stamp DESC`) | |
1cb3df3f | 138 | |
5a2812ca AC |
139 | fun addIssue (usr, cat, title, priv, status) = |
140 | let | |
141 | val db = getDb () | |
142 | val id = nextSeq (db, "SupIssueSeq") | |
143 | in | |
144 | C.dml db ($`INSERT INTO SupIssue (id, usr, cat, title, priv, status, stamp) | |
145 | VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql cat), | |
146 | ^(C.stringToSql title), ^(C.boolToSql priv), | |
147 | ^(statusToSql status), CURRENT_TIMESTAMP)`); | |
148 | id | |
149 | end | |
150 | ||
151 | fun modIssue (iss : issue) = | |
152 | let | |
153 | val db = getDb () | |
154 | in | |
155 | ignore (C.dml db ($`UPDATE SupIssue SET | |
156 | usr = ^(C.intToSql (#usr iss)), cat = ^(C.intToSql (#cat iss)), | |
157 | title = ^(C.stringToSql (#title iss)), priv = ^(C.boolToSql (#priv iss)), | |
158 | status = ^(statusToSql (#status iss)) | |
159 | WHERE id = ^(C.intToSql (#id iss))`)) | |
160 | end | |
161 | ||
162 | fun deleteIssue id = | |
163 | ignore (C.dml (getDb ()) ($`DELETE FROM SupIssue WHERE id = ^(C.intToSql id)`)) | |
164 | ||
165 | ||
166 | (* Posts *) | |
167 | ||
168 | fun mkPostRow [id, usr, iss, body, stamp] = | |
169 | {id = C.intFromSql id, usr = C.intFromSql usr, iss = C.intFromSql iss, | |
170 | body = C.stringFromSql body, stamp = C.timestampFromSql stamp} | |
171 | | mkPostRow row = rowError ("post", row) | |
172 | ||
173 | fun lookupPost id = | |
174 | mkPostRow (C.oneRow (getDb ()) ($`SELECT id, usr, iss, body, stamp | |
175 | FROM SupPost | |
176 | WHERE id = ^(C.intToSql id)`)) | |
177 | ||
edeb626e AC |
178 | fun mkPostRow' (name :: rest) = (C.stringFromSql name, mkPostRow rest) |
179 | | mkPostRow' row = Init.rowError ("post'", row) | |
180 | ||
5a2812ca | 181 | fun listPosts iss = |
edeb626e AC |
182 | C.map (getDb ()) mkPostRow' ($`SELECT name, SupPost.id, usr, iss, body, SupPost.stamp |
183 | FROM SupPost JOIN WebUser ON usr = WebUser.id | |
184 | WHERE iss = ^(C.intToSql iss) | |
185 | ORDER BY stamp`) | |
5a2812ca AC |
186 | |
187 | fun addPost (usr, iss, body) = | |
188 | let | |
189 | val db = getDb () | |
190 | val id = nextSeq (db, "SupPostSeq") | |
191 | in | |
192 | C.dml db ($`INSERT INTO SupPost (id, usr, iss, body, stamp) | |
193 | VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql iss), | |
194 | ^(C.stringToSql body), CURRENT_TIMESTAMP)`); | |
195 | id | |
196 | end | |
197 | ||
198 | fun modPost (post : post) = | |
199 | let | |
200 | val db = getDb () | |
201 | in | |
202 | ignore (C.dml db ($`UPDATE SupPost SET | |
203 | usr = ^(C.intToSql (#usr post)), iss = ^(C.intToSql (#iss post)), | |
204 | body = ^(C.stringToSql (#body post)) | |
205 | WHERE id = ^(C.intToSql (#id post))`)) | |
206 | end | |
207 | ||
208 | fun deletePost id = | |
209 | ignore (C.dml (getDb ()) ($`DELETE FROM SupPost WHERE id = ^(C.intToSql id)`)) | |
210 | ||
211 | ||
212 | (* Subscriptions *) | |
213 | ||
214 | fun mkSubRow [usr, cat] = | |
215 | {usr = C.intFromSql usr, cat = C.intFromSql cat} | |
216 | | mkSubRow row = rowError ("subscription", row) | |
217 | ||
218 | fun subscribed {usr, cat} = | |
219 | case C.oneRow (getDb ()) ($`SELECT COUNT( * ) FROM SupSubscription | |
220 | WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`) of | |
221 | [n] => not (C.isNull n) andalso C.intFromSql n > 0 | |
222 | | r => Init.rowError ("subscribed", r) | |
223 | ||
224 | fun subscribe (sub as {usr, cat}) = | |
225 | if subscribed sub then | |
226 | () | |
227 | else | |
228 | ignore (C.dml (getDb ()) ($`INSERT INTO SupSubscription (usr, cat) | |
229 | VALUES (^(C.intToSql usr), ^(C.intToSql cat))`)) | |
230 | ||
231 | fun unsubscribe {usr, cat} = | |
232 | ignore (C.dml (getDb ()) ($`DELETE FROM SupSubscription | |
233 | WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`)) | |
234 | ||
edeb626e AC |
235 | val okChars = [#" ", #"-", #".", #"!", #"?", #":", #";", #"'", #"\""] |
236 | ||
1cb3df3f | 237 | fun validTitle s = CharVector.exists (fn ch => not (Char.isSpace ch)) s |
edeb626e AC |
238 | andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse List.exists (fn ch' => ch = ch') okChars) s |
239 | ||
240 | fun allowedToSee iss = | |
241 | let | |
242 | val iss = lookupIssue iss | |
243 | val cat = lookupCategory (#cat iss) | |
244 | in | |
245 | not (#priv iss) orelse Group.inGroupNum (#grp cat) orelse (Init.getUserId () = #usr iss) | |
246 | end | |
247 | ||
248 | fun allowedToEdit iss = | |
249 | let | |
250 | val iss = lookupIssue iss | |
251 | val cat = lookupCategory (#cat iss) | |
252 | in | |
253 | Group.inGroupNum (#grp cat) orelse (Init.getUserId () = #usr iss) | |
254 | end | |
255 | ||
5d851d7c | 256 | fun writeRecipients (mail, iss : issue, cat : category, noName) = |
edeb626e AC |
257 | let |
258 | val query = | |
259 | if #priv iss then | |
260 | $`SELECT name | |
261 | FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql (#grp cat)))` | |
262 | else | |
263 | $`SELECT name | |
98a5f121 AC |
264 | FROM WebUser JOIN SupSubscription ON (usr = id AND cat = ^(C.intToSql (#id cat))) |
265 | UNION SELECT name | |
266 | FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql (#grp cat)))` | |
edeb626e | 267 | |
5d851d7c AC |
268 | fun doOne [name] = |
269 | let | |
270 | val name = C.stringFromSql name | |
271 | in | |
272 | if name = noName then | |
273 | () | |
274 | else | |
275 | (Mail.mwrite (mail, name); | |
276 | Mail.mwrite (mail, ",")) | |
277 | end | |
edeb626e AC |
278 | in |
279 | Mail.mwrite (mail, "Bcc: "); | |
280 | C.app (getDb ()) doOne query; | |
281 | Mail.mwrite (mail, "\n") | |
282 | end | |
5a2812ca | 283 | |
edeb626e AC |
284 | fun notify (prefix, f) iss = |
285 | let | |
286 | val iss = lookupIssue iss | |
287 | val cat = lookupCategory (#cat iss) | |
288 | val user = Init.lookupUser (#usr iss) | |
289 | ||
290 | val mail = Mail.mopen () | |
291 | in | |
93f77ca7 AC |
292 | Mail.mwrite (mail, "From: Hcoop Support System <support"); |
293 | Mail.mwrite (mail, emailSuffix); | |
294 | Mail.mwrite (mail, ">\nTo: "); | |
edeb626e | 295 | Mail.mwrite (mail, #name user); |
93f77ca7 AC |
296 | Mail.mwrite (mail, emailSuffix); |
297 | Mail.mwrite (mail, "\n"); | |
5d851d7c | 298 | writeRecipients (mail, iss, cat, #name user); |
edeb626e AC |
299 | Mail.mwrite (mail, "Subject: "); |
300 | Mail.mwrite (mail, prefix); | |
301 | Mail.mwrite (mail, #title iss); | |
302 | Mail.mwrite (mail, "\n\nURL: "); | |
303 | Mail.mwrite (mail, Init.urlPrefix); | |
304 | Mail.mwrite (mail, "issue?cat="); | |
305 | Mail.mwrite (mail, C.intToSql (#id cat)); | |
306 | Mail.mwrite (mail, "&id="); | |
307 | Mail.mwrite (mail, C.intToSql (#id iss)); | |
308 | Mail.mwrite (mail, "\n\nSubmitted by: "); | |
309 | Mail.mwrite (mail, #name user); | |
310 | Mail.mwrite (mail, "\n Category: "); | |
311 | Mail.mwrite (mail, #name cat); | |
312 | Mail.mwrite (mail, "\n Issue: "); | |
313 | Mail.mwrite (mail, #title iss); | |
314 | Mail.mwrite (mail, "\n Private: "); | |
315 | Mail.mwrite (mail, if #priv iss then "yes" else "no"); | |
316 | Mail.mwrite (mail, "\n\n"); | |
317 | ||
318 | f (iss, cat, user, mail); | |
319 | ||
320 | OS.Process.isSuccess (Mail.mclose mail) | |
321 | end | |
322 | ||
323 | val notifyCreation = notify ("[New] ", | |
324 | fn (iss, cat, user, mail) => | |
325 | (case listPosts (#id iss) of | |
326 | [] => () | |
327 | | [(_, post)] => Mail.mwrite (mail, #body post) | |
328 | | _ => raise Fail "Too many posts for supposedly new support issue")) | |
329 | ||
330 | fun notifyPost pid = | |
331 | let | |
332 | val post = lookupPost pid | |
333 | val poster = Init.lookupUser (#usr post) | |
334 | in | |
335 | notify ("[Post] ", | |
336 | fn (iss, cat, user, mail) => | |
337 | (Mail.mwrite (mail, "New post by "); | |
338 | Mail.mwrite (mail, #name poster); | |
339 | Mail.mwrite (mail, ":\n\n"); | |
340 | Mail.mwrite (mail, #body post))) (#iss post) | |
341 | end | |
342 | ||
343 | val statusToString = | |
344 | fn NEW => "New" | |
345 | | PENDING => "Pending" | |
346 | | CLOSED => "Closed" | |
347 | ||
348 | fun notifyStatus (usr, oldStatus, newStatus, iss) = | |
349 | let | |
350 | val user = Init.lookupUser usr | |
351 | in | |
352 | notify ("[" ^ statusToString newStatus ^ "] ", | |
039a9529 | 353 | fn (iss, cat, user', mail) => |
edeb626e AC |
354 | (Mail.mwrite (mail, #name user); |
355 | Mail.mwrite (mail, " changed status from "); | |
356 | Mail.mwrite (mail, statusToString oldStatus); | |
357 | Mail.mwrite (mail, " to "); | |
358 | Mail.mwrite (mail, statusToString newStatus); | |
359 | Mail.mwrite (mail, ".\n"))) iss | |
360 | end | |
361 | ||
93f77ca7 | 362 | end |