mod_dav
[hcoop/domtool2.git] / src / plugins / apache.sml
CommitLineData
8a7c40fa
AC
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
21structure Apache :> APACHE = struct
22
23open Ast
24
f8dfbbcc
AC
25val _ = Env.type_one "proxy_port"
26 Env.int
e95a129e
AC
27 (fn n => n > 1024)
28
29val _ = 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)
f8dfbbcc
AC
45
46val _ = Env.type_one "rewrite_arg"
47 Env.string
48 (CharVector.all Char.isAlphaNum)
49
2882ee37
AC
50fun 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
58val _ = Env.type_one "location"
59 Env.string
60 validLocation
61
8a7c40fa
AC
62val dl = ErrorMsg.dummyLoc
63
64val _ = Main.registerDefault ("WebNodes",
65 (TList (TBase "node", dl), dl),
66 (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes), dl)))
67
68val _ = Main.registerDefault ("SSL",
69 (TBase "bool", dl),
70 (fn () => (EVar "false", dl)))
71
72val _ = Main.registerDefault ("User",
73 (TBase "your_user", dl),
74 (fn () => (EString (Domain.getUser ()), dl)))
75
76val _ = Main.registerDefault ("Group",
77 (TBase "your_group", dl),
78 (fn () => (EString (Domain.getUser ()), dl)))
79
80val _ = Main.registerDefault ("DocumentRoot",
81 (TBase "your_path", dl),
82 (fn () => (EString ("/home/" ^ Domain.getUser () ^ "/public_html"), dl)))
83
84val _ = Main.registerDefault ("ServerAdmin",
85 (TBase "email", dl),
86 (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl)))
87
f8dfbbcc
AC
88
89val 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
101val 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
e95a129e
AC
125val cond_flag = fn (EVar "cond_nocase", _) => SOME "NC"
126 | (EVar "ornext", _) => SOME "OR"
127 | _ => NONE
128
d441e69f
AC
129val apache_option = fn (EVar "execCGI", _) => SOME "ExecCGI"
130 | (EVar "includesNOEXEC", _) => SOME "IncludesNOEXEC"
131 | (EVar "indexes", _) => SOME "Indexes"
132 | _ => NONE
133
f8dfbbcc 134
8a7c40fa
AC
135val vhostsChanged = ref false
136
137val () = Slave.registerPreHandler
138 (fn () => vhostsChanged := false)
139
140val () = 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
166val () = 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
174val vhostFiles : TextIO.outstream list ref = ref []
175fun write s = app (fn file => TextIO.output (file, s)) (!vhostFiles)
176
f8dfbbcc 177val rewriteEnabled = ref false
c98b57cf
AC
178val currentVhost = ref ""
179val currentVhostId = ref ""
f8dfbbcc 180
8a7c40fa
AC
181val () = Env.containerV_one "vhost"
182 ("host", Env.string)
183 (fn (env, host) =>
184 let
185 val nodes = Env.env (Env.list Env.string) (env, "WebNodes")
186
187 val ssl = Env.env Env.bool (env, "SSL")
188 val user = Env.env Env.string (env, "User")
189 val group = Env.env Env.string (env, "Group")
190 val docroot = Env.env Env.string (env, "DocumentRoot")
191 val sadmin = Env.env Env.string (env, "ServerAdmin")
192
193 val fullHost = host ^ "." ^ Domain.currentDomain ()
c98b57cf 194 val vhostId = fullHost ^ (if ssl then ".ssl" else "")
8a7c40fa
AC
195 val confFile = fullHost ^ (if ssl then ".vhost_ssl" else ".vhost")
196 in
c98b57cf
AC
197 currentVhost := fullHost;
198 currentVhostId := vhostId;
199
f8dfbbcc 200 rewriteEnabled := false;
8a7c40fa
AC
201 vhostFiles := map (fn node =>
202 let
203 val file = Domain.domainFile {node = node,
204 name = confFile}
205 in
206 TextIO.output (file, "<VirtualHost ");
207 TextIO.output (file, Domain.nodeIp node);
208 TextIO.output (file, ":");
209 TextIO.output (file, if ssl then
210 "443"
211 else
212 "80");
213 TextIO.output (file, ">\n");
214 file
215 end)
216 nodes;
edd38024
AC
217 write "\tServerName ";
218 write fullHost;
219 write "\n\tSuexecUserGroup ";
8a7c40fa
AC
220 write user;
221 write " ";
222 write group;
223 write "\n\tDocumentRoot ";
224 write docroot;
225 write "\n\tServerAdmin ";
226 write sadmin;
c98b57cf
AC
227 write "\n\tErrorLog ";
228 write Config.Apache.logDir;
229 write "/";
230 write vhostId;
231 write "/error.log\n\tCustomLog ";
232 write Config.Apache.logDir;
233 write "/";
234 write vhostId;
235 write "/access.log combined\n"
8a7c40fa
AC
236 end,
237 fn () => (write "</VirtualHost>\n";
238 app TextIO.closeOut (!vhostFiles)))
239
2882ee37
AC
240val () = Env.container_one "location"
241 ("prefix", Env.string)
242 (fn prefix =>
243 (write "\t<Location ";
244 write prefix;
245 write ">\n"),
246 fn () => write "\t</Location>\n")
247
248val () = Env.container_one "directory"
249 ("directory", Env.string)
250 (fn directory =>
251 (write "\t<Directory ";
252 write directory;
253 write ">\n"),
254 fn () => write "\t</Directory>\n")
255
f8dfbbcc
AC
256fun checkRewrite () =
257 if !rewriteEnabled then
258 ()
259 else
260 (write "\tRewriteEngine on\n";
261 rewriteEnabled := true)
262
263val () = Env.action_three "localProxyRewrite"
264 ("from", Env.string, "to", Env.string, "port", Env.int)
265 (fn (from, to, port) =>
266 (checkRewrite ();
267 write "\tRewriteRule\t";
268 write from;
269 write "\thttp://localhost:";
270 write (Int.toString port);
271 write "/";
272 write to;
273 write " [P]\n"))
274
e95a129e
AC
275val () = Env.action_two "proxyPass"
276 ("from", Env.string, "to", Env.string)
277 (fn (from, to) =>
278 (write "\tProxyPass\t";
279 write from;
280 write "\t";
281 write to;
282 write "\n"))
283
284val () = Env.action_two "proxyPassReverse"
285 ("from", Env.string, "to", Env.string)
286 (fn (from, to) =>
287 (write "\tProxyPassReverse\t";
288 write from;
289 write "\t";
290 write to;
291 write "\n"))
f8dfbbcc
AC
292
293val () = Env.action_three "rewriteRule"
294 ("from", Env.string, "to", Env.string, "flags", Env.list flag)
295 (fn (from, to, flags) =>
296 (checkRewrite ();
297 write "\tRewriteRule\t";
298 write from;
299 write "\t";
300 write to;
301 case flags of
302 [] => ()
303 | flag::rest => (write " [";
304 write flag;
305 app (fn flag => (write ",";
306 write flag)) rest;
307 write "]");
308 write "\n"))
309
e95a129e
AC
310val () = Env.action_three "rewriteCond"
311 ("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
312 (fn (from, to, flags) =>
313 (checkRewrite ();
314 write "\tRewriteCond\t";
315 write from;
316 write "\t";
317 write to;
318 case flags of
319 [] => ()
320 | flag::rest => (write " [";
321 write flag;
322 app (fn flag => (write ",";
323 write flag)) rest;
324 write "]");
325 write "\n"))
326
c98b57cf
AC
327val () = Env.action_one "rewriteLogLevel"
328 ("level", Env.int)
329 (fn level =>
330 (checkRewrite ();
331 write "\tRewriteLog ";
332 write Config.Apache.logDir;
333 write "/";
334 write (!currentVhostId);
335 write "/rewrite.log\n\tRewriteLogLevel ";
336 write (Int.toString level);
337 write "\n"))
338
d5754b53
AC
339val () = Env.action_two "alias"
340 ("from", Env.string, "to", Env.string)
341 (fn (from, to) =>
342 (write "\tAlias\t";
343 write from;
344 write " ";
345 write to;
346 write "\n"))
347
348val () = Env.action_two "scriptAlias"
349 ("from", Env.string, "to", Env.string)
350 (fn (from, to) =>
351 (write "\tScriptAlias\t";
352 write from;
353 write " ";
354 write to;
355 write "\n"))
356
357val () = Env.action_two "errorDocument"
358 ("code", Env.string, "handler", Env.string)
359 (fn (code, handler) =>
360 (write "\tErrorDocument\t";
361 write code;
362 write " ";
363 write handler;
364 write "\n"))
365
d441e69f
AC
366val () = Env.action_one "options"
367 ("options", Env.list apache_option)
368 (fn opts =>
369 case opts of
370 [] => ()
371 | _ => (write "\tOptions";
372 app (fn opt => (write " "; write opt)) opts;
373 write "\n"))
374
375val () = Env.action_one "set_options"
376 ("options", Env.list apache_option)
377 (fn opts =>
378 case opts of
379 [] => ()
380 | _ => (write "\tOptions";
381 app (fn opt => (write " +"; write opt)) opts;
382 write "\n"))
383
384val () = Env.action_one "unset_options"
385 ("options", Env.list apache_option)
386 (fn opts =>
387 case opts of
388 [] => ()
389 | _ => (write "\tOptions";
390 app (fn opt => (write " -"; write opt)) opts;
391 write "\n"))
d5754b53 392
edd38024
AC
393val () = Env.action_one "directoryIndex"
394 ("filenames", Env.list Env.string)
395 (fn opts =>
396 (write "\tDirectoryIndex";
397 app (fn opt => (write " "; write opt)) opts;
398 write "\n"))
399
400val () = Env.action_one "serverAlias"
401 ("host", Env.string)
402 (fn host =>
403 (write "\tServerAlias ";
404 write host;
405 write "\n"))
406
2aeb9eec
AC
407val authType = fn (EVar "basic", _) => SOME "basic"
408 | (EVar "digest", _) => SOME "digest"
409 | _ => NONE
410
411val () = Env.action_one "authType"
412 ("type", authType)
413 (fn ty =>
414 (write "\tAuthType ";
415 write ty;
416 write "\n"))
417
418val () = Env.action_one "authName"
419 ("name", Env.string)
420 (fn name =>
421 (write "\tAuthName \"";
422 write name;
423 write "\"\n"))
424
425val () = Env.action_one "authUserFile"
426 ("file", Env.string)
427 (fn name =>
428 (write "\tAuthUserFile ";
429 write name;
430 write "\n"))
431
432val () = Env.action_none "requireValidUser"
433 (fn () => write "\tRequire valid-user\n")
434
435val () = Env.action_one "requireUser"
436 ("users", Env.list Env.string)
437 (fn names =>
438 case names of
439 [] => ()
440 | _ => (write "\tRequire user";
441 app (fn name => (write " "; write name)) names;
442 write "\n"))
443
444val () = Env.action_one "requireGroup"
445 ("groups", Env.list Env.string)
446 (fn names =>
447 case names of
448 [] => ()
449 | _ => (write "\tRequire group";
450 app (fn name => (write " "; write name)) names;
451 write "\n"))
452
453val () = Env.action_none "orderAllowDeny"
454 (fn () => write "\tOrder allow,deny\n")
455
456val () = Env.action_none "orderDenyAllow"
457 (fn () => write "\tOrder deny,allow\n")
458
459val () = Env.action_none "allowFromAll"
460 (fn () => write "\tAllow from all\n")
461
462val () = Env.action_one "allowFrom"
463 ("entries", Env.list Env.string)
464 (fn names =>
465 case names of
466 [] => ()
467 | _ => (write "\tAllow from";
468 app (fn name => (write " "; write name)) names;
469 write "\n"))
470
471val () = Env.action_none "denyFromAll"
472 (fn () => write "\tDeny from all\n")
473
474val () = Env.action_one "denyFrom"
475 ("entries", Env.list Env.string)
476 (fn names =>
477 case names of
478 [] => ()
479 | _ => (write "\tDeny from";
480 app (fn name => (write " "; write name)) names;
481 write "\n"))
482
483val () = Env.action_none "satisfyAll"
484 (fn () => write "\tSatisfy all\n")
485
486val () = Env.action_none "satisfyAny"
487 (fn () => write "\tSatisfy any\n")
488
7f012ffd
AC
489val () = Env.action_one "forceType"
490 ("type", Env.string)
491 (fn ty => (write "\tForceType ";
492 write ty;
493 write "\n"))
494
495val () = Env.action_none "forceTypeOff"
496 (fn () => write "\tForceType None\n")
497
498val () = Env.action_two "action"
499 ("what", Env.string, "how", Env.string)
500 (fn (what, how) => (write "\tAction ";
501 write what;
502 write " ";
503 write how;
504 write "\n"))
505
506val () = Env.action_one "addDefaultCharset"
507 ("charset", Env.string)
508 (fn ty => (write "\tAddDefaultCharset ";
509 write ty;
510 write "\n"))
511
c8505e59
AC
512val () = Env.action_one "davSvn"
513 ("path", Env.string)
514 (fn path => (write "\tDAV svn\n\tSVNPath ";
515 write path;
516 write "\n"))
517
518val () = Env.action_one "authzSvnAccessFile"
519 ("path", Env.string)
520 (fn path => (write "\tAuthzSVNAccessFile ";
521 write path;
522 write "\n"))
523
8a7c40fa 524end