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