X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/de5351c7e5e91a5a055127e7294419c64a1c74df..1b1021cb38f85f638ec5b2141075e99c7b5f0fdd:/src/plugins/mailman.sml

diff --git a/src/plugins/mailman.sml b/src/plugins/mailman.sml
index 5244682..854c91a 100644
--- a/src/plugins/mailman.sml
+++ b/src/plugins/mailman.sml
@@ -22,16 +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_node",
+			       fn [] => SOME (EString Config.Mailman.node, dl)
+				| _ => NONE)
+
+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 => ())
@@ -55,16 +83,17 @@ 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")
+		 val sadmin = Env.env Env.string (env, "ServerAdmin")
 
 		 val fullHost = host ^ "." ^ Domain.currentDomain ()
 		 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}
@@ -76,16 +105,20 @@ val () = Env.actionV_one "mailmanVhost"
 			     print user;
 			     print "\n";
 			     print "<VirtualHost ";
-			     print (Domain.nodeIp node);
+			     print ip;
 			     print ":";
 			     print (case ssl of
 					SOME _ => "443"
 				      | NONE => "80");
 			     print ">\n";
-			     print "    ServerName $LISTDOMAIN\n";
+			     print "    ServerName ";
+			     print host;
+			     print ".";
+			     print (Domain.currentDomain ());
+			     print "\n";
 			     print "    ServerAdmin ";
-			     print user;
-			     print "@hcoop.net\n";
+			     print sadmin;
+			     print "\n";
 			     print "    SuexecUserGroup list list\n";
 			     print "\n";
 			     print "    ErrorLog ";
@@ -98,7 +131,11 @@ val () = Env.actionV_one "mailmanVhost"
 			     print "    RewriteEngine on\n";
 			     print "\n";
 			     print "    # Default to showing listinfo page\n";
-			     print "    RewriteRule ^/$ http://";
+			     print "    RewriteRule ^/$ http";
+			     case ssl of
+				 NONE => ()
+			       | SOME _ => print "s";
+			     print "://";
 			     print fullHost;
 			     print "/listinfo/\n";
 			     print "\n";
@@ -118,10 +155,15 @@ val () = Env.actionV_one "mailmanVhost"
 			     print "        Order allow,deny\n";
 			     print "        Allow from all\n";
 			     print "    </Directory>\n";
+
+			     Apache.doPre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
+
 			     print "</VirtualHost>\n";
 
-			     TextIO.closeOut file
-			 end) nodes
+			     TextIO.closeOut file;
+
+			     Apache.doPost ()
+			 end) places
 	     end)
 
 val mailmanChanged = ref false
@@ -150,7 +192,7 @@ val () = Slave.registerPostHandler (fn () =>
 
 val () = Domain.registerDescriber (Domain.considerAll
 				   [Domain.Filename {filename = "mailman",
-						     heading = "Mailman web host mapping",
+						     heading = "Mailman web host mapping:",
 						     showEmpty = false}])
 
 end