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