Use proper URL prefix in mailmanVhost redirect

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

diff --git a/src/plugins/mailman.sml b/src/plugins/mailman.sml
index b8925a3..9f30e72 100644 (file)
--- a/src/plugins/mailman.sml
+++ b/src/plugins/mailman.sml
@@ -20,6 +20,47 @@
 
 structure Mailman :> MAILMAN = struct
 
 
 structure Mailman :> MAILMAN = struct
 

+open Ast
+
+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
+            ("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 => ())
 
 val files = ref ([] : TextIO.outstream list)
 val write = ref (fn _ : string => ())
 


@@ -27,17 +68,103 @@ val () = Env.action_one "mailmanWebHost"
                        ("hostname", Env.string)
                        (fn host =>
                            let
                        ("hostname", Env.string)
                        (fn host =>
                            let

-                               val outf = Domain.domainFile {node = Config.Mailman.node,
-                                                             name = "mailman"}
+                               val {write, writeDom, close} = Domain.domainsFile {node = Config.Mailman.node,
+                                                                                  name = "mailman"}

                            in
                            in

-                               TextIO.output (outf, "\t'");
-                               TextIO.output (outf, host);
-                               TextIO.output (outf, "' : '");
-                               TextIO.output (outf, Domain.currentDomain ());
-                               TextIO.output (outf, "',\n");
-                               TextIO.closeOut outf
+                               write "\t'";
+                               write host;
+                               write "' : '";
+                               writeDom ();
+                               write "',\n";
+                               close ()

                            end)
 
                            end)
 

+val () = Env.actionV_one "mailmanVhost"
+        ("host", Env.string)
+        (fn (env, host) =>
+            let
+                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 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, ip) =>
+                        let
+                            val file = Domain.domainFile {node = node,
+                                                          name = confFile}
+                            fun print s = TextIO.output (file, s)
+
+                            val ld = Apache.logDir {user = user, node = node, vhostId = vhostId}
+                        in
+                            print "# Owner: ";
+                            print user;
+                            print "\n";
+                            print "<VirtualHost ";
+                            print ip;
+                            print ":";
+                            print (case ssl of
+                                       SOME _ => "443"
+                                     | NONE => "80");
+                            print ">\n";
+                            print "    ServerName ";
+                            print host;
+                            print ".";
+                            print (Domain.currentDomain ());
+                            print "\n";
+                            print "    ServerAdmin ";
+                            print user;
+                            print "@hcoop.net\n";
+                            print "    SuexecUserGroup list list\n";
+                            print "\n";
+                            print "    ErrorLog ";
+                            print ld;
+                            print "/error.log\n";
+                            print "    CustomLog ";
+                            print ld;
+                            print "/access.log combined\n";
+                            print "\n";
+                            print "    RewriteEngine on\n";
+                            print "\n";
+                            print "    # Default to showing listinfo page\n";
+                            print "    RewriteRule ^/$ http";
+                            case ssl of
+                                NONE => ()
+                              | SOME _ => print "s";
+                            print "://";
+                            print fullHost;
+                            print "/listinfo/\n";
+                            print "\n";
+                            print "    Alias /images/mailman /usr/share/images/mailman\n";
+                            print "    Alias /pipermail /var/lib/mailman/archives/public\n";
+                            print "\n";
+                            print "    DocumentRoot /usr/lib/cgi-bin/mailman\n";
+                            print "    <Directory /usr/lib/cgi-bin/mailman>\n";
+                            print "        AllowOverride None\n";
+                            print "        Options +ExecCGI -MultiViews +SymLinksIfOwnerMatch\n";
+                            print "        ForceType cgi-script\n";
+                            print "        Order allow,deny\n";
+                            print "        Allow from all\n";
+                            print "    </Directory>\n";
+                            print "\n";
+                            print "    <Directory /usr/share/doc/mailman>\n";
+                            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;
+
+                            Apache.doPost ()
+                        end) places
+            end)
+

 val mailmanChanged = ref false
 
 val () = Slave.registerPreHandler (fn () => mailmanChanged := false)
 val mailmanChanged = ref false
 
 val () = Slave.registerPreHandler (fn () => mailmanChanged := false)


@@ -62,4 +189,9 @@ val () = Slave.registerPostHandler (fn () =>
                                       else
                                           ())
 
                                       else
                                           ())
 

+val () = Domain.registerDescriber (Domain.considerAll
+                                  [Domain.Filename {filename = "mailman",
+                                                    heading = "Mailman web host mapping:",
+                                                    showEmpty = false}])
+

 end
 end