Increase length limits on domains
[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
917val () = Env.action_one "indexOptions"
918 ("options", Env.list autoindex_option)
919 (fn opts =>
920 case opts of
921 [] => ()
922 | _ => (write "\tIndexOptions";
923 app (fn (opt, arg) =>
924 (write " ";
925 write opt;
926 Option.app (fn arg =>
927 (write "="; write arg)) arg)) opts;
928 write "\n"))
929
930val () = Env.action_one "set_indexOptions"
931 ("options", Env.list autoindex_option)
932 (fn opts =>
933 case opts of
934 [] => ()
935 | _ => (write "\tIndexOptions";
936 app (fn (opt, arg) =>
937 (write " +";
938 write opt;
939 Option.app (fn arg =>
940 (write "="; write arg)) arg)) opts;
941 write "\n"))
942
943val () = Env.action_one "unset_indexOptions"
944 ("options", Env.list autoindex_option)
945 (fn opts =>
946 case opts of
947 [] => ()
948 | _ => (write "\tIndexOptions";
949 app (fn (opt, _) =>
950 (write " -";
951 write opt)) opts;
952 write "\n"))
953
954val () = Env.action_one "headerName"
955 ("name", Env.string)
956 (fn name => (write "\tHeaderName ";
957 write name;
958 write "\n"))
959
960val () = Env.action_one "readmeName"
961 ("name", Env.string)
962 (fn name => (write "\tReadmeName ";
963 write name;
964 write "\n"))
965
eda33894
AC
966val () = Env.action_two "setEnv"
967 ("key", Env.string, "value", Env.string)
968 (fn (key, value) => (write "\tSetEnv \"";
969 write key;
970 write "\" \"";
ca6ffb3f
AC
971 write (String.translate (fn #"\"" => "\\\""
972 | ch => str ch) value);
eda33894
AC
973 write "\"\n"))
974
f0062360
AC
975val () = Env.action_one "diskCache"
976 ("path", Env.string)
977 (fn path => (write "\tCacheEnable disk \"";
978 write path;
979 write "\"\n"))
980
71420f8b
AC
981val () = Domain.registerResetLocal (fn () =>
982 ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*")))
983
41c58daf
AC
984val () = Domain.registerDescriber (Domain.considerAll
985 [Domain.Extension {extension = "vhost",
d936cf4d 986 heading = fn host => "Web vhost " ^ host ^ ":"},
41c58daf 987 Domain.Extension {extension = "vhost_ssl",
d936cf4d 988 heading = fn host => "SSL web vhost " ^ host ^ ":"}])
41c58daf 989
8a7c40fa 990end