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