ACLs

[hcoop/domtool2.git] / src / acl.sml

diff --git a/src/acl.sml b/src/acl.sml
new file mode 100644 (file)
index 0000000..d0b41fe
--- /dev/null
+++ b/src/acl.sml
@@ -0,0 +1,125 @@
+(* HCoop Domtool (http://hcoop.sourceforge.net/)
+ * Copyright (c) 2006, Adam Chlipala
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+ *)
+
+(* Per-user access control lists for resources various *)
+
+structure Acl :> ACL = struct
+
+type acl = {user : string,
+           class : string,
+           value : string}
+
+structure SM = DataStructures.StringMap
+structure SS = DataStructures.StringSet
+
+val acl : SS.set SM.map SM.map ref = ref SM.empty
+
+fun query {user, class, value} =
+    case SM.find (!acl, user) of
+       NONE => false
+      | SOME classes =>
+       case SM.find (classes, class) of
+           NONE => false
+         | SOME values => SS.member (values, value)
+
+fun class {user, class} =
+    case SM.find (!acl, user) of
+       NONE => SS.empty
+      | SOME classes =>
+       case SM.find (classes, class) of
+           NONE => SS.empty
+         | SOME values => values
+
+fun grant {user, class, value} =
+    let
+       val classes = Option.getOpt (SM.find (!acl, user), SM.empty)
+       val values = Option.getOpt (SM.find (classes, class), SS.empty)
+    in
+       acl := SM.insert (!acl, user,
+                         SM.insert (classes, class,
+                                    SS.add (values, value)))
+    end
+
+fun revoke {user, class, value} =
+    let
+       val classes = Option.getOpt (SM.find (!acl, user), SM.empty)
+       val values = Option.getOpt (SM.find (classes, class), SS.empty)
+
+       val values = if SS.member (values, value) then
+                        SS.delete (values, value)
+                    else
+                        values
+    in
+       acl := SM.insert (!acl, user,
+                         SM.insert (classes, class,
+                                    values))
+    end
+
+fun read fname =
+    let
+       val inf = TextIO.openIn fname
+
+       fun users usrs =
+           case TextIO.inputLine inf of
+               NONE => usrs
+             | SOME line =>
+               case String.tokens Char.isSpace line of
+                   [user] =>
+                   let
+                       fun classes clss =
+                           case TextIO.inputLine inf of
+                               NONE => clss
+                             | SOME line =>
+                               case String.tokens Char.isSpace line of
+                                   [] => clss
+                                 | class :: values =>
+                                   classes (SM.insert (clss, class,
+                                                       foldl SS.add' SS.empty values))
+                   in
+                       users (SM.insert (usrs, user, classes SM.empty))
+                   end
+                 | _ => raise Fail "Unexpected ACL file format"
+    in
+       acl := users SM.empty
+       before TextIO.closeIn inf
+    end
+
+fun write fname =
+    let
+       val outf = TextIO.openOut fname
+
+       val writeValues = SS.app (fn value =>
+                                    (TextIO.output (outf, " ");
+                                     TextIO.output (outf, value)))
+
+       val writeClasses = SM.appi (fn (class, values) =>
+                                      (TextIO.output (outf, class);
+                                       writeValues values;
+                                       TextIO.output (outf, "\n")))
+
+       val writeUsers = SM.appi (fn (user, classes) =>
+                                    (TextIO.output (outf, user);
+                                     TextIO.output (outf, "\n");
+                                     writeClasses classes;
+                                     TextIO.output (outf, "\n")))
+    in
+       writeUsers (!acl);
+       TextIO.closeOut outf
+    end
+
+end