--- /dev/null
+structure Apache :> APACHE_CONFIG = struct
+
+val reload = "echo \"I would reload Apache now.\""
+(*"/etc/init.d/apache2 reload"*)
+
+val confDir = "/home/adamc/fake"
+
+val webNodes = ["this"]
+
+end
--- /dev/null
+structure Apache : APACHE_CONFIG
--- /dev/null
+signature APACHE_CONFIG = sig
+
+ val reload : string
+
+ val confDir : string
+
+ val webNodes : string list
+
+end
val aclFile = "/home/adamc/fake/acl"
val testUser = "adamc"
+
+val defaultDomain = "hcoop.net"
(* Place to serialize ACL information *)
val testUser : string
+
+val defaultDomain : string
--- /dev/null
+{{Apache web server configuration}}
+
+context Vhost;
+{{A WWW virtual host}}
+
+extern val vhost : host -> Vhost => [Domain]
+ {WebNodes : [node],
+ SSL : bool,
+ User : your_user,
+ Group : your_group,
+ DocumentRoot : your_path,
+ ServerAdmin : email};
extern type int;
extern type string;
+
+extern type bool;
+extern val false : bool;
+extern val true : bool;
extern type node;
{{The name of a server controlled by domtool}}
-extern type user;
-extern type group;
+extern type your_user;
+extern type your_group;
{{UNIX users and groups that you're allowed to run as}}
-extern type path;
-{{A filesystem path that you're allowed to use}}
+extern type your_path;
+{{A filesystem path that you're allowed to use.
+ The set of permitted values is generated from a set of roots by closing it
+ under the subdirectory relation.}}
context Domain;
{{Configuration directives specific to an Internet domain}}
(* Names of all system nodes *)
val nodeMap : string Ast.StringMap.map
(* Map node names to IP addresses *)
+ val nodeIp : string -> string
+ (* Look up a node in nodeMap *)
val setUser : string -> unit
val getUser : unit -> string
val your_domains : unit -> DataStructures.StringSet.set
(* The domains the current user may configure *)
+
+ val your_users : unit -> DataStructures.StringSet.set
+ val your_groups : unit -> DataStructures.StringSet.set
+ val your_paths : unit -> DataStructures.StringSet.set
+ (* UNIX users, groups, and paths the user may act with *)
end
val nodes = map #1 Config.nodeIps
val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
SM.empty Config.nodeIps
+fun nodeIp node = valOf (SM.find (nodeMap, node))
val usr = ref ""
fun setUser ur = usr := ur
val your_doms = ref SS.empty
fun your_domains () = !your_doms
+val your_usrs = ref SS.empty
+fun your_users () = !your_usrs
+
+val your_grps = ref SS.empty
+fun your_groups () = !your_grps
+
+val your_pths = ref SS.empty
+fun your_paths () = !your_pths
+
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)
+fun yourUser s = SS.member (your_users (), s)
+fun yourGroup s = SS.member (your_groups (), s)
+fun yourPath path =
+ List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
+ andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/"
+ orelse ch = #"-" orelse ch = #"_") path
+ andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (your_paths ())
val _ = Env.type_one "ip"
Env.string
Env.string
yourDomain
+val _ = Env.type_one "your_user"
+ Env.string
+ yourUser
+
+val _ = Env.type_one "your_group"
+ Env.string
+ yourGroup
+
+val _ = Env.type_one "your_path"
+ Env.string
+ yourPath
+
val _ = Env.type_one "node"
Env.string
validNode
val _ = Main.registerDefault ("DNS",
(TBase "dnsKind", dl),
- (multiApp ((EVar "useDns", dl),
+ (fn () => multiApp ((EVar "useDns", dl),
dl,
[soaD, masterD, (EList [], dl)])))
val _ = Main.registerDefault ("TTL",
(TBase "int", dl),
- (EInt Config.Bind.defaultTTL, dl))
+ (fn () => (EInt Config.Bind.defaultTTL, dl)))
type soa = {ns : string,
serial : int option,
val () = Env.registerPreTycheck (fn () => (setUser Config.testUser;
Acl.read Config.aclFile;
your_doms := Acl.class {user = getUser (),
- class = "domain"}))
+ 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));
plugins/bind.sig
plugins/bind.sml
+plugins/apache.sig
+plugins/apache.sml
+
order.sig
order.sml
val int : int arg
val string : string arg
+ val bool : bool arg
val list : 'a arg -> 'a list arg
val none : string -> (unit -> unit) -> action
fun string (EString s, _) = SOME s
| string _ = NONE
+fun bool (EVar "false", _) = SOME false
+ | bool (EVar "true", _) = SOME true
+ | bool _ = NONE
+
fun mapFail f [] = SOME []
| mapFail f (h :: t) =
case f h of
^ ev ^ " that type-checking has guaranteed")
| SOME v => v
+fun printEvs (name, evs) =
+ (print ("Environment " ^ name ^ "\n");
+ SM.appi (fn (name, i) => Print.preface (name, Print.p_exp i)) evs;
+ print "\n")
+
val conjoin : Env.env_vars * Env.env_vars -> Env.env_vars =
SM.unionWith #2
val evs'' = exec' evs e2
in
cleanup ();
- conjoin (conjoin (evs, evs'), evs'')
+ evs'
end
end
signature MAIN = sig
val tInit : unit -> Ast.typ
- val registerDefault : string * Ast.typ * Ast.exp -> unit
+ val registerDefault : string * Ast.typ * (unit -> Ast.exp) -> unit
val check : string -> Env.env * Ast.exp option
val check' : Env.env -> string -> Env.env
val dmy = ErrorMsg.dummyLoc
val defaultT : record ref = ref SM.empty
-val defaultV : exp SM.map 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
if !ErrorMsg.anyErrors then
()
else
- Eval.exec (!defaultV) body'
+ Eval.exec (SM.map (fn f => f ()) (!defaultV)) body'
| NONE => ()
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.
+ *)
+
+(* Apache HTTPD handling *)
+
+signature APACHE = sig
+
+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.
+ *)
+
+(* Apache HTTPD handling *)
+
+structure Apache :> APACHE = struct
+
+open Ast
+
+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 _ = Main.registerDefault ("SSL",
+ (TBase "bool", dl),
+ (fn () => (EVar "false", dl)))
+
+val _ = Main.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 _ = Main.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 vhostsChanged = ref false
+
+val () = Slave.registerPreHandler
+ (fn () => vhostsChanged := false)
+
+val () = Slave.registerFileHandler (fn fs =>
+ let
+ val spl = OS.Path.splitDirFile (#file fs)
+ in
+ if String.isSuffix ".vhost" (#file spl)
+ orelse String.isSuffix ".vhost_ssl" (#file spl) then
+ (vhostsChanged := true;
+ case #action fs of
+ Slave.Delete =>
+ ignore (OS.Process.system (Config.rm
+ ^ " -rf "
+ ^ Config.Apache.confDir
+ ^ "/"
+ ^ #file spl))
+ | _ =>
+ ignore (OS.Process.system (Config.cp
+ ^ " "
+ ^ #file fs
+ ^ " "
+ ^ Config.Apache.confDir
+ ^ "/"
+ ^ #file spl)))
+ else
+ ()
+ end)
+
+val () = Slave.registerPostHandler
+ (fn () =>
+ (if !vhostsChanged then
+ Slave.shellF ([Config.Apache.reload],
+ fn cl => "Error reloading Apache with " ^ cl)
+ else
+ ()))
+
+val vhostFiles : TextIO.outstream list ref = ref []
+fun write s = app (fn file => TextIO.output (file, s)) (!vhostFiles)
+
+val () = Env.containerV_one "vhost"
+ ("host", Env.string)
+ (fn (env, host) =>
+ let
+ val nodes = Env.env (Env.list Env.string) (env, "WebNodes")
+
+ val ssl = Env.env Env.bool (env, "SSL")
+ val user = Env.env Env.string (env, "User")
+ val group = Env.env Env.string (env, "Group")
+ val docroot = Env.env Env.string (env, "DocumentRoot")
+ val sadmin = Env.env Env.string (env, "ServerAdmin")
+
+ val fullHost = host ^ "." ^ Domain.currentDomain ()
+ val confFile = fullHost ^ (if ssl then ".vhost_ssl" else ".vhost")
+ in
+ vhostFiles := map (fn node =>
+ let
+ val file = Domain.domainFile {node = node,
+ name = confFile}
+ in
+ TextIO.output (file, "<VirtualHost ");
+ TextIO.output (file, Domain.nodeIp node);
+ TextIO.output (file, ":");
+ TextIO.output (file, if ssl then
+ "443"
+ else
+ "80");
+ TextIO.output (file, ">\n");
+ file
+ end)
+ nodes;
+ write "\tSuexecUserGroup ";
+ write user;
+ write " ";
+ write group;
+ write "\n\tDocumentRoot ";
+ write docroot;
+ write "\n\tServerAdmin ";
+ write sadmin;
+ write "\n"
+ end,
+ fn () => (write "</VirtualHost>\n";
+ app TextIO.closeOut (!vhostFiles)))
+
+end
val _ = Main.registerDefault ("MailNodes",
(TList (TBase "node", dl), dl),
- (EList (map (fn s => (EString s, dl)) Config.Exim.aliasTo), dl))
+ (fn () => (EList (map (fn s => (EString s, dl)) Config.Exim.aliasTo), dl)))
val aliasesChanged = ref false
val aliasesDefaultChanged = ref false
space 1, string x2, string ";", space 1],
p_exp e]
| ESeq es => dBox (valOf (foldr (fn (e, NONE) => SOME [p_exp e]
- | (e, SOME ds) => SOME (dBox [p_exp e, string ";", space 1] :: ds))
+ | (e, SOME ds) => SOME (dBox [p_exp e, string ";", newline] :: ds))
NONE es))
| ELocal (e1, e2) => dBox [string "let", space 1,
p_exp e1, space 1,
| TUnif _ => raise Fail "TUnif in parser-generated type"
end
+fun envVarSetFrom v (e, _) =
+ case e of
+ ESet (v', e) =>
+ if v = v' then
+ SOME e
+ else
+ NONE
+ | EGet (_, _, e) => envVarSetFrom v e
+ | ESeq es => foldr (fn (e, found) =>
+ case found of
+ SOME _ => found
+ | NONE => envVarSetFrom v e)
+ NONE es
+ | ELocal (_, e) => envVarSetFrom v e
+
+ | _ => NONE
+
fun checkExp G (eAll as (e, loc)) =
let
val dte = describe_type_error loc
(case SM.find (d', name) of
NONE => SM.insert (d', name, t)
| SOME t' =>
- (subTyp (t, t')
+ ((case envVarSetFrom name e1 of
+ NONE => subTyp (t, t')
+ | SOME e => hasTyp (e, t, t'))
handle Unify ue =>
dte (WrongType ("Shared environment variable",
(EVar name, loc),
- t,
t',
+ t,
SOME ue));
d'))
| SOME t' =>
- (subTyp (t, t')
+ ((case envVarSetFrom name e1 of
+ NONE => subTyp (t, t')
+ | SOME e => hasTyp (e, t, t'))
handle Unify ue =>
dte (WrongType ("Shared environment variable",
(EVar name, loc),
- t,
t',
+ t,
SOME ue));
d'))
d1 d2
(case SM.find (d', name) of
NONE => SM.insert (d', name, t)
| SOME t' =>
- (subTyp (t, t')
+ ((case envVarSetFrom name e1 of
+ NONE => subTyp (t', t)
+ | SOME e => hasTyp (e, t', t))
handle Unify ue =>
dte (WrongType ("Shared environment variable",
(EVar name, loc),
- t,
t',
+ t,
SOME ue));
d'))
| SOME t' =>
- (subTyp (t, t')
+ ((case envVarSetFrom name e1 of
+ NONE => subTyp (t', t)
+ | SOME e => hasTyp (e, t', t))
handle Unify ue =>
dte (WrongType ("Shared environment variable",
(EVar name, loc),
- t,
t',
+ t,
SOME ue));
d'))
d1 d2
--- /dev/null
+domain "hcoop.net" with
+
+ vhost "www" where
+ User = "adamc";
+ Group = "adamc";
+ DocumentRoot = "/home/adamc/html";
+ ServerAdmin = "adamc@hcoop.net"
+ with
+
+ end;
+
+ vhost "members" where
+ SSL = true
+ with
+
+ end
+
+end
+
+