From: Adam Chlipala Date: Sun, 3 Sep 2006 19:38:36 +0000 (+0000) Subject: Server executing client's requested configuration with the right permissions X-Git-Tag: release_2010-11-19~350 X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/commitdiff_plain/aa56e112996b3650e8ac343831322d2a9ab0de54 Server executing client's requested configuration with the right permissions --- diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index 35296fd..421db04 100644 --- a/configDefault/domtool.cfg +++ b/configDefault/domtool.cfg @@ -32,3 +32,7 @@ val bufSize = 1024 val trustStore = "/home/adamc/fake/TrustKey.pem" val serverCert = "/home/adamc/fake/servercert.pem" val serverKey = "/home/adamc/fake/serverkey.pem" + +val certDir = "/home/adamc/fake/certs" +val keyDir = "/home/adamc/fake/keys" + diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs index 109f09f..2d3bc14 100644 --- a/configDefault/domtool.cfs +++ b/configDefault/domtool.cfs @@ -41,3 +41,6 @@ val bufSize : int val trustStore : string val serverCert : string val serverKey : string + +val certDir : string +val keyDir : string diff --git a/src/defaults.sig b/src/defaults.sig new file mode 100644 index 0000000..c380705 --- /dev/null +++ b/src/defaults.sig @@ -0,0 +1,26 @@ +(* 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. + *) + +(* Default record field database *) + +signature DEFAULTS = sig + val registerDefault : string * Ast.typ * (unit -> Ast.exp) -> unit + + val tInit : unit -> Ast.typ + val eInit : unit -> Env.env_vars +end diff --git a/src/defaults.sml b/src/defaults.sml new file mode 100644 index 0000000..43dced5 --- /dev/null +++ b/src/defaults.sml @@ -0,0 +1,46 @@ +(* 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. + *) + +(* Default record field database *) + +structure Defaults :> DEFAULTS = struct + +open Ast Print + +structure SM = StringMap + +val dmy = ErrorMsg.dummyLoc + +val defaultT : record ref = ref SM.empty +val defaultV : (unit -> exp) SM.map ref = ref SM.empty + +fun registerDefault (name, t, v) = + case SM.find (!defaultT, name) of + NONE => (defaultT := SM.insert (!defaultT, name, t); + defaultV := SM.insert (!defaultV, name, v)) + | SOME _ => raise Fail "Duplicate default environment variable" + +fun tInit () = (TAction ((CRoot, dmy), + !defaultT, + StringMap.empty), + dmy) + +fun eInit () = SM.map (fn f => f ()) (!defaultV) + + +end diff --git a/src/domain.sml b/src/domain.sml index 27bc806..2d566a3 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -29,7 +29,6 @@ val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip)) fun nodeIp node = valOf (SM.find (nodeMap, node)) val usr = ref "" -fun setUser ur = usr := ur fun getUser () = !usr val your_doms = ref SS.empty @@ -44,6 +43,17 @@ fun your_groups () = !your_grps val your_pths = ref SS.empty fun your_paths () = !your_pths +fun setUser user = + (usr := Config.testUser; + your_doms := Acl.class {user = getUser (), + class = "domain"}; + your_usrs := Acl.class {user = getUser (), + class = "user"}; + your_grps := Acl.class {user = getUser (), + class = "group"}; + your_pths := Acl.class {user = getUser (), + class = "path"}) + fun validIp s = case map Int.fromString (String.fields (fn ch => ch = #".") s) of [SOME n1, SOME n2, SOME n3, SOME n4] => @@ -157,15 +167,15 @@ val masterD = (EApp ((EVar "internalMaster", dl), (EString Config.defaultNode, dl)), dl) -val _ = Main.registerDefault ("DNS", - (TBase "dnsKind", dl), - (fn () => multiApp ((EVar "useDns", dl), - dl, - [soaD, masterD, (EList [], dl)]))) +val _ = Defaults.registerDefault ("DNS", + (TBase "dnsKind", dl), + (fn () => multiApp ((EVar "useDns", dl), + dl, + [soaD, masterD, (EList [], dl)]))) -val _ = Main.registerDefault ("TTL", - (TBase "int", dl), - (fn () => (EInt Config.Bind.defaultTTL, dl))) +val _ = Defaults.registerDefault ("TTL", + (TBase "int", dl), + (fn () => (EInt Config.Bind.defaultTTL, dl))) type soa = {ns : string, serial : int option, @@ -490,17 +500,6 @@ 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"}; - your_usrs := Acl.class {user = getUser (), - class = "user"}; - your_grps := Acl.class {user = getUser (), - class = "group"}; - your_pths := Acl.class {user = getUser (), - class = "path"})) - val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""], fn cl => "Temp file cleanup failed: " ^ cl)); OS.FileSys.mkDir Config.tmpDir; diff --git a/src/domtool.cm b/src/domtool.cm index ab147b7..d1988c3 100644 --- a/src/domtool.cm +++ b/src/domtool.cm @@ -50,6 +50,9 @@ acl.sml slave.sig slave.sml +defaults.sig +defaults.sml + domain.sig domain.sml diff --git a/src/main.sig b/src/main.sig index 90c7cc9..ef13569 100644 --- a/src/main.sig +++ b/src/main.sig @@ -20,8 +20,7 @@ signature MAIN = sig - val tInit : unit -> Ast.typ - val registerDefault : string * Ast.typ * (unit -> Ast.exp) -> unit + val init : unit -> unit val check : string -> Env.env * Ast.exp option val check' : Env.env -> string -> Env.env diff --git a/src/main.sml b/src/main.sml index 0e1e503..e0beaf2 100644 --- a/src/main.sml +++ b/src/main.sml @@ -24,33 +24,16 @@ open Ast Print structure SM = StringMap -val dmy = ErrorMsg.dummyLoc - -val defaultT : record ref = ref SM.empty -val defaultV : (unit -> exp) SM.map ref = ref SM.empty - -fun registerDefault (name, t, v) = - case SM.find (!defaultT, name) of - NONE => (defaultT := SM.insert (!defaultT, name, t); - defaultV := SM.insert (!defaultV, name, v)) - | SOME _ => raise Fail "Duplicate default environment variable" - -fun tInit () = (TAction ((CRoot, dmy), - !defaultT, - StringMap.empty), - dmy) - - +fun init () = Acl.read Config.aclFile fun check' G fname = let - (*val _ = print ("Check " ^ fname ^ "\n")*) val prog = Parse.parse fname in if !ErrorMsg.anyErrors then G else - Tycheck.checkFile G (tInit ()) prog + Tycheck.checkFile G (Defaults.tInit ()) prog end fun basis () = @@ -96,7 +79,7 @@ fun check fname = (Env.empty, NONE) else let - val G' = Tycheck.checkFile b (tInit ()) prog + val G' = Tycheck.checkFile b (Defaults.tInit ()) prog in (G', #3 prog) end @@ -130,7 +113,7 @@ fun eval fname = if !ErrorMsg.anyErrors then () else - Eval.exec (SM.map (fn f => f ()) (!defaultV)) body' + Eval.exec (Defaults.eInit ()) body' | NONE => () val dispatcher = @@ -138,14 +121,19 @@ val dispatcher = fun request fname = let - val context = OpenSSL.context ("/home/adamc/fake/clientcert.pem", - "/home/adamc/fake/clientkey.pem", + val uid = Posix.ProcEnv.getuid () + val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) + + val () = Acl.read Config.aclFile + val () = Domain.setUser user + val _ = check fname + + val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem", + Config.keyDir ^ "/" ^ user ^ ".pem", Config.trustStore) val bio = OpenSSL.connect (context, dispatcher) - val _ = print ("Subject: " ^ OpenSSL.peerCN bio ^ "\n") - val inf = TextIO.openIn fname fun loop () = @@ -158,9 +146,12 @@ fun request fname = TextIO.closeIn inf; OpenSSL.close bio end + handle ErrorMsg.Error => () fun service () = let + val () = Acl.read Config.aclFile + val context = OpenSSL.context (Config.serverCert, Config.serverKey, Config.trustStore) @@ -172,16 +163,26 @@ fun service () = NONE => () | SOME bio => let - val _ = print ("Subject: " ^ OpenSSL.peerCN bio ^ "\n") + val user = OpenSSL.peerCN bio + val () = print ("\nConnection from " ^ user ^ "\n") + val () = Domain.setUser user + + val outname = OS.FileSys.tmpName () + val outf = TextIO.openOut outname fun loop' () = case OpenSSL.readOne bio of NONE => () - | SOME line => (print line; + | SOME line => (TextIO.output (outf, line); loop' ()) in - loop' (); - OpenSSL.close bio; + (loop' (); + TextIO.closeOut outf; + eval outname + handle ErrorMsg.Error => (); + OS.FileSys.remove outname; + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); loop () end in diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index 3550166..13062a2 100644 --- a/src/plugins/apache.sml +++ b/src/plugins/apache.sml @@ -61,29 +61,29 @@ val _ = Env.type_one "location" val dl = ErrorMsg.dummyLoc -val _ = Main.registerDefault ("WebNodes", - (TList (TBase "node", dl), dl), - (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes), dl))) +val _ = Defaults.registerDefault ("WebNodes", + (TList (TBase "node", dl), dl), + (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes), dl))) -val _ = Main.registerDefault ("SSL", - (TBase "bool", dl), - (fn () => (EVar "false", dl))) +val _ = Defaults.registerDefault ("SSL", + (TBase "bool", dl), + (fn () => (EVar "false", dl))) -val _ = Main.registerDefault ("User", - (TBase "your_user", dl), - (fn () => (EString (Domain.getUser ()), dl))) +val _ = Defaults.registerDefault ("User", + (TBase "your_user", dl), + (fn () => (EString (Domain.getUser ()), dl))) -val _ = Main.registerDefault ("Group", - (TBase "your_group", dl), - (fn () => (EString (Domain.getUser ()), dl))) +val _ = Defaults.registerDefault ("Group", + (TBase "your_group", dl), + (fn () => (EString (Domain.getUser ()), dl))) -val _ = Main.registerDefault ("DocumentRoot", - (TBase "your_path", dl), - (fn () => (EString ("/home/" ^ Domain.getUser () ^ "/public_html"), dl))) +val _ = Defaults.registerDefault ("DocumentRoot", + (TBase "your_path", dl), + (fn () => (EString ("/home/" ^ Domain.getUser () ^ "/public_html"), dl))) -val _ = Main.registerDefault ("ServerAdmin", - (TBase "email", dl), - (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))) +val _ = Defaults.registerDefault ("ServerAdmin", + (TBase "email", dl), + (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))) val redirect_code = fn (EVar "temp", _) => SOME "temp" diff --git a/src/plugins/exim.sml b/src/plugins/exim.sml index 20e27dd..0744fce 100644 --- a/src/plugins/exim.sml +++ b/src/plugins/exim.sml @@ -24,9 +24,9 @@ open Ast val dl = ErrorMsg.dummyLoc -val _ = Main.registerDefault ("MailNodes", - (TList (TBase "node", dl), dl), - (fn () => (EList (map (fn s => (EString s, dl)) Config.Exim.aliasTo), dl))) +val _ = Defaults.registerDefault ("MailNodes", + (TList (TBase "node", dl), dl), + (fn () => (EList (map (fn s => (EString s, dl)) Config.Exim.aliasTo), dl))) val aliasesChanged = ref false val aliasesDefaultChanged = ref false