From e9f528ab975ac28c16b2c370e69206a48f584d78 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sat, 17 Nov 2007 21:58:34 +0000
Subject: [PATCH 1/1] Mailman shortcut working

---
 lib/domain.dtl          |  5 ++++-
 lib/mailman.dtl         | 30 ++++++++++++++++++++++++++++++
 src/domain.sml          |  6 ++++++
 src/plugins/apache.sig  |  3 +++
 src/plugins/apache.sml  |  3 +++
 src/plugins/mailman.sml | 15 ++++++++++++++-
 src/reduce.sml          |  7 ++++++-
 7 files changed, 66 insertions(+), 3 deletions(-)

diff --git a/lib/domain.dtl b/lib/domain.dtl
index 8be8896..55ac254 100644
--- a/lib/domain.dtl
+++ b/lib/domain.dtl
@@ -84,4 +84,7 @@ extern val domain : your_domain -> Domain => [Root] {Aliases : [your_domain], DN
 
 extern type mail_node;
 {{A node offering SMTP services}}
-extern val mail_node_to_node : mail_node -> node;
\ No newline at end of file
+extern val mail_node_to_node : mail_node -> node;
+
+extern val domainHost : host -> [Domain] {} => { Hostname : domain };
+{{Appends the current domain onto a host.}}
diff --git a/lib/mailman.dtl b/lib/mailman.dtl
index 2cf0445..21e3b49 100644
--- a/lib/mailman.dtl
+++ b/lib/mailman.dtl
@@ -3,3 +3,33 @@
 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;
+{{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;
+{{The default location for Mailman web interfaces}}
+
+extern val mailman_web_node_to_node : mailman_web_node -> node;
+
+extern val mailmanVhost : host -> [Domain]
+	{MailmanWebNodes : [mailman_web_node],
+	 SSL : ssl,
+	 User : your_user};
+{{Create an Apache virtual host to serve as the web interface for some Mailman
+  lists.}}
+
+val mailman = \ host : (host) -> begin
+  dnsIP host (ip_of_node (mailman_web_node_to_node mailman_web_node));
+  domainHost host;
+  mwh <- Hostname;
+  mailmanWebHost mwh;
+  mailmanVhost host where
+    MailmanWebNodes = [mailman_web_node];
+    SSL = no_ssl
+  end;
+end;
+{{The most common Mailman config, for when you want to have a virtual host of your
+  domain dedicated to a Mailman interface.  Provide the name of that host (e.g.,
+  "lists") to this directive, and it will take care of the rest.}}
diff --git a/src/domain.sml b/src/domain.sml
index 3ecf883..ebd7a2b 100644
--- a/src/domain.sml
+++ b/src/domain.sml
@@ -907,4 +907,10 @@ val () = registerDescriber (considerAll [Filename {filename = "soa",
 						   heading = "DNS SOA",
 						   showEmpty = false}])
 
+val () = Env.registerAction ("domainHost",
+			     fn (env, [(EString host, _)]) =>
+				SM.insert (env, "Hostname",
+					   (EString (host ^ "." ^ currentDomain ()), dl))
+			      | (_, args) => Env.badArgs ("domainHost", args))
+
 end
diff --git a/src/plugins/apache.sig b/src/plugins/apache.sig
index 8baead3..fd8c166 100644
--- a/src/plugins/apache.sig
+++ b/src/plugins/apache.sig
@@ -26,6 +26,9 @@ signature APACHE = sig
     val registerPost : (unit -> unit) -> unit
     (* Register a callback for the end of a vhost block. *)
 
+    val doPre : {user : string, nodes : string list, id : string, hostname : string} -> unit
+    val doPost : unit -> unit
+
     val registerAliaser : (string -> unit) -> unit
     (* Register a callback for an alternate hostname that is configured. *)
 
diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml
index 62615af..f36bfa4 100644
--- a/src/plugins/apache.sml
+++ b/src/plugins/apache.sml
@@ -383,6 +383,9 @@ fun registerPost f =
 	post := (fn () => (old (); f ()))
     end
 
+fun doPre x = !pre x
+fun doPost () = !post ()
+
 val aliaser = ref (fn _ : string => ())
 fun registerAliaser f =
     let
diff --git a/src/plugins/mailman.sml b/src/plugins/mailman.sml
index 5244682..12d92a0 100644
--- a/src/plugins/mailman.sml
+++ b/src/plugins/mailman.sml
@@ -28,6 +28,14 @@ val () = Env.type_one "mailman_web_node"
 
 val dl = ErrorMsg.dummyLoc
 
+val () = Env.registerFunction ("mailman_web_node",
+			       fn [] => SOME (EString Config.Mailman.node, dl)
+				| _ => NONE)
+
+val () = Env.registerFunction ("mailman_web_node_to_node",
+			    fn [e] => SOME e
+			     | _ => NONE)
+
 val () = Defaults.registerDefault
 	     ("MailmanWebNodes",
 	      (TList (TBase "mailman_web_node", dl), dl),
@@ -118,9 +126,14 @@ val () = Env.actionV_one "mailmanVhost"
 			     print "        Order allow,deny\n";
 			     print "        Allow from all\n";
 			     print "    </Directory>\n";
+
+			     Apache.doPre {user = user, nodes = nodes, id = vhostId, hostname = fullHost};
+
 			     print "</VirtualHost>\n";
 
-			     TextIO.closeOut file
+			     TextIO.closeOut file;
+
+			     Apache.doPost ()
 			 end) nodes
 	     end)
 
diff --git a/src/reduce.sml b/src/reduce.sml
index 5d7a1b9..525d713 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -133,7 +133,12 @@ fun reduceExp G (eAll as (e, loc)) =
 	end
       | EVar x =>
 	(case lookupEquation G x of
-	     NONE => eAll
+	     NONE =>
+	     (case function x of
+		  NONE => eAll
+		| SOME f => case f [] of
+				NONE => eAll
+			      | SOME e' => reduceExp G e')
 	   | SOME e => reduceExp G e)
       | EApp (e1, e2) =>
 	let
-- 
2.20.1