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