From: Adam Chlipala Date: Sun, 18 Nov 2007 18:03:12 +0000 (+0000) Subject: vhost IP specification working X-Git-Tag: release_2010-11-19~117 X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/commitdiff_plain/b5f2d506092c97a597d8f275776dcb76c2525796 vhost IP specification working --- diff --git a/lib/easy_domain.dtl b/lib/easy_domain.dtl index cb63932..82c66bf 100644 --- a/lib/easy_domain.dtl +++ b/lib/easy_domain.dtl @@ -10,7 +10,7 @@ val webAt = (dns (dnsA host (ip_of_node (web_node_to_node n))); vhost host where - WebNodes = [n] + WebPlaces = [web_place_default n] with config end); diff --git a/lib/mailman.dtl b/lib/mailman.dtl index df935be..2e8029e 100644 --- a/lib/mailman.dtl +++ b/lib/mailman.dtl @@ -4,17 +4,25 @@ extern val mailmanWebHost : domain -> [Domain]; {{Set the hostname of the web site for administration of mailing lists for this domain.}} -extern type mailman_web_node; +extern type mailman_node; {{Like web_node, but with the possibility of using some additional nodes set by the admins.}} -extern val mailman_web_node : mailman_web_node; +extern val mailman_node : mailman_node; {{The default location for Mailman web interfaces}} -extern val mailman_web_node_to_node : mailman_web_node -> node; +extern val mailman_node_to_node : mailman_node -> node; + +extern type mailman_place; +extern val mailman_place_default : mailman_node -> mailman_place; +extern val mailman_place : mailman_node -> your_ip -> mailman_place; +extern val mailman_place_to_web_node : mailman_place -> web_node; +extern val mailman_place_to_node : mailman_place -> node; +extern val mailman_place_to_ip : mailman_place -> ip; +{{Analogous to web_place, but based on mailman_nodes}} extern val mailmanVhost : host -> [Domain] - {MailmanWebNodes : [mailman_web_node], + {MailmanPlaces : [mailman_place], SSL : ssl, User : your_user}; {{Create an Apache virtual host to serve as the web interface for some Mailman @@ -24,11 +32,11 @@ val mailman = \ host : (host) -> begin let domainHost host; in - dnsIP host (ip_of_node (mailman_web_node_to_node mailman_web_node)); + dnsIP host (ip_of_node (mailman_node_to_node mailman_node)); mwh <- Hostname; mailmanWebHost mwh; mailmanVhost host where - MailmanWebNodes = [mailman_web_node]; + MailmanPlaces = [mailman_place_default mailman_node]; SSL = no_ssl end end diff --git a/src/plugins/apache.sig b/src/plugins/apache.sig index fd8c166..d08433d 100644 --- a/src/plugins/apache.sig +++ b/src/plugins/apache.sig @@ -39,6 +39,7 @@ signature APACHE = sig (* Default environment variables *) val ssl : string option Env.arg + val webPlace : (string * string) Env.arg val webNode : string -> bool end diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index 2d42a98..4da19f9 100644 --- a/src/plugins/apache.sml +++ b/src/plugins/apache.sml @@ -37,13 +37,13 @@ val _ = Env.registerFunction ("web_node_to_node", fn [e] => SOME e | _ => NONE) -fun webPlace (EApp ((EString "web_place_default", _), (EString node, _)), _) = +fun webPlace (EApp ((EVar "web_place_default", _), (EString node, _)), _) = SOME (node, Domain.nodeIp node) - | webPlace (EApp ((EApp ((EString "web_place", _), (EString node, _)), _), (EString ip, _)), _) = + | webPlace (EApp ((EApp ((EVar "web_place", _), (EString node, _)), _), (EString ip, _)), _) = SOME (node, ip) | webPlace _ = NONE -fun webPlaceDefault node = (EApp ((EString "web_place_default", dl), (EString node, dl)), dl) +fun webPlaceDefault node = (EApp ((EVar "web_place_default", dl), (EString node, dl)), dl) val _ = Env.registerFunction ("web_place_to_web_node", fn [e] => Option.map (fn (node, _) => (EString node, dl)) (webPlace e) diff --git a/src/plugins/mailman.sml b/src/plugins/mailman.sml index 12d92a0..4a00074 100644 --- a/src/plugins/mailman.sml +++ b/src/plugins/mailman.sml @@ -22,24 +22,44 @@ structure Mailman :> MAILMAN = struct open Ast -val () = Env.type_one "mailman_web_node" +val () = Env.type_one "mailman_node" Env.string (fn node => Apache.webNode node orelse node = Config.Mailman.node) val dl = ErrorMsg.dummyLoc -val () = Env.registerFunction ("mailman_web_node", +val () = Env.registerFunction ("mailman_node", fn [] => SOME (EString Config.Mailman.node, dl) | _ => NONE) -val () = Env.registerFunction ("mailman_web_node_to_node", +val () = Env.registerFunction ("mailman_node_to_node", fn [e] => SOME e | _ => NONE) +fun mailmanPlace (EApp ((EVar "mailman_place_default", _), (EString node, _)), _) = + SOME (node, Domain.nodeIp node) + | mailmanPlace (EApp ((EApp ((EVar "mailman_place", _), (EString node, _)), _), (EString ip, _)), _) = + SOME (node, ip) + | mailmanPlace _ = NONE + +fun mailmanPlaceDefault node = (EApp ((EVar "mailman_place_default", dl), (EString node, dl)), dl) + +val _ = Env.registerFunction ("mailman_place_to_web_node", + fn [e] => Option.map (fn (node, _) => (EString node, dl)) (mailmanPlace e) + | _ => NONE) + +val _ = Env.registerFunction ("mailman_place_to_node", + fn [e] => Option.map (fn (node, _) => (EString node, dl)) (mailmanPlace e) + | _ => NONE) + +val _ = Env.registerFunction ("mailman_place_to_ip", + fn [e] => Option.map (fn (_, ip) => (EString ip, dl)) (mailmanPlace e) + | _ => NONE) + val () = Defaults.registerDefault - ("MailmanWebNodes", - (TList (TBase "mailman_web_node", dl), dl), - (fn () => (EList [(EString Config.Mailman.node, dl)], dl))) + ("MailmanPlaces", + (TList (TBase "mailman_place", dl), dl), + (fn () => (EList [mailmanPlaceDefault Config.Mailman.node], dl))) val files = ref ([] : TextIO.outstream list) val write = ref (fn _ : string => ()) @@ -63,7 +83,7 @@ val () = Env.actionV_one "mailmanVhost" ("host", Env.string) (fn (env, host) => let - val nodes = Env.env (Env.list Env.string) (env, "MailmanWebNodes") + val places = Env.env (Env.list mailmanPlace) (env, "MailmanPlaces") val ssl = Env.env Apache.ssl (env, "SSL") val user = Env.env Env.string (env, "User") @@ -72,7 +92,7 @@ val () = Env.actionV_one "mailmanVhost" val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "") val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost") in - app (fn node => + app (fn (node, ip) => let val file = Domain.domainFile {node = node, name = confFile} @@ -84,7 +104,7 @@ val () = Env.actionV_one "mailmanVhost" print user; print "\n"; print " "443" @@ -127,14 +147,14 @@ val () = Env.actionV_one "mailmanVhost" print " Allow from all\n"; print " \n"; - Apache.doPre {user = user, nodes = nodes, id = vhostId, hostname = fullHost}; + Apache.doPre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost}; print "\n"; TextIO.closeOut file; Apache.doPost () - end) nodes + end) places end) val mailmanChanged = ref false