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