Slave catches all exceptions, to avoid dying
[hcoop/domtool2.git] / src / plugins / apache.sml
CommitLineData
8a7c40fa 1(* HCoop Domtool (http://hcoop.sourceforge.net/)
8a5b34c9 2 * Copyright (c) 2006-2007, Adam Chlipala
8a7c40fa
AC
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(* Apache HTTPD handling *)
20
21structure Apache :> APACHE = struct
22
23open Ast
24
128e7b0b
AC
25val dl = ErrorMsg.dummyLoc
26
de5351c7
AC
27fun webNode node =
28 List.exists (fn (x, _) => x = node) Config.Apache.webNodes_all
29 orelse (Domain.hasPriv "www"
30 andalso List.exists (fn (x, _) => x = node) Config.Apache.webNodes_admin)
31
60695e99
AC
32val _ = Env.type_one "web_node"
33 Env.string
de5351c7 34 webNode
60695e99 35
ce01b51a
AC
36val _ = Env.registerFunction ("web_node_to_node",
37 fn [e] => SOME e
38 | _ => NONE)
39
b5f2d506 40fun webPlace (EApp ((EVar "web_place_default", _), (EString node, _)), _) =
128e7b0b 41 SOME (node, Domain.nodeIp node)
b5f2d506 42 | webPlace (EApp ((EApp ((EVar "web_place", _), (EString node, _)), _), (EString ip, _)), _) =
128e7b0b
AC
43 SOME (node, ip)
44 | webPlace _ = NONE
45
b5f2d506 46fun webPlaceDefault node = (EApp ((EVar "web_place_default", dl), (EString node, dl)), dl)
128e7b0b
AC
47
48val _ = Env.registerFunction ("web_place_to_web_node",
49 fn [e] => Option.map (fn (node, _) => (EString node, dl)) (webPlace e)
50 | _ => NONE)
51
52val _ = Env.registerFunction ("web_place_to_node",
53 fn [e] => Option.map (fn (node, _) => (EString node, dl)) (webPlace e)
54 | _ => NONE)
55
56val _ = Env.registerFunction ("web_place_to_ip",
57 fn [e] => Option.map (fn (_, ip) => (EString ip, dl)) (webPlace e)
58 | _ => NONE)
59
f8dfbbcc
AC
60val _ = Env.type_one "proxy_port"
61 Env.int
e95a129e
AC
62 (fn n => n > 1024)
63
64val _ = Env.type_one "proxy_target"
65 Env.string
66 (fn s =>
67 let
68 fun default () = List.exists (fn s' => s = s') Config.Apache.proxyTargets
69 in
70 case String.fields (fn ch => ch = #":") s of
71 ["http", "//localhost", rest] =>
72 (case String.fields (fn ch => ch = #"/") rest of
73 port :: _ =>
74 (case Int.fromString port of
75 NONE => default ()
76 | SOME n => n > 1024 orelse default ())
77 | _ => default ())
78 | _ => default ()
79 end)
f8dfbbcc
AC
80
81val _ = Env.type_one "rewrite_arg"
82 Env.string
83 (CharVector.all Char.isAlphaNum)
84
00a13ad8
AC
85val _ = Env.type_one "suexec_flag"
86 Env.bool
87 (fn b => b orelse Domain.hasPriv "www")
88
2882ee37
AC
89fun validLocation s =
90 size s > 0 andalso size s < 1000 andalso CharVector.all
91 (fn ch => Char.isAlphaNum ch
92 orelse ch = #"-"
93 orelse ch = #"_"
94 orelse ch = #"."
95 orelse ch = #"/") s
96
97val _ = Env.type_one "location"
98 Env.string
99 validLocation
100
434a7b1f
AC
101fun validCert s = Acl.query {user = Domain.getUser (),
102 class = "cert",
103 value = s}
104
105val _ = Env.type_one "ssl_cert_path"
106 Env.string
107 validCert
108
109fun ssl e = case e of
110 (EVar "no_ssl", _) => SOME NONE
111 | (EApp ((EVar "use_cert", _), s), _) => Option.map SOME (Env.string s)
112 | _ => NONE
113
128e7b0b
AC
114val defaults = [("WebPlaces",
115 (TList (TBase "web_place", dl), dl),
116 (fn () => (EList (map webPlaceDefault Config.Apache.webNodes_default), dl))),
8cbb9632
AC
117 ("SSL",
118 (TBase "ssl", dl),
119 (fn () => (EVar "no_ssl", dl))),
120 ("User",
121 (TBase "your_user", dl),
122 (fn () => (EString (Domain.getUser ()), dl))),
123 ("Group",
124 (TBase "your_group", dl),
125 (fn () => (EString "nogroup", dl))),
126 ("DocumentRoot",
127 (TBase "your_path", dl),
128 (fn () => (EString (Domain.homedir () ^ "/" ^ Config.Apache.public_html), dl))),
129 ("ServerAdmin",
130 (TBase "email", dl),
131 (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))),
132 ("SuExec",
133 (TBase "suexec_flag", dl),
134 (fn () => (EVar "true", dl)))]
135
136val () = app Defaults.registerDefault defaults
f8dfbbcc
AC
137
138val redirect_code = fn (EVar "temp", _) => SOME "temp"
139 | (EVar "permanent", _) => SOME "permanent"
140 | (EVar "seeother", _) => SOME "seeother"
141 | (EVar "redir300", _) => SOME "300"
142 | (EVar "redir301", _) => SOME "301"
143 | (EVar "redir302", _) => SOME "302"
144 | (EVar "redir303", _) => SOME "303"
145 | (EVar "redir304", _) => SOME "304"
146 | (EVar "redir305", _) => SOME "305"
147 | (EVar "redir307", _) => SOME "307"
148 | _ => NONE
149
150val flag = fn (EVar "redirect", _) => SOME "R"
151 | (EVar "forbidden", _) => SOME "F"
152 | (EVar "gone", _) => SOME "G"
153 | (EVar "last", _) => SOME "L"
154 | (EVar "chain", _) => SOME "C"
155 | (EVar "nosubreq", _) => SOME "NS"
156 | (EVar "nocase", _) => SOME "NC"
157 | (EVar "qsappend", _) => SOME "QSA"
158 | (EVar "noescape", _) => SOME "NE"
159 | (EVar "passthrough", _) => SOME "PT"
160 | (EApp ((EVar "mimeType", _), e), _) =>
161 Option.map (fn s => "T=" ^ s) (Env.string e)
162 | (EApp ((EVar "redirectWith", _), e), _) =>
163 Option.map (fn s => "R=" ^ s) (redirect_code e)
164 | (EApp ((EVar "skip", _), e), _) =>
165 Option.map (fn n => "S=" ^ Int.toString n) (Env.int e)
166 | (EApp ((EApp ((EVar "env", _), e1), _), e2), _) =>
167 (case Env.string e1 of
168 NONE => NONE
169 | SOME s1 => Option.map (fn s2 => "E=" ^ s1 ^ ":" ^ s2)
170 (Env.string e2))
171
172 | _ => NONE
173
e95a129e
AC
174val cond_flag = fn (EVar "cond_nocase", _) => SOME "NC"
175 | (EVar "ornext", _) => SOME "OR"
176 | _ => NONE
177
d441e69f
AC
178val apache_option = fn (EVar "execCGI", _) => SOME "ExecCGI"
179 | (EVar "includesNOEXEC", _) => SOME "IncludesNOEXEC"
180 | (EVar "indexes", _) => SOME "Indexes"
181 | _ => NONE
182
9d7fa346
AC
183val autoindex_width = fn (EVar "autofit", _) => SOME "*"
184 | (EApp ((EVar "characters", _), n), _) =>
185 Option.map Int.toString (Env.int n)
186 | _ => NONE
187
188val autoindex_option = fn (EApp ((EVar "descriptionWidth", _), w), _) =>
189 Option.map (fn w => ("DescriptionWidth", SOME w))
190 (autoindex_width w)
191 | (EVar "fancyIndexing", _) => SOME ("FancyIndexing", NONE)
192 | (EVar "foldersFirst", _) => SOME ("FoldersFirst", NONE)
193 | (EVar "htmlTable", _) => SOME ("HTMLTable", NONE)
194 | (EVar "iconsAreLinks", _) => SOME ("IconsAreLinks", NONE)
195 | (EApp ((EVar "iconHeight", _), n), _) =>
196 Option.map (fn w => ("IconHeight", SOME (Int.toString w)))
197 (Env.int n)
198 | (EApp ((EVar "iconWidth", _), n), _) =>
199 Option.map (fn w => ("IconWidth", SOME (Int.toString w)))
200 (Env.int n)
201 | (EVar "ignoreCase", _) => SOME ("IgnoreCase", NONE)
202 | (EVar "ignoreClient", _) => SOME ("IgnoreClient", NONE)
203 | (EApp ((EVar "nameWidth", _), w), _) =>
204 Option.map (fn w => ("NameWidth", SOME w))
205 (autoindex_width w)
206 | (EVar "scanHtmlTitles", _) => SOME ("ScanHTMLTitles", NONE)
207 | (EVar "suppressColumnSorting", _) => SOME ("SuppressColumnSorting", NONE)
208 | (EVar "suppressDescription", _) => SOME ("SuppressDescription", NONE)
209 | (EVar "suppressHtmlPreamble", _) => SOME ("SuppressHTMLPreamble", NONE)
210 | (EVar "suppressIcon", _) => SOME ("SuppressIcon", NONE)
211 | (EVar "suppressLastModified", _) => SOME ("SuppressLastModified", NONE)
212 | (EVar "suppressRules", _) => SOME ("SuppressRules", NONE)
213 | (EVar "suppressSize", _) => SOME ("SuppressSize", NONE)
214 | (EVar "trackModified", _) => SOME ("TrackModified", NONE)
215 | (EVar "versionSort", _) => SOME ("VersionSort", NONE)
216 | (EVar "xhtml", _) => SOME ("XHTML", NONE)
217
218 | _ => NONE
f8dfbbcc 219
8a7c40fa 220val vhostsChanged = ref false
8e965b2d 221val logDeleted = ref false
8a7c40fa
AC
222
223val () = Slave.registerPreHandler
8e965b2d
AC
224 (fn () => (vhostsChanged := false;
225 logDeleted := false))
8a7c40fa 226
7db53a0b
AC
227fun findVhostUser fname =
228 let
229 val inf = TextIO.openIn fname
230
231 fun loop () =
232 case TextIO.inputLine inf of
233 NONE => NONE
234 | SOME line =>
00a13ad8
AC
235 if String.isPrefix "# Owner: " line then
236 case String.tokens Char.isSpace line of
237 [_, _, user] => SOME user
238 | _ => NONE
239 else
240 loop ()
7db53a0b
AC
241 in
242 loop ()
243 before TextIO.closeIn inf
3a941c29 244 end handle _ => NONE
7db53a0b 245
55d4a268
AC
246val webNodes_full = Config.Apache.webNodes_all @ Config.Apache.webNodes_admin
247
248fun isVersion1 node =
f8ef6c20
AC
249 List.exists (fn (n, {version = ConfigTypes.APACHE_1_3, ...}) => n = node
250 | _ => false) webNodes_full
55d4a268
AC
251
252fun imVersion1 () = isVersion1 (Slave.hostname ())
253
f8ef6c20
AC
254fun isWaklog node =
255 List.exists (fn (n, {auth = ConfigTypes.MOD_WAKLOG, ...}) => n = node
256 | _ => false) webNodes_full
257
55d4a268
AC
258fun down () = if imVersion1 () then Config.Apache.down1 else Config.Apache.down
259fun undown () = if imVersion1 () then Config.Apache.undown1 else Config.Apache.undown
260fun reload () = if imVersion1 () then Config.Apache.reload1 else Config.Apache.reload
c17d0537 261fun fixperms () = if imVersion1 () then Config.Apache.fixperms1 else Config.Apache.fixperms
55d4a268 262
b59d9074 263fun logDir {user, node, vhostId} =
2a7d2818 264 String.concat [Config.Apache.logDirOf (isVersion1 node) user,
409542d7 265 "/",
b59d9074
AC
266 node,
267 "/",
268 vhostId]
269
8a7c40fa 270val () = Slave.registerFileHandler (fn fs =>
7a2b27f0
AC
271 let
272 val spl = OS.Path.splitDirFile (#file fs)
273 in
274 if String.isSuffix ".vhost" (#file spl)
3a941c29
AC
275 orelse String.isSuffix ".vhost_ssl" (#file spl) then let
276 val realVhostFile = OS.Path.joinDirFile
277 {dir = Config.Apache.confDir,
278 file = #file spl}
279
280 val user = findVhostUser (#file fs)
19026493
AC
281 val oldUser = case #action fs of
282 Slave.Delete false => user
283 | _ => findVhostUser realVhostFile
3a941c29
AC
284 in
285 if (oldUser = NONE andalso #action fs <> Slave.Add)
1638d5a2 286 orelse (user = NONE andalso not (Slave.isDelete (#action fs))) then
3a941c29
AC
287 print ("Can't find user in " ^ #file fs ^ " or " ^ realVhostFile ^ "! Taking no action.\n")
288 else
289 let
5b07cebd 290 val vhostId = if OS.Path.ext (#file spl) = SOME "vhost_ssl" then
b59d9074
AC
291 OS.Path.base (#file spl) ^ ".ssl"
292 else
293 OS.Path.base (#file spl)
294
3a941c29 295 fun realLogDir user =
b59d9074
AC
296 logDir {user = valOf user,
297 node = Slave.hostname (),
298 vhostId = vhostId}
c17d0537
AC
299
300 fun backupLogs () =
301 OS.Path.joinDirFile
302 {dir = Config.Apache.backupLogDirOf
303 (isVersion1 (Slave.hostname ())),
304 file = vhostId}
3a941c29
AC
305 in
306 vhostsChanged := true;
307 case #action fs of
1638d5a2 308 Slave.Delete _ =>
31b50af0
AC
309 let
310 val ldir = realLogDir oldUser
311 in
312 if !logDeleted then
313 ()
314 else
315 (ignore (OS.Process.system (down ()));
c17d0537 316 ignore (OS.Process.system (fixperms ()));
31b50af0
AC
317 logDeleted := true);
318 ignore (OS.Process.system (Config.rm
319 ^ " -rf "
320 ^ realVhostFile));
321 Slave.moveDirCreate {from = ldir,
c17d0537 322 to = backupLogs ()}
31b50af0 323 end
3a941c29
AC
324 | Slave.Add =>
325 let
326 val rld = realLogDir user
327 in
328 ignore (OS.Process.system (Config.cp
329 ^ " "
330 ^ #file fs
331 ^ " "
332 ^ realVhostFile));
333 if Posix.FileSys.access (rld, []) then
334 ()
335 else
c17d0537 336 Slave.moveDirCreate {from = backupLogs (),
31b50af0 337 to = rld}
3a941c29
AC
338 end
339
340 | _ =>
341 (ignore (OS.Process.system (Config.cp
342 ^ " "
343 ^ #file fs
344 ^ " "
345 ^ realVhostFile));
346 if user <> oldUser then
347 let
348 val old = realLogDir oldUser
349 val rld = realLogDir user
350 in
351 if !logDeleted then
352 ()
353 else
55d4a268 354 (ignore (OS.Process.system (down ()));
3a941c29
AC
355 logDeleted := true);
356 ignore (OS.Process.system (Config.rm
357 ^ " -rf "
358 ^ realLogDir oldUser));
359 if Posix.FileSys.access (rld, []) then
360 ()
361 else
409542d7 362 Slave.mkDirAll rld
3a941c29
AC
363 end
364 else
365 ())
366 end
367 end
7a2b27f0
AC
368 else
369 ()
370 end)
8a7c40fa
AC
371
372val () = Slave.registerPostHandler
373 (fn () =>
374 (if !vhostsChanged then
55d4a268 375 Slave.shellF ([if !logDeleted then undown () else reload ()],
8a7c40fa
AC
376 fn cl => "Error reloading Apache with " ^ cl)
377 else
378 ()))
379
7a2b27f0
AC
380val vhostFiles : (string * TextIO.outstream) list ref = ref []
381fun write' s = app (fn (node, file) => TextIO.output (file, s node)) (!vhostFiles)
382fun write s = app (fn (_, file) => TextIO.output (file, s)) (!vhostFiles)
8a7c40fa 383
f8dfbbcc 384val rewriteEnabled = ref false
ce01b51a 385val localRewriteEnabled = ref false
c98b57cf
AC
386val currentVhost = ref ""
387val currentVhostId = ref ""
8a5b34c9 388val sslEnabled = ref false
f8dfbbcc 389
7a2b27f0 390val pre = ref (fn _ : {user : string, nodes : string list, id : string, hostname : string} => ())
7f75d838
AC
391fun registerPre f =
392 let
393 val old = !pre
394 in
395 pre := (fn x => (old x; f x))
396 end
397
398val post = ref (fn () => ())
399fun registerPost f =
400 let
401 val old = !post
402 in
403 post := (fn () => (old (); f ()))
404 end
405
e9f528ab
AC
406fun doPre x = !pre x
407fun doPost () = !post ()
408
7f75d838
AC
409val aliaser = ref (fn _ : string => ())
410fun registerAliaser f =
411 let
412 val old = !aliaser
413 in
414 aliaser := (fn x => (old x; f x))
415 end
416
8a7c40fa
AC
417val () = Env.containerV_one "vhost"
418 ("host", Env.string)
419 (fn (env, host) =>
420 let
128e7b0b 421 val places = Env.env (Env.list webPlace) (env, "WebPlaces")
8a7c40fa 422
434a7b1f 423 val ssl = Env.env ssl (env, "SSL")
8a7c40fa
AC
424 val user = Env.env Env.string (env, "User")
425 val group = Env.env Env.string (env, "Group")
426 val docroot = Env.env Env.string (env, "DocumentRoot")
427 val sadmin = Env.env Env.string (env, "ServerAdmin")
434a7b1f 428 val suexec = Env.env Env.bool (env, "SuExec")
8a7c40fa
AC
429
430 val fullHost = host ^ "." ^ Domain.currentDomain ()
434a7b1f
AC
431 val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
432 val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
8a7c40fa 433 in
c98b57cf
AC
434 currentVhost := fullHost;
435 currentVhostId := vhostId;
8a5b34c9 436 sslEnabled := Option.isSome ssl;
c98b57cf 437
f8dfbbcc 438 rewriteEnabled := false;
ce01b51a 439 localRewriteEnabled := false;
128e7b0b 440 vhostFiles := map (fn (node, ip) =>
8a7c40fa
AC
441 let
442 val file = Domain.domainFile {node = node,
443 name = confFile}
2a7d2818
AC
444
445 val ld = logDir {user = user, node = node, vhostId = vhostId}
8a7c40fa 446 in
00a13ad8
AC
447 TextIO.output (file, "# Owner: ");
448 TextIO.output (file, user);
449 TextIO.output (file, "\n<VirtualHost ");
128e7b0b 450 TextIO.output (file, ip);
8a7c40fa 451 TextIO.output (file, ":");
434a7b1f
AC
452 TextIO.output (file, case ssl of
453 SOME _ => "443"
454 | NONE => "80");
8a7c40fa 455 TextIO.output (file, ">\n");
7a2b27f0 456 TextIO.output (file, "\tErrorLog ");
2a7d2818 457 TextIO.output (file, ld);
7a2b27f0 458 TextIO.output (file, "/error.log\n\tCustomLog ");
2a7d2818 459 TextIO.output (file, ld);
7a2b27f0 460 TextIO.output (file, "/access.log combined\n");
55d4a268
AC
461 TextIO.output (file, "\tServerName ");
462 TextIO.output (file, fullHost);
e519d696
AC
463 app
464 (fn dom => (TextIO.output (file, "\n\tServerAlias ");
465 TextIO.output (file, host);
466 TextIO.output (file, ".");
467 TextIO.output (file, dom)))
468 (Domain.currentAliasDomains ());
3f84c976 469
55d4a268
AC
470 if suexec then
471 if isVersion1 node then
472 (TextIO.output (file, "\n\tUser ");
473 TextIO.output (file, user);
474 TextIO.output (file, "\n\tGroup ");
475 TextIO.output (file, group))
476 else
477 (TextIO.output (file, "\n\tSuexecUserGroup ");
478 TextIO.output (file, user);
479 TextIO.output (file, " ");
480 TextIO.output (file, group))
481 else
482 ();
3f84c976 483
f8ef6c20 484 if isWaklog node then
a09d0e82 485 (TextIO.output (file, "\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
f8ef6c20 486 TextIO.output (file, user);
fdf9a42d 487 TextIO.output (file, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
f8ef6c20
AC
488 TextIO.output (file, user))
489 else
490 ();
3f84c976 491
e34e1f36 492 TextIO.output (file, "\n\tDAVLockDB /var/lock/apache2/dav/");
3f84c976
AC
493 TextIO.output (file, user);
494 TextIO.output (file, "/DAVLock");
495
2a7d2818 496 (ld, file)
8a7c40fa 497 end)
128e7b0b 498 places;
8a7c40fa
AC
499 write "\n\tDocumentRoot ";
500 write docroot;
501 write "\n\tServerAdmin ";
502 write sadmin;
434a7b1f
AC
503 case ssl of
504 SOME cert =>
505 (write "\n\tSSLEngine on\n\tSSLCertificateFile ";
506 write cert)
507 | NONE => ();
7a2b27f0 508 write "\n";
128e7b0b 509 !pre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
5cab5a98 510 app (fn dom => !aliaser (host ^ "." ^ dom)) (Domain.currentAliasDomains ())
8a7c40fa 511 end,
7f75d838
AC
512 fn () => (!post ();
513 write "</VirtualHost>\n";
7a2b27f0 514 app (TextIO.closeOut o #2) (!vhostFiles)))
8a7c40fa 515
ce01b51a
AC
516val inLocal = ref false
517
2882ee37
AC
518val () = Env.container_one "location"
519 ("prefix", Env.string)
520 (fn prefix =>
521 (write "\t<Location ";
522 write prefix;
ce01b51a
AC
523 write ">\n";
524 inLocal := true),
525 fn () => (write "\t</Location>\n";
526 inLocal := false;
527 localRewriteEnabled := false))
2882ee37
AC
528
529val () = Env.container_one "directory"
530 ("directory", Env.string)
531 (fn directory =>
532 (write "\t<Directory ";
533 write directory;
ce01b51a
AC
534 write ">\n";
535 inLocal := true),
536 fn () => (write "\t</Directory>\n";
537 inLocal := false;
538 localRewriteEnabled := false))
2882ee37 539
f8dfbbcc 540fun checkRewrite () =
ce01b51a 541 if !inLocal then
cf283351 542 if !localRewriteEnabled then
ce01b51a
AC
543 ()
544 else
545 (write "\tRewriteEngine on\n";
546 localRewriteEnabled := true)
547 else if !rewriteEnabled then
f8dfbbcc
AC
548 ()
549 else
550 (write "\tRewriteEngine on\n";
551 rewriteEnabled := true)
552
553val () = Env.action_three "localProxyRewrite"
554 ("from", Env.string, "to", Env.string, "port", Env.int)
555 (fn (from, to, port) =>
556 (checkRewrite ();
557 write "\tRewriteRule\t";
558 write from;
559 write "\thttp://localhost:";
560 write (Int.toString port);
561 write "/";
562 write to;
563 write " [P]\n"))
564
e95a129e
AC
565val () = Env.action_two "proxyPass"
566 ("from", Env.string, "to", Env.string)
567 (fn (from, to) =>
568 (write "\tProxyPass\t";
569 write from;
570 write "\t";
571 write to;
572 write "\n"))
573
574val () = Env.action_two "proxyPassReverse"
575 ("from", Env.string, "to", Env.string)
576 (fn (from, to) =>
577 (write "\tProxyPassReverse\t";
578 write from;
579 write "\t";
580 write to;
581 write "\n"))
f8dfbbcc
AC
582
583val () = Env.action_three "rewriteRule"
584 ("from", Env.string, "to", Env.string, "flags", Env.list flag)
585 (fn (from, to, flags) =>
586 (checkRewrite ();
587 write "\tRewriteRule\t";
588 write from;
589 write "\t";
590 write to;
591 case flags of
592 [] => ()
593 | flag::rest => (write " [";
594 write flag;
595 app (fn flag => (write ",";
596 write flag)) rest;
597 write "]");
598 write "\n"))
599
e95a129e
AC
600val () = Env.action_three "rewriteCond"
601 ("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
602 (fn (from, to, flags) =>
603 (checkRewrite ();
604 write "\tRewriteCond\t";
605 write from;
606 write "\t";
607 write to;
608 case flags of
609 [] => ()
610 | flag::rest => (write " [";
611 write flag;
612 app (fn flag => (write ",";
613 write flag)) rest;
614 write "]");
615 write "\n"))
616
94b7b11a
AC
617val () = Env.action_one "rewriteBase"
618 ("prefix", Env.string)
619 (fn prefix =>
620 (checkRewrite ();
621 write "\tRewriteBase\t";
622 write prefix;
623 write "\n"))
624
c98b57cf
AC
625val () = Env.action_one "rewriteLogLevel"
626 ("level", Env.int)
627 (fn level =>
628 (checkRewrite ();
629 write "\tRewriteLog ";
7a2b27f0 630 write' (fn x => x);
c98b57cf
AC
631 write "/rewrite.log\n\tRewriteLogLevel ";
632 write (Int.toString level);
633 write "\n"))
634
d5754b53
AC
635val () = Env.action_two "alias"
636 ("from", Env.string, "to", Env.string)
637 (fn (from, to) =>
638 (write "\tAlias\t";
639 write from;
640 write " ";
641 write to;
642 write "\n"))
643
644val () = Env.action_two "scriptAlias"
645 ("from", Env.string, "to", Env.string)
646 (fn (from, to) =>
647 (write "\tScriptAlias\t";
648 write from;
649 write " ";
650 write to;
651 write "\n"))
652
653val () = Env.action_two "errorDocument"
654 ("code", Env.string, "handler", Env.string)
655 (fn (code, handler) =>
989965b1
AC
656 let
657 val hasSpaces = CharVector.exists Char.isSpace handler
d5754b53 658
989965b1
AC
659 fun maybeQuote () =
660 if hasSpaces then
661 write "\""
662 else
663 ()
664 in
665 write "\tErrorDocument\t";
666 write code;
667 write " ";
668 maybeQuote ();
669 write handler;
670 maybeQuote ();
671 write "\n"
672 end)
673
d441e69f
AC
674val () = Env.action_one "options"
675 ("options", Env.list apache_option)
676 (fn opts =>
677 case opts of
678 [] => ()
679 | _ => (write "\tOptions";
680 app (fn opt => (write " "; write opt)) opts;
681 write "\n"))
682
683val () = Env.action_one "set_options"
684 ("options", Env.list apache_option)
685 (fn opts =>
686 case opts of
687 [] => ()
688 | _ => (write "\tOptions";
689 app (fn opt => (write " +"; write opt)) opts;
690 write "\n"))
691
692val () = Env.action_one "unset_options"
693 ("options", Env.list apache_option)
694 (fn opts =>
695 case opts of
696 [] => ()
697 | _ => (write "\tOptions";
698 app (fn opt => (write " -"; write opt)) opts;
699 write "\n"))
d5754b53 700
edd38024
AC
701val () = Env.action_one "directoryIndex"
702 ("filenames", Env.list Env.string)
703 (fn opts =>
704 (write "\tDirectoryIndex";
705 app (fn opt => (write " "; write opt)) opts;
706 write "\n"))
707
e519d696 708val () = Env.action_one "serverAliasHost"
edd38024
AC
709 ("host", Env.string)
710 (fn host =>
711 (write "\tServerAlias ";
712 write host;
7f75d838
AC
713 write "\n";
714 !aliaser host))
edd38024 715
e519d696
AC
716val () = Env.action_one "serverAlias"
717 ("host", Env.string)
718 (fn host =>
719 (app
720 (fn dom =>
721 let
722 val full = host ^ "." ^ dom
723 in
724 write "\tServerAlias ";
725 write full;
726 write "\n";
727 !aliaser full
728 end)
729 (Domain.currentDomains ())))
730
731val () = Env.action_none "serverAliasDefault"
732 (fn () =>
733 (app
734 (fn dom =>
735 (write "\tServerAlias ";
736 write dom;
737 write "\n";
738 !aliaser dom))
739 (Domain.currentDomains ())))
740
2aeb9eec
AC
741val authType = fn (EVar "basic", _) => SOME "basic"
742 | (EVar "digest", _) => SOME "digest"
35dc7746 743 | (EVar "kerberos", _) => SOME "kerberos"
2aeb9eec
AC
744 | _ => NONE
745
8a5b34c9
AC
746fun allowAuthType "kerberos" = !sslEnabled
747 | allowAuthType _ = true
748
2aeb9eec
AC
749val () = Env.action_one "authType"
750 ("type", authType)
751 (fn ty =>
8a5b34c9
AC
752 if allowAuthType ty then
753 (write "\tAuthType ";
754 write ty;
755 write "\n";
756 case ty of
757 "kerberos" =>
758 write "\tKrbMethodNegotiate off\n\tKrbMethodK5Passwd on\n\tKrbVerifyKDC off\n\tKrbAuthRealms HCOOP.NET\n\tKrbSaveCredentials on\n"
759 | _ => ())
760 else
761 print "WARNING: Skipped Kerberos authType because this isn't an SSL vhost.\n")
2aeb9eec
AC
762
763val () = Env.action_one "authName"
764 ("name", Env.string)
765 (fn name =>
766 (write "\tAuthName \"";
767 write name;
768 write "\"\n"))
769
770val () = Env.action_one "authUserFile"
771 ("file", Env.string)
772 (fn name =>
773 (write "\tAuthUserFile ";
774 write name;
775 write "\n"))
776
777val () = Env.action_none "requireValidUser"
778 (fn () => write "\tRequire valid-user\n")
779
780val () = Env.action_one "requireUser"
781 ("users", Env.list Env.string)
782 (fn names =>
783 case names of
784 [] => ()
785 | _ => (write "\tRequire user";
786 app (fn name => (write " "; write name)) names;
787 write "\n"))
788
789val () = Env.action_one "requireGroup"
790 ("groups", Env.list Env.string)
791 (fn names =>
792 case names of
793 [] => ()
794 | _ => (write "\tRequire group";
795 app (fn name => (write " "; write name)) names;
796 write "\n"))
797
798val () = Env.action_none "orderAllowDeny"
799 (fn () => write "\tOrder allow,deny\n")
800
801val () = Env.action_none "orderDenyAllow"
802 (fn () => write "\tOrder deny,allow\n")
803
804val () = Env.action_none "allowFromAll"
805 (fn () => write "\tAllow from all\n")
806
807val () = Env.action_one "allowFrom"
808 ("entries", Env.list Env.string)
809 (fn names =>
810 case names of
811 [] => ()
812 | _ => (write "\tAllow from";
813 app (fn name => (write " "; write name)) names;
814 write "\n"))
815
816val () = Env.action_none "denyFromAll"
817 (fn () => write "\tDeny from all\n")
818
819val () = Env.action_one "denyFrom"
820 ("entries", Env.list Env.string)
821 (fn names =>
822 case names of
823 [] => ()
824 | _ => (write "\tDeny from";
825 app (fn name => (write " "; write name)) names;
826 write "\n"))
827
828val () = Env.action_none "satisfyAll"
829 (fn () => write "\tSatisfy all\n")
830
831val () = Env.action_none "satisfyAny"
832 (fn () => write "\tSatisfy any\n")
833
7f012ffd
AC
834val () = Env.action_one "forceType"
835 ("type", Env.string)
836 (fn ty => (write "\tForceType ";
837 write ty;
838 write "\n"))
839
840val () = Env.action_none "forceTypeOff"
841 (fn () => write "\tForceType None\n")
842
843val () = Env.action_two "action"
844 ("what", Env.string, "how", Env.string)
845 (fn (what, how) => (write "\tAction ";
846 write what;
847 write " ";
848 write how;
849 write "\n"))
850
851val () = Env.action_one "addDefaultCharset"
852 ("charset", Env.string)
853 (fn ty => (write "\tAddDefaultCharset ";
854 write ty;
855 write "\n"))
856
64e85bae 857(*val () = Env.action_one "davSvn"
c8505e59
AC
858 ("path", Env.string)
859 (fn path => (write "\tDAV svn\n\tSVNPath ";
860 write path;
861 write "\n"))
862
863val () = Env.action_one "authzSvnAccessFile"
864 ("path", Env.string)
865 (fn path => (write "\tAuthzSVNAccessFile ";
866 write path;
64e85bae 867 write "\n"))*)
c8505e59 868
0aed4302
AC
869val () = Env.action_none "davFilesystem"
870 (fn path => write "\tDAV filesystem\n")
871
9d7fa346
AC
872val () = Env.action_two "addDescription"
873 ("description", Env.string, "patterns", Env.list Env.string)
874 (fn (desc, pats) =>
875 case pats of
876 [] => ()
877 | _ => (write "\tAddDescription \"";
878 write (String.toString desc);
879 write "\"";
880 app (fn pat => (write " "; write pat)) pats;
881 write "\n"))
882
883val () = Env.action_one "indexOptions"
884 ("options", Env.list autoindex_option)
885 (fn opts =>
886 case opts of
887 [] => ()
888 | _ => (write "\tIndexOptions";
889 app (fn (opt, arg) =>
890 (write " ";
891 write opt;
892 Option.app (fn arg =>
893 (write "="; write arg)) arg)) opts;
894 write "\n"))
895
896val () = Env.action_one "set_indexOptions"
897 ("options", Env.list autoindex_option)
898 (fn opts =>
899 case opts of
900 [] => ()
901 | _ => (write "\tIndexOptions";
902 app (fn (opt, arg) =>
903 (write " +";
904 write opt;
905 Option.app (fn arg =>
906 (write "="; write arg)) arg)) opts;
907 write "\n"))
908
909val () = Env.action_one "unset_indexOptions"
910 ("options", Env.list autoindex_option)
911 (fn opts =>
912 case opts of
913 [] => ()
914 | _ => (write "\tIndexOptions";
915 app (fn (opt, _) =>
916 (write " -";
917 write opt)) opts;
918 write "\n"))
919
920val () = Env.action_one "headerName"
921 ("name", Env.string)
922 (fn name => (write "\tHeaderName ";
923 write name;
924 write "\n"))
925
926val () = Env.action_one "readmeName"
927 ("name", Env.string)
928 (fn name => (write "\tReadmeName ";
929 write name;
930 write "\n"))
931
eda33894
AC
932val () = Env.action_two "setEnv"
933 ("key", Env.string, "value", Env.string)
934 (fn (key, value) => (write "\tSetEnv \"";
935 write key;
936 write "\" \"";
ca6ffb3f
AC
937 write (String.translate (fn #"\"" => "\\\""
938 | ch => str ch) value);
eda33894
AC
939 write "\"\n"))
940
71420f8b
AC
941val () = Domain.registerResetLocal (fn () =>
942 ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*")))
943
41c58daf
AC
944val () = Domain.registerDescriber (Domain.considerAll
945 [Domain.Extension {extension = "vhost",
d936cf4d 946 heading = fn host => "Web vhost " ^ host ^ ":"},
41c58daf 947 Domain.Extension {extension = "vhost_ssl",
d936cf4d 948 heading = fn host => "SSL web vhost " ^ host ^ ":"}])
41c58daf 949
8a7c40fa 950end