ACLs
[hcoop/domtool2.git] / src / acl.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, Adam Chlipala
3 *
4 * This program is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU General Public License
6 * as published by the Free Software Foundation; either version 2
7 * of the License, or (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
17 *)
18
19 (* Per-user access control lists for resources various *)
20
21 structure Acl :> ACL = struct
22
23 type acl = {user : string,
24 class : string,
25 value : string}
26
27 structure SM = DataStructures.StringMap
28 structure SS = DataStructures.StringSet
29
30 val acl : SS.set SM.map SM.map ref = ref SM.empty
31
32 fun query {user, class, value} =
33 case SM.find (!acl, user) of
34 NONE => false
35 | SOME classes =>
36 case SM.find (classes, class) of
37 NONE => false
38 | SOME values => SS.member (values, value)
39
40 fun class {user, class} =
41 case SM.find (!acl, user) of
42 NONE => SS.empty
43 | SOME classes =>
44 case SM.find (classes, class) of
45 NONE => SS.empty
46 | SOME values => values
47
48 fun grant {user, class, value} =
49 let
50 val classes = Option.getOpt (SM.find (!acl, user), SM.empty)
51 val values = Option.getOpt (SM.find (classes, class), SS.empty)
52 in
53 acl := SM.insert (!acl, user,
54 SM.insert (classes, class,
55 SS.add (values, value)))
56 end
57
58 fun revoke {user, class, value} =
59 let
60 val classes = Option.getOpt (SM.find (!acl, user), SM.empty)
61 val values = Option.getOpt (SM.find (classes, class), SS.empty)
62
63 val values = if SS.member (values, value) then
64 SS.delete (values, value)
65 else
66 values
67 in
68 acl := SM.insert (!acl, user,
69 SM.insert (classes, class,
70 values))
71 end
72
73 fun read fname =
74 let
75 val inf = TextIO.openIn fname
76
77 fun users usrs =
78 case TextIO.inputLine inf of
79 NONE => usrs
80 | SOME line =>
81 case String.tokens Char.isSpace line of
82 [user] =>
83 let
84 fun classes clss =
85 case TextIO.inputLine inf of
86 NONE => clss
87 | SOME line =>
88 case String.tokens Char.isSpace line of
89 [] => clss
90 | class :: values =>
91 classes (SM.insert (clss, class,
92 foldl SS.add' SS.empty values))
93 in
94 users (SM.insert (usrs, user, classes SM.empty))
95 end
96 | _ => raise Fail "Unexpected ACL file format"
97 in
98 acl := users SM.empty
99 before TextIO.closeIn inf
100 end
101
102 fun write fname =
103 let
104 val outf = TextIO.openOut fname
105
106 val writeValues = SS.app (fn value =>
107 (TextIO.output (outf, " ");
108 TextIO.output (outf, value)))
109
110 val writeClasses = SM.appi (fn (class, values) =>
111 (TextIO.output (outf, class);
112 writeValues values;
113 TextIO.output (outf, "\n")))
114
115 val writeUsers = SM.appi (fn (user, classes) =>
116 (TextIO.output (outf, user);
117 TextIO.output (outf, "\n");
118 writeClasses classes;
119 TextIO.output (outf, "\n")))
120 in
121 writeUsers (!acl);
122 TextIO.closeOut outf
123 end
124
125 end