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