Add AuthGroupFile
[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
58f4ce3b
CE
919val () = Env.action_one "authGroupFile"
920 ("file", Env.string)
921 (fn name =>
922 (write "\tAuthGroupFile ";
923 write name;
924 write "\n"))
925
2aeb9eec
AC
926val () = Env.action_none "requireValidUser"
927 (fn () => write "\tRequire valid-user\n")
928
929val () = Env.action_one "requireUser"
930 ("users", Env.list Env.string)
931 (fn names =>
932 case names of
933 [] => ()
934 | _ => (write "\tRequire user";
935 app (fn name => (write " "; write name)) names;
936 write "\n"))
937
938val () = Env.action_one "requireGroup"
939 ("groups", Env.list Env.string)
940 (fn names =>
941 case names of
942 [] => ()
943 | _ => (write "\tRequire group";
944 app (fn name => (write " "; write name)) names;
945 write "\n"))
946
947val () = Env.action_none "orderAllowDeny"
948 (fn () => write "\tOrder allow,deny\n")
949
950val () = Env.action_none "orderDenyAllow"
951 (fn () => write "\tOrder deny,allow\n")
952
953val () = Env.action_none "allowFromAll"
954 (fn () => write "\tAllow from all\n")
955
956val () = Env.action_one "allowFrom"
957 ("entries", Env.list Env.string)
958 (fn names =>
959 case names of
960 [] => ()
961 | _ => (write "\tAllow from";
962 app (fn name => (write " "; write name)) names;
963 write "\n"))
964
965val () = Env.action_none "denyFromAll"
966 (fn () => write "\tDeny from all\n")
967
968val () = Env.action_one "denyFrom"
969 ("entries", Env.list Env.string)
970 (fn names =>
971 case names of
972 [] => ()
973 | _ => (write "\tDeny from";
974 app (fn name => (write " "; write name)) names;
975 write "\n"))
976
977val () = Env.action_none "satisfyAll"
978 (fn () => write "\tSatisfy all\n")
979
980val () = Env.action_none "satisfyAny"
981 (fn () => write "\tSatisfy any\n")
982
7f012ffd
AC
983val () = Env.action_one "forceType"
984 ("type", Env.string)
985 (fn ty => (write "\tForceType ";
986 write ty;
987 write "\n"))
988
989val () = Env.action_none "forceTypeOff"
990 (fn () => write "\tForceType None\n")
991
992val () = Env.action_two "action"
993 ("what", Env.string, "how", Env.string)
994 (fn (what, how) => (write "\tAction ";
995 write what;
996 write " ";
997 write how;
998 write "\n"))
999
1000val () = Env.action_one "addDefaultCharset"
1001 ("charset", Env.string)
1002 (fn ty => (write "\tAddDefaultCharset ";
1003 write ty;
1004 write "\n"))
1005
64e85bae 1006(*val () = Env.action_one "davSvn"
c8505e59
AC
1007 ("path", Env.string)
1008 (fn path => (write "\tDAV svn\n\tSVNPath ";
1009 write path;
1010 write "\n"))
1011
1012val () = Env.action_one "authzSvnAccessFile"
1013 ("path", Env.string)
1014 (fn path => (write "\tAuthzSVNAccessFile ";
1015 write path;
64e85bae 1016 write "\n"))*)
c8505e59 1017
0aed4302
AC
1018val () = Env.action_none "davFilesystem"
1019 (fn path => write "\tDAV filesystem\n")
1020
9d7fa346
AC
1021val () = Env.action_two "addDescription"
1022 ("description", Env.string, "patterns", Env.list Env.string)
1023 (fn (desc, pats) =>
1024 case pats of
1025 [] => ()
1026 | _ => (write "\tAddDescription \"";
1027 write (String.toString desc);
1028 write "\"";
1029 app (fn pat => (write " "; write pat)) pats;
1030 write "\n"))
1031
1817ed97
AC
1032val () = Env.action_two "addIcon"
1033 ("icon", Env.string, "patterns", Env.list Env.string)
1034 (fn (icon, pats) =>
1035 case pats of
1036 [] => ()
1037 | _ => (write "\tAddIcon \"";
1038 write icon;
1039 write "\"";
1040 app (fn pat => (write " "; write pat)) pats;
1041 write "\n"))
1042
9d7fa346
AC
1043val () = Env.action_one "indexOptions"
1044 ("options", Env.list autoindex_option)
1045 (fn opts =>
1046 case opts of
1047 [] => ()
1048 | _ => (write "\tIndexOptions";
1049 app (fn (opt, arg) =>
1050 (write " ";
1051 write opt;
1052 Option.app (fn arg =>
1053 (write "="; write arg)) arg)) opts;
1054 write "\n"))
1055
1817ed97
AC
1056val () = Env.action_one "indexIgnore"
1057 ("patterns", Env.list Env.string)
1058 (fn pats =>
1059 case pats of
1060 [] => ()
1061 | _ => (write "\tIndexIgnore";
1062 app (fn pat => (write " "; write pat)) pats;
1063 write "\n"))
1064
9d7fa346
AC
1065val () = Env.action_one "set_indexOptions"
1066 ("options", Env.list autoindex_option)
1067 (fn opts =>
1068 case opts of
1069 [] => ()
1070 | _ => (write "\tIndexOptions";
1071 app (fn (opt, arg) =>
1072 (write " +";
1073 write opt;
1074 Option.app (fn arg =>
1075 (write "="; write arg)) arg)) opts;
1076 write "\n"))
1077
1078val () = Env.action_one "unset_indexOptions"
1079 ("options", Env.list autoindex_option)
1080 (fn opts =>
1081 case opts of
1082 [] => ()
1083 | _ => (write "\tIndexOptions";
1084 app (fn (opt, _) =>
1085 (write " -";
1086 write opt)) opts;
1087 write "\n"))
1088
1089val () = Env.action_one "headerName"
1090 ("name", Env.string)
1091 (fn name => (write "\tHeaderName ";
1092 write name;
1093 write "\n"))
1094
1095val () = Env.action_one "readmeName"
1096 ("name", Env.string)
1097 (fn name => (write "\tReadmeName ";
1098 write name;
1099 write "\n"))
1100
eda33894
AC
1101val () = Env.action_two "setEnv"
1102 ("key", Env.string, "value", Env.string)
1103 (fn (key, value) => (write "\tSetEnv \"";
1104 write key;
1105 write "\" \"";
ca6ffb3f
AC
1106 write (String.translate (fn #"\"" => "\\\""
1107 | ch => str ch) value);
eda33894
AC
1108 write "\"\n"))
1109
f0062360
AC
1110val () = Env.action_one "diskCache"
1111 ("path", Env.string)
1112 (fn path => (write "\tCacheEnable disk \"";
1113 write path;
1114 write "\"\n"))
83bc6c45 1115
83bc6c45
AC
1116val () = Env.action_one "phpVersion"
1117 ("version", php_version)
1118 (fn version => (write "\tAddHandler x-httpd-php";
1119 write (Int.toString version);
1120 write " .php .phtml\n"))
1121
bcf547ec
AC
1122val () = Env.action_two "addType"
1123 ("mime type", Env.string, "extension", Env.string)
1124 (fn (mt, ext) => (write "\tAddType ";
1125 write mt;
1126 write " ";
1127 write ext;
1128 write "\n"))
1129
1130val filter = fn (EVar "includes", _) => SOME "INCLUDES"
1131 | (EVar "deflate", _) => SOME "DEFLATE"
1132 | _ => NONE
1133
1134val () = Env.action_two "addOutputFilter"
1135 ("filters", Env.list filter, "extensions", Env.list Env.string)
1136 (fn (f :: fs, exts as (_ :: _)) =>
1137 (write "\tAddOutputFilter ";
1138 write f;
1139 app (fn f => (write ";"; write f)) fs;
1140 app (fn ext => (write " "; write ext)) exts;
1141 write "\n")
1142 | _ => ())
1143
ef5ad69a
CE
1144val () = Env.action_one "sslCertificateChainFile"
1145 ("ssl_cacert_path", Env.string)
1146 (fn cacert =>
1147 if !sslEnabled then
1148 (write "\tSSLCertificateChainFile \"";
1149 write cacert;
1150 write "\"\n")
1151 else
1152 print "WARNING: Skipped sslCertificateChainFile because this isn't an SSL vhost.\n")
1153
71420f8b
AC
1154val () = Domain.registerResetLocal (fn () =>
1155 ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*")))
1156
41c58daf
AC
1157val () = Domain.registerDescriber (Domain.considerAll
1158 [Domain.Extension {extension = "vhost",
d936cf4d 1159 heading = fn host => "Web vhost " ^ host ^ ":"},
41c58daf 1160 Domain.Extension {extension = "vhost_ssl",
d936cf4d 1161 heading = fn host => "SSL web vhost " ^ host ^ ":"}])
41c58daf 1162
ecc307a0
AC
1163val () = Env.action_none "testNoHtaccess"
1164 (fn path => write "\tAllowOverride None\n")
1165
563e7792
AC
1166fun writeWaklogUserFile () =
1167 let
1168 val users = Acl.users ()
1169 val outf = TextIO.openOut Config.Apache.waklogUserFile
1170 in
1171 app (fn user => if String.isSuffix "_admin" user then
1172 ()
1173 else
1174 (TextIO.output (outf, "<Location /~");
1175 TextIO.output (outf, user);
1176 TextIO.output (outf, ">\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
1177 TextIO.output (outf, user);
1178 TextIO.output (outf, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
1179 TextIO.output (outf, user);
1180 TextIO.output (outf, "\n</Location>\n\n"))) users;
1181 TextIO.closeOut outf
1182 end
1183
1184val () = Domain.registerOnUsersChange writeWaklogUserFile
1185
8a7c40fa 1186end