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