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