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 | ||
f3a41f3b AC |
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 | ||
208e2cbc AC |
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 | |
9bda1e7f AC |
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 _ => () | |
208e2cbc AC |
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} | |
ee587f7f | 119 | | mkMembershipRow row = Init.rowError ("membership", row) |
208e2cbc AC |
120 | |
121 | fun groupMembers grp = | |
d5f8418b AC |
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`) | |
208e2cbc AC |
127 | |
128 | ||
129 | (* Checking memberships of the current user *) | |
130 | ||
131 | fun inGroupNum grp = userInGroupNum (getUserId(), grp) | |
132 | fun inGroupName grp = userInGroupName (getUserId(), grp) | |
f3a41f3b | 133 | fun reallyInGroupName grp = userReallyInGroupName (getUserId(), grp) |
208e2cbc AC |
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 | |
5a035d64 | 149 | andalso CharVector.all Char.isAlphaNum name |
208e2cbc AC |
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 | ||
2ac29940 | 156 | end |