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