[bpt/portal.git] / support.sml

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 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 ()
	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 mkPostRow' (name :: rest) = (C.stringFromSql name, mkPostRow rest)
  | mkPostRow' row = Init.rowError ("post'", row)

fun listPosts iss =
    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
	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)`))

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, ","))
	    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 <support@hcoop.net>\nTo: ");
	Mail.mwrite (mail, #name user);
	Mail.mwrite (mail, "@hcoop.net\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
Commit	Line	Data
5a2812ca AC	1	structure Support :> SUPPORT =
	2	struct
	3
	4	open Util Sql Init
	5
	6	datatype status =
	7	NEW
	8	\| PENDING
	9	\| CLOSED
	10
	11	type category = { id : int, grp : int, name : string, descr : string }
	12	type issue = { id : int, usr : int, cat : int, title : string, priv : bool, status : status, stamp : C.timestamp }
	13	type post = { id : int, usr : int, iss : int, body : string, stamp : C.timestamp }
	14	type subscription = { usr : int, cat : int }
	15
	16
	17	(* Categories *)
	18
	19	fun mkCatRow [id, grp, name, descr] =
	20	{id = C.intFromSql id, grp = C.intFromSql grp, name = C.stringFromSql name,
	21	descr = C.stringFromSql descr}
	22	\| mkCatRow row = rowError ("category", row)
	23
	24	fun lookupCategory id =
	25	mkCatRow (C.oneRow (getDb ()) ($`SELECT id, grp, name, descr
	26	FROM SupCategory
	27	WHERE id = ^(C.intToSql id)`))
	28
	29	fun listCategories () =
	30	C.map (getDb ()) mkCatRow ($`SELECT id, grp, name, descr
	31	FROM SupCategory
	32	ORDER BY name`)
	33
	34	fun mkCatRow' (sub :: rest) =
	35	(not (C.isNull sub), mkCatRow rest)
	36	\| mkCatRow' row = Init.rowError ("category'", row)
	37
	38	fun listCategoriesWithSubscriptions usr =
	39	C.map (getDb ()) mkCatRow' ($`SELECT cat, id, grp, name, descr
	40	FROM SupCategory LEFT OUTER JOIN SupSubscription
	41	ON (usr = ^(C.intToSql usr) AND cat = id)
	42	ORDER BY name`)
	43
	44	fun addCategory (grp, name, descr) =
	45	let
	46	val db = getDb ()
	47	val id = nextSeq (db, "SupCategorySeq")
	48	in
	49	C.dml db ($`INSERT INTO SupCategory (id, grp, name, descr)
	50	VALUES (^(C.intToSql id), ^(C.intToSql grp), ^(C.stringToSql name), ^(C.stringToSql descr))`);
	51	id
	52	end
	53
	54	fun modCategory (cat : category) =
	55	let
	56	val db = getDb ()
	57	in
	58	ignore (C.dml db ($`UPDATE SupCategory SET
	59	grp = ^(C.intToSql (#grp cat)), name = ^(C.stringToSql (#name cat)),
	60	descr = ^(C.stringToSql (#descr cat))
	61	WHERE id = ^(C.intToSql (#id cat))`))
	62	end
	63
	64	fun deleteCategory id =
65	ignore (C.dml (getDb ()) ($`DELETE FROM SupCategory WHERE id = ^(C.intToSql id)`))
66
67
68	(* Issues *)
69
70	val statusToSql =
71	fn NEW => "0"
72	\| PENDING => "1"
73	\| CLOSED => "2"
74
75	fun statusFromSql v =
76	case C.intFromSql v of
77	0 => NEW
78	\| 1 => PENDING
79	\| 2 => CLOSED
80	\| _ => raise Fail "Bad support issue status"
81
82	fun mkIssueRow [id, usr, cat, title, priv, status, stamp] =
83	{id = C.intFromSql id, usr = C.intFromSql usr, cat = C.intFromSql cat,
84	title = C.stringFromSql title, priv = C.boolFromSql priv,
85	status = statusFromSql status, stamp = C.timestampFromSql stamp}
86	\| mkIssueRow row = rowError ("issue", row)
87
88	fun lookupIssue id =
89	mkIssueRow (C.oneRow (getDb ()) ($`SELECT id, usr, cat, title, priv, status, stamp
90	FROM SupIssue
91	WHERE id = ^(C.intToSql id)`))
92
93	fun listIssues () =
94	C.map (getDb ()) mkIssueRow ($`SELECT id, usr, cat, title, priv, status, stamp
95	FROM SupIssue
96	ORDER BY stamp DESC`)
97
5d851d7c AC	98	fun mkIssueRow' (name :: rest) = (C.stringFromSql name, mkIssueRow rest)
	99	\| mkIssueRow' r = Init.rowError ("issue'", r)
	100
	101	fun listOpenIssues usr =
	102	C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, SupIssue.usr, SupIssue.cat, title, priv, status, stamp
	103	FROM SupIssue JOIN SupCategory ON cat = SupCategory.id
	104	JOIN WebUser ON WebUser.id = SupIssue.usr
	105	WHERE status < 2
	106	AND (usr = ^(C.intToSql usr)
	107	OR ((SELECT COUNT( * ) FROM SupSubscription
	108	WHERE SupSubscription.usr = ^(C.intToSql usr)
	109	AND SupSubscription.cat = SupIssue.cat) > 0
	110	AND (not priv OR (SELECT COUNT( * ) FROM Membership
	111	WHERE Membership.usr = ^(C.intToSql usr)
	112	AND Membership.grp = SupCategory.grp) > 0)))
	113	ORDER BY stamp DESC`)
	114
1cb3df3f	115	fun listCategoryIssues cat =
5d851d7c AC	116	C.map (getDb ()) mkIssueRow' ($`SELECT WebUser.name, SupIssue.id, usr, cat, title, priv, status, stamp
	117	FROM SupIssue
	118	JOIN WebUser ON WebUser.id = usr
	119	WHERE cat = ^(C.intToSql cat)
	120	ORDER BY stamp DESC`)
1cb3df3f AC	121
1cb3df3f AC	122	fun listOpenCategoryIssues (cat, usr) =
5d851d7c AC	123	C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp
	124	FROM SupIssue
	125	JOIN WebUser ON WebUser.id = usr
	126	WHERE cat = ^(C.intToSql cat)
	127	AND status < 2
	128	AND (NOT priv OR usr = ^(C.intToSql usr))
	129	ORDER BY stamp DESC`)
1cb3df3f AC	130
1cb3df3f AC	131	fun listOpenCategoryIssuesAdmin cat =
5d851d7c AC	132	C.map (getDb ()) mkIssueRow' ($`SELECT name, SupIssue.id, usr, cat, title, priv, status, stamp
	133	FROM SupIssue
	134	JOIN WebUser ON WebUser.id = usr
	135	WHERE cat = ^(C.intToSql cat)
	136	AND status < 2
	137	ORDER BY stamp DESC`)
1cb3df3f	138
5a2812ca AC	139	fun addIssue (usr, cat, title, priv, status) =
	140	let
	141	val db = getDb ()
	142	val id = nextSeq (db, "SupIssueSeq")
	143	in
	144	C.dml db ($`INSERT INTO SupIssue (id, usr, cat, title, priv, status, stamp)
	145	VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql cat),
	146	^(C.stringToSql title), ^(C.boolToSql priv),
	147	^(statusToSql status), CURRENT_TIMESTAMP)`);
	148	id
	149	end
	150
	151	fun modIssue (iss : issue) =
	152	let
	153	val db = getDb ()
	154	in
	155	ignore (C.dml db ($`UPDATE SupIssue SET
	156	usr = ^(C.intToSql (#usr iss)), cat = ^(C.intToSql (#cat iss)),
	157	title = ^(C.stringToSql (#title iss)), priv = ^(C.boolToSql (#priv iss)),
	158	status = ^(statusToSql (#status iss))
	159	WHERE id = ^(C.intToSql (#id iss))`))
	160	end
	161
	162	fun deleteIssue id =
	163	ignore (C.dml (getDb ()) ($`DELETE FROM SupIssue WHERE id = ^(C.intToSql id)`))
	164
	165
	166	(* Posts *)
	167
	168	fun mkPostRow [id, usr, iss, body, stamp] =
	169	{id = C.intFromSql id, usr = C.intFromSql usr, iss = C.intFromSql iss,
	170	body = C.stringFromSql body, stamp = C.timestampFromSql stamp}
	171	\| mkPostRow row = rowError ("post", row)
	172
	173	fun lookupPost id =
	174	mkPostRow (C.oneRow (getDb ()) ($`SELECT id, usr, iss, body, stamp
	175	FROM SupPost
	176	WHERE id = ^(C.intToSql id)`))
	177
edeb626e AC	178	fun mkPostRow' (name :: rest) = (C.stringFromSql name, mkPostRow rest)
	179	\| mkPostRow' row = Init.rowError ("post'", row)
	180
5a2812ca	181	fun listPosts iss =
edeb626e AC	182	C.map (getDb ()) mkPostRow' ($`SELECT name, SupPost.id, usr, iss, body, SupPost.stamp
	183	FROM SupPost JOIN WebUser ON usr = WebUser.id
	184	WHERE iss = ^(C.intToSql iss)
	185	ORDER BY stamp`)
5a2812ca AC	186
	187	fun addPost (usr, iss, body) =
	188	let
	189	val db = getDb ()
	190	val id = nextSeq (db, "SupPostSeq")
	191	in
	192	C.dml db ($`INSERT INTO SupPost (id, usr, iss, body, stamp)
	193	VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql iss),
	194	^(C.stringToSql body), CURRENT_TIMESTAMP)`);
	195	id
	196	end
	197
	198	fun modPost (post : post) =
	199	let
	200	val db = getDb ()
	201	in
	202	ignore (C.dml db ($`UPDATE SupPost SET
	203	usr = ^(C.intToSql (#usr post)), iss = ^(C.intToSql (#iss post)),
	204	body = ^(C.stringToSql (#body post))
	205	WHERE id = ^(C.intToSql (#id post))`))
	206	end
	207
	208	fun deletePost id =
	209	ignore (C.dml (getDb ()) ($`DELETE FROM SupPost WHERE id = ^(C.intToSql id)`))
	210
	211
	212	(* Subscriptions *)
	213
	214	fun mkSubRow [usr, cat] =
	215	{usr = C.intFromSql usr, cat = C.intFromSql cat}
	216	\| mkSubRow row = rowError ("subscription", row)
	217
	218	fun subscribed {usr, cat} =
	219	case C.oneRow (getDb ()) ($`SELECT COUNT( * ) FROM SupSubscription
	220	WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`) of
	221	[n] => not (C.isNull n) andalso C.intFromSql n > 0
	222	\| r => Init.rowError ("subscribed", r)
	223
	224	fun subscribe (sub as {usr, cat}) =
	225	if subscribed sub then
	226	()
	227	else
	228	ignore (C.dml (getDb ()) ($`INSERT INTO SupSubscription (usr, cat)
	229	VALUES (^(C.intToSql usr), ^(C.intToSql cat))`))
	230
	231	fun unsubscribe {usr, cat} =
	232	ignore (C.dml (getDb ()) ($`DELETE FROM SupSubscription
	233	WHERE usr = ^(C.intToSql usr) AND cat = ^(C.intToSql cat)`))
	234
edeb626e AC	235	val okChars = [#" ", #"-", #".", #"!", #"?", #":", #";", #"'", #"\""]
edeb626e AC	236
1cb3df3f	237	fun validTitle s = CharVector.exists (fn ch => not (Char.isSpace ch)) s
edeb626e AC	238	andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse List.exists (fn ch' => ch = ch') okChars) s
	239
	240	fun allowedToSee iss =
	241	let
	242	val iss = lookupIssue iss
	243	val cat = lookupCategory (#cat iss)
	244	in
	245	not (#priv iss) orelse Group.inGroupNum (#grp cat) orelse (Init.getUserId () = #usr iss)
	246	end
	247
	248	fun allowedToEdit iss =
	249	let
	250	val iss = lookupIssue iss
	251	val cat = lookupCategory (#cat iss)
	252	in
	253	Group.inGroupNum (#grp cat) orelse (Init.getUserId () = #usr iss)
	254	end
	255
5d851d7c	256	fun writeRecipients (mail, iss : issue, cat : category, noName) =
edeb626e AC	257	let
	258	val query =
	259	if #priv iss then
	260	$`SELECT name
	261	FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql (#grp cat)))`
	262	else
	263	$`SELECT name
98a5f121 AC	264	FROM WebUser JOIN SupSubscription ON (usr = id AND cat = ^(C.intToSql (#id cat)))
	265	UNION SELECT name
	266	FROM WebUser JOIN Membership ON (usr = id AND grp = ^(C.intToSql (#grp cat)))`
edeb626e	267
5d851d7c AC	268	fun doOne [name] =
	269	let
	270	val name = C.stringFromSql name
	271	in
	272	if name = noName then
	273	()
	274	else
	275	(Mail.mwrite (mail, name);
	276	Mail.mwrite (mail, ","))
	277	end
edeb626e AC	278	in
	279	Mail.mwrite (mail, "Bcc: ");
	280	C.app (getDb ()) doOne query;
	281	Mail.mwrite (mail, "\n")
	282	end
5a2812ca	283
edeb626e AC	284	fun notify (prefix, f) iss =
	285	let
	286	val iss = lookupIssue iss
	287	val cat = lookupCategory (#cat iss)
	288	val user = Init.lookupUser (#usr iss)
	289
	290	val mail = Mail.mopen ()
	291	in
	292	Mail.mwrite (mail, "From: Hcoop Support System <support@hcoop.net>\nTo: ");
	293	Mail.mwrite (mail, #name user);
	294	Mail.mwrite (mail, "@hcoop.net\n");
5d851d7c	295	writeRecipients (mail, iss, cat, #name user);
edeb626e AC	296	Mail.mwrite (mail, "Subject: ");
	297	Mail.mwrite (mail, prefix);
	298	Mail.mwrite (mail, #title iss);
	299	Mail.mwrite (mail, "\n\nURL: ");
	300	Mail.mwrite (mail, Init.urlPrefix);
	301	Mail.mwrite (mail, "issue?cat=");
	302	Mail.mwrite (mail, C.intToSql (#id cat));
	303	Mail.mwrite (mail, "&id=");
	304	Mail.mwrite (mail, C.intToSql (#id iss));
	305	Mail.mwrite (mail, "\n\nSubmitted by: ");
	306	Mail.mwrite (mail, #name user);
	307	Mail.mwrite (mail, "\n Category: ");
	308	Mail.mwrite (mail, #name cat);
	309	Mail.mwrite (mail, "\n Issue: ");
	310	Mail.mwrite (mail, #title iss);
	311	Mail.mwrite (mail, "\n Private: ");
	312	Mail.mwrite (mail, if #priv iss then "yes" else "no");
	313	Mail.mwrite (mail, "\n\n");
	314
	315	f (iss, cat, user, mail);
	316
	317	OS.Process.isSuccess (Mail.mclose mail)
	318	end
	319
	320	val notifyCreation = notify ("[New] ",
	321	fn (iss, cat, user, mail) =>
	322	(case listPosts (#id iss) of
	323	[] => ()
	324	\| [(_, post)] => Mail.mwrite (mail, #body post)
	325	\| _ => raise Fail "Too many posts for supposedly new support issue"))
	326
	327	fun notifyPost pid =
	328	let
	329	val post = lookupPost pid
	330	val poster = Init.lookupUser (#usr post)
	331	in
	332	notify ("[Post] ",
	333	fn (iss, cat, user, mail) =>
	334	(Mail.mwrite (mail, "New post by ");
	335	Mail.mwrite (mail, #name poster);
	336	Mail.mwrite (mail, ":\n\n");
	337	Mail.mwrite (mail, #body post))) (#iss post)
	338	end
	339
	340	val statusToString =
	341	fn NEW => "New"
	342	\| PENDING => "Pending"
	343	\| CLOSED => "Closed"
	344
	345	fun notifyStatus (usr, oldStatus, newStatus, iss) =
	346	let
	347	val user = Init.lookupUser usr
	348	in
	349	notify ("[" ^ statusToString newStatus ^ "] ",
039a9529	350	fn (iss, cat, user', mail) =>
edeb626e AC	351	(Mail.mwrite (mail, #name user);
	352	Mail.mwrite (mail, " changed status from ");
	353	Mail.mwrite (mail, statusToString oldStatus);
	354	Mail.mwrite (mail, " to ");
	355	Mail.mwrite (mail, statusToString newStatus);
	356	Mail.mwrite (mail, ".\n"))) iss
	357	end
	358
5a2812ca	359	end