1 (* HCoop
Domtool (http
://hcoop
.sourceforge
.net
/)
2 * Copyright (c
) 2006, Adam Chlipala
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
.
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
.
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
.
19 (* Mailman mailing list handling
*)
21 structure Mailman
:> MAILMAN
= struct
25 val () = Env
.type_one
"mailman_node"
27 (fn node
=> Apache
.webNode node
orelse node
= Config
.Mailman
.node
)
29 val dl
= ErrorMsg
.dummyLoc
31 val () = Env
.registerFunction ("mailman_node",
32 fn [] => SOME (EString Config
.Mailman
.node
, dl
)
35 val () = Env
.registerFunction ("mailman_node_to_node",
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
, _
)), _
) =
43 | mailmanPlace _
= NONE
45 val _
= Env
.registerFunction ("mailman_place_to_web_node",
46 fn [e
] => Option
.map (fn (node
, _
, _
) => (EString node
, dl
)) (mailmanPlace e
)
49 val _
= Env
.registerFunction ("mailman_place_to_node",
50 fn [e
] => Option
.map (fn (node
, _
, _
) => (EString node
, dl
)) (mailmanPlace e
)
53 val _
= Env
.registerFunction ("mailman_place_to_ip",
54 fn [e
] => Option
.map (fn (_
, ip
, _
) => (EString ip
, dl
)) (mailmanPlace e
)
57 val _
= Env
.registerFunction ("mailman_place_to_ip",
58 fn [e
] => Option
.map (fn (_
, _
, ipv6
) => (EString ipv6
, dl
)) (mailmanPlace e
)
61 val files
= ref ([] : TextIO.outstream list
)
62 val write
= ref (fn _
: string => ())
64 val () = Env
.action_one
"mailmanWebHost"
65 ("hostname", Env
.string)
68 val {write
, writeDom
, close
} = Domain
.domainsFile
{node
= Config
.Mailman
.node
,
69 name
= "mailman.conf"}
79 val () = Env
.actionV_one
"mailmanVhost"
83 val places
= Env
.env (Env
.list mailmanPlace
) (env
, "MailmanPlaces")
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")
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")
94 app (fn (node
, ip
, ipv6
) =>
96 val file
= Domain
.domainFile
{node
= node
,
98 fun print s
= TextIO.output (file
, s
)
100 val ld
= Apache
.logDir
{user
= user
, node
= node
, vhostId
= vhostId
}
105 print
"<VirtualHost ";
122 print
" ServerName ";
125 print (Domain
.currentDomain ());
127 print
" ServerAdmin ";
132 (print
"\n\tSSLEngine on\n\tSSLCertificateFile ";
135 | NONE
=> if forcessl
then
136 (print
"\tRewriteRule ^(.*)$ https://%{HTTP_HOST}$1 [R,L]\n")
140 print
" SuexecUserGroup list list\n";
145 print
"/error.log\n";
148 print
"/access.log combined\n";
150 print
" RewriteEngine on\n";
152 print
" # Default to showing listinfo page\n";
153 print
" RewriteRule ^/$ http";
156 | SOME _
=> print
"s";
159 print
"/listinfo/\n";
161 print
" Alias /images/mailman /usr/share/images/mailman\n";
162 print
" Alias /pipermail /var/lib/mailman/archives/public\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";
173 print
" <Directory /usr/share/doc/mailman>\n";
174 print
" Order allow,deny\n";
175 print
" Allow from all\n";
176 print
" </Directory>\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";
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";
190 Apache
.doPre
{user
= user
, nodes
= map #
1 places
, id
= vhostId
, hostname
= fullHost
};
192 print
"</VirtualHost>\n";
194 TextIO.closeOut file
;
200 val mailmanChanged
= ref
false
202 val () = Slave
.registerPreHandler (fn () => mailmanChanged
:= false)
204 val () = Slave
.registerFileHandler (fn fs
=>
206 val spl
= OS
.Path
.splitDirFile (#file fs
)
209 "mailman.conf" => mailmanChanged
:= true
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
))
224 val () = Domain
.registerDescriber (Domain
.considerAll
225 [Domain
.Filename
{filename
= "mailman.conf",
226 heading
= "Mailman web host mapping:",