X-Git-Url: https://git.hcoop.net/bpt/portal.git/blobdiff_plain/edeb626ea2f306ad8a1f021ed3a001a5b7a6bcc6..e38fe5b0e18be227d05b0071de8773d4b8c02236:/support.sml diff --git a/support.sml b/support.sml index 7aed0ea..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)), @@ -212,7 +240,7 @@ fun unsubscribe {usr, cat} = ignore (C.dml (getDb ()) ($`DELETE FROM SupSubscription WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`)) -val okChars = [#" ", #"-", #".", #"!", #"?", #":", #";", #"'", #"\""] +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 @@ -233,7 +261,7 @@ fun allowedToEdit iss = Group.inGroupNum (#grp cat) orelse (Init.getUserId () = #usr iss) end -fun writeRecipients (mail, iss : issue, cat : category) = +fun writeRecipients (mail, iss : issue, cat : category, noName) = let val query = if #priv iss then @@ -241,10 +269,21 @@ fun writeRecipients (mail, iss : issue, cat : category) = 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)))` + 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] = (Mail.mwrite (mail, C.stringFromSql name); - Mail.mwrite (mail, ",")) + 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; @@ -259,10 +298,13 @@ fun notify (prefix, f) iss = val mail = Mail.mopen () in - Mail.mwrite (mail, "From: Hcoop Support System \nTo: "); + Mail.mwrite (mail, "From: Hcoop Support System \nTo: "); Mail.mwrite (mail, #name user); - Mail.mwrite (mail, "@hcoop.net\n"); - writeRecipients (mail, iss, cat); + 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); @@ -317,7 +359,7 @@ fun notifyStatus (usr, oldStatus, newStatus, iss) = val user = Init.lookupUser usr in notify ("[" ^ statusToString newStatus ^ "] ", - fn (iss, cat, user, mail) => + fn (iss, cat, user', mail) => (Mail.mwrite (mail, #name user); Mail.mwrite (mail, " changed status from "); Mail.mwrite (mail, statusToString oldStatus); @@ -326,4 +368,4 @@ fun notifyStatus (usr, oldStatus, newStatus, iss) = Mail.mwrite (mail, ".\n"))) iss end -end \ No newline at end of file +end