Ran successful client/server interaction on deleuze
[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 =
234b917a
AC
30 let
31 val prog = Parse.parse fname
32 in
33 if !ErrorMsg.anyErrors then
d189ec0e 34 G
234b917a 35 else
aa56e112 36 Tycheck.checkFile G (Defaults.tInit ()) prog
a3698041
AC
37 end
38
d189ec0e 39fun basis () =
a3698041 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
6bb366c5
AC
66 val uid = Posix.ProcEnv.getuid ()
67 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
68
69 val () = Acl.read Config.aclFile
70 val () = Domain.setUser user
71
d189ec0e 72 val _ = ErrorMsg.reset ()
12adf55a 73 val _ = Env.preTycheck ()
d189ec0e
AC
74
75 val b = basis ()
a3698041
AC
76 in
77 if !ErrorMsg.anyErrors then
36e42cb8 78 raise ErrorMsg.Error
a3698041
AC
79 else
80 let
7f012ffd 81 val _ = ErrorMsg.reset ()
d189ec0e 82 val prog = Parse.parse fname
a3698041 83 in
492c1cff 84 if !ErrorMsg.anyErrors then
36e42cb8 85 raise ErrorMsg.Error
492c1cff 86 else
d189ec0e 87 let
aa56e112 88 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
d189ec0e 89 in
36e42cb8
AC
90 if !ErrorMsg.anyErrors then
91 raise ErrorMsg.Error
92 else
93 (G', #3 prog)
d189ec0e 94 end
234b917a
AC
95 end
96 end
97
d189ec0e 98fun reduce fname =
a3698041 99 let
d189ec0e 100 val (G, body) = check fname
a3698041
AC
101 in
102 if !ErrorMsg.anyErrors then
d189ec0e 103 NONE
a3698041 104 else
d189ec0e
AC
105 case body of
106 SOME body =>
107 let
108 val body' = Reduce.reduceExp G body
109 in
110 (*printd (PD.hovBox (PD.PPS.Rel 0,
111 [PD.string "Result:",
112 PD.space 1,
113 p_exp body']))*)
114 SOME body'
115 end
116 | _ => NONE
a3698041
AC
117 end
118
d189ec0e
AC
119fun eval fname =
120 case reduce fname of
121 (SOME body') =>
122 if !ErrorMsg.anyErrors then
36e42cb8 123 raise ErrorMsg.Error
d189ec0e 124 else
aa56e112 125 Eval.exec (Defaults.eInit ()) body'
36e42cb8 126 | NONE => raise ErrorMsg.Error
d189ec0e 127
3b267643
AC
128val dispatcher =
129 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
559e89e9 130
36e42cb8
AC
131fun hostname () =
132 let
133 val inf = TextIO.openIn "/etc/hostname"
134 in
135 case TextIO.inputLine inf of
136 NONE => (TextIO.closeIn inf; raise Fail "No line in /etc/hostname")
137 | SOME line => (TextIO.closeIn inf; String.substring (line, 0, size line - 1))
138 end
139
3b267643 140fun request fname =
07cc384c 141 let
6bb366c5
AC
142 val _ = check fname
143
aa56e112
AC
144 val uid = Posix.ProcEnv.getuid ()
145 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
146
aa56e112
AC
147 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
148 Config.keyDir ^ "/" ^ user ^ ".pem",
3b267643 149 Config.trustStore)
07cc384c 150
3b267643 151 val bio = OpenSSL.connect (context, dispatcher)
559e89e9 152
3b267643
AC
153 val inf = TextIO.openIn fname
154
36e42cb8 155 fun loop lines =
3b267643 156 case TextIO.inputLine inf of
36e42cb8
AC
157 NONE => String.concat (List.rev lines)
158 | SOME line => loop (line :: lines)
159
160 val code = loop []
559e89e9 161 in
3b267643 162 TextIO.closeIn inf;
36e42cb8
AC
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";
3b267643 171 OpenSSL.close bio
559e89e9 172 end
aa56e112 173 handle ErrorMsg.Error => ()
559e89e9 174
3b267643 175fun service () =
07cc384c 176 let
aa56e112
AC
177 val () = Acl.read Config.aclFile
178
3b267643
AC
179 val context = OpenSSL.context (Config.serverCert,
180 Config.serverKey,
181 Config.trustStore)
36e42cb8 182 val _ = Domain.set_context context
3b267643 183
60534712 184 val sock = OpenSSL.listen (context, Config.dispatcherPort)
3b267643
AC
185
186 fun loop () =
60534712 187 case OpenSSL.accept sock of
3b267643
AC
188 NONE => ()
189 | SOME bio =>
190 let
aa56e112
AC
191 val user = OpenSSL.peerCN bio
192 val () = print ("\nConnection from " ^ user ^ "\n")
193 val () = Domain.setUser user
194
36e42cb8
AC
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"
3b267643 207
36e42cb8
AC
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 in
361a1e7f 241 print "Listening for connections....\n";
36e42cb8
AC
242 loop ();
243 OpenSSL.shutdown sock
244 end
245
246fun slave () =
247 let
248 val host = hostname ()
249
250 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
251 Config.keyDir ^ "/" ^ host ^ ".pem",
252 Config.trustStore)
253
254 val sock = OpenSSL.listen (context, Config.slavePort)
255
256 fun loop () =
257 case OpenSSL.accept sock of
258 NONE => ()
259 | SOME bio =>
260 let
261 val peer = OpenSSL.peerCN bio
262 val () = print ("\nConnection from " ^ peer ^ "\n")
3b267643 263 in
36e42cb8
AC
264 if peer <> Config.dispatcherName then
265 (print "Not authorized!\n";
266 OpenSSL.close bio;
267 loop ())
268 else let
269 fun loop' files =
270 case Msg.recv bio of
271 NONE => print "Dispatcher closed connection unexpectedly\n"
272 | SOME m =>
273 case m of
274 MsgFile file => loop' (file :: files)
275 | MsgDoFiles => (Slave.handleChanges files;
276 Msg.send (bio, MsgOk))
277 | _ => (print "Dispatcher sent unexpected command\n";
278 Msg.send (bio, MsgError "Unexpected command"))
279 in
280 loop' [];
281 ignore (OpenSSL.readChar bio);
282 OpenSSL.close bio;
283 loop ()
284 end
3196000d
AC
285 end handle OpenSSL.OpenSSL s =>
286 (print ("OpenSSL error: "^ s ^ "\n");
287 OpenSSL.close bio
288 handle OpenSSL.OpenSSL _ => ();
289 loop ())
07cc384c 290 in
3b267643
AC
291 loop ();
292 OpenSSL.shutdown sock
07cc384c
AC
293 end
294
3196000d
AC
295fun autodocBasis outdir =
296 let
297 val dir = Posix.FileSys.opendir Config.libRoot
298
299 fun loop files =
300 case Posix.FileSys.readdir dir of
301 NONE => (Posix.FileSys.closedir dir;
302 files)
303 | SOME fname =>
304 if String.isSuffix ".dtl" fname then
305 loop (OS.Path.joinDirFile {dir = Config.libRoot,
306 file = fname}
307 :: files)
308 else
309 loop files
310
311 val files = loop []
312 in
313 Autodoc.autodoc {outdir = outdir, infiles = files}
314 end
315
234b917a 316end