Managing support categories and subscriptions

diff --git a/support.mlt b/support.mlt
new file mode 100644 (file)
index 0000000..3c87e04
--- /dev/null
+++ b/support.mlt
@@ -0,0 +1,107 @@
+<% @header[("title", ["Support"])];
+
+val you = Init.getUserId ();
+val admin = Group.inGroupName "support";
+
+ref showNormal = true;
+
+if $"sub" <> "" then
+       Support.subscribe { cat = Web.stoi ($"sub"), usr = you }
+       %><h3><b>Subscribed</b></h3>
+
+<% elseif $"unsub" <> "" then
+       Support.unsubscribe { cat = Web.stoi ($"unsub"), usr = you }
+       %><h3><b>Unsubscribed</b></h3>
+
+<% elseif $"cmd" = "add" then
+       Group.requireGroupName "support";
+       val id = Support.addCategory (Web.stoi ($"grp"), $"name", $"descr")
+       %><h3><b>Category added</b></h3>
+
+<% elseif $"mod" <> "" then
+       Group.requireGroupName "support";
+       showNormal := false;
+       val id = Web.stoi ($"mod");
+       val cat = Support.lookupCategory id %>
+
+<h3><b>Modify category</b></h3>
+
+<form action="support">
+<input type="hidden" name="save" value="<% id %>">
+<table>
+<tr> <td align="right"><b>Name</b>:</td> <td><input name="name" value="<% Web.html (#name cat) %>"></td> </tr>
+<tr> <td align="right"><b>Owning group</b>:</td> <td><select name="grp">
+<% foreach group in Group.listGroups () do %>
+       <option value="<% #id group %>"<% if #id group = #grp cat then %> selected<% end %>><% #name group %></option>
+<% end %>
+</select></td> </tr>
+<tr> <td align="right"><b>Description</b>:</td> <td><input name="descr" value="<% Web.html (#descr cat) %>"></td> </tr>
+<tr> <td><input type="submit" value="Save"></td> </tr>
+</table>
+</form>
+
+<% elseif $"save" <> "" then
+       Group.requireGroupName "support";
+       val id = Web.stoi ($"save");
+       val cat = Support.lookupCategory id;
+       Support.modCategory {cat with name = $"name", descr = $"descr", grp = Web.stoi ($"grp")}
+       %><h3><b>Category saved</b></h3>
+
+<% elseif $"del" <> "" then
+       Group.requireGroupName "support";
+       showNormal := false;
+       val id = Web.stoi ($"del");
+       val cat = Support.lookupCategory id;
+       %><h3><b>Are you sure you want to delete category "<% Web.html (#name cat) %>"?</b></h3>
+       <a href="support?del2=<% id %>">Yes, delete "<% Web.html (#name cat) %>"!</a>
+
+<% elseif $"del2" <> "" then
+       Group.requireGroupName "support";
+       val id = Web.stoi ($"del2");
+       val cat = Support.lookupCategory id;
+       Support.deleteCategory id;
+       %><h3><b>"<% Web.html (#name cat) %>" deleted</b></h3>
+
+<% end;
+
+if showNormal then %>
+
+<h3><b>New issue in:</b></h3>
+
+<% foreach (sub, cat) in Support.listCategoriesWithSubscriptions you do %>
+<a href="issue?new=<% #id cat %>"><% Web.html (#name cat) %></a>: <% Web.html (#descr cat) %>
+<% if sub then %>
+<a href="support?unsub=<% #id cat %>">[Unsubscribe]</a>
+<% else %>
+<a href="support?sub=<% #id cat %>">[Subscribe]</a>
+<% end %>
+<% if admin then %>
+<a href="support?mod=<% #id cat %>">[Modify]</a>
+<a href="support?del=<% #id cat %>">[Delete]</a>
+<% end %>
+<br>
+<% end %>
+
+<% if admin then %>
+
+<h3><b>Add new category</b></h3>
+
+<form action="support">
+<input type="hidden" name="cmd" value="add">
+<table>
+<tr> <td align="right"><b>Name</b>:</td> <td><input name="name"></td> </tr>
+<tr> <td align="right"><b>Owning group</b>:</td> <td><select name="grp">
+<% foreach group in Group.listGroups () do %>
+       <option value="<% #id group %>"><% #name group %></option>
+<% end %>
+</select></td> </tr>
+<tr> <td align="right"><b>Description</b>:</td> <td><input name="descr"></td> </tr>
+<tr> <td><input type="submit" value="Add"></td> </tr>
+</table>
+</form>
+
+<% end %>
+
+<% end %>
+
+<% @footer[] %>
\ No newline at end of file

diff --git a/support.sig b/support.sig
new file mode 100644 (file)
index 0000000..2c5e127
--- /dev/null
+++ b/support.sig
@@ -0,0 +1,35 @@
+signature SUPPORT =
+sig
+    datatype status =
+            NEW
+          | PENDING
+          | 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 : Init.C.timestamp }
+    type post = { id : int, usr : int, iss : int, body : string, stamp : Init.C.timestamp }
+    type subscription = { usr : int, cat : int }
+
+    val lookupCategory : int -> category
+    val listCategories : unit -> category list
+    val listCategoriesWithSubscriptions : int -> (bool * category) list
+    val addCategory : int * string * string -> int
+    val modCategory : category -> unit
+    val deleteCategory : int -> unit
+
+    val lookupIssue : int -> issue
+    val listIssues : unit -> issue list
+    val addIssue : int * int * string * bool * status -> int
+    val modIssue : issue -> unit
+    val deleteIssue : int -> unit
+
+    val lookupPost : int -> post
+    val listPosts : int -> post list
+    val addPost : int * int * string -> int
+    val modPost : post -> unit
+    val deletePost : int -> unit
+
+    val subscribed : subscription -> bool
+    val subscribe : subscription -> unit
+    val unsubscribe : subscription -> unit
+end
\ No newline at end of file

