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