apt: Handle Description-en replacing Description in apt-cache output
[hcoop/domtool2.git] / src / main.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006-2009, Adam Chlipala
3 * Copyright (c) 2012,2013,2014 Clinton Ebadi <clinton@unknownlamer.org>
4 *
5 * This program is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU General Public License
7 * as published by the Free Software Foundation; either version 2
8 * of the License, or (at your option) any later version.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with this program; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
18 *)
19
20 (* Main interface *)
21
22 structure Main :> MAIN = struct
23
24 open Ast MsgTypes Print
25
26 structure SM = StringMap
27
28 fun init () = Acl.read Config.aclFile
29
30 fun isLib fname = OS.Path.file fname = "lib.dtl"
31
32 fun wrapFile (fname, file) =
33 case (isLib fname, file) of
34 (true, (comment, ds, SOME e)) =>
35 let
36 val (_, loc) = e
37 in
38 (comment, ds, SOME (ELocal (e, (ESkip, loc)), loc))
39 end
40 | _ => file
41
42 fun check' G fname =
43 let
44 val prog = Parse.parse fname
45 val prog = wrapFile (fname, prog)
46 in
47 if !ErrorMsg.anyErrors then
48 G
49 else
50 (if isLib fname then
51 ()
52 else
53 Option.app (Unused.check G) (#3 prog);
54 Tycheck.checkFile G prog)
55 end
56
57 fun basis () =
58 let
59 val _ = ErrorMsg.reset ()
60 val dir = Posix.FileSys.opendir Config.libRoot
61
62 fun loop files =
63 case Posix.FileSys.readdir dir of
64 NONE => (Posix.FileSys.closedir dir;
65 files)
66 | SOME fname =>
67 if String.isSuffix ".dtl" fname then
68 loop (OS.Path.joinDirFile {dir = Config.libRoot,
69 file = fname}
70 :: files)
71 else
72 loop files
73
74 val files = loop []
75 val (_, files) = Order.order NONE files
76 in
77 if !ErrorMsg.anyErrors then
78 Env.empty
79 else
80 (Tycheck.allowExterns ();
81 foldl (fn (fname, G) => check' G fname) Env.empty files
82 before Tycheck.disallowExterns ())
83 end
84
85 (* val b = basis () *)
86
87 fun check G fname =
88 let
89 val _ = ErrorMsg.reset ()
90 val _ = Env.preTycheck ()
91 in
92 if !ErrorMsg.anyErrors then
93 raise ErrorMsg.Error
94 else
95 let
96 val _ = Tycheck.disallowExterns ()
97 val _ = ErrorMsg.reset ()
98 val prog = Parse.parse fname
99 val prog = wrapFile (fname, prog)
100 in
101 if !ErrorMsg.anyErrors then
102 raise ErrorMsg.Error
103 else
104 let
105 val G' = Tycheck.checkFile G prog
106 in
107 if !ErrorMsg.anyErrors then
108 raise ErrorMsg.Error
109 else
110 (if isLib fname then
111 ()
112 else
113 Option.app (Unused.check G) (#3 prog);
114 (G', #3 prog))
115 end
116 end
117 end
118
119 fun notTmp s =
120 String.sub (s, 0) <> #"."
121 andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") s
122
123 fun setupUser () =
124 let
125 val user =
126 case Posix.ProcEnv.getenv "DOMTOOL_USER" of
127 NONE =>
128 let
129 val uid = Posix.ProcEnv.getuid ()
130 in
131 Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
132 end
133 | SOME user => user
134 in
135 Acl.read Config.aclFile;
136 Domain.setUser user;
137 user
138 end
139
140 fun checkDir' dname =
141 let
142 val b = basis ()
143
144 val dir = Posix.FileSys.opendir dname
145
146 fun loop files =
147 case Posix.FileSys.readdir dir of
148 NONE => (Posix.FileSys.closedir dir;
149 files)
150 | SOME fname =>
151 if notTmp fname then
152 loop (OS.Path.joinDirFile {dir = dname,
153 file = fname}
154 :: files)
155 else
156 loop files
157
158 val files = loop []
159 val (_, files) = Order.order (SOME b) files
160 in
161 if !ErrorMsg.anyErrors then
162 raise ErrorMsg.Error
163 else
164 (foldl (fn (fname, G) => check' G fname) b files;
165 if !ErrorMsg.anyErrors then
166 raise ErrorMsg.Error
167 else
168 ())
169 end
170
171 fun checkDir dname =
172 (setupUser ();
173 checkDir' dname)
174
175 fun reduce G fname =
176 let
177 val (G, body) = check G fname
178 in
179 if !ErrorMsg.anyErrors then
180 (G, NONE)
181 else
182 case body of
183 SOME body =>
184 let
185 val body' = Reduce.reduceExp G body
186 in
187 (*printd (PD.hovBox (PD.PPS.Rel 0,
188 [PD.string "Result:",
189 PD.space 1,
190 p_exp body']))*)
191 (G, SOME body')
192 end
193 | _ => (G, NONE)
194 end
195
196 (*(Defaults.eInit ())*)
197
198 val toplevel = Env.initialDynEnvVals Reduce.reduceExp
199
200 fun eval G evs fname =
201 case reduce G fname of
202 (G, SOME body') =>
203 if !ErrorMsg.anyErrors then
204 raise ErrorMsg.Error
205 else
206 let
207 val evs' = Eval.exec' (toplevel G, evs) body'
208 in
209 (G, evs')
210 end
211 | (G, NONE) => (G, evs)
212
213 val dispatcher =
214 Domain.nodeIp Config.dispatcherName ^ ":" ^ Int.toString Config.dispatcherPort
215
216 val self =
217 "localhost:" ^ Int.toString Config.slavePort
218
219 fun context x =
220 (OpenSSL.context false x)
221 handle e as OpenSSL.OpenSSL s =>
222 (print "Couldn't find your certificate.\nYou probably haven't been given any Domtool privileges.\n";
223 print ("I looked in: " ^ #1 x ^ "\n");
224 print ("Additional information: " ^ s ^ "\n");
225 raise e)
226
227 fun requestContext f =
228 let
229 val user = setupUser ()
230
231 val () = f ()
232
233 val context = context (Config.certDir ^ "/" ^ user ^ ".pem",
234 Config.keyDir ^ "/" ^ user ^ "/key.pem",
235 Config.trustStore)
236 in
237 (user, context)
238 end
239
240 fun requestBio' printErr f =
241 let
242 val (user, context) = requestContext f
243 in
244 (user, OpenSSL.connect printErr (context, dispatcher))
245 end
246
247 val requestBio = requestBio' true
248
249 fun requestSlaveBio' printErr =
250 let
251 val (user, context) = requestContext (fn () => ())
252 in
253 (user, OpenSSL.connect printErr (context, self))
254 end
255
256 fun requestSlaveBio () = requestSlaveBio' true
257
258 fun request (fname, libOpt) =
259 let
260 val (user, bio) = requestBio (fn () =>
261 let
262 val env = basis ()
263 val env = case libOpt of
264 NONE => env
265 | SOME lib => #1 (check env lib)
266 in
267 ignore (check env fname)
268 end)
269
270 fun readFile fname =
271 let
272 val inf = TextIO.openIn fname
273
274 fun loop lines =
275 case TextIO.inputLine inf of
276 NONE => String.concat (rev lines)
277 | SOME line => loop (line :: lines)
278 in
279 loop []
280 before TextIO.closeIn inf
281 end
282
283 val code = readFile fname
284 val msg = case libOpt of
285 NONE => MsgConfig code
286 | SOME fname' => MsgMultiConfig [readFile fname', code]
287 in
288 Msg.send (bio, msg);
289 case Msg.recv bio of
290 NONE => print "Server closed connection unexpectedly.\n"
291 | SOME m =>
292 case m of
293 MsgOk => print "Configuration succeeded.\n"
294 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
295 | _ => print "Unexpected server reply.\n";
296 OpenSSL.close bio
297 end
298 handle ErrorMsg.Error => ()
299
300 fun requestDir dname =
301 let
302 val _ = if Posix.FileSys.access (dname, []) then
303 ()
304 else
305 (print ("Can't access " ^ dname ^ ".\n");
306 print "Did you mean to run domtool on a specific file, instead of asking for all\n";
307 print "files in your ~/.domtool directory?\n";
308 OS.Process.exit OS.Process.failure)
309
310 val _ = ErrorMsg.reset ()
311
312 val (user, bio) = requestBio (fn () => checkDir' dname)
313
314 val b = basis ()
315
316 val dir = Posix.FileSys.opendir dname
317
318 fun loop files =
319 case Posix.FileSys.readdir dir of
320 NONE => (Posix.FileSys.closedir dir;
321 files)
322 | SOME fname =>
323 if notTmp fname then
324 loop (OS.Path.joinDirFile {dir = dname,
325 file = fname}
326 :: files)
327 else
328 loop files
329
330 val files = loop []
331 val (_, files) = Order.order (SOME b) files
332
333 val _ = if !ErrorMsg.anyErrors then
334 raise ErrorMsg.Error
335 else
336 ()
337
338 val codes = map (fn fname =>
339 let
340 val inf = TextIO.openIn fname
341
342 fun loop lines =
343 case TextIO.inputLine inf of
344 NONE => String.concat (rev lines)
345 | SOME line => loop (line :: lines)
346 in
347 loop []
348 before TextIO.closeIn inf
349 end) files
350 in
351 if !ErrorMsg.anyErrors then
352 ()
353 else
354 (Msg.send (bio, MsgMultiConfig codes);
355 case Msg.recv bio of
356 NONE => print "Server closed connection unexpectedly.\n"
357 | SOME m =>
358 case m of
359 MsgOk => print "Configuration succeeded.\n"
360 | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
361 | _ => print "Unexpected server reply.\n";
362 OpenSSL.close bio)
363 end
364 handle ErrorMsg.Error => ()
365
366 fun requestPing () =
367 let
368 val (_, bio) = requestBio' false (fn () => ())
369 in
370 OpenSSL.close bio;
371 OS.Process.success
372 end
373 handle _ => OS.Process.failure
374
375 fun requestShutdown () =
376 let
377 val (_, bio) = requestBio (fn () => ())
378 in
379 Msg.send (bio, MsgShutdown);
380 case Msg.recv bio of
381 NONE => ()
382 | SOME m =>
383 case m of
384 MsgOk => print "Shutdown begun.\n"
385 | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
386 | _ => print "Unexpected server reply.\n";
387 OpenSSL.close bio
388 end
389
390 fun requestSlavePing () =
391 let
392 val (_, bio) = requestSlaveBio' false
393 in
394 OpenSSL.close bio;
395 OS.Process.success
396 end
397 handle _ => OS.Process.failure
398
399 fun requestSlaveShutdown () =
400 let
401 val (_, bio) = requestSlaveBio ()
402 in
403 Msg.send (bio, MsgShutdown);
404 case Msg.recv bio of
405 NONE => ()
406 | SOME m =>
407 case m of
408 MsgOk => print "Shutdown begun.\n"
409 | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
410 | _ => print "Unexpected server reply.\n";
411 OpenSSL.close bio
412 end
413
414 fun requestGrant acl =
415 let
416 val (user, bio) = requestBio (fn () => ())
417 in
418 Msg.send (bio, MsgGrant acl);
419 case Msg.recv bio of
420 NONE => print "Server closed connection unexpectedly.\n"
421 | SOME m =>
422 case m of
423 MsgOk => print "Grant succeeded.\n"
424 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
425 | _ => print "Unexpected server reply.\n";
426 OpenSSL.close bio
427 end
428
429 fun requestRevoke acl =
430 let
431 val (user, bio) = requestBio (fn () => ())
432 in
433 Msg.send (bio, MsgRevoke acl);
434 case Msg.recv bio of
435 NONE => print "Server closed connection unexpectedly.\n"
436 | SOME m =>
437 case m of
438 MsgOk => print "Revoke succeeded.\n"
439 | MsgError s => print ("Revoke failed: " ^ s ^ "\n")
440 | _ => print "Unexpected server reply.\n";
441 OpenSSL.close bio
442 end
443
444 fun requestListPerms user =
445 let
446 val (_, bio) = requestBio (fn () => ())
447 in
448 Msg.send (bio, MsgListPerms user);
449 (case Msg.recv bio of
450 NONE => (print "Server closed connection unexpectedly.\n";
451 NONE)
452 | SOME m =>
453 case m of
454 MsgPerms perms => SOME perms
455 | MsgError s => (print ("Listing failed: " ^ s ^ "\n");
456 NONE)
457 | _ => (print "Unexpected server reply.\n";
458 NONE))
459 before OpenSSL.close bio
460 end
461
462 fun requestWhoHas perm =
463 let
464 val (_, bio) = requestBio (fn () => ())
465 in
466 Msg.send (bio, MsgWhoHas perm);
467 (case Msg.recv bio of
468 NONE => (print "Server closed connection unexpectedly.\n";
469 NONE)
470 | SOME m =>
471 case m of
472 MsgWhoHasResponse users => SOME users
473 | MsgError s => (print ("whohas failed: " ^ s ^ "\n");
474 NONE)
475 | _ => (print "Unexpected server reply.\n";
476 NONE))
477 before OpenSSL.close bio
478 end
479
480 fun requestRegen () =
481 let
482 val (_, bio) = requestBio (fn () => ())
483 in
484 Msg.send (bio, MsgRegenerate);
485 case Msg.recv bio of
486 NONE => print "Server closed connection unexpectedly.\n"
487 | SOME m =>
488 case m of
489 MsgOk => print "Regeneration succeeded.\n"
490 | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
491 | _ => print "Unexpected server reply.\n";
492 OpenSSL.close bio
493 end
494
495 fun requestRegenTc () =
496 let
497 val (_, bio) = requestBio (fn () => ())
498 in
499 Msg.send (bio, MsgRegenerateTc);
500 case Msg.recv bio of
501 NONE => print "Server closed connection unexpectedly.\n"
502 | SOME m =>
503 case m of
504 MsgOk => print "All configuration validated.\n"
505 | MsgError s => print ("Configuration validation failed: " ^ s ^ "\n")
506 | _ => print "Unexpected server reply.\n";
507 OpenSSL.close bio
508 end
509
510 fun requestRmdom dom =
511 let
512 val (_, bio) = requestBio (fn () => ())
513 in
514 Msg.send (bio, MsgRmdom dom);
515 case Msg.recv bio of
516 NONE => print "Server closed connection unexpectedly.\n"
517 | SOME m =>
518 case m of
519 MsgOk => print "Removal succeeded.\n"
520 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
521 | _ => print "Unexpected server reply.\n";
522 OpenSSL.close bio
523 end
524
525 fun requestRmuser user =
526 let
527 val (_, bio) = requestBio (fn () => ())
528 in
529 Msg.send (bio, MsgRmuser user);
530 case Msg.recv bio of
531 NONE => print "Server closed connection unexpectedly.\n"
532 | SOME m =>
533 case m of
534 MsgOk => print "Removal succeeded.\n"
535 | MsgError s => print ("Removal failed: " ^ s ^ "\n")
536 | _ => print "Unexpected server reply.\n";
537 OpenSSL.close bio
538 end
539
540 fun requestDbUser dbtype =
541 let
542 val (_, context) = requestContext (fn () => ())
543 val bio = OpenSSL.connect true (context,
544 Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
545 in
546 Msg.send (bio, MsgCreateDbUser dbtype);
547 case Msg.recv bio of
548 NONE => print "Server closed connection unexpectedly.\n"
549 | SOME m =>
550 case m of
551 MsgOk => print "Your user has been created.\n"
552 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
553 | _ => print "Unexpected server reply.\n";
554 OpenSSL.close bio
555 end
556
557 fun requestDbPasswd rc =
558 let
559 val (_, context) = requestContext (fn () => ())
560 val bio = OpenSSL.connect true (context,
561 Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
562 in
563 Msg.send (bio, MsgDbPasswd rc);
564 case Msg.recv bio of
565 NONE => print "Server closed connection unexpectedly.\n"
566 | SOME m =>
567 case m of
568 MsgOk => print "Your password has been changed.\n"
569 | MsgError s => print ("Password set failed: " ^ s ^ "\n")
570 | _ => print "Unexpected server reply.\n";
571 OpenSSL.close bio
572 end
573
574 fun requestDbTable p =
575 let
576 val (user, context) = requestContext (fn () => ())
577 val bio = OpenSSL.connect true (context,
578 Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
579 in
580 Msg.send (bio, MsgCreateDb p);
581 case Msg.recv bio of
582 NONE => print "Server closed connection unexpectedly.\n"
583 | SOME m =>
584 case m of
585 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n")
586 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
587 | _ => print "Unexpected server reply.\n";
588 OpenSSL.close bio
589 end
590
591 fun requestDbDrop p =
592 let
593 val (user, context) = requestContext (fn () => ())
594 val bio = OpenSSL.connect true (context,
595 Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
596 in
597 Msg.send (bio, MsgDropDb p);
598 case Msg.recv bio of
599 NONE => print "Server closed connection unexpectedly.\n"
600 | SOME m =>
601 case m of
602 MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been dropped.\n")
603 | MsgError s => print ("Drop failed: " ^ s ^ "\n")
604 | _ => print "Unexpected server reply.\n";
605 OpenSSL.close bio
606 end
607
608 fun requestDbGrant p =
609 let
610 val (user, context) = requestContext (fn () => ())
611 val bio = OpenSSL.connect true (context,
612 Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
613 in
614 Msg.send (bio, MsgGrantDb p);
615 case Msg.recv bio of
616 NONE => print "Server closed connection unexpectedly.\n"
617 | SOME m =>
618 case m of
619 MsgOk => print ("You've been granted all allowed privileges to database " ^ user ^ "_" ^ #dbname p ^ ".\n")
620 | MsgError s => print ("Grant failed: " ^ s ^ "\n")
621 | _ => print "Unexpected server reply.\n";
622 OpenSSL.close bio
623 end
624
625 fun requestListMailboxes domain =
626 let
627 val (_, bio) = requestBio (fn () => ())
628 in
629 Msg.send (bio, MsgListMailboxes domain);
630 (case Msg.recv bio of
631 NONE => Vmail.Error "Server closed connection unexpectedly."
632 | SOME m =>
633 case m of
634 MsgMailboxes users => (Msg.send (bio, MsgOk);
635 Vmail.Listing users)
636 | MsgError s => Vmail.Error ("Listing failed: " ^ s)
637 | _ => Vmail.Error "Unexpected server reply.")
638 before OpenSSL.close bio
639 end
640
641 fun requestNewMailbox p =
642 let
643 val (_, bio) = requestBio (fn () => ())
644 in
645 Msg.send (bio, MsgNewMailbox p);
646 case Msg.recv bio of
647 NONE => print "Server closed connection unexpectedly.\n"
648 | SOME m =>
649 case m of
650 MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n")
651 | MsgError s => print ("Creation failed: " ^ s ^ "\n")
652 | _ => print "Unexpected server reply.\n";
653 OpenSSL.close bio
654 end
655
656 fun requestPasswdMailbox p =
657 let
658 val (_, bio) = requestBio (fn () => ())
659 in
660 Msg.send (bio, MsgPasswdMailbox p);
661 case Msg.recv bio of
662 NONE => print "Server closed connection unexpectedly.\n"
663 | SOME m =>
664 case m of
665 MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
666 | MsgError s => print ("Set failed: " ^ s ^ "\n")
667 | _ => print "Unexpected server reply.\n";
668 OpenSSL.close bio
669 end
670
671 fun requestPortalPasswdMailbox p =
672 let
673 val (_, bio) = requestBio (fn () => ())
674 in
675 Msg.send (bio, MsgPortalPasswdMailbox p);
676 case Msg.recv bio of
677 NONE => print "Server closed connection unexpectedly.\n"
678 | SOME m =>
679 case m of
680 MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n")
681 | MsgError s => print ("Set failed: " ^ s ^ "\n")
682 | _ => print "Unexpected server reply.\n";
683 OpenSSL.close bio
684 end
685
686 fun requestRmMailbox p =
687 let
688 val (_, bio) = requestBio (fn () => ())
689 in
690 Msg.send (bio, MsgRmMailbox p);
691 case Msg.recv bio of
692 NONE => print "Server closed connection unexpectedly.\n"
693 | SOME m =>
694 case m of
695 MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n")
696 | MsgError s => print ("Remove failed: " ^ s ^ "\n")
697 | _ => print "Unexpected server reply.\n";
698 OpenSSL.close bio
699 end
700
701 fun requestSaQuery addr =
702 let
703 val (_, bio) = requestBio (fn () => ())
704 in
705 Msg.send (bio, MsgSaQuery addr);
706 (case Msg.recv bio of
707 NONE => print "Server closed connection unexpectedly.\n"
708 | SOME m =>
709 case m of
710 MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is "
711 ^ (if b then "ON" else "OFF") ^ ".\n");
712 Msg.send (bio, MsgOk))
713 | MsgError s => print ("Query failed: " ^ s ^ "\n")
714 | _ => print "Unexpected server reply.\n")
715 before OpenSSL.close bio
716 end
717
718 fun requestSaSet p =
719 let
720 val (_, bio) = requestBio (fn () => ())
721 in
722 Msg.send (bio, MsgSaSet p);
723 case Msg.recv bio of
724 NONE => print "Server closed connection unexpectedly.\n"
725 | SOME m =>
726 case m of
727 MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now "
728 ^ (if #2 p then "ON" else "OFF") ^ ".\n")
729 | MsgError s => print ("Set failed: " ^ s ^ "\n")
730 | _ => print "Unexpected server reply.\n";
731 OpenSSL.close bio
732 end
733
734 fun requestSmtpLog domain =
735 let
736 val (_, bio) = requestBio (fn () => ())
737
738 val _ = Msg.send (bio, MsgSmtpLogReq domain)
739
740 fun loop () =
741 case Msg.recv bio of
742 NONE => print "Server closed connection unexpectedly.\n"
743 | SOME m =>
744 case m of
745 MsgOk => ()
746 | MsgSmtpLogRes line => (print line;
747 loop ())
748 | MsgError s => print ("Log search failed: " ^ s ^ "\n")
749 | _ => print "Unexpected server reply.\n"
750 in
751 loop ();
752 OpenSSL.close bio
753 end
754
755 fun requestMysqlFixperms () =
756 let
757 val (_, context) = requestContext (fn () => ())
758 val bio = OpenSSL.connect true (context,
759 Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
760 in
761 Msg.send (bio, MsgMysqlFixperms);
762 case Msg.recv bio of
763 NONE => print "Server closed connection unexpectedly.\n"
764 | SOME m =>
765 case m of
766 MsgOk => print "Permissions granted.\n"
767 | MsgError s => print ("Failed: " ^ s ^ "\n")
768 | _ => print "Unexpected server reply.\n";
769 OpenSSL.close bio
770 end
771
772 fun requestApt {node, pkg} =
773 let
774 val (user, context) = requestContext (fn () => ())
775 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
776 dispatcher
777 else
778 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
779
780 val _ = Msg.send (bio, MsgQuery (QApt pkg))
781
782 fun loop () =
783 case Msg.recv bio of
784 NONE => (print "Server closed connection unexpectedly.\n";
785 OS.Process.failure)
786 | SOME m =>
787 case m of
788 MsgYes => (print "Package is installed.\n";
789 OS.Process.success)
790 | MsgNo => (print "Package is not installed.\n";
791 OS.Process.failure)
792 | MsgError s => (print ("APT query failed: " ^ s ^ "\n");
793 OS.Process.failure)
794 | _ => (print "Unexpected server reply.\n";
795 OS.Process.failure)
796 in
797 loop ()
798 before OpenSSL.close bio
799 end
800
801 fun requestAptExists {node, pkg} =
802 let
803 val (user, context) = requestContext (fn () => ())
804 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
805 dispatcher
806 else
807 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
808
809 val _ = Msg.send (bio, MsgQuery (QAptExists pkg))
810
811 fun loop () =
812 case Msg.recv bio of
813 NONE => (print "Server closed connection unexpectedly.\n";
814 OS.Process.failure)
815 | SOME m =>
816 case m of
817 MsgAptQuery {section,description} => (print "Package exists.\n";
818 print ("Section: " ^ section ^ "\n");
819 print ("Description: " ^ description ^ "\n");
820 OS.Process.success)
821 | MsgNo => (print "Package does not exist.\n";
822 OS.Process.failure
823 (* It might be the Wrong Thing (tm) to use MsgNo like this *))
824 | MsgError s => (print ("APT existence query failed: " ^ s ^ "\n");
825 OS.Process.failure)
826 | _ => (print "Unexpected server reply.\n";
827 OS.Process.failure)
828 in
829 loop ()
830 before OpenSSL.close bio
831 end
832
833 fun requestCron {node, uname} =
834 let
835 val (user, context) = requestContext (fn () => ())
836 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
837 dispatcher
838 else
839 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
840
841 val _ = Msg.send (bio, MsgQuery (QCron uname))
842
843 fun loop () =
844 case Msg.recv bio of
845 NONE => (print "Server closed connection unexpectedly.\n";
846 OS.Process.failure)
847 | SOME m =>
848 case m of
849 MsgYes => (print "User has cron permissions.\n";
850 OS.Process.success)
851 | MsgNo => (print "User does not have cron permissions.\n";
852 OS.Process.failure)
853 | MsgError s => (print ("Cron query failed: " ^ s ^ "\n");
854 OS.Process.failure)
855 | _ => (print "Unexpected server reply.\n";
856 OS.Process.failure)
857 in
858 loop ()
859 before OpenSSL.close bio
860 end
861
862 fun requestFtp {node, uname} =
863 let
864 val (user, context) = requestContext (fn () => ())
865 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
866 dispatcher
867 else
868 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
869
870 val _ = Msg.send (bio, MsgQuery (QFtp uname))
871
872 fun loop () =
873 case Msg.recv bio of
874 NONE => (print "Server closed connection unexpectedly.\n";
875 OS.Process.failure)
876 | SOME m =>
877 case m of
878 MsgYes => (print "User has FTP permissions.\n";
879 OS.Process.success)
880 | MsgNo => (print "User does not have FTP permissions.\n";
881 OS.Process.failure)
882 | MsgError s => (print ("FTP query failed: " ^ s ^ "\n");
883 OS.Process.failure)
884 | _ => (print "Unexpected server reply.\n";
885 OS.Process.failure)
886 in
887 loop ()
888 before OpenSSL.close bio
889 end
890
891 fun requestTrustedPath {node, uname} =
892 let
893 val (user, context) = requestContext (fn () => ())
894 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
895 dispatcher
896 else
897 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
898
899 val _ = Msg.send (bio, MsgQuery (QTrustedPath uname))
900
901 fun loop () =
902 case Msg.recv bio of
903 NONE => (print "Server closed connection unexpectedly.\n";
904 OS.Process.failure)
905 | SOME m =>
906 case m of
907 MsgYes => (print "User has trusted path restriction.\n";
908 OS.Process.success)
909 | MsgNo => (print "User does not have trusted path restriction.\n";
910 OS.Process.failure)
911 | MsgError s => (print ("Trusted path query failed: " ^ s ^ "\n");
912 OS.Process.failure)
913 | _ => (print "Unexpected server reply.\n";
914 OS.Process.failure)
915 in
916 loop ()
917 before OpenSSL.close bio
918 end
919
920 fun requestSocketPerm {node, uname} =
921 let
922 val (user, context) = requestContext (fn () => ())
923 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
924 dispatcher
925 else
926 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
927
928 val _ = Msg.send (bio, MsgQuery (QSocket uname))
929
930 fun loop () =
931 case Msg.recv bio of
932 NONE => (print "Server closed connection unexpectedly.\n";
933 OS.Process.failure)
934 | SOME m =>
935 case m of
936 MsgSocket p => (case p of
937 Any => print "Any\n"
938 | Client => print "Client\n"
939 | Server => print "Server\n"
940 | Nada => print "Nada\n";
941 OS.Process.success)
942 | MsgError s => (print ("Socket permission query failed: " ^ s ^ "\n");
943 OS.Process.failure)
944 | _ => (print "Unexpected server reply.\n";
945 OS.Process.failure)
946 in
947 loop ()
948 before OpenSSL.close bio
949 end
950
951 fun requestFirewall {node, uname} =
952 let
953 val (user, context) = requestContext (fn () => ())
954 val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then
955 dispatcher
956 else
957 Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
958
959 val _ = Msg.send (bio, MsgQuery (QFirewall {node = node, user = uname}))
960
961 fun loop () =
962 case Msg.recv bio of
963 NONE => (print "Server closed connection unexpectedly.\n";
964 OS.Process.failure)
965 | SOME m =>
966 case m of
967 MsgFirewall ls => (app (fn s => (print s; print "\n")) ls;
968 OS.Process.success)
969 | MsgError s => (print ("Firewall query failed: " ^ s ^ "\n");
970 OS.Process.failure)
971 | _ => (print "Unexpected server reply.\n";
972 OS.Process.failure)
973 in
974 loop ()
975 before OpenSSL.close bio
976 end
977
978 fun requestDescribe dom =
979 let
980 val (_, bio) = requestBio (fn () => ())
981 in
982 Msg.send (bio, MsgDescribe dom);
983 case Msg.recv bio of
984 NONE => print "Server closed connection unexpectedly.\n"
985 | SOME m =>
986 case m of
987 MsgDescription s => print s
988 | MsgError s => print ("Description failed: " ^ s ^ "\n")
989 | _ => print "Unexpected server reply.\n";
990 OpenSSL.close bio
991 end
992
993 fun requestReUsers () =
994 let
995 val (_, bio) = requestBio (fn () => ())
996 in
997 Msg.send (bio, MsgReUsers);
998 case Msg.recv bio of
999 NONE => print "Server closed connection unexpectedly.\n"
1000 | SOME m =>
1001 case m of
1002 MsgOk => print "Callbacks run.\n"
1003 | MsgError s => print ("Failed: " ^ s ^ "\n")
1004 | _ => print "Unexpected server reply.\n";
1005 OpenSSL.close bio
1006 end
1007
1008 fun requestFirewallRegen node =
1009 let
1010 val (user, context) = requestContext (fn () => ())
1011 val bio = OpenSSL.connect true (context, Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
1012 (* Only supporting on slave nodes *)
1013
1014 val _ = Msg.send (bio, MsgFirewallRegen)
1015
1016 fun handleResult () =
1017 case Msg.recv bio of
1018 NONE => (print "Server closed connection unexpectedly.\n";
1019 OS.Process.failure)
1020 | SOME m =>
1021 case m of
1022 MsgOk => (print "Firewall regenerated.\n";
1023 OS.Process.success)
1024 | MsgError s => (print ("Firewall regeneration failed: " ^ s ^ "\n");
1025 OS.Process.failure)
1026 | _ => (print "Unexpected server reply.\n";
1027 OS.Process.failure)
1028 in
1029 handleResult()
1030 before OpenSSL.close bio
1031 end
1032
1033 structure SS = StringSet
1034
1035 fun domainList dname =
1036 let
1037 val dir = Posix.FileSys.opendir dname
1038
1039 fun visitNode dset =
1040 case Posix.FileSys.readdir dir of
1041 NONE => dset
1042 | SOME node =>
1043 let
1044 val path = OS.Path.joinDirFile {dir = dname,
1045 file = node}
1046
1047 fun visitDomains (path, bfor, dset) =
1048 let
1049 val dir = Posix.FileSys.opendir path
1050
1051 fun loop dset =
1052 case Posix.FileSys.readdir dir of
1053 NONE => dset
1054 | SOME dname =>
1055 let
1056 val path = OS.Path.joinDirFile {dir = path,
1057 file = dname}
1058 in
1059 if Posix.FileSys.ST.isDir (Posix.FileSys.stat path) then
1060 let
1061 val bfor = dname :: bfor
1062 in
1063 loop (visitDomains (path, bfor,
1064 SS.add (dset,
1065 String.concatWith "." bfor)))
1066 end
1067 else
1068 loop dset
1069 end
1070 in
1071 loop dset
1072 before Posix.FileSys.closedir dir
1073 end
1074 in
1075 visitNode (visitDomains (path, [], dset))
1076 end
1077 in
1078 visitNode SS.empty
1079 before Posix.FileSys.closedir dir
1080 end
1081
1082 fun regenerateEither tc checker context =
1083 let
1084 val () = print "Starting regeneration....\n"
1085
1086 val domainsBefore =
1087 if tc then
1088 SS.empty
1089 else
1090 domainList Config.resultRoot
1091
1092 fun ifReal f =
1093 if tc then
1094 ()
1095 else
1096 f ()
1097
1098 val _ = ErrorMsg.reset ()
1099
1100 val b = basis ()
1101 val () = Tycheck.disallowExterns ()
1102
1103 val () = ifReal (fn () =>
1104 (ignore (OS.Process.system ("rm -rf " ^ Config.oldResultRoot ^ "/*"));
1105 ignore (OS.Process.system ("cp -r " ^ Config.resultRoot
1106 ^ "/* " ^ Config.oldResultRoot ^ "/"));
1107 Domain.resetGlobal ()))
1108
1109 val ok = ref true
1110
1111 fun contactNode (node, ip) =
1112 if node = Config.dispatcherName then
1113 Domain.resetLocal ()
1114 else let
1115 val bio = OpenSSL.connect true (context,
1116 ip
1117 ^ ":"
1118 ^ Int.toString Config.slavePort)
1119 in
1120 Msg.send (bio, MsgRegenerate);
1121 case Msg.recv bio of
1122 NONE => print "Slave closed connection unexpectedly\n"
1123 | SOME m =>
1124 case m of
1125 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
1126 | MsgError s => print ("Slave " ^ node
1127 ^ " returned error: " ^
1128 s ^ "\n")
1129 | _ => print ("Slave " ^ node
1130 ^ " returned unexpected command\n");
1131 OpenSSL.close bio
1132 end
1133 handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n")
1134
1135 fun doUser user =
1136 let
1137 val _ = Domain.setUser user
1138 val _ = ErrorMsg.reset ()
1139
1140 val dname = Config.domtoolDir user
1141 in
1142 if Posix.FileSys.access (dname, []) then
1143 let
1144 val dir = Posix.FileSys.opendir dname
1145
1146 fun loop files =
1147 case Posix.FileSys.readdir dir of
1148 NONE => (Posix.FileSys.closedir dir;
1149 files)
1150 | SOME fname =>
1151 if notTmp fname then
1152 loop (OS.Path.joinDirFile {dir = dname,
1153 file = fname}
1154 :: files)
1155 else
1156 loop files
1157
1158 val files = loop []
1159 val (_, files) = Order.order (SOME b) files
1160
1161 fun checker' (file, (G, evs)) =
1162 checker G evs file
1163 in
1164 if !ErrorMsg.anyErrors then
1165 (ErrorMsg.reset ();
1166 print ("User " ^ user ^ "'s configuration has errors!\n");
1167 ok := false)
1168 else
1169 ();
1170 let val basis' = basis () in
1171 ignore (foldl checker' (basis', SM.empty) files)
1172 end
1173 end
1174 else if String.isSuffix "_admin" user then
1175 ()
1176 else
1177 (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n");
1178 ok := false)
1179 end
1180 handle IO.Io {name, function, ...} =>
1181 (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
1182 ok := false)
1183 | exn as OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
1184 ok := false)
1185 | ErrorMsg.Error => (ErrorMsg.reset ();
1186 print ("User " ^ user ^ " had a compilation error.\n");
1187 ok := false)
1188 | _ => (print "Unknown exception during regeneration!\n";
1189 ok := false)
1190 in
1191 ifReal (fn () => (app contactNode Config.nodeIps;
1192 Env.pre ()));
1193 app doUser (Acl.users ());
1194 ifReal (fn () =>
1195 let
1196 val domainsAfter = domainList Config.resultRoot
1197 val domainsGone = SS.difference (domainsBefore, domainsAfter)
1198 in
1199 if SS.isEmpty domainsGone then
1200 ()
1201 else
1202 (print "Domains to kill:";
1203 SS.app (fn s => (print " "; print s)) domainsGone;
1204 print "\n";
1205
1206 Domain.rmdom' Config.oldResultRoot (SS.listItems domainsGone));
1207
1208 Env.post ()
1209 end);
1210 !ok
1211 end
1212
1213 val regenerate = regenerateEither false eval
1214 val regenerateTc = regenerateEither true
1215 (fn G => fn evs => fn file =>
1216 (#1 (check G file), evs))
1217
1218 fun usersChanged () =
1219 (Domain.onUsersChange ();
1220 ignore (OS.Process.system Config.publish_reusers))
1221
1222 fun rmuser user =
1223 let
1224 val doms = Acl.class {user = user, class = "domain"}
1225 val doms = List.filter (fn dom =>
1226 case Acl.whoHas {class = "domain", value = dom} of
1227 [_] => true
1228 | _ => false) (StringSet.listItems doms)
1229 in
1230 Acl.rmuser user;
1231 Domain.rmdom doms;
1232 usersChanged ()
1233 end
1234
1235 fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
1236
1237 fun answerQuery q =
1238 case q of
1239 QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
1240 | QAptExists pkg => (case Apt.info pkg of
1241 SOME {section, description} => MsgAptQuery {section = section, description = description}
1242 | NONE => MsgNo)
1243 | QCron user => if Cron.allowed user then MsgYes else MsgNo
1244 | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
1245 | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
1246 | QSocket user => MsgSocket (SocketPerm.query user)
1247 | QFirewall {node, user} => MsgFirewall (Firewall.query (node, user))
1248
1249 fun describeQuery q =
1250 case q of
1251 QApt pkg => "Requested installation status of package " ^ pkg
1252 | QAptExists pkg => "Requested if package " ^ pkg ^ " exists"
1253 | QCron user => "Asked about cron permissions for user " ^ user
1254 | QFtp user => "Asked about FTP permissions for user " ^ user
1255 | QTrustedPath user => "Asked about trusted path settings for user " ^ user
1256 | QSocket user => "Asked about socket permissions for user " ^ user
1257 | QFirewall {node, user} => "Asked about firewall rules on " ^ node ^ " for user " ^ user
1258
1259 fun doIt' loop bio f cleanup =
1260 ((case f () of
1261 (msgLocal, SOME msgRemote) =>
1262 (print msgLocal;
1263 print "\n";
1264 Msg.send (bio, MsgError msgRemote))
1265 | (msgLocal, NONE) =>
1266 (print msgLocal;
1267 print "\n";
1268 Msg.send (bio, MsgOk)))
1269 handle e as (OpenSSL.OpenSSL s) =>
1270 (print ("OpenSSL error: " ^ s ^ "\n");
1271 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1272 Msg.send (bio, MsgError ("OpenSSL error: " ^ s))
1273 handle OpenSSL.OpenSSL _ => ())
1274 | OS.SysErr (s, _) =>
1275 (print "System error: ";
1276 print s;
1277 print "\n";
1278 Msg.send (bio, MsgError ("System error: " ^ s))
1279 handle OpenSSL.OpenSSL _ => ())
1280 | Fail s =>
1281 (print "Failure: ";
1282 print s;
1283 print "\n";
1284 Msg.send (bio, MsgError ("Failure: " ^ s))
1285 handle OpenSSL.OpenSSL _ => ())
1286 | ErrorMsg.Error =>
1287 (print "Compilation error\n";
1288 Msg.send (bio, MsgError "Error during configuration evaluation")
1289 handle OpenSSL.OpenSSL _ => ());
1290 (cleanup ();
1291 ignore (OpenSSL.readChar bio);
1292 OpenSSL.close bio)
1293 handle OpenSSL.OpenSSL _ => ();
1294 loop ())
1295
1296 fun service () =
1297 let
1298 val host = Slave.hostname ()
1299
1300 val () = Acl.read Config.aclFile
1301
1302 val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1303 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1304 Config.trustStore)
1305 val _ = Domain.set_context context
1306
1307 val sock = OpenSSL.listen (context, Config.dispatcherPort)
1308
1309 fun loop () =
1310 (case OpenSSL.accept sock of
1311 NONE => ()
1312 | SOME bio =>
1313 let
1314 val user = OpenSSL.peerCN bio
1315 val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
1316 val () = Domain.setUser user
1317 val doIt = doIt' loop bio
1318
1319 fun doConfig codes =
1320 let
1321 val _ = print "Configuration:\n"
1322 val _ = app (fn s => (print s; print "\n")) codes
1323 val _ = print "\n"
1324
1325 val outname = OS.FileSys.tmpName ()
1326
1327 fun doOne (code, (G, evs)) =
1328 let
1329 val outf = TextIO.openOut outname
1330 in
1331 TextIO.output (outf, code);
1332 TextIO.closeOut outf;
1333 eval G evs outname
1334 end
1335 in
1336 doIt (fn () => (Env.pre ();
1337 let val basis' = basis () in
1338 ignore (foldl doOne (basis', SM.empty) codes)
1339 end;
1340 Env.post ();
1341 Msg.send (bio, MsgOk);
1342 ("Configuration complete.", NONE)))
1343 (fn () => OS.FileSys.remove outname)
1344 end
1345
1346 fun checkAddr s =
1347 case String.fields (fn ch => ch = #"@") s of
1348 [user'] =>
1349 if user = user' then
1350 SOME (SetSA.User s)
1351 else
1352 NONE
1353 | [user', domain] =>
1354 if Domain.validEmailUser user' andalso Domain.yourDomain domain then
1355 SOME (SetSA.Email s)
1356 else
1357 NONE
1358 | _ => NONE
1359
1360 fun cmdLoop () =
1361 case Msg.recv bio of
1362 NONE => (OpenSSL.close bio
1363 handle OpenSSL.OpenSSL _ => ();
1364 loop ())
1365 | SOME m =>
1366 case m of
1367 MsgConfig code => doConfig [code]
1368 | MsgMultiConfig codes => doConfig codes
1369
1370 | MsgShutdown =>
1371 if Acl.query {user = user, class = "priv", value = "all"}
1372 orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
1373 print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
1374 else
1375 (print "Unauthorized shutdown command!\n";
1376 OpenSSL.close bio
1377 handle OpenSSL.OpenSSL _ => ();
1378 loop ())
1379
1380 | MsgGrant acl =>
1381 doIt (fn () =>
1382 if Acl.query {user = user, class = "priv", value = "all"} then
1383 (Acl.grant acl;
1384 Acl.write Config.aclFile;
1385 if #class acl = "user" then
1386 usersChanged ()
1387 else
1388 ();
1389 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
1390 NONE))
1391 else
1392 ("Unauthorized user asked to grant a permission!",
1393 SOME "Not authorized to grant privileges"))
1394 (fn () => ())
1395
1396 | MsgRevoke acl =>
1397 doIt (fn () =>
1398 if Acl.query {user = user, class = "priv", value = "all"} then
1399 (Acl.revoke acl;
1400 Acl.write Config.aclFile;
1401 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
1402 NONE))
1403 else
1404 ("Unauthorized user asked to revoke a permission!",
1405 SOME "Not authorized to revoke privileges"))
1406 (fn () => ())
1407
1408 | MsgListPerms user =>
1409 doIt (fn () =>
1410 (Msg.send (bio, MsgPerms (Acl.queryAll user));
1411 ("Sent permission list for user " ^ user ^ ".",
1412 NONE)))
1413 (fn () => ())
1414
1415 | MsgWhoHas perm =>
1416 doIt (fn () =>
1417 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
1418 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
1419 NONE)))
1420 (fn () => ())
1421
1422 | MsgRmdom doms =>
1423 doIt (fn () =>
1424 if Acl.query {user = user, class = "priv", value = "all"}
1425 orelse List.all (fn dom => Domain.validDomain dom
1426 andalso Acl.queryDomain {user = user, domain = dom}) doms then
1427 (Domain.rmdom doms;
1428 (*app (fn dom =>
1429 Acl.revokeFromAll {class = "domain", value = dom}) doms;
1430 Acl.write Config.aclFile;*)
1431 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
1432 NONE))
1433 else
1434 ("Unauthorized user asked to remove a domain!",
1435 SOME "Not authorized to remove that domain"))
1436 (fn () => ())
1437
1438 | MsgRegenerate =>
1439 doIt (fn () =>
1440 if Acl.query {user = user, class = "priv", value = "regen"}
1441 orelse Acl.query {user = user, class = "priv", value = "all"} then
1442 (if regenerate context then
1443 ("Regenerated all configuration.",
1444 NONE)
1445 else
1446 ("Error regenerating configuration!",
1447 SOME "Error regenerating configuration! Consult /var/log/domtool.log."))
1448 else
1449 ("Unauthorized user asked to regenerate!",
1450 SOME "Not authorized to regenerate"))
1451 (fn () => ())
1452
1453 | MsgRegenerateTc =>
1454 doIt (fn () =>
1455 if Acl.query {user = user, class = "priv", value = "regen"}
1456 orelse Acl.query {user = user, class = "priv", value = "all"} then
1457 (if regenerateTc context then
1458 ("Checked all configuration.",
1459 NONE)
1460 else
1461 ("Found a compilation error!",
1462 SOME "Found a compilation error! Consult /var/log/domtool.log."))
1463 else
1464 ("Unauthorized user asked to regenerate -tc!",
1465 SOME "Not authorized to regenerate -tc"))
1466 (fn () => ())
1467
1468 | MsgRmuser user' =>
1469 doIt (fn () =>
1470 if Acl.query {user = user, class = "priv", value = "all"} then
1471 (rmuser user';
1472 Acl.write Config.aclFile;
1473 ("Removed user " ^ user' ^ ".",
1474 NONE))
1475 else
1476 ("Unauthorized user asked to remove a user!",
1477 SOME "Not authorized to remove users"))
1478 (fn () => ())
1479
1480 | MsgListMailboxes domain =>
1481 doIt (fn () =>
1482 if not (Domain.yourDomain domain) then
1483 ("User wasn't authorized to list mailboxes for " ^ domain,
1484 SOME "You're not authorized to configure that domain.")
1485 else
1486 case Vmail.list domain of
1487 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
1488 ("Sent mailbox list for " ^ domain,
1489 NONE))
1490 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
1491 SOME msg))
1492 (fn () => ())
1493
1494 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
1495 doIt (fn () =>
1496 if not (Domain.yourDomain domain) then
1497 ("User wasn't authorized to add a mailbox to " ^ domain,
1498 SOME "You're not authorized to configure that domain.")
1499 else if not (Domain.validEmailUser emailUser) then
1500 ("Invalid e-mail username " ^ emailUser,
1501 SOME "Invalid e-mail username")
1502 else if not (CharVector.all Char.isGraph passwd) then
1503 ("Invalid password",
1504 SOME "Invalid password; may only contain printable, non-space characters")
1505 else if not (Domain.yourPath mailbox) then
1506 ("User wasn't authorized to add a mailbox at " ^ mailbox,
1507 SOME ("You're not authorized to use that mailbox location. ("
1508 ^ mailbox ^ ")"))
1509 else
1510 case Vmail.add {requester = user,
1511 domain = domain, user = emailUser,
1512 passwd = passwd, mailbox = mailbox} of
1513 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
1514 NONE)
1515 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1516 SOME msg))
1517 (fn () => ())
1518
1519 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1520 doIt (fn () =>
1521 if not (Domain.yourDomain domain) then
1522 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1523 SOME "You're not authorized to configure that domain.")
1524 else if not (Domain.validEmailUser emailUser) then
1525 ("Invalid e-mail username " ^ emailUser,
1526 SOME "Invalid e-mail username")
1527 else if not (CharVector.all Char.isGraph passwd) then
1528 ("Invalid password",
1529 SOME "Invalid password; may only contain printable, non-space characters")
1530 else
1531 case Vmail.passwd {domain = domain, user = emailUser,
1532 passwd = passwd} of
1533 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1534 NONE)
1535 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1536 SOME msg))
1537 (fn () => ())
1538
1539 | MsgPortalPasswdMailbox {domain, user = emailUser, oldpasswd, newpasswd} =>
1540 doIt (fn () =>
1541 if not (Acl.query {user = user, class = "priv", value = "vmail"}) then
1542 ("User is not authorized to run portal vmail password",
1543 SOME "You're not authorized to use the portal password command")
1544 else if not (Domain.validEmailUser emailUser) then
1545 ("Invalid e-mail username " ^ emailUser,
1546 SOME "Invalid e-mail username")
1547 else if not (CharVector.all Char.isGraph oldpasswd
1548 andalso CharVector.all Char.isGraph newpasswd) then
1549 ("Invalid password",
1550 SOME "Invalid password; may only contain printable, non-space characters")
1551 else
1552 case Vmail.portalpasswd {domain = domain, user = emailUser,
1553 oldpasswd = oldpasswd, newpasswd = newpasswd} of
1554 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1555 NONE)
1556 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1557 SOME msg))
1558 (fn () => ())
1559
1560 | MsgRmMailbox {domain, user = emailUser} =>
1561 doIt (fn () =>
1562 if not (Domain.yourDomain domain) then
1563 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1564 SOME "You're not authorized to configure that domain.")
1565 else if not (Domain.validEmailUser emailUser) then
1566 ("Invalid e-mail username " ^ emailUser,
1567 SOME "Invalid e-mail username")
1568 else
1569 case Vmail.rm {domain = domain, user = emailUser} of
1570 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1571 NONE)
1572 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
1573 SOME msg))
1574 (fn () => ())
1575
1576 | MsgSaQuery addr =>
1577 doIt (fn () =>
1578 case checkAddr addr of
1579 NONE => ("User tried to query SA filtering for " ^ addr,
1580 SOME "You aren't allowed to configure SA filtering for that recipient.")
1581 | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1582 ("Queried SA filtering status for " ^ addr,
1583 NONE)))
1584 (fn () => ())
1585
1586 | MsgSaSet (addr, b) =>
1587 doIt (fn () =>
1588 case checkAddr addr of
1589 NONE => ("User tried to set SA filtering for " ^ addr,
1590 SOME "You aren't allowed to configure SA filtering for that recipient.")
1591 | SOME addr' => (SetSA.set (addr', b);
1592 SetSA.rebuild ();
1593 Msg.send (bio, MsgOk);
1594 ("Set SA filtering status for " ^ addr ^ " to "
1595 ^ (if b then "ON" else "OFF"),
1596 NONE)))
1597 (fn () => ())
1598
1599 | MsgSmtpLogReq domain =>
1600 doIt (fn () =>
1601 if not (Domain.yourDomain domain) then
1602 ("Unauthorized user tried to request SMTP logs for " ^ domain,
1603 SOME "You aren't authorized to configure that domain.")
1604 else
1605 (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1606 domain;
1607 ("Requested SMTP logs for " ^ domain,
1608 NONE)))
1609 (fn () => ())
1610
1611 | MsgQuery q =>
1612 doIt (fn () => (Msg.send (bio, answerQuery q);
1613 (describeQuery q,
1614 NONE)))
1615 (fn () => ())
1616 | MsgDescribe dom =>
1617 doIt (fn () => if not (Domain.validDomain dom) then
1618 ("Requested description of invalid domain " ^ dom,
1619 SOME "Invalid domain name")
1620 else if not (Domain.yourDomain dom
1621 orelse Acl.query {user = user, class = "priv", value = "all"}) then
1622 ("Requested description of " ^ dom ^ ", but not allowed access",
1623 SOME "Access denied")
1624 else
1625 (Msg.send (bio, MsgDescription (Domain.describe dom));
1626 ("Sent description of domain " ^ dom,
1627 NONE)))
1628 (fn () => ())
1629
1630 | MsgReUsers =>
1631 doIt (fn () => if Acl.query {user = user, class = "priv", value = "regen"}
1632 orelse Acl.query {user = user, class = "priv", value = "all"} then
1633 (usersChanged ();
1634 ("Users change callbacks run", NONE))
1635 else
1636 ("Unauthorized user asked to reusers!",
1637 SOME "You aren't authorized to regenerate files."))
1638 (fn () => ())
1639
1640 | _ =>
1641 doIt (fn () => ("Unexpected command",
1642 SOME "Unexpected command"))
1643 (fn () => ())
1644 in
1645 cmdLoop ()
1646 end
1647 handle e as (OpenSSL.OpenSSL s) =>
1648 (print ("OpenSSL error: " ^ s ^ "\n");
1649 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1650 OpenSSL.close bio
1651 handle OpenSSL.OpenSSL _ => ();
1652 loop ())
1653 | OS.SysErr (s, _) =>
1654 (print ("System error: " ^ s ^ "\n");
1655 OpenSSL.close bio
1656 handle OpenSSL.OpenSSL _ => ();
1657 loop ())
1658 | IO.Io {name, function, cause} =>
1659 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1660 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1661 OpenSSL.close bio
1662 handle OpenSSL.OpenSSL _ => ();
1663 loop ())
1664 | OS.Path.InvalidArc =>
1665 (print "Invalid arc\n";
1666 OpenSSL.close bio
1667 handle OpenSSL.OpenSSL _ => ();
1668 loop ())
1669 | e =>
1670 (print "Unknown exception in main loop!\n";
1671 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1672 OpenSSL.close bio
1673 handle OpenSSL.OpenSSL _ => ();
1674 loop ()))
1675 handle e as (OpenSSL.OpenSSL s) =>
1676 (print ("OpenSSL error: " ^ s ^ "\n");
1677 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1678 loop ())
1679 | OS.SysErr (s, _) =>
1680 (print ("System error: " ^ s ^ "\n");
1681 loop ())
1682 | IO.Io {name, function, cause} =>
1683 (print ("IO error: " ^ function ^ " for " ^ name ^ "\n");
1684 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause);
1685 loop ())
1686 | e =>
1687 (print "Unknown exception in main loop!\n";
1688 app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
1689 loop ())
1690 in
1691 print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
1692 print "Listening for connections....\n";
1693 loop ();
1694 OpenSSL.shutdown sock
1695 end
1696
1697 fun slave () =
1698 let
1699 val host = Slave.hostname ()
1700
1701 val context = context (Config.certDir ^ "/" ^ host ^ ".pem",
1702 Config.keyDir ^ "/" ^ host ^ "/key.pem",
1703 Config.trustStore)
1704
1705 val sock = OpenSSL.listen (context, Config.slavePort)
1706
1707 val _ = print ("Slave server starting at " ^ now () ^ "\n")
1708
1709 fun loop () =
1710 (case OpenSSL.accept sock of
1711 NONE => ()
1712 | SOME bio =>
1713 let
1714 val peer = OpenSSL.peerCN bio
1715 val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
1716 in
1717 if peer = Config.dispatcherName then let
1718 fun loop' files =
1719 case Msg.recv bio of
1720 NONE => print "Dispatcher closed connection unexpectedly\n"
1721 | SOME m =>
1722 case m of
1723 MsgFile file => loop' (file :: files)
1724 | MsgDoFiles => (Slave.handleChanges files;
1725 Msg.send (bio, MsgOk))
1726 | MsgRegenerate => (Domain.resetLocal ();
1727 Msg.send (bio, MsgOk))
1728 | MsgVmailChanged => (if Vmail.doChanged () then
1729 Msg.send (bio, MsgOk)
1730 else
1731 Msg.send (bio, MsgError "userdb update failed"))
1732 | MsgSaChanged => (if Slave.shell [Config.SpamAssassin.postReload] then
1733 Msg.send (bio, MsgOk)
1734 else
1735 Msg.send (bio, MsgError "Error reloading SpamAssassin addresses"))
1736 | _ => (print "Dispatcher sent unexpected command\n";
1737 Msg.send (bio, MsgError "Unexpected command"))
1738 in
1739 loop' [];
1740 ignore (OpenSSL.readChar bio);
1741 OpenSSL.close bio;
1742 loop ()
1743 end
1744 else if peer = "domtool" then
1745 case Msg.recv bio of
1746 SOME MsgShutdown => (OpenSSL.close bio;
1747 print ("Shutting down at " ^ now () ^ "\n\n"))
1748 | _ => (OpenSSL.close bio;
1749 loop ())
1750 else
1751 let
1752 val doIt = doIt' loop bio
1753 val user = peer
1754 in
1755 case Msg.recv bio of
1756 NONE => (OpenSSL.close bio
1757 handle OpenSSL.OpenSSL _ => ();
1758 loop ())
1759 | SOME m =>
1760 case m of
1761 (MsgQuery q) => (print (describeQuery q ^ "\n");
1762 Msg.send (bio, answerQuery q);
1763 ignore (OpenSSL.readChar bio);
1764 OpenSSL.close bio;
1765 loop ())
1766 | MsgCreateDbUser {dbtype, passwd} =>
1767 doIt (fn () =>
1768 case Dbms.lookup dbtype of
1769 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
1770 SOME ("Unknown database type " ^ dbtype))
1771 | SOME handler =>
1772 case #adduser handler {user = user, passwd = passwd} of
1773 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
1774 NONE)
1775 | SOME msg =>
1776 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
1777 SOME ("Error adding user: " ^ msg)))
1778 (fn () => ())
1779
1780 | MsgDbPasswd {dbtype, passwd} =>
1781 doIt (fn () =>
1782 case Dbms.lookup dbtype of
1783 NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
1784 SOME ("Unknown database type " ^ dbtype))
1785 | SOME handler =>
1786 case #passwd handler {user = user, passwd = passwd} of
1787 NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
1788 NONE)
1789 | SOME msg =>
1790 ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
1791 SOME ("Error adding user: " ^ msg)))
1792 (fn () => ())
1793
1794 | MsgCreateDb {dbtype, dbname, encoding} =>
1795 doIt (fn () =>
1796 if Dbms.validDbname dbname then
1797 case Dbms.lookup dbtype of
1798 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
1799 SOME ("Unknown database type " ^ dbtype))
1800 | SOME handler =>
1801 if not (Dbms.validEncoding encoding) then
1802 ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.",
1803 SOME "Invalid encoding")
1804 else
1805 case #createdb handler {user = user, dbname = dbname, encoding = encoding} of
1806 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
1807 NONE)
1808 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1809 SOME ("Error creating database: " ^ msg))
1810 else
1811 ("Invalid database name " ^ user ^ "_" ^ dbname,
1812 SOME ("Invalid database name " ^ dbname)))
1813 (fn () => ())
1814
1815 | MsgDropDb {dbtype, dbname} =>
1816 doIt (fn () =>
1817 if Dbms.validDbname dbname then
1818 case Dbms.lookup dbtype of
1819 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1820 SOME ("Unknown database type " ^ dbtype))
1821 | SOME handler =>
1822 case #dropdb handler {user = user, dbname = dbname} of
1823 NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
1824 NONE)
1825 | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1826 SOME ("Error dropping database: " ^ msg))
1827 else
1828 ("Invalid database name " ^ user ^ "_" ^ dbname,
1829 SOME ("Invalid database name " ^ dbname)))
1830 (fn () => ())
1831
1832 | MsgGrantDb {dbtype, dbname} =>
1833 doIt (fn () =>
1834 if Dbms.validDbname dbname then
1835 case Dbms.lookup dbtype of
1836 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
1837 SOME ("Unknown database type " ^ dbtype))
1838 | SOME handler =>
1839 case #grant handler {user = user, dbname = dbname} of
1840 NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".",
1841 NONE)
1842 | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
1843 SOME ("Error granting permissions to database: " ^ msg))
1844 else
1845 ("Invalid database name " ^ user ^ "_" ^ dbname,
1846 SOME ("Invalid database name " ^ dbname)))
1847 (fn () => ())
1848 | MsgMysqlFixperms =>
1849 (print "Starting mysql-fixperms\n";
1850 doIt (fn () => if OS.Process.isSuccess
1851 (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then
1852 ("Requested mysql-fixperms",
1853 NONE)
1854 else
1855 ("Requested mysql-fixperms, but execution failed!",
1856 SOME "Script execution failed."))
1857 (fn () => ()))
1858 | MsgFirewallRegen =>
1859 doIt (fn () => (Acl.read Config.aclFile;
1860 if Acl.query {user = user, class = "priv", value = "all"} then
1861 if List.exists (fn x => x = host) Config.Firewall.firewallNodes then
1862 if (Firewall.generateFirewallConfig (Firewall.parseRules ()) andalso Firewall.publishConfig ())
1863 then
1864 ("Firewall rules regenerated.", NONE)
1865 else
1866 ("Rules regeneration failed!", SOME "Script execution failed.")
1867 else ("Node not controlled by domtool firewall.", SOME (host))
1868 else
1869 ("Not authorized to regenerate firewall.", SOME ("Unauthorized user " ^ user ^ " attempted to regenerated firewall"))))
1870 (fn () => ())
1871
1872 | _ => (OpenSSL.close bio;
1873 loop ())
1874 end
1875 end handle OpenSSL.OpenSSL s =>
1876 (print ("OpenSSL error: " ^ s ^ "\n");
1877 OpenSSL.close bio
1878 handle OpenSSL.OpenSSL _ => ();
1879 loop ())
1880 | e as OS.SysErr (s, _) =>
1881 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1882 print ("System error: "^ s ^ "\n");
1883 OpenSSL.close bio
1884 handle OpenSSL.OpenSSL _ => ();
1885 loop ())
1886 | IO.Io {function, name, ...} =>
1887 (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");
1888 OpenSSL.close bio
1889 handle OpenSSL.OpenSSL _ => ();
1890 loop ())
1891 | e =>
1892 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1893 print "Uncaught exception!\n";
1894 OpenSSL.close bio
1895 handle OpenSSL.OpenSSL _ => ();
1896 loop ()))
1897 handle OpenSSL.OpenSSL s =>
1898 (print ("OpenSSL error: " ^ s ^ "\n");
1899 loop ())
1900 | e =>
1901 (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
1902 print "Uncaught exception!\n";
1903 loop ())
1904 in
1905 loop ();
1906 OpenSSL.shutdown sock
1907 end
1908
1909 fun listBasis () =
1910 let
1911 val dir = Posix.FileSys.opendir Config.libRoot
1912
1913 fun loop files =
1914 case Posix.FileSys.readdir dir of
1915 NONE => (Posix.FileSys.closedir dir;
1916 files)
1917 | SOME fname =>
1918 if String.isSuffix ".dtl" fname then
1919 loop (OS.Path.joinDirFile {dir = Config.libRoot,
1920 file = fname}
1921 :: files)
1922 else
1923 loop files
1924 in
1925 loop []
1926 end
1927
1928 fun autodocBasis outdir =
1929 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1930
1931 end