Use proper URL prefix in mailmanVhost redirect

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

(* HCoop Domtool (http://hcoop.sourceforge.net/)
 * Copyright (c) 2006, Adam Chlipala
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 *)

(* Mailman mailing list handling *)

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 () = Env.action_one "mailmanWebHost"
			("hostname", Env.string)
			(fn host =>
			    let
				val {write, writeDom, close} = Domain.domainsFile {node = Config.Mailman.node,
										   name = "mailman"}
			    in
				write "\t'";
				write host;
				write "' : '";
				writeDom ();
				write "',\n";
				close ()
			    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 () = Slave.registerFileHandler (fn fs =>
				       let
					   val spl = OS.Path.splitDirFile (#file fs)
				       in
					   case #file spl of
					       "mailman" => mailmanChanged := true
					     | _ => ()
				       end)

val () = Slave.registerPostHandler (fn () =>
				       if !mailmanChanged then
					   (Slave.concatTo (fn s => s = "mailman")
							   Config.Mailman.mapFile;
				            Slave.enumerateTo (fn s => s = "mailman") ":"
							      Config.Mailman.handleDomains;
							      Slave.shellF ([Config.Mailman.reload],
						       fn cl => "Error reloading Mailman with " ^ cl))
				       else
					   ())

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

end