Commit | Line | Data |
---|---|---|
208e2cbc AC |
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} | |
ee587f7f | 13 | | mkGroupRow row = Init.rowError ("group", row) |
208e2cbc AC |
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) | |
ee587f7f AC |
21 | VALUES (^(C.intToSql id), ^(C.stringToSql name))`); |
22 | id | |
208e2cbc AC |
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 | |
b340786b | 58 | WHERE (grp IN (0, ^(C.intToSql grp))) |
208e2cbc | 59 | AND usr = ^(C.intToSql usr)`) of |
ee587f7f | 60 | SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0 |
208e2cbc AC |
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 | |
88a858ea | 70 | WHERE (grp = 0 OR (name = ^(C.stringToSql grp) AND grp = id)) |
b340786b | 71 | AND usr = ^(C.intToSql usr)`) of |
ee587f7f | 72 | SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0 |
208e2cbc AC |
73 | | _ => false) |
74 | end | |
75 | ||
76 | ||
77 | (* Managing group memberships *) | |
78 | ||
79 | type membership = {usr : int, grp : int} | |
80 | ||
81 | fun addToGroup (mem : membership) = | |
82 | let | |
83 | val usr = #usr mem | |
84 | val grp = #grp mem | |
85 | in | |
86 | if userInGroupNum (usr, grp) then | |
87 | () | |
88 | else | |
89 | ignore (C.dml (getDb ()) ($`INSERT INTO Membership (grp, usr) | |
90 | VALUES (^(C.intToSql grp), ^(C.intToSql usr))`)) | |
91 | end | |
92 | ||
93 | fun addToGroups (usr, grps) = | |
94 | List.app (fn grp => addToGroup {usr = usr, grp = grp}) grps | |
95 | ||
96 | fun removeFromGroup (mem : membership) = | |
97 | let | |
98 | val usr = #usr mem | |
99 | val grp = #grp mem | |
100 | in | |
101 | ignore (C.dml (getDb ()) ($`DELETE FROM Membership | |
102 | WHERE grp = ^(C.intToSql grp) | |
103 | AND usr = ^(C.intToSql usr)`)) | |
104 | end | |
105 | ||
106 | fun mkMembershipRow [grp, usr] = | |
107 | {grp = C.intFromSql grp, usr = C.intFromSql usr} | |
ee587f7f | 108 | | mkMembershipRow row = Init.rowError ("membership", row) |
208e2cbc AC |
109 | |
110 | fun groupMembers grp = | |
111 | C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined FROM Membership, WebUser | |
112 | WHERE grp = ^(C.intToSql grp) | |
113 | AND usr = id | |
114 | ORDER BY name`) | |
115 | ||
116 | ||
117 | (* Checking memberships of the current user *) | |
118 | ||
119 | fun inGroupNum grp = userInGroupNum (getUserId(), grp) | |
120 | fun inGroupName grp = userInGroupName (getUserId(), grp) | |
121 | ||
122 | fun requireGroupNum grp = | |
123 | if inGroupNum grp then | |
124 | () | |
125 | else | |
126 | raise Access ("You aren't a member of group #" ^ Int.toString grp) | |
127 | ||
128 | fun requireGroupName grp = | |
129 | if inGroupName grp then | |
130 | () | |
131 | else | |
132 | raise Access ("You aren't a member of group \"" ^ grp ^ "\"") | |
133 | ||
134 | fun validGroupName name = | |
135 | size name <= 10 | |
136 | andalso CharVector.all Char.isAlpha name | |
137 | ||
138 | fun groupNameToId name = | |
139 | case C.oneOrNoRows (getDb ()) ($`SELECT id FROM WebGroup WHERE name = ^(C.stringToSql name)`) of | |
140 | SOME [id] => SOME (C.intFromSql id) | |
141 | | _ => NONE | |
142 | ||
143 | end |