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