diff --git a/support.sml b/support.sml
new file mode 100644 (file)
index 0000000..5b9c714
--- /dev/null
+++ b/support.sml
@@ -0,0 +1,192 @@
+structure Support :> SUPPORT =
+struct
+
+open Util Sql Init
+
+datatype status =
+        NEW
+       | PENDING
+       | 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 post = { id : int, usr : int, iss : int, body : string, stamp : C.timestamp }
+type subscription = { usr : int, cat : int }
+
+
+(* Categories *)
+
+fun mkCatRow [id, grp, name, descr] =
+    {id = C.intFromSql id, grp = C.intFromSql grp, name = C.stringFromSql name,
+     descr = C.stringFromSql descr}
+  | mkCatRow row = rowError ("category", row)
+
+fun lookupCategory id =
+    mkCatRow (C.oneRow (getDb ()) ($`SELECT id, grp, name, descr
+                                     FROM SupCategory
+                                     WHERE id = ^(C.intToSql id)`))
+
+fun listCategories () =
+    C.map (getDb ()) mkCatRow ($`SELECT id, grp, name, descr
+                                FROM SupCategory
+                                ORDER BY name`)
+
+fun mkCatRow' (sub :: rest) =
+    (not (C.isNull sub), mkCatRow rest)
+  | mkCatRow' row = Init.rowError ("category'", row)
+
+fun listCategoriesWithSubscriptions usr =
+    C.map (getDb ()) mkCatRow' ($`SELECT cat, id, grp, name, descr
+                                 FROM SupCategory LEFT OUTER JOIN SupSubscription
+                                    ON (usr = ^(C.intToSql usr) AND cat = id)
+                                 ORDER BY name`)
+
+fun addCategory (grp, name, descr) =
+    let
+       val db = getDb ()
+       val id = nextSeq (db, "SupCategorySeq")
+    in
+       C.dml db ($`INSERT INTO SupCategory (id, grp, name, descr)
+                   VALUES (^(C.intToSql id), ^(C.intToSql grp), ^(C.stringToSql name), ^(C.stringToSql descr))`);
+       id
+    end
+
+fun modCategory (cat : category) =
+    let
+       val db = getDb ()
+    in
+       ignore (C.dml db ($`UPDATE SupCategory SET
+                           grp = ^(C.intToSql (#grp cat)), name = ^(C.stringToSql (#name cat)),
+                              descr = ^(C.stringToSql (#descr cat))
+                           WHERE id = ^(C.intToSql (#id cat))`))
+    end
+
+fun deleteCategory id =
+    ignore (C.dml (getDb ()) ($`DELETE FROM SupCategory WHERE id = ^(C.intToSql id)`))
+
+
+(* Issues *)
+
+val statusToSql =
+    fn NEW => "0"
+     | PENDING => "1"
+     | CLOSED => "2"
+
+fun statusFromSql v =
+    case C.intFromSql v of
+       0 => NEW
+      | 1 => PENDING
+      | 2 => CLOSED
+      | _ => raise Fail "Bad support issue status"
+
+fun mkIssueRow [id, usr, cat, title, priv, status, stamp] =
+    {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}
+  | mkIssueRow row = rowError ("issue", row)
+
+fun lookupIssue id =
+    mkIssueRow (C.oneRow (getDb ()) ($`SELECT id, usr, cat, title, priv, status, stamp
+                                      FROM SupIssue
+                                      WHERE id = ^(C.intToSql id)`))
+
+fun listIssues () =
+    C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp
+                                  FROM SupIssue
+                                  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)
+                   VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql cat),
+                           ^(C.stringToSql title), ^(C.boolToSql priv),
+                           ^(statusToSql status), CURRENT_TIMESTAMP)`);
+       id
+    end
+
+fun modIssue (iss : issue) =
+    let
+       val db = getDb ()
+    in
+       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)),
+                              status = ^(statusToSql (#status iss))
+                           WHERE id = ^(C.intToSql (#id iss))`))
+    end
+
+fun deleteIssue id =
+    ignore (C.dml (getDb ()) ($`DELETE FROM SupIssue WHERE id = ^(C.intToSql id)`))
+
+
+(* Posts *)
+
+fun mkPostRow [id, usr, iss, body, stamp] =
+    {id = C.intFromSql id, usr = C.intFromSql usr, iss = C.intFromSql iss,
+     body = C.stringFromSql body, stamp = C.timestampFromSql stamp}
+  | mkPostRow row = rowError ("post", row)
+
+fun lookupPost id =
+    mkPostRow (C.oneRow (getDb ()) ($`SELECT id, usr, iss, body, stamp
+                                     FROM SupPost
+                                     WHERE id = ^(C.intToSql id)`))
+
+fun listPosts iss =
+    C.map (getDb ()) mkPostRow ($`SELECT id, usr, iss, body, stamp
+                                 FROM SupPost
+                                 WHERE iss = ^(C.intToSql iss)
+                                 ORDER BY stamp`)
+
+fun addPost (usr, iss, body) =
+    let
+       val db = getDb ()
+       val id = nextSeq (db, "SupPostSeq")
+    in
+       C.dml db ($`INSERT INTO SupPost (id, usr, iss, body, stamp)
+                   VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql iss),
+                           ^(C.stringToSql body), CURRENT_TIMESTAMP)`);
+       id
+    end
+
+fun modPost (post : post) =
+    let
+       val db = getDb ()
+    in
+       ignore (C.dml db ($`UPDATE SupPost SET
+                           usr = ^(C.intToSql (#usr post)), iss = ^(C.intToSql (#iss post)),
+                              body = ^(C.stringToSql (#body post))
+                           WHERE id = ^(C.intToSql (#id post))`))
+    end
+
+fun deletePost id =
+    ignore (C.dml (getDb ()) ($`DELETE FROM SupPost WHERE id = ^(C.intToSql id)`))
+
+
+(* Subscriptions *)
+
+fun mkSubRow [usr, cat] =
+    {usr = C.intFromSql usr, cat = C.intFromSql cat}
+  | mkSubRow row = rowError ("subscription", row)
+
+fun subscribed {usr, cat} =
+    case C.oneRow (getDb ()) ($`SELECT COUNT( * ) FROM SupSubscription
+                               WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`) of
+       [n] => not (C.isNull n) andalso C.intFromSql n > 0
+      | r => Init.rowError ("subscribed", r)
+
+fun subscribe (sub as {usr, cat}) =
+    if subscribed sub then
+       ()
+    else
+       ignore (C.dml (getDb ()) ($`INSERT INTO SupSubscription (usr, cat)
+                                   VALUES (^(C.intToSql usr), ^(C.intToSql cat))`))
+
+fun unsubscribe {usr, cat} =
+    ignore (C.dml (getDb ()) ($`DELETE FROM SupSubscription
+                               WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`))
+
+
+end
\ No newline at end of file

diff --git a/tables.sql b/tables.sql
index b4996bb..2e638df 100644 (file)
--- a/tables.sql
+++ b/tables.sql
@@ -134,3 +134,46 @@ CREATE TABLE Link(
 
 CREATE SEQUENCE LinkSeq START 1;
 
+CREATE TABLE SupCategory(
+       id INTEGER PRIMARY KEY,
+       grp INTEGER NOT NULL,
+       name TEXT NOT NULL,
+       descr TEXT NOT NULL,
+       FOREIGN KEY (grp) REFERENCES WebGroup(id) ON DELETE CASCADE);
+
+CREATE SEQUENCE SupCategorySeq START 1;
+
+CREATE TABLE SupIssue(
+       id INTEGER PRIMARY KEY,
+       usr INTEGER NOT NULL,
+       cat INTEGER NOT NULL,
+       title TEXT NOT NULL,
+       priv BOOLEAN NOT NULL,
+       status INTEGER NOT NULL,
+       stamp TIMESTAMP NOT NULL,
+       FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE,
+       FOREIGN KEY (cat) REFERENCES SupCategory(id) ON DELETE CASCADE);
+
+CREATE SEQUENCE SupIssueSeq START 1;
+
+CREATE TABLE SupPost(
+       id INTEGER PRIMARY KEY,
+       usr INTEGER NOT NULL,
+       iss INTEGER NOT NULL,
+       body TEXT NOT NULL,
+       stamp TIMESTAMP NOT NULL,
+       FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE,
+       FOREIGN KEY (iss) REFERENCES SupIssue(id) ON DELETE CASCADE);
+
+CREATE SEQUENCE SupPostSeq START 1;
+
+CREATE TABLE SupSubscription(
+       usr INTEGER NOT NULL,
+       cat INTEGER NOT NULL,
+       PRIMARY KEY (usr, cat),
+       FOREIGN KEY (usr) REFERENCES WebUser(id) ON DELETE CASCADE,
+       FOREIGN KEY (cat) REFERENCES SupCategory(id) ON DELETE CASCADE);
+
+
+
+