Generate right Mailman vhost name
[hcoop/domtool2.git] / src / plugins / mailman.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, Adam Chlipala
3 *
4 * This program is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU General Public License
6 * as published by the Free Software Foundation; either version 2
7 * of the License, or (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
17 *)
18
19 (* Mailman mailing list handling *)
20
21 structure Mailman :> MAILMAN = struct
22
23 open Ast
24
25 val () = Env.type_one "mailman_node"
26 Env.string
27 (fn node => Apache.webNode node orelse node = Config.Mailman.node)
28
29 val dl = ErrorMsg.dummyLoc
30
31 val () = Env.registerFunction ("mailman_node",
32 fn [] => SOME (EString Config.Mailman.node, dl)
33 | _ => NONE)
34
35 val () = Env.registerFunction ("mailman_node_to_node",
36 fn [e] => SOME e
37 | _ => NONE)
38
39 fun mailmanPlace (EApp ((EVar "mailman_place_default", _), (EString node, _)), _) =
40 SOME (node, Domain.nodeIp node)
41 | mailmanPlace (EApp ((EApp ((EVar "mailman_place", _), (EString node, _)), _), (EString ip, _)), _) =
42 SOME (node, ip)
43 | mailmanPlace _ = NONE
44
45 fun mailmanPlaceDefault node = (EApp ((EVar "mailman_place_default", dl), (EString node, dl)), dl)
46
47 val _ = Env.registerFunction ("mailman_place_to_web_node",
48 fn [e] => Option.map (fn (node, _) => (EString node, dl)) (mailmanPlace e)
49 | _ => NONE)
50
51 val _ = Env.registerFunction ("mailman_place_to_node",
52 fn [e] => Option.map (fn (node, _) => (EString node, dl)) (mailmanPlace e)
53 | _ => NONE)
54
55 val _ = Env.registerFunction ("mailman_place_to_ip",
56 fn [e] => Option.map (fn (_, ip) => (EString ip, dl)) (mailmanPlace e)
57 | _ => NONE)
58
59 val () = Defaults.registerDefault
60 ("MailmanPlaces",
61 (TList (TBase "mailman_place", dl), dl),
62 (fn () => (EList [mailmanPlaceDefault Config.Mailman.node], dl)))
63
64 val files = ref ([] : TextIO.outstream list)
65 val write = ref (fn _ : string => ())
66
67 val () = Env.action_one "mailmanWebHost"
68 ("hostname", Env.string)
69 (fn host =>
70 let
71 val {write, writeDom, close} = Domain.domainsFile {node = Config.Mailman.node,
72 name = "mailman"}
73 in
74 write "\t'";
75 write host;
76 write "' : '";
77 writeDom ();
78 write "',\n";
79 close ()
80 end)
81
82 val () = Env.actionV_one "mailmanVhost"
83 ("host", Env.string)
84 (fn (env, host) =>
85 let
86 val places = Env.env (Env.list mailmanPlace) (env, "MailmanPlaces")
87
88 val ssl = Env.env Apache.ssl (env, "SSL")
89 val user = Env.env Env.string (env, "User")
90
91 val fullHost = host ^ "." ^ Domain.currentDomain ()
92 val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
93 val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
94 in
95 app (fn (node, ip) =>
96 let
97 val file = Domain.domainFile {node = node,
98 name = confFile}
99 fun print s = TextIO.output (file, s)
100
101 val ld = Apache.logDir {user = user, node = node, vhostId = vhostId}
102 in
103 print "# Owner: ";
104 print user;
105 print "\n";
106 print "<VirtualHost ";
107 print ip;
108 print ":";
109 print (case ssl of
110 SOME _ => "443"
111 | NONE => "80");
112 print ">\n";
113 print " ServerName ";
114 print host;
115 print ".";
116 print (Domain.currentDomain ());
117 print "\n";
118 print " ServerAdmin ";
119 print user;
120 print "@hcoop.net\n";
121 print " SuexecUserGroup list list\n";
122 print "\n";
123 print " ErrorLog ";
124 print ld;
125 print "/error.log\n";
126 print " CustomLog ";
127 print ld;
128 print "/access.log combined\n";
129 print "\n";
130 print " RewriteEngine on\n";
131 print "\n";
132 print " # Default to showing listinfo page\n";
133 print " RewriteRule ^/$ http://";
134 print fullHost;
135 print "/listinfo/\n";
136 print "\n";
137 print " Alias /images/mailman /usr/share/images/mailman\n";
138 print " Alias /pipermail /var/lib/mailman/archives/public\n";
139 print "\n";
140 print " DocumentRoot /usr/lib/cgi-bin/mailman\n";
141 print " <Directory /usr/lib/cgi-bin/mailman>\n";
142 print " AllowOverride None\n";
143 print " Options +ExecCGI -MultiViews +SymLinksIfOwnerMatch\n";
144 print " ForceType cgi-script\n";
145 print " Order allow,deny\n";
146 print " Allow from all\n";
147 print " </Directory>\n";
148 print "\n";
149 print " <Directory /usr/share/doc/mailman>\n";
150 print " Order allow,deny\n";
151 print " Allow from all\n";
152 print " </Directory>\n";
153
154 Apache.doPre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
155
156 print "</VirtualHost>\n";
157
158 TextIO.closeOut file;
159
160 Apache.doPost ()
161 end) places
162 end)
163
164 val mailmanChanged = ref false
165
166 val () = Slave.registerPreHandler (fn () => mailmanChanged := false)
167
168 val () = Slave.registerFileHandler (fn fs =>
169 let
170 val spl = OS.Path.splitDirFile (#file fs)
171 in
172 case #file spl of
173 "mailman" => mailmanChanged := true
174 | _ => ()
175 end)
176
177 val () = Slave.registerPostHandler (fn () =>
178 if !mailmanChanged then
179 (Slave.concatTo (fn s => s = "mailman")
180 Config.Mailman.mapFile;
181 Slave.enumerateTo (fn s => s = "mailman") ":"
182 Config.Mailman.handleDomains;
183 Slave.shellF ([Config.Mailman.reload],
184 fn cl => "Error reloading Mailman with " ^ cl))
185 else
186 ())
187
188 val () = Domain.registerDescriber (Domain.considerAll
189 [Domain.Filename {filename = "mailman",
190 heading = "Mailman web host mapping",
191 showEmpty = false}])
192
193 end