mailman: open /usr/share/images/mailman, revert to mod_access_compat

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

diff --git a/src/plugins/mailman.sml b/src/plugins/mailman.sml
index aa0b7ee..d165dc6 100644 (file)
--- a/src/plugins/mailman.sml
+++ b/src/plugins/mailman.sml
@@ -20,6 +20,40 @@
 
 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
+
+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 files = ref ([] : TextIO.outstream list)
 val write = ref (fn _ : string => ())
 
@@ -28,7 +62,7 @@ val () = Env.action_one "mailmanWebHost"
                        (fn host =>
                            let
                                val {write, writeDom, close} = Domain.domainsFile {node = Config.Mailman.node,
-                                                                                  name = "mailman"}
+                                                                                  name = "mailman.conf"}
                            in
                                write "\t'";
                                write host;
@@ -42,16 +76,17 @@ val () = Env.actionV_one "mailmanVhost"
         ("host", Env.string)
         (fn (env, host) =>
             let
-                val nodes = Env.env (Env.list Env.string) (env, "WebNodes")
+                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}
@@ -63,18 +98,24 @@ 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 ";
+                            print host;
+                            print ".";
+                            print (Domain.currentDomain ());
                             print "\n";
-                            print "    ServerName $LISTDOMAIN\n";
                             print "    ServerAdmin ";
-                            print user;
-                            print "@hcoop.net\n";
-                            print "    SuexecUserGroup list list\n";
+                            print sadmin;
+                            print "\n";
+                            (* 
+                             print "    SuexecUserGroup list list\n";
                             print "\n";
+                            *)
                             print "    ErrorLog ";
                             print ld;
                             print "/error.log\n";
@@ -85,7 +126,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";
@@ -105,10 +150,27 @@ val () = Env.actionV_one "mailmanVhost"
                             print "        Order allow,deny\n";
                             print "        Allow from all\n";
                             print "    </Directory>\n";
+                            print "\n";
+                            print "\n";
+                            print "    <Directory /usr/share/images/mailman>\n";
+                            print "        Order allow,deny\n";
+                            print "        Allow from all\n";
+                            print "    </Directory>\n";
+                            print "\n";
+                            print "    <Directory /var/lib/mailman/archives/public/>\n";
+                            print "        Options +SymlinksIfOwnerMatch -ExecCGI +Indexes\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
-                        end) nodes
+                            TextIO.closeOut file;
+
+                            Apache.doPost ()
+                        end) places
             end)
 
 val mailmanChanged = ref false
@@ -120,15 +182,15 @@ val () = Slave.registerFileHandler (fn fs =>
                                           val spl = OS.Path.splitDirFile (#file fs)
                                       in
                                           case #file spl of
-                                              "mailman" => mailmanChanged := true
+                                              "mailman.conf" => mailmanChanged := true
                                             | _ => ()
                                       end)
 
 val () = Slave.registerPostHandler (fn () =>
                                       if !mailmanChanged then
-                                          (Slave.concatTo (fn s => s = "mailman")
+                                          (Slave.concatTo (fn s => s = "mailman.conf")
                                                           Config.Mailman.mapFile;
-                                           Slave.enumerateTo (fn s => s = "mailman") ":"
+                                           Slave.enumerateTo (fn s => s = "mailman.conf") ":"
                                                              Config.Mailman.handleDomains;
                                                              Slave.shellF ([Config.Mailman.reload],
                                                       fn cl => "Error reloading Mailman with " ^ cl))
@@ -136,8 +198,8 @@ val () = Slave.registerPostHandler (fn () =>
                                           ())
 
 val () = Domain.registerDescriber (Domain.considerAll
-                                  [Domain.Filename {filename = "mailman",
-                                                    heading = "Mailman web host mapping",
+                                  [Domain.Filename {filename = "mailman.conf",
+                                                    heading = "Mailman web host mapping:",
                                                     showEmpty = false}])
 
 end