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