X-Git-Url: http://git.hcoop.net/bpt/portal.git/blobdiff_plain/1cb3df3f8acdd2598a2717d5670070a1f554771e..af6e66d925f1d1f7e050c29c0cf3252323acfe13:/support.sml diff --git a/support.sml b/support.sml index 5370150..43bb9fb 100644 --- a/support.sml +++ b/support.sml @@ -9,7 +9,8 @@ datatype status = | CLOSED type category = { id : int, grp : int, name : string, descr : string } -type issue = { id : int, usr : int, cat : int, title : string, priv : bool, status : status, stamp : C.timestamp } +type issue = { id : int, usr : int, cat : int, title : string, priv : bool, status : status, + stamp : C.timestamp, cstamp : C.timestamp option, pstamp : C.timestamp option } type post = { id : int, usr : int, iss : int, body : string, stamp : C.timestamp } type subscription = { usr : int, cat : int } @@ -79,52 +80,75 @@ fun statusFromSql v = | 2 => CLOSED | _ => raise Fail "Bad support issue status" -fun mkIssueRow [id, usr, cat, title, priv, status, stamp] = +fun mkIssueRow [id, usr, cat, title, priv, status, stamp, pstamp, cstamp] = {id = C.intFromSql id, usr = C.intFromSql usr, cat = C.intFromSql cat, title = C.stringFromSql title, priv = C.boolFromSql priv, - status = statusFromSql status, stamp = C.timestampFromSql stamp} + status = statusFromSql status, stamp = C.timestampFromSql stamp, + pstamp = if C.isNull pstamp then NONE else SOME (C.timestampFromSql pstamp), + cstamp = if C.isNull cstamp then NONE else SOME (C.timestampFromSql cstamp)} + | mkIssueRow row = rowError ("issue", row) fun lookupIssue id = - mkIssueRow (C.oneRow (getDb ()) ($`SELECT id, usr, cat, title, priv, status, stamp + mkIssueRow (C.oneRow (getDb ()) ($`SELECT id, usr, cat, title, priv, status, stamp, pstamp, cstamp FROM SupIssue WHERE id = ^(C.intToSql id)`)) fun listIssues () = - C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp + C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp, pstamp, cstamp 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, pstamp, cstamp + 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, pstamp, cstamp + 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, pstamp, cstamp + 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, pstamp, cstamp + 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 () val id = nextSeq (db, "SupIssueSeq") in - C.dml db ($`INSERT INTO SupIssue (id, usr, cat, title, priv, status, stamp) + C.dml db ($`INSERT INTO SupIssue (id, usr, cat, title, priv, status, stamp, pstamp, cstamp) VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql cat), ^(C.stringToSql title), ^(C.boolToSql priv), - ^(statusToSql status), CURRENT_TIMESTAMP)`); + ^(statusToSql status), CURRENT_TIMESTAMP, NULL, NULL)`); id end @@ -132,6 +156,10 @@ fun modIssue (iss : issue) = let val db = getDb () in + case #status iss of + PENDING => ignore (C.dml db ($`UPDATE SupIssue SET pstamp = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql (#id iss))`)) + | CLOSED => ignore (C.dml db ($`UPDATE SupIssue SET cstamp = CURRENT_TIMESTAMP WHERE id = ^(C.intToSql (#id iss))`)) + | _ => (); ignore (C.dml db ($`UPDATE SupIssue SET usr = ^(C.intToSql (#usr iss)), cat = ^(C.intToSql (#cat iss)), title = ^(C.stringToSql (#title iss)), priv = ^(C.boolToSql (#priv iss)), @@ -155,11 +183,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 +240,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 -end \ No newline at end of file +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 + +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