Contact kind administration

[bpt/portal.git] / group.sml

structure Group :> GROUP =
struct

open Util Sql Init


(* Managing groups *)

type group = {id :int, name : string}

fun mkGroupRow [id, name] =
    {id = C.intFromSql id, name = C.stringFromSql name}
  | mkGroupRow row = raise Fail ("Bad group row : " ^ makeSet id row)

fun addGroup name =
    let
	val db = getDb ()
	val id = nextSeq (db, "WebGroupSeq")
    in
	C.dml db ($`INSERT INTO WebGroup (id, name)
                    VALUES (^id, ^(C.stringToSql name))`);
	C.intFromSql id
    end

fun lookupGroup id =
    let
	val c = getDb ()
    in
	(case C.oneOrNoRows c ($`SELECT id, name FROM WebGroup WHERE id = ^(C.intToSql id)`) of
	     NONE => raise Fail "Group not found"
	   | SOME r => mkGroupRow r)
    end

fun modGroup (group : group) =
    let
	val db = getDb ()
    in
	ignore (C.dml db ($`UPDATE WebGroup
			    SET name = ^(C.stringToSql (#name group))
			    WHERE id = ^(C.intToSql (#id group))`))
    end

fun deleteGroup id =
    ignore (C.dml (getDb ()) ($`DELETE FROM WebGroup WHERE id = ^(C.intToSql id)`))

fun listGroups () =
    C.map (getDb ()) mkGroupRow ($`SELECT id, name FROM WebGroup
				   ORDER BY name`)

(* Checking group membership *)

fun userInGroupNum (usr, grp) =
    let
	val c = getDb ()
    in
	(case C.oneOrNoRows c ($`SELECT COUNT( * )
				    FROM Membership
				    WHERE grp = ^(C.intToSql grp)
				       AND usr = ^(C.intToSql usr)`) of
	     SOME[x] => x <> "0"
	   | _ => false)
    end

fun userInGroupName (usr, grp) =
    let
	val c = getDb ()
    in
	(case C.oneOrNoRows c ($`SELECT COUNT( * )
				    FROM Membership, WebGroup
				    WHERE name = ^(C.stringToSql grp)
				       AND usr = ^(C.intToSql usr)
                                       AND grp = id`) of
	     SOME[x] => x <> "0"
	   | _ => false)
    end


(* Managing group memberships *)

type membership = {usr : int, grp : int}

fun addToGroup (mem : membership) =
    let
	val usr = #usr mem
	val grp = #grp mem
    in
	if userInGroupNum (usr, grp) then
	    ()
	else
	    ignore (C.dml (getDb ()) ($`INSERT INTO Membership (grp, usr)
					VALUES (^(C.intToSql grp), ^(C.intToSql usr))`))
    end

fun addToGroups (usr, grps) =
    List.app (fn grp => addToGroup {usr = usr, grp = grp}) grps

fun removeFromGroup (mem : membership) =
    let
	val usr = #usr mem
	val grp = #grp mem
    in
	ignore (C.dml (getDb ()) ($`DELETE FROM Membership
			            WHERE grp = ^(C.intToSql grp)
				       AND usr = ^(C.intToSql usr)`))
    end

fun mkMembershipRow [grp, usr] =
    {grp = C.intFromSql grp, usr = C.intFromSql usr}
  | mkMembershipRow row = raise Fail ("Bad membership row : " ^ makeSet id row)

fun groupMembers grp =
    C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined FROM Membership, WebUser
					WHERE grp = ^(C.intToSql grp)
					   AND usr = id
					ORDER BY name`)


(* Checking memberships of the current user *)

fun inGroupNum grp = userInGroupNum (getUserId(), grp)
fun inGroupName grp = userInGroupName (getUserId(), grp)

fun requireGroupNum grp =
    if inGroupNum grp then
	()
    else
	raise Access ("You aren't a member of group #" ^ Int.toString grp)

fun requireGroupName grp =
    if inGroupName grp then
	()
    else
	raise Access ("You aren't a member of group \"" ^ grp ^ "\"")

fun validGroupName name =
    size name <= 10
    andalso CharVector.all Char.isAlpha name

fun groupNameToId name =
    case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebGroup WHERE name = ^(C.stringToSql name)`) of
	SOME [id] => SOME (C.intFromSql id)
      | _ => NONE

end