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