Commit | Line | Data |
---|---|---|
dda99898 | 1 | structure Support :> SUPPORT = |
5a2812ca AC |
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 } | |
4d46d3eb AC |
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 } | |
5a2812ca AC |
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 | ||
4d46d3eb | 83 | fun mkIssueRow [id, usr, cat, title, priv, status, stamp, pstamp, cstamp] = |
5a2812ca AC |
84 | {id = C.intFromSql id, usr = C.intFromSql usr, cat = C.intFromSql cat, |
85 | title = C.stringFromSql title, priv = C.boolFromSql priv, | |
4d46d3eb AC |
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 | ||
5a2812ca AC |
90 | | mkIssueRow row = rowError ("issue", row) |
91 | ||
92 | fun lookupIssue id = | |
4d46d3eb | 93 | mkIssueRow (C.oneRow (getDb ()) ($`SELECT id, usr, cat, title, priv, status, stamp, pstamp, cstamp |
5a2812ca AC |
94 | FROM SupIssue |
95 | WHERE id = ^(C.intToSql id)`)) | |
96 | ||
97 | fun listIssues () = | |
4d46d3eb | 98 | C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp, pstamp, cstamp |
5a2812ca AC |
99 | FROM SupIssue |
100 | ORDER BY stamp DESC`) | |
101 | ||
5d851d7c AC |
102 | fun mkIssueRow' (name :: rest) = (C.stringFromSql name, mkIssueRow rest) |
103 | | mkIssueRow' r = Init.rowError ("issue'", r) | |
104 | ||
105 | fun listOpenIssues usr = | |
4d46d3eb | 106 | C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, SupIssue.usr, SupIssue.cat, title, priv, status, stamp, pstamp, cstamp |
5d851d7c AC |
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 | ||
1cb3df3f | 119 | fun listCategoryIssues cat = |
4d46d3eb | 120 | C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, usr, cat, title, priv, status, stamp, pstamp, cstamp |
5d851d7c AC |
121 | FROM SupIssue |
122 | JOIN WebUser ON WebUser.id = usr | |
123 | WHERE cat = ^(C.intToSql cat) | |
124 | ORDER BY stamp DESC`) | |
1cb3df3f AC |
125 | |
126 | fun listOpenCategoryIssues (cat, usr) = | |
4d46d3eb | 127 | C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp, pstamp, cstamp |
5d851d7c AC |
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`) | |
1cb3df3f AC |
134 | |
135 | fun listOpenCategoryIssuesAdmin cat = | |
4d46d3eb | 136 | C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp, pstamp, cstamp |
5d851d7c AC |
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`) | |
1cb3df3f | 142 | |
5a2812ca AC |
143 | fun addIssue (usr, cat, title, priv, status) = |
144 | let | |
145 | val db = getDb () | |
146 | val id = nextSeq (db, "SupIssueSeq") | |
147 | in | |
4d46d3eb | 148 | C.dml db ($`INSERT INTO SupIssue (id, usr, cat, title, priv, status, stamp, pstamp, cstamp) |
5a2812ca AC |
149 | VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql cat), |
150 | ^(C.stringToSql title), ^(C.boolToSql priv), | |
4d46d3eb | 151 | ^(statusToSql status), CURRENT_TIMESTAMP, NULL, NULL)`); |
5a2812ca AC |
152 | id |
153 | end | |
154 | ||
155 | fun modIssue (iss : issue) = | |
156 | let | |
157 | val db = getDb () | |
158 | in | |
4d46d3eb | 159 | case #status iss of |
a75ed94b AC |
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))`)) | |
4d46d3eb | 162 | | _ => (); |
5a2812ca AC |
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 | ||
edeb626e AC |
186 | fun mkPostRow' (name :: rest) = (C.stringFromSql name, mkPostRow rest) |
187 | | mkPostRow' row = Init.rowError ("post'", row) | |
188 | ||
5a2812ca | 189 | fun listPosts iss = |
edeb626e AC |
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`) | |
5a2812ca AC |
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 | ||
5a035d64 | 243 | val okChars = [#" ", #"-", #".", #"!", #"?", #":", #",", #";", #"'", #"\"", #"/", #"(", #")", #"{", #"}", #"[", #"]"] |
edeb626e | 244 | |
1cb3df3f | 245 | fun validTitle s = CharVector.exists (fn ch => not (Char.isSpace ch)) s |
edeb626e AC |
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 | ||
5d851d7c | 264 | fun writeRecipients (mail, iss : issue, cat : category, noName) = |
edeb626e AC |
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 | |
98a5f121 AC |
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)))` | |
edeb626e | 275 | |
5d851d7c AC |
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); | |
e84acecc | 284 | Mail.mwrite (mail, emailSuffix); |
5d851d7c AC |
285 | Mail.mwrite (mail, ",")) |
286 | end | |
edeb626e AC |
287 | in |
288 | Mail.mwrite (mail, "Bcc: "); | |
289 | C.app (getDb ()) doOne query; | |
290 | Mail.mwrite (mail, "\n") | |
291 | end | |
5a2812ca | 292 | |
edeb626e AC |
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 | |
93f77ca7 AC |
301 | Mail.mwrite (mail, "From: Hcoop Support System <support"); |
302 | Mail.mwrite (mail, emailSuffix); | |
303 | Mail.mwrite (mail, ">\nTo: "); | |
edeb626e | 304 | Mail.mwrite (mail, #name user); |
93f77ca7 AC |
305 | Mail.mwrite (mail, emailSuffix); |
306 | Mail.mwrite (mail, "\n"); | |
5d851d7c | 307 | writeRecipients (mail, iss, cat, #name user); |
edeb626e AC |
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 ^ "] ", | |
039a9529 | 362 | fn (iss, cat, user', mail) => |
edeb626e AC |
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 | ||
93f77ca7 | 371 | end |