HCoop / hcoop / domtool2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
errorDocument outputs quotes as needed
[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
8a7c40fa 270val () = Slave.registerFileHandler (fn fs =>
7a2b27f0
AC		 271 let
272 val spl = OS.Path.splitDirFile (#file fs)
273 in
274 if String.isSuffix ".vhost" (#file spl)
3a941c29
AC		 275 orelse String.isSuffix ".vhost_ssl" (#file spl) then let
276 val realVhostFile = OS.Path.joinDirFile
277 {dir = Config.Apache.confDir,
278 file = #file spl}
279
280 val user = findVhostUser (#file fs)
19026493
AC		 281 val oldUser = case #action fs of
282 Slave.Delete false => user
283 | _ => findVhostUser realVhostFile
3a941c29
AC		 284 in
285 if (oldUser = NONE andalso #action fs <> Slave.Add)
1638d5a2 286 orelse (user = NONE andalso not (Slave.isDelete (#action fs))) then
3a941c29
AC		 287 print ("Can't find user in " ^ #file fs ^ " or " ^ realVhostFile ^ "! Taking no action.\n")
288 else
289 let
5b07cebd 290 val vhostId = if OS.Path.ext (#file spl) = SOME "vhost_ssl" then
b59d9074
AC		 291 OS.Path.base (#file spl) ^ ".ssl"
292 else
293 OS.Path.base (#file spl)
294
3a941c29 295 fun realLogDir user =
b59d9074
AC		 296 logDir {user = valOf user,
297 node = Slave.hostname (),
298 vhostId = vhostId}
c17d0537
AC		 299
300 fun backupLogs () =
301 OS.Path.joinDirFile
302 {dir = Config.Apache.backupLogDirOf
303 (isVersion1 (Slave.hostname ())),
304 file = vhostId}
3a941c29
AC		 305 in
306 vhostsChanged := true;
307 case #action fs of
1638d5a2 308 Slave.Delete _ =>
31b50af0
AC		 309 let
310 val ldir = realLogDir oldUser
311 in
312 if !logDeleted then
313 ()
314 else
315 (ignore (OS.Process.system (down ()));
c17d0537 316 ignore (OS.Process.system (fixperms ()));
31b50af0
AC		 317 logDeleted := true);
318 ignore (OS.Process.system (Config.rm
319 ^ " -rf "
320 ^ realVhostFile));
321 Slave.moveDirCreate {from = ldir,
c17d0537 322 to = backupLogs ()}
31b50af0 323 end
3a941c29
AC		 324 | Slave.Add =>
325 let
326 val rld = realLogDir user
327 in
328 ignore (OS.Process.system (Config.cp
329 ^ " "
330 ^ #file fs
331 ^ " "
332 ^ realVhostFile));
333 if Posix.FileSys.access (rld, []) then
334 ()
335 else
c17d0537 336 Slave.moveDirCreate {from = backupLogs (),
31b50af0 337 to = rld}
3a941c29
AC		 338 end
339
340 | _ =>
341 (ignore (OS.Process.system (Config.cp
342 ^ " "
343 ^ #file fs
344 ^ " "
345 ^ realVhostFile));
346 if user <> oldUser then
347 let
348 val old = realLogDir oldUser
349 val rld = realLogDir user
350 in
351 if !logDeleted then
352 ()
353 else
55d4a268 354 (ignore (OS.Process.system (down ()));
3a941c29
AC		 355 logDeleted := true);
356 ignore (OS.Process.system (Config.rm
357 ^ " -rf "
358 ^ realLogDir oldUser));
359 if Posix.FileSys.access (rld, []) then
360 ()
361 else
409542d7 362 Slave.mkDirAll rld
3a941c29
AC		 363 end
364 else
365 ())
366 end
367 end
7a2b27f0
AC		 368 else
369 ()
370 end)
8a7c40fa
AC		 371
372val () = Slave.registerPostHandler
373 (fn () =>
374 (if !vhostsChanged then
55d4a268 375 Slave.shellF ([if !logDeleted then undown () else reload ()],
8a7c40fa
AC		 376 fn cl => "Error reloading Apache with " ^ cl)
377 else
378 ()))
379
7a2b27f0
AC		 380val vhostFiles : (string * TextIO.outstream) list ref = ref []
381fun write' s = app (fn (node, file) => TextIO.output (file, s node)) (!vhostFiles)
382fun write s = app (fn (_, file) => TextIO.output (file, s)) (!vhostFiles)
8a7c40fa 383
f8dfbbcc 384val rewriteEnabled = ref false
ce01b51a 385val localRewriteEnabled = ref false
c98b57cf
AC		 386val currentVhost = ref ""
387val currentVhostId = ref ""
8a5b34c9 388val sslEnabled = ref false
f8dfbbcc 389
7a2b27f0 390val pre = ref (fn _ : {user : string, nodes : string list, id : string, hostname : string} => ())
7f75d838
AC		 391fun registerPre f =
392 let
393 val old = !pre
394 in
395 pre := (fn x => (old x; f x))
396 end
397
398val post = ref (fn () => ())
399fun registerPost f =
400 let
401 val old = !post
402 in
403 post := (fn () => (old (); f ()))
404 end
405
e9f528ab
AC		 406fun doPre x = !pre x
407fun doPost () = !post ()
408
7f75d838
AC		 409val aliaser = ref (fn _ : string => ())
410fun registerAliaser f =
411 let
412 val old = !aliaser
413 in
414 aliaser := (fn x => (old x; f x))
415 end
416
8a7c40fa
AC		 417val () = Env.containerV_one "vhost"
418 ("host", Env.string)
419 (fn (env, host) =>
420 let
128e7b0b 421 val places = Env.env (Env.list webPlace) (env, "WebPlaces")
8a7c40fa 422
434a7b1f 423 val ssl = Env.env ssl (env, "SSL")
8a7c40fa
AC		 424 val user = Env.env Env.string (env, "User")
425 val group = Env.env Env.string (env, "Group")
426 val docroot = Env.env Env.string (env, "DocumentRoot")
427 val sadmin = Env.env Env.string (env, "ServerAdmin")
434a7b1f 428 val suexec = Env.env Env.bool (env, "SuExec")
8a7c40fa
AC		 429
430 val fullHost = host ^ "." ^ Domain.currentDomain ()
434a7b1f
AC		 431 val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
432 val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
8a7c40fa 433 in
c98b57cf
AC		 434 currentVhost := fullHost;
435 currentVhostId := vhostId;
8a5b34c9 436 sslEnabled := Option.isSome ssl;
c98b57cf 437
f8dfbbcc 438 rewriteEnabled := false;
ce01b51a 439 localRewriteEnabled := false;
128e7b0b 440 vhostFiles := map (fn (node, ip) =>
8a7c40fa
AC		 441 let
442 val file = Domain.domainFile {node = node,
443 name = confFile}
2a7d2818
AC		 444
445 val ld = logDir {user = user, node = node, vhostId = vhostId}
8a7c40fa 446 in
00a13ad8
AC		 447 TextIO.output (file, "# Owner: ");
448 TextIO.output (file, user);
449 TextIO.output (file, "\n<VirtualHost ");
128e7b0b 450 TextIO.output (file, ip);
8a7c40fa 451 TextIO.output (file, ":");
434a7b1f
AC		 452 TextIO.output (file, case ssl of
453 SOME _ => "443"
454 | NONE => "80");
8a7c40fa 455 TextIO.output (file, ">\n");
7a2b27f0 456 TextIO.output (file, "\tErrorLog ");
2a7d2818 457 TextIO.output (file, ld);
7a2b27f0 458 TextIO.output (file, "/error.log\n\tCustomLog ");
2a7d2818 459 TextIO.output (file, ld);
7a2b27f0 460 TextIO.output (file, "/access.log combined\n");
55d4a268
AC		 461 TextIO.output (file, "\tServerName ");
462 TextIO.output (file, fullHost);
e519d696
AC		 463 app
464 (fn dom => (TextIO.output (file, "\n\tServerAlias ");
465 TextIO.output (file, host);
466 TextIO.output (file, ".");
467 TextIO.output (file, dom)))
468 (Domain.currentAliasDomains ());
3f84c976 469
55d4a268
AC		 470 if suexec then
471 if isVersion1 node then
472 (TextIO.output (file, "\n\tUser ");
473 TextIO.output (file, user);
474 TextIO.output (file, "\n\tGroup ");
475 TextIO.output (file, group))
476 else
477 (TextIO.output (file, "\n\tSuexecUserGroup ");
478 TextIO.output (file, user);
479 TextIO.output (file, " ");
480 TextIO.output (file, group))
481 else
482 ();
3f84c976 483
f8ef6c20 484 if isWaklog node then
a09d0e82 485 (TextIO.output (file, "\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
f8ef6c20 486 TextIO.output (file, user);
fdf9a42d 487 TextIO.output (file, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
f8ef6c20
AC		 488 TextIO.output (file, user))
489 else
490 ();
3f84c976 491
e34e1f36 492 TextIO.output (file, "\n\tDAVLockDB /var/lock/apache2/dav/");
3f84c976
AC		 493 TextIO.output (file, user);
494 TextIO.output (file, "/DAVLock");
495
2a7d2818 496 (ld, file)
8a7c40fa 497 end)
128e7b0b 498 places;
8a7c40fa
AC		 499 write "\n\tDocumentRoot ";
500 write docroot;
501 write "\n\tServerAdmin ";
502 write sadmin;
434a7b1f
AC		 503 case ssl of
504 SOME cert =>
505 (write "\n\tSSLEngine on\n\tSSLCertificateFile ";
506 write cert)
507 | NONE => ();
7a2b27f0 508 write "\n";
128e7b0b 509 !pre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
5cab5a98 510 app (fn dom => !aliaser (host ^ "." ^ dom)) (Domain.currentAliasDomains ())
8a7c40fa 511 end,
7f75d838
AC		 512 fn () => (!post ();
513 write "</VirtualHost>\n";
7a2b27f0 514 app (TextIO.closeOut o #2) (!vhostFiles)))
8a7c40fa 515
ce01b51a
AC		 516val inLocal = ref false
517
2882ee37
AC		 518val () = Env.container_one "location"
519 ("prefix", Env.string)
520 (fn prefix =>
521 (write "\t<Location ";
522 write prefix;
ce01b51a
AC		 523 write ">\n";
524 inLocal := true),
525 fn () => (write "\t</Location>\n";
526 inLocal := false;
527 localRewriteEnabled := false))
2882ee37
AC		 528
529val () = Env.container_one "directory"
530 ("directory", Env.string)
531 (fn directory =>
532 (write "\t<Directory ";
533 write directory;
ce01b51a
AC		 534 write ">\n";
535 inLocal := true),
536 fn () => (write "\t</Directory>\n";
537 inLocal := false;
538 localRewriteEnabled := false))
2882ee37 539
f8dfbbcc 540fun checkRewrite () =
ce01b51a 541 if !inLocal then
cf283351 542 if !localRewriteEnabled then
ce01b51a
AC		 543 ()
544 else
545 (write "\tRewriteEngine on\n";
546 localRewriteEnabled := true)
547 else if !rewriteEnabled then
f8dfbbcc
AC		 548 ()
549 else
550 (write "\tRewriteEngine on\n";
551 rewriteEnabled := true)
552
553val () = Env.action_three "localProxyRewrite"
554 ("from", Env.string, "to", Env.string, "port", Env.int)
555 (fn (from, to, port) =>
556 (checkRewrite ();
557 write "\tRewriteRule\t";
558 write from;
559 write "\thttp://localhost:";
560 write (Int.toString port);
561 write "/";
562 write to;
563 write " [P]\n"))
564
e95a129e
AC		 565val () = Env.action_two "proxyPass"
566 ("from", Env.string, "to", Env.string)
567 (fn (from, to) =>
568 (write "\tProxyPass\t";
569 write from;
570 write "\t";
571 write to;
572 write "\n"))
573
574val () = Env.action_two "proxyPassReverse"
575 ("from", Env.string, "to", Env.string)
576 (fn (from, to) =>
577 (write "\tProxyPassReverse\t";
578 write from;
579 write "\t";
580 write to;
581 write "\n"))
f8dfbbcc
AC		 582
583val () = Env.action_three "rewriteRule"
584 ("from", Env.string, "to", Env.string, "flags", Env.list flag)
585 (fn (from, to, flags) =>
586 (checkRewrite ();
587 write "\tRewriteRule\t";
588 write from;
589 write "\t";
590 write to;
591 case flags of
592 [] => ()
593 | flag::rest => (write " [";
594 write flag;
595 app (fn flag => (write ",";
596 write flag)) rest;
597 write "]");
598 write "\n"))
599
e95a129e
AC		 600val () = Env.action_three "rewriteCond"
601 ("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
602 (fn (from, to, flags) =>
603 (checkRewrite ();
604 write "\tRewriteCond\t";
605 write from;
606 write "\t";
607 write to;
608 case flags of
609 [] => ()
610 | flag::rest => (write " [";
611 write flag;
612 app (fn flag => (write ",";
613 write flag)) rest;
614 write "]");
615 write "\n"))
616
94b7b11a
AC		 617val () = Env.action_one "rewriteBase"
618 ("prefix", Env.string)
619 (fn prefix =>
620 (checkRewrite ();
621 write "\tRewriteBase\t";
622 write prefix;
623 write "\n"))
624
c98b57cf
AC		 625val () = Env.action_one "rewriteLogLevel"
626 ("level", Env.int)
627 (fn level =>
628 (checkRewrite ();
629 write "\tRewriteLog ";
7a2b27f0 630 write' (fn x => x);
c98b57cf
AC		 631 write "/rewrite.log\n\tRewriteLogLevel ";
632 write (Int.toString level);
633 write "\n"))
634
d5754b53
AC		 635val () = Env.action_two "alias"
636 ("from", Env.string, "to", Env.string)
637 (fn (from, to) =>
638 (write "\tAlias\t";
639 write from;
640 write " ";
641 write to;
642 write "\n"))
643
644val () = Env.action_two "scriptAlias"
645 ("from", Env.string, "to", Env.string)
646 (fn (from, to) =>
647 (write "\tScriptAlias\t";
648 write from;
649 write " ";
650 write to;
651 write "\n"))
652
653val () = Env.action_two "errorDocument"
654 ("code", Env.string, "handler", Env.string)
655 (fn (code, handler) =>
989965b1
AC		 656 let
657 val hasSpaces = CharVector.exists Char.isSpace handler
d5754b53 658
989965b1
AC		 659 fun maybeQuote () =
660 if hasSpaces then
661 write "\""
662 else
663 ()
664 in
665 write "\tErrorDocument\t";
666 write code;
667 write " ";
668 maybeQuote ();
669 write handler;
670 maybeQuote ();
671 write "\n"
672 end)
673
d441e69f
AC		 674val () = Env.action_one "options"
675 ("options", Env.list apache_option)
676 (fn opts =>
677 case opts of
678 [] => ()
679 | _ => (write "\tOptions";
680 app (fn opt => (write " "; write opt)) opts;
681 write "\n"))
682
683val () = Env.action_one "set_options"
684 ("options", Env.list apache_option)
685 (fn opts =>
686 case opts of
687 [] => ()
688 | _ => (write "\tOptions";
689 app (fn opt => (write " +"; write opt)) opts;
690 write "\n"))
691
692val () = Env.action_one "unset_options"
693 ("options", Env.list apache_option)
694 (fn opts =>
695 case opts of
696 [] => ()
697 | _ => (write "\tOptions";
698 app (fn opt => (write " -"; write opt)) opts;
699 write "\n"))
d5754b53 700
edd38024
AC		 701val () = Env.action_one "directoryIndex"
702 ("filenames", Env.list Env.string)
703 (fn opts =>
704 (write "\tDirectoryIndex";
705 app (fn opt => (write " "; write opt)) opts;
706 write "\n"))
707
e519d696 708val () = Env.action_one "serverAliasHost"
edd38024
AC		 709 ("host", Env.string)
710 (fn host =>
711 (write "\tServerAlias ";
712 write host;
7f75d838
AC		 713 write "\n";
714 !aliaser host))
edd38024 715
e519d696
AC		 716val () = Env.action_one "serverAlias"
717 ("host", Env.string)
718 (fn host =>
719 (app
720 (fn dom =>
721 let
722 val full = host ^ "." ^ dom
723 in
724 write "\tServerAlias ";
725 write full;
726 write "\n";
727 !aliaser full
728 end)
729 (Domain.currentDomains ())))
730
731val () = Env.action_none "serverAliasDefault"
732 (fn () =>
733 (app
734 (fn dom =>
735 (write "\tServerAlias ";
736 write dom;
737 write "\n";
738 !aliaser dom))
739 (Domain.currentDomains ())))
740
2aeb9eec
AC		 741val authType = fn (EVar "basic", _) => SOME "basic"
742 | (EVar "digest", _) => SOME "digest"
35dc7746 743 | (EVar "kerberos", _) => SOME "kerberos"
2aeb9eec
AC		 744 | _ => NONE
745
8a5b34c9
AC		 746fun allowAuthType "kerberos" = !sslEnabled
747 | allowAuthType _ = true
748
2aeb9eec
AC		 749val () = Env.action_one "authType"
750 ("type", authType)
751 (fn ty =>
8a5b34c9
AC		 752 if allowAuthType ty then
753 (write "\tAuthType ";
754 write ty;
755 write "\n";
756 case ty of
757 "kerberos" =>
758 write "\tKrbMethodNegotiate off\n\tKrbMethodK5Passwd on\n\tKrbVerifyKDC off\n\tKrbAuthRealms HCOOP.NET\n\tKrbSaveCredentials on\n"
759 | _ => ())
760 else
761 print "WARNING: Skipped Kerberos authType because this isn't an SSL vhost.\n")
2aeb9eec
AC		 762
763val () = Env.action_one "authName"
764 ("name", Env.string)
765 (fn name =>
766 (write "\tAuthName \"";
767 write name;
768 write "\"\n"))
769
770val () = Env.action_one "authUserFile"
771 ("file", Env.string)
772 (fn name =>
773 (write "\tAuthUserFile ";
774 write name;
775 write "\n"))
776
777val () = Env.action_none "requireValidUser"
778 (fn () => write "\tRequire valid-user\n")
779
780val () = Env.action_one "requireUser"
781 ("users", Env.list Env.string)
782 (fn names =>
783 case names of
784 [] => ()
785 | _ => (write "\tRequire user";
786 app (fn name => (write " "; write name)) names;
787 write "\n"))
788
789val () = Env.action_one "requireGroup"
790 ("groups", Env.list Env.string)
791 (fn names =>
792 case names of
793 [] => ()
794 | _ => (write "\tRequire group";
795 app (fn name => (write " "; write name)) names;
796 write "\n"))
797
798val () = Env.action_none "orderAllowDeny"
799 (fn () => write "\tOrder allow,deny\n")
800
801val () = Env.action_none "orderDenyAllow"
802 (fn () => write "\tOrder deny,allow\n")
803
804val () = Env.action_none "allowFromAll"
805 (fn () => write "\tAllow from all\n")
806
807val () = Env.action_one "allowFrom"
808 ("entries", Env.list Env.string)
809 (fn names =>
810 case names of
811 [] => ()
812 | _ => (write "\tAllow from";
813 app (fn name => (write " "; write name)) names;
814 write "\n"))
815
816val () = Env.action_none "denyFromAll"
817 (fn () => write "\tDeny from all\n")
818
819val () = Env.action_one "denyFrom"
820 ("entries", Env.list Env.string)
821 (fn names =>
822 case names of
823 [] => ()
824 | _ => (write "\tDeny from";
825 app (fn name => (write " "; write name)) names;
826 write "\n"))
827
828val () = Env.action_none "satisfyAll"
829 (fn () => write "\tSatisfy all\n")
830
831val () = Env.action_none "satisfyAny"
832 (fn () => write "\tSatisfy any\n")
833
7f012ffd
AC		 834val () = Env.action_one "forceType"
835 ("type", Env.string)
836 (fn ty => (write "\tForceType ";
837 write ty;
838 write "\n"))
839
840val () = Env.action_none "forceTypeOff"
841 (fn () => write "\tForceType None\n")
842
843val () = Env.action_two "action"
844 ("what", Env.string, "how", Env.string)
845 (fn (what, how) => (write "\tAction ";
846 write what;
847 write " ";
848 write how;
849 write "\n"))
850
851val () = Env.action_one "addDefaultCharset"
852 ("charset", Env.string)
853 (fn ty => (write "\tAddDefaultCharset ";
854 write ty;
855 write "\n"))
856
64e85bae 857(*val () = Env.action_one "davSvn"
c8505e59
AC		 858 ("path", Env.string)
859 (fn path => (write "\tDAV svn\n\tSVNPath ";
860 write path;
861 write "\n"))
862
863val () = Env.action_one "authzSvnAccessFile"
864 ("path", Env.string)
865 (fn path => (write "\tAuthzSVNAccessFile ";
866 write path;
64e85bae 867 write "\n"))*)
c8505e59 868
0aed4302
AC		 869val () = Env.action_none "davFilesystem"
870 (fn path => write "\tDAV filesystem\n")
871
9d7fa346
AC		 872val () = Env.action_two "addDescription"
873 ("description", Env.string, "patterns", Env.list Env.string)
874 (fn (desc, pats) =>
875 case pats of
876 [] => ()
877 | _ => (write "\tAddDescription \"";
878 write (String.toString desc);
879 write "\"";
880 app (fn pat => (write " "; write pat)) pats;
881 write "\n"))
882
883val () = Env.action_one "indexOptions"
884 ("options", Env.list autoindex_option)
885 (fn opts =>
886 case opts of
887 [] => ()
888 | _ => (write "\tIndexOptions";
889 app (fn (opt, arg) =>
890 (write " ";
891 write opt;
892 Option.app (fn arg =>
893 (write "="; write arg)) arg)) opts;
894 write "\n"))
895
896val () = Env.action_one "set_indexOptions"
897 ("options", Env.list autoindex_option)
898 (fn opts =>
899 case opts of
900 [] => ()
901 | _ => (write "\tIndexOptions";
902 app (fn (opt, arg) =>
903 (write " +";
904 write opt;
905 Option.app (fn arg =>
906 (write "="; write arg)) arg)) opts;
907 write "\n"))
908
909val () = Env.action_one "unset_indexOptions"
910 ("options", Env.list autoindex_option)
911 (fn opts =>
912 case opts of
913 [] => ()
914 | _ => (write "\tIndexOptions";
915 app (fn (opt, _) =>
916 (write " -";
917 write opt)) opts;
918 write "\n"))
919
920val () = Env.action_one "headerName"
921 ("name", Env.string)
922 (fn name => (write "\tHeaderName ";
923 write name;
924 write "\n"))
925
926val () = Env.action_one "readmeName"
927 ("name", Env.string)
928 (fn name => (write "\tReadmeName ";
929 write name;
930 write "\n"))
931
eda33894
AC		 932val () = Env.action_two "setEnv"
933 ("key", Env.string, "value", Env.string)
934 (fn (key, value) => (write "\tSetEnv \"";
935 write key;
936 write "\" \"";
ca6ffb3f
AC		 937 write (String.translate (fn #"\"" => "\\\""
938 | ch => str ch) value);
eda33894
AC		 939 write "\"\n"))
940
71420f8b
AC		 941val () = Domain.registerResetLocal (fn () =>
942 ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*")))
943
41c58daf
AC		 944val () = Domain.registerDescriber (Domain.considerAll
945 [Domain.Extension {extension = "vhost",
d936cf4d 946 heading = fn host => "Web vhost " ^ host ^ ":"},
41c58daf 947 Domain.Extension {extension = "vhost_ssl",
d936cf4d 948 heading = fn host => "SSL web vhost " ^ host ^ ":"}])
41c58daf 949
8a7c40fa 950end
Unnamed repository; edit this file to name it for gitweb.