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