HCoop / hcoop / domtool2.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
apache: add php 7.2 support
[hcoop/domtool2.git] / src / plugins / apache.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006-2009, Adam Chlipala
3 * Copyright (c) 2013 Clinton Ebadi
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
22 structure Apache :> APACHE = struct
23
24 open Ast
25
26 val dl = ErrorMsg.dummyLoc
27
28 fun 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
33 val _ = Env.type_one "web_node"
34 Env.string
35 webNode
36
37 val _ = Env.registerFunction ("web_node_to_node",
38 fn [e] => SOME e
39 | _ => NONE)
40
41 fun webPlace (EApp ((EVar "web_place_default", _), (EString node, _)), _) =
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)
45 | webPlace _ = NONE
46
47 fun webPlaceDefault node = (EApp ((EVar "web_place_default", dl), (EString node, dl)), dl)
48
49 val _ = Env.registerFunction ("web_place_to_web_node",
50 fn [e] => Option.map (fn (node, _, _) => (EString node, dl)) (webPlace e)
51 | _ => NONE)
52
53 val _ = Env.registerFunction ("web_place_to_node",
54 fn [e] => Option.map (fn (node, _, _) => (EString node, dl)) (webPlace e)
55 | _ => NONE)
56
57 val _ = Env.registerFunction ("web_place_to_ip",
58 fn [e] => Option.map (fn (_, ip, _) => (EString ip, dl)) (webPlace e)
59 | _ => NONE)
60
61 val _ = Env.registerFunction ("web_place_to_ipv6",
62 fn [e] => Option.map (fn (_, _, ipv6) => (EString ipv6, dl)) (webPlace e)
63 | _ => NONE)
64
65 val _ = Env.type_one "proxy_port"
66 Env.int
67 (fn n => n > 1024)
68
69 fun 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
90 val _ = Env.type_one "proxy_target"
91 Env.string
92 (validProxyTarget (fn s => List.exists (fn s' => s = s') (Config.Apache.proxyTargets @ ["!"])))
93
94 val _ = Env.type_one "proxy_reverse_target"
95 Env.string
96 (validProxyTarget (fn s => List.exists (fn s' => s = s') Config.Apache.proxyTargets))
97
98 val _ = Env.type_one "rewrite_arg"
99 Env.string
100 (CharVector.all Char.isAlphaNum)
101
102 val _ = Env.type_one "suexec_flag"
103 Env.bool
104 (fn b => b orelse Domain.hasPriv "www")
105
106 val _ = Env.type_one "regexp"
107 Env.string
108 Pcre.validRegexp
109
110 fun 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 = #"."
116 orelse ch = #"/"
117 orelse ch = #"~") s
118
119 val _ = Env.type_one "location"
120 Env.string
121 validLocation
122
123 fun validCert s = Acl.query {user = Domain.getUser (),
124 class = "cert",
125 value = s}
126
127 fun validCaCert s = Acl.query {user = Domain.getUser (),
128 class = "cacert",
129 value = s}
130
131 val _ = Env.type_one "ssl_cert_path"
132 Env.string
133 validCert
134
135 val _ = Env.type_one "ssl_cacert_path"
136 Env.string
137 validCaCert
138
139 fun 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
144 fun validExtension s =
145 size s > 0
146 andalso size s < 20
147 andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_") s
148
149 val _ = Env.type_one "file_extension"
150 Env.string
151 validExtension
152
153 val _ = Env.registerFunction ("defaultServerAdmin",
154 fn [] => SOME (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl)
155 | _ => NONE)
156
157 val 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"
167 | (EVar "notfound", _) => SOME "404"
168 | _ => NONE
169
170 val 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
194 val cond_flag = fn (EVar "cond_nocase", _) => SOME "NC"
195 | (EVar "ornext", _) => SOME "OR"
196 | _ => NONE
197
198 val apache_option = fn (EVar "execCGI", _) => SOME "ExecCGI"
199 | (EVar "includesNOEXEC", _) => SOME "IncludesNOEXEC"
200 | (EVar "indexes", _) => SOME "Indexes"
201 | (EVar "followSymLinks", _) => SOME "FollowSymLinks"
202 | (EVar "multiViews", _) => SOME "MultiViews"
203 | _ => NONE
204
205 val autoindex_width = fn (EVar "autofit", _) => SOME "*"
206 | (EApp ((EVar "characters", _), n), _) =>
207 Option.map Int.toString (Env.int n)
208 | _ => NONE
209
210 val 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
241
242 val interval_base = fn (EVar "access", _) => SOME "access"
243 | (EVar "modification", _) => SOME "modification"
244 | _ => NONE
245
246 val 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
255 val vhostsChanged = ref false
256 val logDeleted = ref false
257 val delayedLogMoves = ref (fn () => ())
258
259 val () = Slave.registerPreHandler
260 (fn () => (vhostsChanged := false;
261 logDeleted := false;
262 delayedLogMoves := (fn () => print "Executing delayed log moves/deletes.\n")))
263
264 fun 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 =>
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 ()
278 in
279 loop ()
280 before TextIO.closeIn inf
281 end handle _ => NONE
282
283 val webNodes_full = Config.Apache.webNodes_all @ Config.Apache.webNodes_admin
284
285 fun isVersion1 node =
286 List.exists (fn (n, {version = ConfigTypes.APACHE_1_3, ...}) => n = node
287 | _ => false) webNodes_full
288
289 fun imVersion1 () = isVersion1 (Slave.hostname ())
290
291 fun isWaklog node =
292 List.exists (fn (n, {auth = ConfigTypes.MOD_WAKLOG, ...}) => n = node
293 | _ => false) webNodes_full
294
295 fun down () = if imVersion1 () then Config.Apache.down1 else Config.Apache.down
296 fun undown () = if imVersion1 () then Config.Apache.undown1 else Config.Apache.undown
297 fun reload () = if imVersion1 () then Config.Apache.reload1 else Config.Apache.reload
298 fun fixperms () = if imVersion1 () then Config.Apache.fixperms1 else Config.Apache.fixperms
299
300 fun logDir {user, node, vhostId} =
301 String.concat [Config.Apache.logDirOf (isVersion1 node) user,
302 "/",
303 node,
304 "/",
305 vhostId]
306
307 fun realLogDir {user, node, vhostId} =
308 String.concat [Config.Apache.realLogDirOf user,
309 "/",
310 node,
311 "/",
312 vhostId]
313
314 val () = Slave.registerFileHandler (fn fs =>
315 let
316 val spl = OS.Path.splitDirFile (#file fs)
317 in
318 if String.isSuffix ".vhost" (#file spl)
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)
325 val oldUser = case #action fs of
326 Slave.Delete false => user
327 | _ => findVhostUser realVhostFile
328 in
329 if (oldUser = NONE andalso #action fs <> Slave.Add)
330 orelse (user = NONE andalso not (Slave.isDelete (#action fs))) then
331 print ("Can't find user in " ^ #file fs ^ " or " ^ realVhostFile ^ "! Taking no action.\n")
332 else
333 let
334 val vhostId = if OS.Path.ext (#file spl) = SOME "vhost_ssl" then
335 OS.Path.base (#file spl) ^ ".ssl"
336 else
337 OS.Path.base (#file spl)
338
339 fun realLogDir user =
340 logDir {user = valOf user,
341 node = Slave.hostname (),
342 vhostId = vhostId}
343
344 fun backupLogs () =
345 OS.Path.joinDirFile
346 {dir = Config.Apache.backupLogDirOf
347 (isVersion1 (Slave.hostname ())),
348 file = vhostId}
349 in
350 vhostsChanged := true;
351 case #action fs of
352 Slave.Delete _ =>
353 let
354 val ldir = realLogDir oldUser
355 val dlm = !delayedLogMoves
356 in
357 if !logDeleted then
358 ()
359 else
360 ((*ignore (OS.Process.system (down ()));*)
361 ignore (OS.Process.system (fixperms ()));
362 logDeleted := true);
363 ignore (OS.Process.system (Config.rm
364 ^ " -rf "
365 ^ realVhostFile));
366 delayedLogMoves := (fn () => (dlm ();
367 Slave.moveDirCreate {from = ldir,
368 to = backupLogs ()}))
369 end
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
382 Slave.moveDirCreate {from = backupLogs (),
383 to = rld}
384 end
385
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
396
397 val dlm = !delayedLogMoves
398 in
399 if !logDeleted then
400 ()
401 else
402 ((*ignore (OS.Process.system (down ()));*)
403 logDeleted := true);
404 delayedLogMoves := (fn () => (dlm ();
405 ignore (OS.Process.system (Config.rm
406 ^ " -rf "
407 ^ realLogDir oldUser))));
408 if Posix.FileSys.access (rld, []) then
409 ()
410 else
411 Slave.mkDirAll rld
412 end
413 else
414 ())
415 end
416 end
417 else
418 ()
419 end)
420
421 val () = Slave.registerPostHandler
422 (fn () =>
423 (if !vhostsChanged then
424 (Slave.shellF ([reload ()],
425 fn cl => "Error reloading Apache with " ^ cl);
426 if !logDeleted then !delayedLogMoves () else ())
427 else
428 ()))
429
430 val vhostFiles : (string * TextIO.outstream) list ref = ref []
431 fun write' s = app (fn (node, file) => TextIO.output (file, s node)) (!vhostFiles)
432 fun write s = app (fn (_, file) => TextIO.output (file, s)) (!vhostFiles)
433
434 val rewriteEnabled = ref false
435 val localRewriteEnabled = ref false
436 val expiresEnabled = ref false
437 val localExpiresEnabled = ref false
438 val currentVhost = ref ""
439 val currentVhostId = ref ""
440 val sslEnabled = ref false
441
442 val pre = ref (fn _ : {user : string, nodes : string list, id : string, hostname : string} => ())
443 fun registerPre f =
444 let
445 val old = !pre
446 in
447 pre := (fn x => (old x; f x))
448 end
449
450 val post = ref (fn () => ())
451 fun registerPost f =
452 let
453 val old = !post
454 in
455 post := (fn () => (old (); f ()))
456 end
457
458 fun doPre x = !pre x
459 fun doPost () = !post ()
460
461 val aliaser = ref (fn _ : string => ())
462 fun registerAliaser f =
463 let
464 val old = !aliaser
465 in
466 aliaser := (fn x => (old x; f x))
467 end
468
469 fun vhostPost () = (!post ();
470 write "</VirtualHost>\n";
471 app (TextIO.closeOut o #2) (!vhostFiles))
472
473 val php_version = fn (EVar "php56", _) => SOME 56
474 | (EVar "php72", _) => SOME 72
475 | _ => NONE
476
477 fun 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")
487 val php = Env.env php_version (env, "PhpVersion")
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;
499 expiresEnabled := false;
500 localExpiresEnabled := false;
501 vhostFiles := map (fn (node, ip, ipv6) =>
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 ");
511
512 TextIO.output (file, ip);
513 TextIO.output (file, ":");
514 TextIO.output (file, case ssl of
515 SOME _ => "443"
516 | NONE => "80");
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
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 ");
542 TextIO.output (file, user);
543 TextIO.output (file, "\n\tGroup ");
544 TextIO.output (file, group))
545 else
546 (TextIO.output (file, "\n\tSuexecUserGroup ");
547 TextIO.output (file, user);
548 TextIO.output (file, " ");
549 TextIO.output (file, group))
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
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"];
577 (ld, file)
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 ())
592 end
593
594 val () = Env.containerV_one "vhost"
595 ("host", Env.string)
596 (fn (env, host) => vhostBody (env, fn dom => host ^ "." ^ dom),
597 vhostPost)
598
599 val () = Env.containerV_none "vhostDefault"
600 (fn env => vhostBody (env, fn dom => dom),
601 vhostPost)
602
603 val inLocal = ref false
604
605 val () = Env.container_one "location"
606 ("prefix", Env.string)
607 (fn prefix =>
608 (write "\t<Location ";
609 write prefix;
610 write ">\n";
611 inLocal := true),
612 fn () => (write "\t</Location>\n";
613 inLocal := false;
614 localRewriteEnabled := false;
615 localExpiresEnabled := false))
616
617 val () = Env.container_one "directory"
618 ("directory", Env.string)
619 (fn directory =>
620 (write "\t<Directory ";
621 write directory;
622 write ">\n";
623 inLocal := true),
624 fn () => (write "\t</Directory>\n";
625 inLocal := false;
626 localRewriteEnabled := false;
627 localExpiresEnabled := false))
628
629 val () = 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";
636 localRewriteEnabled := false;
637 localExpiresEnabled := false))
638
639 fun checkRewrite () =
640 if !inLocal then
641 if !localRewriteEnabled then
642 ()
643 else
644 (write "\tRewriteEngine on\n";
645 localRewriteEnabled := true)
646 else if !rewriteEnabled then
647 ()
648 else
649 (write "\tRewriteEngine on\n";
650 rewriteEnabled := true)
651
652 fun 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
665 val () = Env.action_three "localProxyRewrite"
666 ("from", Env.string, "to", Env.string, "port", Env.int)
667 (fn (from, to, port) =>
668 (checkRewrite ();
669 write "\tRewriteRule\t\"";
670 write from;
671 write "\"\thttp://localhost:";
672 write (Int.toString port);
673 write "/";
674 write to;
675 write " [P]\n"))
676
677 val () = 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
695 val () = 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;
702 write "\tretry=0\n"))
703
704 val () = 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"))
712
713 val () = 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
720 val () = Env.action_three "rewriteRule"
721 ("from", Env.string, "to", Env.string, "flags", Env.list flag)
722 (fn (from, to, flags) =>
723 (checkRewrite ();
724 write "\tRewriteRule\t\"";
725 write from;
726 write "\"\t\"";
727 write to;
728 write "\"";
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
738 val () = Env.action_three "rewriteCond"
739 ("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
740 (fn (from, to, flags) =>
741 (checkRewrite ();
742 write "\tRewriteCond\t\"";
743 write from;
744 write "\"\t\"";
745 write to;
746 write "\"";
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
756 val () = Env.action_one "rewriteBase"
757 ("prefix", Env.string)
758 (fn prefix =>
759 (checkRewrite ();
760 write "\tRewriteBase\t\"";
761 write prefix;
762 write "\"\n"))
763
764 val () = Env.action_one "rewriteLogLevel"
765 ("level", Env.int)
766 (fn level =>
767 (checkRewrite ();
768 write "\tRewriteLog ";
769 write' (fn x => x);
770 write "/rewrite.log\n\tRewriteLogLevel ";
771 write (Int.toString level);
772 write "\n"))
773
774 val () = 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
783 val () = 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
792 val () = Env.action_two "fastScriptAlias"
793 ("from", Env.string, "to", Env.string)
794 (fn (from, to) =>
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";
812
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 *)
818 (* won't be trivial, since we don't have access to node here *)
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)
827
828 val () = Env.action_two "errorDocument"
829 ("code", Env.string, "handler", Env.string)
830 (fn (code, handler) =>
831 let
832 val hasSpaces = CharVector.exists Char.isSpace handler
833
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)
848
849 val () = 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
858 val () = 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
867 val () = 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"))
875
876 val () = Env.action_one "cgiExtension"
877 ("extension", Env.string)
878 (fn ext => (write "\tAddHandler cgi-script ";
879 write ext;
880 write "\n"))
881
882 val () = 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
889 val () = Env.action_one "serverAliasHost"
890 ("host", Env.string)
891 (fn host =>
892 (write "\tServerAlias ";
893 write host;
894 write "\n";
895 !aliaser host))
896
897 val () = 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
912 val () = 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
922 val authType = fn (EVar "basic", _) => SOME "basic"
923 | (EVar "digest", _) => SOME "digest"
924 | (EVar "kerberos", _) => SOME "kerberos"
925 | _ => NONE
926
927 fun allowAuthType "kerberos" = !sslEnabled
928 | allowAuthType _ = true
929
930 val () = Env.action_one "authType"
931 ("type", authType)
932 (fn ty =>
933 if allowAuthType ty then
934 (write "\tAuthType ";
935 write ty;
936 write "\n";
937 case ty of
938 "kerberos" =>
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"
940 | _ => ())
941 else
942 print "WARNING: Skipped Kerberos authType because this isn't an SSL vhost.\n")
943
944 val () = Env.action_one "authName"
945 ("name", Env.string)
946 (fn name =>
947 (write "\tAuthName \"";
948 write name;
949 write "\"\n"))
950
951 val () = Env.action_one "authUserFile"
952 ("file", Env.string)
953 (fn name =>
954 (write "\tAuthUserFile ";
955 write name;
956 write "\n"))
957
958 val () = Env.action_one "authGroupFile"
959 ("file", Env.string)
960 (fn name =>
961 (write "\tAuthGroupFile ";
962 write name;
963 write "\n"))
964
965 val () = Env.action_none "requireValidUser"
966 (fn () => write "\tRequire valid-user\n")
967
968 val () = 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
977 val () = 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
986 val () = Env.action_none "orderAllowDeny"
987 (fn () => write "\tOrder allow,deny\n")
988
989 val () = Env.action_none "orderDenyAllow"
990 (fn () => write "\tOrder deny,allow\n")
991
992 val () = Env.action_none "allowFromAll"
993 (fn () => write "\tAllow from all\n")
994
995 val () = 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
1004 val () = Env.action_none "denyFromAll"
1005 (fn () => write "\tDeny from all\n")
1006
1007 val () = 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
1016 val () = Env.action_none "satisfyAll"
1017 (fn () => write "\tSatisfy all\n")
1018
1019 val () = Env.action_none "satisfyAny"
1020 (fn () => write "\tSatisfy any\n")
1021
1022 val () = Env.action_one "forceType"
1023 ("type", Env.string)
1024 (fn ty => (write "\tForceType ";
1025 write ty;
1026 write "\n"))
1027
1028 val () = Env.action_none "forceTypeOff"
1029 (fn () => write "\tForceType None\n")
1030
1031 val () = 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
1039 val () = Env.action_one "addDefaultCharset"
1040 ("charset", Env.string)
1041 (fn ty => (write "\tAddDefaultCharset ";
1042 write ty;
1043 write "\n"))
1044
1045 (*val () = Env.action_one "davSvn"
1046 ("path", Env.string)
1047 (fn path => (write "\tDAV svn\n\tSVNPath ";
1048 write path;
1049 write "\n"))
1050
1051 val () = Env.action_one "authzSvnAccessFile"
1052 ("path", Env.string)
1053 (fn path => (write "\tAuthzSVNAccessFile ";
1054 write path;
1055 write "\n"))*)
1056
1057 val () = Env.action_none "davFilesystem"
1058 (fn path => write "\tDAV filesystem\n")
1059
1060 val () = 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
1071 val () = 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
1082 val () = 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
1095 val () = 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
1104 val () = 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
1117 val () = 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
1128 val () = Env.action_one "headerName"
1129 ("name", Env.string)
1130 (fn name => (write "\tHeaderName ";
1131 write name;
1132 write "\n"))
1133
1134 val () = Env.action_one "readmeName"
1135 ("name", Env.string)
1136 (fn name => (write "\tReadmeName ";
1137 write name;
1138 write "\n"))
1139
1140 val () = Env.action_two "setEnv"
1141 ("key", Env.string, "value", Env.string)
1142 (fn (key, value) => (write "\tSetEnv \"";
1143 write key;
1144 write "\" \"";
1145 write (String.translate (fn #"\"" => "\\\""
1146 | ch => str ch) value);
1147 write "\"\n"))
1148
1149 val () = Env.action_one "diskCache"
1150 ("path", Env.string)
1151 (fn path => (write "\tCacheEnable disk \"";
1152 write path;
1153 write "\"\n"))
1154
1155 val () = Env.action_one "phpVersion"
1156 ("version", php_version)
1157 (fn version => (write "\tAddHandler fcgid-script .php .phtml\n";
1158 (* FIXME: only set kerberos wrapper of waklog is on *)
1159 (* won't be trivial, since we don't have access to node here *)
1160 write "\n\tFcgidWrapper \"";
1161 write (Config.Apache.fastCgiWrapperOf (Domain.getUser ()));
1162 write " ";
1163 write (Config.Apache.phpFastCgiWrapper version);
1164 write "\" .php .phtml\n"))
1165
1166 val () = 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
1174 val filter = fn (EVar "includes", _) => SOME "INCLUDES"
1175 | (EVar "deflate", _) => SOME "DEFLATE"
1176 | _ => NONE
1177
1178 val () = 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
1188 val () = 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
1198 val () = Domain.registerResetLocal (fn () =>
1199 ignore (OS.Process.system (Config.rm ^ " -rf " ^ Config.Apache.confDir ^ "/*")))
1200
1201 val () = Domain.registerDescriber (Domain.considerAll
1202 [Domain.Extension {extension = "vhost",
1203 heading = fn host => "Web vhost " ^ host ^ ":"},
1204 Domain.Extension {extension = "vhost_ssl",
1205 heading = fn host => "SSL web vhost " ^ host ^ ":"}])
1206
1207 val () = Env.action_one "allowEncodedSlashes"
1208 ("enable", Env.bool)
1209 (fn enable => (write "\tAllowEncodedSlashes ";
1210 write (if enable then "NoDecode" else "Off");
1211 write "\n"))
1212 val () = Env.action_none "testNoHtaccess"
1213 (fn path => write "\tAllowOverride None\n")
1214
1215 fun 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
1233 val () = Domain.registerOnUsersChange writeWaklogUserFile
1234
1235 end
Unnamed repository; edit this file to name it for gitweb.