Changing default slaves
[hcoop/domtool2.git] / src / main.sml
... / ...
CommitLineData
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(* Main interface *)
20
21structure Main :> MAIN = struct
22
23open Ast MsgTypes Print
24
25structure SM = StringMap
26
27fun init () = Acl.read Config.aclFile
28
29fun check' G fname =
30 let
31 val prog = Parse.parse fname
32 in
33 if !ErrorMsg.anyErrors then
34 G
35 else
36 Tycheck.checkFile G (Defaults.tInit ()) prog
37 end
38
39fun basis () =
40 let
41 val dir = Posix.FileSys.opendir Config.libRoot
42
43 fun loop files =
44 case Posix.FileSys.readdir dir of
45 NONE => (Posix.FileSys.closedir dir;
46 files)
47 | SOME fname =>
48 if String.isSuffix ".dtl" fname then
49 loop (OS.Path.joinDirFile {dir = Config.libRoot,
50 file = fname}
51 :: files)
52 else
53 loop files
54
55 val files = loop []
56 val (_, files) = Order.order files
57 in
58 if !ErrorMsg.anyErrors then
59 Env.empty
60 else
61 foldl (fn (fname, G) => check' G fname) Env.empty files
62 end
63
64fun check fname =
65 let
66 val _ = ErrorMsg.reset ()
67 val _ = Env.preTycheck ()
68
69 val b = basis ()
70 in
71 if !ErrorMsg.anyErrors then
72 raise ErrorMsg.Error
73 else
74 let
75 val _ = ErrorMsg.reset ()
76 val prog = Parse.parse fname
77 in
78 if !ErrorMsg.anyErrors then
79 raise ErrorMsg.Error
80 else
81 let
82 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
83 in
84 if !ErrorMsg.anyErrors then
85 raise ErrorMsg.Error
86 else
87 (G', #3 prog)
88 end
89 end
90 end
91
92fun reduce fname =
93 let
94 val (G, body) = check fname
95 in
96 if !ErrorMsg.anyErrors then
97 NONE
98 else
99 case body of
100 SOME body =>
101 let
102 val body' = Reduce.reduceExp G body
103 in
104 (*printd (PD.hovBox (PD.PPS.Rel 0,
105 [PD.string "Result:",
106 PD.space 1,
107 p_exp body']))*)
108 SOME body'
109 end
110 | _ => NONE
111 end
112
113fun eval fname =
114 case reduce fname of
115 (SOME body') =>
116 if !ErrorMsg.anyErrors then
117 raise ErrorMsg.Error
118 else
119 Eval.exec (Defaults.eInit ()) body'
120 | NONE => raise ErrorMsg.Error
121
122val dispatcher =
123 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
124
125fun hostname () =
126 let
127 val inf = TextIO.openIn "/etc/hostname"
128 in
129 case TextIO.inputLine inf of
130 NONE => (TextIO.closeIn inf; raise Fail "No line in /etc/hostname")
131 | SOME line => (TextIO.closeIn inf; String.substring (line, 0, size line - 1))
132 end
133
134fun request fname =
135 let
136 val uid = Posix.ProcEnv.getuid ()
137 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
138
139 val () = Acl.read Config.aclFile
140 val () = Domain.setUser user
141
142 val _ = check fname
143
144 val uid = Posix.ProcEnv.getuid ()
145 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
146
147 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
148 Config.keyDir ^ "/" ^ user ^ "/key.pem",
149 Config.trustStore)
150
151 val bio = OpenSSL.connect (context, dispatcher)
152
153 val inf = TextIO.openIn fname
154
155 fun loop lines =
156 case TextIO.inputLine inf of
157 NONE => String.concat (List.rev lines)
158 | SOME line => loop (line :: lines)
159
160 val code = loop []
161 in
162 TextIO.closeIn inf;
163 Msg.send (bio, MsgConfig code);
164 case Msg.recv bio of
165 NONE => print "Server closed connection unexpectedly.\n"
166 | SOME m =>
167 case m of
168 MsgOk => print "Configuration succeeded.\n"
169 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
170 | _ => print "Unexpected server reply.\n";
171 OpenSSL.close bio
172 end
173 handle ErrorMsg.Error => ()
174
175fun service () =
176 let
177 val () = Acl.read Config.aclFile
178
179 val context = OpenSSL.context (Config.serverCert,
180 Config.serverKey,
181 Config.trustStore)
182 val _ = Domain.set_context context
183
184 val sock = OpenSSL.listen (context, Config.dispatcherPort)
185
186 fun loop () =
187 case OpenSSL.accept sock of
188 NONE => ()
189 | SOME bio =>
190 let
191 val user = OpenSSL.peerCN bio
192 val () = print ("\nConnection from " ^ user ^ "\n")
193 val () = Domain.setUser user
194
195 fun cmdLoop () =
196 case Msg.recv bio of
197 NONE => (OpenSSL.close bio
198 handle OpenSSL.OpenSSL _ => ();
199 loop ())
200 | SOME m =>
201 case m of
202 MsgConfig code =>
203 let
204 val _ = print "Configuration:\n"
205 val _ = print code
206 val _ = print "\n"
207
208 val outname = OS.FileSys.tmpName ()
209 val outf = TextIO.openOut outname
210 in
211 TextIO.output (outf, code);
212 TextIO.closeOut outf;
213 (eval outname;
214 Msg.send (bio, MsgOk))
215 handle ErrorMsg.Error =>
216 (print "Compilation error\n";
217 Msg.send (bio,
218 MsgError "Error during configuration evaluation"))
219 | OpenSSL.OpenSSL s =>
220 (print "OpenSSL error\n";
221 Msg.send (bio,
222 MsgError
223 ("Error during configuration evaluation: "
224 ^ s)));
225 OS.FileSys.remove outname;
226 (ignore (OpenSSL.readChar bio);
227 OpenSSL.close bio)
228 handle OpenSSL.OpenSSL _ => ();
229 loop ()
230 end
231 | _ =>
232 (Msg.send (bio, MsgError "Unexpected command")
233 handle OpenSSL.OpenSSL _ => ();
234 OpenSSL.close bio
235 handle OpenSSL.OpenSSL _ => ();
236 loop ())
237 in
238 cmdLoop ()
239 end
240 handle OpenSSL.OpenSSL s =>
241 (print ("OpenSSL error: " ^ s ^ "\n");
242 OpenSSL.close bio
243 handle OpenSSL.OpenSSL _ => ();
244 loop ())
245 | OS.SysErr (s, _) =>
246 (print ("System error: " ^ s ^ "\n");
247 OpenSSL.close bio
248 handle OpenSSL.OpenSSL _ => ();
249 loop ())
250 in
251 print "Listening for connections....\n";
252 loop ();
253 OpenSSL.shutdown sock
254 end
255
256fun slave () =
257 let
258 val host = hostname ()
259
260 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
261 Config.keyDir ^ "/" ^ host ^ "/key.pem",
262 Config.trustStore)
263
264 val sock = OpenSSL.listen (context, Config.slavePort)
265
266 fun loop () =
267 case OpenSSL.accept sock of
268 NONE => ()
269 | SOME bio =>
270 let
271 val peer = OpenSSL.peerCN bio
272 val () = print ("\nConnection from " ^ peer ^ "\n")
273 in
274 if peer <> Config.dispatcherName then
275 (print "Not authorized!\n";
276 OpenSSL.close bio;
277 loop ())
278 else let
279 fun loop' files =
280 case Msg.recv bio of
281 NONE => print "Dispatcher closed connection unexpectedly\n"
282 | SOME m =>
283 case m of
284 MsgFile file => loop' (file :: files)
285 | MsgDoFiles => (Slave.handleChanges files;
286 Msg.send (bio, MsgOk))
287 | _ => (print "Dispatcher sent unexpected command\n";
288 Msg.send (bio, MsgError "Unexpected command"))
289 in
290 loop' [];
291 ignore (OpenSSL.readChar bio);
292 OpenSSL.close bio;
293 loop ()
294 end
295 end handle OpenSSL.OpenSSL s =>
296 (print ("OpenSSL error: "^ s ^ "\n");
297 OpenSSL.close bio
298 handle OpenSSL.OpenSSL _ => ();
299 loop ())
300 | OS.SysErr (s, _) =>
301 (print ("System error: "^ s ^ "\n");
302 OpenSSL.close bio
303 handle OpenSSL.OpenSSL _ => ();
304 loop ())
305 in
306 loop ();
307 OpenSSL.shutdown sock
308 end
309
310fun autodocBasis outdir =
311 let
312 val dir = Posix.FileSys.opendir Config.libRoot
313
314 fun loop files =
315 case Posix.FileSys.readdir dir of
316 NONE => (Posix.FileSys.closedir dir;
317 files)
318 | SOME fname =>
319 if String.isSuffix ".dtl" fname then
320 loop (OS.Path.joinDirFile {dir = Config.libRoot,
321 file = fname}
322 :: files)
323 else
324 loop files
325
326 val files = loop []
327 in
328 Autodoc.autodoc {outdir = outdir, infiles = files}
329 end
330
331end