cvsimport

[hcoop/zz_old/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 = Init.rowError ("group", row)

fun addGroup name =
    let
	val db = getDb ()
	val id = nextSeq (db, "WebGroupSeq")
    in
	C.dml db ($`INSERT INTO WebGroup (id, name)
                    VALUES (^(C.intToSql id), ^(C.stringToSql name))`);
	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 IN (0, ^(C.intToSql grp)))
				       AND usr = ^(C.intToSql usr)`) of
	     SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0
	   | _ => false)
    end

fun userInGroupName (usr, grp) =
    let
	val c = getDb ()
    in
	(case C.oneOrNoRows c ($`SELECT COUNT( * )
				    FROM Membership, WebGroup
				    WHERE (grp = 0 OR (name = ^(C.stringToSql grp) AND grp = id))
				       AND usr = ^(C.intToSql usr)`) of
	     SOME[x] => not (C.isNull x) andalso C.intFromSql 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
	case C.oneOrNoRows (getDb ()) ($`SELECT * FROM Membership WHERE grp = ^(C.intToSql grp) AND usr = ^(C.intToSql usr)`) of
	    NONE => ignore (C.dml (getDb ()) ($`INSERT INTO Membership (grp, usr)
					        VALUES (^(C.intToSql grp), ^(C.intToSql usr))`))
	  | SOME _ => ()
    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 = Init.rowError ("membership", row)

fun groupMembers grp =
    C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
				  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.isAlphaNum 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