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