Allow IP address specification for Apache, though no way yet to do anything but defau...

[hcoop/domtool2.git] / src / plugins / apache.sml

diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml
index f36bfa4..2d42a98 100644 (file)
--- a/src/plugins/apache.sml
+++ b/src/plugins/apache.sml
@@ -22,6 +22,8 @@ structure Apache :> APACHE = struct
 
 open Ast
 
+val dl = ErrorMsg.dummyLoc
+
 fun webNode node =
     List.exists (fn (x, _) => x = node) Config.Apache.webNodes_all
     orelse (Domain.hasPriv "www"
@@ -35,6 +37,26 @@ val _ = Env.registerFunction ("web_node_to_node",
                              fn [e] => SOME e
                               | _ => NONE)
 
+fun webPlace (EApp ((EString "web_place_default", _), (EString node, _)), _) =
+    SOME (node, Domain.nodeIp node)
+  | webPlace (EApp ((EApp ((EString "web_place", _), (EString node, _)), _), (EString ip, _)), _) =
+    SOME (node, ip)
+  | webPlace _ = NONE
+
+fun webPlaceDefault node = (EApp ((EString "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)
+                              | _ => NONE)
+
+val _ = Env.registerFunction ("web_place_to_node",
+                             fn [e] => Option.map (fn (node, _) => (EString node, dl)) (webPlace e)
+                              | _ => NONE)
+
+val _ = Env.registerFunction ("web_place_to_ip",
+                             fn [e] => Option.map (fn (_, ip) => (EString ip, dl)) (webPlace e)
+                              | _ => NONE)
+
 val _ = Env.type_one "proxy_port"
        Env.int
        (fn n => n > 1024)
@@ -89,11 +111,9 @@ fun ssl e = case e of
              | (EApp ((EVar "use_cert", _), s), _) => Option.map SOME (Env.string s)
              | _ => NONE
 
-val dl = ErrorMsg.dummyLoc
-
-val defaults = [("WebNodes",
-                (TList (TBase "web_node", dl), dl),
-                (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes_default), dl))),
+val defaults = [("WebPlaces",
+                (TList (TBase "web_place", dl), dl),
+                (fn () => (EList (map webPlaceDefault Config.Apache.webNodes_default), dl))),
                ("SSL",
                 (TBase "ssl", dl),
                 (fn () => (EVar "no_ssl", dl))),
@@ -398,7 +418,7 @@ val () = Env.containerV_one "vhost"
         ("host", Env.string)
         (fn (env, host) =>
             let
-                val nodes = Env.env (Env.list Env.string) (env, "WebNodes")
+                val places = Env.env (Env.list webPlace) (env, "WebPlaces")
 
                 val ssl = Env.env ssl (env, "SSL")
                 val user = Env.env Env.string (env, "User")
@@ -417,7 +437,7 @@ val () = Env.containerV_one "vhost"
 
                 rewriteEnabled := false;
                 localRewriteEnabled := false;
-                vhostFiles := map (fn node =>
+                vhostFiles := map (fn (node, ip) =>
                                       let
                                           val file = Domain.domainFile {node = node,
                                                                         name = confFile}
@@ -427,7 +447,7 @@ val () = Env.containerV_one "vhost"
                                           TextIO.output (file, "# Owner: ");
                                           TextIO.output (file, user);
                                           TextIO.output (file, "\n<VirtualHost ");
-                                          TextIO.output (file, Domain.nodeIp node);
+                                          TextIO.output (file, ip);
                                           TextIO.output (file, ":");
                                           TextIO.output (file, case ssl of
                                                                    SOME _ => "443"
@@ -475,7 +495,7 @@ val () = Env.containerV_one "vhost"
 
                                           (ld, file)
                                       end)
-                                  nodes;
+                                  places;
                 write "\n\tDocumentRoot ";
                 write docroot;
                 write "\n\tServerAdmin ";
@@ -486,7 +506,7 @@ val () = Env.containerV_one "vhost"
                      write cert)
                   | NONE => ();
                 write "\n";
-                !pre {user = user, nodes = nodes, id = vhostId, hostname = fullHost};
+                !pre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
                 app (fn dom => !aliaser (host ^ "." ^ dom)) (Domain.currentAliasDomains ())
             end,
          fn () => (!post ();