mailman: add MailmanForceSSL env var
[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, Domain.nodeIpv6 node)
41 | mailmanPlace (EApp ((EApp ((EApp ((EVar "mailman_place", _), (EString node, _)), _), (EString ip, _)), _), (EString ipv6, _)), _) =
42 SOME (node, ip, ipv6)
43 | mailmanPlace _ = NONE
44
45 val _ = Env.registerFunction ("mailman_place_to_web_node",
46 fn [e] => Option.map (fn (node, _, _) => (EString node, dl)) (mailmanPlace e)
47 | _ => NONE)
48
49 val _ = Env.registerFunction ("mailman_place_to_node",
50 fn [e] => Option.map (fn (node, _, _) => (EString node, dl)) (mailmanPlace e)
51 | _ => NONE)
52
53 val _ = Env.registerFunction ("mailman_place_to_ip",
54 fn [e] => Option.map (fn (_, ip, _) => (EString ip, dl)) (mailmanPlace e)
55 | _ => NONE)
56
57 val _ = Env.registerFunction ("mailman_place_to_ip",
58 fn [e] => Option.map (fn (_, _, ipv6) => (EString ipv6, dl)) (mailmanPlace e)
59 | _ => NONE)
60
61 val files = ref ([] : TextIO.outstream list)
62 val write = ref (fn _ : string => ())
63
64 val () = Env.action_one "mailmanWebHost"
65 ("hostname", Env.string)
66 (fn host =>
67 let
68 val {write, writeDom, close} = Domain.domainsFile {node = Config.Mailman.node,
69 name = "mailman.conf"}
70 in
71 write "\t'";
72 write host;
73 write "' : '";
74 writeDom ();
75 write "',\n";
76 close ()
77 end)
78
79 val () = Env.actionV_one "mailmanVhost"
80 ("host", Env.string)
81 (fn (env, host) =>
82 let
83 val places = Env.env (Env.list mailmanPlace) (env, "MailmanPlaces")
84
85 val ssl = Env.env Apache.ssl (env, "SSL")
86 val forcessl = Env.env Env.bool (env, "MailmanForceSSL")
87 val user = Env.env Env.string (env, "User")
88 val sadmin = Env.env Env.string (env, "ServerAdmin")
89
90 val fullHost = host ^ "." ^ Domain.currentDomain ()
91 val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
92 val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
93 in
94 app (fn (node, ip, ipv6) =>
95 let
96 val file = Domain.domainFile {node = node,
97 name = confFile}
98 fun print s = TextIO.output (file, s)
99
100 val ld = Apache.logDir {user = user, node = node, vhostId = vhostId}
101 in
102 print "# Owner: ";
103 print user;
104 print "\n";
105 print "<VirtualHost ";
106
107 print ip;
108 print ":";
109 print (case ssl of
110 SOME _ => "443"
111 | NONE => "80");
112
113 print " [";
114 print ipv6;
115 print "]";
116 print ":";
117 print (case ssl of
118 SOME _ => "443"
119 | NONE => "80");
120
121 print ">\n";
122 print " ServerName ";
123 print host;
124 print ".";
125 print (Domain.currentDomain ());
126 print "\n";
127 print " ServerAdmin ";
128 print sadmin;
129 print "\n";
130 case ssl of
131 SOME cert =>
132 (print "\n\tSSLEngine on\n\tSSLCertificateFile ";
133 print cert;
134 print "\n")
135 | NONE => if forcessl then
136 (print "RewriteRule ^(.*)$ https://%{HTTP_HOST}$1 [R,L]")
137 else
138 ();
139 (*
140 print " SuexecUserGroup list list\n";
141 print "\n";
142 *)
143 print " ErrorLog ";
144 print ld;
145 print "/error.log\n";
146 print " CustomLog ";
147 print ld;
148 print "/access.log combined\n";
149 print "\n";
150 print " RewriteEngine on\n";
151 print "\n";
152 print " # Default to showing listinfo page\n";
153 print " RewriteRule ^/$ http";
154 case ssl of
155 NONE => ()
156 | SOME _ => print "s";
157 print "://";
158 print fullHost;
159 print "/listinfo/\n";
160 print "\n";
161 print " Alias /images/mailman /usr/share/images/mailman\n";
162 print " Alias /pipermail /var/lib/mailman/archives/public\n";
163 print "\n";
164 print " DocumentRoot /usr/lib/cgi-bin/mailman\n";
165 print " <Directory /usr/lib/cgi-bin/mailman>\n";
166 print " AllowOverride None\n";
167 print " Options +ExecCGI -MultiViews +SymLinksIfOwnerMatch\n";
168 print " ForceType cgi-script\n";
169 print " Order allow,deny\n";
170 print " Allow from all\n";
171 print " </Directory>\n";
172 print "\n";
173 print " <Directory /usr/share/doc/mailman>\n";
174 print " Order allow,deny\n";
175 print " Allow from all\n";
176 print " </Directory>\n";
177 print "\n";
178 print "\n";
179 print " <Directory /usr/share/images/mailman>\n";
180 print " Order allow,deny\n";
181 print " Allow from all\n";
182 print " </Directory>\n";
183 print "\n";
184 print " <Directory /var/lib/mailman/archives/public/>\n";
185 print " Options +SymlinksIfOwnerMatch -ExecCGI +Indexes\n";
186 print " Order allow,deny\n";
187 print " Allow from all\n";
188 print " </Directory>\n";
189
190 Apache.doPre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
191
192 print "</VirtualHost>\n";
193
194 TextIO.closeOut file;
195
196 Apache.doPost ()
197 end) places
198 end)
199
200 val mailmanChanged = ref false
201
202 val () = Slave.registerPreHandler (fn () => mailmanChanged := false)
203
204 val () = Slave.registerFileHandler (fn fs =>
205 let
206 val spl = OS.Path.splitDirFile (#file fs)
207 in
208 case #file spl of
209 "mailman.conf" => mailmanChanged := true
210 | _ => ()
211 end)
212
213 val () = Slave.registerPostHandler (fn () =>
214 if !mailmanChanged then
215 (Slave.concatTo (fn s => s = "mailman.conf")
216 Config.Mailman.mapFile;
217 Slave.enumerateTo (fn s => s = "mailman.conf") ":"
218 Config.Mailman.handleDomains;
219 Slave.shellF ([Config.Mailman.reload],
220 fn cl => "Error reloading Mailman with " ^ cl))
221 else
222 ())
223
224 val () = Domain.registerDescriber (Domain.considerAll
225 [Domain.Filename {filename = "mailman.conf",
226 heading = "Mailman web host mapping:",
227 showEmpty = false}])
228
229 end