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 12d92a0..9f30e72 100644 (file)
--- a/src/plugins/mailman.sml
+++ b/src/plugins/mailman.sml
@@ -22,24 +22,44 @@ structure Mailman :> MAILMAN = struct
 
 open Ast
 
 
 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
 
                      Env.string
                      (fn node => Apache.webNode node orelse node = Config.Mailman.node)
 
 val dl = ErrorMsg.dummyLoc
 

-val () = Env.registerFunction ("mailman_web_node",
+val () = Env.registerFunction ("mailman_node",

                               fn [] => SOME (EString Config.Mailman.node, dl)
                                | _ => NONE)
 
                               fn [] => SOME (EString Config.Mailman.node, dl)
                                | _ => NONE)
 

-val () = Env.registerFunction ("mailman_web_node_to_node",
+val () = Env.registerFunction ("mailman_node_to_node",

                            fn [e] => SOME e
                             | _ => NONE)
 
                            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
 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 => ())
 
 val files = ref ([] : TextIO.outstream list)
 val write = ref (fn _ : string => ())


@@ -63,7 +83,7 @@ val () = Env.actionV_one "mailmanVhost"
         ("host", Env.string)
         (fn (env, host) =>
             let
         ("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 ssl = Env.env Apache.ssl (env, "SSL")
                 val user = Env.env Env.string (env, "User")


@@ -72,7 +92,7 @@ val () = Env.actionV_one "mailmanVhost"
                 val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
                 val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
             in
                 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}
                         let
                             val file = Domain.domainFile {node = node,
                                                           name = confFile}


@@ -84,13 +104,17 @@ val () = Env.actionV_one "mailmanVhost"
                             print user;
                             print "\n";
                             print "<VirtualHost ";
                             print user;
                             print "\n";
                             print "<VirtualHost ";

-                            print (Domain.nodeIp node);
+                            print ip;

                             print ":";
                             print (case ssl of
                                        SOME _ => "443"
                                      | NONE => "80");
                             print ">\n";
                             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 "    ServerAdmin ";
                             print user;
                             print "@hcoop.net\n";


@@ -106,7 +130,11 @@ val () = Env.actionV_one "mailmanVhost"
                             print "    RewriteEngine on\n";
                             print "\n";
                             print "    # Default to showing listinfo page\n";
                             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";
                             print fullHost;
                             print "/listinfo/\n";
                             print "\n";


@@ -127,14 +155,14 @@ val () = Env.actionV_one "mailmanVhost"
                             print "        Allow from all\n";
                             print "    </Directory>\n";
 
                             print "        Allow from all\n";
                             print "    </Directory>\n";
 

-                            Apache.doPre {user = user, nodes = nodes, id = vhostId, hostname = fullHost};
+                            Apache.doPre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};

 
                             print "</VirtualHost>\n";
 
                             TextIO.closeOut file;
 
                             Apache.doPost ()
 
                             print "</VirtualHost>\n";
 
                             TextIO.closeOut file;
 
                             Apache.doPost ()

-                        end) nodes
+                        end) places

             end)
 
 val mailmanChanged = ref false
             end)
 
 val mailmanChanged = ref false


@@ -163,7 +191,7 @@ val () = Slave.registerPostHandler (fn () =>
 
 val () = Domain.registerDescriber (Domain.considerAll
                                   [Domain.Filename {filename = "mailman",
 
 val () = Domain.registerDescriber (Domain.considerAll
                                   [Domain.Filename {filename = "mailman",

-                                                    heading = "Mailman web host mapping",
+                                                    heading = "Mailman web host mapping:",

                                                     showEmpty = false}])
 
 end
                                                     showEmpty = false}])
 
 end