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 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 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 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
val db = getDb ()
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
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
-end
\ No newline at end of file
+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 <support");
+ Mail.mwrite (mail, emailSuffix);
+ Mail.mwrite (mail, ">\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
+
+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
HCoop / hcoop / zz_old / portal.git / blobdiff