3c0b7281e8e39f04f43db7cc0c78306584fab145
[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 NONE 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 val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")
96
97 fun checkDir dname =
98 let
99 val b = basis ()
100
101 val dir = Posix.FileSys.opendir dname
102
103 fun loop files =
104 case Posix.FileSys.readdir dir of
105 NONE => (Posix.FileSys.closedir dir;
106 files)
107 | SOME fname =>
108 if notTmp fname then
109 loop (OS.Path.joinDirFile {dir = dname,
110 file = fname}
111 :: files)
112 else
113 loop files
114
115 val files = loop []
116 val (_, files) = Order.order (SOME b) files
117 in
118 if !ErrorMsg.anyErrors then
119 false
120 else
121 (foldl (fn (fname, G) => check' G fname) b files;
122 !ErrorMsg.anyErrors)
123 end
124
125 fun reduce fname =
126 let
127 val (G, body) = check fname
128 in
129 if !ErrorMsg.anyErrors then
130 NONE
131 else
132 case body of
133 SOME body =>
134 let
135 val body' = Reduce.reduceExp G body
136 in
137 (*printd (PD.hovBox (PD.PPS.Rel 0,
138 [PD.string "Result:",
139 PD.space 1,
140 p_exp body']))*)
141 SOME body'
142 end
143 | _ => NONE
144 end
145
146 fun eval fname =
147 case reduce fname of
148 (SOME body') =>
149 if !ErrorMsg.anyErrors then
150 raise ErrorMsg.Error
151 else
152 Eval.exec (Defaults.eInit ()) body'
153 | NONE => raise ErrorMsg.Error
154
155 val dispatcher =
156 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
157
158 fun requestContext f =
159 let
160 val uid = Posix.ProcEnv.getuid ()
161 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
162
163 val () = Acl.read Config.aclFile
164 val () = Domain.setUser user
165
166 val () = f ()
167
168 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
169 Config.keyDir ^ "/" ^ user ^ "/key.pem",
170 Config.trustStore)
171 in
172 (user, context)
173 end
174
175 fun requestBio f =
176 let
177 val (user, context) = requestContext f
178 in
179 (user, OpenSSL.connect (context, dispatcher))
180 end
181
182 fun request fname =
183 let
184 val (user, bio) = requestBio (fn () => ignore (check fname))
185
186 val inf = TextIO.openIn fname
187
188 fun loop lines =
189 case TextIO.inputLine inf of
190 NONE => String.concat (List.rev lines)
191 | SOME line => loop (line :: lines)
192
193 val code = loop []
194 in
195 TextIO.closeIn inf;
196 Msg.send (bio, MsgConfig code);
197 case Msg.recv bio of
198 NONE => print "Server closed connection unexpectedly.\n"
199 | SOME m =>
200 case m of
201 MsgOk => print "Configuration succeeded.\n"
202 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
203 | _ => print "Unexpected server reply.\n";
204 OpenSSL.close bio
205 end
206 handle ErrorMsg.Error => ()
207
208 fun requestDir dname =
209 let
210 val (user, bio) = requestBio (fn () => ignore (checkDir dname))
211
212 val b = basis ()
213
214 val dir = Posix.FileSys.opendir dname
215
216 fun loop files =
217 case Posix.FileSys.readdir dir of
218 NONE => (Posix.FileSys.closedir dir;
219 files)
220 | SOME fname =>
221 if notTmp fname then
222 loop (OS.Path.joinDirFile {dir = dname,
223 file = fname}
224 :: files)
225 else
226 loop files
227
228 val files = loop []
229 val (_, files) = Order.order (SOME b) files
230
231 val _ = if !ErrorMsg.anyErrors then
232 raise ErrorMsg.Error
233 else
234 ()
235
236 val codes = map (fn fname =>
237 let
238 val inf = TextIO.openIn fname
239
240 fun loop lines =
241 case TextIO.inputLine inf of
242 NONE => String.concat (rev lines)
243 | SOME line => loop (line :: lines)
244 in
245 loop []
246 before TextIO.closeIn inf
247 end) files
248 in
249 Msg.send (bio, MsgMultiConfig codes);
250 case Msg.recv bio of
251 NONE => print "Server closed connection unexpectedly.\n"
252 | SOME m =>
253 case m of
254 MsgOk => print "Configuration succeeded.\n"
255 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
256 | _ => print "Unexpected server reply.\n";
257 OpenSSL.close bio
258 end
259 handle ErrorMsg.Error => ()
260
261 fun requestGrant acl =
262 let
263 val (user, bio) = requestBio (fn () => ())
264 in
265 Msg.send (bio, MsgGrant acl);
266 case Msg.recv bio of
267 NONE => print "Server closed connection unexpectedly.\n"
268 | SOME m =>
269 case m of
270 MsgOk => print "Grant succeeded.\n"
271 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
272 | _ => print "Unexpected server reply.\n";
273 OpenSSL.close bio
274 end
275
276 fun requestRevoke acl =
277 let
278 val (user, bio) = requestBio (fn () => ())
279 in
280 Msg.send (bio, MsgRevoke acl);
281 case Msg.recv bio of
282 NONE => print "Server closed connection unexpectedly.\n"
283 | SOME m =>
284 case m of
285 MsgOk => print "Revoke succeeded.\n"
286 | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
287 | _ => print "Unexpected server reply.\n";
288 OpenSSL.close bio
289 end
290
291 fun requestListPerms user =
292 let
293 val (_, bio) = requestBio (fn () => ())
294 in
295 Msg.send (bio, MsgListPerms user);
296 (case Msg.recv bio of
297 NONE => (print "Server closed connection unexpectedly.\n";
298 NONE)
299 | SOME m =>
300 case m of
301 MsgPerms perms => SOME perms
302 | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
303 NONE)
304 | _ => (print "Unexpected server reply.\n";
305 NONE))
306 before OpenSSL.close bio
307 end
308
309 fun requestWhoHas perm =
310 let
311 val (_, bio) = requestBio (fn () => ())
312 in
313 Msg.send (bio, MsgWhoHas perm);
314 (case Msg.recv bio of
315 NONE => (print "Server closed connection unexpectedly.\n";
316 NONE)
317 | SOME m =>
318 case m of
319 MsgWhoHasResponse users => SOME users
320 | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
321 NONE)
322 | _ => (print "Unexpected server reply.\n";
323 NONE))
324 before OpenSSL.close bio
325 end
326
327 fun service () =
328 let
329 val () = Acl.read Config.aclFile
330
331 val context = OpenSSL.context (Config.serverCert,
332 Config.serverKey,
333 Config.trustStore)
334 val _ = Domain.set_context context
335
336 val sock = OpenSSL.listen (context, Config.dispatcherPort)
337
338 fun loop () =
339 case OpenSSL.accept sock of
340 NONE => ()
341 | SOME bio =>
342 let
343 val user = OpenSSL.peerCN bio
344 val () = print ("\nConnection from " ^ user ^ "\n")
345 val () = Domain.setUser user
346
347 fun doConfig codes =
348 let
349 val _ = print "Configuration:\n"
350 val _ = app (fn s => (print s; print "\n")) codes
351 val _ = print "\n"
352
353 val outname = OS.FileSys.tmpName ()
354
355 fun doOne code =
356 let
357 val outf = TextIO.openOut outname
358 in
359 TextIO.output (outf, code);
360 TextIO.closeOut outf;
361 eval outname
362 end
363 in
364 (app doOne codes;
365 Msg.send (bio, MsgOk))
366 handle ErrorMsg.Error =>
367 (print "Compilation error\n";
368 Msg.send (bio,
369 MsgError "Error during configuration evaluation"))
370 | OpenSSL.OpenSSL s =>
371 (print "OpenSSL error\n";
372 Msg.send (bio,
373 MsgError
374 ("Error during configuration evaluation: "
375 ^ s)));
376 OS.FileSys.remove outname;
377 (ignore (OpenSSL.readChar bio);
378 OpenSSL.close bio)
379 handle OpenSSL.OpenSSL _ => ();
380 loop ()
381 end
382
383 fun cmdLoop () =
384 case Msg.recv bio of
385 NONE => (OpenSSL.close bio
386 handle OpenSSL.OpenSSL _ => ();
387 loop ())
388 | SOME m =>
389 case m of
390 MsgConfig code => doConfig [code]
391 | MsgMultiConfig codes => doConfig codes
392
393 | MsgGrant acl =>
394 if Acl.query {user = user, class = "priv", value = "all"} then
395 ((Acl.grant acl;
396 Acl.write Config.aclFile;
397 Msg.send (bio, MsgOk);
398 print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
399 handle OpenSSL.OpenSSL s =>
400 (print "OpenSSL error\n";
401 Msg.send (bio,
402 MsgError
403 ("Error during granting: "
404 ^ s)));
405 (ignore (OpenSSL.readChar bio);
406 OpenSSL.close bio)
407 handle OpenSSL.OpenSSL _ => ();
408 loop ())
409 else
410 ((Msg.send (bio, MsgError "Not authorized to grant privileges");
411 print "Unauthorized user asked to grant a permission!\n";
412 ignore (OpenSSL.readChar bio);
413 OpenSSL.close bio)
414 handle OpenSSL.OpenSSL _ => ();
415 loop ())
416
417 | MsgRevoke acl =>
418 if Acl.query {user = user, class = "priv", value = "all"} then
419 ((Acl.revoke acl;
420 Acl.write Config.aclFile;
421 Msg.send (bio, MsgOk);
422 print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
423 handle OpenSSL.OpenSSL s =>
424 (print "OpenSSL error\n";
425 Msg.send (bio,
426 MsgError
427 ("Error during revocation: "
428 ^ s)));
429 (ignore (OpenSSL.readChar bio);
430 OpenSSL.close bio)
431 handle OpenSSL.OpenSSL _ => ();
432 loop ())
433 else
434 ((Msg.send (bio, MsgError "Not authorized to revoke privileges");
435 print "Unauthorized user asked to revoke a permission!\n";
436 ignore (OpenSSL.readChar bio);
437 OpenSSL.close bio)
438 handle OpenSSL.OpenSSL _ => ();
439 loop ())
440
441 | MsgListPerms user =>
442 ((Msg.send (bio, MsgPerms (Acl.queryAll user));
443 print ("Sent permission list for user " ^ user ^ ".\n"))
444 handle OpenSSL.OpenSSL s =>
445 (print "OpenSSL error\n";
446 Msg.send (bio,
447 MsgError
448 ("Error during permission listing: "
449 ^ s)));
450 (ignore (OpenSSL.readChar bio);
451 OpenSSL.close bio)
452 handle OpenSSL.OpenSSL _ => ();
453 loop ())
454
455 | MsgWhoHas perm =>
456 ((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
457 print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
458 handle OpenSSL.OpenSSL s =>
459 (print "OpenSSL error\n";
460 Msg.send (bio,
461 MsgError
462 ("Error during whohas: "
463 ^ s)));
464 (ignore (OpenSSL.readChar bio);
465 OpenSSL.close bio)
466 handle OpenSSL.OpenSSL _ => ();
467 loop ())
468
469 | _ =>
470 (Msg.send (bio, MsgError "Unexpected command")
471 handle OpenSSL.OpenSSL _ => ();
472 OpenSSL.close bio
473 handle OpenSSL.OpenSSL _ => ();
474 loop ())
475 in
476 cmdLoop ()
477 end
478 handle OpenSSL.OpenSSL s =>
479 (print ("OpenSSL error: " ^ s ^ "\n");
480 OpenSSL.close bio
481 handle OpenSSL.OpenSSL _ => ();
482 loop ())
483 | OS.SysErr (s, _) =>
484 (print ("System error: " ^ s ^ "\n");
485 OpenSSL.close bio
486 handle OpenSSL.OpenSSL _ => ();
487 loop ())
488 in
489 print "Listening for connections....\n";
490 loop ();
491 OpenSSL.shutdown sock
492 end
493
494 fun slave () =
495 let
496 val host = Slave.hostname ()
497
498 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
499 Config.keyDir ^ "/" ^ host ^ "/key.pem",
500 Config.trustStore)
501
502 val sock = OpenSSL.listen (context, Config.slavePort)
503
504 fun loop () =
505 case OpenSSL.accept sock of
506 NONE => ()
507 | SOME bio =>
508 let
509 val peer = OpenSSL.peerCN bio
510 val () = print ("\nConnection from " ^ peer ^ "\n")
511 in
512 if peer <> Config.dispatcherName then
513 (print "Not authorized!\n";
514 OpenSSL.close bio;
515 loop ())
516 else let
517 fun loop' files =
518 case Msg.recv bio of
519 NONE => print "Dispatcher closed connection unexpectedly\n"
520 | SOME m =>
521 case m of
522 MsgFile file => loop' (file :: files)
523 | MsgDoFiles => (Slave.handleChanges files;
524 Msg.send (bio, MsgOk))
525 | _ => (print "Dispatcher sent unexpected command\n";
526 Msg.send (bio, MsgError "Unexpected command"))
527 in
528 loop' [];
529 ignore (OpenSSL.readChar bio);
530 OpenSSL.close bio;
531 loop ()
532 end
533 end handle OpenSSL.OpenSSL s =>
534 (print ("OpenSSL error: "^ s ^ "\n");
535 OpenSSL.close bio
536 handle OpenSSL.OpenSSL _ => ();
537 loop ())
538 | OS.SysErr (s, _) =>
539 (print ("System error: "^ s ^ "\n");
540 OpenSSL.close bio
541 handle OpenSSL.OpenSSL _ => ();
542 loop ())
543 in
544 loop ();
545 OpenSSL.shutdown sock
546 end
547
548 fun autodocBasis outdir =
549 let
550 val dir = Posix.FileSys.opendir Config.libRoot
551
552 fun loop files =
553 case Posix.FileSys.readdir dir of
554 NONE => (Posix.FileSys.closedir dir;
555 files)
556 | SOME fname =>
557 if String.isSuffix ".dtl" fname then
558 loop (OS.Path.joinDirFile {dir = Config.libRoot,
559 file = fname}
560 :: files)
561 else
562 loop files
563
564 val files = loop []
565 in
566 Autodoc.autodoc {outdir = outdir, infiles = files}
567 end
568
569 end