Support follow-up posting and e-mail notification

[bpt/portal.git] / support.sml

diff --git a/support.sml b/support.sml
index 5b9c714..7aed0ea 100644 (file)
--- a/support.sml
+++ b/support.sml
@@ -95,6 +95,27 @@ fun listIssues () =
                                   FROM SupIssue
                                   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`)
+
+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`)
+
+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`)
+
 fun addIssue (usr, cat, title, priv, status) =
     let
        val db = getDb ()
@@ -134,11 +155,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
@@ -188,5 +212,118 @@ 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) =
+    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)))`
+
+       fun doOne [name] = (Mail.mwrite (mail, C.stringFromSql name);
+                           Mail.mwrite (mail, ","))
+    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 <support@hcoop.net>\nTo: ");
+       Mail.mwrite (mail, #name user);
+       Mail.mwrite (mail, "@hcoop.net\n");
+       writeRecipients (mail, iss, cat);
+       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
\ No newline at end of file