vhost IP specification working

diff --git a/lib/easy_domain.dtl b/lib/easy_domain.dtl
index cb63932..82c66bf 100644 (file)
--- 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 (file)
--- 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 <tt>web_node</tt>, 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 <tt>web_place</tt>, but based on <tt>mailman_node</tt>s}}
 
 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 "<VirtualHost ";
-                            print (Domain.nodeIp node);
+                            print ip;
                             print ":";
                             print (case ssl of
                                        SOME _ => "443"
@@ -127,14 +147,14 @@ val () = Env.actionV_one "mailmanVhost"
                             print "        Allow from all\n";
                             print "    </Directory>\n";
 
-                            Apache.doPre {user = user, nodes = nodes, id = vhostId, hostname = fullHost};
+                            Apache.doPre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
 
                             print "</VirtualHost>\n";
 
                             TextIO.closeOut file;
 
                             Apache.doPost ()
-                        end) nodes
+                        end) places
             end)
 
 val mailmanChanged = ref false