| 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 | |
| 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 | |
| 115 | fun listCategoryIssues cat = |
| 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`) |
| 121 | |
| 122 | fun listOpenCategoryIssues (cat, usr) = |
| 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`) |
| 130 | |
| 131 | fun listOpenCategoryIssuesAdmin cat = |
| 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`) |
| 138 | |
| 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 | |
| 178 | fun mkPostRow' (name :: rest) = (C.stringFromSql name, mkPostRow rest) |
| 179 | | mkPostRow' row = Init.rowError ("post'", row) |
| 180 | |
| 181 | fun listPosts iss = |
| 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`) |
| 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 | |
| 235 | val okChars = [#" ", #"-", #".", #"!", #"?", #":", #";", #"'", #"\"", #"/"] |
| 236 | |
| 237 | fun validTitle s = CharVector.exists (fn ch => not (Char.isSpace ch)) s |
| 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 | |
| 256 | fun writeRecipients (mail, iss : issue, cat : category, noName) = |
| 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 |
| 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)))` |
| 267 | |
| 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, emailSuffix); |
| 277 | Mail.mwrite (mail, ",")) |
| 278 | end |
| 279 | in |
| 280 | Mail.mwrite (mail, "Bcc: "); |
| 281 | C.app (getDb ()) doOne query; |
| 282 | Mail.mwrite (mail, "\n") |
| 283 | end |
| 284 | |
| 285 | fun notify (prefix, f) iss = |
| 286 | let |
| 287 | val iss = lookupIssue iss |
| 288 | val cat = lookupCategory (#cat iss) |
| 289 | val user = Init.lookupUser (#usr iss) |
| 290 | |
| 291 | val mail = Mail.mopen () |
| 292 | in |
| 293 | Mail.mwrite (mail, "From: Hcoop Support System <support"); |
| 294 | Mail.mwrite (mail, emailSuffix); |
| 295 | Mail.mwrite (mail, ">\nTo: "); |
| 296 | Mail.mwrite (mail, #name user); |
| 297 | Mail.mwrite (mail, emailSuffix); |
| 298 | Mail.mwrite (mail, "\n"); |
| 299 | writeRecipients (mail, iss, cat, #name user); |
| 300 | Mail.mwrite (mail, "Subject: "); |
| 301 | Mail.mwrite (mail, prefix); |
| 302 | Mail.mwrite (mail, #title iss); |
| 303 | Mail.mwrite (mail, "\n\nURL: "); |
| 304 | Mail.mwrite (mail, Init.urlPrefix); |
| 305 | Mail.mwrite (mail, "issue?cat="); |
| 306 | Mail.mwrite (mail, C.intToSql (#id cat)); |
| 307 | Mail.mwrite (mail, "&id="); |
| 308 | Mail.mwrite (mail, C.intToSql (#id iss)); |
| 309 | Mail.mwrite (mail, "\n\nSubmitted by: "); |
| 310 | Mail.mwrite (mail, #name user); |
| 311 | Mail.mwrite (mail, "\n Category: "); |
| 312 | Mail.mwrite (mail, #name cat); |
| 313 | Mail.mwrite (mail, "\n Issue: "); |
| 314 | Mail.mwrite (mail, #title iss); |
| 315 | Mail.mwrite (mail, "\n Private: "); |
| 316 | Mail.mwrite (mail, if #priv iss then "yes" else "no"); |
| 317 | Mail.mwrite (mail, "\n\n"); |
| 318 | |
| 319 | f (iss, cat, user, mail); |
| 320 | |
| 321 | OS.Process.isSuccess (Mail.mclose mail) |
| 322 | end |
| 323 | |
| 324 | val notifyCreation = notify ("[New] ", |
| 325 | fn (iss, cat, user, mail) => |
| 326 | (case listPosts (#id iss) of |
| 327 | [] => () |
| 328 | | [(_, post)] => Mail.mwrite (mail, #body post) |
| 329 | | _ => raise Fail "Too many posts for supposedly new support issue")) |
| 330 | |
| 331 | fun notifyPost pid = |
| 332 | let |
| 333 | val post = lookupPost pid |
| 334 | val poster = Init.lookupUser (#usr post) |
| 335 | in |
| 336 | notify ("[Post] ", |
| 337 | fn (iss, cat, user, mail) => |
| 338 | (Mail.mwrite (mail, "New post by "); |
| 339 | Mail.mwrite (mail, #name poster); |
| 340 | Mail.mwrite (mail, ":\n\n"); |
| 341 | Mail.mwrite (mail, #body post))) (#iss post) |
| 342 | end |
| 343 | |
| 344 | val statusToString = |
| 345 | fn NEW => "New" |
| 346 | | PENDING => "Pending" |
| 347 | | CLOSED => "Closed" |
| 348 | |
| 349 | fun notifyStatus (usr, oldStatus, newStatus, iss) = |
| 350 | let |
| 351 | val user = Init.lookupUser usr |
| 352 | in |
| 353 | notify ("[" ^ statusToString newStatus ^ "] ", |
| 354 | fn (iss, cat, user', mail) => |
| 355 | (Mail.mwrite (mail, #name user); |
| 356 | Mail.mwrite (mail, " changed status from "); |
| 357 | Mail.mwrite (mail, statusToString oldStatus); |
| 358 | Mail.mwrite (mail, " to "); |
| 359 | Mail.mwrite (mail, statusToString newStatus); |
| 360 | Mail.mwrite (mail, ".\n"))) iss |
| 361 | end |
| 362 | |
| 363 | end |