HCoop / hcoop / domtool2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Output suPHP_UserGroup
[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 ");
d5601036
AC		 522 TextIO.output (file, user);
523 TextIO.output (file, " ");
524 TextIO.output (file, group);
525 TextIO.output (file, "\n\tsuPHP_UserGroup ");
3f84c976 526 TextIO.output (file, user);
57e066bb
AC		 527 TextIO.output (file, " ");
528 TextIO.output (file, group))
529 else
530 ();
531
532 if isWaklog node then
533 (TextIO.output (file, "\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
534 TextIO.output (file, user);
535 TextIO.output (file, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
536 TextIO.output (file, user))
537 else
538 ();
539
540 TextIO.output (file, "\n\tDAVLockDB /var/lock/apache2/dav/");
541 TextIO.output (file, user);
542 TextIO.output (file, "/DAVLock");
543
e7482df3
AC		 544 if php <> Config.Apache.defaultPhpVersion then
545 (TextIO.output (file, "\n\tAddHandler x-httpd-php");
546 TextIO.output (file, Int.toString php);
547 TextIO.output (file, " .php .phtml"))
548 else
549 ();
550
57e066bb
AC		 551 (ld, file)
552 end)
553 places;
554 write "\n\tDocumentRoot ";
555 write docroot;
556 write "\n\tServerAdmin ";
557 write sadmin;
558 case ssl of
559 SOME cert =>
560 (write "\n\tSSLEngine on\n\tSSLCertificateFile ";
561 write cert)
562 | NONE => ();
563 write "\n";
564 !pre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
565 app (fn dom => !aliaser (makeFullHost dom)) (Domain.currentAliasDomains ())
566 end
3f84c976 567
57e066bb
AC		 568val () = Env.containerV_one "vhost"
569 ("host", Env.string)
570 (fn (env, host) => vhostBody (env, fn dom => host ^ "." ^ dom),
571 vhostPost)
572
573val () = Env.containerV_none "vhostDefault"
574 (fn env => vhostBody (env, fn dom => dom),
575 vhostPost)
8a7c40fa 576
ce01b51a
AC		 577val inLocal = ref false
578
2882ee37
AC		 579val () = Env.container_one "location"
580 ("prefix", Env.string)
581 (fn prefix =>
582 (write "\t<Location ";
583 write prefix;
ce01b51a
AC		 584 write ">\n";
585 inLocal := true),
586 fn () => (write "\t</Location>\n";
587 inLocal := false;
588 localRewriteEnabled := false))
2882ee37
AC		 589
590val () = Env.container_one "directory"
591 ("directory", Env.string)
592 (fn directory =>
593 (write "\t<Directory ";
594 write directory;
ce01b51a
AC		 595 write ">\n";
596 inLocal := true),
597 fn () => (write "\t</Directory>\n";
598 inLocal := false;
599 localRewriteEnabled := false))
2882ee37 600
767fe695
AC		 601val () = Env.container_one "filesMatch"
602 ("regexp", Env.string)
603 (fn prefix =>
604 (write "\t<FilesMatch \"";
605 write prefix;
606 write "\">\n"),
607 fn () => (write "\t</FilesMatch>\n";
608 localRewriteEnabled := false))
609
f8dfbbcc 610fun checkRewrite () =
ce01b51a 611 if !inLocal then
cf283351 612 if !localRewriteEnabled then
ce01b51a
AC		 613 ()
614 else
615 (write "\tRewriteEngine on\n";
616 localRewriteEnabled := true)
617 else if !rewriteEnabled then
f8dfbbcc
AC		 618 ()
619 else
620 (write "\tRewriteEngine on\n";
621 rewriteEnabled := true)
622
623val () = Env.action_three "localProxyRewrite"
624 ("from", Env.string, "to", Env.string, "port", Env.int)
625 (fn (from, to, port) =>
626 (checkRewrite ();
06bd8215 627 write "\tRewriteRule\t\"";
f8dfbbcc 628 write from;
06bd8215 629 write "\"\thttp://localhost:";
f8dfbbcc
AC		 630 write (Int.toString port);
631 write "/";
632 write to;
633 write " [P]\n"))
634
e95a129e
AC		 635val () = Env.action_two "proxyPass"
636 ("from", Env.string, "to", Env.string)
637 (fn (from, to) =>
638 (write "\tProxyPass\t";
639 write from;
640 write "\t";
641 write to;
642 write "\n"))
643
644val () = Env.action_two "proxyPassReverse"
645 ("from", Env.string, "to", Env.string)
646 (fn (from, to) =>
647 (write "\tProxyPassReverse\t";
648 write from;
649 write "\t";
650 write to;
651 write "\n"))
f8dfbbcc
AC		 652
653val () = Env.action_three "rewriteRule"
654 ("from", Env.string, "to", Env.string, "flags", Env.list flag)
655 (fn (from, to, flags) =>
656 (checkRewrite ();
06bd8215 657 write "\tRewriteRule\t\"";
f8dfbbcc 658 write from;
06bd8215 659 write "\"\t\"";
f8dfbbcc 660 write to;
06bd8215 661 write "\"";
f8dfbbcc
AC		 662 case flags of
663 [] => ()
664 | flag::rest => (write " [";
665 write flag;
666 app (fn flag => (write ",";
667 write flag)) rest;
668 write "]");
669 write "\n"))
670
e95a129e
AC		 671val () = Env.action_three "rewriteCond"
672 ("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
673 (fn (from, to, flags) =>
674 (checkRewrite ();
06bd8215 675 write "\tRewriteCond\t\"";
e95a129e 676 write from;
06bd8215 677 write "\"\t\"";
e95a129e 678 write to;
06bd8215 679 write "\"";
e95a129e
AC		 680 case flags of
681 [] => ()
682 | flag::rest => (write " [";
683 write flag;
684 app (fn flag => (write ",";
685 write flag)) rest;
686 write "]");
687 write "\n"))
688
94b7b11a
AC		 689val () = Env.action_one "rewriteBase"
690 ("prefix", Env.string)
691 (fn prefix =>
692 (checkRewrite ();
06bd8215 693 write "\tRewriteBase\t\"";
94b7b11a 694 write prefix;
06bd8215 695 write "\"\n"))
94b7b11a 696
c98b57cf
AC		 697val () = Env.action_one "rewriteLogLevel"
698 ("level", Env.int)
699 (fn level =>
700 (checkRewrite ();
701 write "\tRewriteLog ";
7a2b27f0 702 write' (fn x => x);
c98b57cf
AC		 703 write "/rewrite.log\n\tRewriteLogLevel ";
704 write (Int.toString level);
705 write "\n"))
706
d5754b53
AC		 707val () = Env.action_two "alias"
708 ("from", Env.string, "to", Env.string)
709 (fn (from, to) =>
710 (write "\tAlias\t";
711 write from;
712 write " ";
713 write to;
714 write "\n"))
715
716val () = Env.action_two "scriptAlias"
717 ("from", Env.string, "to", Env.string)
718 (fn (from, to) =>
719 (write "\tScriptAlias\t";
720 write from;
721 write " ";
722 write to;
723 write "\n"))
724
725val () = Env.action_two "errorDocument"
726 ("code", Env.string, "handler", Env.string)
727 (fn (code, handler) =>
989965b1
AC		 728 let
729 val hasSpaces = CharVector.exists Char.isSpace handler
d5754b53 730
989965b1
AC		 731 fun maybeQuote () =
732 if hasSpaces then
733 write "\""
734 else
735 ()
736 in
737 write "\tErrorDocument\t";
738 write code;
739 write " ";
740 maybeQuote ();
741 write handler;
742 maybeQuote ();
743 write "\n"
744 end)
745
d441e69f
AC		 746val () = Env.action_one "options"
747 ("options", Env.list apache_option)
748 (fn opts =>
749 case opts of
750 [] => ()
751 | _ => (write "\tOptions";
752 app (fn opt => (write " "; write opt)) opts;
753 write "\n"))
754
755val () = Env.action_one "set_options"
756 ("options", Env.list apache_option)
757 (fn opts =>
758 case opts of
759 [] => ()
760 | _ => (write "\tOptions";
761 app (fn opt => (write " +"; write opt)) opts;
762 write "\n"))
763
764val () = Env.action_one "unset_options"
765 ("options", Env.list apache_option)
766 (fn opts =>
767 case opts of
768 [] => ()
769 | _ => (write "\tOptions";
770 app (fn opt => (write " -"; write opt)) opts;
771 write "\n"))
d5754b53 772
781ebc11
AC		 773val () = Env.action_one "cgiExtension"
774 ("extension", Env.string)
775 (fn ext => (write "\tAddHandler cgi-script ";
776 write ext;
777 write "\n"))
778
edd38024
AC		 779val () = Env.action_one "directoryIndex"
780 ("filenames", Env.list Env.string)
781 (fn opts =>
782 (write "\tDirectoryIndex";
783 app (fn opt => (write " "; write opt)) opts;
784 write "\n"))
785
e519d696 786val () = Env.action_one "serverAliasHost"
edd38024
AC		 787 ("host", Env.string)
788 (fn host =>
789 (write "\tServerAlias ";
790 write host;
7f75d838
AC		 791 write "\n";
792 !aliaser host))
edd38024 793
e519d696
AC		 794val () = Env.action_one "serverAlias"
795 ("host", Env.string)
796 (fn host =>
797 (app
798 (fn dom =>
799 let
800 val full = host ^ "." ^ dom
801 in
802 write "\tServerAlias ";
803 write full;
804 write "\n";
805 !aliaser full
806 end)
807 (Domain.currentDomains ())))
808
809val () = Env.action_none "serverAliasDefault"
810 (fn () =>
811 (app
812 (fn dom =>
813 (write "\tServerAlias ";
814 write dom;
815 write "\n";
816 !aliaser dom))
817 (Domain.currentDomains ())))
818
2aeb9eec
AC		 819val authType = fn (EVar "basic", _) => SOME "basic"
820 | (EVar "digest", _) => SOME "digest"
35dc7746 821 | (EVar "kerberos", _) => SOME "kerberos"
2aeb9eec
AC		 822 | _ => NONE
823
8a5b34c9
AC		 824fun allowAuthType "kerberos" = !sslEnabled
825 | allowAuthType _ = true
826
2aeb9eec
AC		 827val () = Env.action_one "authType"
828 ("type", authType)
829 (fn ty =>
8a5b34c9
AC		 830 if allowAuthType ty then
831 (write "\tAuthType ";
832 write ty;
833 write "\n";
834 case ty of
835 "kerberos" =>
836 write "\tKrbMethodNegotiate off\n\tKrbMethodK5Passwd on\n\tKrbVerifyKDC off\n\tKrbAuthRealms HCOOP.NET\n\tKrbSaveCredentials on\n"
837 | _ => ())
838 else
839 print "WARNING: Skipped Kerberos authType because this isn't an SSL vhost.\n")
2aeb9eec
AC		 840
841val () = Env.action_one "authName"
842 ("name", Env.string)
843 (fn name =>
844 (write "\tAuthName \"";
845 write name;
846 write "\"\n"))
847
848val () = Env.action_one "authUserFile"
849 ("file", Env.string)
850 (fn name =>
851 (write "\tAuthUserFile ";
852 write name;
853 write "\n"))
854
855val () = Env.action_none "requireValidUser"
856 (fn () => write "\tRequire valid-user\n")
857
858val () = Env.action_one "requireUser"
859 ("users", Env.list Env.string)
860 (fn names =>
861 case names of
862 [] => ()
863 | _ => (write "\tRequire user";
864 app (fn name => (write " "; write name)) names;
865 write "\n"))
866
867val () = Env.action_one "requireGroup"
868 ("groups", Env.list Env.string)
869 (fn names =>
870 case names of
871 [] => ()
872 | _ => (write "\tRequire group";
873 app (fn name => (write " "; write name)) names;
874 write "\n"))
875
876val () = Env.action_none "orderAllowDeny"
877 (fn () => write "\tOrder allow,deny\n")
878
879val () = Env.action_none "orderDenyAllow"
880 (fn () => write "\tOrder deny,allow\n")
881
882val () = Env.action_none "allowFromAll"
883 (fn () => write "\tAllow from all\n")
884
885val () = Env.action_one "allowFrom"
886 ("entries", Env.list Env.string)
887 (fn names =>
888 case names of
889 [] => ()
890 | _ => (write "\tAllow from";
891 app (fn name => (write " "; write name)) names;
892 write "\n"))
893
894val () = Env.action_none "denyFromAll"
895 (fn () => write "\tDeny from all\n")
896
897val () = Env.action_one "denyFrom"
898 ("entries", Env.list Env.string)
899 (fn names =>
900 case names of
901 [] => ()
902 | _ => (write "\tDeny from";
903 app (fn name => (write " "; write name)) names;
904 write "\n"))
905
906val () = Env.action_none "satisfyAll"
907 (fn () => write "\tSatisfy all\n")
908
909val () = Env.action_none "satisfyAny"
910 (fn () => write "\tSatisfy any\n")
911
7f012ffd
AC		 912val () = Env.action_one "forceType"
913 ("type", Env.string)
914 (fn ty => (write "\tForceType ";
915 write ty;
916 write "\n"))
917
918val () = Env.action_none "forceTypeOff"
919 (fn () => write "\tForceType None\n")
920
921val () = Env.action_two "action"
922 ("what", Env.string, "how", Env.string)
923 (fn (what, how) => (write "\tAction ";
924 write what;
925 write " ";
926 write how;
927 write "\n"))
928
929val () = Env.action_one "addDefaultCharset"
930 ("charset", Env.string)
931 (fn ty => (write "\tAddDefaultCharset ";
932 write ty;
933 write "\n"))
934
64e85bae 935(*val () = Env.action_one "davSvn"
c8505e59
AC		 936 ("path", Env.string)
937 (fn path => (write "\tDAV svn\n\tSVNPath ";
938 write path;
939 write "\n"))
940
941val () = Env.action_one "authzSvnAccessFile"
942 ("path", Env.string)
943 (fn path => (write "\tAuthzSVNAccessFile ";
944 write path;
64e85bae 945 write "\n"))*)
c8505e59 946
0aed4302
AC		 947val () = Env.action_none "davFilesystem"
948 (fn path => write "\tDAV filesystem\n")
949
9d7fa346
AC		 950val () = Env.action_two "addDescription"
951 ("description", Env.string, "patterns", Env.list Env.string)
952 (fn (desc, pats) =>
953 case pats of
954 [] => ()
955 | _ => (write "\tAddDescription \"";
956 write (String.toString desc);
957 write "\"";
958 app (fn pat => (write " "; write pat)) pats;
959 write "\n"))
960
1817ed97
AC		 961val () = Env.action_two "addIcon"
962 ("icon", Env.string, "patterns", Env.list Env.string)
963 (fn (icon, pats) =>
964 case pats of
965 [] => ()
966 | _ => (write "\tAddIcon \"";
967 write icon;
968 write "\"";
969 app (fn pat => (write " "; write pat)) pats;
970 write "\n"))
971
9d7fa346
AC		 972val () = Env.action_one "indexOptions"
973 ("options", Env.list autoindex_option)
974 (fn opts =>
975 case opts of
976 [] => ()
977 | _ => (write "\tIndexOptions";
978 app (fn (opt, arg) =>
979 (write " ";
980 write opt;
981 Option.app (fn arg =>
982 (write "="; write arg)) arg)) opts;
983 write "\n"))
984
1817ed97
AC		 985val () = Env.action_one "indexIgnore"
986 ("patterns", Env.list Env.string)
987 (fn pats =>
988 case pats of
989 [] => ()
990 | _ => (write "\tIndexIgnore";
991 app (fn pat => (write " "; write pat)) pats;
992 write "\n"))
993
9d7fa346
AC		 994val () = Env.action_one "set_indexOptions"
995 ("options", Env.list autoindex_option)
996 (fn opts =>
997 case opts of
998 [] => ()
999 | _ => (write "\tIndexOptions";
1000 app (fn (opt, arg) =>
1001 (write " +";
1002 write opt;
1003 Option.app (fn arg =>
1004 (write "="; write arg)) arg)) opts;
1005 write "\n"))
1006
1007val () = Env.action_one "unset_indexOptions"
1008 ("options", Env.list autoindex_option)
1009 (fn opts =>
1010 case opts of
1011 [] => ()
1012 | _ => (write "\tIndexOptions";
1013 app (fn (opt, _) =>
1014 (write " -";
1015 write opt)) opts;
1016 write "\n"))
1017
1018val () = Env.action_one "headerName"
1019 ("name", Env.string)
1020 (fn name => (write "\tHeaderName ";
1021 write name;
1022 write "\n"))
1023
1024val () = Env.action_one "readmeName"
1025 ("name", Env.string)
1026 (fn name => (write "\tReadmeName ";
1027 write name;
1028 write "\n"))
1029
eda33894
AC		 1030val () = Env.action_two "setEnv"
1031 ("key", Env.string, "value", Env.string)
1032 (fn (key, value) => (write "\tSetEnv \"";
1033 write key;
1034 write "\" \"";
ca6ffb3f
AC		 1035 write (String.translate (fn #"\"" => "\\\""
1036 | ch => str ch) value);
eda33894
AC		 1037 write "\"\n"))
1038
f0062360
AC		 1039val () = Env.action_one "diskCache"
1040 ("path", Env.string)
1041 (fn path => (write "\tCacheEnable disk \"";
1042 write path;
1043 write "\"\n"))
83bc6c45 1044
83bc6c45
AC		 1045val () = Env.action_one "phpVersion"
1046 ("version", php_version)
1047 (fn version => (write "\tAddHandler x-httpd-php";
1048 write (Int.toString version);
1049 write " .php .phtml\n"))
1050
bcf547ec
AC		 1051val () = Env.action_two "addType"
1052 ("mime type", Env.string, "extension", Env.string)
1053 (fn (mt, ext) => (write "\tAddType ";
1054 write mt;
1055 write " ";
1056 write ext;
1057 write "\n"))
1058
1059val filter = fn (EVar "includes", _) => SOME "INCLUDES"
1060 | (EVar "deflate", _) => SOME "DEFLATE"
1061 | _ => NONE
1062
1063val () = Env.action_two "addOutputFilter"
1064 ("filters", Env.list filter, "extensions", Env.list Env.string)
1065 (fn (f :: fs, exts as (_ :: _)) =>
1066 (write "\tAddOutputFilter ";
1067 write f;
1068 app (fn f => (write ";"; write f)) fs;
1069 app (fn ext => (write " "; write ext)) exts;
1070 write "\n")
1071 | _ => ())
1072
71420f8b
AC		 1073val () = Domain.registerResetLocal (fn () =>
1074 ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*")))
1075
41c58daf
AC		 1076val () = Domain.registerDescriber (Domain.considerAll
1077 [Domain.Extension {extension = "vhost",
d936cf4d 1078 heading = fn host => "Web vhost " ^ host ^ ":"},
41c58daf 1079 Domain.Extension {extension = "vhost_ssl",
d936cf4d 1080 heading = fn host => "SSL web vhost " ^ host ^ ":"}])
41c58daf 1081
ecc307a0
AC		 1082val () = Env.action_none "testNoHtaccess"
1083 (fn path => write "\tAllowOverride None\n")
1084
8a7c40fa 1085end
Unnamed repository; edit this file to name it for gitweb.