--- /dev/null
+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
HCoop / bpt / portal.git / blobdiff