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