More Apache directory option stuff
[hcoop/domtool2.git] / src / plugins / apache.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, Adam Chlipala
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
21 structure Apache :> APACHE = struct
22
23 open Ast
24
25 val _ = Env.type_one "proxy_port"
26 Env.int
27 (fn n => n > 1024)
28
29 val _ = Env.type_one "proxy_target"
30 Env.string
31 (fn s =>
32 let
33 fun default () = List.exists (fn s' => s = s') Config.Apache.proxyTargets
34 in
35 case String.fields (fn ch => ch = #":") s of
36 ["http", "//localhost", rest] =>
37 (case String.fields (fn ch => ch = #"/") rest of
38 port :: _ =>
39 (case Int.fromString port of
40 NONE => default ()
41 | SOME n => n > 1024 orelse default ())
42 | _ => default ())
43 | _ => default ()
44 end)
45
46 val _ = Env.type_one "rewrite_arg"
47 Env.string
48 (CharVector.all Char.isAlphaNum)
49
50 fun validLocation s =
51 size s > 0 andalso size s < 1000 andalso CharVector.all
52 (fn ch => Char.isAlphaNum ch
53 orelse ch = #"-"
54 orelse ch = #"_"
55 orelse ch = #"."
56 orelse ch = #"/") s
57
58 val _ = Env.type_one "location"
59 Env.string
60 validLocation
61
62 val dl = ErrorMsg.dummyLoc
63
64 val _ = Main.registerDefault ("WebNodes",
65 (TList (TBase "node", dl), dl),
66 (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes), dl)))
67
68 val _ = Main.registerDefault ("SSL",
69 (TBase "bool", dl),
70 (fn () => (EVar "false", dl)))
71
72 val _ = Main.registerDefault ("User",
73 (TBase "your_user", dl),
74 (fn () => (EString (Domain.getUser ()), dl)))
75
76 val _ = Main.registerDefault ("Group",
77 (TBase "your_group", dl),
78 (fn () => (EString (Domain.getUser ()), dl)))
79
80 val _ = Main.registerDefault ("DocumentRoot",
81 (TBase "your_path", dl),
82 (fn () => (EString ("/home/" ^ Domain.getUser () ^ "/public_html"), dl)))
83
84 val _ = Main.registerDefault ("ServerAdmin",
85 (TBase "email", dl),
86 (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl)))
87
88
89 val redirect_code = fn (EVar "temp", _) => SOME "temp"
90 | (EVar "permanent", _) => SOME "permanent"
91 | (EVar "seeother", _) => SOME "seeother"
92 | (EVar "redir300", _) => SOME "300"
93 | (EVar "redir301", _) => SOME "301"
94 | (EVar "redir302", _) => SOME "302"
95 | (EVar "redir303", _) => SOME "303"
96 | (EVar "redir304", _) => SOME "304"
97 | (EVar "redir305", _) => SOME "305"
98 | (EVar "redir307", _) => SOME "307"
99 | _ => NONE
100
101 val flag = fn (EVar "redirect", _) => SOME "R"
102 | (EVar "forbidden", _) => SOME "F"
103 | (EVar "gone", _) => SOME "G"
104 | (EVar "last", _) => SOME "L"
105 | (EVar "chain", _) => SOME "C"
106 | (EVar "nosubreq", _) => SOME "NS"
107 | (EVar "nocase", _) => SOME "NC"
108 | (EVar "qsappend", _) => SOME "QSA"
109 | (EVar "noescape", _) => SOME "NE"
110 | (EVar "passthrough", _) => SOME "PT"
111 | (EApp ((EVar "mimeType", _), e), _) =>
112 Option.map (fn s => "T=" ^ s) (Env.string e)
113 | (EApp ((EVar "redirectWith", _), e), _) =>
114 Option.map (fn s => "R=" ^ s) (redirect_code e)
115 | (EApp ((EVar "skip", _), e), _) =>
116 Option.map (fn n => "S=" ^ Int.toString n) (Env.int e)
117 | (EApp ((EApp ((EVar "env", _), e1), _), e2), _) =>
118 (case Env.string e1 of
119 NONE => NONE
120 | SOME s1 => Option.map (fn s2 => "E=" ^ s1 ^ ":" ^ s2)
121 (Env.string e2))
122
123 | _ => NONE
124
125 val cond_flag = fn (EVar "cond_nocase", _) => SOME "NC"
126 | (EVar "ornext", _) => SOME "OR"
127 | _ => NONE
128
129 val apache_option = fn (EVar "execCGI", _) => SOME "ExecCGI"
130 | (EVar "includesNOEXEC", _) => SOME "IncludesNOEXEC"
131 | (EVar "indexes", _) => SOME "Indexes"
132 | _ => NONE
133
134
135 val vhostsChanged = ref false
136
137 val () = Slave.registerPreHandler
138 (fn () => vhostsChanged := false)
139
140 val () = Slave.registerFileHandler (fn fs =>
141 let
142 val spl = OS.Path.splitDirFile (#file fs)
143 in
144 if String.isSuffix ".vhost" (#file spl)
145 orelse String.isSuffix ".vhost_ssl" (#file spl) then
146 (vhostsChanged := true;
147 case #action fs of
148 Slave.Delete =>
149 ignore (OS.Process.system (Config.rm
150 ^ " -rf "
151 ^ Config.Apache.confDir
152 ^ "/"
153 ^ #file spl))
154 | _ =>
155 ignore (OS.Process.system (Config.cp
156 ^ " "
157 ^ #file fs
158 ^ " "
159 ^ Config.Apache.confDir
160 ^ "/"
161 ^ #file spl)))
162 else
163 ()
164 end)
165
166 val () = Slave.registerPostHandler
167 (fn () =>
168 (if !vhostsChanged then
169 Slave.shellF ([Config.Apache.reload],
170 fn cl => "Error reloading Apache with " ^ cl)
171 else
172 ()))
173
174 val vhostFiles : TextIO.outstream list ref = ref []
175 fun write s = app (fn file => TextIO.output (file, s)) (!vhostFiles)
176
177 val rewriteEnabled = ref false
178
179 val () = Env.containerV_one "vhost"
180 ("host", Env.string)
181 (fn (env, host) =>
182 let
183 val nodes = Env.env (Env.list Env.string) (env, "WebNodes")
184
185 val ssl = Env.env Env.bool (env, "SSL")
186 val user = Env.env Env.string (env, "User")
187 val group = Env.env Env.string (env, "Group")
188 val docroot = Env.env Env.string (env, "DocumentRoot")
189 val sadmin = Env.env Env.string (env, "ServerAdmin")
190
191 val fullHost = host ^ "." ^ Domain.currentDomain ()
192 val confFile = fullHost ^ (if ssl then ".vhost_ssl" else ".vhost")
193 in
194 rewriteEnabled := false;
195 vhostFiles := map (fn node =>
196 let
197 val file = Domain.domainFile {node = node,
198 name = confFile}
199 in
200 TextIO.output (file, "<VirtualHost ");
201 TextIO.output (file, Domain.nodeIp node);
202 TextIO.output (file, ":");
203 TextIO.output (file, if ssl then
204 "443"
205 else
206 "80");
207 TextIO.output (file, ">\n");
208 file
209 end)
210 nodes;
211 write "\tServerName ";
212 write fullHost;
213 write "\n\tSuexecUserGroup ";
214 write user;
215 write " ";
216 write group;
217 write "\n\tDocumentRoot ";
218 write docroot;
219 write "\n\tServerAdmin ";
220 write sadmin;
221 write "\n"
222 end,
223 fn () => (write "</VirtualHost>\n";
224 app TextIO.closeOut (!vhostFiles)))
225
226 val () = Env.container_one "location"
227 ("prefix", Env.string)
228 (fn prefix =>
229 (write "\t<Location ";
230 write prefix;
231 write ">\n"),
232 fn () => write "\t</Location>\n")
233
234 val () = Env.container_one "directory"
235 ("directory", Env.string)
236 (fn directory =>
237 (write "\t<Directory ";
238 write directory;
239 write ">\n"),
240 fn () => write "\t</Directory>\n")
241
242 fun checkRewrite () =
243 if !rewriteEnabled then
244 ()
245 else
246 (write "\tRewriteEngine on\n";
247 rewriteEnabled := true)
248
249 val () = Env.action_three "localProxyRewrite"
250 ("from", Env.string, "to", Env.string, "port", Env.int)
251 (fn (from, to, port) =>
252 (checkRewrite ();
253 write "\tRewriteRule\t";
254 write from;
255 write "\thttp://localhost:";
256 write (Int.toString port);
257 write "/";
258 write to;
259 write " [P]\n"))
260
261 val () = Env.action_two "proxyPass"
262 ("from", Env.string, "to", Env.string)
263 (fn (from, to) =>
264 (write "\tProxyPass\t";
265 write from;
266 write "\t";
267 write to;
268 write "\n"))
269
270 val () = Env.action_two "proxyPassReverse"
271 ("from", Env.string, "to", Env.string)
272 (fn (from, to) =>
273 (write "\tProxyPassReverse\t";
274 write from;
275 write "\t";
276 write to;
277 write "\n"))
278
279 val () = Env.action_three "rewriteRule"
280 ("from", Env.string, "to", Env.string, "flags", Env.list flag)
281 (fn (from, to, flags) =>
282 (checkRewrite ();
283 write "\tRewriteRule\t";
284 write from;
285 write "\t";
286 write to;
287 case flags of
288 [] => ()
289 | flag::rest => (write " [";
290 write flag;
291 app (fn flag => (write ",";
292 write flag)) rest;
293 write "]");
294 write "\n"))
295
296 val () = Env.action_three "rewriteCond"
297 ("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
298 (fn (from, to, flags) =>
299 (checkRewrite ();
300 write "\tRewriteCond\t";
301 write from;
302 write "\t";
303 write to;
304 case flags of
305 [] => ()
306 | flag::rest => (write " [";
307 write flag;
308 app (fn flag => (write ",";
309 write flag)) rest;
310 write "]");
311 write "\n"))
312
313 val () = Env.action_two "alias"
314 ("from", Env.string, "to", Env.string)
315 (fn (from, to) =>
316 (write "\tAlias\t";
317 write from;
318 write " ";
319 write to;
320 write "\n"))
321
322 val () = Env.action_two "scriptAlias"
323 ("from", Env.string, "to", Env.string)
324 (fn (from, to) =>
325 (write "\tScriptAlias\t";
326 write from;
327 write " ";
328 write to;
329 write "\n"))
330
331 val () = Env.action_two "errorDocument"
332 ("code", Env.string, "handler", Env.string)
333 (fn (code, handler) =>
334 (write "\tErrorDocument\t";
335 write code;
336 write " ";
337 write handler;
338 write "\n"))
339
340 val () = Env.action_one "options"
341 ("options", Env.list apache_option)
342 (fn opts =>
343 case opts of
344 [] => ()
345 | _ => (write "\tOptions";
346 app (fn opt => (write " "; write opt)) opts;
347 write "\n"))
348
349 val () = Env.action_one "set_options"
350 ("options", Env.list apache_option)
351 (fn opts =>
352 case opts of
353 [] => ()
354 | _ => (write "\tOptions";
355 app (fn opt => (write " +"; write opt)) opts;
356 write "\n"))
357
358 val () = Env.action_one "unset_options"
359 ("options", Env.list apache_option)
360 (fn opts =>
361 case opts of
362 [] => ()
363 | _ => (write "\tOptions";
364 app (fn opt => (write " -"; write opt)) opts;
365 write "\n"))
366
367 val () = Env.action_one "directoryIndex"
368 ("filenames", Env.list Env.string)
369 (fn opts =>
370 (write "\tDirectoryIndex";
371 app (fn opt => (write " "; write opt)) opts;
372 write "\n"))
373
374 val () = Env.action_one "serverAlias"
375 ("host", Env.string)
376 (fn host =>
377 (write "\tServerAlias ";
378 write host;
379 write "\n"))
380
381 val authType = fn (EVar "basic", _) => SOME "basic"
382 | (EVar "digest", _) => SOME "digest"
383 | _ => NONE
384
385 val () = Env.action_one "authType"
386 ("type", authType)
387 (fn ty =>
388 (write "\tAuthType ";
389 write ty;
390 write "\n"))
391
392 val () = Env.action_one "authName"
393 ("name", Env.string)
394 (fn name =>
395 (write "\tAuthName \"";
396 write name;
397 write "\"\n"))
398
399 val () = Env.action_one "authUserFile"
400 ("file", Env.string)
401 (fn name =>
402 (write "\tAuthUserFile ";
403 write name;
404 write "\n"))
405
406 val () = Env.action_none "requireValidUser"
407 (fn () => write "\tRequire valid-user\n")
408
409 val () = Env.action_one "requireUser"
410 ("users", Env.list Env.string)
411 (fn names =>
412 case names of
413 [] => ()
414 | _ => (write "\tRequire user";
415 app (fn name => (write " "; write name)) names;
416 write "\n"))
417
418 val () = Env.action_one "requireGroup"
419 ("groups", Env.list Env.string)
420 (fn names =>
421 case names of
422 [] => ()
423 | _ => (write "\tRequire group";
424 app (fn name => (write " "; write name)) names;
425 write "\n"))
426
427 val () = Env.action_none "orderAllowDeny"
428 (fn () => write "\tOrder allow,deny\n")
429
430 val () = Env.action_none "orderDenyAllow"
431 (fn () => write "\tOrder deny,allow\n")
432
433 val () = Env.action_none "allowFromAll"
434 (fn () => write "\tAllow from all\n")
435
436 val () = Env.action_one "allowFrom"
437 ("entries", Env.list Env.string)
438 (fn names =>
439 case names of
440 [] => ()
441 | _ => (write "\tAllow from";
442 app (fn name => (write " "; write name)) names;
443 write "\n"))
444
445 val () = Env.action_none "denyFromAll"
446 (fn () => write "\tDeny from all\n")
447
448 val () = Env.action_one "denyFrom"
449 ("entries", Env.list Env.string)
450 (fn names =>
451 case names of
452 [] => ()
453 | _ => (write "\tDeny from";
454 app (fn name => (write " "; write name)) names;
455 write "\n"))
456
457 val () = Env.action_none "satisfyAll"
458 (fn () => write "\tSatisfy all\n")
459
460 val () = Env.action_none "satisfyAny"
461 (fn () => write "\tSatisfy any\n")
462
463 val () = Env.action_one "forceType"
464 ("type", Env.string)
465 (fn ty => (write "\tForceType ";
466 write ty;
467 write "\n"))
468
469 val () = Env.action_none "forceTypeOff"
470 (fn () => write "\tForceType None\n")
471
472 val () = Env.action_two "action"
473 ("what", Env.string, "how", Env.string)
474 (fn (what, how) => (write "\tAction ";
475 write what;
476 write " ";
477 write how;
478 write "\n"))
479
480 val () = Env.action_one "addDefaultCharset"
481 ("charset", Env.string)
482 (fn ty => (write "\tAddDefaultCharset ";
483 write ty;
484 write "\n"))
485
486 end