From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 18 Nov 2007 17:35:57 +0000 (+0000)
Subject: Allow IP address specification for Apache, though no way yet to do anything but defau... 
X-Git-Tag: release_2010-11-19~119
X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/commitdiff_plain/128e7b0b302e295411797f2465c508013bce4430

Allow IP address specification for Apache, though no way yet to do anything but default IP
---

diff --git a/lib/apache.dtl b/lib/apache.dtl
index db30398..db9dc37 100644
--- a/lib/apache.dtl
+++ b/lib/apache.dtl
@@ -5,6 +5,16 @@ extern type web_node;
 
 extern val web_node_to_node : web_node -> node;
 
+extern type web_place;
+extern val web_place_default : web_node -> web_place;
+extern val web_place : web_node -> your_ip -> web_place;
+extern val web_place_to_web_node : web_place -> web_node;
+extern val web_place_to_node : web_place -> node;
+extern val web_place_to_ip : web_place -> ip;
+{{Web places are combinations of web nodes (servers on which you are allowed to
+  run web sites) and IP addresses on which those servers should listen for
+  requests.}}
+
 context Vhost;
 {{A WWW virtual host}}
 
@@ -21,7 +31,7 @@ extern val no_ssl : ssl;
 extern val use_cert : ssl_cert_path -> ssl;
 
 extern val vhost : host -> Vhost => [Domain]
-	{WebNodes : [web_node],
+	{WebPlaces : [web_place],
 	 SSL : ssl,
 	 User : your_user,
 	 Group : your_group,
diff --git a/lib/domain.dtl b/lib/domain.dtl
index 55ac254..8946633 100644
--- a/lib/domain.dtl
+++ b/lib/domain.dtl
@@ -9,6 +9,9 @@ extern type no_newlines;
 extern type ip;
 {{An IP address}}
 
+extern type your_ip;
+{{An IP address that you're authorized to use; e.g., for an SSL web host}}
+
 extern type host;
 {{A hostname; that is, (more or less) an alphanumeric string}}
 
diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml
index f36bfa4..2d42a98 100644
--- 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 ();