Changed ProxyPass
[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 val dl = ErrorMsg.dummyLoc
51
52 val _ = Main.registerDefault ("WebNodes",
53 (TList (TBase "node", dl), dl),
54 (fn () => (EList (map (fn s => (EString s, dl)) Config.Apache.webNodes), dl)))
55
56 val _ = Main.registerDefault ("SSL",
57 (TBase "bool", dl),
58 (fn () => (EVar "false", dl)))
59
60 val _ = Main.registerDefault ("User",
61 (TBase "your_user", dl),
62 (fn () => (EString (Domain.getUser ()), dl)))
63
64 val _ = Main.registerDefault ("Group",
65 (TBase "your_group", dl),
66 (fn () => (EString (Domain.getUser ()), dl)))
67
68 val _ = Main.registerDefault ("DocumentRoot",
69 (TBase "your_path", dl),
70 (fn () => (EString ("/home/" ^ Domain.getUser () ^ "/public_html"), dl)))
71
72 val _ = Main.registerDefault ("ServerAdmin",
73 (TBase "email", dl),
74 (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl)))
75
76
77 val redirect_code = fn (EVar "temp", _) => SOME "temp"
78 | (EVar "permanent", _) => SOME "permanent"
79 | (EVar "seeother", _) => SOME "seeother"
80 | (EVar "redir300", _) => SOME "300"
81 | (EVar "redir301", _) => SOME "301"
82 | (EVar "redir302", _) => SOME "302"
83 | (EVar "redir303", _) => SOME "303"
84 | (EVar "redir304", _) => SOME "304"
85 | (EVar "redir305", _) => SOME "305"
86 | (EVar "redir307", _) => SOME "307"
87 | _ => NONE
88
89 val flag = fn (EVar "redirect", _) => SOME "R"
90 | (EVar "forbidden", _) => SOME "F"
91 | (EVar "gone", _) => SOME "G"
92 | (EVar "last", _) => SOME "L"
93 | (EVar "chain", _) => SOME "C"
94 | (EVar "nosubreq", _) => SOME "NS"
95 | (EVar "nocase", _) => SOME "NC"
96 | (EVar "qsappend", _) => SOME "QSA"
97 | (EVar "noescape", _) => SOME "NE"
98 | (EVar "passthrough", _) => SOME "PT"
99 | (EApp ((EVar "mimeType", _), e), _) =>
100 Option.map (fn s => "T=" ^ s) (Env.string e)
101 | (EApp ((EVar "redirectWith", _), e), _) =>
102 Option.map (fn s => "R=" ^ s) (redirect_code e)
103 | (EApp ((EVar "skip", _), e), _) =>
104 Option.map (fn n => "S=" ^ Int.toString n) (Env.int e)
105 | (EApp ((EApp ((EVar "env", _), e1), _), e2), _) =>
106 (case Env.string e1 of
107 NONE => NONE
108 | SOME s1 => Option.map (fn s2 => "E=" ^ s1 ^ ":" ^ s2)
109 (Env.string e2))
110
111 | _ => NONE
112
113 val cond_flag = fn (EVar "cond_nocase", _) => SOME "NC"
114 | (EVar "ornext", _) => SOME "OR"
115 | _ => NONE
116
117
118 val vhostsChanged = ref false
119
120 val () = Slave.registerPreHandler
121 (fn () => vhostsChanged := false)
122
123 val () = Slave.registerFileHandler (fn fs =>
124 let
125 val spl = OS.Path.splitDirFile (#file fs)
126 in
127 if String.isSuffix ".vhost" (#file spl)
128 orelse String.isSuffix ".vhost_ssl" (#file spl) then
129 (vhostsChanged := true;
130 case #action fs of
131 Slave.Delete =>
132 ignore (OS.Process.system (Config.rm
133 ^ " -rf "
134 ^ Config.Apache.confDir
135 ^ "/"
136 ^ #file spl))
137 | _ =>
138 ignore (OS.Process.system (Config.cp
139 ^ " "
140 ^ #file fs
141 ^ " "
142 ^ Config.Apache.confDir
143 ^ "/"
144 ^ #file spl)))
145 else
146 ()
147 end)
148
149 val () = Slave.registerPostHandler
150 (fn () =>
151 (if !vhostsChanged then
152 Slave.shellF ([Config.Apache.reload],
153 fn cl => "Error reloading Apache with " ^ cl)
154 else
155 ()))
156
157 val vhostFiles : TextIO.outstream list ref = ref []
158 fun write s = app (fn file => TextIO.output (file, s)) (!vhostFiles)
159
160 val rewriteEnabled = ref false
161
162 val () = Env.containerV_one "vhost"
163 ("host", Env.string)
164 (fn (env, host) =>
165 let
166 val nodes = Env.env (Env.list Env.string) (env, "WebNodes")
167
168 val ssl = Env.env Env.bool (env, "SSL")
169 val user = Env.env Env.string (env, "User")
170 val group = Env.env Env.string (env, "Group")
171 val docroot = Env.env Env.string (env, "DocumentRoot")
172 val sadmin = Env.env Env.string (env, "ServerAdmin")
173
174 val fullHost = host ^ "." ^ Domain.currentDomain ()
175 val confFile = fullHost ^ (if ssl then ".vhost_ssl" else ".vhost")
176 in
177 rewriteEnabled := false;
178 vhostFiles := map (fn node =>
179 let
180 val file = Domain.domainFile {node = node,
181 name = confFile}
182 in
183 TextIO.output (file, "<VirtualHost ");
184 TextIO.output (file, Domain.nodeIp node);
185 TextIO.output (file, ":");
186 TextIO.output (file, if ssl then
187 "443"
188 else
189 "80");
190 TextIO.output (file, ">\n");
191 file
192 end)
193 nodes;
194 write "\tSuexecUserGroup ";
195 write user;
196 write " ";
197 write group;
198 write "\n\tDocumentRoot ";
199 write docroot;
200 write "\n\tServerAdmin ";
201 write sadmin;
202 write "\n"
203 end,
204 fn () => (write "</VirtualHost>\n";
205 app TextIO.closeOut (!vhostFiles)))
206
207 fun checkRewrite () =
208 if !rewriteEnabled then
209 ()
210 else
211 (write "\tRewriteEngine on\n";
212 rewriteEnabled := true)
213
214 val () = Env.action_three "localProxyRewrite"
215 ("from", Env.string, "to", Env.string, "port", Env.int)
216 (fn (from, to, port) =>
217 (checkRewrite ();
218 write "\tRewriteRule\t";
219 write from;
220 write "\thttp://localhost:";
221 write (Int.toString port);
222 write "/";
223 write to;
224 write " [P]\n"))
225
226 val () = Env.action_two "proxyPass"
227 ("from", Env.string, "to", Env.string)
228 (fn (from, to) =>
229 (write "\tProxyPass\t";
230 write from;
231 write "\t";
232 write to;
233 write "\n"))
234
235 val () = Env.action_two "proxyPassReverse"
236 ("from", Env.string, "to", Env.string)
237 (fn (from, to) =>
238 (write "\tProxyPassReverse\t";
239 write from;
240 write "\t";
241 write to;
242 write "\n"))
243
244 val () = Env.action_three "rewriteRule"
245 ("from", Env.string, "to", Env.string, "flags", Env.list flag)
246 (fn (from, to, flags) =>
247 (checkRewrite ();
248 write "\tRewriteRule\t";
249 write from;
250 write "\t";
251 write to;
252 case flags of
253 [] => ()
254 | flag::rest => (write " [";
255 write flag;
256 app (fn flag => (write ",";
257 write flag)) rest;
258 write "]");
259 write "\n"))
260
261 val () = Env.action_three "rewriteCond"
262 ("test", Env.string, "pattern", Env.string, "flags", Env.list cond_flag)
263 (fn (from, to, flags) =>
264 (checkRewrite ();
265 write "\tRewriteCond\t";
266 write from;
267 write "\t";
268 write to;
269 case flags of
270 [] => ()
271 | flag::rest => (write " [";
272 write flag;
273 app (fn flag => (write ",";
274 write flag)) rest;
275 write "]");
276 write "\n"))
277
278 end