Factor error message generation into a separate file; add '-tc' flag to domtool-client
[hcoop/domtool2.git] / src / main.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006-2007, 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 raise ErrorMsg.Error
120 else
121 (foldl (fn (fname, G) => check' G fname) b files;
122 if !ErrorMsg.anyErrors then
123 raise ErrorMsg.Error
124 else
125 ())
126 end
127
128 fun reduce fname =
129 let
130 val (G, body) = check fname
131 in
132 if !ErrorMsg.anyErrors then
133 NONE
134 else
135 case body of
136 SOME body =>
137 let
138 val body' = Reduce.reduceExp G body
139 in
140 (*printd (PD.hovBox (PD.PPS.Rel 0,
141 [PD.string "Result:",
142 PD.space 1,
143 p_exp body']))*)
144 SOME body'
145 end
146 | _ => NONE
147 end
148
149 fun eval fname =
150 case reduce fname of
151 (SOME body') =>
152 if !ErrorMsg.anyErrors then
153 raise ErrorMsg.Error
154 else
155 Eval.exec (Defaults.eInit ()) body'
156 | NONE => raise ErrorMsg.Error
157
158 fun eval' fname =
159 case reduce fname of
160 (SOME body') =>
161 if !ErrorMsg.anyErrors then
162 raise ErrorMsg.Error
163 else
164 ignore (Eval.exec' (Defaults.eInit ()) body')
165 | NONE => raise ErrorMsg.Error
166
167 val dispatcher =
168 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
169
170 val self =
171 "localhost:" ^ Int.toString Config.slavePort
172
173 fun context x =
174 (OpenSSL.context false x)
175 handle e as OpenSSL.OpenSSL _ =>
176 (print "Couldn't find your certificate.\nYou probably haven't been given any Domtool privileges.\n";
177 raise e)
178
179 fun setupUser () =
180 let
181 val user =
182 case Posix.ProcEnv.getenv "DOMTOOL_USER" of
183 NONE =>
184 let
185 val uid = Posix.ProcEnv.getuid ()
186 in
187 Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
188 end
189 | SOME user => user
190 in
191 Acl.read Config.aclFile;
192 Domain.setUser user;
193 user
194 end
195
196 fun requestContext f =
197 let
198 val user = setupUser ()
199
200 val () = f ()
201
202 val context = context (Config.certDir ^ "/" ^ user ^ ".pem",
203 Config.keyDir ^ "/" ^ user ^ "/key.pem",
204 Config.trustStore)
205 in
206 (user, context)
207 end
208
209 fun requestBio f =
210 let
211 val (user, context) = requestContext f
212 in
213 (user, OpenSSL.connect (context, dispatcher))
214 end
215
216 fun requestSlaveBio () =
217 let
218 val (user, context) = requestContext (fn () => ())
219 in
220 (user, OpenSSL.connect (context, self))
221 end
222
223 fun request fname =
224 let
225 val (user, bio) = requestBio (fn () => ignore (check fname))
226
227 val inf = TextIO.openIn fname
228
229 fun loop lines =
230 case TextIO.inputLine inf of
231 NONE => String.concat (List.rev lines)
232 | SOME line => loop (line :: lines)
233
234 val code = loop []
235 in
236 TextIO.closeIn inf;
237 Msg.send (bio, MsgConfig code);
238 case Msg.recv bio of
239 NONE => print "Server closed connection unexpectedly.\n"
240 | SOME m =>
241 case m of
242 MsgOk => print "Configuration succeeded.\n"
243 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
244 | _ => print "Unexpected server reply.\n";
245 OpenSSL.close bio
246 end
247 handle ErrorMsg.Error => ()
248
249 fun requestDir dname =
250 let
251 val _ = if Posix.FileSys.access (dname, []) then
252 ()
253 else
254 (print ("Can't access " ^ dname ^ ".\n");
255 print "Did you mean to run domtool on a specific file, instead of asking for all\n";
256 print "files in your ~/domtool directory?\n";
257 OS.Process.exit OS.Process.failure)
258
259 val _ = ErrorMsg.reset ()
260
261 val (user, bio) = requestBio (fn () => checkDir dname)
262
263 val b = basis ()
264
265 val dir = Posix.FileSys.opendir dname
266
267 fun loop files =
268 case Posix.FileSys.readdir dir of
269 NONE => (Posix.FileSys.closedir dir;
270 files)
271 | SOME fname =>
272 if notTmp fname then
273 loop (OS.Path.joinDirFile {dir = dname,
274 file = fname}
275 :: files)
276 else
277 loop files
278
279 val files = loop []
280 val (_, files) = Order.order (SOME b) files
281
282 val _ = if !ErrorMsg.anyErrors then
283 raise ErrorMsg.Error
284 else
285 ()
286
287 val codes = map (fn fname =>
288 let
289 val inf = TextIO.openIn fname
290
291 fun loop lines =
292 case TextIO.inputLine inf of
293 NONE => String.concat (rev lines)
294 | SOME line => loop (line :: lines)
295 in
296 loop []
297 before TextIO.closeIn inf
298 end) files
299 in
300 if !ErrorMsg.anyErrors then
301 ()
302 else
303 (Msg.send (bio, MsgMultiConfig codes);
304 case Msg.recv bio of
305 NONE => print "Server closed connection unexpectedly.\n"
306 | SOME m =>
307 case m of
308 MsgOk => print "Configuration succeeded.\n"
309 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
310 | _ => print "Unexpected server reply.\n";
311 OpenSSL.close bio)
312 end
313 handle ErrorMsg.Error => ()
314
315 fun requestPing () =
316 let
317 val (_, bio) = requestBio (fn () => ())
318 in
319 OpenSSL.close bio;
320 OS.Process.success
321 end
322 handle _ => OS.Process.failure
323
324 fun requestShutdown () =
325 let
326 val (_, bio) = requestBio (fn () => ())
327 in
328 Msg.send (bio, MsgShutdown);
329 case Msg.recv bio of
330 NONE => print "Server closed connection unexpectedly.\n"
331 | SOME m =>
332 case m of
333 MsgOk => print "Shutdown begun.\n"
334 | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
335 | _ => print "Unexpected server reply.\n";
336 OpenSSL.close bio
337 end
338
339 fun requestSlavePing () =
340 let
341 val (_, bio) = requestSlaveBio ()
342 in
343 OpenSSL.close bio;
344 OS.Process.success
345 end
346 handle _ => OS.Process.failure
347
348 fun requestSlaveShutdown () =
349 let
350 val (_, bio) = requestSlaveBio ()
351 in
352 Msg.send (bio, MsgShutdown);
353 case Msg.recv bio of
354 NONE => print "Server closed connection unexpectedly.\n"
355 | SOME m =>
356 case m of
357 MsgOk => print "Shutdown begun.\n"
358 | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
359 | _ => print "Unexpected server reply.\n";
360 OpenSSL.close bio
361 end
362
363 fun requestGrant acl =
364 let
365 val (user, bio) = requestBio (fn () => ())
366 in
367 Msg.send (bio, MsgGrant acl);
368 case Msg.recv bio of
369 NONE => print "Server closed connection unexpectedly.\n"
370 | SOME m =>
371 case m of
372 MsgOk => print "Grant succeeded.\n"
373 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
374 | _ => print "Unexpected server reply.\n";
375 OpenSSL.close bio
376 end
377
378 fun requestRevoke acl =
379 let
380 val (user, bio) = requestBio (fn () => ())
381 in
382 Msg.send (bio, MsgRevoke acl);
383 case Msg.recv bio of
384 NONE => print "Server closed connection unexpectedly.\n"
385 | SOME m =>
386 case m of
387 MsgOk => print "Revoke succeeded.\n"
388 | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
389 | _ => print "Unexpected server reply.\n";
390 OpenSSL.close bio
391 end
392
393 fun requestListPerms user =
394 let
395 val (_, bio) = requestBio (fn () => ())
396 in
397 Msg.send (bio, MsgListPerms user);
398 (case Msg.recv bio of
399 NONE => (print "Server closed connection unexpectedly.\n";
400 NONE)
401 | SOME m =>
402 case m of
403 MsgPerms perms => SOME perms
404 | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
405 NONE)
406 | _ => (print "Unexpected server reply.\n";
407 NONE))
408 before OpenSSL.close bio
409 end
410
411 fun requestWhoHas perm =
412 let
413 val (_, bio) = requestBio (fn () => ())
414 in
415 Msg.send (bio, MsgWhoHas perm);
416 (case Msg.recv bio of
417 NONE => (print "Server closed connection unexpectedly.\n";
418 NONE)
419 | SOME m =>
420 case m of
421 MsgWhoHasResponse users => SOME users
422 | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
423 NONE)
424 | _ => (print "Unexpected server reply.\n";
425 NONE))
426 before OpenSSL.close bio
427 end
428
429 fun requestRegen () =
430 let
431 val (_, bio) = requestBio (fn () => ())
432 in
433 Msg.send (bio, MsgRegenerate);
434 case Msg.recv bio of
435 NONE => print "Server closed connection unexpectedly.\n"
436 | SOME m =>
437 case m of
438 MsgOk => print "Regeneration succeeded.\n"
439 | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
440 | _ => print "Unexpected server reply.\n";
441 OpenSSL.close bio
442 end
443
444 fun requestRmdom dom =
445 let
446 val (_, bio) = requestBio (fn () => ())
447 in
448 Msg.send (bio, MsgRmdom dom);
449 case Msg.recv bio of
450 NONE => print "Server closed connection unexpectedly.\n"
451 | SOME m =>
452 case m of
453 MsgOk => print "Removal succeeded.\n"
454 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
455 | _ => print "Unexpected server reply.\n";
456 OpenSSL.close bio
457 end
458
459 fun requestRmuser user =
460 let
461 val (_, bio) = requestBio (fn () => ())
462 in
463 Msg.send (bio, MsgRmuser user);
464 case Msg.recv bio of
465 NONE => print "Server closed connection unexpectedly.\n"
466 | SOME m =>
467 case m of
468 MsgOk => print "Removal succeeded.\n"
469 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
470 | _ => print "Unexpected server reply.\n";
471 OpenSSL.close bio
472 end
473
474 fun requestDbUser dbtype =
475 let
476 val (_, bio) = requestBio (fn () => ())
477 in
478 Msg.send (bio, MsgCreateDbUser dbtype);
479 case Msg.recv bio of
480 NONE => print "Server closed connection unexpectedly.\n"
481 | SOME m =>
482 case m of
483 MsgOk => print "Your user has been created.\n"
484 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
485 | _ => print "Unexpected server reply.\n";
486 OpenSSL.close bio
487 end
488
489 fun requestDbPasswd rc =
490 let
491 val (_, bio) = requestBio (fn () => ())
492 in
493 Msg.send (bio, MsgDbPasswd rc);
494 case Msg.recv bio of
495 NONE => print "Server closed connection unexpectedly.\n"
496 | SOME m =>
497 case m of
498 MsgOk => print "Your password has been changed.\n"
499 | MsgError s => print ("Password set failed: " ^ s ^ "\n")
500 | _ => print "Unexpected server reply.\n";
501 OpenSSL.close bio
502 end
503
504 fun requestDbTable p =
505 let
506 val (user, bio) = requestBio (fn () => ())
507 in
508 Msg.send (bio, MsgCreateDbTable p);
509 case Msg.recv bio of
510 NONE => print "Server closed connection unexpectedly.\n"
511 | SOME m =>
512 case m of
513 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
514 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
515 | _ => print "Unexpected server reply.\n";
516 OpenSSL.close bio
517 end
518
519 fun requestListMailboxes domain =
520 let
521 val (_, bio) = requestBio (fn () => ())
522 in
523 Msg.send (bio, MsgListMailboxes domain);
524 (case Msg.recv bio of
525 NONE => Vmail.Error "Server closed connection unexpectedly."
526 | SOME m =>
527 case m of
528 MsgMailboxes users => (Msg.send (bio, MsgOk);
529 Vmail.Listing users)
530 | MsgError s => Vmail.Error ("Creation failed: " ^ s)
531 | _ => Vmail.Error "Unexpected server reply.")
532 before OpenSSL.close bio
533 end
534
535 fun requestNewMailbox p =
536 let
537 val (_, bio) = requestBio (fn () => ())
538 in
539 Msg.send (bio, MsgNewMailbox p);
540 case Msg.recv bio of
541 NONE => print "Server closed connection unexpectedly.\n"
542 | SOME m =>
543 case m of
544 MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
545 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
546 | _ => print "Unexpected server reply.\n";
547 OpenSSL.close bio
548 end
549
550 fun requestPasswdMailbox p =
551 let
552 val (_, bio) = requestBio (fn () => ())
553 in
554 Msg.send (bio, MsgPasswdMailbox p);
555 case Msg.recv bio of
556 NONE => print "Server closed connection unexpectedly.\n"
557 | SOME m =>
558 case m of
559 MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
560 | MsgError s => print ("Set failed: " ^ s ^ "\n")
561 | _ => print "Unexpected server reply.\n";
562 OpenSSL.close bio
563 end
564
565 fun requestRmMailbox p =
566 let
567 val (_, bio) = requestBio (fn () => ())
568 in
569 Msg.send (bio, MsgRmMailbox p);
570 case Msg.recv bio of
571 NONE => print "Server closed connection unexpectedly.\n"
572 | SOME m =>
573 case m of
574 MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
575 | MsgError s => print ("Remove failed: " ^ s ^ "\n")
576 | _ => print "Unexpected server reply.\n";
577 OpenSSL.close bio
578 end
579
580 fun requestSaQuery addr =
581 let
582 val (_, bio) = requestBio (fn () => ())
583 in
584 Msg.send (bio, MsgSaQuery addr);
585 (case Msg.recv bio of
586 NONE => print "Server closed connection unexpectedly.\n"
587 | SOME m =>
588 case m of
589 MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "
590 ^ (if b then "ON" else "OFF") ^ ".\n");
591 Msg.send (bio, MsgOk))
592 | MsgError s => print ("Query failed: " ^ s ^ "\n")
593 | _ => print "Unexpected server reply.\n")
594 before OpenSSL.close bio
595 end
596
597 fun requestSaSet p =
598 let
599 val (_, bio) = requestBio (fn () => ())
600 in
601 Msg.send (bio, MsgSaSet p);
602 case Msg.recv bio of
603 NONE => print "Server closed connection unexpectedly.\n"
604 | SOME m =>
605 case m of
606 MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "
607 ^ (if #2 p then "ON" else "OFF") ^ ".\n")
608 | MsgError s => print ("Set failed: " ^ s ^ "\n")
609 | _ => print "Unexpected server reply.\n";
610 OpenSSL.close bio
611 end
612
613 fun requestSmtpLog domain =
614 let
615 val (_, bio) = requestBio (fn () => ())
616
617 val _ = Msg.send (bio, MsgSmtpLogReq domain)
618
619 fun loop () =
620 case Msg.recv bio of
621 NONE => print "Server closed connection unexpectedly.\n"
622 | SOME m =>
623 case m of
624 MsgOk => ()
625 | MsgSmtpLogRes line => (print line;
626 loop ())
627 | MsgError s => print ("Log search failed: " ^ s ^ "\n")
628 | _ => print "Unexpected server reply.\n"
629 in
630 loop ();
631 OpenSSL.close bio
632 end
633
634 fun requestApt {node, pkg} =
635 let
636 val (user, context) = requestContext (fn () => ())
637 val bio = OpenSSL.connect (context, if node = Config.masterNode then
638 dispatcher
639 else
640 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
641
642 val _ = Msg.send (bio, MsgQuery (QApt pkg))
643
644 fun loop () =
645 case Msg.recv bio of
646 NONE => (print "Server closed connection unexpectedly.\n";
647 OS.Process.failure)
648 | SOME m =>
649 case m of
650 MsgYes => (print "Package is installed.\n";
651 OS.Process.success)
652 | MsgNo => (print "Package is not installed.\n";
653 OS.Process.failure)
654 | MsgError s => (print ("APT query failed: " ^ s ^ "\n");
655 OS.Process.failure)
656 | _ => (print "Unexpected server reply.\n";
657 OS.Process.failure)
658 in
659 loop ()
660 before OpenSSL.close bio
661 end
662
663 fun requestCron {node, uname} =
664 let
665 val (user, context) = requestContext (fn () => ())
666 val bio = OpenSSL.connect (context, if node = Config.masterNode then
667 dispatcher
668 else
669 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
670
671 val _ = Msg.send (bio, MsgQuery (QCron uname))
672
673 fun loop () =
674 case Msg.recv bio of
675 NONE => (print "Server closed connection unexpectedly.\n";
676 OS.Process.failure)
677 | SOME m =>
678 case m of
679 MsgYes => (print "User has cron permissions.\n";
680 OS.Process.success)
681 | MsgNo => (print "User does not have cron permissions.\n";
682 OS.Process.failure)
683 | MsgError s => (print ("Cron query failed: " ^ s ^ "\n");
684 OS.Process.failure)
685 | _ => (print "Unexpected server reply.\n";
686 OS.Process.failure)
687 in
688 loop ()
689 before OpenSSL.close bio
690 end
691
692 fun requestFtp {node, uname} =
693 let
694 val (user, context) = requestContext (fn () => ())
695 val bio = OpenSSL.connect (context, if node = Config.masterNode then
696 dispatcher
697 else
698 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
699
700 val _ = Msg.send (bio, MsgQuery (QFtp uname))
701
702 fun loop () =
703 case Msg.recv bio of
704 NONE => (print "Server closed connection unexpectedly.\n";
705 OS.Process.failure)
706 | SOME m =>
707 case m of
708 MsgYes => (print "User has FTP permissions.\n";
709 OS.Process.success)
710 | MsgNo => (print "User does not have FTP permissions.\n";
711 OS.Process.failure)
712 | MsgError s => (print ("FTP query failed: " ^ s ^ "\n");
713 OS.Process.failure)
714 | _ => (print "Unexpected server reply.\n";
715 OS.Process.failure)
716 in
717 loop ()
718 before OpenSSL.close bio
719 end
720
721 fun requestTrustedPath {node, uname} =
722 let
723 val (user, context) = requestContext (fn () => ())
724 val bio = OpenSSL.connect (context, if node = Config.masterNode then
725 dispatcher
726 else
727 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
728
729 val _ = Msg.send (bio, MsgQuery (QTrustedPath uname))
730
731 fun loop () =
732 case Msg.recv bio of
733 NONE => (print "Server closed connection unexpectedly.\n";
734 OS.Process.failure)
735 | SOME m =>
736 case m of
737 MsgYes => (print "User has trusted path restriction.\n";
738 OS.Process.success)
739 | MsgNo => (print "User does not have trusted path restriction.\n";
740 OS.Process.failure)
741 | MsgError s => (print ("Trusted path query failed: " ^ s ^ "\n");
742 OS.Process.failure)
743 | _ => (print "Unexpected server reply.\n";
744 OS.Process.failure)
745 in
746 loop ()
747 before OpenSSL.close bio
748 end
749
750 fun requestSocketPerm {node, uname} =
751 let
752 val (user, context) = requestContext (fn () => ())
753 val bio = OpenSSL.connect (context, if node = Config.masterNode then
754 dispatcher
755 else
756 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
757
758 val _ = Msg.send (bio, MsgQuery (QSocket uname))
759
760 fun loop () =
761 case Msg.recv bio of
762 NONE => (print "Server closed connection unexpectedly.\n";
763 OS.Process.failure)
764 | SOME m =>
765 case m of
766 MsgSocket p => (case p of
767 Any => print "Any\n"
768 | Client => print "Client\n"
769 | Server => print "Server\n"
770 | Nada => print "Nada\n";
771 OS.Process.success)
772 | MsgError s => (print ("Socket permission query failed: " ^ s ^ "\n");
773 OS.Process.failure)
774 | _ => (print "Unexpected server reply.\n";
775 OS.Process.failure)
776 in
777 loop ()
778 before OpenSSL.close bio
779 end
780
781 fun requestFirewall {node, uname} =
782 let
783 val (user, context) = requestContext (fn () => ())
784 val bio = OpenSSL.connect (context, if node = Config.masterNode then
785 dispatcher
786 else
787 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
788
789 val _ = Msg.send (bio, MsgQuery (QFirewall uname))
790
791 fun loop () =
792 case Msg.recv bio of
793 NONE => (print "Server closed connection unexpectedly.\n";
794 OS.Process.failure)
795 | SOME m =>
796 case m of
797 MsgFirewall ls => (app (fn s => (print s; print "\n")) ls;
798 OS.Process.success)
799 | MsgError s => (print ("Firewall query failed: " ^ s ^ "\n");
800 OS.Process.failure)
801 | _ => (print "Unexpected server reply.\n";
802 OS.Process.failure)
803 in
804 loop ()
805 before OpenSSL.close bio
806 end
807
808 fun regenerate context =
809 let
810 val _ = ErrorMsg.reset ()
811
812 val b = basis ()
813 val () = Tycheck.disallowExterns ()
814
815 val () = Domain.resetGlobal ()
816
817 fun contactNode (node, ip) =
818 if node = Config.defaultNode then
819 Domain.resetLocal ()
820 else let
821 val bio = OpenSSL.connect (context,
822 ip
823 ^ ":"
824 ^ Int.toString Config.slavePort)
825 in
826 Msg.send (bio, MsgRegenerate);
827 case Msg.recv bio of
828 NONE => print "Slave closed connection unexpectedly\n"
829 | SOME m =>
830 case m of
831 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
832 | MsgError s => print ("Slave " ^ node
833 ^ " returned error: " ^
834 s ^ "\n")
835 | _ => print ("Slave " ^ node
836 ^ " returned unexpected command\n");
837 OpenSSL.close bio
838 end
839
840 fun doUser user =
841 let
842 val _ = Domain.setUser user
843 val _ = ErrorMsg.reset ()
844
845 val dname = Config.domtoolDir user
846
847 val dir = Posix.FileSys.opendir dname
848
849 fun loop files =
850 case Posix.FileSys.readdir dir of
851 NONE => (Posix.FileSys.closedir dir;
852 files)
853 | SOME fname =>
854 if notTmp fname then
855 loop (OS.Path.joinDirFile {dir = dname,
856 file = fname}
857 :: files)
858 else
859 loop files
860
861 val files = loop []
862 val (_, files) = Order.order (SOME b) files
863 in
864 if !ErrorMsg.anyErrors then
865 (ErrorMsg.reset ();
866 print ("User " ^ user ^ "'s configuration has errors!\n"))
867 else
868 app eval' files
869 end
870 handle IO.Io _ => ()
871 | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
872 | ErrorMsg.Error => (ErrorMsg.reset ();
873 print ("User " ^ user ^ " had a compilation error.\n"))
874 | _ => print "Unknown exception during regeneration!\n"
875 in
876 app contactNode Config.nodeIps;
877 Env.pre ();
878 app doUser (Acl.users ());
879 Env.post ()
880 end
881
882 fun rmuser user =
883 let
884 val doms = Acl.class {user = user, class = "domain"}
885 val doms = List.filter (fn dom =>
886 case Acl.whoHas {class = "domain", value = dom} of
887 [_] => true
888 | _ => false) (StringSet.listItems doms)
889 in
890 Acl.rmuser user;
891 Domain.rmdom doms
892 end
893
894 fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
895
896 fun answerQuery q =
897 case q of
898 QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
899 | QCron user => if Cron.allowed user then MsgYes else MsgNo
900 | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
901 | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
902 | QSocket user => MsgSocket (SocketPerm.query user)
903 | QFirewall user => MsgFirewall (Firewall.query user)
904
905 fun describeQuery q =
906 case q of
907 QApt pkg => "Requested installation status of package " ^ pkg
908 | QCron user => "Asked about cron permissions for user " ^ user
909 | QFtp user => "Asked about FTP permissions for user " ^ user
910 | QTrustedPath user => "Asked about trusted path settings for user " ^ user
911 | QSocket user => "Asked about socket permissions for user " ^ user
912 | QFirewall user => "Asked about firewall rules for user " ^ user
913
914 fun service () =
915 let
916 val () = Acl.read Config.aclFile
917
918 val context = context (Config.serverCert,
919 Config.serverKey,
920 Config.trustStore)
921 val _ = Domain.set_context context
922
923 val sock = OpenSSL.listen (context, Config.dispatcherPort)
924
925 fun loop () =
926 case OpenSSL.accept sock of
927 NONE => ()
928 | SOME bio =>
929 let
930 val user = OpenSSL.peerCN bio
931 val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
932 val () = Domain.setUser user
933
934 fun doIt f cleanup =
935 ((case f () of
936 (msgLocal, SOME msgRemote) =>
937 (print msgLocal;
938 print "\n";
939 Msg.send (bio, MsgError msgRemote))
940 | (msgLocal, NONE) =>
941 (print msgLocal;
942 print "\n";
943 Msg.send (bio, MsgOk)))
944 handle OpenSSL.OpenSSL _ =>
945 print "OpenSSL error\n"
946 | OS.SysErr (s, _) =>
947 (print "System error: ";
948 print s;
949 print "\n";
950 Msg.send (bio, MsgError ("System error: " ^ s))
951 handle OpenSSL.OpenSSL _ => ())
952 | Fail s =>
953 (print "Failure: ";
954 print s;
955 print "\n";
956 Msg.send (bio, MsgError ("Failure: " ^ s))
957 handle OpenSSL.OpenSSL _ => ())
958 | ErrorMsg.Error =>
959 (print "Compilation error\n";
960 Msg.send (bio, MsgError "Error during configuration evaluation")
961 handle OpenSSL.OpenSSL _ => ());
962 (cleanup ();
963 ignore (OpenSSL.readChar bio);
964 OpenSSL.close bio)
965 handle OpenSSL.OpenSSL _ => ();
966 loop ())
967
968 fun doConfig codes =
969 let
970 val _ = print "Configuration:\n"
971 val _ = app (fn s => (print s; print "\n")) codes
972 val _ = print "\n"
973
974 val outname = OS.FileSys.tmpName ()
975
976 fun doOne code =
977 let
978 val outf = TextIO.openOut outname
979 in
980 TextIO.output (outf, code);
981 TextIO.closeOut outf;
982 eval' outname
983 end
984 in
985 doIt (fn () => (Env.pre ();
986 app doOne codes;
987 Env.post ();
988 Msg.send (bio, MsgOk);
989 ("Configuration complete.", NONE)))
990 (fn () => OS.FileSys.remove outname)
991 end
992
993 fun checkAddr s =
994 case String.fields (fn ch => ch = #"@") s of
995 [user'] =>
996 if user = user' then
997 SOME (SetSA.User s)
998 else
999 NONE
1000 | [user', domain] =>
1001 if Domain.validEmailUser user' andalso Domain.yourDomain domain then
1002 SOME (SetSA.Email s)
1003 else
1004 NONE
1005 | _ => NONE
1006
1007 fun cmdLoop () =
1008 case Msg.recv bio of
1009 NONE => (OpenSSL.close bio
1010 handle OpenSSL.OpenSSL _ => ();
1011 loop ())
1012 | SOME m =>
1013 case m of
1014 MsgConfig code => doConfig [code]
1015 | MsgMultiConfig codes => doConfig codes
1016
1017 | MsgShutdown =>
1018 if Acl.query {user = user, class = "priv", value = "all"}
1019 orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
1020 print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
1021 else
1022 (print "Unauthorized shutdown command!\n";
1023 OpenSSL.close bio
1024 handle OpenSSL.OpenSSL _ => ();
1025 loop ())
1026
1027 | MsgGrant acl =>
1028 doIt (fn () =>
1029 if Acl.query {user = user, class = "priv", value = "all"} then
1030 (Acl.grant acl;
1031 Acl.write Config.aclFile;
1032 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
1033 NONE))
1034 else
1035 ("Unauthorized user asked to grant a permission!",
1036 SOME "Not authorized to grant privileges"))
1037 (fn () => ())
1038
1039 | MsgRevoke acl =>
1040 doIt (fn () =>
1041 if Acl.query {user = user, class = "priv", value = "all"} then
1042 (Acl.revoke acl;
1043 Acl.write Config.aclFile;
1044 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
1045 NONE))
1046 else
1047 ("Unauthorized user asked to revoke a permission!",
1048 SOME "Not authorized to revoke privileges"))
1049 (fn () => ())
1050
1051 | MsgListPerms user =>
1052 doIt (fn () =>
1053 (Msg.send (bio, MsgPerms (Acl.queryAll user));
1054 ("Sent permission list for user " ^ user ^ ".",
1055 NONE)))
1056 (fn () => ())
1057
1058 | MsgWhoHas perm =>
1059 doIt (fn () =>
1060 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
1061 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
1062 NONE)))
1063 (fn () => ())
1064
1065 | MsgRmdom doms =>
1066 doIt (fn () =>
1067 if Acl.query {user = user, class = "priv", value = "all"}
1068 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
1069 (Domain.rmdom doms;
1070 app (fn dom =>
1071 Acl.revokeFromAll {class = "domain", value = dom}) doms;
1072 Acl.write Config.aclFile;
1073 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
1074 NONE))
1075 else
1076 ("Unauthorized user asked to remove a domain!",
1077 SOME "Not authorized to remove that domain"))
1078 (fn () => ())
1079
1080 | MsgRegenerate =>
1081 doIt (fn () =>
1082 if Acl.query {user = user, class = "priv", value = "regen"}
1083 orelse Acl.query {user = user, class = "priv", value = "all"} then
1084 (regenerate context;
1085 ("Regenerated all configuration.",
1086 NONE))
1087 else
1088 ("Unauthorized user asked to regenerate!",
1089 SOME "Not authorized to regenerate"))
1090 (fn () => ())
1091
1092 | MsgRmuser user' =>
1093 doIt (fn () =>
1094 if Acl.query {user = user, class = "priv", value = "all"} then
1095 (rmuser user';
1096 Acl.write Config.aclFile;
1097 ("Removed user " ^ user' ^ ".",
1098 NONE))
1099 else
1100 ("Unauthorized user asked to remove a user!",
1101 SOME "Not authorized to remove users"))
1102 (fn () => ())
1103
1104 | MsgCreateDbUser {dbtype, passwd} =>
1105 doIt (fn () =>
1106 case Dbms.lookup dbtype of
1107 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1108 SOME ("Unknown database type " ^ dbtype))
1109 | SOME handler =>
1110 case #adduser handler {user = user, passwd = passwd} of
1111 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1112 NONE)
1113 | SOME msg =>
1114 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1115 SOME ("Error adding user: " ^ msg)))
1116 (fn () => ())
1117
1118 | MsgDbPasswd {dbtype, passwd} =>
1119 doIt (fn () =>
1120 case Dbms.lookup dbtype of
1121 NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1122 SOME ("Unknown database type " ^ dbtype))
1123 | SOME handler =>
1124 case #passwd handler {user = user, passwd = passwd} of
1125 NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1126 NONE)
1127 | SOME msg =>
1128 ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1129 SOME ("Error adding user: " ^ msg)))
1130 (fn () => ())
1131
1132 | MsgCreateDbTable {dbtype, dbname} =>
1133 doIt (fn () =>
1134 if Dbms.validDbname dbname then
1135 case Dbms.lookup dbtype of
1136 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1137 SOME ("Unknown database type " ^ dbtype))
1138 | SOME handler =>
1139 case #createdb handler {user = user, dbname = dbname} of
1140 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1141 NONE)
1142 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1143 SOME ("Error creating database: " ^ msg))
1144 else
1145 ("Invalid database name " ^ user ^ "_" ^ dbname,
1146 SOME ("Invalid database name " ^ dbname)))
1147 (fn () => ())
1148
1149 | MsgListMailboxes domain =>
1150 doIt (fn () =>
1151 if not (Domain.yourDomain domain) then
1152 ("User wasn't authorized to list mailboxes for " ^ domain,
1153 SOME "You're not authorized to configure that domain.")
1154 else
1155 case Vmail.list domain of
1156 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
1157 ("Sent mailbox list for " ^ domain,
1158 NONE))
1159 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
1160 SOME msg))
1161 (fn () => ())
1162
1163 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
1164 doIt (fn () =>
1165 if not (Domain.yourDomain domain) then
1166 ("User wasn't authorized to add a mailbox to " ^ domain,
1167 SOME "You're not authorized to configure that domain.")
1168 else if not (Domain.validEmailUser emailUser) then
1169 ("Invalid e-mail username " ^ emailUser,
1170 SOME "Invalid e-mail username")
1171 else if not (CharVector.all Char.isGraph passwd) then
1172 ("Invalid password",
1173 SOME "Invalid password; may only contain printable, non-space characters")
1174 else if not (Domain.yourPath mailbox) then
1175 ("User wasn't authorized to add a mailbox at " ^ mailbox,
1176 SOME "You're not authorized to use that mailbox location.")
1177 else
1178 case Vmail.add {requester = user,
1179 domain = domain, user = emailUser,
1180 passwd = passwd, mailbox = mailbox} of
1181 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
1182 NONE)
1183 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1184 SOME msg))
1185 (fn () => ())
1186
1187 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1188 doIt (fn () =>
1189 if not (Domain.yourDomain domain) then
1190 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1191 SOME "You're not authorized to configure that domain.")
1192 else if not (Domain.validEmailUser emailUser) then
1193 ("Invalid e-mail username " ^ emailUser,
1194 SOME "Invalid e-mail username")
1195 else if not (CharVector.all Char.isGraph passwd) then
1196 ("Invalid password",
1197 SOME "Invalid password; may only contain printable, non-space characters")
1198 else
1199 case Vmail.passwd {domain = domain, user = emailUser,
1200 passwd = passwd} of
1201 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1202 NONE)
1203 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1204 SOME msg))
1205 (fn () => ())
1206
1207 | MsgRmMailbox {domain, user = emailUser} =>
1208 doIt (fn () =>
1209 if not (Domain.yourDomain domain) then
1210 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1211 SOME "You're not authorized to configure that domain.")
1212 else if not (Domain.validEmailUser emailUser) then
1213 ("Invalid e-mail username " ^ emailUser,
1214 SOME "Invalid e-mail username")
1215 else
1216 case Vmail.rm {domain = domain, user = emailUser} of
1217 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1218 NONE)
1219 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1220 SOME msg))
1221 (fn () => ())
1222
1223 | MsgSaQuery addr =>
1224 doIt (fn () =>
1225 case checkAddr addr of
1226 NONE => ("User tried to query SA filtering for " ^ addr,
1227 SOME "You aren't allowed to configure SA filtering for that recipient.")
1228 | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1229 ("Queried SA filtering status for " ^ addr,
1230 NONE)))
1231 (fn () => ())
1232
1233 | MsgSaSet (addr, b) =>
1234 doIt (fn () =>
1235 case checkAddr addr of
1236 NONE => ("User tried to set SA filtering for " ^ addr,
1237 SOME "You aren't allowed to configure SA filtering for that recipient.")
1238 | SOME addr' => (SetSA.set (addr', b);
1239 Msg.send (bio, MsgOk);
1240 ("Set SA filtering status for " ^ addr ^ " to "
1241 ^ (if b then "ON" else "OFF"),
1242 NONE)))
1243 (fn () => ())
1244
1245 | MsgSmtpLogReq domain =>
1246 doIt (fn () =>
1247 if not (Domain.yourDomain domain) then
1248 ("Unauthorized user tried to request SMTP logs for " ^ domain,
1249 SOME "You aren't authorized to configure that domain.")
1250 else
1251 (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1252 domain;
1253 ("Requested SMTP logs for " ^ domain,
1254 NONE)))
1255 (fn () => ())
1256
1257 | MsgQuery q =>
1258 doIt (fn () => (Msg.send (bio, answerQuery q);
1259 (describeQuery q,
1260 NONE)))
1261 (fn () => ())
1262
1263 | _ =>
1264 doIt (fn () => ("Unexpected command",
1265 SOME "Unexpected command"))
1266 (fn () => ())
1267 in
1268 cmdLoop ()
1269 end
1270 handle OpenSSL.OpenSSL s =>
1271 (print ("OpenSSL error: " ^ s ^ "\n");
1272 OpenSSL.close bio
1273 handle OpenSSL.OpenSSL _ => ();
1274 loop ())
1275 | OS.SysErr (s, _) =>
1276 (print ("System error: " ^ s ^ "\n");
1277 OpenSSL.close bio
1278 handle OpenSSL.OpenSSL _ => ();
1279 loop ())
1280 | IO.Io {name, function, cause} =>
1281 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1282 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1283 OpenSSL.close bio
1284 handle OpenSSL.OpenSSL _ => ();
1285 loop ())
1286 | e =>
1287 (print "Unknown exception in main loop!\n";
1288 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1289 OpenSSL.close bio
1290 handle OpenSSL.OpenSSL _ => ();
1291 loop ())
1292 in
1293 print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
1294 print "Listening for connections....\n";
1295 loop ();
1296 OpenSSL.shutdown sock
1297 end
1298
1299 fun slave () =
1300 let
1301 val host = Slave.hostname ()
1302
1303 val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1304 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1305 Config.trustStore)
1306
1307 val sock = OpenSSL.listen (context, Config.slavePort)
1308
1309 val _ = print ("Slave server starting at " ^ now () ^ "\n")
1310
1311 fun loop () =
1312 case OpenSSL.accept sock of
1313 NONE => ()
1314 | SOME bio =>
1315 let
1316 val peer = OpenSSL.peerCN bio
1317 val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
1318 in
1319 if peer = Config.dispatcherName then let
1320 fun loop' files =
1321 case Msg.recv bio of
1322 NONE => print "Dispatcher closed connection unexpectedly\n"
1323 | SOME m =>
1324 case m of
1325 MsgFile file => loop' (file :: files)
1326 | MsgDoFiles => (Slave.handleChanges files;
1327 Msg.send (bio, MsgOk))
1328 | MsgRegenerate => (Domain.resetLocal ();
1329 Msg.send (bio, MsgOk))
1330 | _ => (print "Dispatcher sent unexpected command\n";
1331 Msg.send (bio, MsgError "Unexpected command"))
1332 in
1333 loop' [];
1334 ignore (OpenSSL.readChar bio);
1335 OpenSSL.close bio;
1336 loop ()
1337 end
1338 else if peer = "domtool" then
1339 case Msg.recv bio of
1340 SOME MsgShutdown => (OpenSSL.close bio;
1341 print ("Shutting down at " ^ now () ^ "\n\n"))
1342 | _ => (OpenSSL.close bio;
1343 loop ())
1344 else
1345 case Msg.recv bio of
1346 SOME (MsgQuery q) => (print (describeQuery q ^ "\n");
1347 Msg.send (bio, answerQuery q);
1348 ignore (OpenSSL.readChar bio);
1349 OpenSSL.close bio;
1350 loop ())
1351 | _ => (OpenSSL.close bio;
1352 loop ())
1353 end handle OpenSSL.OpenSSL s =>
1354 (print ("OpenSSL error: "^ s ^ "\n");
1355 OpenSSL.close bio
1356 handle OpenSSL.OpenSSL _ => ();
1357 loop ())
1358 | e as OS.SysErr (s, _) =>
1359 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1360 print ("System error: "^ s ^ "\n");
1361 OpenSSL.close bio
1362 handle OpenSSL.OpenSSL _ => ();
1363 loop ())
1364 in
1365 loop ();
1366 OpenSSL.shutdown sock
1367 end
1368
1369 fun listBasis () =
1370 let
1371 val dir = Posix.FileSys.opendir Config.libRoot
1372
1373 fun loop files =
1374 case Posix.FileSys.readdir dir of
1375 NONE => (Posix.FileSys.closedir dir;
1376 files)
1377 | SOME fname =>
1378 if String.isSuffix ".dtl" fname then
1379 loop (OS.Path.joinDirFile {dir = Config.libRoot,
1380 file = fname}
1381 :: files)
1382 else
1383 loop files
1384 in
1385 loop []
1386 end
1387
1388 fun autodocBasis outdir =
1389 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1390
1391 end