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