Testing queries on slave servers
[hcoop/domtool2.git] / src / main.sml
CommitLineData
234b917a
AC
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.
dac62e84 17 *)
234b917a
AC
18
19(* Main interface *)
20
21structure Main :> MAIN = struct
22
36e42cb8 23open Ast MsgTypes Print
234b917a 24
6ae327f8
AC
25structure SM = StringMap
26
aa56e112 27fun init () = Acl.read Config.aclFile
234b917a 28
d189ec0e 29fun check' G fname =
a3698041
AC
30 let
31 val prog = Parse.parse fname
32 in
33 if !ErrorMsg.anyErrors then
d189ec0e 34 G
a3698041 35 else
aa56e112 36 Tycheck.checkFile G (Defaults.tInit ()) prog
a3698041
AC
37 end
38
d189ec0e 39fun basis () =
234b917a 40 let
d189ec0e
AC
41 val dir = Posix.FileSys.opendir Config.libRoot
42
43 fun loop files =
44 case Posix.FileSys.readdir dir of
d612d62c
AC
45 NONE => (Posix.FileSys.closedir dir;
46 files)
d189ec0e
AC
47 | SOME fname =>
48 if String.isSuffix ".dtl" fname then
d612d62c
AC
49 loop (OS.Path.joinDirFile {dir = Config.libRoot,
50 file = fname}
d189ec0e
AC
51 :: files)
52 else
53 loop files
54
55 val files = loop []
c53e82e4 56 val (_, files) = Order.order NONE files
d189ec0e 57 in
6ae327f8
AC
58 if !ErrorMsg.anyErrors then
59 Env.empty
60 else
b3159a70
AC
61 (Tycheck.allowExterns ();
62 foldl (fn (fname, G) => check' G fname) Env.empty files
63 before Tycheck.disallowExterns ())
d189ec0e
AC
64 end
65
66fun check fname =
67 let
68 val _ = ErrorMsg.reset ()
12adf55a 69 val _ = Env.preTycheck ()
d189ec0e
AC
70
71 val b = basis ()
234b917a
AC
72 in
73 if !ErrorMsg.anyErrors then
36e42cb8 74 raise ErrorMsg.Error
234b917a
AC
75 else
76 let
b3159a70 77 val _ = Tycheck.disallowExterns ()
7f012ffd 78 val _ = ErrorMsg.reset ()
d189ec0e 79 val prog = Parse.parse fname
234b917a 80 in
492c1cff 81 if !ErrorMsg.anyErrors then
36e42cb8 82 raise ErrorMsg.Error
492c1cff 83 else
d189ec0e 84 let
aa56e112 85 val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
d189ec0e 86 in
36e42cb8
AC
87 if !ErrorMsg.anyErrors then
88 raise ErrorMsg.Error
89 else
90 (G', #3 prog)
d189ec0e 91 end
234b917a
AC
92 end
93 end
94
c53e82e4
AC
95val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")
96
97fun 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
1824f573 119 raise ErrorMsg.Error
c53e82e4
AC
120 else
121 (foldl (fn (fname, G) => check' G fname) b files;
1824f573
AC
122 if !ErrorMsg.anyErrors then
123 raise ErrorMsg.Error
124 else
125 ())
c53e82e4
AC
126 end
127
d189ec0e 128fun reduce fname =
a3698041 129 let
d189ec0e 130 val (G, body) = check fname
a3698041
AC
131 in
132 if !ErrorMsg.anyErrors then
d189ec0e 133 NONE
a3698041 134 else
d189ec0e
AC
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
a3698041
AC
147 end
148
d189ec0e
AC
149fun eval fname =
150 case reduce fname of
151 (SOME body') =>
152 if !ErrorMsg.anyErrors then
36e42cb8 153 raise ErrorMsg.Error
d189ec0e 154 else
aa56e112 155 Eval.exec (Defaults.eInit ()) body'
36e42cb8 156 | NONE => raise ErrorMsg.Error
d189ec0e 157
1824f573
AC
158fun 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
3b267643
AC
167val dispatcher =
168 Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
559e89e9 169
c9731b9b
AC
170val self =
171 "localhost:" ^ Int.toString Config.slavePort
172
5ee41dd0 173fun requestContext f =
07cc384c 174 let
a56cc2c3
AC
175 val uid = Posix.ProcEnv.getuid ()
176 val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid)
5ee41dd0 177
a56cc2c3
AC
178 val () = Acl.read Config.aclFile
179 val () = Domain.setUser user
5ee41dd0
AC
180
181 val () = f ()
aa56e112 182
aa56e112 183 val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem",
a088cea6 184 Config.keyDir ^ "/" ^ user ^ "/key.pem",
3b267643 185 Config.trustStore)
5ee41dd0
AC
186 in
187 (user, context)
188 end
07cc384c 189
5ee41dd0
AC
190fun requestBio f =
191 let
192 val (user, context) = requestContext f
193 in
194 (user, OpenSSL.connect (context, dispatcher))
195 end
196
c9731b9b
AC
197fun requestSlaveBio () =
198 let
199 val (user, context) = requestContext (fn () => ())
200 in
201 (user, OpenSSL.connect (context, self))
202 end
203
5ee41dd0
AC
204fun request fname =
205 let
206 val (user, bio) = requestBio (fn () => ignore (check fname))
559e89e9 207
3b267643
AC
208 val inf = TextIO.openIn fname
209
36e42cb8 210 fun loop lines =
3b267643 211 case TextIO.inputLine inf of
36e42cb8
AC
212 NONE => String.concat (List.rev lines)
213 | SOME line => loop (line :: lines)
214
215 val code = loop []
559e89e9 216 in
3b267643 217 TextIO.closeIn inf;
36e42cb8
AC
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";
3b267643 226 OpenSSL.close bio
559e89e9 227 end
aa56e112 228 handle ErrorMsg.Error => ()
559e89e9 229
c53e82e4
AC
230fun requestDir dname =
231 let
1824f573
AC
232 val _ = ErrorMsg.reset ()
233
234 val (user, bio) = requestBio (fn () => checkDir dname)
c53e82e4
AC
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
1824f573
AC
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)
c53e82e4
AC
285 end
286 handle ErrorMsg.Error => ()
287
62260c5f
AC
288fun 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
9f27d58f
AC
297fun 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
c9731b9b
AC
312fun 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
321fun 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
5ee41dd0
AC
336fun 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
411a85f2
AC
351fun 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
08a04eb4
AC
366fun 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
094877b1
AC
384fun 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
1824f573
AC
402fun 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
c189cbe9
AC
417fun 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
e69e60cc
AC
432fun 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
d541c618
AC
447fun 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
86aa5de7
AC
462fun 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
90dd48df
AC
477fun 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
1d3ef80e
AC
492fun requestListMailboxes domain =
493 let
494 val (_, bio) = requestBio (fn () => ())
495 in
496 Msg.send (bio, MsgListMailboxes domain);
497 (case Msg.recv bio of
2e96b9d4 498 NONE => Vmail.Error "Server closed connection unexpectedly."
1d3ef80e
AC
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)
2e96b9d4 504 | _ => Vmail.Error "Unexpected server reply.")
1d3ef80e
AC
505 before OpenSSL.close bio
506 end
507
08688401
AC
508fun 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
523fun 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
538fun 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
2e96b9d4
AC
553fun 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
570fun 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
2bc5ed22
AC
586fun 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
75585a67
AC
607fun requestApt {node, pkg} =
608 let
a95a0107
AC
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)
75585a67 614
a95a0107 615 val _ = Msg.send (bio, MsgQuery (QApt pkg))
75585a67
AC
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
71420f8b 636fun regenerate context =
1824f573
AC
637 let
638 val b = basis ()
71420f8b
AC
639 val () = Tycheck.disallowExterns ()
640
641 val () = Domain.resetGlobal ()
642
643 fun contactNode (node, ip) =
644 if node = Config.defaultNode then
645 Domain.resetLocal ()
646 else let
647 val bio = OpenSSL.connect (context,
648 ip
649 ^ ":"
650 ^ Int.toString Config.slavePort)
651 in
652 Msg.send (bio, MsgRegenerate);
653 case Msg.recv bio of
654 NONE => print "Slave closed connection unexpectedly\n"
655 | SOME m =>
656 case m of
657 MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n")
658 | MsgError s => print ("Slave " ^ node
659 ^ " returned error: " ^
660 s ^ "\n")
661 | _ => print ("Slave " ^ node
662 ^ " returned unexpected command\n");
663 OpenSSL.close bio
664 end
1824f573
AC
665
666 fun doUser user =
667 let
668 val _ = Domain.setUser user
669 val _ = ErrorMsg.reset ()
670
671 val dname = Config.domtoolDir user
672
673 val dir = Posix.FileSys.opendir dname
674
675 fun loop files =
676 case Posix.FileSys.readdir dir of
677 NONE => (Posix.FileSys.closedir dir;
678 files)
679 | SOME fname =>
680 if notTmp fname then
681 loop (OS.Path.joinDirFile {dir = dname,
682 file = fname}
683 :: files)
684 else
685 loop files
686
687 val files = loop []
688 val (_, files) = Order.order (SOME b) files
689 in
690 if !ErrorMsg.anyErrors then
691 print ("User " ^ user ^ "'s configuration has errors!\n")
692 else
693 app eval' files
694 end
695 handle IO.Io _ => ()
696 | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
434a7b1f 697 | ErrorMsg.Error => print ("User " ^ user ^ " had a compilation error.\n")
1824f573 698 in
71420f8b 699 app contactNode Config.nodeIps;
1824f573
AC
700 Env.pre ();
701 app doUser (Acl.users ());
702 Env.post ()
703 end
704
e69e60cc
AC
705fun rmuser user =
706 let
707 val doms = Acl.class {user = user, class = "domain"}
708 val doms = List.filter (fn dom =>
709 case Acl.whoHas {class = "domain", value = dom} of
710 [_] => true
711 | _ => false) (StringSet.listItems doms)
712 in
713 Acl.rmuser user;
714 Domain.rmdom doms
715 end
716
c9731b9b
AC
717fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
718
a95a0107
AC
719fun answerQuery q =
720 case q of
721 QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
722
723fun describeQuery q =
724 case q of
725 QApt pkg => "Requested installation status of package " ^ pkg
726
3b267643 727fun service () =
07cc384c 728 let
aa56e112
AC
729 val () = Acl.read Config.aclFile
730
3b267643
AC
731 val context = OpenSSL.context (Config.serverCert,
732 Config.serverKey,
733 Config.trustStore)
36e42cb8 734 val _ = Domain.set_context context
3b267643 735
60534712 736 val sock = OpenSSL.listen (context, Config.dispatcherPort)
3b267643
AC
737
738 fun loop () =
60534712 739 case OpenSSL.accept sock of
3b267643
AC
740 NONE => ()
741 | SOME bio =>
742 let
aa56e112 743 val user = OpenSSL.peerCN bio
c9731b9b 744 val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n")
aa56e112
AC
745 val () = Domain.setUser user
746
08688401
AC
747 fun doIt f cleanup =
748 ((case f () of
749 (msgLocal, SOME msgRemote) =>
750 (print msgLocal;
751 print "\n";
752 Msg.send (bio, MsgError msgRemote))
753 | (msgLocal, NONE) =>
754 (print msgLocal;
755 print "\n";
756 Msg.send (bio, MsgOk)))
757 handle OpenSSL.OpenSSL _ =>
758 print "OpenSSL error\n"
759 | OS.SysErr (s, _) =>
760 (print "System error: ";
761 print s;
762 print "\n";
763 Msg.send (bio, MsgError ("System error: " ^ s))
764 handle OpenSSL.OpenSSL _ => ())
765 | Fail s =>
766 (print "Failure: ";
767 print s;
768 print "\n";
769 Msg.send (bio, MsgError ("Failure: " ^ s))
770 handle OpenSSL.OpenSSL _ => ())
771 | ErrorMsg.Error =>
772 (print "Compilation error\n";
773 Msg.send (bio, MsgError "Error during configuration evaluation")
774 handle OpenSSL.OpenSSL _ => ());
775 (cleanup ();
776 ignore (OpenSSL.readChar bio);
777 OpenSSL.close bio)
778 handle OpenSSL.OpenSSL _ => ();
779 loop ())
780
c53e82e4
AC
781 fun doConfig codes =
782 let
783 val _ = print "Configuration:\n"
784 val _ = app (fn s => (print s; print "\n")) codes
785 val _ = print "\n"
786
787 val outname = OS.FileSys.tmpName ()
788
789 fun doOne code =
790 let
791 val outf = TextIO.openOut outname
792 in
793 TextIO.output (outf, code);
794 TextIO.closeOut outf;
1824f573 795 eval' outname
c53e82e4
AC
796 end
797 in
08688401
AC
798 doIt (fn () => (Env.pre ();
799 app doOne codes;
800 Env.post ();
801 Msg.send (bio, MsgOk);
802 ("Configuration complete.", NONE)))
803 (fn () => OS.FileSys.remove outname)
c53e82e4
AC
804 end
805
2e96b9d4
AC
806 fun checkAddr s =
807 case String.fields (fn ch => ch = #"@") s of
808 [user'] =>
809 if user = user' then
810 SOME (SetSA.User s)
811 else
812 NONE
813 | [user', domain] =>
814 if Domain.validEmailUser user' andalso Domain.yourDomain domain then
815 SOME (SetSA.Email s)
816 else
817 NONE
818 | _ => NONE
819
36e42cb8
AC
820 fun cmdLoop () =
821 case Msg.recv bio of
822 NONE => (OpenSSL.close bio
823 handle OpenSSL.OpenSSL _ => ();
824 loop ())
825 | SOME m =>
826 case m of
c53e82e4
AC
827 MsgConfig code => doConfig [code]
828 | MsgMultiConfig codes => doConfig codes
5ee41dd0 829
9f27d58f 830 | MsgShutdown =>
62260c5f
AC
831 if Acl.query {user = user, class = "priv", value = "all"}
832 orelse Acl.query {user = user, class = "priv", value = "shutdown"} then
c9731b9b 833 print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n")
9f27d58f 834 else
62260c5f
AC
835 (print "Unauthorized shutdown command!\n";
836 OpenSSL.close bio
9f27d58f
AC
837 handle OpenSSL.OpenSSL _ => ();
838 loop ())
839
5ee41dd0 840 | MsgGrant acl =>
08688401
AC
841 doIt (fn () =>
842 if Acl.query {user = user, class = "priv", value = "all"} then
843 (Acl.grant acl;
844 Acl.write Config.aclFile;
845 ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".",
846 NONE))
847 else
848 ("Unauthorized user asked to grant a permission!",
849 SOME "Not authorized to grant privileges"))
850 (fn () => ())
851
411a85f2 852 | MsgRevoke acl =>
08688401
AC
853 doIt (fn () =>
854 if Acl.query {user = user, class = "priv", value = "all"} then
855 (Acl.revoke acl;
856 Acl.write Config.aclFile;
857 ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".",
858 NONE))
859 else
860 ("Unauthorized user asked to revoke a permission!",
861 SOME "Not authorized to revoke privileges"))
862 (fn () => ())
5ee41dd0 863
08a04eb4 864 | MsgListPerms user =>
08688401
AC
865 doIt (fn () =>
866 (Msg.send (bio, MsgPerms (Acl.queryAll user));
867 ("Sent permission list for user " ^ user ^ ".",
868 NONE)))
869 (fn () => ())
08a04eb4 870
094877b1 871 | MsgWhoHas perm =>
08688401
AC
872 doIt (fn () =>
873 (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm));
874 ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".",
875 NONE)))
876 (fn () => ())
094877b1 877
e69e60cc 878 | MsgRmdom doms =>
08688401
AC
879 doIt (fn () =>
880 if Acl.query {user = user, class = "priv", value = "all"}
881 orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then
882 (Domain.rmdom doms;
883 app (fn dom =>
884 Acl.revokeFromAll {class = "domain", value = dom}) doms;
885 Acl.write Config.aclFile;
886 ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".",
887 NONE))
888 else
889 ("Unauthorized user asked to remove a domain!",
890 SOME "Not authorized to remove that domain"))
891 (fn () => ())
1824f573
AC
892
893 | MsgRegenerate =>
08688401
AC
894 doIt (fn () =>
895 if Acl.query {user = user, class = "priv", value = "regen"}
896 orelse Acl.query {user = user, class = "priv", value = "all"} then
897 (regenerate context;
898 ("Regenerated all configuration.",
899 NONE))
900 else
901 ("Unauthorized user asked to regenerate!",
902 SOME "Not authorized to regenerate"))
903 (fn () => ())
e69e60cc 904
05323cbc 905 | MsgRmuser user' =>
08688401
AC
906 doIt (fn () =>
907 if Acl.query {user = user, class = "priv", value = "all"} then
908 (rmuser user';
909 Acl.write Config.aclFile;
910 ("Removed user " ^ user' ^ ".",
911 NONE))
912 else
913 ("Unauthorized user asked to remove a user!",
914 SOME "Not authorized to remove users"))
915 (fn () => ())
d541c618 916
21d921a5 917 | MsgCreateDbUser {dbtype, passwd} =>
08688401
AC
918 doIt (fn () =>
919 case Dbms.lookup dbtype of
920 NONE => ("Database user creation request with unknown datatype type " ^ dbtype,
921 SOME ("Unknown database type " ^ dbtype))
922 | SOME handler =>
923 case #adduser handler {user = user, passwd = passwd} of
924 NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".",
925 NONE)
926 | SOME msg =>
927 ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg,
928 SOME ("Error adding user: " ^ msg)))
929 (fn () => ())
c189cbe9 930
86aa5de7
AC
931 | MsgDbPasswd {dbtype, passwd} =>
932 doIt (fn () =>
933 case Dbms.lookup dbtype of
934 NONE => ("Database passwd request with unknown datatype type " ^ dbtype,
935 SOME ("Unknown database type " ^ dbtype))
936 | SOME handler =>
937 case #passwd handler {user = user, passwd = passwd} of
938 NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".",
939 NONE)
940 | SOME msg =>
941 ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg,
942 SOME ("Error adding user: " ^ msg)))
943 (fn () => ())
944
90dd48df 945 | MsgCreateDbTable {dbtype, dbname} =>
08688401
AC
946 doIt (fn () =>
947 if Dbms.validDbname dbname then
948 case Dbms.lookup dbtype of
949 NONE => ("Database creation request with unknown datatype type " ^ dbtype,
950 SOME ("Unknown database type " ^ dbtype))
951 | SOME handler =>
952 case #createdb handler {user = user, dbname = dbname} of
953 NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".",
954 NONE)
955 | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
956 SOME ("Error creating database: " ^ msg))
957 else
958 ("Invalid database name " ^ user ^ "_" ^ dbname,
959 SOME ("Invalid database name " ^ dbname)))
960 (fn () => ())
961
1d3ef80e
AC
962 | MsgListMailboxes domain =>
963 doIt (fn () =>
964 if not (Domain.yourDomain domain) then
965 ("User wasn't authorized to list mailboxes for " ^ domain,
966 SOME "You're not authorized to configure that domain.")
967 else
968 case Vmail.list domain of
969 Vmail.Listing users => (Msg.send (bio, MsgMailboxes users);
970 ("Sent mailbox list for " ^ domain,
971 NONE))
972 | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg,
973 SOME msg))
974 (fn () => ())
975
08688401
AC
976 | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} =>
977 doIt (fn () =>
978 if not (Domain.yourDomain domain) then
979 ("User wasn't authorized to add a mailbox to " ^ domain,
980 SOME "You're not authorized to configure that domain.")
2e96b9d4 981 else if not (Domain.validEmailUser emailUser) then
08688401
AC
982 ("Invalid e-mail username " ^ emailUser,
983 SOME "Invalid e-mail username")
984 else if not (CharVector.all Char.isGraph passwd) then
985 ("Invalid password",
986 SOME "Invalid password; may only contain printable, non-space characters")
987 else if not (Domain.yourPath mailbox) then
988 ("User wasn't authorized to add a mailbox at " ^ mailbox,
989 SOME "You're not authorized to use that mailbox location.")
990 else
991 case Vmail.add {requester = user,
992 domain = domain, user = emailUser,
993 passwd = passwd, mailbox = mailbox} of
994 NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox,
995 NONE)
9ffe2f0f 996 | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
08688401
AC
997 SOME msg))
998 (fn () => ())
999
1000 | MsgPasswdMailbox {domain, user = emailUser, passwd} =>
1001 doIt (fn () =>
1002 if not (Domain.yourDomain domain) then
1003 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1004 SOME "You're not authorized to configure that domain.")
2e96b9d4 1005 else if not (Domain.validEmailUser emailUser) then
08688401
AC
1006 ("Invalid e-mail username " ^ emailUser,
1007 SOME "Invalid e-mail username")
1008 else if not (CharVector.all Char.isGraph passwd) then
1009 ("Invalid password",
1010 SOME "Invalid password; may only contain printable, non-space characters")
1011 else
1012 case Vmail.passwd {domain = domain, user = emailUser,
1013 passwd = passwd} of
1014 NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain,
1015 NONE)
9ffe2f0f 1016 | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
08688401
AC
1017 SOME msg))
1018 (fn () => ())
1019
1020 | MsgRmMailbox {domain, user = emailUser} =>
1021 doIt (fn () =>
1022 if not (Domain.yourDomain domain) then
1023 ("User wasn't authorized to change password of a mailbox for " ^ domain,
1024 SOME "You're not authorized to configure that domain.")
2e96b9d4 1025 else if not (Domain.validEmailUser emailUser) then
08688401
AC
1026 ("Invalid e-mail username " ^ emailUser,
1027 SOME "Invalid e-mail username")
1028 else
1029 case Vmail.rm {domain = domain, user = emailUser} of
1030 NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain,
1031 NONE)
9ffe2f0f 1032 | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg,
08688401
AC
1033 SOME msg))
1034 (fn () => ())
90dd48df 1035
2e96b9d4
AC
1036 | MsgSaQuery addr =>
1037 doIt (fn () =>
1038 case checkAddr addr of
1039 NONE => ("User tried to query SA filtering for " ^ addr,
1040 SOME "You aren't allowed to configure SA filtering for that recipient.")
1041 | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr'));
1042 ("Queried SA filtering status for " ^ addr,
1043 NONE)))
1044 (fn () => ())
1045
1046 | MsgSaSet (addr, b) =>
1047 doIt (fn () =>
1048 case checkAddr addr of
1049 NONE => ("User tried to set SA filtering for " ^ addr,
1050 SOME "You aren't allowed to configure SA filtering for that recipient.")
1051 | SOME addr' => (SetSA.set (addr', b);
1052 Msg.send (bio, MsgOk);
1053 ("Set SA filtering status for " ^ addr ^ " to "
1054 ^ (if b then "ON" else "OFF"),
1055 NONE)))
1056 (fn () => ())
1057
2bc5ed22
AC
1058 | MsgSmtpLogReq domain =>
1059 doIt (fn () =>
1060 if not (Domain.yourDomain domain) then
1061 ("Unauthorized user tried to request SMTP logs for " ^ domain,
1062 SOME "You aren't authorized to configure that domain.")
1063 else
1064 (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line))
1065 domain;
1066 ("Requested SMTP logs for " ^ domain,
1067 NONE)))
1068 (fn () => ())
1069
a95a0107
AC
1070 | MsgQuery q =>
1071 doIt (fn () => (Msg.send (bio, answerQuery q);
1072 (describeQuery q,
75585a67
AC
1073 NONE)))
1074 (fn () => ())
1075
36e42cb8 1076 | _ =>
08688401
AC
1077 doIt (fn () => ("Unexpected command",
1078 SOME "Unexpected command"))
1079 (fn () => ())
36e42cb8
AC
1080 in
1081 cmdLoop ()
1082 end
97665758
AC
1083 handle OpenSSL.OpenSSL s =>
1084 (print ("OpenSSL error: " ^ s ^ "\n");
1085 OpenSSL.close bio
1086 handle OpenSSL.OpenSSL _ => ();
1087 loop ())
1088 | OS.SysErr (s, _) =>
1089 (print ("System error: " ^ s ^ "\n");
1090 OpenSSL.close bio
1091 handle OpenSSL.OpenSSL _ => ();
1092 loop ())
36e42cb8 1093 in
c9731b9b 1094 print ("Domtool dispatcher starting up at " ^ now () ^ "\n");
361a1e7f 1095 print "Listening for connections....\n";
36e42cb8
AC
1096 loop ();
1097 OpenSSL.shutdown sock
1098 end
1099
1100fun slave () =
1101 let
6e62228d 1102 val host = Slave.hostname ()
36e42cb8
AC
1103
1104 val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
a088cea6 1105 Config.keyDir ^ "/" ^ host ^ "/key.pem",
36e42cb8
AC
1106 Config.trustStore)
1107
1108 val sock = OpenSSL.listen (context, Config.slavePort)
1109
c9731b9b
AC
1110 val _ = print ("Slave server starting at " ^ now () ^ "\n")
1111
36e42cb8
AC
1112 fun loop () =
1113 case OpenSSL.accept sock of
1114 NONE => ()
1115 | SOME bio =>
1116 let
1117 val peer = OpenSSL.peerCN bio
c9731b9b 1118 val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n")
3b267643 1119 in
c9731b9b 1120 if peer = Config.dispatcherName then let
36e42cb8
AC
1121 fun loop' files =
1122 case Msg.recv bio of
1123 NONE => print "Dispatcher closed connection unexpectedly\n"
1124 | SOME m =>
1125 case m of
1126 MsgFile file => loop' (file :: files)
1127 | MsgDoFiles => (Slave.handleChanges files;
1128 Msg.send (bio, MsgOk))
71420f8b
AC
1129 | MsgRegenerate => (Domain.resetLocal ();
1130 Msg.send (bio, MsgOk))
36e42cb8
AC
1131 | _ => (print "Dispatcher sent unexpected command\n";
1132 Msg.send (bio, MsgError "Unexpected command"))
1133 in
1134 loop' [];
1135 ignore (OpenSSL.readChar bio);
1136 OpenSSL.close bio;
1137 loop ()
1138 end
c9731b9b
AC
1139 else if peer = "domtool" then
1140 case Msg.recv bio of
1141 SOME MsgShutdown => (OpenSSL.close bio;
1142 print ("Shutting down at " ^ now () ^ "\n\n"))
1143 | _ => (OpenSSL.close bio;
1144 loop ())
1145 else
a95a0107
AC
1146 case Msg.recv bio of
1147 SOME (MsgQuery q) => (print (describeQuery q ^ "\n");
1148 Msg.send (bio, answerQuery q);
1149 ignore (OpenSSL.readChar bio);
1150 OpenSSL.close bio;
1151 loop ())
1152 | _ => (OpenSSL.close bio;
1153 loop ())
3196000d
AC
1154 end handle OpenSSL.OpenSSL s =>
1155 (print ("OpenSSL error: "^ s ^ "\n");
1156 OpenSSL.close bio
1157 handle OpenSSL.OpenSSL _ => ();
1158 loop ())
7af7d4cb
AC
1159 | OS.SysErr (s, _) =>
1160 (print ("System error: "^ s ^ "\n");
1161 OpenSSL.close bio
1162 handle OpenSSL.OpenSSL _ => ();
1163 loop ())
07cc384c 1164 in
3b267643
AC
1165 loop ();
1166 OpenSSL.shutdown sock
07cc384c
AC
1167 end
1168
44a5ce2f 1169fun listBasis () =
3196000d
AC
1170 let
1171 val dir = Posix.FileSys.opendir Config.libRoot
1172
1173 fun loop files =
1174 case Posix.FileSys.readdir dir of
1175 NONE => (Posix.FileSys.closedir dir;
1176 files)
1177 | SOME fname =>
1178 if String.isSuffix ".dtl" fname then
1179 loop (OS.Path.joinDirFile {dir = Config.libRoot,
1180 file = fname}
1181 :: files)
1182 else
1183 loop files
3196000d 1184 in
44a5ce2f 1185 loop []
3196000d
AC
1186 end
1187
44a5ce2f
AC
1188fun autodocBasis outdir =
1189 Autodoc.autodoc {outdir = outdir, infiles = listBasis ()}
1190
234b917a 1191end