| 1 | structure Group :> GROUP = |
| 2 | struct |
| 3 | |
| 4 | open Util Sql Init |
| 5 | |
| 6 | |
| 7 | (* Managing groups *) |
| 8 | |
| 9 | type group = {id :int, name : string} |
| 10 | |
| 11 | fun mkGroupRow [id, name] = |
| 12 | {id = C.intFromSql id, name = C.stringFromSql name} |
| 13 | | mkGroupRow row = Init.rowError ("group", row) |
| 14 | |
| 15 | fun addGroup name = |
| 16 | let |
| 17 | val db = getDb () |
| 18 | val id = nextSeq (db, "WebGroupSeq") |
| 19 | in |
| 20 | C.dml db ($`INSERT INTO WebGroup (id, name) |
| 21 | VALUES (^(C.intToSql id), ^(C.stringToSql name))`); |
| 22 | id |
| 23 | end |
| 24 | |
| 25 | fun lookupGroup id = |
| 26 | let |
| 27 | val c = getDb () |
| 28 | in |
| 29 | (case C.oneOrNoRows c ($`SELECT id, name FROM WebGroup WHERE id = ^(C.intToSql id)`) of |
| 30 | NONE => raise Fail "Group not found" |
| 31 | | SOME r => mkGroupRow r) |
| 32 | end |
| 33 | |
| 34 | fun modGroup (group : group) = |
| 35 | let |
| 36 | val db = getDb () |
| 37 | in |
| 38 | ignore (C.dml db ($`UPDATE WebGroup |
| 39 | SET name = ^(C.stringToSql (#name group)) |
| 40 | WHERE id = ^(C.intToSql (#id group))`)) |
| 41 | end |
| 42 | |
| 43 | fun deleteGroup id = |
| 44 | ignore (C.dml (getDb ()) ($`DELETE FROM WebGroup WHERE id = ^(C.intToSql id)`)) |
| 45 | |
| 46 | fun listGroups () = |
| 47 | C.map (getDb ()) mkGroupRow ($`SELECT id, name FROM WebGroup |
| 48 | ORDER BY name`) |
| 49 | |
| 50 | (* Checking group membership *) |
| 51 | |
| 52 | fun userInGroupNum (usr, grp) = |
| 53 | let |
| 54 | val c = getDb () |
| 55 | in |
| 56 | (case C.oneOrNoRows c ($`SELECT COUNT( * ) |
| 57 | FROM Membership |
| 58 | WHERE (grp IN (0, ^(C.intToSql grp))) |
| 59 | AND usr = ^(C.intToSql usr)`) of |
| 60 | SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0 |
| 61 | | _ => false) |
| 62 | end |
| 63 | |
| 64 | fun userInGroupName (usr, grp) = |
| 65 | let |
| 66 | val c = getDb () |
| 67 | in |
| 68 | (case C.oneOrNoRows c ($`SELECT COUNT( * ) |
| 69 | FROM Membership, WebGroup |
| 70 | WHERE (grp = 0 OR (name = ^(C.stringToSql grp) AND grp = id)) |
| 71 | AND usr = ^(C.intToSql usr)`) of |
| 72 | SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0 |
| 73 | | _ => false) |
| 74 | end |
| 75 | |
| 76 | fun userReallyInGroupName (usr, grp) = |
| 77 | let |
| 78 | val c = getDb () |
| 79 | in |
| 80 | (case C.oneOrNoRows c ($`SELECT COUNT( * ) |
| 81 | FROM Membership, WebGroup |
| 82 | WHERE (name = ^(C.stringToSql grp) AND grp = id) |
| 83 | AND usr = ^(C.intToSql usr)`) of |
| 84 | SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0 |
| 85 | | _ => false) |
| 86 | end |
| 87 | |
| 88 | |
| 89 | (* Managing group memberships *) |
| 90 | |
| 91 | type membership = {usr : int, grp : int} |
| 92 | |
| 93 | fun addToGroup (mem : membership) = |
| 94 | let |
| 95 | val usr = #usr mem |
| 96 | val grp = #grp mem |
| 97 | in |
| 98 | case C.oneOrNoRows (getDb ()) ($`SELECT * FROM Membership WHERE grp = ^(C.intToSql grp) AND usr = ^(C.intToSql usr)`) of |
| 99 | NONE => ignore (C.dml (getDb ()) ($`INSERT INTO Membership (grp, usr) |
| 100 | VALUES (^(C.intToSql grp), ^(C.intToSql usr))`)) |
| 101 | | SOME _ => () |
| 102 | end |
| 103 | |
| 104 | fun addToGroups (usr, grps) = |
| 105 | List.app (fn grp => addToGroup {usr = usr, grp = grp}) grps |
| 106 | |
| 107 | fun removeFromGroup (mem : membership) = |
| 108 | let |
| 109 | val usr = #usr mem |
| 110 | val grp = #grp mem |
| 111 | in |
| 112 | ignore (C.dml (getDb ()) ($`DELETE FROM Membership |
| 113 | WHERE grp = ^(C.intToSql grp) |
| 114 | AND usr = ^(C.intToSql usr)`)) |
| 115 | end |
| 116 | |
| 117 | fun mkMembershipRow [grp, usr] = |
| 118 | {grp = C.intFromSql grp, usr = C.intFromSql usr} |
| 119 | | mkMembershipRow row = Init.rowError ("membership", row) |
| 120 | |
| 121 | fun groupMembers grp = |
| 122 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout |
| 123 | FROM Membership, WebUser |
| 124 | WHERE grp = ^(C.intToSql grp) |
| 125 | AND usr = id |
| 126 | ORDER BY name`) |
| 127 | |
| 128 | |
| 129 | (* Checking memberships of the current user *) |
| 130 | |
| 131 | fun inGroupNum grp = userInGroupNum (getUserId(), grp) |
| 132 | fun inGroupName grp = userInGroupName (getUserId(), grp) |
| 133 | fun reallyInGroupName grp = userReallyInGroupName (getUserId(), grp) |
| 134 | |
| 135 | fun requireGroupNum grp = |
| 136 | if inGroupNum grp then |
| 137 | () |
| 138 | else |
| 139 | raise Access ("You aren't a member of group #" ^ Int.toString grp) |
| 140 | |
| 141 | fun requireGroupName grp = |
| 142 | if inGroupName grp then |
| 143 | () |
| 144 | else |
| 145 | raise Access ("You aren't a member of group \"" ^ grp ^ "\"") |
| 146 | |
| 147 | fun validGroupName name = |
| 148 | size name <= 10 |
| 149 | andalso CharVector.all Char.isAlphaNum name |
| 150 | |
| 151 | fun groupNameToId name = |
| 152 | case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebGroup WHERE name = ^(C.stringToSql name)`) of |
| 153 | SOME [id] => SOME (C.intFromSql id) |
| 154 | | _ => NONE |
| 155 | |
| 156 | end |