[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, 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 }


(* 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, 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,
     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, pstamp, cstamp
		  		       FROM SupIssue
			     	       WHERE id = ^(C.intToSql id)`))

fun listIssues () =
    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 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 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 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, pstamp, cstamp)
		    VALUES (^(C.intToSql id), ^(C.intToSql usr), ^(C.intToSql cat),
			    ^(C.stringToSql title), ^(C.boolToSql priv),
			    ^(statusToSql status), CURRENT_TIMESTAMP, NULL, NULL)`);
	id
    end

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