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