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