ACLs

diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg
index 306eee7..c3edb16 100644 (file)
--- a/configDefault/domtool.cfg
+++ b/configDefault/domtool.cfg
@@ -16,3 +16,7 @@ val defaultMinimum = 3600
 
 val nodeIps = [("this", "1.2.3.4")]
 val defaultNode = "this"
 
 val nodeIps = [("this", "1.2.3.4")]
 val defaultNode = "this"

+
+val aclFile = "/home/adamc/fake/acl"
+
+val testUser = "adamc"

diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs
index e23e55f..e42271a 100644 (file)
--- a/configDefault/domtool.cfs
+++ b/configDefault/domtool.cfs
@@ -24,3 +24,8 @@ val defaultMinimum : int
 (* Names of machines who will receive configuration *)
 val nodeIps : (string * string) list
 val defaultNode : string
 (* Names of machines who will receive configuration *)
 val nodeIps : (string * string) list
 val defaultNode : string

+
+val aclFile : string
+(* Place to serialize ACL information *)
+
+val testUser : string

diff --git a/lib/domain.dtl b/lib/domain.dtl
index 0f2b1fa..b2333e8 100644 (file)
--- a/lib/domain.dtl
+++ b/lib/domain.dtl
@@ -9,9 +9,19 @@ extern type host;
 extern type domain;
 {{An Internet domain name}}
 
 extern type domain;
 {{An Internet domain name}}
 

+extern type your_domain;
+{{A domain that you're allowed to configure}}
+

 extern type node;
 {{The name of a server controlled by domtool}}
 
 extern type node;
 {{The name of a server controlled by domtool}}
 

+extern type user;
+extern type group;
+{{UNIX users and groups that you're allowed to run as}}
+
+extern type path;
+{{A filesystem path that you're allowed to use}}
+

 context Domain;
 {{Configuration directives specific to an Internet domain}}
 
 context Domain;
 {{Configuration directives specific to an Internet domain}}
 


@@ -41,5 +51,5 @@ extern val useDns : soa -> master -> [node] -> dnsKind;
 extern val noDns : dnsKind;
 {{No DNS services for this domain.}}
 
 extern val noDns : dnsKind;
 {{No DNS services for this domain.}}
 

-extern val domain : domain -> Domain => [Root] {DNS : dnsKind, TTL : int};
+extern val domain : your_domain -> Domain => [Root] {DNS : dnsKind, TTL : int};

 {{Configure a domain to which you have access rights.}}
 {{Configure a domain to which you have access rights.}}

diff --git a/src/acl.sig b/src/acl.sig
new file mode 100644 (file)
index 0000000..d815cad
--- /dev/null
+++ b/src/acl.sig
@@ -0,0 +1,41 @@
+(* 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 *)
+
+signature ACL = sig
+
+    type acl = {user : string,  (* The UNIX user being granted a permission *)
+               class : string, (* The type of permission granted *)
+               value : string} (* The object for which it is granted *)
+
+    val query : acl -> bool
+    (* Is this permission granted? *)
+
+    val class : {user : string, class : string} -> DataStructures.StringSet.set
+    (* For what objects does the user have the permission? *)
+
+    val grant : acl -> unit
+    val revoke : acl -> unit
+    (* Grant/ungrant the user the permission. *)
+
+    val read : string -> unit
+    val write : string -> unit
+    (* Read/write saved ACL state from/to a file *)
+
+end

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

diff --git a/src/domain.sig b/src/domain.sig
index c4fc329..570fa5e 100644 (file)
--- a/src/domain.sig
+++ b/src/domain.sig
@@ -43,4 +43,11 @@ signature DOMAIN = sig
     (* Names of all system nodes *)
     val nodeMap : string Ast.StringMap.map
     (* Map node names to IP addresses *)
     (* Names of all system nodes *)
     val nodeMap : string Ast.StringMap.map
     (* Map node names to IP addresses *)

+
+    val setUser : string -> unit
+    val getUser : unit -> string
+    (* Name of the UNIX user providing this configuration *)
+
+    val your_domains : unit -> DataStructures.StringSet.set
+    (* The domains the current user may configure *)

 end
 end

diff --git a/src/domain.sml b/src/domain.sml
index 6a70c72..f0e7635 100644 (file)
--- a/src/domain.sml
+++ b/src/domain.sml
@@ -21,11 +21,19 @@
 structure Domain :> DOMAIN = struct
 
 structure SM = DataStructures.StringMap
 structure Domain :> DOMAIN = struct
 
 structure SM = DataStructures.StringMap

+structure SS = DataStructures.StringSet

 
 

-val nodes = map #2 Config.nodeIps
+val nodes = map #1 Config.nodeIps

 val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
                    SM.empty Config.nodeIps
 
 val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
                    SM.empty Config.nodeIps
 

+val usr = ref ""
+fun setUser ur = usr := ur
+fun getUser () = !usr
+
+val your_doms = ref SS.empty
+fun your_domains () = !your_doms
+

 fun validIp s =
     case map Int.fromString (String.fields (fn ch => ch = #".") s) of
        [SOME n1, SOME n2, SOME n3, SOME n4] =>
 fun validIp s =
     case map Int.fromString (String.fields (fn ch => ch = #".") s) of
        [SOME n1, SOME n2, SOME n3, SOME n4] =>


@@ -44,6 +52,8 @@ fun validDomain s =
 
 fun validNode s = List.exists (fn s' => s = s') nodes
 
 
 fun validNode s = List.exists (fn s' => s = s') nodes
 

+fun yourDomain s = SS.member (your_domains (), s)
+

 val _ = Env.type_one "ip"
        Env.string
        validIp
 val _ = Env.type_one "ip"
        Env.string
        validIp


@@ -56,6 +66,10 @@ val _ = Env.type_one "domain"
        Env.string
        validDomain
 
        Env.string
        validDomain
 

+val _ = Env.type_one "your_domain"
+       Env.string
+       yourDomain
+

 val _ = Env.type_one "node"
        Env.string
        validNode
 val _ = Env.type_one "node"
        Env.string
        validNode


@@ -411,6 +425,11 @@ val _ = Env.containerV_one "domain"
                               end,
                            fn () => !afters (!current))
 
                               end,
                            fn () => !afters (!current))
 

+val () = Env.registerPreTycheck (fn () => (setUser Config.testUser;
+                                          Acl.read Config.aclFile;
+                                          your_doms := Acl.class {user = getUser (),
+                                                                  class = "domain"}))
+

 val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
                                                       fn cl => "Temp file cleanup failed: " ^ cl));
                                    OS.FileSys.mkDir Config.tmpDir;
 val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
                                                       fn cl => "Temp file cleanup failed: " ^ cl));
                                    OS.FileSys.mkDir Config.tmpDir;


@@ -457,9 +476,9 @@ val () = Env.registerPost (fn () =>
                                  if !ErrorMsg.anyErrors then
                                      ()
                                  else
                                  if !ErrorMsg.anyErrors then
                                      ()
                                  else

-                                     Slave.handleChanges (map #2 diffs);
+                                     Slave.handleChanges (map #2 diffs)(*;

                                  ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
                                  ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],

-                                                    fn cl => "Temp file cleanup failed: " ^ cl))
+                                                    fn cl => "Temp file cleanup failed: " ^ cl))*)

                              end)
 
 
                              end)
 
 

