HCoop / hcoop / domtool2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fix firewall input rules, add ProxiedServer directive
[hcoop/domtool2.git] / src / plugins / apache.sml
CommitLineData
8a7c40fa 1(* HCoop Domtool (http://hcoop.sourceforge.net/)
fb09779a 2 * Copyright (c) 2006-2009, 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
fb09779a
AC		 244val interval_base = fn (EVar "access", _) => SOME "access"
245 | (EVar "modification", _) => SOME "modification"
246 | _ => NONE
247
248val interval = fn (EVar "years", _) => SOME "years"
249 | (EVar "months", _) => SOME "months"
250 | (EVar "weeks", _) => SOME "weeks"
251 | (EVar "days", _) => SOME "days"
252 | (EVar "hours", _) => SOME "hours"
253 | (EVar "minutes", _) => SOME "minutes"
254 | (EVar "seconds", _) => SOME "seconds"
255 | _ => NONE
256
8a7c40fa 257val vhostsChanged = ref false
8e965b2d 258val logDeleted = ref false
ffd50ec7 259val delayedLogMoves = ref (fn () => ())
8a7c40fa
AC		 260
261val () = Slave.registerPreHandler
8e965b2d 262 (fn () => (vhostsChanged := false;
ffd50ec7
AC		 263 logDeleted := false;
264 delayedLogMoves := (fn () => print "Executing delayed log moves/deletes.\n")))
8a7c40fa 265
7db53a0b
AC		 266fun findVhostUser fname =
267 let
268 val inf = TextIO.openIn fname
269
270 fun loop () =
271 case TextIO.inputLine inf of
272 NONE => NONE
273 | SOME line =>
00a13ad8
AC		 274 if String.isPrefix "# Owner: " line then
275 case String.tokens Char.isSpace line of
276 [_, _, user] => SOME user
277 | _ => NONE
278 else
279 loop ()
7db53a0b
AC		 280 in
281 loop ()
282 before TextIO.closeIn inf
3a941c29 283 end handle _ => NONE
7db53a0b 284
55d4a268
AC		 285val webNodes_full = Config.Apache.webNodes_all @ Config.Apache.webNodes_admin
286
287fun isVersion1 node =
f8ef6c20
AC		 288 List.exists (fn (n, {version = ConfigTypes.APACHE_1_3, ...}) => n = node
289 | _ => false) webNodes_full
55d4a268
AC		 290
291fun imVersion1 () = isVersion1 (Slave.hostname ())
292
f8ef6c20
AC		 293fun isWaklog node =
294 List.exists (fn (n, {auth = ConfigTypes.MOD_WAKLOG, ...}) => n = node
295 | _ => false) webNodes_full
296
55d4a268
AC		 297fun down () = if imVersion1 () then Config.Apache.down1 else Config.Apache.down
298fun undown () = if imVersion1 () then Config.Apache.undown1 else Config.Apache.undown
299fun reload () = if imVersion1 () then Config.Apache.reload1 else Config.Apache.reload
c17d0537 300fun fixperms () = if imVersion1 () then Config.Apache.fixperms1 else Config.Apache.fixperms
55d4a268 301
b59d9074 302fun logDir {user, node, vhostId} =
2a7d2818 303 String.concat [Config.Apache.logDirOf (isVersion1 node) user,
409542d7 304 "/",
b59d9074
AC		 305 node,
306 "/",
307 vhostId]
308
f086616f
AC		 309fun realLogDir {user, node, vhostId} =
310 String.concat [Config.Apache.realLogDirOf user,
311 "/",
312 node,
313 "/",
314 vhostId]
315
8a7c40fa 316val () = Slave.registerFileHandler (fn fs =>
7a2b27f0
AC		 317 let
318 val spl = OS.Path.splitDirFile (#file fs)
319 in
320 if String.isSuffix ".vhost" (#file spl)
3a941c29
AC		 321 orelse String.isSuffix ".vhost_ssl" (#file spl) then let
322 val realVhostFile = OS.Path.joinDirFile
323 {dir = Config.Apache.confDir,
324 file = #file spl}
325
326 val user = findVhostUser (#file fs)
19026493
AC		 327 val oldUser = case #action fs of
328 Slave.Delete false => user
329 | _ => findVhostUser realVhostFile
3a941c29
AC		 330 in
331 if (oldUser = NONE andalso #action fs <> Slave.Add)
1638d5a2 332 orelse (user = NONE andalso not (Slave.isDelete (#action fs))) then
3a941c29
AC		 333 print ("Can't find user in " ^ #file fs ^ " or " ^ realVhostFile ^ "! Taking no action.\n")
334 else
335 let
5b07cebd 336 val vhostId = if OS.Path.ext (#file spl) = SOME "vhost_ssl" then
b59d9074
AC		 337 OS.Path.base (#file spl) ^ ".ssl"
338 else
339 OS.Path.base (#file spl)
340
3a941c29 341 fun realLogDir user =
b59d9074
AC		 342 logDir {user = valOf user,
343 node = Slave.hostname (),
344 vhostId = vhostId}
c17d0537
AC		 345
346 fun backupLogs () =
347 OS.Path.joinDirFile
348 {dir = Config.Apache.backupLogDirOf
349 (isVersion1 (Slave.hostname ())),
350 file = vhostId}
3a941c29
AC		 351 in
352 vhostsChanged := true;
353 case #action fs of
1638d5a2 354 Slave.Delete _ =>
31b50af0
AC		 355 let
356 val ldir = realLogDir oldUser
ffd50ec7 357 val dlm = !delayedLogMoves
31b50af0
AC		 358 in
359 if !logDeleted then
360 ()
361 else
ffd50ec7 362 ((*ignore (OS.Process.system (down ()));*)
c17d0537 363 ignore (OS.Process.system (fixperms ()));
31b50af0
AC		 364 logDeleted := true);
365 ignore (OS.Process.system (Config.rm
366 ^ " -rf "
367 ^ realVhostFile));
ffd50ec7
AC		 368 delayedLogMoves := (fn () => (dlm ();
369 Slave.moveDirCreate {from = ldir,
370 to = backupLogs ()}))
31b50af0 371 end
3a941c29
AC		 372 | Slave.Add =>
373 let
374 val rld = realLogDir user
375 in
376 ignore (OS.Process.system (Config.cp
377 ^ " "
378 ^ #file fs
379 ^ " "
380 ^ realVhostFile));
381 if Posix.FileSys.access (rld, []) then
382 ()
383 else
c17d0537 384 Slave.moveDirCreate {from = backupLogs (),
31b50af0 385 to = rld}
3a941c29
AC		 386 end
387
388 | _ =>
389 (ignore (OS.Process.system (Config.cp
390 ^ " "
391 ^ #file fs
392 ^ " "
393 ^ realVhostFile));
394 if user <> oldUser then
395 let
396 val old = realLogDir oldUser
397 val rld = realLogDir user
ffd50ec7
AC		 398
399 val dlm = !delayedLogMoves
3a941c29
AC		 400 in
401 if !logDeleted then
402 ()
403 else
ffd50ec7 404 ((*ignore (OS.Process.system (down ()));*)
3a941c29 405 logDeleted := true);
ffd50ec7
AC		 406 delayedLogMoves := (fn () => (dlm ();
407 ignore (OS.Process.system (Config.rm
408 ^ " -rf "
409 ^ realLogDir oldUser))));
3a941c29
AC		 410 if Posix.FileSys.access (rld, []) then
411 ()
412 else
409542d7 413 Slave.mkDirAll rld
3a941c29
AC		 414 end
415 else
416 ())
417 end
418 end
7a2b27f0
AC		 419 else
420 ()
421 end)
8a7c40fa
AC		 422
423val () = Slave.registerPostHandler
424 (fn () =>
425 (if !vhostsChanged then
ffd50ec7
AC		 426 (Slave.shellF ([reload ()],
427 fn cl => "Error reloading Apache with " ^ cl);
428 if !logDeleted then !delayedLogMoves () else ())
8a7c40fa
AC		 429 else
430 ()))
431
7a2b27f0
AC		 432val vhostFiles : (string * TextIO.outstream) list ref = ref []
433fun write' s = app (fn (node, file) => TextIO.output (file, s node)) (!vhostFiles)
434fun write s = app (fn (_, file) => TextIO.output (file, s)) (!vhostFiles)
8a7c40fa 435
f8dfbbcc 436val rewriteEnabled = ref false
ce01b51a 437val localRewriteEnabled = ref false
fb09779a
AC		 438val expiresEnabled = ref false
439val localExpiresEnabled = ref false
c98b57cf
AC		 440val currentVhost = ref ""
441val currentVhostId = ref ""
8a5b34c9 442val sslEnabled = ref false
f8dfbbcc 443
7a2b27f0 444val pre = ref (fn _ : {user : string, nodes : string list, id : string, hostname : string} => ())
7f75d838
AC		 445fun registerPre f =
446 let
447 val old = !pre
448 in
449 pre := (fn x => (old x; f x))
450 end
451
452val post = ref (fn () => ())
453fun registerPost f =
454 let
455 val old = !post
456 in
457 post := (fn () => (old (); f ()))
458 end
459
e9f528ab
AC		 460fun doPre x = !pre x
461fun doPost () = !post ()
462
7f75d838
AC		 463val aliaser = ref (fn _ : string => ())
464fun registerAliaser f =
465 let
466 val old = !aliaser
467 in
468 aliaser := (fn x => (old x; f x))
469 end
470
57e066bb
AC		 471fun vhostPost () = (!post ();
472 write "</VirtualHost>\n";
473 app (TextIO.closeOut o #2) (!vhostFiles))
2a7d2818 474
e7482df3
AC		 475val php_version = fn (EVar "php4", _) => SOME 4
476 | (EVar "php5", _) => SOME 5
477 | _ => NONE
478
57e066bb
AC		 479fun vhostBody (env, makeFullHost) =
480 let
481 val places = Env.env (Env.list webPlace) (env, "WebPlaces")
482
483 val ssl = Env.env ssl (env, "SSL")
484 val user = Env.env Env.string (env, "User")
485 val group = Env.env Env.string (env, "Group")
486 val docroot = Env.env Env.string (env, "DocumentRoot")
487 val sadmin = Env.env Env.string (env, "ServerAdmin")
488 val suexec = Env.env Env.bool (env, "SuExec")
e7482df3 489 val php = Env.env php_version (env, "PhpVersion")
57e066bb
AC		 490
491 val fullHost = makeFullHost (Domain.currentDomain ())
492 val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
493 val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
494 in
495 currentVhost := fullHost;
496 currentVhostId := vhostId;
497 sslEnabled := Option.isSome ssl;
498
499 rewriteEnabled := false;
500 localRewriteEnabled := false;
fb09779a
AC		 501 expiresEnabled := false;
502 localExpiresEnabled := false;
57e066bb
AC		 503 vhostFiles := map (fn (node, ip) =>
504 let
505 val file = Domain.domainFile {node = node,
506 name = confFile}
507
508 val ld = logDir {user = user, node = node, vhostId = vhostId}
509 in
510 TextIO.output (file, "# Owner: ");
511 TextIO.output (file, user);
512 TextIO.output (file, "\n<VirtualHost ");
513 TextIO.output (file, ip);
514 TextIO.output (file, ":");
515 TextIO.output (file, case ssl of
516 SOME _ => "443"
517 | NONE => "80");
518 TextIO.output (file, ">\n");
519 TextIO.output (file, "\tErrorLog ");
520 TextIO.output (file, ld);
521 TextIO.output (file, "/error.log\n\tCustomLog ");
522 TextIO.output (file, ld);
523 TextIO.output (file, "/access.log combined\n");
524 TextIO.output (file, "\tServerName ");
525 TextIO.output (file, fullHost);
526 app
527 (fn dom => (TextIO.output (file, "\n\tServerAlias ");
528 TextIO.output (file, makeFullHost dom)))
529 (Domain.currentAliasDomains ());
530
531 if suexec then
532 if isVersion1 node then
533 (TextIO.output (file, "\n\tUser ");
00a13ad8 534 TextIO.output (file, user);
57e066bb
AC		 535 TextIO.output (file, "\n\tGroup ");
536 TextIO.output (file, group))
537 else
538 (TextIO.output (file, "\n\tSuexecUserGroup ");
d5601036
AC		 539 TextIO.output (file, user);
540 TextIO.output (file, " ");
541 TextIO.output (file, group);
542 TextIO.output (file, "\n\tsuPHP_UserGroup ");
3f84c976 543 TextIO.output (file, user);
57e066bb
AC		 544 TextIO.output (file, " ");
545 TextIO.output (file, group))
546 else
547 ();
548
549 if isWaklog node then
550 (TextIO.output (file, "\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
551 TextIO.output (file, user);
552 TextIO.output (file, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
553 TextIO.output (file, user))
554 else
555 ();
556
557 TextIO.output (file, "\n\tDAVLockDB /var/lock/apache2/dav/");
558 TextIO.output (file, user);
559 TextIO.output (file, "/DAVLock");
560
e7482df3
AC		 561 if php <> Config.Apache.defaultPhpVersion then
562 (TextIO.output (file, "\n\tAddHandler x-httpd-php");
563 TextIO.output (file, Int.toString php);
564 TextIO.output (file, " .php .phtml"))
565 else
566 ();
567
57e066bb
AC		 568 (ld, file)
569 end)
570 places;
571 write "\n\tDocumentRoot ";
572 write docroot;
573 write "\n\tServerAdmin ";
574 write sadmin;
575 case ssl of
576 SOME cert =>
577 (write "\n\tSSLEngine on\n\tSSLCertificateFile ";
578 write cert)
579 | NONE => ();
580 write "\n";
581 !pre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
582 app (fn dom => !aliaser (makeFullHost dom)) (Domain.currentAliasDomains ())
583 end
3f84c976 584
57e066bb
AC		 585val () = Env.containerV_one "vhost"
586 ("host", Env.string)
587 (fn (env, host) => vhostBody (env, fn dom => host ^ "." ^ dom),
588 vhostPost)
589
590val () = Env.containerV_none "vhostDefault"
591 (fn env => vhostBody (env, fn dom => dom),
592 vhostPost)
8a7c40fa 593
ce01b51a
AC		 594val inLocal = ref false
595
2882ee37
AC		 596val () = Env.container_one "location"
597 ("prefix", Env.string)
598 (fn prefix =>
599 (write "\t<Location ";
600 write prefix;
ce01b51a
AC		 601 write ">\n";
602 inLocal := true),
603 fn () => (write "\t</Location>\n";
604 inLocal := false;
fb09779a
AC		 605 localRewriteEnabled := false;
606 localExpiresEnabled := false))
2882ee37
AC		 607
608val () = Env.container_one "directory"
609 ("directory", Env.string)
610 (fn directory =>
611 (write "\t<Directory ";
612 write directory;
ce01b51a
AC		 613 write ">\n";
614 inLocal := true),
615 fn () => (write "\t</Directory>\n";
616 inLocal := false;
fb09779a
AC		 617 localRewriteEnabled := false;
618 localExpiresEnabled := false))
2882ee37 619
767fe695
AC		 620val () = Env.container_one "filesMatch"
621 ("regexp", Env.string)
622 (fn prefix =>
623 (write "\t<FilesMatch \"";
624 write prefix;
625 write "\">\n"),
626 fn () => (write "\t</FilesMatch>\n";
fb09779a
AC		 627 localRewriteEnabled := false;
628 localExpiresEnabled := false))
767fe695 629
f8dfbbcc 630fun checkRewrite () =
ce01b51a 631 if !inLocal then
cf283351 632 if !localRewriteEnabled then
ce01b51a
AC		 633 ()
634 else
635 (write "\tRewriteEngine on\n";
636 localRewriteEnabled := true)
637 else if !rewriteEnabled then
f8dfbbcc
AC		 638 ()
639 else
640 (write "\tRewriteEngine on\n";
641 rewriteEnabled := true)
642
fb09779a
AC		 643fun checkExpires () =
644 if !inLocal then
645 if !localExpiresEnabled then
646 ()
647 else
648 (write "\tExpiresActive on\n";
649 localExpiresEnabled := true)
650 else if !expiresEnabled then
651 ()
652 else
653 (write "\tExpiresActive on\n";
654 expiresEnabled := true)
655
f8dfbbcc
AC		 656val () = Env.action_three "localProxyRewrite"
657 ("from", Env.string, "to", Env.string, "port", Env.int)
658 (fn (from, to, port) =>
659 (checkRewrite ();
06bd8215 660 write "\tRewriteRule\t\"";
f8dfbbcc 661 write from;
06bd8215 662 write "\"\thttp://localhost:";
f8dfbbcc
AC		 663 write (Int.toString port);
664 write "/";
665 write to;
666 write " [P]\n"))
667
fb09779a
AC		 668val () = Env.action_four "expiresByType"
669 ("mime", Env.string, "base", interval_base, "num", Env.int, "inter", interval)
670 (fn (mime, base, num, inter) =>
671 (checkExpires ();
672 write "\tExpiresByType\t\"";
673 write mime;
674 write "\"\t\"";
675 write base;
676 write " plus ";
677 if num < 0 then
678 (write "-";
679 write (Int.toString (~num)))
680 else
681 write (Int.toString num);
682 write " ";
683 write inter;
684 write "\"\n"))
685
e95a129e
AC		 686val () = Env.action_two "proxyPass"
687 ("from", Env.string, "to", Env.string)
688 (fn (from, to) =>
689 (write "\tProxyPass\t";
690 write from;
691 write "\t";
692 write to;
693 write "\n"))
694
695val () = Env.action_two "proxyPassReverse"
696 ("from", Env.string, "to", Env.string)
697 (fn (from, to) =>
698 (write "\tProxyPassReverse\t";
699 write from;
700 write "\t";
701 write to;
702 write "\n"))
f8dfbbcc
AC		 703
704val () = Env.action_three "rewriteRule"
705 ("from", Env.string, "to", Env.string, "flags", Env.list flag)
706 (fn (from, to, flags) =>
707 (checkRewrite ();
06bd8215 708 write "\tRewriteRule\t\"";
f8dfbbcc 709 write from;
06bd8215 710 write "\"\t\"";
f8dfbbcc 711 write to;
06bd8215 712 write "\"";
f8dfbbcc
AC		 713 case flags of
714 [] => ()
715 | flag::rest => (write " [";
716 write flag;
717 app (fn flag => (write ",";
718 write flag)) rest;
719 write "]");
720 write "\n"))
721
e95a129e
AC		 722val () = Env.action_three "rewriteCond"
723 ("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
724 (fn (from, to, flags) =>
725 (checkRewrite ();
06bd8215 726 write "\tRewriteCond\t\"";
e95a129e 727 write from;
06bd8215 728 write "\"\t\"";
e95a129e 729 write to;
06bd8215 730 write "\"";
e95a129e
AC		 731 case flags of
732 [] => ()
733 | flag::rest => (write " [";
734 write flag;
735 app (fn flag => (write ",";
736 write flag)) rest;
737 write "]");
738 write "\n"))
739
94b7b11a
AC		 740val () = Env.action_one "rewriteBase"
741 ("prefix", Env.string)
742 (fn prefix =>
743 (checkRewrite ();
06bd8215 744 write "\tRewriteBase\t\"";
94b7b11a 745 write prefix;
06bd8215 746 write "\"\n"))
94b7b11a 747
c98b57cf
AC		 748val () = Env.action_one "rewriteLogLevel"
749 ("level", Env.int)
750 (fn level =>
751 (checkRewrite ();
752 write "\tRewriteLog ";
7a2b27f0 753 write' (fn x => x);
c98b57cf
AC		 754 write "/rewrite.log\n\tRewriteLogLevel ";
755 write (Int.toString level);
756 write "\n"))
757
d5754b53
AC		 758val () = Env.action_two "alias"
759 ("from", Env.string, "to", Env.string)
760 (fn (from, to) =>
761 (write "\tAlias\t";
762 write from;
763 write " ";
764 write to;
765 write "\n"))
766
767val () = Env.action_two "scriptAlias"
768 ("from", Env.string, "to", Env.string)
769 (fn (from, to) =>
770 (write "\tScriptAlias\t";
771 write from;
772 write " ";
773 write to;
774 write "\n"))
775
776val () = Env.action_two "errorDocument"
777 ("code", Env.string, "handler", Env.string)
778 (fn (code, handler) =>
989965b1
AC		 779 let
780 val hasSpaces = CharVector.exists Char.isSpace handler
d5754b53 781
989965b1
AC		 782 fun maybeQuote () =
783 if hasSpaces then
784 write "\""
785 else
786 ()
787 in
788 write "\tErrorDocument\t";
789 write code;
790 write " ";
791 maybeQuote ();
792 write handler;
793 maybeQuote ();
794 write "\n"
795 end)
796
d441e69f
AC		 797val () = Env.action_one "options"
798 ("options", Env.list apache_option)
799 (fn opts =>
800 case opts of
801 [] => ()
802 | _ => (write "\tOptions";
803 app (fn opt => (write " "; write opt)) opts;
804 write "\n"))
805
806val () = Env.action_one "set_options"
807 ("options", Env.list apache_option)
808 (fn opts =>
809 case opts of
810 [] => ()
811 | _ => (write "\tOptions";
812 app (fn opt => (write " +"; write opt)) opts;
813 write "\n"))
814
815val () = Env.action_one "unset_options"
816 ("options", Env.list apache_option)
817 (fn opts =>
818 case opts of
819 [] => ()
820 | _ => (write "\tOptions";
821 app (fn opt => (write " -"; write opt)) opts;
822 write "\n"))
d5754b53 823
781ebc11
AC		 824val () = Env.action_one "cgiExtension"
825 ("extension", Env.string)
826 (fn ext => (write "\tAddHandler cgi-script ";
827 write ext;
828 write "\n"))
829
edd38024
AC		 830val () = Env.action_one "directoryIndex"
831 ("filenames", Env.list Env.string)
832 (fn opts =>
833 (write "\tDirectoryIndex";
834 app (fn opt => (write " "; write opt)) opts;
835 write "\n"))
836
e519d696 837val () = Env.action_one "serverAliasHost"
edd38024
AC		 838 ("host", Env.string)
839 (fn host =>
840 (write "\tServerAlias ";
841 write host;
7f75d838
AC		 842 write "\n";
843 !aliaser host))
edd38024 844
e519d696
AC		 845val () = Env.action_one "serverAlias"
846 ("host", Env.string)
847 (fn host =>
848 (app
849 (fn dom =>
850 let
851 val full = host ^ "." ^ dom
852 in
853 write "\tServerAlias ";
854 write full;
855 write "\n";
856 !aliaser full
857 end)
858 (Domain.currentDomains ())))
859
860val () = Env.action_none "serverAliasDefault"
861 (fn () =>
862 (app
863 (fn dom =>
864 (write "\tServerAlias ";
865 write dom;
866 write "\n";
867 !aliaser dom))
868 (Domain.currentDomains ())))
869
2aeb9eec
AC		 870val authType = fn (EVar "basic", _) => SOME "basic"
871 | (EVar "digest", _) => SOME "digest"
35dc7746 872 | (EVar "kerberos", _) => SOME "kerberos"
2aeb9eec
AC		 873 | _ => NONE
874
8a5b34c9
AC		 875fun allowAuthType "kerberos" = !sslEnabled
876 | allowAuthType _ = true
877
2aeb9eec
AC		 878val () = Env.action_one "authType"
879 ("type", authType)
880 (fn ty =>
8a5b34c9
AC		 881 if allowAuthType ty then
882 (write "\tAuthType ";
883 write ty;
884 write "\n";
885 case ty of
886 "kerberos" =>
887 write "\tKrbMethodNegotiate off\n\tKrbMethodK5Passwd on\n\tKrbVerifyKDC off\n\tKrbAuthRealms HCOOP.NET\n\tKrbSaveCredentials on\n"
888 | _ => ())
889 else
890 print "WARNING: Skipped Kerberos authType because this isn't an SSL vhost.\n")
2aeb9eec
AC		 891
892val () = Env.action_one "authName"
893 ("name", Env.string)
894 (fn name =>
895 (write "\tAuthName \"";
896 write name;
897 write "\"\n"))
898
899val () = Env.action_one "authUserFile"
900 ("file", Env.string)
901 (fn name =>
902 (write "\tAuthUserFile ";
903 write name;
904 write "\n"))
905
906val () = Env.action_none "requireValidUser"
907 (fn () => write "\tRequire valid-user\n")
908
909val () = Env.action_one "requireUser"
910 ("users", Env.list Env.string)
911 (fn names =>
912 case names of
913 [] => ()
914 | _ => (write "\tRequire user";
915 app (fn name => (write " "; write name)) names;
916 write "\n"))
917
918val () = Env.action_one "requireGroup"
919 ("groups", Env.list Env.string)
920 (fn names =>
921 case names of
922 [] => ()
923 | _ => (write "\tRequire group";
924 app (fn name => (write " "; write name)) names;
925 write "\n"))
926
927val () = Env.action_none "orderAllowDeny"
928 (fn () => write "\tOrder allow,deny\n")
929
930val () = Env.action_none "orderDenyAllow"
931 (fn () => write "\tOrder deny,allow\n")
932
933val () = Env.action_none "allowFromAll"
934 (fn () => write "\tAllow from all\n")
935
936val () = Env.action_one "allowFrom"
937 ("entries", Env.list Env.string)
938 (fn names =>
939 case names of
940 [] => ()
941 | _ => (write "\tAllow from";
942 app (fn name => (write " "; write name)) names;
943 write "\n"))
944
945val () = Env.action_none "denyFromAll"
946 (fn () => write "\tDeny from all\n")
947
948val () = Env.action_one "denyFrom"
949 ("entries", Env.list Env.string)
950 (fn names =>
951 case names of
952 [] => ()
953 | _ => (write "\tDeny from";
954 app (fn name => (write " "; write name)) names;
955 write "\n"))
956
957val () = Env.action_none "satisfyAll"
958 (fn () => write "\tSatisfy all\n")
959
960val () = Env.action_none "satisfyAny"
961 (fn () => write "\tSatisfy any\n")
962
7f012ffd
AC		 963val () = Env.action_one "forceType"
964 ("type", Env.string)
965 (fn ty => (write "\tForceType ";
966 write ty;
967 write "\n"))
968
969val () = Env.action_none "forceTypeOff"
970 (fn () => write "\tForceType None\n")
971
972val () = Env.action_two "action"
973 ("what", Env.string, "how", Env.string)
974 (fn (what, how) => (write "\tAction ";
975 write what;
976 write " ";
977 write how;
978 write "\n"))
979
980val () = Env.action_one "addDefaultCharset"
981 ("charset", Env.string)
982 (fn ty => (write "\tAddDefaultCharset ";
983 write ty;
984 write "\n"))
985
64e85bae 986(*val () = Env.action_one "davSvn"
c8505e59
AC		 987 ("path", Env.string)
988 (fn path => (write "\tDAV svn\n\tSVNPath ";
989 write path;
990 write "\n"))
991
992val () = Env.action_one "authzSvnAccessFile"
993 ("path", Env.string)
994 (fn path => (write "\tAuthzSVNAccessFile ";
995 write path;
64e85bae 996 write "\n"))*)
c8505e59 997
0aed4302
AC		 998val () = Env.action_none "davFilesystem"
999 (fn path => write "\tDAV filesystem\n")
1000
9d7fa346
AC		 1001val () = Env.action_two "addDescription"
1002 ("description", Env.string, "patterns", Env.list Env.string)
1003 (fn (desc, pats) =>
1004 case pats of
1005 [] => ()
1006 | _ => (write "\tAddDescription \"";
1007 write (String.toString desc);
1008 write "\"";
1009 app (fn pat => (write " "; write pat)) pats;
1010 write "\n"))
1011
1817ed97
AC		 1012val () = Env.action_two "addIcon"
1013 ("icon", Env.string, "patterns", Env.list Env.string)
1014 (fn (icon, pats) =>
1015 case pats of
1016 [] => ()
1017 | _ => (write "\tAddIcon \"";
1018 write icon;
1019 write "\"";
1020 app (fn pat => (write " "; write pat)) pats;
1021 write "\n"))
1022
9d7fa346
AC		 1023val () = Env.action_one "indexOptions"
1024 ("options", Env.list autoindex_option)
1025 (fn opts =>
1026 case opts of
1027 [] => ()
1028 | _ => (write "\tIndexOptions";
1029 app (fn (opt, arg) =>
1030 (write " ";
1031 write opt;
1032 Option.app (fn arg =>
1033 (write "="; write arg)) arg)) opts;
1034 write "\n"))
1035
1817ed97
AC		 1036val () = Env.action_one "indexIgnore"
1037 ("patterns", Env.list Env.string)
1038 (fn pats =>
1039 case pats of
1040 [] => ()
1041 | _ => (write "\tIndexIgnore";
1042 app (fn pat => (write " "; write pat)) pats;
1043 write "\n"))
1044
9d7fa346
AC		 1045val () = Env.action_one "set_indexOptions"
1046 ("options", Env.list autoindex_option)
1047 (fn opts =>
1048 case opts of
1049 [] => ()
1050 | _ => (write "\tIndexOptions";
1051 app (fn (opt, arg) =>
1052 (write " +";
1053 write opt;
1054 Option.app (fn arg =>
1055 (write "="; write arg)) arg)) opts;
1056 write "\n"))
1057
1058val () = Env.action_one "unset_indexOptions"
1059 ("options", Env.list autoindex_option)
1060 (fn opts =>
1061 case opts of
1062 [] => ()
1063 | _ => (write "\tIndexOptions";
1064 app (fn (opt, _) =>
1065 (write " -";
1066 write opt)) opts;
1067 write "\n"))
1068
1069val () = Env.action_one "headerName"
1070 ("name", Env.string)
1071 (fn name => (write "\tHeaderName ";
1072 write name;
1073 write "\n"))
1074
1075val () = Env.action_one "readmeName"
1076 ("name", Env.string)
1077 (fn name => (write "\tReadmeName ";
1078 write name;
1079 write "\n"))
1080
eda33894
AC		 1081val () = Env.action_two "setEnv"
1082 ("key", Env.string, "value", Env.string)
1083 (fn (key, value) => (write "\tSetEnv \"";
1084 write key;
1085 write "\" \"";
ca6ffb3f
AC		 1086 write (String.translate (fn #"\"" => "\\\""
1087 | ch => str ch) value);
eda33894
AC		 1088 write "\"\n"))
1089
f0062360
AC		 1090val () = Env.action_one "diskCache"
1091 ("path", Env.string)
1092 (fn path => (write "\tCacheEnable disk \"";
1093 write path;
1094 write "\"\n"))
83bc6c45 1095
83bc6c45
AC		 1096val () = Env.action_one "phpVersion"
1097 ("version", php_version)
1098 (fn version => (write "\tAddHandler x-httpd-php";
1099 write (Int.toString version);
1100 write " .php .phtml\n"))
1101
bcf547ec
AC		 1102val () = Env.action_two "addType"
1103 ("mime type", Env.string, "extension", Env.string)
1104 (fn (mt, ext) => (write "\tAddType ";
1105 write mt;
1106 write " ";
1107 write ext;
1108 write "\n"))
1109
1110val filter = fn (EVar "includes", _) => SOME "INCLUDES"
1111 | (EVar "deflate", _) => SOME "DEFLATE"
1112 | _ => NONE
1113
1114val () = Env.action_two "addOutputFilter"
1115 ("filters", Env.list filter, "extensions", Env.list Env.string)
1116 (fn (f :: fs, exts as (_ :: _)) =>
1117 (write "\tAddOutputFilter ";
1118 write f;
1119 app (fn f => (write ";"; write f)) fs;
1120 app (fn ext => (write " "; write ext)) exts;
1121 write "\n")
1122 | _ => ())
1123
71420f8b
AC		 1124val () = Domain.registerResetLocal (fn () =>
1125 ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*")))
1126
41c58daf
AC		 1127val () = Domain.registerDescriber (Domain.considerAll
1128 [Domain.Extension {extension = "vhost",
d936cf4d 1129 heading = fn host => "Web vhost " ^ host ^ ":"},
41c58daf 1130 Domain.Extension {extension = "vhost_ssl",
d936cf4d 1131 heading = fn host => "SSL web vhost " ^ host ^ ":"}])
41c58daf 1132
ecc307a0
AC		 1133val () = Env.action_none "testNoHtaccess"
1134 (fn path => write "\tAllowOverride None\n")
1135
563e7792
AC		 1136fun writeWaklogUserFile () =
1137 let
1138 val users = Acl.users ()
1139 val outf = TextIO.openOut Config.Apache.waklogUserFile
1140 in
1141 app (fn user => if String.isSuffix "_admin" user then
1142 ()
1143 else
1144 (TextIO.output (outf, "<Location /~");
1145 TextIO.output (outf, user);
1146 TextIO.output (outf, ">\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
1147 TextIO.output (outf, user);
1148 TextIO.output (outf, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
1149 TextIO.output (outf, user);
1150 TextIO.output (outf, "\n</Location>\n\n"))) users;
1151 TextIO.closeOut outf
1152 end
1153
1154val () = Domain.registerOnUsersChange writeWaklogUserFile
1155
8a7c40fa 1156end
Unnamed repository; edit this file to name it for gitweb.