Basic issue management

[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 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 ()
	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)`))

fun validTitle s = CharVector.exists (fn ch => not (Char.isSpace ch)) s

end