diff --git a/src/domtool.cm b/src/domtool.cm
index f7f6551..bb7047e 100644 (file)
--- a/src/domtool.cm
+++ b/src/domtool.cm
@@ -41,6 +41,9 @@ eval.sml
 baseTypes.sig
 baseTypes.sml
 
 baseTypes.sig
 baseTypes.sml
 

+acl.sig
+acl.sml
+

 slave.sig
 slave.sml
 
 slave.sig
 slave.sml
 

diff --git a/src/env.sig b/src/env.sig
index 477af94..e5f19e6 100644 (file)
--- a/src/env.sig
+++ b/src/env.sig
@@ -38,6 +38,10 @@ signature ENV = sig
     val registerPost : (unit -> unit) -> unit
     val post : unit -> unit
 
     val registerPost : (unit -> unit) -> unit
     val post : unit -> unit
 

+    (* ...and before type-checking *)
+    val registerPreTycheck : (unit -> unit) -> unit
+    val preTycheck : unit -> unit
+

     val badArgs : string * Ast.exp list -> 'a
     val badArg : string * string * Ast.exp -> 'a
 
     val badArgs : string * Ast.exp list -> 'a
     val badArg : string * string * Ast.exp -> 'a
 

diff --git a/src/env.sml b/src/env.sml
index 167adce..db92e6e 100644 (file)
--- a/src/env.sml
+++ b/src/env.sml
@@ -69,6 +69,20 @@ fun post () = !pst ()
 
 end
 
 
 end
 

+local
+    val pr = ref (fn () => ())
+in
+
+fun registerPreTycheck f =
+    let
+       val old = !pr
+    in
+       pr := (fn () => (old (); f ()))
+    end
+fun preTycheck () = !pr ()
+
+end
+

 fun badArgs (name, args) =
     (print ("Invalid arguments to " ^ name ^ "\n");
      app (fn arg => Print.preface ("Argument: ", Print.p_exp arg)) args;
 fun badArgs (name, args) =
     (print ("Invalid arguments to " ^ name ^ "\n");
      app (fn arg => Print.preface ("Argument: ", Print.p_exp arg)) args;

diff --git a/src/main.sml b/src/main.sml
index 59a76d5..b91f73a 100644 (file)
--- a/src/main.sml
+++ b/src/main.sml
@@ -81,6 +81,7 @@ fun basis () =
 fun check fname =
     let
        val _ = ErrorMsg.reset ()
 fun check fname =
     let
        val _ = ErrorMsg.reset ()

+       val _ = Env.preTycheck ()

 
        val b = basis ()
     in
 
        val b = basis ()
     in