HCoop / hcoop / domtool2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
SSLCertificateChainFile 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
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),
170 (fn () => (EVar "php4", 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
e7482df3
AC		 489val php_version = fn (EVar "php4", _) => SOME 4
490 | (EVar "php5", _) => SOME 5
491 | _ => NONE
492
57e066bb
AC		 493fun vhostBody (env, makeFullHost) =
494 let
495 val places = Env.env (Env.list webPlace) (env, "WebPlaces")
496
497 val ssl = Env.env ssl (env, "SSL")
498 val user = Env.env Env.string (env, "User")
499 val group = Env.env Env.string (env, "Group")
500 val docroot = Env.env Env.string (env, "DocumentRoot")
501 val sadmin = Env.env Env.string (env, "ServerAdmin")
502 val suexec = Env.env Env.bool (env, "SuExec")
e7482df3 503 val php = Env.env php_version (env, "PhpVersion")
57e066bb
AC		 504
505 val fullHost = makeFullHost (Domain.currentDomain ())
506 val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
507 val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
508 in
509 currentVhost := fullHost;
510 currentVhostId := vhostId;
511 sslEnabled := Option.isSome ssl;
512
513 rewriteEnabled := false;
514 localRewriteEnabled := false;
fb09779a
AC		 515 expiresEnabled := false;
516 localExpiresEnabled := false;
57e066bb
AC		 517 vhostFiles := map (fn (node, ip) =>
518 let
519 val file = Domain.domainFile {node = node,
520 name = confFile}
521
522 val ld = logDir {user = user, node = node, vhostId = vhostId}
523 in
524 TextIO.output (file, "# Owner: ");
525 TextIO.output (file, user);
526 TextIO.output (file, "\n<VirtualHost ");
527 TextIO.output (file, ip);
528 TextIO.output (file, ":");
529 TextIO.output (file, case ssl of
530 SOME _ => "443"
531 | NONE => "80");
532 TextIO.output (file, ">\n");
533 TextIO.output (file, "\tErrorLog ");
534 TextIO.output (file, ld);
535 TextIO.output (file, "/error.log\n\tCustomLog ");
536 TextIO.output (file, ld);
537 TextIO.output (file, "/access.log combined\n");
538 TextIO.output (file, "\tServerName ");
539 TextIO.output (file, fullHost);
540 app
541 (fn dom => (TextIO.output (file, "\n\tServerAlias ");
542 TextIO.output (file, makeFullHost dom)))
543 (Domain.currentAliasDomains ());
544
545 if suexec then
546 if isVersion1 node then
547 (TextIO.output (file, "\n\tUser ");
00a13ad8 548 TextIO.output (file, user);
57e066bb
AC		 549 TextIO.output (file, "\n\tGroup ");
550 TextIO.output (file, group))
551 else
552 (TextIO.output (file, "\n\tSuexecUserGroup ");
d5601036
AC		 553 TextIO.output (file, user);
554 TextIO.output (file, " ");
555 TextIO.output (file, group);
556 TextIO.output (file, "\n\tsuPHP_UserGroup ");
3f84c976 557 TextIO.output (file, user);
57e066bb
AC		 558 TextIO.output (file, " ");
559 TextIO.output (file, group))
560 else
561 ();
562
563 if isWaklog node then
564 (TextIO.output (file, "\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
565 TextIO.output (file, user);
566 TextIO.output (file, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
567 TextIO.output (file, user))
568 else
569 ();
570
571 TextIO.output (file, "\n\tDAVLockDB /var/lock/apache2/dav/");
572 TextIO.output (file, user);
573 TextIO.output (file, "/DAVLock");
574
e7482df3
AC		 575 if php <> Config.Apache.defaultPhpVersion then
576 (TextIO.output (file, "\n\tAddHandler x-httpd-php");
577 TextIO.output (file, Int.toString php);
578 TextIO.output (file, " .php .phtml"))
579 else
580 ();
581
57e066bb
AC		 582 (ld, file)
583 end)
584 places;
585 write "\n\tDocumentRoot ";
586 write docroot;
587 write "\n\tServerAdmin ";
588 write sadmin;
589 case ssl of
590 SOME cert =>
591 (write "\n\tSSLEngine on\n\tSSLCertificateFile ";
592 write cert)
593 | NONE => ();
594 write "\n";
595 !pre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
596 app (fn dom => !aliaser (makeFullHost dom)) (Domain.currentAliasDomains ())
597 end
3f84c976 598
57e066bb
AC		 599val () = Env.containerV_one "vhost"
600 ("host", Env.string)
601 (fn (env, host) => vhostBody (env, fn dom => host ^ "." ^ dom),
602 vhostPost)
603
604val () = Env.containerV_none "vhostDefault"
605 (fn env => vhostBody (env, fn dom => dom),
606 vhostPost)
8a7c40fa 607
ce01b51a
AC		 608val inLocal = ref false
609
2882ee37
AC		 610val () = Env.container_one "location"
611 ("prefix", Env.string)
612 (fn prefix =>
613 (write "\t<Location ";
614 write prefix;
ce01b51a
AC		 615 write ">\n";
616 inLocal := true),
617 fn () => (write "\t</Location>\n";
618 inLocal := false;
fb09779a
AC		 619 localRewriteEnabled := false;
620 localExpiresEnabled := false))
2882ee37
AC		 621
622val () = Env.container_one "directory"
623 ("directory", Env.string)
624 (fn directory =>
625 (write "\t<Directory ";
626 write directory;
ce01b51a
AC		 627 write ">\n";
628 inLocal := true),
629 fn () => (write "\t</Directory>\n";
630 inLocal := false;
fb09779a
AC		 631 localRewriteEnabled := false;
632 localExpiresEnabled := false))
2882ee37 633
767fe695
AC		 634val () = Env.container_one "filesMatch"
635 ("regexp", Env.string)
636 (fn prefix =>
637 (write "\t<FilesMatch \"";
638 write prefix;
639 write "\">\n"),
640 fn () => (write "\t</FilesMatch>\n";
fb09779a
AC		 641 localRewriteEnabled := false;
642 localExpiresEnabled := false))
767fe695 643
f8dfbbcc 644fun checkRewrite () =
ce01b51a 645 if !inLocal then
cf283351 646 if !localRewriteEnabled then
ce01b51a
AC		 647 ()
648 else
649 (write "\tRewriteEngine on\n";
650 localRewriteEnabled := true)
651 else if !rewriteEnabled then
f8dfbbcc
AC		 652 ()
653 else
654 (write "\tRewriteEngine on\n";
655 rewriteEnabled := true)
656
fb09779a
AC		 657fun checkExpires () =
658 if !inLocal then
659 if !localExpiresEnabled then
660 ()
661 else
662 (write "\tExpiresActive on\n";
663 localExpiresEnabled := true)
664 else if !expiresEnabled then
665 ()
666 else
667 (write "\tExpiresActive on\n";
668 expiresEnabled := true)
669
f8dfbbcc
AC		 670val () = Env.action_three "localProxyRewrite"
671 ("from", Env.string, "to", Env.string, "port", Env.int)
672 (fn (from, to, port) =>
673 (checkRewrite ();
06bd8215 674 write "\tRewriteRule\t\"";
f8dfbbcc 675 write from;
06bd8215 676 write "\"\thttp://localhost:";
f8dfbbcc
AC		 677 write (Int.toString port);
678 write "/";
679 write to;
680 write " [P]\n"))
681
fb09779a
AC		 682val () = Env.action_four "expiresByType"
683 ("mime", Env.string, "base", interval_base, "num", Env.int, "inter", interval)
684 (fn (mime, base, num, inter) =>
685 (checkExpires ();
686 write "\tExpiresByType\t\"";
687 write mime;
688 write "\"\t\"";
689 write base;
690 write " plus ";
691 if num < 0 then
692 (write "-";
693 write (Int.toString (~num)))
694 else
695 write (Int.toString num);
696 write " ";
697 write inter;
698 write "\"\n"))
699
e95a129e
AC		 700val () = Env.action_two "proxyPass"
701 ("from", Env.string, "to", Env.string)
702 (fn (from, to) =>
703 (write "\tProxyPass\t";
704 write from;
705 write "\t";
706 write to;
707 write "\n"))
708
709val () = Env.action_two "proxyPassReverse"
710 ("from", Env.string, "to", Env.string)
711 (fn (from, to) =>
712 (write "\tProxyPassReverse\t";
713 write from;
714 write "\t";
715 write to;
716 write "\n"))
f8dfbbcc
AC		 717
718val () = Env.action_three "rewriteRule"
719 ("from", Env.string, "to", Env.string, "flags", Env.list flag)
720 (fn (from, to, flags) =>
721 (checkRewrite ();
06bd8215 722 write "\tRewriteRule\t\"";
f8dfbbcc 723 write from;
06bd8215 724 write "\"\t\"";
f8dfbbcc 725 write to;
06bd8215 726 write "\"";
f8dfbbcc
AC		 727 case flags of
728 [] => ()
729 | flag::rest => (write " [";
730 write flag;
731 app (fn flag => (write ",";
732 write flag)) rest;
733 write "]");
734 write "\n"))
735
e95a129e
AC		 736val () = Env.action_three "rewriteCond"
737 ("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
738 (fn (from, to, flags) =>
739 (checkRewrite ();
06bd8215 740 write "\tRewriteCond\t\"";
e95a129e 741 write from;
06bd8215 742 write "\"\t\"";
e95a129e 743 write to;
06bd8215 744 write "\"";
e95a129e
AC		 745 case flags of
746 [] => ()
747 | flag::rest => (write " [";
748 write flag;
749 app (fn flag => (write ",";
750 write flag)) rest;
751 write "]");
752 write "\n"))
753
94b7b11a
AC		 754val () = Env.action_one "rewriteBase"
755 ("prefix", Env.string)
756 (fn prefix =>
757 (checkRewrite ();
06bd8215 758 write "\tRewriteBase\t\"";
94b7b11a 759 write prefix;
06bd8215 760 write "\"\n"))
94b7b11a 761
c98b57cf
AC		 762val () = Env.action_one "rewriteLogLevel"
763 ("level", Env.int)
764 (fn level =>
765 (checkRewrite ();
766 write "\tRewriteLog ";
7a2b27f0 767 write' (fn x => x);
c98b57cf
AC		 768 write "/rewrite.log\n\tRewriteLogLevel ";
769 write (Int.toString level);
770 write "\n"))
771
d5754b53
AC		 772val () = Env.action_two "alias"
773 ("from", Env.string, "to", Env.string)
774 (fn (from, to) =>
775 (write "\tAlias\t";
776 write from;
777 write " ";
778 write to;
779 write "\n"))
780
781val () = Env.action_two "scriptAlias"
782 ("from", Env.string, "to", Env.string)
783 (fn (from, to) =>
784 (write "\tScriptAlias\t";
785 write from;
786 write " ";
787 write to;
788 write "\n"))
789
790val () = Env.action_two "errorDocument"
791 ("code", Env.string, "handler", Env.string)
792 (fn (code, handler) =>
989965b1
AC		 793 let
794 val hasSpaces = CharVector.exists Char.isSpace handler
d5754b53 795
989965b1
AC		 796 fun maybeQuote () =
797 if hasSpaces then
798 write "\""
799 else
800 ()
801 in
802 write "\tErrorDocument\t";
803 write code;
804 write " ";
805 maybeQuote ();
806 write handler;
807 maybeQuote ();
808 write "\n"
809 end)
810
d441e69f
AC		 811val () = Env.action_one "options"
812 ("options", Env.list apache_option)
813 (fn opts =>
814 case opts of
815 [] => ()
816 | _ => (write "\tOptions";
817 app (fn opt => (write " "; write opt)) opts;
818 write "\n"))
819
820val () = Env.action_one "set_options"
821 ("options", Env.list apache_option)
822 (fn opts =>
823 case opts of
824 [] => ()
825 | _ => (write "\tOptions";
826 app (fn opt => (write " +"; write opt)) opts;
827 write "\n"))
828
829val () = Env.action_one "unset_options"
830 ("options", Env.list apache_option)
831 (fn opts =>
832 case opts of
833 [] => ()
834 | _ => (write "\tOptions";
835 app (fn opt => (write " -"; write opt)) opts;
836 write "\n"))
d5754b53 837
781ebc11
AC		 838val () = Env.action_one "cgiExtension"
839 ("extension", Env.string)
840 (fn ext => (write "\tAddHandler cgi-script ";
841 write ext;
842 write "\n"))
843
edd38024
AC		 844val () = Env.action_one "directoryIndex"
845 ("filenames", Env.list Env.string)
846 (fn opts =>
847 (write "\tDirectoryIndex";
848 app (fn opt => (write " "; write opt)) opts;
849 write "\n"))
850
e519d696 851val () = Env.action_one "serverAliasHost"
edd38024
AC		 852 ("host", Env.string)
853 (fn host =>
854 (write "\tServerAlias ";
855 write host;
7f75d838
AC		 856 write "\n";
857 !aliaser host))
edd38024 858
e519d696
AC		 859val () = Env.action_one "serverAlias"
860 ("host", Env.string)
861 (fn host =>
862 (app
863 (fn dom =>
864 let
865 val full = host ^ "." ^ dom
866 in
867 write "\tServerAlias ";
868 write full;
869 write "\n";
870 !aliaser full
871 end)
872 (Domain.currentDomains ())))
873
874val () = Env.action_none "serverAliasDefault"
875 (fn () =>
876 (app
877 (fn dom =>
878 (write "\tServerAlias ";
879 write dom;
880 write "\n";
881 !aliaser dom))
882 (Domain.currentDomains ())))
883
2aeb9eec
AC		 884val authType = fn (EVar "basic", _) => SOME "basic"
885 | (EVar "digest", _) => SOME "digest"
35dc7746 886 | (EVar "kerberos", _) => SOME "kerberos"
2aeb9eec
AC		 887 | _ => NONE
888
8a5b34c9
AC		 889fun allowAuthType "kerberos" = !sslEnabled
890 | allowAuthType _ = true
891
2aeb9eec
AC		 892val () = Env.action_one "authType"
893 ("type", authType)
894 (fn ty =>
8a5b34c9
AC		 895 if allowAuthType ty then
896 (write "\tAuthType ";
897 write ty;
898 write "\n";
899 case ty of
900 "kerberos" =>
901 write "\tKrbMethodNegotiate off\n\tKrbMethodK5Passwd on\n\tKrbVerifyKDC off\n\tKrbAuthRealms HCOOP.NET\n\tKrbSaveCredentials on\n"
902 | _ => ())
903 else
904 print "WARNING: Skipped Kerberos authType because this isn't an SSL vhost.\n")
2aeb9eec
AC		 905
906val () = Env.action_one "authName"
907 ("name", Env.string)
908 (fn name =>
909 (write "\tAuthName \"";
910 write name;
911 write "\"\n"))
912
913val () = Env.action_one "authUserFile"
914 ("file", Env.string)
915 (fn name =>
916 (write "\tAuthUserFile ";
917 write name;
918 write "\n"))
919
920val () = Env.action_none "requireValidUser"
921 (fn () => write "\tRequire valid-user\n")
922
923val () = Env.action_one "requireUser"
924 ("users", Env.list Env.string)
925 (fn names =>
926 case names of
927 [] => ()
928 | _ => (write "\tRequire user";
929 app (fn name => (write " "; write name)) names;
930 write "\n"))
931
932val () = Env.action_one "requireGroup"
933 ("groups", Env.list Env.string)
934 (fn names =>
935 case names of
936 [] => ()
937 | _ => (write "\tRequire group";
938 app (fn name => (write " "; write name)) names;
939 write "\n"))
940
941val () = Env.action_none "orderAllowDeny"
942 (fn () => write "\tOrder allow,deny\n")
943
944val () = Env.action_none "orderDenyAllow"
945 (fn () => write "\tOrder deny,allow\n")
946
947val () = Env.action_none "allowFromAll"
948 (fn () => write "\tAllow from all\n")
949
950val () = Env.action_one "allowFrom"
951 ("entries", Env.list Env.string)
952 (fn names =>
953 case names of
954 [] => ()
955 | _ => (write "\tAllow from";
956 app (fn name => (write " "; write name)) names;
957 write "\n"))
958
959val () = Env.action_none "denyFromAll"
960 (fn () => write "\tDeny from all\n")
961
962val () = Env.action_one "denyFrom"
963 ("entries", Env.list Env.string)
964 (fn names =>
965 case names of
966 [] => ()
967 | _ => (write "\tDeny from";
968 app (fn name => (write " "; write name)) names;
969 write "\n"))
970
971val () = Env.action_none "satisfyAll"
972 (fn () => write "\tSatisfy all\n")
973
974val () = Env.action_none "satisfyAny"
975 (fn () => write "\tSatisfy any\n")
976
7f012ffd
AC		 977val () = Env.action_one "forceType"
978 ("type", Env.string)
979 (fn ty => (write "\tForceType ";
980 write ty;
981 write "\n"))
982
983val () = Env.action_none "forceTypeOff"
984 (fn () => write "\tForceType None\n")
985
986val () = Env.action_two "action"
987 ("what", Env.string, "how", Env.string)
988 (fn (what, how) => (write "\tAction ";
989 write what;
990 write " ";
991 write how;
992 write "\n"))
993
994val () = Env.action_one "addDefaultCharset"
995 ("charset", Env.string)
996 (fn ty => (write "\tAddDefaultCharset ";
997 write ty;
998 write "\n"))
999
64e85bae 1000(*val () = Env.action_one "davSvn"
c8505e59
AC		 1001 ("path", Env.string)
1002 (fn path => (write "\tDAV svn\n\tSVNPath ";
1003 write path;
1004 write "\n"))
1005
1006val () = Env.action_one "authzSvnAccessFile"
1007 ("path", Env.string)
1008 (fn path => (write "\tAuthzSVNAccessFile ";
1009 write path;
64e85bae 1010 write "\n"))*)
c8505e59 1011
0aed4302
AC		 1012val () = Env.action_none "davFilesystem"
1013 (fn path => write "\tDAV filesystem\n")
1014
9d7fa346
AC		 1015val () = Env.action_two "addDescription"
1016 ("description", Env.string, "patterns", Env.list Env.string)
1017 (fn (desc, pats) =>
1018 case pats of
1019 [] => ()
1020 | _ => (write "\tAddDescription \"";
1021 write (String.toString desc);
1022 write "\"";
1023 app (fn pat => (write " "; write pat)) pats;
1024 write "\n"))
1025
1817ed97
AC		 1026val () = Env.action_two "addIcon"
1027 ("icon", Env.string, "patterns", Env.list Env.string)
1028 (fn (icon, pats) =>
1029 case pats of
1030 [] => ()
1031 | _ => (write "\tAddIcon \"";
1032 write icon;
1033 write "\"";
1034 app (fn pat => (write " "; write pat)) pats;
1035 write "\n"))
1036
9d7fa346
AC		 1037val () = Env.action_one "indexOptions"
1038 ("options", Env.list autoindex_option)
1039 (fn opts =>
1040 case opts of
1041 [] => ()
1042 | _ => (write "\tIndexOptions";
1043 app (fn (opt, arg) =>
1044 (write " ";
1045 write opt;
1046 Option.app (fn arg =>
1047 (write "="; write arg)) arg)) opts;
1048 write "\n"))
1049
1817ed97
AC		 1050val () = Env.action_one "indexIgnore"
1051 ("patterns", Env.list Env.string)
1052 (fn pats =>
1053 case pats of
1054 [] => ()
1055 | _ => (write "\tIndexIgnore";
1056 app (fn pat => (write " "; write pat)) pats;
1057 write "\n"))
1058
9d7fa346
AC		 1059val () = Env.action_one "set_indexOptions"
1060 ("options", Env.list autoindex_option)
1061 (fn opts =>
1062 case opts of
1063 [] => ()
1064 | _ => (write "\tIndexOptions";
1065 app (fn (opt, arg) =>
1066 (write " +";
1067 write opt;
1068 Option.app (fn arg =>
1069 (write "="; write arg)) arg)) opts;
1070 write "\n"))
1071
1072val () = Env.action_one "unset_indexOptions"
1073 ("options", Env.list autoindex_option)
1074 (fn opts =>
1075 case opts of
1076 [] => ()
1077 | _ => (write "\tIndexOptions";
1078 app (fn (opt, _) =>
1079 (write " -";
1080 write opt)) opts;
1081 write "\n"))
1082
1083val () = Env.action_one "headerName"
1084 ("name", Env.string)
1085 (fn name => (write "\tHeaderName ";
1086 write name;
1087 write "\n"))
1088
1089val () = Env.action_one "readmeName"
1090 ("name", Env.string)
1091 (fn name => (write "\tReadmeName ";
1092 write name;
1093 write "\n"))
1094
eda33894
AC		 1095val () = Env.action_two "setEnv"
1096 ("key", Env.string, "value", Env.string)
1097 (fn (key, value) => (write "\tSetEnv \"";
1098 write key;
1099 write "\" \"";
ca6ffb3f
AC		 1100 write (String.translate (fn #"\"" => "\\\""
1101 | ch => str ch) value);
eda33894
AC		 1102 write "\"\n"))
1103
f0062360
AC		 1104val () = Env.action_one "diskCache"
1105 ("path", Env.string)
1106 (fn path => (write "\tCacheEnable disk \"";
1107 write path;
1108 write "\"\n"))
83bc6c45 1109
83bc6c45
AC		 1110val () = Env.action_one "phpVersion"
1111 ("version", php_version)
1112 (fn version => (write "\tAddHandler x-httpd-php";
1113 write (Int.toString version);
1114 write " .php .phtml\n"))
1115
bcf547ec
AC		 1116val () = Env.action_two "addType"
1117 ("mime type", Env.string, "extension", Env.string)
1118 (fn (mt, ext) => (write "\tAddType ";
1119 write mt;
1120 write " ";
1121 write ext;
1122 write "\n"))
1123
1124val filter = fn (EVar "includes", _) => SOME "INCLUDES"
1125 | (EVar "deflate", _) => SOME "DEFLATE"
1126 | _ => NONE
1127
1128val () = Env.action_two "addOutputFilter"
1129 ("filters", Env.list filter, "extensions", Env.list Env.string)
1130 (fn (f :: fs, exts as (_ :: _)) =>
1131 (write "\tAddOutputFilter ";
1132 write f;
1133 app (fn f => (write ";"; write f)) fs;
1134 app (fn ext => (write " "; write ext)) exts;
1135 write "\n")
1136 | _ => ())
1137
ef5ad69a
CE		 1138val () = Env.action_one "sslCertificateChainFile"
1139 ("ssl_cacert_path", Env.string)
1140 (fn cacert =>
1141 if !sslEnabled then
1142 (write "\tSSLCertificateChainFile \"";
1143 write cacert;
1144 write "\"\n")
1145 else
1146 print "WARNING: Skipped sslCertificateChainFile because this isn't an SSL vhost.\n")
1147
71420f8b
AC		 1148val () = Domain.registerResetLocal (fn () =>
1149 ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*")))
1150
41c58daf
AC		 1151val () = Domain.registerDescriber (Domain.considerAll
1152 [Domain.Extension {extension = "vhost",
d936cf4d 1153 heading = fn host => "Web vhost " ^ host ^ ":"},
41c58daf 1154 Domain.Extension {extension = "vhost_ssl",
d936cf4d 1155 heading = fn host => "SSL web vhost " ^ host ^ ":"}])
41c58daf 1156
ecc307a0
AC		 1157val () = Env.action_none "testNoHtaccess"
1158 (fn path => write "\tAllowOverride None\n")
1159
563e7792
AC		 1160fun writeWaklogUserFile () =
1161 let
1162 val users = Acl.users ()
1163 val outf = TextIO.openOut Config.Apache.waklogUserFile
1164 in
1165 app (fn user => if String.isSuffix "_admin" user then
1166 ()
1167 else
1168 (TextIO.output (outf, "<Location /~");
1169 TextIO.output (outf, user);
1170 TextIO.output (outf, ">\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
1171 TextIO.output (outf, user);
1172 TextIO.output (outf, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
1173 TextIO.output (outf, user);
1174 TextIO.output (outf, "\n</Location>\n\n"))) users;
1175 TextIO.closeOut outf
1176 end
1177
1178val () = Domain.registerOnUsersChange writeWaklogUserFile
1179
8a7c40fa 1180end
Unnamed repository; edit this file to name it for gitweb.