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