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