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