1 structure Group
:> GROUP
=
9 type group
= {id
:int, name
: string}
11 fun mkGroupRow
[id
, name
] =
12 {id
= C
.intFromSql id
, name
= C
.stringFromSql name
}
13 | mkGroupRow row
= Init
.rowError ("group", row
)
18 val id
= nextSeq (db
, "WebGroupSeq")
20 C
.dml
db ($`INSERT INTO
WebGroup (id
, name
)
21 VALUES (^
(C
.intToSql id
), ^
(C
.stringToSql name
))`
);
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
)
34 fun modGroup (group
: group
) =
38 ignore (C
.dml
db ($`UPDATE WebGroup
39 SET name
= ^
(C
.stringToSql (#name group
))
40 WHERE id
= ^
(C
.intToSql (#id group
))`
))
44 ignore (C
.dml (getDb ()) ($`DELETE FROM WebGroup WHERE id
= ^
(C
.intToSql id
)`
))
47 C
.map (getDb ()) mkGroupRow ($`SELECT id
, name FROM WebGroup
50 (* Checking group membership
*)
52 fun userInGroupNum (usr
, grp
) =
56 (case C
.oneOrNoRows
c ($`SELECT
COUNT( * )
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
64 fun userInGroupName (usr
, grp
) =
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
77 (* Managing group memberships
*)
79 type membership
= {usr
: int, grp
: int}
81 fun addToGroup (mem
: membership
) =
86 case C
.oneOrNoRows (getDb ()) ($`SELECT
* FROM Membership WHERE grp
= ^
(C
.intToSql grp
) AND usr
= ^
(C
.intToSql usr
)`
) of
87 NONE
=> ignore (C
.dml (getDb ()) ($`INSERT INTO
Membership (grp
, usr
)
88 VALUES (^
(C
.intToSql grp
), ^
(C
.intToSql usr
))`
))
92 fun addToGroups (usr
, grps
) =
93 List.app (fn grp
=> addToGroup
{usr
= usr
, grp
= grp
}) grps
95 fun removeFromGroup (mem
: membership
) =
100 ignore (C
.dml (getDb ()) ($`DELETE FROM Membership
101 WHERE grp
= ^
(C
.intToSql grp
)
102 AND usr
= ^
(C
.intToSql usr
)`
))
105 fun mkMembershipRow
[grp
, usr
] =
106 {grp
= C
.intFromSql grp
, usr
= C
.intFromSql usr
}
107 | mkMembershipRow row
= Init
.rowError ("membership", row
)
109 fun groupMembers grp
=
110 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined
, app
, shares FROM Membership
, WebUser
111 WHERE grp
= ^
(C
.intToSql grp
)
116 (* Checking memberships
of the current user
*)
118 fun inGroupNum grp
= userInGroupNum (getUserId(), grp
)
119 fun inGroupName grp
= userInGroupName (getUserId(), grp
)
121 fun requireGroupNum grp
=
122 if inGroupNum grp
then
125 raise Access ("You aren't a member of group #" ^
Int.toString grp
)
127 fun requireGroupName grp
=
128 if inGroupName grp
then
131 raise Access ("You aren't a member of group \"" ^ grp ^
"\"")
133 fun validGroupName name
=
135 andalso CharVector
.all
Char.isAlpha name
137 fun groupNameToId name
=
138 case C
.oneOrNoRows (getDb ()) ($`SELECT id FROM WebGroup WHERE name
= ^
(C
.stringToSql name
)`
) of
139 SOME
[id
] => SOME (C
.intFromSql id
)