Be more cautious creating log directories
[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 requestRmdom dom =
328 let
329 val (_, bio) = requestBio (fn () => ())
330 in
331 Msg.send (bio, MsgRmdom dom);
332 case Msg.recv bio of
333 NONE => print "Server closed connection unexpectedly.\n"
334 | SOME m =>
335 case m of
336 MsgOk => print "Removal succeeded.\n"
337 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
338 | _ => print "Unexpected server reply.\n";
339 OpenSSL.close bio
340 end
341
342 fun service () =
343 let
344 val () = Acl.read Config.aclFile
345
346 val context = OpenSSL.context (Config.serverCert,
347 Config.serverKey,
348 Config.trustStore)
349 val _ = Domain.set_context context
350
351 val sock = OpenSSL.listen (context, Config.dispatcherPort)
352
353 fun loop () =
354 case OpenSSL.accept sock of
355 NONE => ()
356 | SOME bio =>
357 let
358 val user = OpenSSL.peerCN bio
359 val () = print ("\nConnection from " ^ user ^ "\n")
360 val () = Domain.setUser user
361
362 fun doConfig codes =
363 let
364 val _ = print "Configuration:\n"
365 val _ = app (fn s => (print s; print "\n")) codes
366 val _ = print "\n"
367
368 val outname = OS.FileSys.tmpName ()
369
370 fun doOne code =
371 let
372 val outf = TextIO.openOut outname
373 in
374 TextIO.output (outf, code);
375 TextIO.closeOut outf;
376 eval outname
377 end
378 in
379 (app doOne codes;
380 Msg.send (bio, MsgOk))
381 handle ErrorMsg.Error =>
382 (print "Compilation error\n";
383 Msg.send (bio,
384 MsgError "Error during configuration evaluation"))
385 | OpenSSL.OpenSSL s =>
386 (print "OpenSSL error\n";
387 Msg.send (bio,
388 MsgError
389 ("Error during configuration evaluation: "
390 ^ s)));
391 OS.FileSys.remove outname;
392 (ignore (OpenSSL.readChar bio);
393 OpenSSL.close bio)
394 handle OpenSSL.OpenSSL _ => ();
395 loop ()
396 end
397
398 fun cmdLoop () =
399 case Msg.recv bio of
400 NONE => (OpenSSL.close bio
401 handle OpenSSL.OpenSSL _ => ();
402 loop ())
403 | SOME m =>
404 case m of
405 MsgConfig code => doConfig [code]
406 | MsgMultiConfig codes => doConfig codes
407
408 | MsgGrant acl =>
409 if Acl.query {user = user, class = "priv", value = "all"} then
410 ((Acl.grant acl;
411 Acl.write Config.aclFile;
412 Msg.send (bio, MsgOk);
413 print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
414 handle OpenSSL.OpenSSL s =>
415 (print "OpenSSL error\n";
416 Msg.send (bio,
417 MsgError
418 ("Error during granting: "
419 ^ s)));
420 (ignore (OpenSSL.readChar bio);
421 OpenSSL.close bio)
422 handle OpenSSL.OpenSSL _ => ();
423 loop ())
424 else
425 ((Msg.send (bio, MsgError "Not authorized to grant privileges");
426 print "Unauthorized user asked to grant a permission!\n";
427 ignore (OpenSSL.readChar bio);
428 OpenSSL.close bio)
429 handle OpenSSL.OpenSSL _ => ();
430 loop ())
431
432 | MsgRevoke acl =>
433 if Acl.query {user = user, class = "priv", value = "all"} then
434 ((Acl.revoke acl;
435 Acl.write Config.aclFile;
436 Msg.send (bio, MsgOk);
437 print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n"))
438 handle OpenSSL.OpenSSL s =>
439 (print "OpenSSL error\n";
440 Msg.send (bio,
441 MsgError
442 ("Error during revocation: "
443 ^ s)));
444 (ignore (OpenSSL.readChar bio);
445 OpenSSL.close bio)
446 handle OpenSSL.OpenSSL _ => ();
447 loop ())
448 else
449 ((Msg.send (bio, MsgError "Not authorized to revoke privileges");
450 print "Unauthorized user asked to revoke a permission!\n";
451 ignore (OpenSSL.readChar bio);
452 OpenSSL.close bio)
453 handle OpenSSL.OpenSSL _ => ();
454 loop ())
455
456 | MsgListPerms user =>
457 ((Msg.send (bio, MsgPerms (Acl.queryAll user));
458 print ("Sent permission list for user " ^ user ^ ".\n"))
459 handle OpenSSL.OpenSSL s =>
460 (print "OpenSSL error\n";
461 Msg.send (bio,
462 MsgError
463 ("Error during permission listing: "
464 ^ s)));
465 (ignore (OpenSSL.readChar bio);
466 OpenSSL.close bio)
467 handle OpenSSL.OpenSSL _ => ();
468 loop ())
469
470 | MsgWhoHas perm =>
471 ((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
472 print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n"))
473 handle OpenSSL.OpenSSL s =>
474 (print "OpenSSL error\n";
475 Msg.send (bio,
476 MsgError
477 ("Error during whohas: "
478 ^ s)));
479 (ignore (OpenSSL.readChar bio);
480 OpenSSL.close bio)
481 handle OpenSSL.OpenSSL _ => ();
482 loop ())
483
484 | MsgRmdom dom =>
485 if Acl.query {user = user, class = "priv", value = "all"}
486 orelse Acl.query {user = user, class = "domain", value = dom} then
487 ((Domain.rmdom dom;
488 Msg.send (bio, MsgOk);
489 print ("Removed domain " ^ dom ^ ".\n"))
490 handle OpenSSL.OpenSSL s =>
491 (print "OpenSSL error\n";
492 Msg.send (bio,
493 MsgError
494 ("Error during revocation: "
495 ^ s)));
496 (ignore (OpenSSL.readChar bio);
497 OpenSSL.close bio)
498 handle OpenSSL.OpenSSL _ => ();
499 loop ())
500 else
501 ((Msg.send (bio, MsgError "Not authorized to remove that domain");
502 print "Unauthorized user asked to remove a domain!\n";
503 ignore (OpenSSL.readChar bio);
504 OpenSSL.close bio)
505 handle OpenSSL.OpenSSL _ => ();
506 loop ())
507
508 | _ =>
509 (Msg.send (bio, MsgError "Unexpected command")
510 handle OpenSSL.OpenSSL _ => ();
511 OpenSSL.close bio
512 handle OpenSSL.OpenSSL _ => ();
513 loop ())
514 in
515 cmdLoop ()
516 end
517 handle OpenSSL.OpenSSL s =>
518 (print ("OpenSSL error: " ^ s ^ "\n");
519 OpenSSL.close bio
520 handle OpenSSL.OpenSSL _ => ();
521 loop ())
522 | OS.SysErr (s, _) =>
523 (print ("System error: " ^ s ^ "\n");
524 OpenSSL.close bio
525 handle OpenSSL.OpenSSL _ => ();
526 loop ())
527 in
528 print "Listening for connections....\n";
529 loop ();
530 OpenSSL.shutdown sock
531 end
532
533 fun slave () =
534 let
535 val host = Slave.hostname ()
536
537 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
538 Config.keyDir ^ "/" ^ host ^ "/key.pem",
539 Config.trustStore)
540
541 val sock = OpenSSL.listen (context, Config.slavePort)
542
543 fun loop () =
544 case OpenSSL.accept sock of
545 NONE => ()
546 | SOME bio =>
547 let
548 val peer = OpenSSL.peerCN bio
549 val () = print ("\nConnection from " ^ peer ^ "\n")
550 in
551 if peer <> Config.dispatcherName then
552 (print "Not authorized!\n";
553 OpenSSL.close bio;
554 loop ())
555 else let
556 fun loop' files =
557 case Msg.recv bio of
558 NONE => print "Dispatcher closed connection unexpectedly\n"
559 | SOME m =>
560 case m of
561 MsgFile file => loop' (file :: files)
562 | MsgDoFiles => (Slave.handleChanges files;
563 Msg.send (bio, MsgOk))
564 | _ => (print "Dispatcher sent unexpected command\n";
565 Msg.send (bio, MsgError "Unexpected command"))
566 in
567 loop' [];
568 ignore (OpenSSL.readChar bio);
569 OpenSSL.close bio;
570 loop ()
571 end
572 end handle OpenSSL.OpenSSL s =>
573 (print ("OpenSSL error: "^ s ^ "\n");
574 OpenSSL.close bio
575 handle OpenSSL.OpenSSL _ => ();
576 loop ())
577 | OS.SysErr (s, _) =>
578 (print ("System error: "^ s ^ "\n");
579 OpenSSL.close bio
580 handle OpenSSL.OpenSSL _ => ();
581 loop ())
582 in
583 loop ();
584 OpenSSL.shutdown sock
585 end
586
587 fun autodocBasis outdir =
588 let
589 val dir = Posix.FileSys.opendir Config.libRoot
590
591 fun loop files =
592 case Posix.FileSys.readdir dir of
593 NONE => (Posix.FileSys.closedir dir;
594 files)
595 | SOME fname =>
596 if String.isSuffix ".dtl" fname then
597 loop (OS.Path.joinDirFile {dir = Config.libRoot,
598 file = fname}
599 :: files)
600 else
601 loop files
602
603 val files = loop []
604 in
605 Autodoc.autodoc {outdir = outdir, infiles = files}
606 end
607
608 end