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