From 8a7c40fa29ff18a437fcf4ee3f248a7aeb41c19c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 6 Aug 2006 19:58:18 +0000 Subject: [PATCH] Start of Apache --- configDefault/apache.cfg | 10 +++ configDefault/apache.cfs | 1 + configDefault/apache.csg | 9 +++ configDefault/domtool.cfg | 2 + configDefault/domtool.cfs | 2 + lib/apache.dtl | 12 ++++ lib/base.dtl | 4 ++ lib/domain.dtl | 10 +-- src/domain.sig | 7 ++ src/domain.sml | 41 +++++++++++- src/domtool.cm | 3 + src/env.sig | 1 + src/env.sml | 4 ++ src/eval.sml | 7 +- src/main.sig | 2 +- src/main.sml | 4 +- src/plugins/apache.sig | 23 +++++++ src/plugins/apache.sml | 137 ++++++++++++++++++++++++++++++++++++++ src/plugins/exim.sml | 2 +- src/print.sml | 2 +- src/tycheck.sml | 41 +++++++++--- tests/testApache.dtl | 20 ++++++ 22 files changed, 323 insertions(+), 21 deletions(-) create mode 100644 configDefault/apache.cfg create mode 100644 configDefault/apache.cfs create mode 100644 configDefault/apache.csg create mode 100644 lib/apache.dtl create mode 100644 src/plugins/apache.sig create mode 100644 src/plugins/apache.sml create mode 100644 tests/testApache.dtl diff --git a/configDefault/apache.cfg b/configDefault/apache.cfg new file mode 100644 index 0000000..4977093 --- /dev/null +++ b/configDefault/apache.cfg @@ -0,0 +1,10 @@ +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 diff --git a/configDefault/apache.cfs b/configDefault/apache.cfs new file mode 100644 index 0000000..1e213ff --- /dev/null +++ b/configDefault/apache.cfs @@ -0,0 +1 @@ +structure Apache : APACHE_CONFIG diff --git a/configDefault/apache.csg b/configDefault/apache.csg new file mode 100644 index 0000000..3ade218 --- /dev/null +++ b/configDefault/apache.csg @@ -0,0 +1,9 @@ +signature APACHE_CONFIG = sig + + val reload : string + + val confDir : string + + val webNodes : string list + +end diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index c3edb16..529ec7b 100644 --- a/configDefault/domtool.cfg +++ b/configDefault/domtool.cfg @@ -20,3 +20,5 @@ val defaultNode = "this" val aclFile = "/home/adamc/fake/acl" val testUser = "adamc" + +val defaultDomain = "hcoop.net" diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs index e42271a..1814dc4 100644 --- a/configDefault/domtool.cfs +++ b/configDefault/domtool.cfs @@ -29,3 +29,5 @@ val aclFile : string (* Place to serialize ACL information *) val testUser : string + +val defaultDomain : string diff --git a/lib/apache.dtl b/lib/apache.dtl new file mode 100644 index 0000000..3b41927 --- /dev/null +++ b/lib/apache.dtl @@ -0,0 +1,12 @@ +{{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}; diff --git a/lib/base.dtl b/lib/base.dtl index 3e8989b..0107d0c 100644 --- a/lib/base.dtl +++ b/lib/base.dtl @@ -1,2 +1,6 @@ extern type int; extern type string; + +extern type bool; +extern val false : bool; +extern val true : bool; diff --git a/lib/domain.dtl b/lib/domain.dtl index b2333e8..ac0345c 100644 --- a/lib/domain.dtl +++ b/lib/domain.dtl @@ -15,12 +15,14 @@ extern type your_domain; 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}} diff --git a/src/domain.sig b/src/domain.sig index 570fa5e..003dd2b 100644 --- a/src/domain.sig +++ b/src/domain.sig @@ -43,6 +43,8 @@ signature DOMAIN = sig (* 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 @@ -50,4 +52,9 @@ signature DOMAIN = sig 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 diff --git a/src/domain.sml b/src/domain.sml index f0e7635..aa392bc 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -26,6 +26,7 @@ structure SS = DataStructures.StringSet 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 @@ -34,6 +35,15 @@ fun getUser () = !usr 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] => @@ -53,6 +63,13 @@ fun validDomain s = 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 @@ -70,6 +87,18 @@ val _ = Env.type_one "your_domain" 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 @@ -95,13 +124,13 @@ val masterD = (EApp ((EVar "internalMaster", dl), 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, @@ -428,7 +457,13 @@ val _ = Env.containerV_one "domain" 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)); diff --git a/src/domtool.cm b/src/domtool.cm index bb7047e..7e4cb0a 100644 --- a/src/domtool.cm +++ b/src/domtool.cm @@ -59,6 +59,9 @@ plugins/exim.sml plugins/bind.sig plugins/bind.sml +plugins/apache.sig +plugins/apache.sml + order.sig order.sml diff --git a/src/env.sig b/src/env.sig index e5f19e6..adb03ea 100644 --- a/src/env.sig +++ b/src/env.sig @@ -49,6 +49,7 @@ signature ENV = sig 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 diff --git a/src/env.sml b/src/env.sml index db92e6e..d9905dd 100644 --- a/src/env.sml +++ b/src/env.sml @@ -100,6 +100,10 @@ fun int (EInt n, _) = SOME n 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 diff --git a/src/eval.sml b/src/eval.sml index 232a8aa..7aa8053 100644 --- a/src/eval.sml +++ b/src/eval.sml @@ -30,6 +30,11 @@ fun lookup (evs, ev) = ^ 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 @@ -90,7 +95,7 @@ fun exec evs e = val evs'' = exec' evs e2 in cleanup (); - conjoin (conjoin (evs, evs'), evs'') + evs' end end diff --git a/src/main.sig b/src/main.sig index 7197f36..62a87ef 100644 --- a/src/main.sig +++ b/src/main.sig @@ -21,7 +21,7 @@ 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 diff --git a/src/main.sml b/src/main.sml index b91f73a..22577ad 100644 --- a/src/main.sml +++ b/src/main.sml @@ -27,7 +27,7 @@ structure SM = StringMap 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 @@ -129,7 +129,7 @@ fun eval fname = if !ErrorMsg.anyErrors then () else - Eval.exec (!defaultV) body' + Eval.exec (SM.map (fn f => f ()) (!defaultV)) body' | NONE => () end diff --git a/src/plugins/apache.sig b/src/plugins/apache.sig new file mode 100644 index 0000000..da69e65 --- /dev/null +++ b/src/plugins/apache.sig @@ -0,0 +1,23 @@ +(* 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 diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml new file mode 100644 index 0000000..27641ab --- /dev/null +++ b/src/plugins/apache.sml @@ -0,0 +1,137 @@ +(* 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, "\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 "\n"; + app TextIO.closeOut (!vhostFiles))) + +end diff --git a/src/plugins/exim.sml b/src/plugins/exim.sml index a93b732..20e27dd 100644 --- a/src/plugins/exim.sml +++ b/src/plugins/exim.sml @@ -26,7 +26,7 @@ val dl = ErrorMsg.dummyLoc 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 diff --git a/src/print.sml b/src/print.sml index 89a640c..76d3fd1 100644 --- a/src/print.sml +++ b/src/print.sml @@ -109,7 +109,7 @@ fun p_exp (e, _) = 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, diff --git a/src/tycheck.sml b/src/tycheck.sml index ac9fad5..6d58e43 100644 --- a/src/tycheck.sml +++ b/src/tycheck.sml @@ -334,6 +334,23 @@ fun checkTyp G (tAll as (t, loc)) = | 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 @@ -467,21 +484,25 @@ fun checkExp G (eAll as (e, 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 @@ -525,21 +546,25 @@ fun checkExp G (eAll as (e, 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 diff --git a/tests/testApache.dtl b/tests/testApache.dtl new file mode 100644 index 0000000..1c7ed54 --- /dev/null +++ b/tests/testApache.dtl @@ -0,0 +1,20 @@ +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 + + -- 2.20.1