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