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"
+
val trustStore : string
val serverCert : string
val serverKey : string
+
+val certDir : string
+val keyDir : string
--- /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.
+ *)
+
+(* 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
--- /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.
+ *)
+
+(* 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
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
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] =>
(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,
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;
slave.sig
slave.sml
+defaults.sig
+defaults.sml
+
domain.sig
domain.sml
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
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 () =
(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
if !ErrorMsg.anyErrors then
()
else
- Eval.exec (SM.map (fn f => f ()) (!defaultV)) body'
+ Eval.exec (Defaults.eInit ()) body'
| NONE => ()
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 () =
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)
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
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"
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
HCoop / hcoop / domtool2.git / commitdiff