Cron and FTP queries
[hcoop/domtool2.git] / src / main.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, Adam Chlipala
3 *
4 * This program is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU General Public License
6 * as published by the Free Software Foundation; either version 2
7 * of the License, or (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
17 *)
18
19 (* Main interface *)
20
21 structure Main :> MAIN = struct
22
23 open Ast MsgTypes Print
24
25 structure SM = StringMap
26
27 fun init () = Acl.read Config.aclFile
28
29 fun check' G fname =
30 let
31 val prog = Parse.parse fname
32 in
33 if !ErrorMsg.anyErrors then
34 G
35 else
36 Tycheck.checkFile G (Defaults.tInit ()) prog
37 end
38
39 fun basis () =
40 let
41 val dir = Posix.FileSys.opendir Config.libRoot
42
43 fun loop files =
44 case Posix.FileSys.readdir dir of
45 NONE => (Posix.FileSys.closedir dir;
46 files)
47 | SOME fname =>
48 if String.isSuffix ".dtl" fname then
49 loop (OS.Path.joinDirFile {dir = Config.libRoot,
50 file = fname}
51 :: files)
52 else
53 loop files
54
55 val files = loop []
56 val (_, files) = Order.order NONE files
57 in
58 if !ErrorMsg.anyErrors then
59 Env.empty
60 else
61 (Tycheck.allowExterns ();
62 foldl (fn (fname, G) => check' G fname) Env.empty files
63 before Tycheck.disallowExterns ())
64 end
65
66 fun check fname =
67 let
68 val _ = ErrorMsg.reset ()
69 val _ = Env.preTycheck ()
70
71 val b = basis ()
72 in
73 if !ErrorMsg.anyErrors then
74 raise ErrorMsg.Error
75 else
76 let
77 val _ = Tycheck.disallowExterns ()
78 val _ = ErrorMsg.reset ()
79 val prog = Parse.parse fname
80 in
81 if !ErrorMsg.anyErrors then
82 raise ErrorMsg.Error
83 else
84 let
85 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
86 in
87 if !ErrorMsg.anyErrors then
88 raise ErrorMsg.Error
89 else
90 (G', #3 prog)
91 end
92 end
93 end
94
95 val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")
96
97 fun checkDir dname =
98 let
99 val b = basis ()
100
101 val dir = Posix.FileSys.opendir dname
102
103 fun loop files =
104 case Posix.FileSys.readdir dir of
105 NONE => (Posix.FileSys.closedir dir;
106 files)
107 | SOME fname =>
108 if notTmp fname then
109 loop (OS.Path.joinDirFile {dir = dname,
110 file = fname}
111 :: files)
112 else
113 loop files
114
115 val files = loop []
116 val (_, files) = Order.order (SOME b) files
117 in
118 if !ErrorMsg.anyErrors then
119 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 requestContext f =
174 let
175 val uid = Posix.ProcEnv.getuid ()
176 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
177
178 val () = Acl.read Config.aclFile
179 val () = Domain.setUser user
180
181 val () = f ()
182
183 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
184 Config.keyDir ^ "/" ^ user ^ "/key.pem",
185 Config.trustStore)
186 in
187 (user, context)
188 end
189
190 fun requestBio f =
191 let
192 val (user, context) = requestContext f
193 in
194 (user, OpenSSL.connect (context, dispatcher))
195 end
196
197 fun requestSlaveBio () =
198 let
199 val (user, context) = requestContext (fn () => ())
200 in
201 (user, OpenSSL.connect (context, self))
202 end
203
204 fun request fname =
205 let
206 val (user, bio) = requestBio (fn () => ignore (check fname))
207
208 val inf = TextIO.openIn fname
209
210 fun loop lines =
211 case TextIO.inputLine inf of
212 NONE => String.concat (List.rev lines)
213 | SOME line => loop (line :: lines)
214
215 val code = loop []
216 in
217 TextIO.closeIn inf;
218 Msg.send (bio, MsgConfig code);
219 case Msg.recv bio of
220 NONE => print "Server closed connection unexpectedly.\n"
221 | SOME m =>
222 case m of
223 MsgOk => print "Configuration succeeded.\n"
224 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
225 | _ => print "Unexpected server reply.\n";
226 OpenSSL.close bio
227 end
228 handle ErrorMsg.Error => ()
229
230 fun requestDir dname =
231 let
232 val _ = ErrorMsg.reset ()
233
234 val (user, bio) = requestBio (fn () => checkDir dname)
235
236 val b = basis ()
237
238 val dir = Posix.FileSys.opendir dname
239
240 fun loop files =
241 case Posix.FileSys.readdir dir of
242 NONE => (Posix.FileSys.closedir dir;
243 files)
244 | SOME fname =>
245 if notTmp fname then
246 loop (OS.Path.joinDirFile {dir = dname,
247 file = fname}
248 :: files)
249 else
250 loop files
251
252 val files = loop []
253 val (_, files) = Order.order (SOME b) files
254
255 val _ = if !ErrorMsg.anyErrors then
256 raise ErrorMsg.Error
257 else
258 ()
259
260 val codes = map (fn fname =>
261 let
262 val inf = TextIO.openIn fname
263
264 fun loop lines =
265 case TextIO.inputLine inf of
266 NONE => String.concat (rev lines)
267 | SOME line => loop (line :: lines)
268 in
269 loop []
270 before TextIO.closeIn inf
271 end) files
272 in
273 if !ErrorMsg.anyErrors then
274 ()
275 else
276 (Msg.send (bio, MsgMultiConfig codes);
277 case Msg.recv bio of
278 NONE => print "Server closed connection unexpectedly.\n"
279 | SOME m =>
280 case m of
281 MsgOk => print "Configuration succeeded.\n"
282 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
283 | _ => print "Unexpected server reply.\n";
284 OpenSSL.close bio)
285 end
286 handle ErrorMsg.Error => ()
287
288 fun requestPing () =
289 let
290 val (_, bio) = requestBio (fn () => ())
291 in
292 OpenSSL.close bio;
293 OS.Process.success
294 end
295 handle _ => OS.Process.failure
296
297 fun requestShutdown () =
298 let
299 val (_, bio) = requestBio (fn () => ())
300 in
301 Msg.send (bio, MsgShutdown);
302 case Msg.recv bio of
303 NONE => print "Server closed connection unexpectedly.\n"
304 | SOME m =>
305 case m of
306 MsgOk => print "Shutdown begun.\n"
307 | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
308 | _ => print "Unexpected server reply.\n";
309 OpenSSL.close bio
310 end
311
312 fun requestSlavePing () =
313 let
314 val (_, bio) = requestSlaveBio ()
315 in
316 OpenSSL.close bio;
317 OS.Process.success
318 end
319 handle _ => OS.Process.failure
320
321 fun requestSlaveShutdown () =
322 let
323 val (_, bio) = requestSlaveBio ()
324 in
325 Msg.send (bio, MsgShutdown);
326 case Msg.recv bio of
327 NONE => print "Server closed connection unexpectedly.\n"
328 | SOME m =>
329 case m of
330 MsgOk => print "Shutdown begun.\n"
331 | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
332 | _ => print "Unexpected server reply.\n";
333 OpenSSL.close bio
334 end
335
336 fun requestGrant acl =
337 let
338 val (user, bio) = requestBio (fn () => ())
339 in
340 Msg.send (bio, MsgGrant acl);
341 case Msg.recv bio of
342 NONE => print "Server closed connection unexpectedly.\n"
343 | SOME m =>
344 case m of
345 MsgOk => print "Grant succeeded.\n"
346 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
347 | _ => print "Unexpected server reply.\n";
348 OpenSSL.close bio
349 end
350
351 fun requestRevoke acl =
352 let
353 val (user, bio) = requestBio (fn () => ())
354 in
355 Msg.send (bio, MsgRevoke acl);
356 case Msg.recv bio of
357 NONE => print "Server closed connection unexpectedly.\n"
358 | SOME m =>
359 case m of
360 MsgOk => print "Revoke succeeded.\n"
361 | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
362 | _ => print "Unexpected server reply.\n";
363 OpenSSL.close bio
364 end
365
366 fun requestListPerms user =
367 let
368 val (_, bio) = requestBio (fn () => ())
369 in
370 Msg.send (bio, MsgListPerms user);
371 (case Msg.recv bio of
372 NONE => (print "Server closed connection unexpectedly.\n";
373 NONE)
374 | SOME m =>
375 case m of
376 MsgPerms perms => SOME perms
377 | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
378 NONE)
379 | _ => (print "Unexpected server reply.\n";
380 NONE))
381 before OpenSSL.close bio
382 end
383
384 fun requestWhoHas perm =
385 let
386 val (_, bio) = requestBio (fn () => ())
387 in
388 Msg.send (bio, MsgWhoHas perm);
389 (case Msg.recv bio of
390 NONE => (print "Server closed connection unexpectedly.\n";
391 NONE)
392 | SOME m =>
393 case m of
394 MsgWhoHasResponse users => SOME users
395 | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
396 NONE)
397 | _ => (print "Unexpected server reply.\n";
398 NONE))
399 before OpenSSL.close bio
400 end
401
402 fun requestRegen () =
403 let
404 val (_, bio) = requestBio (fn () => ())
405 in
406 Msg.send (bio, MsgRegenerate);
407 case Msg.recv bio of
408 NONE => print "Server closed connection unexpectedly.\n"
409 | SOME m =>
410 case m of
411 MsgOk => print "Regeneration succeeded.\n"
412 | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
413 | _ => print "Unexpected server reply.\n";
414 OpenSSL.close bio
415 end
416
417 fun requestRmdom dom =
418 let
419 val (_, bio) = requestBio (fn () => ())
420 in
421 Msg.send (bio, MsgRmdom dom);
422 case Msg.recv bio of
423 NONE => print "Server closed connection unexpectedly.\n"
424 | SOME m =>
425 case m of
426 MsgOk => print "Removal succeeded.\n"
427 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
428 | _ => print "Unexpected server reply.\n";
429 OpenSSL.close bio
430 end
431
432 fun requestRmuser user =
433 let
434 val (_, bio) = requestBio (fn () => ())
435 in
436 Msg.send (bio, MsgRmuser user);
437 case Msg.recv bio of
438 NONE => print "Server closed connection unexpectedly.\n"
439 | SOME m =>
440 case m of
441 MsgOk => print "Removal succeeded.\n"
442 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
443 | _ => print "Unexpected server reply.\n";
444 OpenSSL.close bio
445 end
446
447 fun requestDbUser dbtype =
448 let
449 val (_, bio) = requestBio (fn () => ())
450 in
451 Msg.send (bio, MsgCreateDbUser dbtype);
452 case Msg.recv bio of
453 NONE => print "Server closed connection unexpectedly.\n"
454 | SOME m =>
455 case m of
456 MsgOk => print "Your user has been created.\n"
457 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
458 | _ => print "Unexpected server reply.\n";
459 OpenSSL.close bio
460 end
461
462 fun requestDbPasswd rc =
463 let
464 val (_, bio) = requestBio (fn () => ())
465 in
466 Msg.send (bio, MsgDbPasswd rc);
467 case Msg.recv bio of
468 NONE => print "Server closed connection unexpectedly.\n"
469 | SOME m =>
470 case m of
471 MsgOk => print "Your password has been changed.\n"
472 | MsgError s => print ("Password set failed: " ^ s ^ "\n")
473 | _ => print "Unexpected server reply.\n";
474 OpenSSL.close bio
475 end
476
477 fun requestDbTable p =
478 let
479 val (user, bio) = requestBio (fn () => ())
480 in
481 Msg.send (bio, MsgCreateDbTable p);
482 case Msg.recv bio of
483 NONE => print "Server closed connection unexpectedly.\n"
484 | SOME m =>
485 case m of
486 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
487 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
488 | _ => print "Unexpected server reply.\n";
489 OpenSSL.close bio
490 end
491
492 fun requestListMailboxes domain =
493 let
494 val (_, bio) = requestBio (fn () => ())
495 in
496 Msg.send (bio, MsgListMailboxes domain);
497 (case Msg.recv bio of
498 NONE => Vmail.Error "Server closed connection unexpectedly."
499 | SOME m =>
500 case m of
501 MsgMailboxes users => (Msg.send (bio, MsgOk);
502 Vmail.Listing users)
503 | MsgError s => Vmail.Error ("Creation failed: " ^ s)
504 | _ => Vmail.Error "Unexpected server reply.")
505 before OpenSSL.close bio
506 end
507
508 fun requestNewMailbox p =
509 let
510 val (_, bio) = requestBio (fn () => ())
511 in
512 Msg.send (bio, MsgNewMailbox p);
513 case Msg.recv bio of
514 NONE => print "Server closed connection unexpectedly.\n"
515 | SOME m =>
516 case m of
517 MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
518 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
519 | _ => print "Unexpected server reply.\n";
520 OpenSSL.close bio
521 end
522
523 fun requestPasswdMailbox p =
524 let
525 val (_, bio) = requestBio (fn () => ())
526 in
527 Msg.send (bio, MsgPasswdMailbox 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 ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
533 | MsgError s => print ("Set failed: " ^ s ^ "\n")
534 | _ => print "Unexpected server reply.\n";
535 OpenSSL.close bio
536 end
537
538 fun requestRmMailbox p =
539 let
540 val (_, bio) = requestBio (fn () => ())
541 in
542 Msg.send (bio, MsgRmMailbox 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 ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
548 | MsgError s => print ("Remove failed: " ^ s ^ "\n")
549 | _ => print "Unexpected server reply.\n";
550 OpenSSL.close bio
551 end
552
553 fun requestSaQuery addr =
554 let
555 val (_, bio) = requestBio (fn () => ())
556 in
557 Msg.send (bio, MsgSaQuery addr);
558 (case Msg.recv bio of
559 NONE => print "Server closed connection unexpectedly.\n"
560 | SOME m =>
561 case m of
562 MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "
563 ^ (if b then "ON" else "OFF") ^ ".\n");
564 Msg.send (bio, MsgOk))
565 | MsgError s => print ("Query failed: " ^ s ^ "\n")
566 | _ => print "Unexpected server reply.\n")
567 before OpenSSL.close bio
568 end
569
570 fun requestSaSet p =
571 let
572 val (_, bio) = requestBio (fn () => ())
573 in
574 Msg.send (bio, MsgSaSet p);
575 case Msg.recv bio of
576 NONE => print "Server closed connection unexpectedly.\n"
577 | SOME m =>
578 case m of
579 MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "
580 ^ (if #2 p then "ON" else "OFF") ^ ".\n")
581 | MsgError s => print ("Set failed: " ^ s ^ "\n")
582 | _ => print "Unexpected server reply.\n";
583 OpenSSL.close bio
584 end
585
586 fun requestSmtpLog domain =
587 let
588 val (_, bio) = requestBio (fn () => ())
589
590 val _ = Msg.send (bio, MsgSmtpLogReq domain)
591
592 fun loop () =
593 case Msg.recv bio of
594 NONE => print "Server closed connection unexpectedly.\n"
595 | SOME m =>
596 case m of
597 MsgOk => ()
598 | MsgSmtpLogRes line => (print line;
599 loop ())
600 | MsgError s => print ("Log search failed: " ^ s ^ "\n")
601 | _ => print "Unexpected server reply.\n"
602 in
603 loop ();
604 OpenSSL.close bio
605 end
606
607 fun requestApt {node, pkg} =
608 let
609 val (user, context) = requestContext (fn () => ())
610 val bio = OpenSSL.connect (context, if node = Config.masterNode then
611 dispatcher
612 else
613 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
614
615 val _ = Msg.send (bio, MsgQuery (QApt pkg))
616
617 fun loop () =
618 case Msg.recv bio of
619 NONE => (print "Server closed connection unexpectedly.\n";
620 OS.Process.failure)
621 | SOME m =>
622 case m of
623 MsgYes => (print "Package is installed.\n";
624 OS.Process.success)
625 | MsgNo => (print "Package is not installed.\n";
626 OS.Process.failure)
627 | MsgError s => (print ("APT query failed: " ^ s ^ "\n");
628 OS.Process.failure)
629 | _ => (print "Unexpected server reply.\n";
630 OS.Process.failure)
631 in
632 loop ()
633 before OpenSSL.close bio
634 end
635
636 fun requestCron {node, uname} =
637 let
638 val (user, context) = requestContext (fn () => ())
639 val bio = OpenSSL.connect (context, if node = Config.masterNode then
640 dispatcher
641 else
642 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
643
644 val _ = Msg.send (bio, MsgQuery (QCron uname))
645
646 fun loop () =
647 case Msg.recv bio of
648 NONE => (print "Server closed connection unexpectedly.\n";
649 OS.Process.failure)
650 | SOME m =>
651 case m of
652 MsgYes => (print "User has cron permissions.\n";
653 OS.Process.success)
654 | MsgNo => (print "User does not have cron permissions.\n";
655 OS.Process.failure)
656 | MsgError s => (print ("Cron query failed: " ^ s ^ "\n");
657 OS.Process.failure)
658 | _ => (print "Unexpected server reply.\n";
659 OS.Process.failure)
660 in
661 loop ()
662 before OpenSSL.close bio
663 end
664
665 fun requestFtp {node, uname} =
666 let
667 val (user, context) = requestContext (fn () => ())
668 val bio = OpenSSL.connect (context, if node = Config.masterNode then
669 dispatcher
670 else
671 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
672
673 val _ = Msg.send (bio, MsgQuery (QFtp uname))
674
675 fun loop () =
676 case Msg.recv bio of
677 NONE => (print "Server closed connection unexpectedly.\n";
678 OS.Process.failure)
679 | SOME m =>
680 case m of
681 MsgYes => (print "User has FTP permissions.\n";
682 OS.Process.success)
683 | MsgNo => (print "User does not have FTP permissions.\n";
684 OS.Process.failure)
685 | MsgError s => (print ("FTP query failed: " ^ s ^ "\n");
686 OS.Process.failure)
687 | _ => (print "Unexpected server reply.\n";
688 OS.Process.failure)
689 in
690 loop ()
691 before OpenSSL.close bio
692 end
693
694 fun regenerate context =
695 let
696 val b = basis ()
697 val () = Tycheck.disallowExterns ()
698
699 val () = Domain.resetGlobal ()
700
701 fun contactNode (node, ip) =
702 if node = Config.defaultNode then
703 Domain.resetLocal ()
704 else let
705 val bio = OpenSSL.connect (context,
706 ip
707 ^ ":"
708 ^ Int.toString Config.slavePort)
709 in
710 Msg.send (bio, MsgRegenerate);
711 case Msg.recv bio of
712 NONE => print "Slave closed connection unexpectedly\n"
713 | SOME m =>
714 case m of
715 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
716 | MsgError s => print ("Slave " ^ node
717 ^ " returned error: " ^
718 s ^ "\n")
719 | _ => print ("Slave " ^ node
720 ^ " returned unexpected command\n");
721 OpenSSL.close bio
722 end
723
724 fun doUser user =
725 let
726 val _ = Domain.setUser user
727 val _ = ErrorMsg.reset ()
728
729 val dname = Config.domtoolDir user
730
731 val dir = Posix.FileSys.opendir dname
732
733 fun loop files =
734 case Posix.FileSys.readdir dir of
735 NONE => (Posix.FileSys.closedir dir;
736 files)
737 | SOME fname =>
738 if notTmp fname then
739 loop (OS.Path.joinDirFile {dir = dname,
740 file = fname}
741 :: files)
742 else
743 loop files
744
745 val files = loop []
746 val (_, files) = Order.order (SOME b) files
747 in
748 if !ErrorMsg.anyErrors then
749 print ("User " ^ user ^ "'s configuration has errors!\n")
750 else
751 app eval' files
752 end
753 handle IO.Io _ => ()
754 | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
755 | ErrorMsg.Error => print ("User " ^ user ^ " had a compilation error.\n")
756 in
757 app contactNode Config.nodeIps;
758 Env.pre ();
759 app doUser (Acl.users ());
760 Env.post ()
761 end
762
763 fun rmuser user =
764 let
765 val doms = Acl.class {user = user, class = "domain"}
766 val doms = List.filter (fn dom =>
767 case Acl.whoHas {class = "domain", value = dom} of
768 [_] => true
769 | _ => false) (StringSet.listItems doms)
770 in
771 Acl.rmuser user;
772 Domain.rmdom doms
773 end
774
775 fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
776
777 fun answerQuery q =
778 case q of
779 QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
780 | QCron user => if Cron.allowed user then MsgYes else MsgNo
781 | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
782
783 fun describeQuery q =
784 case q of
785 QApt pkg => "Requested installation status of package " ^ pkg
786 | QCron user => "Asked about cron permissions for user " ^ user
787 | QFtp user => "Asked about FTP permissions for user " ^ user
788
789 fun service () =
790 let
791 val () = Acl.read Config.aclFile
792
793 val context = OpenSSL.context (Config.serverCert,
794 Config.serverKey,
795 Config.trustStore)
796 val _ = Domain.set_context context
797
798 val sock = OpenSSL.listen (context, Config.dispatcherPort)
799
800 fun loop () =
801 case OpenSSL.accept sock of
802 NONE => ()
803 | SOME bio =>
804 let
805 val user = OpenSSL.peerCN bio
806 val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
807 val () = Domain.setUser user
808
809 fun doIt f cleanup =
810 ((case f () of
811 (msgLocal, SOME msgRemote) =>
812 (print msgLocal;
813 print "\n";
814 Msg.send (bio, MsgError msgRemote))
815 | (msgLocal, NONE) =>
816 (print msgLocal;
817 print "\n";
818 Msg.send (bio, MsgOk)))
819 handle OpenSSL.OpenSSL _ =>
820 print "OpenSSL error\n"
821 | OS.SysErr (s, _) =>
822 (print "System error: ";
823 print s;
824 print "\n";
825 Msg.send (bio, MsgError ("System error: " ^ s))
826 handle OpenSSL.OpenSSL _ => ())
827 | Fail s =>
828 (print "Failure: ";
829 print s;
830 print "\n";
831 Msg.send (bio, MsgError ("Failure: " ^ s))
832 handle OpenSSL.OpenSSL _ => ())
833 | ErrorMsg.Error =>
834 (print "Compilation error\n";
835 Msg.send (bio, MsgError "Error during configuration evaluation")
836 handle OpenSSL.OpenSSL _ => ());
837 (cleanup ();
838 ignore (OpenSSL.readChar bio);
839 OpenSSL.close bio)
840 handle OpenSSL.OpenSSL _ => ();
841 loop ())
842
843 fun doConfig codes =
844 let
845 val _ = print "Configuration:\n"
846 val _ = app (fn s => (print s; print "\n")) codes
847 val _ = print "\n"
848
849 val outname = OS.FileSys.tmpName ()
850
851 fun doOne code =
852 let
853 val outf = TextIO.openOut outname
854 in
855 TextIO.output (outf, code);
856 TextIO.closeOut outf;
857 eval' outname
858 end
859 in
860 doIt (fn () => (Env.pre ();
861 app doOne codes;
862 Env.post ();
863 Msg.send (bio, MsgOk);
864 ("Configuration complete.", NONE)))
865 (fn () => OS.FileSys.remove outname)
866 end
867
868 fun checkAddr s =
869 case String.fields (fn ch => ch = #"@") s of
870 [user'] =>
871 if user = user' then
872 SOME (SetSA.User s)
873 else
874 NONE
875 | [user', domain] =>
876 if Domain.validEmailUser user' andalso Domain.yourDomain domain then
877 SOME (SetSA.Email s)
878 else
879 NONE
880 | _ => NONE
881
882 fun cmdLoop () =
883 case Msg.recv bio of
884 NONE => (OpenSSL.close bio
885 handle OpenSSL.OpenSSL _ => ();
886 loop ())
887 | SOME m =>
888 case m of
889 MsgConfig code => doConfig [code]
890 | MsgMultiConfig codes => doConfig codes
891
892 | MsgShutdown =>
893 if Acl.query {user = user, class = "priv", value = "all"}
894 orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
895 print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
896 else
897 (print "Unauthorized shutdown command!\n";
898 OpenSSL.close bio
899 handle OpenSSL.OpenSSL _ => ();
900 loop ())
901
902 | MsgGrant acl =>
903 doIt (fn () =>
904 if Acl.query {user = user, class = "priv", value = "all"} then
905 (Acl.grant acl;
906 Acl.write Config.aclFile;
907 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
908 NONE))
909 else
910 ("Unauthorized user asked to grant a permission!",
911 SOME "Not authorized to grant privileges"))
912 (fn () => ())
913
914 | MsgRevoke acl =>
915 doIt (fn () =>
916 if Acl.query {user = user, class = "priv", value = "all"} then
917 (Acl.revoke acl;
918 Acl.write Config.aclFile;
919 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
920 NONE))
921 else
922 ("Unauthorized user asked to revoke a permission!",
923 SOME "Not authorized to revoke privileges"))
924 (fn () => ())
925
926 | MsgListPerms user =>
927 doIt (fn () =>
928 (Msg.send (bio, MsgPerms (Acl.queryAll user));
929 ("Sent permission list for user " ^ user ^ ".",
930 NONE)))
931 (fn () => ())
932
933 | MsgWhoHas perm =>
934 doIt (fn () =>
935 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
936 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
937 NONE)))
938 (fn () => ())
939
940 | MsgRmdom doms =>
941 doIt (fn () =>
942 if Acl.query {user = user, class = "priv", value = "all"}
943 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
944 (Domain.rmdom doms;
945 app (fn dom =>
946 Acl.revokeFromAll {class = "domain", value = dom}) doms;
947 Acl.write Config.aclFile;
948 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
949 NONE))
950 else
951 ("Unauthorized user asked to remove a domain!",
952 SOME "Not authorized to remove that domain"))
953 (fn () => ())
954
955 | MsgRegenerate =>
956 doIt (fn () =>
957 if Acl.query {user = user, class = "priv", value = "regen"}
958 orelse Acl.query {user = user, class = "priv", value = "all"} then
959 (regenerate context;
960 ("Regenerated all configuration.",
961 NONE))
962 else
963 ("Unauthorized user asked to regenerate!",
964 SOME "Not authorized to regenerate"))
965 (fn () => ())
966
967 | MsgRmuser user' =>
968 doIt (fn () =>
969 if Acl.query {user = user, class = "priv", value = "all"} then
970 (rmuser user';
971 Acl.write Config.aclFile;
972 ("Removed user " ^ user' ^ ".",
973 NONE))
974 else
975 ("Unauthorized user asked to remove a user!",
976 SOME "Not authorized to remove users"))
977 (fn () => ())
978
979 | MsgCreateDbUser {dbtype, passwd} =>
980 doIt (fn () =>
981 case Dbms.lookup dbtype of
982 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
983 SOME ("Unknown database type " ^ dbtype))
984 | SOME handler =>
985 case #adduser handler {user = user, passwd = passwd} of
986 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
987 NONE)
988 | SOME msg =>
989 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
990 SOME ("Error adding user: " ^ msg)))
991 (fn () => ())
992
993 | MsgDbPasswd {dbtype, passwd} =>
994 doIt (fn () =>
995 case Dbms.lookup dbtype of
996 NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
997 SOME ("Unknown database type " ^ dbtype))
998 | SOME handler =>
999 case #passwd handler {user = user, passwd = passwd} of
1000 NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1001 NONE)
1002 | SOME msg =>
1003 ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1004 SOME ("Error adding user: " ^ msg)))
1005 (fn () => ())
1006
1007 | MsgCreateDbTable {dbtype, dbname} =>
1008 doIt (fn () =>
1009 if Dbms.validDbname dbname then
1010 case Dbms.lookup dbtype of
1011 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1012 SOME ("Unknown database type " ^ dbtype))
1013 | SOME handler =>
1014 case #createdb handler {user = user, dbname = dbname} of
1015 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1016 NONE)
1017 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1018 SOME ("Error creating database: " ^ msg))
1019 else
1020 ("Invalid database name " ^ user ^ "_" ^ dbname,
1021 SOME ("Invalid database name " ^ dbname)))
1022 (fn () => ())
1023
1024 | MsgListMailboxes domain =>
1025 doIt (fn () =>
1026 if not (Domain.yourDomain domain) then
1027 ("User wasn't authorized to list mailboxes for " ^ domain,
1028 SOME "You're not authorized to configure that domain.")
1029 else
1030 case Vmail.list domain of
1031 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
1032 ("Sent mailbox list for " ^ domain,
1033 NONE))
1034 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
1035 SOME msg))
1036 (fn () => ())
1037
1038 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
1039 doIt (fn () =>
1040 if not (Domain.yourDomain domain) then
1041 ("User wasn't authorized to add a mailbox to " ^ domain,
1042 SOME "You're not authorized to configure that domain.")
1043 else if not (Domain.validEmailUser emailUser) then
1044 ("Invalid e-mail username " ^ emailUser,
1045 SOME "Invalid e-mail username")
1046 else if not (CharVector.all Char.isGraph passwd) then
1047 ("Invalid password",
1048 SOME "Invalid password; may only contain printable, non-space characters")
1049 else if not (Domain.yourPath mailbox) then
1050 ("User wasn't authorized to add a mailbox at " ^ mailbox,
1051 SOME "You're not authorized to use that mailbox location.")
1052 else
1053 case Vmail.add {requester = user,
1054 domain = domain, user = emailUser,
1055 passwd = passwd, mailbox = mailbox} of
1056 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
1057 NONE)
1058 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1059 SOME msg))
1060 (fn () => ())
1061
1062 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1063 doIt (fn () =>
1064 if not (Domain.yourDomain domain) then
1065 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1066 SOME "You're not authorized to configure that domain.")
1067 else if not (Domain.validEmailUser emailUser) then
1068 ("Invalid e-mail username " ^ emailUser,
1069 SOME "Invalid e-mail username")
1070 else if not (CharVector.all Char.isGraph passwd) then
1071 ("Invalid password",
1072 SOME "Invalid password; may only contain printable, non-space characters")
1073 else
1074 case Vmail.passwd {domain = domain, user = emailUser,
1075 passwd = passwd} of
1076 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1077 NONE)
1078 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1079 SOME msg))
1080 (fn () => ())
1081
1082 | MsgRmMailbox {domain, user = emailUser} =>
1083 doIt (fn () =>
1084 if not (Domain.yourDomain domain) then
1085 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1086 SOME "You're not authorized to configure that domain.")
1087 else if not (Domain.validEmailUser emailUser) then
1088 ("Invalid e-mail username " ^ emailUser,
1089 SOME "Invalid e-mail username")
1090 else
1091 case Vmail.rm {domain = domain, user = emailUser} of
1092 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1093 NONE)
1094 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1095 SOME msg))
1096 (fn () => ())
1097
1098 | MsgSaQuery addr =>
1099 doIt (fn () =>
1100 case checkAddr addr of
1101 NONE => ("User tried to query SA filtering for " ^ addr,
1102 SOME "You aren't allowed to configure SA filtering for that recipient.")
1103 | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1104 ("Queried SA filtering status for " ^ addr,
1105 NONE)))
1106 (fn () => ())
1107
1108 | MsgSaSet (addr, b) =>
1109 doIt (fn () =>
1110 case checkAddr addr of
1111 NONE => ("User tried to set SA filtering for " ^ addr,
1112 SOME "You aren't allowed to configure SA filtering for that recipient.")
1113 | SOME addr' => (SetSA.set (addr', b);
1114 Msg.send (bio, MsgOk);
1115 ("Set SA filtering status for " ^ addr ^ " to "
1116 ^ (if b then "ON" else "OFF"),
1117 NONE)))
1118 (fn () => ())
1119
1120 | MsgSmtpLogReq domain =>
1121 doIt (fn () =>
1122 if not (Domain.yourDomain domain) then
1123 ("Unauthorized user tried to request SMTP logs for " ^ domain,
1124 SOME "You aren't authorized to configure that domain.")
1125 else
1126 (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1127 domain;
1128 ("Requested SMTP logs for " ^ domain,
1129 NONE)))
1130 (fn () => ())
1131
1132 | MsgQuery q =>
1133 doIt (fn () => (Msg.send (bio, answerQuery q);
1134 (describeQuery q,
1135 NONE)))
1136 (fn () => ())
1137
1138 | _ =>
1139 doIt (fn () => ("Unexpected command",
1140 SOME "Unexpected command"))
1141 (fn () => ())
1142 in
1143 cmdLoop ()
1144 end
1145 handle OpenSSL.OpenSSL s =>
1146 (print ("OpenSSL error: " ^ s ^ "\n");
1147 OpenSSL.close bio
1148 handle OpenSSL.OpenSSL _ => ();
1149 loop ())
1150 | OS.SysErr (s, _) =>
1151 (print ("System error: " ^ s ^ "\n");
1152 OpenSSL.close bio
1153 handle OpenSSL.OpenSSL _ => ();
1154 loop ())
1155 in
1156 print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
1157 print "Listening for connections....\n";
1158 loop ();
1159 OpenSSL.shutdown sock
1160 end
1161
1162 fun slave () =
1163 let
1164 val host = Slave.hostname ()
1165
1166 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
1167 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1168 Config.trustStore)
1169
1170 val sock = OpenSSL.listen (context, Config.slavePort)
1171
1172 val _ = print ("Slave server starting at " ^ now () ^ "\n")
1173
1174 fun loop () =
1175 case OpenSSL.accept sock of
1176 NONE => ()
1177 | SOME bio =>
1178 let
1179 val peer = OpenSSL.peerCN bio
1180 val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
1181 in
1182 if peer = Config.dispatcherName then let
1183 fun loop' files =
1184 case Msg.recv bio of
1185 NONE => print "Dispatcher closed connection unexpectedly\n"
1186 | SOME m =>
1187 case m of
1188 MsgFile file => loop' (file :: files)
1189 | MsgDoFiles => (Slave.handleChanges files;
1190 Msg.send (bio, MsgOk))
1191 | MsgRegenerate => (Domain.resetLocal ();
1192 Msg.send (bio, MsgOk))
1193 | _ => (print "Dispatcher sent unexpected command\n";
1194 Msg.send (bio, MsgError "Unexpected command"))
1195 in
1196 loop' [];
1197 ignore (OpenSSL.readChar bio);
1198 OpenSSL.close bio;
1199 loop ()
1200 end
1201 else if peer = "domtool" then
1202 case Msg.recv bio of
1203 SOME MsgShutdown => (OpenSSL.close bio;
1204 print ("Shutting down at " ^ now () ^ "\n\n"))
1205 | _ => (OpenSSL.close bio;
1206 loop ())
1207 else
1208 case Msg.recv bio of
1209 SOME (MsgQuery q) => (print (describeQuery q ^ "\n");
1210 Msg.send (bio, answerQuery q);
1211 ignore (OpenSSL.readChar bio);
1212 OpenSSL.close bio;
1213 loop ())
1214 | _ => (OpenSSL.close bio;
1215 loop ())
1216 end handle OpenSSL.OpenSSL s =>
1217 (print ("OpenSSL error: "^ s ^ "\n");
1218 OpenSSL.close bio
1219 handle OpenSSL.OpenSSL _ => ();
1220 loop ())
1221 | OS.SysErr (s, _) =>
1222 (print ("System error: "^ s ^ "\n");
1223 OpenSSL.close bio
1224 handle OpenSSL.OpenSSL _ => ();
1225 loop ())
1226 in
1227 loop ();
1228 OpenSSL.shutdown sock
1229 end
1230
1231 fun listBasis () =
1232 let
1233 val dir = Posix.FileSys.opendir Config.libRoot
1234
1235 fun loop files =
1236 case Posix.FileSys.readdir dir of
1237 NONE => (Posix.FileSys.closedir dir;
1238 files)
1239 | SOME fname =>
1240 if String.isSuffix ".dtl" fname then
1241 loop (OS.Path.joinDirFile {dir = Config.libRoot,
1242 file = fname}
1243 :: files)
1244 else
1245 loop files
1246 in
1247 loop []
1248 end
1249
1250 fun autodocBasis outdir =
1251 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1252
1253 end