val nodeIps = [("this", "1.2.3.4")]
val defaultNode = "this"
+
+val aclFile = "/home/adamc/fake/acl"
+
+val testUser = "adamc"
(* 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
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 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}}
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.}}
--- /dev/null
+(* 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
--- /dev/null
+(* 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
(* 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
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 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 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
Env.string
validDomain
+val _ = Env.type_one "your_domain"
+ Env.string
+ yourDomain
+
val _ = Env.type_one "node"
Env.string
validNode
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;
if !ErrorMsg.anyErrors then
()
else
- Slave.handleChanges (map #2 diffs);
+ Slave.handleChanges (map #2 diffs)(*;
ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
- fn cl => "Temp file cleanup failed: " ^ cl))
+ fn cl => "Temp file cleanup failed: " ^ cl))*)
end)
baseTypes.sig
baseTypes.sml
+acl.sig
+acl.sml
+
slave.sig
slave.sml
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
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 check fname =
let
val _ = ErrorMsg.reset ()
+ val _ = Env.preTycheck ()
val b = basis ()
in