From 12adf55a902b1d9bde677e4636530e5753857e05 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 6 Aug 2006 17:14:04 +0000 Subject: [PATCH] ACLs --- configDefault/domtool.cfg | 4 ++ configDefault/domtool.cfs | 5 ++ lib/domain.dtl | 12 +++- src/acl.sig | 41 +++++++++++++ src/acl.sml | 125 ++++++++++++++++++++++++++++++++++++++ src/domain.sig | 7 +++ src/domain.sml | 25 +++++++- src/domtool.cm | 3 + src/env.sig | 4 ++ src/env.sml | 14 +++++ src/main.sml | 1 + 11 files changed, 237 insertions(+), 4 deletions(-) create mode 100644 src/acl.sig create mode 100644 src/acl.sml diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index 306eee7..c3edb16 100644 --- 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 aclFile = "/home/adamc/fake/acl" + +val testUser = "adamc" diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs index e23e55f..e42271a 100644 --- 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 + +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 --- a/lib/domain.dtl +++ b/lib/domain.dtl @@ -9,9 +9,19 @@ extern type host; 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}} @@ -41,5 +51,5 @@ extern val useDns : soa -> master -> [node] -> dnsKind; 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.}} diff --git a/src/acl.sig b/src/acl.sig new file mode 100644 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 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 --- 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 *) + + 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 diff --git a/src/domain.sml b/src/domain.sml index 6a70c72..f0e7635 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -21,11 +21,19 @@ 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] => @@ -44,6 +52,8 @@ fun validDomain s = 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 @@ -56,6 +66,10 @@ val _ = Env.type_one "domain" Env.string validDomain +val _ = Env.type_one "your_domain" + Env.string + yourDomain + val _ = Env.type_one "node" Env.string validNode @@ -411,6 +425,11 @@ val _ = Env.containerV_one "domain" 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; @@ -457,9 +476,9 @@ val () = Env.registerPost (fn () => 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) diff --git a/src/domtool.cm b/src/domtool.cm index f7f6551..bb7047e 100644 --- a/src/domtool.cm +++ b/src/domtool.cm @@ -41,6 +41,9 @@ eval.sml baseTypes.sig baseTypes.sml +acl.sig +acl.sml + slave.sig slave.sml diff --git a/src/env.sig b/src/env.sig index 477af94..e5f19e6 100644 --- a/src/env.sig +++ b/src/env.sig @@ -38,6 +38,10 @@ signature ENV = sig 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 diff --git a/src/env.sml b/src/env.sml index 167adce..db92e6e 100644 --- a/src/env.sml +++ b/src/env.sml @@ -69,6 +69,20 @@ fun post () = !pst () 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; diff --git a/src/main.sml b/src/main.sml index 59a76d5..b91f73a 100644 --- a/src/main.sml +++ b/src/main.sml @@ -81,6 +81,7 @@ fun basis () = fun check fname = let val _ = ErrorMsg.reset () + val _ = Env.preTycheck () val b = basis () in -- 2.20.1