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