X-Git-Url: https://git.hcoop.net/hcoop/portal.git/blobdiff_plain/1cb3df3f8acdd2598a2717d5670070a1f554771e..e84aceccd570655fbd36593ca20302456e1b501a:/support.sml diff --git a/support.sml b/support.sml index 5370150..48a818d 100644 --- a/support.sml +++ b/support.sml @@ -95,26 +95,46 @@ fun listIssues () = FROM SupIssue ORDER BY stamp DESC`) +fun mkIssueRow' (name :: rest) = (C.stringFromSql name, mkIssueRow rest) + | mkIssueRow' r = Init.rowError ("issue'", r) + +fun listOpenIssues usr = + C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, SupIssue.usr, SupIssue.cat, title, priv, status, stamp + FROM SupIssue JOIN SupCategory ON cat = SupCategory.id + JOIN WebUser ON WebUser.id = SupIssue.usr + WHERE status < 2 + AND (usr = ^(C.intToSql usr) + OR ((SELECT COUNT( * ) FROM SupSubscription + WHERE SupSubscription.usr = ^(C.intToSql usr) + AND SupSubscription.cat = SupIssue.cat) > 0 + AND (not priv OR (SELECT COUNT( * ) FROM Membership + WHERE Membership.usr = ^(C.intToSql usr) + AND Membership.grp = SupCategory.grp) > 0))) + ORDER BY stamp DESC`) + fun listCategoryIssues cat = - C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp - FROM SupIssue - WHERE cat = ^(C.intToSql cat) - ORDER BY stamp DESC`) + C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, usr, cat, title, priv, status, stamp + FROM SupIssue + JOIN WebUser ON WebUser.id = usr + WHERE cat = ^(C.intToSql cat) + ORDER BY stamp DESC`) fun listOpenCategoryIssues (cat, usr) = - C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp - FROM SupIssue - WHERE cat = ^(C.intToSql cat) - AND status < 2 - AND (NOT priv OR usr = ^(C.intToSql usr)) - ORDER BY stamp DESC`) + C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp + FROM SupIssue + JOIN WebUser ON WebUser.id = usr + WHERE cat = ^(C.intToSql cat) + AND status < 2 + AND (NOT priv OR usr = ^(C.intToSql usr)) + ORDER BY stamp DESC`) fun listOpenCategoryIssuesAdmin cat = - C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp - FROM SupIssue - WHERE cat = ^(C.intToSql cat) - AND status < 2 - ORDER BY stamp DESC`) + C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp + FROM SupIssue + JOIN WebUser ON WebUser.id = usr + WHERE cat = ^(C.intToSql cat) + AND status < 2 + ORDER BY stamp DESC`) fun addIssue (usr, cat, title, priv, status) = let @@ -155,11 +175,14 @@ fun lookupPost id = FROM SupPost WHERE id = ^(C.intToSql id)`)) +fun mkPostRow' (name :: rest) = (C.stringFromSql name, mkPostRow rest) + | mkPostRow' row = Init.rowError ("post'", row) + fun listPosts iss = - C.map (getDb ()) mkPostRow ($`SELECT id, usr, iss, body, stamp - FROM SupPost - WHERE iss = ^(C.intToSql iss) - ORDER BY stamp`) + C.map (getDb ()) mkPostRow' ($`SELECT name, SupPost.id, usr, iss, body, SupPost.stamp + FROM SupPost JOIN WebUser ON usr = WebUser.id + WHERE iss = ^(C.intToSql iss) + ORDER BY stamp`) fun addPost (usr, iss, body) = let @@ -209,6 +232,132 @@ fun unsubscribe {usr, cat} = ignore (C.dml (getDb ()) ($`DELETE FROM SupSubscription WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`)) +val okChars = [#" ", #"-", #".", #"!", #"?", #":", #";", #"'", #"\""] + fun validTitle s = CharVector.exists (fn ch => not (Char.isSpace ch)) s + andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse List.exists (fn ch' => ch = ch') okChars) s + +fun allowedToSee iss = + let + val iss = lookupIssue iss + val cat = lookupCategory (#cat iss) + in + not (#priv iss) orelse Group.inGroupNum (#grp cat) orelse (Init.getUserId () = #usr iss) + end + +fun allowedToEdit iss = + let + val iss = lookupIssue iss + val cat = lookupCategory (#cat iss) + in + Group.inGroupNum (#grp cat) orelse (Init.getUserId () = #usr iss) + end + +fun writeRecipients (mail, iss : issue, cat : category, noName) = + let + val query = + if #priv iss then + $`SELECT name + FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql (#grp cat)))` + else + $`SELECT name + FROM WebUser JOIN SupSubscription ON (usr = id AND cat = ^(C.intToSql (#id cat))) + UNION SELECT name + FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql (#grp cat)))` + + fun doOne [name] = + let + val name = C.stringFromSql name + in + if name = noName then + () + else + (Mail.mwrite (mail, name); + Mail.mwrite (mail, emailSuffix); + Mail.mwrite (mail, ",")) + end + in + Mail.mwrite (mail, "Bcc: "); + C.app (getDb ()) doOne query; + Mail.mwrite (mail, "\n") + end + +fun notify (prefix, f) iss = + let + val iss = lookupIssue iss + val cat = lookupCategory (#cat iss) + val user = Init.lookupUser (#usr iss) + + val mail = Mail.mopen () + in + Mail.mwrite (mail, "From: Hcoop Support System \nTo: "); + Mail.mwrite (mail, #name user); + Mail.mwrite (mail, emailSuffix); + Mail.mwrite (mail, "\n"); + writeRecipients (mail, iss, cat, #name user); + Mail.mwrite (mail, "Subject: "); + Mail.mwrite (mail, prefix); + Mail.mwrite (mail, #title iss); + Mail.mwrite (mail, "\n\nURL: "); + Mail.mwrite (mail, Init.urlPrefix); + Mail.mwrite (mail, "issue?cat="); + Mail.mwrite (mail, C.intToSql (#id cat)); + Mail.mwrite (mail, "&id="); + Mail.mwrite (mail, C.intToSql (#id iss)); + Mail.mwrite (mail, "\n\nSubmitted by: "); + Mail.mwrite (mail, #name user); + Mail.mwrite (mail, "\n Category: "); + Mail.mwrite (mail, #name cat); + Mail.mwrite (mail, "\n Issue: "); + Mail.mwrite (mail, #title iss); + Mail.mwrite (mail, "\n Private: "); + Mail.mwrite (mail, if #priv iss then "yes" else "no"); + Mail.mwrite (mail, "\n\n"); + + f (iss, cat, user, mail); + + OS.Process.isSuccess (Mail.mclose mail) + end -end \ No newline at end of file +val notifyCreation = notify ("[New] ", + fn (iss, cat, user, mail) => + (case listPosts (#id iss) of + [] => () + | [(_, post)] => Mail.mwrite (mail, #body post) + | _ => raise Fail "Too many posts for supposedly new support issue")) + +fun notifyPost pid = + let + val post = lookupPost pid + val poster = Init.lookupUser (#usr post) + in + notify ("[Post] ", + fn (iss, cat, user, mail) => + (Mail.mwrite (mail, "New post by "); + Mail.mwrite (mail, #name poster); + Mail.mwrite (mail, ":\n\n"); + Mail.mwrite (mail, #body post))) (#iss post) + end + +val statusToString = + fn NEW => "New" + | PENDING => "Pending" + | CLOSED => "Closed" + +fun notifyStatus (usr, oldStatus, newStatus, iss) = + let + val user = Init.lookupUser usr + in + notify ("[" ^ statusToString newStatus ^ "] ", + fn (iss, cat, user', mail) => + (Mail.mwrite (mail, #name user); + Mail.mwrite (mail, " changed status from "); + Mail.mwrite (mail, statusToString oldStatus); + Mail.mwrite (mail, " to "); + Mail.mwrite (mail, statusToString newStatus); + Mail.mwrite (mail, ".\n"))) iss + end + +end