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