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
= ^
(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 name
= ^
(C
.stringToSql grp
)
71 AND usr
= ^
(C
.intToSql usr
)
73 SOME
[x
] => not (C
.isNull x
) andalso C
.intFromSql x
<> 0
78 (* Managing group memberships
*)
80 type membership
= {usr
: int, grp
: int}
82 fun addToGroup (mem
: membership
) =
87 if userInGroupNum (usr
, grp
) then
90 ignore (C
.dml (getDb ()) ($`INSERT INTO
Membership (grp
, usr
)
91 VALUES (^
(C
.intToSql grp
), ^
(C
.intToSql usr
))`
))
94 fun addToGroups (usr
, grps
) =
95 List.app (fn grp
=> addToGroup
{usr
= usr
, grp
= grp
}) grps
97 fun removeFromGroup (mem
: membership
) =
102 ignore (C
.dml (getDb ()) ($`DELETE FROM Membership
103 WHERE grp
= ^
(C
.intToSql grp
)
104 AND usr
= ^
(C
.intToSql usr
)`
))
107 fun mkMembershipRow
[grp
, usr
] =
108 {grp
= C
.intFromSql grp
, usr
= C
.intFromSql usr
}
109 | mkMembershipRow row
= Init
.rowError ("membership", row
)
111 fun groupMembers grp
=
112 C
.map (getDb ()) mkUserRow ($`SELECT id
, name
, rname
, bal
, joined FROM Membership
, WebUser
113 WHERE grp
= ^
(C
.intToSql grp
)
118 (* Checking memberships
of the current user
*)
120 fun inGroupNum grp
= userInGroupNum (getUserId(), grp
)
121 fun inGroupName grp
= userInGroupName (getUserId(), grp
)
123 fun requireGroupNum grp
=
124 if inGroupNum grp
then
127 raise Access ("You aren't a member of group #" ^
Int.toString grp
)
129 fun requireGroupName grp
=
130 if inGroupName grp
then
133 raise Access ("You aren't a member of group \"" ^ grp ^
"\"")
135 fun validGroupName name
=
137 andalso CharVector
.all
Char.isAlpha name
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
)